mirror of
https://github.com/msberends/AMR.git
synced 2025-07-09 08:52:15 +02:00
atc and bactid functions, readme update
This commit is contained in:
32
R/abname.R
32
R/abname.R
@ -18,9 +18,9 @@
|
||||
|
||||
#' Name of an antibiotic
|
||||
#'
|
||||
#' Convert antibiotic codes (from a laboratory information system like MOLIS or GLIMS) to a (trivial) antibiotic name or ATC code, or vice versa. This uses the data from \code{\link{antibiotics}}.
|
||||
#' Convert antibiotic codes to a (trivial) antibiotic name or ATC code, or vice versa. This uses the data from \code{\link{antibiotics}}.
|
||||
#' @param abcode a code or name, like \code{"AMOX"}, \code{"AMCL"} or \code{"J01CA04"}
|
||||
#' @param from,to type to transform from and to. See \code{\link{antibiotics}} for its column names. WIth \code{from = "guess"} the from will be guessed from \code{"atc"}, \code{"molis"} and \code{"umcg"}. When using \code{to = "atc"}, the ATC code will be searched using \code{\link{guess_atc}}.
|
||||
#' @param from,to type to transform from and to. See \code{\link{antibiotics}} for its column names. WIth \code{from = "guess"} the from will be guessed from \code{"atc"}, \code{"certe"} and \code{"umcg"}. When using \code{to = "atc"}, the ATC code will be searched using \code{\link{as.atc}}.
|
||||
#' @param textbetween text to put between multiple returned texts
|
||||
#' @param tolower return output as lower case with function \code{\link{tolower}}.
|
||||
#' @keywords ab antibiotics
|
||||
@ -29,7 +29,7 @@
|
||||
#' @importFrom dplyr %>% pull
|
||||
#' @examples
|
||||
#' abname("AMCL")
|
||||
#' # "amoxicillin and enzyme inhibitor"
|
||||
#' # "Amoxicillin and beta-lactamase inhibitor"
|
||||
#'
|
||||
#' # It is quite flexible at default (having `from = "guess"`)
|
||||
#' abname(c("amox", "J01CA04", "Trimox", "dispermox", "Amoxil"))
|
||||
@ -52,8 +52,12 @@
|
||||
#' # specific codes for University Medical Center Groningen (UMCG):
|
||||
#' abname("J01CR02", from = "atc", to = "umcg")
|
||||
#' # "AMCL"
|
||||
#'
|
||||
#' # specific codes for Certe:
|
||||
#' abname("J01CR02", from = "atc", to = "certe")
|
||||
#' # "amcl"
|
||||
abname <- function(abcode,
|
||||
from = c("guess", "atc", "molis", "umcg"),
|
||||
from = c("guess", "atc", "certe", "umcg"),
|
||||
to = 'official',
|
||||
textbetween = ' + ',
|
||||
tolower = FALSE) {
|
||||
@ -63,24 +67,12 @@ abname <- function(abcode,
|
||||
}
|
||||
|
||||
if (to == "atc") {
|
||||
return(guess_atc(abcode))
|
||||
return(as.character(as.atc(abcode)))
|
||||
}
|
||||
|
||||
#antibiotics <- AMR::antibiotics
|
||||
abx <- AMR::antibiotics
|
||||
|
||||
from <- from[1]
|
||||
# if (from == "guess") {
|
||||
# for (i in 1:3) {
|
||||
# if (abcode[1] %in% (antibiotics %>% pull(i))) {
|
||||
# from <- colnames(antibiotics)[i]
|
||||
# }
|
||||
# }
|
||||
# if (from == "guess") {
|
||||
# from <- "umcg"
|
||||
# }
|
||||
# }
|
||||
|
||||
colnames(abx) <- colnames(abx) %>% tolower()
|
||||
from <- from %>% tolower()
|
||||
to <- to %>% tolower()
|
||||
@ -112,9 +104,9 @@ abname <- function(abcode,
|
||||
next
|
||||
}
|
||||
}
|
||||
if (from %in% c("molis", "guess")) {
|
||||
if (abcode[i] %in% abx$molis) {
|
||||
abcode[i] <- abx[which(abx$molis == abcode[i]),] %>% pull(to)
|
||||
if (from %in% c("certe", "guess")) {
|
||||
if (abcode[i] %in% abx$certe) {
|
||||
abcode[i] <- abx[which(abx$certe == abcode[i]),] %>% pull(to)
|
||||
next
|
||||
}
|
||||
}
|
||||
|
||||
263
R/atc.R
263
R/atc.R
@ -16,6 +16,185 @@
|
||||
# GNU General Public License for more details. #
|
||||
# ==================================================================== #
|
||||
|
||||
|
||||
#' Find ATC code based on antibiotic property
|
||||
#'
|
||||
#' Use this function to determine the ATC code of one or more antibiotics. The dataset \code{\link{antibiotics}} will be searched for abbreviations, official names and trade names.
|
||||
#' @param x character vector to determine \code{ATC} code
|
||||
#' @rdname as.atc
|
||||
#' @aliases atc
|
||||
#' @keywords atc
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% filter slice pull
|
||||
#' @details In the ATC classification system, the active substances are classified in a hierarchy with five different levels. The system has fourteen main anatomical/pharmacological groups or 1st levels. Each ATC main group is divided into 2nd levels which could be either pharmacological or therapeutic groups. The 3rd and 4th levels are chemical, pharmacological or therapeutic subgroups and the 5th level is the chemical substance. The 2nd, 3rd and 4th levels are often used to identify pharmacological subgroups when that is considered more appropriate than therapeutic or chemical subgroups.
|
||||
#' Source: \url{https://www.whocc.no/atc/structure_and_principles/}
|
||||
#' @return Character (vector) with class \code{"act"}. Unknown values will return \code{NA}.
|
||||
#' @seealso \code{\link{antibiotics}} for the dataframe that is being used to determine ATC's.
|
||||
#' @examples
|
||||
#' # These examples all return "J01FA01", the ATC code of Erythromycin:
|
||||
#' as.atc("J01FA01")
|
||||
#' as.atc("Erythromycin")
|
||||
#' as.atc("eryt")
|
||||
#' as.atc("ERYT")
|
||||
#' as.atc("ERY")
|
||||
#' as.atc("Erythrocin") # Trade name
|
||||
#' as.atc("Eryzole") # Trade name
|
||||
#' as.atc("Pediamycin") # Trade name
|
||||
as.atc <- function(x) {
|
||||
|
||||
x.new <- rep(NA_character_, length(x))
|
||||
x.bak <- x
|
||||
x <- unique(x[!is.na(x)])
|
||||
failures <- character(0)
|
||||
|
||||
for (i in 1:length(x)) {
|
||||
fail <- TRUE
|
||||
|
||||
# first try atc
|
||||
found <- AMR::antibiotics[which(AMR::antibiotics$atc == x[i]),]$atc
|
||||
if (length(found) > 0) {
|
||||
fail <- FALSE
|
||||
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
|
||||
}
|
||||
|
||||
# try abbreviation of certe and glims
|
||||
found <- AMR::antibiotics[which(tolower(AMR::antibiotics$certe) == tolower(x[i])),]$atc
|
||||
if (length(found) > 0) {
|
||||
fail <- FALSE
|
||||
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
|
||||
}
|
||||
found <- AMR::antibiotics[which(tolower(AMR::antibiotics$umcg) == tolower(x[i])),]$atc
|
||||
if (length(found) > 0) {
|
||||
fail <- FALSE
|
||||
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
|
||||
}
|
||||
|
||||
# try exact official name
|
||||
found <- AMR::antibiotics[which(tolower(AMR::antibiotics$official) == tolower(x[i])),]$atc
|
||||
if (length(found) > 0) {
|
||||
fail <- FALSE
|
||||
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
|
||||
}
|
||||
|
||||
# try trade name
|
||||
found <- AMR::antibiotics[which(paste0("(", AMR::antibiotics$trade_name, ")") %like% x[i]),]$atc
|
||||
if (length(found) > 0) {
|
||||
fail <- FALSE
|
||||
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
|
||||
}
|
||||
|
||||
# try abbreviation
|
||||
found <- AMR::antibiotics[which(paste0("(", AMR::antibiotics$abbr, ")") %like% x[i]),]$atc
|
||||
if (length(found) > 0) {
|
||||
fail <- FALSE
|
||||
x.new[is.na(x.new) & x.bak == x[i]] <- found[1L]
|
||||
}
|
||||
|
||||
# not found
|
||||
if (fail == TRUE) {
|
||||
failures <- c(failures, x[i])
|
||||
}
|
||||
}
|
||||
|
||||
failures <- failures[!failures %in% c(NA, NULL, NaN)]
|
||||
if (length(failures) > 0) {
|
||||
warning("These values could not be coerced to a valid atc: ",
|
||||
paste('"', unique(failures), '"', sep = "", collapse = ', '),
|
||||
".",
|
||||
call. = FALSE)
|
||||
}
|
||||
class(x.new) <- "atc"
|
||||
attr(x.new, 'package') <- 'AMR'
|
||||
x.new
|
||||
}
|
||||
|
||||
#' @rdname as.atc
|
||||
#' @export
|
||||
guess_atc <- as.atc
|
||||
|
||||
#' @rdname as.atc
|
||||
#' @export
|
||||
is.atc <- function(x) {
|
||||
identical(class(x), "atc")
|
||||
}
|
||||
|
||||
|
||||
#' @exportMethod print.atc
|
||||
#' @export
|
||||
#' @noRd
|
||||
print.atc <- function(x, ...) {
|
||||
cat("Class 'atc'\n")
|
||||
print.default(as.character(x), quote = FALSE)
|
||||
}
|
||||
|
||||
#' @exportMethod as.data.frame.atc
|
||||
#' @export
|
||||
#' @noRd
|
||||
as.data.frame.atc <- function (x, ...) {
|
||||
# same as as.data.frame.character but with removed stringsAsFactors
|
||||
nm <- paste(deparse(substitute(x), width.cutoff = 500L),
|
||||
collapse = " ")
|
||||
if (!"nm" %in% names(list(...))) {
|
||||
as.data.frame.vector(x, ..., nm = nm)
|
||||
} else {
|
||||
as.data.frame.vector(x, ...)
|
||||
}
|
||||
}
|
||||
|
||||
#' @exportMethod pull.atc
|
||||
#' @export
|
||||
#' @importFrom dplyr pull
|
||||
#' @noRd
|
||||
pull.atc <- function(.data, ...) {
|
||||
pull(as.data.frame(.data), ...)
|
||||
}
|
||||
|
||||
atc_get_property <- function(atc, param) {
|
||||
if (!is.atc(atc)) {
|
||||
atc <- as.atc(atc)
|
||||
}
|
||||
suppressWarnings(
|
||||
data.frame(atc = atc, stringsAsFactors = FALSE) %>%
|
||||
left_join(AMR::antibiotics, by = "atc") %>%
|
||||
pull(param)
|
||||
)
|
||||
}
|
||||
|
||||
#' Get antibiotic property based on ATC
|
||||
#'
|
||||
#' Use these functions to return a specific property of an antibiotic from the \code{\link{antibiotics}} data set, based on their ATC code.
|
||||
#' @param atc a valid ATC code, created with \code{\link{as.atc}}
|
||||
#' @rdname atc.property
|
||||
#' @name atc.property
|
||||
#' @export
|
||||
atc.official <- function(atc) {
|
||||
atc_get_property(atc, "official")
|
||||
}
|
||||
|
||||
#' @rdname atc.property
|
||||
#' @export
|
||||
atc.official_nl <- function(atc) {
|
||||
atc_get_property(atc, "official_nl")
|
||||
}
|
||||
|
||||
#' @rdname atc.property
|
||||
#' @export
|
||||
atc.trivial_nl <- function(atc) {
|
||||
atc_get_property(atc, "trivial_nl")
|
||||
}
|
||||
|
||||
#' @rdname atc.property
|
||||
#' @export
|
||||
atc.certe <- function(atc) {
|
||||
atc_get_property(atc, "certe")
|
||||
}
|
||||
|
||||
#' @rdname atc.property
|
||||
#' @export
|
||||
atc.umcg <- function(atc) {
|
||||
atc_get_property(atc, "umcg")
|
||||
}
|
||||
|
||||
#' Properties of an ATC code
|
||||
#'
|
||||
#' Gets data from the WHO to determine properties of an ATC (e.g. an antibiotic) like name, defined daily dose (DDD) or standard unit. \cr \strong{This function requires an internet connection.}
|
||||
@ -203,87 +382,3 @@ atc_ddd <- function(atc_code, ...) {
|
||||
atc_property(atc_code = atc_code, property = "ddd", ...)
|
||||
}
|
||||
|
||||
|
||||
#' Find ATC code based on antibiotic property
|
||||
#'
|
||||
#' Use this function to determine the ATC code of one or more antibiotics. The dataset \code{\link{antibiotics}} will be searched for abbreviations, official names and trade names.
|
||||
#' @param x character vector to determine \code{ATC} code
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% filter slice pull
|
||||
#' @details In the ATC classification system, the active substances are classified in a hierarchy with five different levels. The system has fourteen main anatomical/pharmacological groups or 1st levels. Each ATC main group is divided into 2nd levels which could be either pharmacological or therapeutic groups. The 3rd and 4th levels are chemical, pharmacological or therapeutic subgroups and the 5th level is the chemical substance. The 2nd, 3rd and 4th levels are often used to identify pharmacological subgroups when that is considered more appropriate than therapeutic or chemical subgroups.
|
||||
#' Source: \url{https://www.whocc.no/atc/structure_and_principles/}
|
||||
#' @return Character (vector).
|
||||
#' @seealso \code{\link{antibiotics}} for the dataframe that is being used to determine ATC's.
|
||||
#' @examples
|
||||
#' # These examples all return "J01FA01", the ATC code of Erythromycin:
|
||||
#' guess_atc("J01FA01")
|
||||
#' guess_atc("Erythromycin")
|
||||
#' guess_atc("eryt")
|
||||
#' guess_atc("ERYT")
|
||||
#' guess_atc("ERY")
|
||||
#' guess_atc("Erythrocin") # Trade name
|
||||
#' guess_atc("Eryzole") # Trade name
|
||||
#' guess_atc("Pediamycin") # Trade name
|
||||
guess_atc <- function(x) {
|
||||
|
||||
# use this later to further fill AMR::antibiotics
|
||||
|
||||
# drug <- "Ciprofloxacin"
|
||||
# url <- xml2::read_html(paste0("https://www.ncbi.nlm.nih.gov/pccompound?term=", drug)) %>%
|
||||
# html_nodes(".rslt") %>%
|
||||
# .[[1]] %>%
|
||||
# html_nodes(".title a") %>%
|
||||
# html_attr("href") %>%
|
||||
# gsub("/compound/", "/rest/pug_view/data/compound/", ., fixed = TRUE) %>%
|
||||
# paste0("/XML/?response_type=display")
|
||||
# synonyms <- url %>%
|
||||
# read_xml() %>%
|
||||
# xml_contents() %>% .[[6]] %>%
|
||||
# xml_contents() %>% .[[8]] %>%
|
||||
# xml_contents() %>% .[[3]] %>%
|
||||
# xml_contents() %>% .[[3]] %>%
|
||||
# xml_contents() %>%
|
||||
# paste() %>%
|
||||
# .[. %like% "StringValueList"] %>%
|
||||
# gsub("[</]+StringValueList[>]", "", .)
|
||||
|
||||
|
||||
for (i in 1:length(x)) {
|
||||
|
||||
# first try atc
|
||||
found <- AMR::antibiotics %>% filter(atc == x[i])
|
||||
|
||||
if (nrow(found) == 0) {
|
||||
# try abbreviation of molis and glims
|
||||
found <- AMR::antibiotics %>% filter(tolower(molis) == tolower(x[i]) | tolower(umcg) == tolower(x[i]))
|
||||
}
|
||||
|
||||
if (nrow(found) == 0) {
|
||||
# try exact official name
|
||||
found <- AMR::antibiotics[which(tolower(AMR::antibiotics$official) == tolower(x[i])),]
|
||||
}
|
||||
|
||||
if (nrow(found) == 0) {
|
||||
# try trade name
|
||||
found <- AMR::antibiotics[which(paste0("(", AMR::antibiotics$trade_name, ")") %like% x[i]),]
|
||||
}
|
||||
|
||||
if (nrow(found) == 0) {
|
||||
# try abbreviation
|
||||
found <- AMR::antibiotics[which(paste0("(", AMR::antibiotics$abbr, ")") %like% x[i]),]
|
||||
}
|
||||
# if (nrow(found) == 0) {
|
||||
# # loosely try official name
|
||||
# found <- AMR::antibiotics[which(AMR::antibiotics$official %like% x[i]),]
|
||||
# }
|
||||
|
||||
if (nrow(found) != 0) {
|
||||
x[i] <- found %>%
|
||||
slice(1) %>%
|
||||
pull(atc)
|
||||
} else {
|
||||
x[i] <- NA
|
||||
}
|
||||
}
|
||||
x
|
||||
}
|
||||
|
||||
76
R/bactid.R
76
R/bactid.R
@ -380,3 +380,79 @@ as.data.frame.bactid <- function (x, ...) {
|
||||
pull.bactid <- function(.data, ...) {
|
||||
pull(as.data.frame(.data), ...)
|
||||
}
|
||||
|
||||
bactid_get_property <- function(bactid, param) {
|
||||
if (!is.bactid(bactid)) {
|
||||
bactid <- as.bactid(bactid)
|
||||
}
|
||||
suppressWarnings(
|
||||
data.frame(bactid = bactid, stringsAsFactors = FALSE) %>%
|
||||
left_join(AMR::microorganisms, by = "bactid") %>%
|
||||
pull(param)
|
||||
)
|
||||
}
|
||||
|
||||
#' Get microbial property based on `bactid`
|
||||
#'
|
||||
#' Use these functions to return a specific property of a microorganism from the \code{\link{microorganisms}} data set, based on their \code{bactid}. Get such an ID with \code{\link{as.bactid}}.
|
||||
#' @param bactid a valid bactid code, created with \code{\link{as.bactid}}
|
||||
#' @rdname bactid.property
|
||||
#' @name bactid.property
|
||||
#' @export
|
||||
bactid.family <- function(bactid) {
|
||||
bactid_get_property(bactid, "family")
|
||||
}
|
||||
|
||||
#' @rdname bactid.property
|
||||
#' @export
|
||||
bactid.genus <- function(bactid) {
|
||||
bactid_get_property(bactid, "genus")
|
||||
}
|
||||
|
||||
#' @rdname bactid.property
|
||||
#' @export
|
||||
bactid.species <- function(bactid) {
|
||||
bactid_get_property(bactid, "species")
|
||||
}
|
||||
|
||||
#' @rdname bactid.property
|
||||
#' @export
|
||||
bactid.subspecies <- function(bactid) {
|
||||
bactid_get_property(bactid, "subspecies")
|
||||
}
|
||||
|
||||
#' @rdname bactid.property
|
||||
#' @export
|
||||
bactid.fullname <- function(bactid) {
|
||||
bactid_get_property(bactid, "fullname")
|
||||
}
|
||||
|
||||
#' @rdname bactid.property
|
||||
#' @export
|
||||
bactid.type <- function(bactid) {
|
||||
bactid_get_property(bactid, "type")
|
||||
}
|
||||
|
||||
#' @rdname bactid.property
|
||||
#' @export
|
||||
bactid.gramstain <- function(bactid) {
|
||||
bactid_get_property(bactid, "gramstain")
|
||||
}
|
||||
|
||||
#' @rdname bactid.property
|
||||
#' @export
|
||||
bactid.aerobic <- function(bactid) {
|
||||
bactid_get_property(bactid, "aerobic")
|
||||
}
|
||||
|
||||
#' @rdname bactid.property
|
||||
#' @export
|
||||
bactid.type_nl <- function(bactid) {
|
||||
bactid_get_property(bactid, "type_nl")
|
||||
}
|
||||
|
||||
#' @rdname bactid.property
|
||||
#' @export
|
||||
bactid.gramstain_nl <- function(bactid) {
|
||||
bactid_get_property(bactid, "gramstain_nl")
|
||||
}
|
||||
|
||||
21
R/data.R
21
R/data.R
@ -22,7 +22,7 @@
|
||||
#' @format A data.frame with 420 observations and 18 variables:
|
||||
#' \describe{
|
||||
#' \item{\code{atc}}{ATC code, like \code{J01CR02}}
|
||||
#' \item{\code{molis}}{MOLIS code, like \code{amcl}}
|
||||
#' \item{\code{certe}}{Certe code, like \code{amcl}}
|
||||
#' \item{\code{umcg}}{UMCG code, like \code{AMCL}}
|
||||
#' \item{\code{abbr}}{Abbreviation as used by many countries, to be used for \code{\link{guess_atc}}}
|
||||
#' \item{\code{official}}{Official name by the WHO, like \code{"Amoxicillin and enzyme inhibitor"}}
|
||||
@ -42,6 +42,25 @@
|
||||
#' }
|
||||
#' @source - World Health Organization: \url{https://www.whocc.no/atc_ddd_index/} \cr - EUCAST - Expert rules intrinsic exceptional V3.1 \cr - MOLIS (LIS of Certe): \url{https://www.certe.nl} \cr - GLIMS (LIS of UMCG): \url{https://www.umcg.nl}
|
||||
#' @seealso \code{\link{microorganisms}}
|
||||
# use this later to further fill AMR::antibiotics
|
||||
# drug <- "Ciprofloxacin"
|
||||
# url <- xml2::read_html(paste0("https://www.ncbi.nlm.nih.gov/pccompound?term=", drug)) %>%
|
||||
# html_nodes(".rslt") %>%
|
||||
# .[[1]] %>%
|
||||
# html_nodes(".title a") %>%
|
||||
# html_attr("href") %>%
|
||||
# gsub("/compound/", "/rest/pug_view/data/compound/", ., fixed = TRUE) %>%
|
||||
# paste0("/XML/?response_type=display")
|
||||
# synonyms <- url %>%
|
||||
# read_xml() %>%
|
||||
# xml_contents() %>% .[[6]] %>%
|
||||
# xml_contents() %>% .[[8]] %>%
|
||||
# xml_contents() %>% .[[3]] %>%
|
||||
# xml_contents() %>% .[[3]] %>%
|
||||
# xml_contents() %>%
|
||||
# paste() %>%
|
||||
# .[. %like% "StringValueList"] %>%
|
||||
# gsub("[</]+StringValueList[>]", "", .)
|
||||
# abbr and trade_name created with:
|
||||
# https://hs.unr.edu/Documents/dhs/chs/NVPHTC/antibiotic_refeference_guide.pdf
|
||||
# antibiotics %>%
|
||||
|
||||
35
R/eucast.R
35
R/eucast.R
@ -695,38 +695,3 @@ EUCAST_rules <- function(tbl,
|
||||
interpretive_reading <- function(...) {
|
||||
EUCAST_rules(...)
|
||||
}
|
||||
|
||||
#' Poperties of a microorganism
|
||||
#'
|
||||
#' @param bactid ID of a microorganisme, like \code{"STAAUR} and \code{"ESCCOL}
|
||||
#' @param property One of the values \code{bactid}, \code{bactsys}, \code{family}, \code{genus}, \code{species}, \code{subspecies}, \code{fullname}, \code{type}, \code{gramstain}, \code{aerobic}
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% filter select
|
||||
#' @seealso \code{\link{microorganisms}}
|
||||
mo_property <- function(bactid, property = 'fullname') {
|
||||
|
||||
mocode <- as.character(bactid)
|
||||
|
||||
for (i in 1:length(mocode)) {
|
||||
bug <- mocode[i]
|
||||
|
||||
if (!is.na(bug)) {
|
||||
result = tryCatch({
|
||||
mocode[i] <-
|
||||
AMR::microorganisms %>%
|
||||
filter(bactid == bug) %>%
|
||||
select(property) %>%
|
||||
unlist() %>%
|
||||
as.character()
|
||||
}, error = function(error_condition) {
|
||||
warning('Code ', bug, ' not found in bacteria list.')
|
||||
}, finally = {
|
||||
if (mocode[i] == bug & !property %in% c('bactid', 'bactsys')) {
|
||||
mocode[i] <- NA
|
||||
}
|
||||
})
|
||||
}
|
||||
|
||||
}
|
||||
mocode
|
||||
}
|
||||
|
||||
@ -30,6 +30,7 @@ globalVariables(c('abname',
|
||||
'atc',
|
||||
'bactid',
|
||||
'C_chisq_sim',
|
||||
'certe',
|
||||
'cnt',
|
||||
'count',
|
||||
'Count',
|
||||
@ -54,7 +55,6 @@ globalVariables(c('abname',
|
||||
'MIC',
|
||||
'microorganisms',
|
||||
'mocode',
|
||||
'molis',
|
||||
'n',
|
||||
'na.omit',
|
||||
'observations',
|
||||
|
||||
@ -16,186 +16,6 @@
|
||||
# GNU General Public License for more details. #
|
||||
# ==================================================================== #
|
||||
|
||||
#' Class 'rsi'
|
||||
#'
|
||||
#' This transforms a vector to a new class \code{rsi}, which is an ordered factor with levels \code{S < I < R}. Invalid antimicrobial interpretations will be translated as \code{NA} with a warning.
|
||||
#' @rdname as.rsi
|
||||
#' @param x vector
|
||||
#' @details The function \code{is.rsi.eligible} returns \code{TRUE} when a columns contains only valid antimicrobial interpretations (S and/or I and/or R), and \code{FALSE} otherwise.
|
||||
#' @return Ordered factor with new class \code{rsi} and new attribute \code{package}
|
||||
#' @keywords rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>%
|
||||
#' @seealso \code{\link{as.mic}}
|
||||
#' @examples
|
||||
#' rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370)))
|
||||
#' rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370), "A", "B", "C"))
|
||||
#' is.rsi(rsi_data)
|
||||
#'
|
||||
#' # this can also coerce combined MIC/RSI values:
|
||||
#' as.rsi("<= 0.002; S") # will return S
|
||||
#'
|
||||
#' plot(rsi_data) # for percentages
|
||||
#' barplot(rsi_data) # for frequencies
|
||||
#' freq(rsi_data) # frequency table with informative header
|
||||
#'
|
||||
#' # fastest way to transform all columns with already valid AB results to class `rsi`:
|
||||
#' library(dplyr)
|
||||
#' septic_patients %>%
|
||||
#' mutate_if(is.rsi.eligible,
|
||||
#' as.rsi)
|
||||
as.rsi <- function(x) {
|
||||
if (is.rsi(x)) {
|
||||
x
|
||||
} else {
|
||||
|
||||
x <- x %>% unlist()
|
||||
x.bak <- x
|
||||
|
||||
na_before <- x[is.na(x) | x == ''] %>% length()
|
||||
# remove all spaces
|
||||
x <- gsub(' +', '', x)
|
||||
# remove all MIC-like values: numbers, operators and periods
|
||||
x <- gsub('[0-9.,;:<=>]+', '', x)
|
||||
# disallow more than 3 characters
|
||||
x[nchar(x) > 3] <- NA
|
||||
# set to capitals
|
||||
x <- toupper(x)
|
||||
# remove all invalid characters
|
||||
x <- gsub('[^RSI]+', '', x)
|
||||
# in cases of "S;S" keep S, but in case of "S;I" make it NA
|
||||
x <- gsub('^S+$', 'S', x)
|
||||
x <- gsub('^I+$', 'I', x)
|
||||
x <- gsub('^R+$', 'R', x)
|
||||
x[!x %in% c('S', 'I', 'R')] <- NA
|
||||
na_after <- x[is.na(x) | x == ''] %>% length()
|
||||
|
||||
if (na_before != na_after) {
|
||||
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>%
|
||||
unique() %>%
|
||||
sort()
|
||||
list_missing <- paste0('"', list_missing , '"', collapse = ", ")
|
||||
warning(na_after - na_before, ' results truncated (',
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
'%) that were invalid antimicrobial interpretations: ',
|
||||
list_missing, call. = FALSE)
|
||||
}
|
||||
|
||||
x <- x %>% factor(levels = c("S", "I", "R"), ordered = TRUE)
|
||||
class(x) <- c('rsi', 'ordered', 'factor')
|
||||
attr(x, 'package') <- 'AMR'
|
||||
x
|
||||
}
|
||||
}
|
||||
|
||||
#' @rdname as.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>%
|
||||
is.rsi <- function(x) {
|
||||
class(x) %>% identical(c('rsi', 'ordered', 'factor'))
|
||||
}
|
||||
|
||||
#' @rdname as.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>%
|
||||
is.rsi.eligible <- function(x) {
|
||||
distinct_val <- x %>% unique() %>% sort() %>% as.character()
|
||||
distinct_val <- distinct_val[!is.na(distinct_val) & trimws(distinct_val) != ""]
|
||||
distinct_val_rsi <- as.character(suppressWarnings(as.rsi(distinct_val)))
|
||||
|
||||
length(distinct_val) > 0 &
|
||||
identical(distinct_val, distinct_val_rsi)
|
||||
}
|
||||
|
||||
#' @exportMethod print.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>%
|
||||
#' @noRd
|
||||
print.rsi <- function(x, ...) {
|
||||
cat("Class 'rsi'\n")
|
||||
print(as.character(x), quote = FALSE)
|
||||
}
|
||||
|
||||
#' @exportMethod summary.rsi
|
||||
#' @export
|
||||
#' @noRd
|
||||
summary.rsi <- function(object, ...) {
|
||||
x <- object
|
||||
c(
|
||||
"Mode" = 'rsi',
|
||||
"<NA>" = sum(is.na(x)),
|
||||
"Sum S" = sum(x == "S", na.rm = TRUE),
|
||||
"Sum IR" = sum(x %in% c("I", "R"), na.rm = TRUE),
|
||||
"-Sum R" = sum(x == "R", na.rm = TRUE),
|
||||
"-Sum I" = sum(x == "I", na.rm = TRUE)
|
||||
)
|
||||
}
|
||||
|
||||
#' @exportMethod plot.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% group_by summarise filter mutate if_else n_distinct
|
||||
#' @importFrom graphics plot text
|
||||
#' @noRd
|
||||
plot.rsi <- function(x, ...) {
|
||||
x_name <- deparse(substitute(x))
|
||||
|
||||
data <- data.frame(x = x,
|
||||
y = 1,
|
||||
stringsAsFactors = TRUE) %>%
|
||||
group_by(x) %>%
|
||||
summarise(n = sum(y)) %>%
|
||||
filter(!is.na(x)) %>%
|
||||
mutate(s = round((n / sum(n)) * 100, 1))
|
||||
data$x <- factor(data$x, levels = c('S', 'I', 'R'), ordered = TRUE)
|
||||
|
||||
ymax <- if_else(max(data$s) > 95, 105, 100)
|
||||
|
||||
plot(x = data$x,
|
||||
y = data$s,
|
||||
lwd = 2,
|
||||
col = c('green', 'orange', 'red'),
|
||||
ylim = c(0, ymax),
|
||||
ylab = 'Percentage',
|
||||
xlab = 'Antimicrobial Interpretation',
|
||||
main = paste('Susceptibility Analysis of', x_name),
|
||||
axes = FALSE,
|
||||
...)
|
||||
# x axis
|
||||
axis(side = 1, at = 1:n_distinct(data$x), labels = levels(data$x), lwd = 0)
|
||||
# y axis, 0-100%
|
||||
axis(side = 2, at = seq(0, 100, 5))
|
||||
|
||||
text(x = data$x,
|
||||
y = data$s + 4,
|
||||
labels = paste0(data$s, '% (n = ', data$n, ')'))
|
||||
}
|
||||
|
||||
|
||||
#' @exportMethod barplot.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% group_by summarise filter mutate if_else n_distinct
|
||||
#' @importFrom graphics barplot axis
|
||||
#' @noRd
|
||||
barplot.rsi <- function(height, ...) {
|
||||
x <- height
|
||||
x_name <- deparse(substitute(height))
|
||||
|
||||
data <- data.frame(rsi = x, cnt = 1) %>%
|
||||
group_by(rsi) %>%
|
||||
summarise(cnt = sum(cnt)) %>%
|
||||
droplevels()
|
||||
|
||||
barplot(table(x),
|
||||
col = c('green3', 'orange2', 'red3'),
|
||||
xlab = 'Antimicrobial Interpretation',
|
||||
main = paste('Susceptibility Analysis of', x_name),
|
||||
ylab = 'Frequency',
|
||||
axes = FALSE,
|
||||
...)
|
||||
# y axis, 0-100%
|
||||
axis(side = 2, at = seq(0, max(data$cnt) + max(data$cnt) * 1.1, by = 25))
|
||||
}
|
||||
|
||||
#' Class 'mic'
|
||||
#'
|
||||
#' This transforms a vector to a new class \code{mic}, which is an ordered factor with valid MIC values as levels. Invalid MIC values will be translated as \code{NA} with a warning.
|
||||
45
R/portion.R
45
R/portion.R
@ -251,3 +251,48 @@ portion_df <- function(data,
|
||||
|
||||
res
|
||||
}
|
||||
|
||||
|
||||
#' Calculate resistance of isolates
|
||||
#'
|
||||
#' This function is deprecated. Use the \code{\link{portion}} functions instead.
|
||||
#' @inheritParams portion
|
||||
#' @param ab1,ab2 vector (or column) with antibiotic interpretations. It will be transformed internally with \code{\link{as.rsi}} if needed.
|
||||
#' @param interpretation antimicrobial interpretation to check for
|
||||
#' @param ... deprecated parameters to support usage on older versions
|
||||
#' @importFrom dplyr tibble case_when
|
||||
#' @export
|
||||
rsi <- function(ab1,
|
||||
ab2 = NULL,
|
||||
interpretation = "IR",
|
||||
minimum = 30,
|
||||
as_percent = FALSE,
|
||||
...) {
|
||||
|
||||
if (all(is.null(ab2))) {
|
||||
df <- tibble(ab1 = ab1)
|
||||
} else {
|
||||
df <- tibble(ab1 = ab1,
|
||||
ab2 = ab2)
|
||||
}
|
||||
|
||||
result <- case_when(
|
||||
interpretation == "S" ~ portion_S(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation %in% c("SI", "IS") ~ portion_SI(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation == "I" ~ portion_I(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation %in% c("RI", "IR") ~ portion_IR(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation == "R" ~ portion_R(df, minimum = minimum, as_percent = FALSE),
|
||||
TRUE ~ -1
|
||||
)
|
||||
if (result == -1) {
|
||||
stop("invalid interpretation")
|
||||
}
|
||||
|
||||
.Deprecated(new = paste0("portion_", interpretation))
|
||||
|
||||
if (as_percent == TRUE) {
|
||||
percent(result, force_zero = TRUE)
|
||||
} else {
|
||||
result
|
||||
}
|
||||
}
|
||||
|
||||
206
R/rsi.R
206
R/rsi.R
@ -16,46 +16,182 @@
|
||||
# GNU General Public License for more details. #
|
||||
# ==================================================================== #
|
||||
|
||||
#' Calculate resistance of isolates
|
||||
#' Class 'rsi'
|
||||
#'
|
||||
#' This function is deprecated. Use the \code{\link{portion}} functions instead.
|
||||
#' @inheritParams portion
|
||||
#' @param ab1,ab2 vector (or column) with antibiotic interpretations. It will be transformed internally with \code{\link{as.rsi}} if needed.
|
||||
#' @param interpretation antimicrobial interpretation to check for
|
||||
#' @param ... deprecated parameters to support usage on older versions
|
||||
#' @importFrom dplyr tibble case_when
|
||||
#' This transforms a vector to a new class \code{rsi}, which is an ordered factor with levels \code{S < I < R}. Invalid antimicrobial interpretations will be translated as \code{NA} with a warning.
|
||||
#' @rdname as.rsi
|
||||
#' @param x vector
|
||||
#' @details The function \code{is.rsi.eligible} returns \code{TRUE} when a columns contains only valid antimicrobial interpretations (S and/or I and/or R), and \code{FALSE} otherwise.
|
||||
#' @return Ordered factor with new class \code{rsi} and new attribute \code{package}
|
||||
#' @keywords rsi
|
||||
#' @export
|
||||
rsi <- function(ab1,
|
||||
ab2 = NULL,
|
||||
interpretation = "IR",
|
||||
minimum = 30,
|
||||
as_percent = FALSE,
|
||||
...) {
|
||||
|
||||
if (all(is.null(ab2))) {
|
||||
df <- tibble(ab1 = ab1)
|
||||
#' @importFrom dplyr %>%
|
||||
#' @seealso \code{\link{as.mic}}
|
||||
#' @examples
|
||||
#' rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370)))
|
||||
#' rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370), "A", "B", "C"))
|
||||
#' is.rsi(rsi_data)
|
||||
#'
|
||||
#' # this can also coerce combined MIC/RSI values:
|
||||
#' as.rsi("<= 0.002; S") # will return S
|
||||
#'
|
||||
#' plot(rsi_data) # for percentages
|
||||
#' barplot(rsi_data) # for frequencies
|
||||
#' freq(rsi_data) # frequency table with informative header
|
||||
#'
|
||||
#' # fastest way to transform all columns with already valid AB results to class `rsi`:
|
||||
#' library(dplyr)
|
||||
#' septic_patients %>%
|
||||
#' mutate_if(is.rsi.eligible,
|
||||
#' as.rsi)
|
||||
as.rsi <- function(x) {
|
||||
if (is.rsi(x)) {
|
||||
x
|
||||
} else {
|
||||
df <- tibble(ab1 = ab1,
|
||||
ab2 = ab2)
|
||||
}
|
||||
|
||||
result <- case_when(
|
||||
interpretation == "S" ~ portion_S(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation %in% c("SI", "IS") ~ portion_SI(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation == "I" ~ portion_I(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation %in% c("RI", "IR") ~ portion_IR(df, minimum = minimum, as_percent = FALSE),
|
||||
interpretation == "R" ~ portion_R(df, minimum = minimum, as_percent = FALSE),
|
||||
TRUE ~ -1
|
||||
)
|
||||
if (result == -1) {
|
||||
stop("invalid interpretation")
|
||||
}
|
||||
x <- x %>% unlist()
|
||||
x.bak <- x
|
||||
|
||||
.Deprecated(new = paste0("portion_", interpretation))
|
||||
na_before <- x[is.na(x) | x == ''] %>% length()
|
||||
# remove all spaces
|
||||
x <- gsub(' +', '', x)
|
||||
# remove all MIC-like values: numbers, operators and periods
|
||||
x <- gsub('[0-9.,;:<=>]+', '', x)
|
||||
# disallow more than 3 characters
|
||||
x[nchar(x) > 3] <- NA
|
||||
# set to capitals
|
||||
x <- toupper(x)
|
||||
# remove all invalid characters
|
||||
x <- gsub('[^RSI]+', '', x)
|
||||
# in cases of "S;S" keep S, but in case of "S;I" make it NA
|
||||
x <- gsub('^S+$', 'S', x)
|
||||
x <- gsub('^I+$', 'I', x)
|
||||
x <- gsub('^R+$', 'R', x)
|
||||
x[!x %in% c('S', 'I', 'R')] <- NA
|
||||
na_after <- x[is.na(x) | x == ''] %>% length()
|
||||
|
||||
if (as_percent == TRUE) {
|
||||
percent(result, force_zero = TRUE)
|
||||
} else {
|
||||
result
|
||||
if (na_before != na_after) {
|
||||
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ''] %>%
|
||||
unique() %>%
|
||||
sort()
|
||||
list_missing <- paste0('"', list_missing , '"', collapse = ", ")
|
||||
warning(na_after - na_before, ' results truncated (',
|
||||
round(((na_after - na_before) / length(x)) * 100),
|
||||
'%) that were invalid antimicrobial interpretations: ',
|
||||
list_missing, call. = FALSE)
|
||||
}
|
||||
|
||||
x <- x %>% factor(levels = c("S", "I", "R"), ordered = TRUE)
|
||||
class(x) <- c('rsi', 'ordered', 'factor')
|
||||
attr(x, 'package') <- 'AMR'
|
||||
x
|
||||
}
|
||||
}
|
||||
|
||||
#' @rdname as.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>%
|
||||
is.rsi <- function(x) {
|
||||
class(x) %>% identical(c('rsi', 'ordered', 'factor'))
|
||||
}
|
||||
|
||||
#' @rdname as.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>%
|
||||
is.rsi.eligible <- function(x) {
|
||||
distinct_val <- x %>% unique() %>% sort() %>% as.character()
|
||||
distinct_val <- distinct_val[!is.na(distinct_val) & trimws(distinct_val) != ""]
|
||||
distinct_val_rsi <- as.character(suppressWarnings(as.rsi(distinct_val)))
|
||||
|
||||
length(distinct_val) > 0 &
|
||||
identical(distinct_val, distinct_val_rsi)
|
||||
}
|
||||
|
||||
#' @exportMethod print.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>%
|
||||
#' @noRd
|
||||
print.rsi <- function(x, ...) {
|
||||
cat("Class 'rsi'\n")
|
||||
print(as.character(x), quote = FALSE)
|
||||
}
|
||||
|
||||
#' @exportMethod summary.rsi
|
||||
#' @export
|
||||
#' @noRd
|
||||
summary.rsi <- function(object, ...) {
|
||||
x <- object
|
||||
c(
|
||||
"Mode" = 'rsi',
|
||||
"<NA>" = sum(is.na(x)),
|
||||
"Sum S" = sum(x == "S", na.rm = TRUE),
|
||||
"Sum IR" = sum(x %in% c("I", "R"), na.rm = TRUE),
|
||||
"-Sum R" = sum(x == "R", na.rm = TRUE),
|
||||
"-Sum I" = sum(x == "I", na.rm = TRUE)
|
||||
)
|
||||
}
|
||||
|
||||
#' @exportMethod plot.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% group_by summarise filter mutate if_else n_distinct
|
||||
#' @importFrom graphics plot text
|
||||
#' @noRd
|
||||
plot.rsi <- function(x, ...) {
|
||||
x_name <- deparse(substitute(x))
|
||||
|
||||
data <- data.frame(x = x,
|
||||
y = 1,
|
||||
stringsAsFactors = TRUE) %>%
|
||||
group_by(x) %>%
|
||||
summarise(n = sum(y)) %>%
|
||||
filter(!is.na(x)) %>%
|
||||
mutate(s = round((n / sum(n)) * 100, 1))
|
||||
data$x <- factor(data$x, levels = c('S', 'I', 'R'), ordered = TRUE)
|
||||
|
||||
ymax <- if_else(max(data$s) > 95, 105, 100)
|
||||
|
||||
plot(x = data$x,
|
||||
y = data$s,
|
||||
lwd = 2,
|
||||
col = c('green', 'orange', 'red'),
|
||||
ylim = c(0, ymax),
|
||||
ylab = 'Percentage',
|
||||
xlab = 'Antimicrobial Interpretation',
|
||||
main = paste('Susceptibility Analysis of', x_name),
|
||||
axes = FALSE,
|
||||
...)
|
||||
# x axis
|
||||
axis(side = 1, at = 1:n_distinct(data$x), labels = levels(data$x), lwd = 0)
|
||||
# y axis, 0-100%
|
||||
axis(side = 2, at = seq(0, 100, 5))
|
||||
|
||||
text(x = data$x,
|
||||
y = data$s + 4,
|
||||
labels = paste0(data$s, '% (n = ', data$n, ')'))
|
||||
}
|
||||
|
||||
|
||||
#' @exportMethod barplot.rsi
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% group_by summarise filter mutate if_else n_distinct
|
||||
#' @importFrom graphics barplot axis
|
||||
#' @noRd
|
||||
barplot.rsi <- function(height, ...) {
|
||||
x <- height
|
||||
x_name <- deparse(substitute(height))
|
||||
|
||||
data <- data.frame(rsi = x, cnt = 1) %>%
|
||||
group_by(rsi) %>%
|
||||
summarise(cnt = sum(cnt)) %>%
|
||||
droplevels()
|
||||
|
||||
barplot(table(x),
|
||||
col = c('green3', 'orange2', 'red3'),
|
||||
xlab = 'Antimicrobial Interpretation',
|
||||
main = paste('Susceptibility Analysis of', x_name),
|
||||
ylab = 'Frequency',
|
||||
axes = FALSE,
|
||||
...)
|
||||
# y axis, 0-100%
|
||||
axis(side = 2, at = seq(0, max(data$cnt) + max(data$cnt) * 1.1, by = 25))
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user