mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 18:41:58 +02:00
added mdr_tb()
This commit is contained in:
2
R/data.R
2
R/data.R
@ -22,7 +22,7 @@
|
||||
#' Data set with ~450 antibiotics
|
||||
#'
|
||||
#' A data set containing all antibiotics. Use \code{\link{as.ab}} or one of the \code{\link{ab_property}} functions to retrieve values from this data set. Three identifiers are included in this data set: an antibiotic ID (\code{ab}, primarily used in this package) as defined by WHONET/EARS-Net, an ATC code (\code{atc}) as defined by the WHO, and a Compound ID (\code{cid}) as found in PubChem. Other properties in this data set are derived from one or more of these codes.
|
||||
#' @format A \code{\link{data.frame}} with 455 observations and 13 variables:
|
||||
#' @format A \code{\link{data.frame}} with 454 observations and 13 variables:
|
||||
#' \describe{
|
||||
#' \item{\code{ab}}{Antibiotic ID as used in this package (like \code{AMC}), using the official EARS-Net (European Antimicrobial Resistance Surveillance Network) codes where available}
|
||||
#' \item{\code{atc}}{ATC code (Anatomical Therapeutic Chemical) as defined by the WHOCC, like \code{J01CR02}}
|
||||
|
||||
@ -116,7 +116,7 @@ EUCAST_VERSION_EXPERT_RULES <- "3.1, 2016"
|
||||
#' @export
|
||||
#' @importFrom dplyr %>% select pull mutate_at vars group_by summarise n
|
||||
#' @importFrom crayon bold bgGreen bgYellow bgRed black green blue italic strip_style white
|
||||
#' @return The input of \code{tbl_}, possibly with edited values of antibiotics. Or, if \code{verbose = TRUE}, a \code{data.frame} with all original and new values of the affected bug-drug combinations.
|
||||
#' @return The input of \code{x}, possibly with edited values of antibiotics. Or, if \code{verbose = TRUE}, a \code{data.frame} with all original and new values of the affected bug-drug combinations.
|
||||
#' @source
|
||||
#' \itemize{
|
||||
#' \item{
|
||||
@ -184,16 +184,16 @@ eucast_rules <- function(x,
|
||||
verbose = FALSE,
|
||||
...) {
|
||||
|
||||
tbl_ <- x
|
||||
x <- x
|
||||
|
||||
if (!is.data.frame(tbl_)) {
|
||||
if (!is.data.frame(x)) {
|
||||
stop("`x` must be a data frame.", call. = FALSE)
|
||||
}
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
col_mo <- search_type_in_df(tbl = tbl_, type = "mo")
|
||||
col_mo <- search_type_in_df(x = x, type = "mo")
|
||||
}
|
||||
if (is.null(col_mo)) {
|
||||
stop("`col_mo` must be set.", call. = FALSE)
|
||||
@ -376,12 +376,12 @@ eucast_rules <- function(x,
|
||||
edit_rsi <- function(to, rule, rows, cols) {
|
||||
cols <- unique(cols[!is.na(cols) & !is.null(cols)])
|
||||
if (length(rows) > 0 & length(cols) > 0) {
|
||||
before_df <- tbl_original
|
||||
before <- as.character(unlist(as.list(tbl_original[rows, cols])))
|
||||
before_df <- x_original
|
||||
before <- as.character(unlist(as.list(x_original[rows, cols])))
|
||||
|
||||
tryCatch(
|
||||
# insert into original table
|
||||
tbl_original[rows, cols] <<- to,
|
||||
x_original[rows, cols] <<- to,
|
||||
warning = function(w) {
|
||||
if (w$message %like% 'invalid factor level') {
|
||||
warning('Value "', to, '" could not be applied to column(s) `', paste(cols, collapse = '`, `'), '` because this value is not an existing factor level.', call. = FALSE)
|
||||
@ -396,9 +396,9 @@ eucast_rules <- function(x,
|
||||
}
|
||||
)
|
||||
|
||||
tbl_[rows, cols] <<- tbl_original[rows, cols]
|
||||
x[rows, cols] <<- x_original[rows, cols]
|
||||
|
||||
after <- as.character(unlist(as.list(tbl_original[rows, cols])))
|
||||
after <- as.character(unlist(as.list(x_original[rows, cols])))
|
||||
|
||||
# before_df might not be a data.frame, but a tibble of data.table instead
|
||||
old <- as.data.frame(before_df, stringsAsFactors = FALSE)[rows,]
|
||||
@ -406,9 +406,9 @@ eucast_rules <- function(x,
|
||||
for (i in 1:length(cols)) {
|
||||
verbose_new <- data.frame(row = rows,
|
||||
col = cols[i],
|
||||
mo_fullname = tbl_[rows, "fullname"],
|
||||
mo_fullname = x[rows, "fullname"],
|
||||
old = as.character(old[, cols[i]]),
|
||||
new = as.character(tbl_[rows, cols[i]]),
|
||||
new = as.character(x[rows, cols[i]]),
|
||||
rule = strip_style(rule[1]),
|
||||
rule_group = strip_style(rule[2]),
|
||||
rule_name = strip_style(rule[3]),
|
||||
@ -426,11 +426,11 @@ eucast_rules <- function(x,
|
||||
}
|
||||
|
||||
# save original table
|
||||
tbl_original <- tbl_
|
||||
x_original <- x
|
||||
|
||||
# join to microorganisms data set
|
||||
suppressWarnings(
|
||||
tbl_ <- tbl_ %>%
|
||||
x <- x %>%
|
||||
mutate_at(vars(col_mo), as.mo) %>%
|
||||
left_join_microorganisms(by = col_mo, suffix = c("_oldcols", "")) %>%
|
||||
mutate(gramstain = mo_gramstain(pull(., col_mo), language = "en"),
|
||||
@ -448,18 +448,18 @@ eucast_rules <- function(x,
|
||||
if (!ab_missing(AMP) & !ab_missing(AMX)) {
|
||||
if (verbose == TRUE) {
|
||||
cat("\n VERBOSE: transforming",
|
||||
length(which(tbl_[, AMX] == "S" & !tbl_[, AMP] %in% c("S", "I", "R"))),
|
||||
length(which(x[, AMX] == "S" & !x[, AMP] %in% c("S", "I", "R"))),
|
||||
"empty ampicillin fields to 'S' based on amoxicillin. ")
|
||||
cat("\n VERBOSE: transforming",
|
||||
length(which(tbl_[, AMX] == "I" & !tbl_[, AMP] %in% c("S", "I", "R"))),
|
||||
length(which(x[, AMX] == "I" & !x[, AMP] %in% c("S", "I", "R"))),
|
||||
"empty ampicillin fields to 'I' based on amoxicillin. ")
|
||||
cat("\n VERBOSE: transforming",
|
||||
length(which(tbl_[, AMX] == "R" & !tbl_[, AMP] %in% c("S", "I", "R"))),
|
||||
length(which(x[, AMX] == "R" & !x[, AMP] %in% c("S", "I", "R"))),
|
||||
"empty ampicillin fields to 'R' based on amoxicillin. \n")
|
||||
}
|
||||
tbl_[which(tbl_[, AMX] == "S" & !tbl_[, AMP] %in% c("S", "I", "R")), AMP] <- "S"
|
||||
tbl_[which(tbl_[, AMX] == "I" & !tbl_[, AMP] %in% c("S", "I", "R")), AMP] <- "I"
|
||||
tbl_[which(tbl_[, AMX] == "R" & !tbl_[, AMP] %in% c("S", "I", "R")), AMP] <- "R"
|
||||
x[which(x[, AMX] == "S" & !x[, AMP] %in% c("S", "I", "R")), AMP] <- "S"
|
||||
x[which(x[, AMX] == "I" & !x[, AMP] %in% c("S", "I", "R")), AMP] <- "I"
|
||||
x[which(x[, AMX] == "R" & !x[, AMP] %in% c("S", "I", "R")), AMP] <- "R"
|
||||
} else if (ab_missing(AMP) & !ab_missing(AMX)) {
|
||||
# ampicillin column is missing, but amoxicillin is available
|
||||
message(blue(paste0("NOTE: Using column `", bold(AMX), "` as input for ampicillin (J01CA01) since many EUCAST rules depend on it.")))
|
||||
@ -605,36 +605,36 @@ eucast_rules <- function(x,
|
||||
target_value <- eucast_rules_df[i, 7]
|
||||
|
||||
if (is.na(source_antibiotics)) {
|
||||
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value),
|
||||
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value),
|
||||
error = function(e) integer(0))
|
||||
} else {
|
||||
source_antibiotics <- get_antibiotic_columns(source_antibiotics, tbl_)
|
||||
source_antibiotics <- get_antibiotic_columns(source_antibiotics, x)
|
||||
if (length(source_value) == 1 & length(source_antibiotics) > 1) {
|
||||
source_value <- rep(source_value, length(source_antibiotics))
|
||||
}
|
||||
if (length(source_antibiotics) == 0) {
|
||||
rows <- integer(0)
|
||||
} else if (length(source_antibiotics) == 1) {
|
||||
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value
|
||||
& tbl_[, source_antibiotics[1L]] == source_value[1L]),
|
||||
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value
|
||||
& x[, source_antibiotics[1L]] == source_value[1L]),
|
||||
error = function(e) integer(0))
|
||||
} else if (length(source_antibiotics) == 2) {
|
||||
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value
|
||||
& tbl_[, source_antibiotics[1L]] == source_value[1L]
|
||||
& tbl_[, source_antibiotics[2L]] == source_value[2L]),
|
||||
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value
|
||||
& x[, source_antibiotics[1L]] == source_value[1L]
|
||||
& x[, source_antibiotics[2L]] == source_value[2L]),
|
||||
error = function(e) integer(0))
|
||||
} else if (length(source_antibiotics) == 3) {
|
||||
rows <- tryCatch(which(tbl_[, col_mo_property] %like% mo_value
|
||||
& tbl_[, source_antibiotics[1L]] == source_value[1L]
|
||||
& tbl_[, source_antibiotics[2L]] == source_value[2L]
|
||||
& tbl_[, source_antibiotics[3L]] == source_value[3L]),
|
||||
rows <- tryCatch(which(x[, col_mo_property] %like% mo_value
|
||||
& x[, source_antibiotics[1L]] == source_value[1L]
|
||||
& x[, source_antibiotics[2L]] == source_value[2L]
|
||||
& x[, source_antibiotics[3L]] == source_value[3L]),
|
||||
error = function(e) integer(0))
|
||||
} else {
|
||||
stop("only 3 antibiotics supported for source_antibiotics ", call. = FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
cols <- get_antibiotic_columns(target_antibiotics, tbl_)
|
||||
cols <- get_antibiotic_columns(target_antibiotics, x)
|
||||
|
||||
# Apply rule on data ------------------------------------------------------
|
||||
# this will return the unique number of changes
|
||||
@ -671,7 +671,7 @@ eucast_rules <- function(x,
|
||||
cat(paste0("\n", silver(strrep("-", options()$width - 1)), "\n"))
|
||||
cat(bold(paste('EUCAST rules', paste0(wouldve, 'affected'),
|
||||
formatnr(n_distinct(verbose_info$row)),
|
||||
'out of', formatnr(nrow(tbl_original)),
|
||||
'out of', formatnr(nrow(x_original)),
|
||||
'rows, making a total of', formatnr(nrow(verbose_info)), 'edits\n')))
|
||||
|
||||
n_added <- verbose_info %>% filter(is.na(old)) %>% nrow()
|
||||
@ -742,7 +742,7 @@ eucast_rules <- function(x,
|
||||
if (verbose == TRUE) {
|
||||
verbose_info
|
||||
} else {
|
||||
tbl_original
|
||||
x_original
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -191,7 +191,7 @@ first_isolate <- function(x,
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
col_mo <- search_type_in_df(tbl = x, type = "mo")
|
||||
col_mo <- search_type_in_df(x = x, type = "mo")
|
||||
}
|
||||
if (is.null(col_mo)) {
|
||||
stop("`col_mo` must be set.", call. = FALSE)
|
||||
@ -199,7 +199,7 @@ first_isolate <- function(x,
|
||||
|
||||
# -- date
|
||||
if (is.null(col_date)) {
|
||||
col_date <- search_type_in_df(tbl = x, type = "date")
|
||||
col_date <- search_type_in_df(x = x, type = "date")
|
||||
}
|
||||
if (is.null(col_date)) {
|
||||
stop("`col_date` must be set.", call. = FALSE)
|
||||
@ -217,7 +217,7 @@ first_isolate <- function(x,
|
||||
col_patient_id <- "patient_id"
|
||||
message(blue(paste0("NOTE: Using combined columns ", bold("`First name`, `Last name` and `Sex`"), " as input for `col_patient_id`.")))
|
||||
} else {
|
||||
col_patient_id <- search_type_in_df(tbl = x, type = "patient_id")
|
||||
col_patient_id <- search_type_in_df(x = x, type = "patient_id")
|
||||
}
|
||||
}
|
||||
if (is.null(col_patient_id)) {
|
||||
@ -226,7 +226,7 @@ first_isolate <- function(x,
|
||||
|
||||
# -- key antibiotics
|
||||
if (is.null(col_keyantibiotics)) {
|
||||
col_keyantibiotics <- search_type_in_df(tbl = x, type = "keyantibiotics")
|
||||
col_keyantibiotics <- search_type_in_df(x = x, type = "keyantibiotics")
|
||||
}
|
||||
if (isFALSE(col_keyantibiotics)) {
|
||||
col_keyantibiotics <- NULL
|
||||
@ -234,7 +234,7 @@ first_isolate <- function(x,
|
||||
|
||||
# -- specimen
|
||||
if (is.null(col_specimen)) {
|
||||
col_specimen <- search_type_in_df(tbl = x, type = "specimen")
|
||||
col_specimen <- search_type_in_df(x = x, type = "specimen")
|
||||
}
|
||||
if (isFALSE(col_specimen)) {
|
||||
col_specimen <- NULL
|
||||
@ -547,10 +547,10 @@ filter_first_isolate <- function(x,
|
||||
col_mo = NULL,
|
||||
...) {
|
||||
filter(x, first_isolate(x = x,
|
||||
col_date = col_date,
|
||||
col_patient_id = col_patient_id,
|
||||
col_mo = col_mo,
|
||||
...))
|
||||
col_date = col_date,
|
||||
col_patient_id = col_patient_id,
|
||||
col_mo = col_mo,
|
||||
...))
|
||||
}
|
||||
|
||||
#' @rdname first_isolate
|
||||
|
||||
7
R/freq.R
7
R/freq.R
@ -336,9 +336,10 @@ frequency_tbl <- function(x,
|
||||
cols <- unlist(strsplit(x.name, "$", fixed = TRUE))[2]
|
||||
x.name <- unlist(strsplit(x.name, "$", fixed = TRUE))[1]
|
||||
# try to find the object to determine dimensions
|
||||
|
||||
x.obj <- tryCatch(get(x.name), error = function(e) NULL)
|
||||
x.name <- paste0("`", x.name , "`")
|
||||
if (!is.null(x.obj)) {
|
||||
if (!is.null(dim(x.obj))) {
|
||||
x.name <- paste0(x.name,
|
||||
" (",
|
||||
x.obj %>%
|
||||
@ -664,6 +665,10 @@ format_header <- function(x, markdown = FALSE, decimal.mark = ".", big.mark = ",
|
||||
if (nchar(levels_text) > 70) {
|
||||
# levels text wider than half the console
|
||||
levels_text <- paste0(substr(levels_text, 1, 70 - 3), "...")
|
||||
if (nchar(gsub("[^`]", "", levels_text)) %% 2 == 1) {
|
||||
# odd number of backticks, should be even
|
||||
levels_text <- paste0(levels_text, "`")
|
||||
}
|
||||
}
|
||||
header$levels <- paste0(length(header$levels), ": ", levels_text)
|
||||
header <- header[names(header) != "ordered"]
|
||||
|
||||
@ -22,7 +22,7 @@
|
||||
#' Key antibiotics for first \emph{weighted} isolates
|
||||
#'
|
||||
#' These function can be used to determine first isolates (see \code{\link{first_isolate}}). Using key antibiotics to determine first isolates is more reliable than without key antibiotics. These selected isolates will then be called first \emph{weighted} isolates.
|
||||
#' @param tbl table with antibiotics coloms, like \code{amox} and \code{amcl}.
|
||||
#' @param x table with antibiotics coloms, like \code{AMX} or \code{amox}
|
||||
#' @param x,y characters to compare
|
||||
#' @inheritParams first_isolate
|
||||
#' @param universal_1,universal_2,universal_3,universal_4,universal_5,universal_6 column names of \strong{broad-spectrum} antibiotics, case-insensitive. At default, the columns containing these antibiotics will be guessed with \code{\link{guess_ab_col}}.
|
||||
@ -76,33 +76,33 @@
|
||||
#'
|
||||
#' key_antibiotics_equal(strainA, strainB, ignore_I = FALSE)
|
||||
#' # FALSE, because I is not ignored and so the 4th value differs
|
||||
key_antibiotics <- function(tbl,
|
||||
key_antibiotics <- function(x,
|
||||
col_mo = NULL,
|
||||
universal_1 = guess_ab_col(tbl, "AMX"),
|
||||
universal_2 = guess_ab_col(tbl, "AMC"),
|
||||
universal_3 = guess_ab_col(tbl, "CXM"),
|
||||
universal_4 = guess_ab_col(tbl, "TZP"),
|
||||
universal_5 = guess_ab_col(tbl, "CIP"),
|
||||
universal_6 = guess_ab_col(tbl, "SXT"),
|
||||
GramPos_1 = guess_ab_col(tbl, "VAN"),
|
||||
GramPos_2 = guess_ab_col(tbl, "TEC"),
|
||||
GramPos_3 = guess_ab_col(tbl, "TCY"),
|
||||
GramPos_4 = guess_ab_col(tbl, "ERY"),
|
||||
GramPos_5 = guess_ab_col(tbl, "OXA"),
|
||||
GramPos_6 = guess_ab_col(tbl, "RIF"),
|
||||
GramNeg_1 = guess_ab_col(tbl, "GEN"),
|
||||
GramNeg_2 = guess_ab_col(tbl, "TOB"),
|
||||
GramNeg_3 = guess_ab_col(tbl, "COL"),
|
||||
GramNeg_4 = guess_ab_col(tbl, "CTX"),
|
||||
GramNeg_5 = guess_ab_col(tbl, "CAZ"),
|
||||
GramNeg_6 = guess_ab_col(tbl, "MEM"),
|
||||
universal_1 = guess_ab_col(x, "AMX"),
|
||||
universal_2 = guess_ab_col(x, "AMC"),
|
||||
universal_3 = guess_ab_col(x, "CXM"),
|
||||
universal_4 = guess_ab_col(x, "TZP"),
|
||||
universal_5 = guess_ab_col(x, "CIP"),
|
||||
universal_6 = guess_ab_col(x, "SXT"),
|
||||
GramPos_1 = guess_ab_col(x, "VAN"),
|
||||
GramPos_2 = guess_ab_col(x, "TEC"),
|
||||
GramPos_3 = guess_ab_col(x, "TCY"),
|
||||
GramPos_4 = guess_ab_col(x, "ERY"),
|
||||
GramPos_5 = guess_ab_col(x, "OXA"),
|
||||
GramPos_6 = guess_ab_col(x, "RIF"),
|
||||
GramNeg_1 = guess_ab_col(x, "GEN"),
|
||||
GramNeg_2 = guess_ab_col(x, "TOB"),
|
||||
GramNeg_3 = guess_ab_col(x, "COL"),
|
||||
GramNeg_4 = guess_ab_col(x, "CTX"),
|
||||
GramNeg_5 = guess_ab_col(x, "CAZ"),
|
||||
GramNeg_6 = guess_ab_col(x, "MEM"),
|
||||
warnings = TRUE,
|
||||
...) {
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
col_mo <- search_type_in_df(tbl = tbl, type = "mo")
|
||||
col_mo <- search_type_in_df(x = x, type = "mo")
|
||||
}
|
||||
if (is.null(col_mo)) {
|
||||
stop("`col_mo` must be set.", call. = FALSE)
|
||||
@ -112,7 +112,7 @@ key_antibiotics <- function(tbl,
|
||||
col.list <- c(universal_1, universal_2, universal_3, universal_4, universal_5, universal_6,
|
||||
GramPos_1, GramPos_2, GramPos_3, GramPos_4, GramPos_5, GramPos_6,
|
||||
GramNeg_1, GramNeg_2, GramNeg_3, GramNeg_4, GramNeg_5, GramNeg_6)
|
||||
check_available_columns <- function(tbl, col.list, info = TRUE) {
|
||||
check_available_columns <- function(x, col.list, info = TRUE) {
|
||||
# check columns
|
||||
col.list <- col.list[!is.na(col.list) & !is.null(col.list)]
|
||||
names(col.list) <- col.list
|
||||
@ -121,18 +121,18 @@ key_antibiotics <- function(tbl,
|
||||
for (i in 1:length(col.list)) {
|
||||
if (is.null(col.list[i]) | isTRUE(is.na(col.list[i]))) {
|
||||
col.list[i] <- NA
|
||||
} else if (toupper(col.list[i]) %in% colnames(tbl)) {
|
||||
} else if (toupper(col.list[i]) %in% colnames(x)) {
|
||||
col.list[i] <- toupper(col.list[i])
|
||||
} else if (tolower(col.list[i]) %in% colnames(tbl)) {
|
||||
} else if (tolower(col.list[i]) %in% colnames(x)) {
|
||||
col.list[i] <- tolower(col.list[i])
|
||||
} else if (!col.list[i] %in% colnames(tbl)) {
|
||||
} else if (!col.list[i] %in% colnames(x)) {
|
||||
col.list[i] <- NA
|
||||
}
|
||||
}
|
||||
if (!all(col.list %in% colnames(tbl))) {
|
||||
if (!all(col.list %in% colnames(x))) {
|
||||
if (info == TRUE) {
|
||||
warning('Some columns do not exist and will be ignored: ',
|
||||
col.list.bak[!(col.list %in% colnames(tbl))] %>% toString(),
|
||||
col.list.bak[!(col.list %in% colnames(x))] %>% toString(),
|
||||
'.\nTHIS MAY STRONGLY INFLUENCE THE OUTCOME.',
|
||||
immediate. = TRUE,
|
||||
call. = FALSE)
|
||||
@ -141,7 +141,7 @@ key_antibiotics <- function(tbl,
|
||||
col.list
|
||||
}
|
||||
|
||||
col.list <- check_available_columns(tbl = tbl, col.list = col.list, info = warnings)
|
||||
col.list <- check_available_columns(x = x, col.list = col.list, info = warnings)
|
||||
universal_1 <- col.list[universal_1]
|
||||
universal_2 <- col.list[universal_2]
|
||||
universal_3 <- col.list[universal_3]
|
||||
@ -183,30 +183,30 @@ key_antibiotics <- function(tbl,
|
||||
}
|
||||
|
||||
# join to microorganisms data set
|
||||
tbl <- tbl %>%
|
||||
x <- x %>%
|
||||
mutate_at(vars(col_mo), as.mo) %>%
|
||||
left_join_microorganisms(by = col_mo) %>%
|
||||
mutate(key_ab = NA_character_,
|
||||
gramstain = mo_gramstain(pull(., col_mo)))
|
||||
|
||||
# Gram +
|
||||
tbl <- tbl %>% mutate(key_ab =
|
||||
if_else(gramstain == "Gram positive",
|
||||
apply(X = tbl[, gram_positive],
|
||||
MARGIN = 1,
|
||||
FUN = function(x) paste(x, collapse = "")),
|
||||
key_ab))
|
||||
x <- x %>% mutate(key_ab =
|
||||
if_else(gramstain == "Gram positive",
|
||||
apply(X = x[, gram_positive],
|
||||
MARGIN = 1,
|
||||
FUN = function(x) paste(x, collapse = "")),
|
||||
key_ab))
|
||||
|
||||
# Gram -
|
||||
tbl <- tbl %>% mutate(key_ab =
|
||||
if_else(gramstain == "Gram negative",
|
||||
apply(X = tbl[, gram_negative],
|
||||
MARGIN = 1,
|
||||
FUN = function(x) paste(x, collapse = "")),
|
||||
key_ab))
|
||||
x <- x %>% mutate(key_ab =
|
||||
if_else(gramstain == "Gram negative",
|
||||
apply(X = x[, gram_negative],
|
||||
MARGIN = 1,
|
||||
FUN = function(x) paste(x, collapse = "")),
|
||||
key_ab))
|
||||
|
||||
# format
|
||||
key_abs <- tbl %>%
|
||||
key_abs <- x %>%
|
||||
pull(key_ab) %>%
|
||||
gsub('(NA|NULL)', '.', .) %>%
|
||||
gsub('[^SIR]', '.', ., ignore.case = TRUE)
|
||||
|
||||
290
R/mdro.R
290
R/mdro.R
@ -23,12 +23,25 @@
|
||||
#'
|
||||
#' Determine which isolates are multidrug-resistant organisms (MDRO) according to country-specific guidelines.
|
||||
#' @param x table with antibiotic columns, like e.g. \code{AMX} and \code{AMC}
|
||||
#' @param country country code to determine guidelines. EUCAST rules will be used when left empty, see Details. Should be or a code from the \href{https://en.wikipedia.org/wiki/ISO_3166-1_alpha-2#Officially_assigned_code_elements}{list of ISO 3166-1 alpha-2 country codes}. Case-insensitive. Currently supported are \code{de} (Germany) and \code{nl} (the Netherlands).
|
||||
#' @param country country code to determine guidelines. Should be or a code from the \href{https://en.wikipedia.org/wiki/ISO_3166-1_alpha-2#Officially_assigned_code_elements}{list of ISO 3166-1 alpha-2 country codes}. Case-insensitive.
|
||||
#' @param guideline a specific guideline to mention. For some countries this will be determined automatically, see Details. EUCAST guidelines will be used when left empty, see Details.
|
||||
#' @param info print progress
|
||||
#' @inheritParams eucast_rules
|
||||
#' @param verbose print additional info: missing antibiotic columns per parameter
|
||||
#' @inheritSection eucast_rules Antibiotics
|
||||
#' @details When \code{country} will be left blank, guidelines will be taken from EUCAST Expert Rules Version 3.1 "Intrinsic Resistance and Exceptional Phenotypes Tables" (\href{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf}{link}).
|
||||
#' @details When \code{country} is set, the parameter guideline will be ignored as these guidelines will be used:
|
||||
#'
|
||||
#' \itemize{
|
||||
#' \item{\code{country = "nl"}: Rijksinstituut voor Volksgezondheid en Milieu "WIP-richtlijn BRMO (Bijzonder Resistente Micro-Organismen) [ZKH]" (\href{https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH}{link})}
|
||||
#' }
|
||||
#'
|
||||
#' Please suggest your own country's specific guidelines by letting us know: \url{https://gitlab.com/msberends/AMR/issues/new}.
|
||||
#'
|
||||
#' Other currently supported guidelines are:
|
||||
#' \itemize{
|
||||
#' \item{\code{guideline = "eucast"}: EUCAST Expert Rules Version 3.1 "Intrinsic Resistance and Exceptional Phenotypes Tables" (\href{http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf}{link})}
|
||||
#' \item{\code{guideline = "tb"}: World Health Organization "Companion handbook to the WHO guidelines for the programmatic management of drug-resistant tuberculosis" (\href{https://www.who.int/tb/publications/pmdt_companionhandbook/en/}{link})}
|
||||
#' }
|
||||
#' @return Ordered factor with levels \code{Negative < Positive, unconfirmed < Positive}.
|
||||
#' @rdname mdro
|
||||
#' @importFrom dplyr %>%
|
||||
@ -43,21 +56,41 @@
|
||||
#' BRMO = brmo(.))
|
||||
mdro <- function(x,
|
||||
country = NULL,
|
||||
guideline = NULL,
|
||||
col_mo = NULL,
|
||||
info = TRUE,
|
||||
verbose = FALSE,
|
||||
...) {
|
||||
|
||||
tbl_ <- x
|
||||
|
||||
if (!is.data.frame(tbl_)) {
|
||||
if (!is.data.frame(x)) {
|
||||
stop("`x` must be a data frame.", call. = FALSE)
|
||||
}
|
||||
|
||||
if (length(guideline) > 1) {
|
||||
stop("`guideline` must be a length one character string.", call. = FALSE)
|
||||
}
|
||||
if (!is.null(country)) {
|
||||
guideline <- country
|
||||
}
|
||||
if (is.null(guideline)) {
|
||||
guideline <- "eucast"
|
||||
}
|
||||
if (!tolower(guideline) %in% c("nl", "de", "eucast", "tb")) {
|
||||
stop("invalid guideline: ", guideline, call. = FALSE)
|
||||
}
|
||||
guideline <- list(code = tolower(guideline))
|
||||
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
col_mo <- search_type_in_df(tbl = tbl_, type = "mo")
|
||||
col_mo <- search_type_in_df(x = x, type = "mo")
|
||||
}
|
||||
if (is.null(col_mo) & guideline$code == "tb") {
|
||||
message(blue("NOTE: No column found as input for `col_mo`,",
|
||||
bold("assuming all records contain",
|
||||
italic("Mycobacterium tuberculosis."))))
|
||||
x$mo <- AMR::as.mo("Mycobacterium tuberculosis")
|
||||
col_mo <- "mo"
|
||||
}
|
||||
if (is.null(col_mo)) {
|
||||
stop("`col_mo` must be set.", call. = FALSE)
|
||||
@ -67,50 +100,59 @@ mdro <- function(x,
|
||||
stop("`country` must be a length one character string.", call. = FALSE)
|
||||
}
|
||||
|
||||
if (is.null(country)) {
|
||||
country <- "EUCAST"
|
||||
}
|
||||
country <- trimws(country)
|
||||
if (tolower(country) != "eucast" & !country %like% "^[a-z]{2}$") {
|
||||
stop("This is not a valid ISO 3166-1 alpha-2 country code: '", country, "'. Please see ?mdro.", call. = FALSE)
|
||||
}
|
||||
|
||||
# create list and make country code case-independent
|
||||
guideline <- list(country = list(code = tolower(country)))
|
||||
|
||||
if (guideline$country$code == "eucast") {
|
||||
guideline$country$name <- "(European guidelines)"
|
||||
if (guideline$code == "eucast") {
|
||||
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Exceptional Phenotypes Tables\""
|
||||
guideline$version <- "Version 3.1"
|
||||
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
|
||||
guideline$version <- "3.1"
|
||||
guideline$source <- "http://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf"
|
||||
|
||||
} else if (guideline$code == "tb") {
|
||||
guideline$name <- "Companion handbook to the WHO guidelines for the programmatic management of drug-resistant tuberculosis"
|
||||
guideline$author <- "WHO (World Health Organization)"
|
||||
guideline$version <- "WHO/HTM/TB/2014.11"
|
||||
guideline$source <- "https://www.who.int/tb/publications/pmdt_companionhandbook/en/"
|
||||
|
||||
# support per country:
|
||||
} else if (guideline$country$code == "de") {
|
||||
guideline$country$name <- "Germany"
|
||||
} else if (guideline$code == "de") {
|
||||
guideline$name <- "Germany"
|
||||
guideline$name <- ""
|
||||
guideline$version <- ""
|
||||
guideline$source <- ""
|
||||
} else if (guideline$country$code == "nl") {
|
||||
guideline$country$name <- "The Netherlands"
|
||||
guideline$name <- "WIP-Richtlijn BRMO"
|
||||
} else if (guideline$code == "nl") {
|
||||
guideline$name <- "WIP-Richtlijn Bijzonder Resistente Micro-organismen (BRMO)"
|
||||
guideline$author <- "RIVM (Rijksinstituut voor de Volksgezondheid)"
|
||||
guideline$version <- "Revision as of December 2017"
|
||||
guideline$source <- "https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH"
|
||||
# add here more countries like this:
|
||||
# } else if (country$code == "xx") {
|
||||
# country$name <- "country name"
|
||||
} else {
|
||||
stop("This country code is currently unsupported: ", guideline$country$code, call. = FALSE)
|
||||
stop("This guideline is currently unsupported: ", guideline$code, call. = FALSE)
|
||||
}
|
||||
|
||||
if (info == TRUE) {
|
||||
cat("Determining multidrug-resistant organisms (MDRO), according to:\n",
|
||||
"Guideline: ", red(paste0(guideline$name, ", ", guideline$version, "\n")),
|
||||
"Country : ", red(paste0(guideline$country$name, "\n")),
|
||||
"Source : ", blue(paste0(guideline$source, "\n")),
|
||||
"Guideline: ", red(guideline$name), "\n",
|
||||
"Version: ", red(guideline$version), "\n",
|
||||
"Author: ", red(guideline$author), "\n",
|
||||
"Source: ", blue(guideline$source), "\n",
|
||||
"\n", sep = "")
|
||||
}
|
||||
|
||||
|
||||
cols_ab <- get_column_abx(x = x, verbose = verbose, ...)
|
||||
if (guideline$code == "tb") {
|
||||
cols_ab <- get_column_abx(x = x,
|
||||
soft_dependencies = c("CAP",
|
||||
"ETH",
|
||||
"GAT",
|
||||
"INH",
|
||||
"PZA",
|
||||
"RIF",
|
||||
"RIB",
|
||||
"RFP"),
|
||||
verbose = verbose, ...)
|
||||
} else {
|
||||
cols_ab <- get_column_abx(x = x, verbose = verbose, ...)
|
||||
}
|
||||
|
||||
AMC <- cols_ab["AMC"]
|
||||
AMK <- cols_ab["AMK"]
|
||||
@ -175,7 +217,20 @@ mdro <- function(x,
|
||||
TOB <- cols_ab["TOB"]
|
||||
TZP <- cols_ab["TZP"]
|
||||
VAN <- cols_ab["VAN"]
|
||||
|
||||
# additional for TB
|
||||
CAP <- cols_ab["CAP"]
|
||||
ETH <- cols_ab["ETH"]
|
||||
GAT <- cols_ab["GAT"]
|
||||
INH <- cols_ab["INH"]
|
||||
PZA <- cols_ab["PZA"]
|
||||
RIF <- cols_ab["RIF"]
|
||||
RIB <- cols_ab["RIB"]
|
||||
RFP <- cols_ab["RFP"]
|
||||
abx_tb <- c(CAP, ETH, GAT, INH, PZA, RIF, RIB, RFP)
|
||||
abx_tb <- abx_tb[!is.na(abx_tb)]
|
||||
if (guideline$code == "tb" & length(abx_tb) == 0) {
|
||||
stop("No antimycobacterials found in data set.", call. = FALSE)
|
||||
}
|
||||
|
||||
ab_missing <- function(ab) {
|
||||
isTRUE(ab %in% c(NULL, NA)) | length(ab) == 0
|
||||
@ -194,96 +249,96 @@ mdro <- function(x,
|
||||
cols <- cols[!is.na(cols)]
|
||||
if (length(rows) > 0 & length(cols) > 0) {
|
||||
if (any_all == "any") {
|
||||
row_filter <- which(tbl_[, cols] == "R")
|
||||
row_filter <- which(x[, cols] == "R")
|
||||
} else if (any_all == "all") {
|
||||
row_filter <- tbl_ %>%
|
||||
row_filter <- x %>%
|
||||
mutate(index = 1:nrow(.)) %>%
|
||||
filter_at(vars(cols), all_vars(. == "R")) %>%
|
||||
pull((index))
|
||||
}
|
||||
rows <- rows[rows %in% row_filter]
|
||||
tbl_[rows, "MDRO"] <<- to
|
||||
x[rows, "MDRO"] <<- to
|
||||
}
|
||||
}
|
||||
|
||||
tbl_ <- tbl_ %>%
|
||||
x <- x %>%
|
||||
mutate_at(vars(col_mo), as.mo) %>%
|
||||
# join to microorganisms data set
|
||||
left_join_microorganisms(by = col_mo) %>%
|
||||
# add unconfirmed to where genus is available
|
||||
mutate(MDRO = ifelse(!is.na(genus), 1, NA_integer_))
|
||||
|
||||
if (guideline$country$code == "eucast") {
|
||||
if (guideline$code == "eucast") {
|
||||
# EUCAST ------------------------------------------------------------------
|
||||
# Table 5
|
||||
trans_tbl(3,
|
||||
which(tbl_$family == "Enterobacteriaceae"
|
||||
| tbl_$fullname %like% "^Pseudomonas aeruginosa"
|
||||
| tbl_$genus == "Acinetobacter"),
|
||||
which(x$family == "Enterobacteriaceae"
|
||||
| x$fullname %like% "^Pseudomonas aeruginosa"
|
||||
| x$genus == "Acinetobacter"),
|
||||
COL,
|
||||
"all")
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "^Salmonella Typhi"),
|
||||
which(x$fullname %like% "^Salmonella Typhi"),
|
||||
c(carbapenems, fluoroquinolones),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "^Haemophilus influenzae"),
|
||||
which(x$fullname %like% "^Haemophilus influenzae"),
|
||||
c(cephalosporins_3rd, carbapenems, fluoroquinolones),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "^Moraxella catarrhalis"),
|
||||
which(x$fullname %like% "^Moraxella catarrhalis"),
|
||||
c(cephalosporins_3rd, fluoroquinolones),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "^Neisseria meningitidis"),
|
||||
which(x$fullname %like% "^Neisseria meningitidis"),
|
||||
c(cephalosporins_3rd, fluoroquinolones),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "^Neisseria gonorrhoeae"),
|
||||
which(x$fullname %like% "^Neisseria gonorrhoeae"),
|
||||
AZM,
|
||||
"any")
|
||||
# Table 6
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "^Staphylococcus (aureus|epidermidis|coagulase negatief|hominis|haemolyticus|intermedius|pseudointermedius)"),
|
||||
which(x$fullname %like% "^Staphylococcus (aureus|epidermidis|coagulase negatief|hominis|haemolyticus|intermedius|pseudointermedius)"),
|
||||
c(VAN, TEC, DAP, LNZ, QDA, TGC),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(tbl_$genus == "Corynebacterium"),
|
||||
which(x$genus == "Corynebacterium"),
|
||||
c(VAN, TEC, DAP, LNZ, QDA, TGC),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "^Streptococcus pneumoniae"),
|
||||
which(x$fullname %like% "^Streptococcus pneumoniae"),
|
||||
c(carbapenems, VAN, TEC, DAP, LNZ, QDA, TGC, RIF),
|
||||
"any")
|
||||
trans_tbl(3, # Sr. groups A/B/C/G
|
||||
which(tbl_$fullname %like% "^Streptococcus (pyogenes|agalactiae|equisimilis|equi|zooepidemicus|dysgalactiae|anginosus)"),
|
||||
which(x$fullname %like% "^Streptococcus (pyogenes|agalactiae|equisimilis|equi|zooepidemicus|dysgalactiae|anginosus)"),
|
||||
c(PEN, cephalosporins, VAN, TEC, DAP, LNZ, QDA, TGC),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(tbl_$genus == "Enterococcus"),
|
||||
which(x$genus == "Enterococcus"),
|
||||
c(DAP, LNZ, TGC, TEC),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "^Enterococcus faecalis"),
|
||||
which(x$fullname %like% "^Enterococcus faecalis"),
|
||||
c(AMP, AMX),
|
||||
"any")
|
||||
# Table 7
|
||||
trans_tbl(3,
|
||||
which(tbl_$genus == "Bacteroides"),
|
||||
which(x$genus == "Bacteroides"),
|
||||
MTR,
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "^Clostridium difficile"),
|
||||
which(x$fullname %like% "^Clostridium difficile"),
|
||||
c(MTR, VAN),
|
||||
"any")
|
||||
}
|
||||
|
||||
if (guideline$country$code == "de") {
|
||||
if (guideline$code == "de") {
|
||||
# Germany -----------------------------------------------------------------
|
||||
stop("We are still working on German guidelines in this beta version.", call. = FALSE)
|
||||
}
|
||||
|
||||
if (guideline$country$code == "nl") {
|
||||
if (guideline$code == "nl") {
|
||||
# Netherlands -------------------------------------------------------------
|
||||
aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)]
|
||||
fluoroquinolones <- fluoroquinolones[!is.na(fluoroquinolones)]
|
||||
@ -298,32 +353,32 @@ mdro <- function(x,
|
||||
|
||||
# Table 1
|
||||
trans_tbl(3,
|
||||
which(tbl_$family == "Enterobacteriaceae"),
|
||||
which(x$family == "Enterobacteriaceae"),
|
||||
c(aminoglycosides, fluoroquinolones),
|
||||
"all")
|
||||
|
||||
trans_tbl(2,
|
||||
which(tbl_$family == "Enterobacteriaceae"),
|
||||
which(x$family == "Enterobacteriaceae"),
|
||||
carbapenems,
|
||||
"any")
|
||||
|
||||
trans_tbl(2,
|
||||
which(tbl_$family == "Enterobacteriaceae"),
|
||||
which(x$family == "Enterobacteriaceae"),
|
||||
ESBLs,
|
||||
"all")
|
||||
|
||||
# Table 2
|
||||
trans_tbl(2,
|
||||
which(tbl_$genus == "Acinetobacter"),
|
||||
which(x$genus == "Acinetobacter"),
|
||||
c(carbapenems),
|
||||
"any")
|
||||
trans_tbl(3,
|
||||
which(tbl_$genus == "Acinetobacter"),
|
||||
which(x$genus == "Acinetobacter"),
|
||||
c(aminoglycosides, fluoroquinolones),
|
||||
"all")
|
||||
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "^Stenotrophomonas maltophilia"),
|
||||
which(x$fullname %like% "^Stenotrophomonas maltophilia"),
|
||||
SXT,
|
||||
"all")
|
||||
|
||||
@ -332,39 +387,108 @@ mdro <- function(x,
|
||||
& !ab_missing(CIP)
|
||||
& !ab_missing(CAZ)
|
||||
& !ab_missing(TZP) ) {
|
||||
tbl_$psae <- 0
|
||||
tbl_[which(tbl_[, MEM] == "R" | tbl_[, IPM] == "R"), "psae"] <- 1 + tbl_[which(tbl_[, MEM] == "R" | tbl_[, IPM] == "R"), "psae"]
|
||||
tbl_[which(tbl_[, GEN] == "R" & tbl_[, TOB] == "R"), "psae"] <- 1 + tbl_[which(tbl_[, GEN] == "R" & tbl_[, TOB] == "R"), "psae"]
|
||||
tbl_[which(tbl_[, CIP] == "R"), "psae"] <- 1 + tbl_[which(tbl_[, CIP] == "R"), "psae"]
|
||||
tbl_[which(tbl_[, CAZ] == "R"), "psae"] <- 1 + tbl_[which(tbl_[, CAZ] == "R"), "psae"]
|
||||
tbl_[which(tbl_[, TZP] == "R"), "psae"] <- 1 + tbl_[which(tbl_[, TZP] == "R"), "psae"]
|
||||
x$psae <- 0
|
||||
x[which(x[, MEM] == "R" | x[, IPM] == "R"), "psae"] <- 1 + x[which(x[, MEM] == "R" | x[, IPM] == "R"), "psae"]
|
||||
x[which(x[, GEN] == "R" & x[, TOB] == "R"), "psae"] <- 1 + x[which(x[, GEN] == "R" & x[, TOB] == "R"), "psae"]
|
||||
x[which(x[, CIP] == "R"), "psae"] <- 1 + x[which(x[, CIP] == "R"), "psae"]
|
||||
x[which(x[, CAZ] == "R"), "psae"] <- 1 + x[which(x[, CAZ] == "R"), "psae"]
|
||||
x[which(x[, TZP] == "R"), "psae"] <- 1 + x[which(x[, TZP] == "R"), "psae"]
|
||||
} else {
|
||||
tbl_$psae <- 0
|
||||
x$psae <- 0
|
||||
}
|
||||
tbl_[which(
|
||||
tbl_$fullname %like% "Pseudomonas aeruginosa"
|
||||
& tbl_$psae >= 3
|
||||
x[which(
|
||||
x$fullname %like% "Pseudomonas aeruginosa"
|
||||
& x$psae >= 3
|
||||
), "MDRO"] <- 3
|
||||
|
||||
# Table 3
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "Streptococcus pneumoniae"),
|
||||
which(x$fullname %like% "Streptococcus pneumoniae"),
|
||||
PEN,
|
||||
"all")
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "Streptococcus pneumoniae"),
|
||||
which(x$fullname %like% "Streptococcus pneumoniae"),
|
||||
VAN,
|
||||
"all")
|
||||
trans_tbl(3,
|
||||
which(tbl_$fullname %like% "Enterococcus faecium"),
|
||||
which(x$fullname %like% "Enterococcus faecium"),
|
||||
c(PEN, VAN),
|
||||
"all")
|
||||
}
|
||||
|
||||
factor(x = tbl_$MDRO,
|
||||
levels = 1:3,
|
||||
labels = c("Negative", "Positive, unconfirmed", "Positive"),
|
||||
ordered = TRUE)
|
||||
prepare_drug <- function(ab) {
|
||||
# returns vector values of drug
|
||||
# if `ab` is a column name, looks up the values in `x`
|
||||
if (length(ab) == 1 & is.character(ab)) {
|
||||
if (ab %in% colnames(x)) {
|
||||
ab <- as.data.frame(x)[, ab]
|
||||
}
|
||||
}
|
||||
ab <- as.character(as.rsi(ab))
|
||||
ab[is.na(ab)] <- ""
|
||||
ab
|
||||
}
|
||||
drug_is_R <- function(ab) {
|
||||
# returns logical vector
|
||||
ab <- prepare_drug(ab)
|
||||
if (length(ab) == 1) {
|
||||
rep(ab, NROW(x)) == "R"
|
||||
} else {
|
||||
ab == "R"
|
||||
}
|
||||
}
|
||||
drug_is_not_R <- function(ab) {
|
||||
# returns logical vector
|
||||
ab <- prepare_drug(ab)
|
||||
if (length(ab) == 1) {
|
||||
rep(ab, NROW(x)) != "R"
|
||||
} else {
|
||||
ab != "R"
|
||||
}
|
||||
}
|
||||
|
||||
if (guideline$code == "tb") {
|
||||
# Tuberculosis ------------------------------------------------------------
|
||||
x <- x %>%
|
||||
mutate(mono_count = 0,
|
||||
mono_count = ifelse(drug_is_R(INH), mono_count + 1, mono_count),
|
||||
mono_count = ifelse(drug_is_R(RIF), mono_count + 1, mono_count),
|
||||
mono_count = ifelse(drug_is_R(ETH), mono_count + 1, mono_count),
|
||||
mono_count = ifelse(drug_is_R(PZA), mono_count + 1, mono_count),
|
||||
mono_count = ifelse(drug_is_R(RIB), mono_count + 1, mono_count),
|
||||
mono_count = ifelse(drug_is_R(RFP), mono_count + 1, mono_count),
|
||||
# from here on logicals
|
||||
mono = mono_count > 0,
|
||||
poly = ifelse(mono_count > 1 & drug_is_not_R(RIF) & drug_is_not_R(INH),
|
||||
TRUE, FALSE),
|
||||
mdr = ifelse(drug_is_R(RIF) & drug_is_R(INH),
|
||||
TRUE, FALSE),
|
||||
xdr = ifelse(drug_is_R(LVX) | drug_is_R(MFX) | drug_is_R(GAT),
|
||||
TRUE, FALSE),
|
||||
second = ifelse(drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK),
|
||||
TRUE, FALSE),
|
||||
xdr = ifelse(mdr & xdr & second, TRUE, FALSE)) %>%
|
||||
mutate(mdr_tb = case_when(xdr ~ 5,
|
||||
mdr ~ 4,
|
||||
poly ~ 3,
|
||||
mono ~ 2,
|
||||
TRUE ~ 1),
|
||||
# keep all real TB, make other species NA
|
||||
mdr_tb = ifelse(x$fullname == "Mycobacterium tuberculosis", mdr_tb, NA_real_))
|
||||
}
|
||||
|
||||
# return results
|
||||
if (guideline$code == "tb") {
|
||||
factor(x = x$mdr_tb,
|
||||
levels = 1:5,
|
||||
labels = c("Negative", "Mono-resistance", "Poly-resistance", "Multidrug resistance", "Extensive drug resistance"),
|
||||
ordered = TRUE)
|
||||
} else {
|
||||
factor(x = x$MDRO,
|
||||
levels = 1:3,
|
||||
labels = c("Negative", "Positive, unconfirmed", "Positive"),
|
||||
ordered = TRUE)
|
||||
}
|
||||
}
|
||||
|
||||
#' @rdname mdro
|
||||
@ -381,6 +505,12 @@ mrgn <- function(x, country = "de", ...) {
|
||||
|
||||
#' @rdname mdro
|
||||
#' @export
|
||||
eucast_exceptional_phenotypes <- function(x, country = "EUCAST", ...) {
|
||||
mdro(x = x, country = "EUCAST", ...)
|
||||
mdr_tb <- function(x, guideline = "TB", ...) {
|
||||
mdro(x = x, guideline = "TB", ...)
|
||||
}
|
||||
|
||||
#' @rdname mdro
|
||||
#' @export
|
||||
eucast_exceptional_phenotypes <- function(x, guideline = "EUCAST", ...) {
|
||||
mdro(x = x, guideline = "EUCAST", ...)
|
||||
}
|
||||
|
||||
44
R/misc.R
44
R/misc.R
@ -87,43 +87,43 @@ percent <- function(x, round = 1, force_zero = FALSE, decimal.mark = getOption("
|
||||
|
||||
#' @importFrom crayon blue bold red
|
||||
#' @importFrom dplyr %>% pull
|
||||
search_type_in_df <- function(tbl, type) {
|
||||
search_type_in_df <- function(x, type) {
|
||||
# try to find columns based on type
|
||||
found <- NULL
|
||||
|
||||
colnames(tbl) <- trimws(colnames(tbl))
|
||||
colnames(x) <- trimws(colnames(x))
|
||||
|
||||
# -- mo
|
||||
if (type == "mo") {
|
||||
if ("mo" %in% lapply(tbl, class)) {
|
||||
found <- colnames(tbl)[lapply(tbl, class) == "mo"][1]
|
||||
} else if (any(colnames(tbl) %like% "^(mo|microorganism|organism|bacteria)")) {
|
||||
found <- colnames(tbl)[colnames(tbl) %like% "^(mo|microorganism|organism|bacteria)"][1]
|
||||
} else if (any(colnames(tbl) %like% "species")) {
|
||||
found <- colnames(tbl)[colnames(tbl) %like% "species"][1]
|
||||
if ("mo" %in% lapply(x, class)) {
|
||||
found <- colnames(x)[lapply(x, class) == "mo"][1]
|
||||
} else if (any(colnames(x) %like% "^(mo|microorganism|organism|bacteria)s?$")) {
|
||||
found <- colnames(x)[colnames(x) %like% "^(mo|microorganism|organism|bacteria)s?$"][1]
|
||||
} else if (any(colnames(x) %like% "species")) {
|
||||
found <- colnames(x)[colnames(x) %like% "species"][1]
|
||||
}
|
||||
|
||||
}
|
||||
# -- key antibiotics
|
||||
if (type == "keyantibiotics") {
|
||||
if (any(colnames(tbl) %like% "^key.*(ab|antibiotics)")) {
|
||||
found <- colnames(tbl)[colnames(tbl) %like% "^key.*(ab|antibiotics)"][1]
|
||||
if (any(colnames(x) %like% "^key.*(ab|antibiotics)")) {
|
||||
found <- colnames(x)[colnames(x) %like% "^key.*(ab|antibiotics)"][1]
|
||||
}
|
||||
}
|
||||
# -- date
|
||||
if (type == "date") {
|
||||
if (any(colnames(tbl) %like% "^(specimen date|specimen_date|spec_date)")) {
|
||||
if (any(colnames(x) %like% "^(specimen date|specimen_date|spec_date)")) {
|
||||
# WHONET support
|
||||
found <- colnames(tbl)[colnames(tbl) %like% "^(specimen date|specimen_date|spec_date)"][1]
|
||||
if (!any(class(tbl %>% pull(found)) %in% c("Date", "POSIXct"))) {
|
||||
found <- colnames(x)[colnames(x) %like% "^(specimen date|specimen_date|spec_date)"][1]
|
||||
if (!any(class(x %>% pull(found)) %in% c("Date", "POSIXct"))) {
|
||||
stop(red(paste0("ERROR: Found column `", bold(found), "` to be used as input for `col_", type,
|
||||
"`, but this column contains no valid dates. Transform its values to valid dates first.")),
|
||||
call. = FALSE)
|
||||
}
|
||||
} else {
|
||||
for (i in 1:ncol(tbl)) {
|
||||
if (any(class(tbl %>% pull(i)) %in% c("Date", "POSIXct"))) {
|
||||
found <- colnames(tbl)[i]
|
||||
for (i in 1:ncol(x)) {
|
||||
if (any(class(x %>% pull(i)) %in% c("Date", "POSIXct"))) {
|
||||
found <- colnames(x)[i]
|
||||
break
|
||||
}
|
||||
}
|
||||
@ -131,16 +131,16 @@ search_type_in_df <- function(tbl, type) {
|
||||
}
|
||||
# -- patient id
|
||||
if (type == "patient_id") {
|
||||
if (any(colnames(tbl) %like% "^(identification |patient|patid)")) {
|
||||
found <- colnames(tbl)[colnames(tbl) %like% "^(identification |patient|patid)"][1]
|
||||
if (any(colnames(x) %like% "^(identification |patient|patid)")) {
|
||||
found <- colnames(x)[colnames(x) %like% "^(identification |patient|patid)"][1]
|
||||
}
|
||||
}
|
||||
# -- specimen
|
||||
if (type == "specimen") {
|
||||
if (any(colnames(tbl) %like% "(specimen type|spec_type)")) {
|
||||
found <- colnames(tbl)[colnames(tbl) %like% "(specimen type|spec_type)"][1]
|
||||
} else if (any(colnames(tbl) %like% "^(specimen)")) {
|
||||
found <- colnames(tbl)[colnames(tbl) %like% "^(specimen)"][1]
|
||||
if (any(colnames(x) %like% "(specimen type|spec_type)")) {
|
||||
found <- colnames(x)[colnames(x) %like% "(specimen type|spec_type)"][1]
|
||||
} else if (any(colnames(x) %like% "^(specimen)")) {
|
||||
found <- colnames(x)[colnames(x) %like% "^(specimen)"][1]
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -31,7 +31,7 @@
|
||||
#' @param data a \code{data.frame} containing columns with class \code{rsi} (see \code{\link{as.rsi}})
|
||||
#' @param translate_ab a column name of the \code{\link{antibiotics}} data set to translate the antibiotic abbreviations to, using \code{\link{ab_property}}
|
||||
#' @inheritParams ab_property
|
||||
#' @param combine_SI a logical to indicate whether all values of S and I must be merged into one, so the output only consists of S+I vs. R (susceptible vs. resistant). This used to be the parameter \code{combine_IR}, but this now follows the redefinition by EUCAST about the interpretion of I (increased exposure) in 2019, see below. Default is now \code{TRUE}.
|
||||
#' @param combine_SI a logical to indicate whether all values of S and I must be merged into one, so the output only consists of S+I vs. R (susceptible vs. resistant). This used to be the parameter \code{combine_IR}, but this now follows the redefinition by EUCAST about the interpretion of I (increased exposure) in 2019, see section 'Interpretation of S, I and R' below. Default is \code{TRUE}.
|
||||
#' @param combine_IR a logical to indicate whether all values of I and R must be merged into one, so the output only consists of S vs. I+R (susceptible vs. non-susceptible). This is outdated, see parameter \code{combine_SI}.
|
||||
#' @inheritSection as.rsi Interpretation of S, I and R
|
||||
#' @details \strong{Remember that you should filter your table to let it contain only first isolates!} Use \code{\link{first_isolate}} to determine them in your data set.
|
||||
|
||||
@ -140,7 +140,7 @@ resistance_predict <- function(x,
|
||||
|
||||
# -- date
|
||||
if (is.null(col_date)) {
|
||||
col_date <- search_type_in_df(tbl = x, type = "date")
|
||||
col_date <- search_type_in_df(x = x, type = "date")
|
||||
}
|
||||
if (is.null(col_date)) {
|
||||
stop("`col_date` must be set.", call. = FALSE)
|
||||
|
||||
30
R/rsi.R
30
R/rsi.R
@ -39,9 +39,9 @@
|
||||
#' In 2019, EUCAST has decided to change the definitions of susceptibility testing categories S, I and R as shown below. Results of several consultations on the new definitions are available on the EUCAST website under "Consultations".
|
||||
#'
|
||||
#' \itemize{
|
||||
#' \item{\strong{S}}{Susceptible, standard dosing regimen: A microorganism is categorised as "Susceptible, standard dosing regimen", when there is a high likelihood of therapeutic success using a standard dosing regimen of the agent.}
|
||||
#' \item{\strong{I}}{Susceptible, increased exposure: A microorganism is categorised as "Susceptible, Increased exposure" when there is a high likelihood of therapeutic success because exposure to the agent is increased by adjusting the dosing regimen or by its concentration at the site of infection.}
|
||||
#' \item{\strong{R}}{Resistant: A microorganism is categorised as "Resistant" when there is a high likelihood of therapeutic failure even when there is increased exposure.}
|
||||
#' \item{\strong{S} - }{Susceptible, standard dosing regimen: A microorganism is categorised as "Susceptible, standard dosing regimen", when there is a high likelihood of therapeutic success using a standard dosing regimen of the agent.}
|
||||
#' \item{\strong{I} - }{Susceptible, increased exposure: A microorganism is categorised as "Susceptible, Increased exposure" when there is a high likelihood of therapeutic success because exposure to the agent is increased by adjusting the dosing regimen or by its concentration at the site of infection.}
|
||||
#' \item{\strong{R} - }{Resistant: A microorganism is categorised as "Resistant" when there is a high likelihood of therapeutic failure even when there is increased exposure.}
|
||||
#' }
|
||||
#'
|
||||
#' Exposure is a function of how the mode of administration, dose, dosing interval, infusion time, as well as distribution and excretion of the antimicrobial agent will influence the infecting organism at the site of infection.
|
||||
@ -259,9 +259,9 @@ exec_as.rsi <- function(method, x, mo, ab, guideline) {
|
||||
#' @importFrom crayon red blue
|
||||
#' @export
|
||||
as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
|
||||
tbl_ <- x
|
||||
x <- x
|
||||
|
||||
ab_cols <- colnames(tbl_)[sapply(tbl_, function(x) is.mic(x) | is.disk(x))]
|
||||
ab_cols <- colnames(x)[sapply(x, function(y) is.mic(y) | is.disk(y))]
|
||||
if (length(ab_cols) == 0) {
|
||||
stop("No columns with MIC values or disk zones found in this data set. Use as.mic or as.disk to transform antibiotic columns.", call. = FALSE)
|
||||
}
|
||||
@ -269,14 +269,14 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
|
||||
# try to find columns based on type
|
||||
# -- mo
|
||||
if (is.null(col_mo)) {
|
||||
col_mo <- search_type_in_df(tbl = tbl_, type = "mo")
|
||||
col_mo <- search_type_in_df(x = x, type = "mo")
|
||||
}
|
||||
if (is.null(col_mo)) {
|
||||
stop("`col_mo` must be set.", call. = FALSE)
|
||||
}
|
||||
|
||||
# transform all MICs
|
||||
ab_cols <- colnames(tbl_)[sapply(tbl_, is.mic)]
|
||||
ab_cols <- colnames(x)[sapply(x, is.mic)]
|
||||
if (length(ab_cols) > 0) {
|
||||
for (i in 1:length(ab_cols)) {
|
||||
if (is.na(suppressWarnings(as.ab(ab_cols[i])))) {
|
||||
@ -284,16 +284,16 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
|
||||
next
|
||||
}
|
||||
message(blue(paste0("Interpreting column `", bold(ab_cols[i]), "` (", ab_name(ab_cols[i], tolower = TRUE), ")...")), appendLF = FALSE)
|
||||
tbl_[, ab_cols[i]] <- exec_as.rsi(method = "mic",
|
||||
x = tbl_ %>% pull(ab_cols[i]),
|
||||
mo = tbl_ %>% pull(col_mo),
|
||||
x[, ab_cols[i]] <- exec_as.rsi(method = "mic",
|
||||
x = x %>% pull(ab_cols[i]),
|
||||
mo = x %>% pull(col_mo),
|
||||
ab = as.ab(ab_cols[i]),
|
||||
guideline = guideline)
|
||||
message(blue(" OK."))
|
||||
}
|
||||
}
|
||||
# transform all disks
|
||||
ab_cols <- colnames(tbl_)[sapply(tbl_, is.disk)]
|
||||
ab_cols <- colnames(x)[sapply(x, is.disk)]
|
||||
if (length(ab_cols) > 0) {
|
||||
for (i in 1:length(ab_cols)) {
|
||||
if (is.na(suppressWarnings(as.ab(ab_cols[i])))) {
|
||||
@ -301,16 +301,16 @@ as.rsi.data.frame <- function(x, col_mo = NULL, guideline = "EUCAST", ...) {
|
||||
next
|
||||
}
|
||||
message(blue(paste0("Interpreting column `", bold(ab_cols[i]), "` (", ab_name(ab_cols[i], tolower = TRUE), ")...")), appendLF = FALSE)
|
||||
tbl_[, ab_cols[i]] <- exec_as.rsi(method = "disk",
|
||||
x = tbl_ %>% pull(ab_cols[i]),
|
||||
mo = tbl_ %>% pull(col_mo),
|
||||
x[, ab_cols[i]] <- exec_as.rsi(method = "disk",
|
||||
x = x %>% pull(ab_cols[i]),
|
||||
mo = x %>% pull(col_mo),
|
||||
ab = as.ab(ab_cols[i]),
|
||||
guideline = guideline)
|
||||
message(blue(" OK."))
|
||||
}
|
||||
}
|
||||
|
||||
tbl_
|
||||
x
|
||||
}
|
||||
|
||||
#' @rdname as.rsi
|
||||
|
||||
Reference in New Issue
Block a user