diff --git a/DESCRIPTION b/DESCRIPTION index b6546527..0e307b06 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: AMR -Version: 1.8.2.9052 -Date: 2022-11-17 +Version: 1.8.2.9053 +Date: 2022-11-24 Title: Antimicrobial Resistance Data Analysis Description: Functions to simplify and standardise antimicrobial resistance (AMR) data analysis and to work with microbial and antimicrobial properties by diff --git a/NEWS.md b/NEWS.md index 20b07483..6b5f8e3a 100755 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# AMR 1.8.2.9052 +# AMR 1.8.2.9053 This version will eventually become v2.0! We're happy to reach a new major milestone soon! @@ -45,13 +45,17 @@ This version will eventually become v2.0! We're happy to reach a new major miles * Support for using antibiotic selectors in scoped `dplyr` verbs (with or without `vars()`), such as in: `... %>% summarise_at(aminoglycosides(), resistance)`, see `resistance()` ### Changed -* Fix for using `as.rsi()` on certain EUCAST breakpoints for MIC values -* Fix for using `as.rsi()` on `NA` values (e.g. `as.rsi(as.disk(NA), ...)`) -* Fix for using `as.rsi()` on bug-drug combinations with multiple breakpoints for different body sites -* Removed `as.integer()` for MIC values, since MIC are not integer values and running `table()` on MIC values consequently failed for not being able to retrieve the level position (as that's how normally `as.integer()` on `factor`s work) +* Fixes and changes for using `as.rsi()`: + * On certain EUCAST breakpoints for MIC values + * On `NA` values (e.g. `as.rsi(as.disk(NA), ...)`) + * On bug-drug combinations with multiple breakpoints for different body sites + * Interpretation from MIC and disk zones is now more informative about availability of breakpoints and more robust + * The default guideline (EUCAST) can now be changed with `options(AMR_guideline = "...")` +* Removed the `as.integer()` method for MIC values, since MIC are not integer values and running `table()` on MIC values consequently failed for not being able to retrieve the level position (as that's how normally `as.integer()` on `factor`s work) * `droplevels()` on MIC will now return a common `factor` at default and will lose the `mic` class. Use `droplevels(..., as.mic = TRUE)` to keep the `mic` class. * Small fix for using `ab_from_text()` * Fixes for reading in text files using `set_mo_source()`, which now also allows the source file to contain valid taxonomic names instead of only valid microorganism ID of this package +* Fixed a bug for `mdro()` when using similar column names with the Magiorakos guideline * Using any `random_*()` function (such as `random_mic()`) is now possible by directly calling the package without loading it first: `AMR::random_mic(10)` * Added *Toxoplasma gondii* (`P_TXPL_GOND`) to the `microorganisms` data set, together with its genus, family, and order * Changed value in column `prevalence` of the `microorganisms` data set from 3 to 2 for these genera: *Acholeplasma*, *Alistipes*, *Alloprevotella*, *Bergeyella*, *Borrelia*, *Brachyspira*, *Butyricimonas*, *Cetobacterium*, *Chlamydia*, *Chlamydophila*, *Deinococcus*, *Dysgonomonas*, *Elizabethkingia*, *Empedobacter*, *Haloarcula*, *Halobacterium*, *Halococcus*, *Myroides*, *Odoribacter*, *Ornithobacterium*, *Parabacteroides*, *Pedobacter*, *Phocaeicola*, *Porphyromonas*, *Riemerella*, *Sphingobacterium*, *Streptobacillus*, *Tenacibaculum*, *Terrimonas*, *Victivallis*, *Wautersiella*, *Weeksella* diff --git a/R/aa_helper_functions.R b/R/aa_helper_functions.R index cef40799..c4642843 100755 --- a/R/aa_helper_functions.R +++ b/R/aa_helper_functions.R @@ -469,7 +469,7 @@ word_wrap <- function(..., } # format backticks - msg <- gsub("(`.+?`)", font_grey_bg("\\1"), msg) + msg <- gsub("`(.+?)`", font_grey_bg("\\1"), msg) # clean introduced whitespace between fullstops msg <- gsub("[.] +[.]", "..", msg) @@ -968,7 +968,7 @@ unique_call_id <- function(entire_session = FALSE, match_fn = NULL) { if (!isTRUE(in_test)) { for (i in seq_len(length(calls))) { call_clean <- gsub("[^a-zA-Z0-9_().-]", "", as.character(calls[[i]]), perl = TRUE) - if (any(call_clean %like% paste0(match_fn, "\\("), na.rm = TRUE)) { + if (match_fn %in% call_clean || any(call_clean %like% paste0(match_fn, "\\("), na.rm = TRUE)) { return(c( envir = gsub("", "\\1", utils::capture.output(sys.frames()[[1]]), perl = TRUE), call = paste0(deparse(calls[[i]]), collapse = "") @@ -1171,9 +1171,19 @@ font_italic <- function(..., collapse = " ") { font_underline <- function(..., collapse = " ") { try_colour(..., before = "\033[4m", after = "\033[24m", collapse = collapse) } +font_url <- function(url, txt = url) { + if (tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE)) { + paste0("\033]8;;", url, "\a", txt, "\033]8;;\a") + } else { + url + } +} font_stripstyle <- function(x) { + # remove URLs + x <- gsub("\033]8;;(.*?)\a.*?\033]8;;\a", "\\1", x) # from crayon:::ansi_regex - gsub("(?:(?:\\x{001b}\\[)|\\x{009b})(?:(?:[0-9]{1,3})?(?:(?:;[0-9]{0,3})*)?[A-M|f-m])|\\x{001b}[A-M]", "", x, perl = TRUE) + x <- gsub("(?:(?:\\x{001b}\\[)|\\x{009b})(?:(?:[0-9]{1,3})?(?:(?:;[0-9]{0,3})*)?[A-M|f-m])|\\x{001b}[A-M]", "", x, perl = TRUE) + x } progress_ticker <- function(n = 1, n_min = 0, print = TRUE, ...) { diff --git a/R/mdro.R b/R/mdro.R index 51cd0982..e149be68 100755 --- a/R/mdro.R +++ b/R/mdro.R @@ -193,13 +193,17 @@ mdro <- function(x = NULL, meet_criteria(combine_SI, allow_class = "logical", has_length = 1) meet_criteria(verbose, allow_class = "logical", has_length = 1) meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1) - + + if (!any(is.rsi.eligible(x))) { + stop_("There were no possible R/SI columns found in the data set. Transform columns with `as.rsi()` for valid antimicrobial interpretations.") + } + info.bak <- info # don't thrown info's more than once per call if (isTRUE(info)) { info <- message_not_thrown_before("mdro") } - + if (interactive() && isTRUE(verbose) && isTRUE(info)) { txt <- paste0( "WARNING: In Verbose mode, the mdro() function does not return the MDRO results, but instead returns a data set in logbook form with extensive info about which isolates would be MDRO-positive, or why they are not.", @@ -217,7 +221,7 @@ mdro <- function(x = NULL, return(x) } } - + group_msg <- "" if (isTRUE(info.bak)) { # print group name if used in dplyr::group_by() @@ -239,15 +243,15 @@ mdro <- function(x = NULL, } } } - + # force regular [data.frame], not a tibble or data.table x <- as.data.frame(x, stringsAsFactors = FALSE) - + if (pct_required_classes > 1) { # allow pct_required_classes = 75 -> pct_required_classes = 0.75 pct_required_classes <- pct_required_classes / 100 } - + guideline.bak <- guideline if (is.list(guideline)) { # Custom MDRO guideline --------------------------------------------------- @@ -256,8 +260,8 @@ mdro <- function(x = NULL, txt <- paste0( "Determining MDROs based on custom rules", ifelse(isTRUE(attributes(guideline)$as_factor), - paste0(", resulting in factor levels: ", paste0(attributes(guideline)$values, collapse = " < ")), - "" + paste0(", resulting in factor levels: ", paste0(attributes(guideline)$values, collapse = " < ")), + "" ), "." ) @@ -310,7 +314,7 @@ mdro <- function(x = NULL, "invalid guideline: ", guideline.bak ) guideline <- list(code = guideline) - + # try to find columns based on type # -- mo if (is.null(col_mo)) { @@ -325,55 +329,55 @@ mdro <- function(x = NULL, col_mo <- "mo" } stop_if(is.null(col_mo), "`col_mo` must be set") - + if (guideline$code == "cmi2012") { guideline$name <- "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance." guideline$author <- "Magiorakos AP, Srinivasan A, Carey RB, ..., Vatopoulos A, Weber JT, Monnet DL" guideline$version <- NA - guideline$source_url <- "Clinical Microbiology and Infection 18:3, 2012; doi: 10.1111/j.1469-0691.2011.03570.x" + guideline$source_url <- paste0("Clinical Microbiology and Infection 18:3, 2012; ", font_url("https://doi.org/10.1111/j.1469-0691.2011.03570.x", "doi: 10.1111/j.1469-0691.2011.03570.x")) guideline$type <- "MDRs/XDRs/PDRs" } else if (guideline$code == "eucast3.1") { guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Exceptional Phenotypes Tables\"" guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)" guideline$version <- "3.1, 2016" - guideline$source_url <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf" + guideline$source_url <- font_url("https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/Expert_rules_intrinsic_exceptional_V3.1.pdf", "Direct download") guideline$type <- "EUCAST Exceptional Phenotypes" } else if (guideline$code == "eucast3.2") { guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Unusual Phenotypes\"" guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)" guideline$version <- "3.2, February 2020" - guideline$source_url <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2020/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.2_20200225.pdf" + guideline$source_url <- font_url("https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2020/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.2_20200225.pdf", "Direct download") guideline$type <- "EUCAST Unusual Phenotypes" } else if (guideline$code == "eucast3.3") { guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Unusual Phenotypes\"" guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)" guideline$version <- "3.3, October 2021" - guideline$source_url <- "https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2021/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.3_20211018.pdf" + guideline$source_url <- font_url("https://www.eucast.org/fileadmin/src/media/PDFs/EUCAST_files/Expert_Rules/2021/Intrinsic_Resistance_and_Unusual_Phenotypes_Tables_v3.3_20211018.pdf", "Direct download") guideline$type <- "EUCAST Unusual Phenotypes" } 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, 2014" - guideline$source_url <- "https://www.who.int/publications/i/item/9789241548809" + guideline$source_url <- font_url("https://www.who.int/publications/i/item/9789241548809", "Direct download") guideline$type <- "MDR-TB's" - + # support per country: } else if (guideline$code == "mrgn") { guideline$name <- "Cross-border comparison of the Dutch and German guidelines on multidrug-resistant Gram-negative microorganisms" guideline$author <- "M\u00fcller J, Voss A, K\u00f6ck R, ..., Kern WV, Wendt C, Friedrich AW" guideline$version <- NA - guideline$source_url <- "Antimicrobial Resistance and Infection Control 4:7, 2015; doi: 10.1186/s13756-015-0047-6" + guideline$source_url <- paste0("Antimicrobial Resistance and Infection Control 4:7, 2015; ", font_url("https://doi.org/10.1186/s13756-015-0047-6", "doi: 10.1186/s13756-015-0047-6")) guideline$type <- "MRGNs" } else if (guideline$code == "brmo") { 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_url <- "https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH" + guideline$source_url <- font_url("https://www.rivm.nl/Documenten_en_publicaties/Professioneel_Praktisch/Richtlijnen/Infectieziekten/WIP_Richtlijnen/WIP_Richtlijnen/Ziekenhuizen/WIP_richtlijn_BRMO_Bijzonder_Resistente_Micro_Organismen_ZKH", "Direct download") guideline$type <- "BRMOs" } else { stop("This guideline is currently unsupported: ", guideline$code, call. = FALSE) } - + if (guideline$code == "cmi2012") { cols_ab <- get_column_abx( x = x, @@ -618,7 +622,7 @@ mdro <- function(x = NULL, } cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"]))) } - + # nolint start AMC <- cols_ab["AMC"] AMK <- cols_ab["AMK"] @@ -763,13 +767,13 @@ mdro <- function(x = NULL, abx_tb <- abx_tb[!is.na(abx_tb)] stop_if(guideline$code == "tb" & length(abx_tb) == 0, "no antimycobacterials found in data set") # nolint end - + if (isTRUE(combine_SI)) { search_result <- "R" } else { search_result <- c("R", "I") } - + if (isTRUE(info)) { if (isTRUE(combine_SI)) { cat(font_red("\nOnly results with 'R' are considered as resistance. Use `combine_SI = FALSE` to also consider 'I' as resistance.\n")) @@ -777,18 +781,18 @@ mdro <- function(x = NULL, cat(font_red("\nResults with 'R' or 'I' are considered as resistance. Use `combine_SI = TRUE` to only consider 'R' as resistance.\n")) } cat("\n", word_wrap("Determining multidrug-resistant organisms (MDRO), according to:"), "\n", - word_wrap(paste0(font_bold("Guideline: "), font_italic(guideline$name)), extra_indent = 11, as_note = FALSE), "\n", - word_wrap(paste0(font_bold("Author(s): "), guideline$author), extra_indent = 11, as_note = FALSE), "\n", - ifelse(!is.na(guideline$version), - paste0(word_wrap(paste0(font_bold("Version: "), guideline$version), extra_indent = 11, as_note = FALSE), "\n"), - "" - ), - paste0(font_bold("Source: "), guideline$source_url), - "\n\n", - sep = "" + word_wrap(paste0(font_bold("Guideline: "), font_italic(guideline$name)), extra_indent = 11, as_note = FALSE), "\n", + word_wrap(paste0(font_bold("Author(s): "), guideline$author), extra_indent = 11, as_note = FALSE), "\n", + ifelse(!is.na(guideline$version), + paste0(word_wrap(paste0(font_bold("Version: "), guideline$version), extra_indent = 11, as_note = FALSE), "\n"), + "" + ), + paste0(font_bold("Source: "), guideline$source_url), + "\n\n", + sep = "" ) } - + ab_missing <- function(ab) { isTRUE(ab %in% c(NULL, NA)) | length(ab) == 0 } @@ -800,7 +804,7 @@ mdro <- function(x = NULL, out[is.na(out)] <- FALSE out } - + # antibiotic classes # nolint start aminoglycosides <- c(TOB, GEN) @@ -811,7 +815,7 @@ mdro <- function(x = NULL, carbapenems <- c(DOR, ETP, IPM, MEM, MEV) fluoroquinolones <- c(CIP, ENX, FLE, GAT, GEM, GRX, LVX, LOM, MFX, NOR, OFX, PAZ, PEF, PRU, RFL, SPX, TMX, TVA) # nolint end - + # helper function for editing the table trans_tbl <- function(to, rows, cols, any_all) { cols <- cols[!ab_missing(cols)] @@ -840,14 +844,14 @@ mdro <- function(x = NULL, ) } ) - + if (any_all == "any") { search_function <- any } else if (any_all == "all") { search_function <- all } x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]), - stringsAsFactors = FALSE + stringsAsFactors = FALSE )) rows_affected <- vapply( FUN.VALUE = logical(1), @@ -866,7 +870,7 @@ mdro <- function(x = NULL, ) } } - + trans_tbl2 <- function(txt, rows, lst) { if (isTRUE(info)) { message_(txt, "...", appendLF = FALSE, as_note = FALSE) @@ -874,6 +878,9 @@ mdro <- function(x = NULL, if (length(rows) > 0) { # function specific for the CMI paper of 2012 (Magiorakos et al.) lst_vector <- unlist(lst)[!is.na(unlist(lst))] + # keep only unique ones: + lst_vector <- lst_vector[!duplicated(paste(lst_vector, names(lst_vector)))] + x[, lst_vector] <- as.data.frame(lapply( x[, lst_vector, drop = FALSE], function(col) as.rsi(col) @@ -892,7 +899,7 @@ mdro <- function(x = NULL, )) } ) - + if (isTRUE(verbose)) { x[rows, "columns_nonsusceptible"] <<- vapply( FUN.VALUE = character(1), @@ -920,17 +927,17 @@ mdro <- function(x = NULL, ) # for PDR; all drugs are R (or I if combine_SI = FALSE) x_transposed <- as.list(as.data.frame(t(x[rows, lst_vector, drop = FALSE]), - stringsAsFactors = FALSE + stringsAsFactors = FALSE )) row_filter <- vapply(FUN.VALUE = logical(1), x_transposed, function(y) all(y %in% search_result, na.rm = TRUE)) x[which(row_filter), "classes_affected"] <<- 999 } - + if (isTRUE(info)) { message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE) } } - + x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE])) # rename col_mo to prevent interference with joined columns colnames(x)[colnames(x) == col_mo] <- ".col_mo" @@ -941,12 +948,12 @@ mdro <- function(x = NULL, x$row_number <- seq_len(nrow(x)) x$reason <- paste0("not covered by ", toupper(guideline$code), " guideline") x$columns_nonsusceptible <- "" - + if (guideline$code == "cmi2012") { # CMI, 2012 --------------------------------------------------------------- # Non-susceptible = R and I # (see header 'Approaches to Creating Definitions for MDR, XDR and PDR' in paper) - + # take amoxicillin if ampicillin is unavailable if (is.na(AMP) && !is.na(AMX)) { if (isTRUE(verbose)) { @@ -967,87 +974,87 @@ mdro <- function(x = NULL, } CTX <- CRO } - + # intrinsic resistant must not be considered for the determination of MDR, # so let's just remove them, meticulously following the paper x[which(x$genus == "Enterococcus" & x$species == "faecium"), ab_NA(IPM)] <- NA x[which(x$genus == "Enterococcus" & x$species == "faecalis"), ab_NA(QDA)] <- NA x[which((x$genus == "Providencia" & x$species == "rettgeri") | - (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(GEN, TOB, NET))] <- NA + (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(GEN, TOB, NET))] <- NA x[which(x$genus == "Escherichia" & x$species == "hermannii"), ab_NA(c(TCC, TZP))] <- NA x[which((x$genus == "Citrobacter" & x$species == "freundii") | - (x$genus == "Enterobacter" & x$species == "aerogenes") | - (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) - | (x$genus == "Enterobacter" & x$species == "cloacae") | - (x$genus == "Hafnia" & x$species == "alvei") | - (x$genus == "Morganella" & x$species == "morganii") | - (x$genus == "Proteus" & x$species == "penneri") | - (x$genus == "Proteus" & x$species == "vulgaris") | - (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CZO)] <- NA + (x$genus == "Enterobacter" & x$species == "aerogenes") | + (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) + | (x$genus == "Enterobacter" & x$species == "cloacae") | + (x$genus == "Hafnia" & x$species == "alvei") | + (x$genus == "Morganella" & x$species == "morganii") | + (x$genus == "Proteus" & x$species == "penneri") | + (x$genus == "Proteus" & x$species == "vulgaris") | + (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CZO)] <- NA x[which((x$genus == "Morganella" & x$species == "morganii") | - (x$genus == "Proteus" & x$species == "penneri") | - (x$genus == "Proteus" & x$species == "vulgaris") | - (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CXM)] <- NA + (x$genus == "Proteus" & x$species == "penneri") | + (x$genus == "Proteus" & x$species == "vulgaris") | + (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CXM)] <- NA x[which((x$genus == "Morganella" & x$species == "morganii") | - (x$genus == "Proteus" & x$species == "mirabilis") | - (x$genus == "Proteus" & x$species == "penneri") | - (x$genus == "Proteus" & x$species == "vulgaris") | - (x$genus == "Providencia" & x$species == "rettgeri") | - (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TGC)] <- NA + (x$genus == "Proteus" & x$species == "mirabilis") | + (x$genus == "Proteus" & x$species == "penneri") | + (x$genus == "Proteus" & x$species == "vulgaris") | + (x$genus == "Providencia" & x$species == "rettgeri") | + (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TGC)] <- NA x[which((x$genus == "Citrobacter" & x$species == "koseri") | - (x$genus == "Citrobacter" & x$species == "freundii") | - (x$genus == "Enterobacter" & x$species == "aerogenes") | - (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) - | (x$genus == "Enterobacter" & x$species == "cloacae") | - (x$genus == "Escherichia" & x$species == "hermannii") | - (x$genus == "Hafnia" & x$species == "alvei") | - (x$genus == "Klebsiella") | - (x$genus == "Morganella" & x$species == "morganii") | - (x$genus == "Proteus" & x$species == "penneri") | - (x$genus == "Proteus" & x$species == "vulgaris") | - (x$genus == "Providencia" & x$species == "rettgeri") | - (x$genus == "Providencia" & x$species == "stuartii") | - (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMP)] <- NA + (x$genus == "Citrobacter" & x$species == "freundii") | + (x$genus == "Enterobacter" & x$species == "aerogenes") | + (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) + | (x$genus == "Enterobacter" & x$species == "cloacae") | + (x$genus == "Escherichia" & x$species == "hermannii") | + (x$genus == "Hafnia" & x$species == "alvei") | + (x$genus == "Klebsiella") | + (x$genus == "Morganella" & x$species == "morganii") | + (x$genus == "Proteus" & x$species == "penneri") | + (x$genus == "Proteus" & x$species == "vulgaris") | + (x$genus == "Providencia" & x$species == "rettgeri") | + (x$genus == "Providencia" & x$species == "stuartii") | + (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMP)] <- NA x[which((x$genus == "Citrobacter" & x$species == "freundii") | - (x$genus == "Enterobacter" & x$species == "aerogenes") | - (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) - | (x$genus == "Enterobacter" & x$species == "cloacae") | - (x$genus == "Hafnia" & x$species == "alvei") | - (x$genus == "Morganella" & x$species == "morganii") | - (x$genus == "Providencia" & x$species == "rettgeri") | - (x$genus == "Providencia" & x$species == "stuartii") | - (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMC)] <- NA + (x$genus == "Enterobacter" & x$species == "aerogenes") | + (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) + | (x$genus == "Enterobacter" & x$species == "cloacae") | + (x$genus == "Hafnia" & x$species == "alvei") | + (x$genus == "Morganella" & x$species == "morganii") | + (x$genus == "Providencia" & x$species == "rettgeri") | + (x$genus == "Providencia" & x$species == "stuartii") | + (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMC)] <- NA x[which((x$genus == "Citrobacter" & x$species == "freundii") | - (x$genus == "Citrobacter" & x$species == "koseri") | - (x$genus == "Enterobacter" & x$species == "aerogenes") | - (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) - | (x$genus == "Enterobacter" & x$species == "cloacae") | - (x$genus == "Hafnia" & x$species == "alvei") | - (x$genus == "Providencia" & x$species == "rettgeri") | - (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(SAM)] <- NA + (x$genus == "Citrobacter" & x$species == "koseri") | + (x$genus == "Enterobacter" & x$species == "aerogenes") | + (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) + | (x$genus == "Enterobacter" & x$species == "cloacae") | + (x$genus == "Hafnia" & x$species == "alvei") | + (x$genus == "Providencia" & x$species == "rettgeri") | + (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(SAM)] <- NA x[which((x$genus == "Morganella" & x$species == "morganii") | - (x$genus == "Proteus" & x$species == "mirabilis") | - (x$genus == "Proteus" & x$species == "penneri") | - (x$genus == "Proteus" & x$species == "vulgaris") | - (x$genus == "Providencia" & x$species == "rettgeri") | - (x$genus == "Providencia" & x$species == "stuartii") | - (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(COL)] <- NA + (x$genus == "Proteus" & x$species == "mirabilis") | + (x$genus == "Proteus" & x$species == "penneri") | + (x$genus == "Proteus" & x$species == "vulgaris") | + (x$genus == "Providencia" & x$species == "rettgeri") | + (x$genus == "Providencia" & x$species == "stuartii") | + (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(COL)] <- NA x[which((x$genus == "Morganella" & x$species == "morganii") | - (x$genus == "Proteus" & x$species == "mirabilis") | - (x$genus == "Proteus" & x$species == "penneri") | - (x$genus == "Proteus" & x$species == "vulgaris") | - (x$genus == "Providencia" & x$species == "rettgeri") | - (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TCY)] <- NA + (x$genus == "Proteus" & x$species == "mirabilis") | + (x$genus == "Proteus" & x$species == "penneri") | + (x$genus == "Proteus" & x$species == "vulgaris") | + (x$genus == "Providencia" & x$species == "rettgeri") | + (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TCY)] <- NA x[which((x$genus == "Morganella" & x$species == "morganii") | - (x$genus == "Proteus" & x$species == "penneri") | - (x$genus == "Proteus" & x$species == "vulgaris") | - (x$genus == "Providencia" & x$species == "rettgeri") | - (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(DOX, MNO))] <- NA - + (x$genus == "Proteus" & x$species == "penneri") | + (x$genus == "Proteus" & x$species == "vulgaris") | + (x$genus == "Providencia" & x$species == "rettgeri") | + (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(DOX, MNO))] <- NA + x$classes_in_guideline <- NA_integer_ x$classes_available <- NA_integer_ x$classes_affected <- NA_integer_ - + # now add the MDR levels to the data trans_tbl( 2, @@ -1149,7 +1156,7 @@ mdro <- function(x = NULL, c(TCY, DOX, MNO) ) ) - + # now set MDROs: # MDR (=2): >=3 classes affected x[which(x$classes_affected >= 3), "MDRO"] <- 2 @@ -1161,7 +1168,7 @@ mdro <- function(x = NULL, " out of ", x$classes_available[which(x$classes_affected >= 3)], " available classes" ) } - + # XDR (=3): all but <=2 classes affected x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3 if (isTRUE(verbose)) { @@ -1170,7 +1177,7 @@ mdro <- function(x = NULL, " out of ", x$classes_in_guideline[which(x$MDRO == 3)], " classes)" ) } - + # PDR (=4): all drugs are R x[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available), "MDRO"] <- 4 if (isTRUE(verbose)) { @@ -1181,7 +1188,7 @@ mdro <- function(x = NULL, ifelse(!isTRUE(combine_SI), " or I", "") ) } - + # not enough classes available x[which(x$MDRO %in% c(1, 3) & x$classes_available < floor(x$classes_in_guideline * pct_required_classes)), "MDRO"] <- -1 if (isTRUE(verbose)) { @@ -1191,18 +1198,18 @@ mdro <- function(x = NULL, " (~", percentage(pct_required_classes), " of ", x$classes_in_guideline[which(x$MDRO == -1)], ")" ) } - + # add antibiotic names of resistant ones to verbose output } - + if (guideline$code == "eucast3.1") { # EUCAST 3.1 -------------------------------------------------------------- # Table 5 trans_tbl( 3, which(x$order == "Enterobacterales" | - (x$genus == "Pseudomonas" & x$species == "aeruginosa") | - x$genus == "Acinetobacter"), + (x$genus == "Pseudomonas" & x$species == "aeruginosa") | + x$genus == "Acinetobacter"), COL, "all" ) @@ -1287,17 +1294,17 @@ mdro <- function(x = NULL, "any" ) } - + if (guideline$code == "eucast3.2") { # EUCAST 3.2 -------------------------------------------------------------- # Table 6 trans_tbl( 3, which((x$order == "Enterobacterales" & - !x$family == "Morganellaceae" & - !(x$genus == "Serratia" & x$species == "marcescens")) | - (x$genus == "Pseudomonas" & x$species == "aeruginosa") | - x$genus == "Acinetobacter"), + !x$family == "Morganellaceae" & + !(x$genus == "Serratia" & x$species == "marcescens")) | + (x$genus == "Pseudomonas" & x$species == "aeruginosa") | + x$genus == "Acinetobacter"), COL, "all" ) @@ -1388,7 +1395,7 @@ mdro <- function(x = NULL, "any" ) } - + if (guideline$code == "eucast3.3") { # EUCAST 3.3 -------------------------------------------------------------- # note: this guideline is equal to EUCAST 3.2 - no MDRO insights changed @@ -1396,10 +1403,10 @@ mdro <- function(x = NULL, trans_tbl( 3, which((x$order == "Enterobacterales" & - !x$family == "Morganellaceae" & - !(x$genus == "Serratia" & x$species == "marcescens")) | - (x$genus == "Pseudomonas" & x$species == "aeruginosa") | - x$genus == "Acinetobacter"), + !x$family == "Morganellaceae" & + !(x$genus == "Serratia" & x$species == "marcescens")) | + (x$genus == "Pseudomonas" & x$species == "aeruginosa") | + x$genus == "Acinetobacter"), COL, "all" ) @@ -1490,72 +1497,72 @@ mdro <- function(x = NULL, "any" ) } - + if (guideline$code == "mrgn") { # Germany ----------------------------------------------------------------- - + # Table 1 trans_tbl( 2, # 3MRGN which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification - (x$genus == "Acinetobacter" & x$species == "baumannii")) & - try_ab(x[, PIP, drop = TRUE] == "R") & - (try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) & - (try_ab(x[, IPM, drop = TRUE] != "R") | try_ab(x[, MEM, drop = TRUE] != "R")) & - try_ab(x[, CIP, drop = TRUE] == "R")), + (x$genus == "Acinetobacter" & x$species == "baumannii")) & + try_ab(x[, PIP, drop = TRUE] == "R") & + (try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) & + (try_ab(x[, IPM, drop = TRUE] != "R") | try_ab(x[, MEM, drop = TRUE] != "R")) & + try_ab(x[, CIP, drop = TRUE] == "R")), c(PIP, CTX, CAZ, IPM, MEM, CIP), "any" ) - + trans_tbl( 3, # 4MRGN, overwrites 3MRGN if applicable which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification - (x$genus == "Acinetobacter" & x$species == "baumannii")) & - try_ab(x[, PIP, drop = TRUE] == "R") & - (try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) & - (try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) & - try_ab(x[, CIP, drop = TRUE] == "R")), + (x$genus == "Acinetobacter" & x$species == "baumannii")) & + try_ab(x[, PIP, drop = TRUE] == "R") & + (try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) & + (try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) & + try_ab(x[, CIP, drop = TRUE] == "R")), c(PIP, CTX, CAZ, IPM, MEM, CIP), "any" ) - + trans_tbl( 3, # 4MRGN, overwrites 3MRGN if applicable which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification - (x$genus == "Acinetobacter" & x$species == "baumannii")) & - (try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R"))), + (x$genus == "Acinetobacter" & x$species == "baumannii")) & + (try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R"))), c(IPM, MEM), "any" ) - + trans_tbl( 2, # 3MRGN, if only 1 group is S which(x$genus == "Pseudomonas" & x$species == "aeruginosa" & - try_ab(x[, PIP, drop = TRUE] == "S") + - try_ab(x[, CTX, drop = TRUE] == "S") + - try_ab(x[, CAZ, drop = TRUE] == "S") + - try_ab(x[, IPM, drop = TRUE] == "S") + - try_ab(x[, MEM, drop = TRUE] == "S") + - try_ab(x[, CIP, drop = TRUE] == "S") == 1), + try_ab(x[, PIP, drop = TRUE] == "S") + + try_ab(x[, CTX, drop = TRUE] == "S") + + try_ab(x[, CAZ, drop = TRUE] == "S") + + try_ab(x[, IPM, drop = TRUE] == "S") + + try_ab(x[, MEM, drop = TRUE] == "S") + + try_ab(x[, CIP, drop = TRUE] == "S") == 1), c(PIP, CTX, CAZ, IPM, MEM, CIP), "any" ) - + trans_tbl( 3, # 4MRGN otherwise which((x$genus == "Pseudomonas" & x$species == "aeruginosa") & - try_ab(x[, PIP, drop = TRUE] == "R") & - (try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) & - (try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) & - try_ab(x[, CIP, drop = TRUE] == "R")), + try_ab(x[, PIP, drop = TRUE] == "R") & + (try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) & + (try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) & + try_ab(x[, CIP, drop = TRUE] == "R")), c(PIP, CTX, CAZ, IPM, MEM, CIP), "any" ) - + x[which(x$MDRO == 2), "reason"] <- "3MRGN" x[which(x$MDRO == 3), "reason"] <- "4MRGN" } - + if (guideline$code == "brmo") { # Netherlands ------------------------------------------------------------- aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)] @@ -1568,7 +1575,7 @@ mdro <- function(x = NULL, if (length(ESBLs) != 2) { ESBLs <- character(0) } - + # Table 1 trans_tbl( 3, @@ -1576,21 +1583,21 @@ mdro <- function(x = NULL, c(aminoglycosides, fluoroquinolones), "all" ) - + trans_tbl( 2, which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification carbapenems, "any" ) - + trans_tbl( 2, which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification ESBLs, "all" ) - + # Table 2 trans_tbl( 2, @@ -1604,19 +1611,19 @@ mdro <- function(x = NULL, c(aminoglycosides, fluoroquinolones), "all" ) - + trans_tbl( 3, which(x$genus == "Stenotrophomonas" & x$species == "maltophilia"), SXT, "all" ) - + if (!ab_missing(MEM) && !ab_missing(IPM) && - !ab_missing(GEN) && !ab_missing(TOB) && - !ab_missing(CIP) && - !ab_missing(CAZ) && - !ab_missing(TZP)) { + !ab_missing(GEN) && !ab_missing(TOB) && + !ab_missing(CIP) && + !ab_missing(CAZ) && + !ab_missing(TZP)) { x$psae <- 0 x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"] x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"] @@ -1636,7 +1643,7 @@ mdro <- function(x = NULL, x$genus == "Pseudomonas" & x$species == "aeruginosa" & x$psae >= 3 ), "reason"] <- paste0("at least 3 classes contain R", ifelse(!isTRUE(combine_SI), " or I", "")) - + # Table 3 trans_tbl( 3, @@ -1657,7 +1664,7 @@ mdro <- function(x = NULL, "all" ) } - + if (guideline$code == "tb") { # Tuberculosis ------------------------------------------------------------ prepare_drug <- function(ab) { @@ -1694,7 +1701,7 @@ mdro <- function(x = NULL, ab != "R" } } - + x$mono_count <- 0 x[drug_is_R(INH), "mono_count"] <- x[drug_is_R(INH), "mono_count", drop = TRUE] + 1 x[drug_is_R(RIF), "mono_count"] <- x[drug_is_R(RIF), "mono_count", drop = TRUE] + 1 @@ -1702,7 +1709,7 @@ mdro <- function(x = NULL, x[drug_is_R(PZA), "mono_count"] <- x[drug_is_R(PZA), "mono_count", drop = TRUE] + 1 x[drug_is_R(RIB), "mono_count"] <- x[drug_is_R(RIB), "mono_count", drop = TRUE] + 1 x[drug_is_R(RFP), "mono_count"] <- x[drug_is_R(RFP), "mono_count", drop = TRUE] + 1 - + x$mono <- x$mono_count > 0 x$poly <- x$mono_count > 1 & drug_is_not_R(RIF) & drug_is_not_R(INH) x$mdr <- drug_is_R(RIF) & drug_is_R(INH) @@ -1710,19 +1717,19 @@ mdro <- function(x = NULL, x$second <- drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK) x$xdr <- x$mdr & x$xdr & x$second x$MDRO <- ifelse(x$xdr, 5, - ifelse(x$mdr, 4, - ifelse(x$poly, 3, - ifelse(x$mono, 2, - 1 - ) - ) - ) + ifelse(x$mdr, 4, + ifelse(x$poly, 3, + ifelse(x$mono, 2, + 1 + ) + ) + ) ) # keep all real TB, make other species NA x$MDRO <- ifelse(x$fullname == "Mycobacterium tuberculosis", x$MDRO, NA_real_) x$reason <- "PDR/MDR/XDR criteria were met" } - + # some more info on negative results if (isTRUE(verbose)) { if (guideline$code == "cmi2012") { @@ -1738,7 +1745,7 @@ mdro <- function(x = NULL, x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R" } } - + if (isTRUE(info.bak)) { cat(group_msg) if (sum(!is.na(x$MDRO)) == 0) { @@ -1750,11 +1757,11 @@ mdro <- function(x = NULL, ))) } } - + # Fill in blanks ---- # for rows that have no results x_transposed <- as.list(as.data.frame(t(x[, cols_ab, drop = FALSE]), - stringsAsFactors = FALSE + stringsAsFactors = FALSE )) rows_empty <- which(vapply( FUN.VALUE = logical(1), @@ -1768,7 +1775,7 @@ mdro <- function(x = NULL, } else { cat("\n") } - + # Results ---- if (guideline$code == "cmi2012") { if (any(x$MDRO == -1, na.rm = TRUE)) { @@ -1815,7 +1822,7 @@ mdro <- function(x = NULL, ordered = TRUE ) } - + if (isTRUE(verbose)) { colnames(x)[colnames(x) == col_mo] <- "microorganism" x$microorganism <- mo_name(x$microorganism, language = NULL) @@ -1837,9 +1844,9 @@ mdro <- function(x = NULL, #' @export custom_mdro_guideline <- function(..., as_factor = TRUE) { meet_criteria(as_factor, allow_class = "logical", has_length = 1) - + dots <- tryCatch(list(...), - error = function(e) "error" + error = function(e) "error" ) stop_if( identical(dots, "error"), @@ -1853,7 +1860,7 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) { inherits(dots[[i]], "formula"), "rule ", i, " must be a valid formula input (e.g., using '~'), see `?mdro`" ) - + # Query qry <- dots[[i]][[2]] if (inherits(qry, "call")) { @@ -1869,14 +1876,14 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) { qry <- gsub(" *([&|+-/*^><==]+) *", " \\1 ", qry) qry <- gsub("'", "\"", qry, fixed = TRUE) out[[i]]$query <- as.expression(qry) - + # Value val <- tryCatch(eval(dots[[i]][[3]]), error = function(e) NULL) stop_if(is.null(val), "rule ", i, " must return a valid value, it now returns an error: ", tryCatch(eval(dots[[i]][[3]]), error = function(e) e$message)) stop_if(length(val) > 1, "rule ", i, " must return a value of length 1, not ", length(val)) out[[i]]$value <- as.character(val) } - + names(out) <- paste0("rule", seq_len(n_dots)) out <- set_clean_class(out, new_class = c("custom_mdro_guideline", "list")) attr(out, "values") <- unname(c("Negative", vapply(FUN.VALUE = character(1), unclass(out), function(x) x$value))) @@ -1898,8 +1905,8 @@ c.custom_mdro_guideline <- function(x, ..., as_factor = NULL) { } for (g in list(...)) { stop_ifnot(inherits(g, "custom_mdro_guideline"), - "for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`", - call = FALSE + "for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`", + call = FALSE ) vals <- attributes(x)$values if (!all(attributes(g)$values %in% vals)) { @@ -1949,28 +1956,28 @@ run_custom_mdro_guideline <- function(df, guideline, info) { reasons <- character(length = NROW(df)) for (i in seq_len(n_dots)) { qry <- tryCatch(eval(parse(text = guideline[[i]]$query), envir = df, enclos = parent.frame()), - error = function(e) { - AMR_env$err_msg <- e$message - return("error") - } + error = function(e) { + AMR_env$err_msg <- e$message + return("error") + } ) if (identical(qry, "error")) { warning_("in `custom_mdro_guideline()`: rule ", i, - " (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ", - AMR_env$err_msg, - call = FALSE, - add_fn = font_red + " (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ", + AMR_env$err_msg, + call = FALSE, + add_fn = font_red ) next } stop_ifnot(is.logical(qry), "in custom_mdro_guideline(): rule ", i, " (`", guideline[[i]]$query, - "`) must return `TRUE` or `FALSE`, not ", - format_class(class(qry), plural = FALSE), - call = FALSE + "`) must return `TRUE` or `FALSE`, not ", + format_class(class(qry), plural = FALSE), + call = FALSE ) - + new_mdros <- which(qry == TRUE & out == "") - + if (isTRUE(info)) { cat(word_wrap( "- Custom MDRO rule ", i, ": `", as.character(guideline[[i]]$query), @@ -1986,11 +1993,11 @@ run_custom_mdro_guideline <- function(df, guideline, info) { } out[out == ""] <- "Negative" reasons[out == "Negative"] <- "no rules matched" - + if (isTRUE(attributes(guideline)$as_factor)) { out <- factor(out, levels = attributes(guideline)$values, ordered = TRUE) } - + columns_nonsusceptible <- as.data.frame(t(df[, is.rsi(df), drop = FALSE] == "R")) columns_nonsusceptible <- vapply( FUN.VALUE = character(1), @@ -1998,7 +2005,7 @@ run_custom_mdro_guideline <- function(df, guideline, info) { function(x) paste0(rownames(columns_nonsusceptible)[which(x)], collapse = " ") ) columns_nonsusceptible[is.na(out)] <- NA_character_ - + data.frame( row_number = seq_len(NROW(df)), MDRO = out, diff --git a/R/mo.R b/R/mo.R index 7c1b851c..05ec1903 100755 --- a/R/mo.R +++ b/R/mo.R @@ -181,8 +181,9 @@ as.mo <- function(x, x_lower <- tolower(x) - if (any(trimws2(x_lower) %like_case% "complex$", na.rm = TRUE)) { - warning_("in `as.mo()`: translation of complexes is not supported at the moment - the input text 'complex' was ignored.", call = FALSE) + complexes <- x[trimws2(x_lower) %like_case% "complex$"] + if (length(complexes) > 0) { + warning_("in `as.mo()`: translation of complexes is not supported at the moment - the input text 'complex' was ignored in ", length(complexes), " cases.", call = FALSE) } # WHONET: xxx = no growth @@ -935,6 +936,7 @@ convert_colloquial_input <- function(x) { out[x %like_case% "^fung(us|i)"] <- "F_FUNGUS" # Salmonella city names, starting with capital species name - they are all S. enterica + out[x.bak %like_case% "[sS]almonella " & x %like% "paratyphi"] <- "B_SLMNL_ENTR" out[x.bak %like_case% "[sS]almonella [A-Z][a-z]+ ?.*" & x %unlike% "typhi"] <- "B_SLMNL_ENTR" out[x %like_case% "salmonella group"] <- "B_SLMNL" diff --git a/R/rsi.R b/R/rsi.R index 7b98a3b0..4075043c 100755 --- a/R/rsi.R +++ b/R/rsi.R @@ -36,7 +36,7 @@ #' @param ab any (vector of) text that can be coerced to a valid antimicrobial drug code with [as.ab()] #' @param uti (Urinary Tract Infection) A vector with [logical]s (`TRUE` or `FALSE`) to specify whether a UTI specific interpretation from the guideline should be chosen. For using [as.rsi()] on a [data.frame], this can also be a column containing [logical]s or when left blank, the data set will be searched for a column 'specimen', and rows within this column containing 'urin' (such as 'urine', 'urina') will be regarded isolates from a UTI. See *Examples*. #' @inheritParams first_isolate -#' @param guideline defaults to EUCAST `r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))` (the latest implemented EUCAST guideline in the [rsi_translation] data set), supports EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`), see *Details* +#' @param guideline defaults to EUCAST `r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))` (the latest implemented EUCAST guideline in the [rsi_translation] data set), but can be set with the [option][options()] `AMR_guideline`. Supports EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`), see *Details*. #' @param conserve_capped_values a [logical] to indicate that MIC values starting with `">"` (but not `">="`) must always return "R" , and that MIC values starting with `"<"` (but not `"<="`) must always return "S" #' @param add_intrinsic_resistance *(only useful when using a EUCAST guideline)* a [logical] to indicate whether intrinsic antibiotic resistance must also be considered for applicable bug-drug combinations, meaning that e.g. ampicillin will always return "R" in *Klebsiella* species. Determination is based on the [intrinsic_resistant] data set, that itself is based on `r format_eucast_version_nr(3.3)`. #' @param reference_data a [data.frame] to be used for interpretation, which defaults to the [rsi_translation] data set. Changing this argument allows for using own interpretation guidelines. This argument must contain a data set that is equal in structure to the [rsi_translation] data set (same column names and column types). Please note that the `guideline` argument will be ignored when `reference_data` is manually set. @@ -52,15 +52,15 @@ #' 2. For **interpreting minimum inhibitory concentration (MIC) values** according to EUCAST or CLSI. You must clean your MIC values first using [as.mic()], that also gives your columns the new data class [`mic`]. Also, be sure to have a column with microorganism names or codes. It will be found automatically, but can be set manually using the `mo` argument. #' * Using `dplyr`, R/SI interpretation can be done very easily with either: #' ``` -#' your_data %>% mutate_if(is.mic, as.rsi) # until dplyr 1.0.0 -#' your_data %>% mutate(across(where(is.mic), as.rsi)) # since dplyr 1.0.0 +#' your_data %>% mutate_if(is.mic, as.rsi) +#' your_data %>% mutate(across(where(is.mic), as.rsi)) #' ``` #' * Operators like "<=" will be stripped before interpretation. When using `conserve_capped_values = TRUE`, an MIC value of e.g. ">2" will always return "R", even if the breakpoint according to the chosen guideline is ">=4". This is to prevent that capped values from raw laboratory data would not be treated conservatively. The default behaviour (`conserve_capped_values = FALSE`) considers ">2" to be lower than ">=4" and might in this case return "S" or "I". #' 3. For **interpreting disk diffusion diameters** according to EUCAST or CLSI. You must clean your disk zones first using [as.disk()], that also gives your columns the new data class [`disk`]. Also, be sure to have a column with microorganism names or codes. It will be found automatically, but can be set manually using the `mo` argument. #' * Using `dplyr`, R/SI interpretation can be done very easily with either: #' ``` -#' your_data %>% mutate_if(is.disk, as.rsi) # until dplyr 1.0.0 -#' your_data %>% mutate(across(where(is.disk), as.rsi)) # since dplyr 1.0.0 +#' your_data %>% mutate_if(is.disk, as.rsi) +#' your_data %>% mutate(across(where(is.disk), as.rsi)) #' ``` #' 4. For **interpreting a complete data set**, with automatic determination of MIC values, disk diffusion diameters, microorganism names or codes, and antimicrobial test results. This is done very simply by running `as.rsi(your_data)`. #' @@ -71,6 +71,16 @@ #' For interpreting MIC values as well as disk diffusion diameters, currently implemented guidelines are EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`). #' #' Thus, the `guideline` argument must be set to e.g., ``r paste0('"', subset(rsi_translation, guideline %like% "EUCAST")$guideline[1], '"')`` or ``r paste0('"', subset(rsi_translation, guideline %like% "CLSI")$guideline[1], '"')``. By simply using `"EUCAST"` (the default) or `"CLSI"` as input, the latest included version of that guideline will automatically be selected. You can set your own data set using the `reference_data` argument. The `guideline` argument will then be ignored. +#' +#' You can set the default guideline with the `AMR_guideline` [option][options()] (e.g. in your `.Rprofile` file), such as: +#' +#' ``` +#' options(AMR_guideline = "CLSI") +#' options(AMR_guideline = "CLSI 2018") +#' options(AMR_guideline = "EUCAST 2020") +#' # or to reset: +#' options(AMR_guideline = NULL) +#' ``` #' #' ### After Interpretation #' @@ -400,7 +410,7 @@ as.rsi.default <- function(x, ...) { as.rsi.mic <- function(x, mo = NULL, ab = deparse(substitute(x)), - guideline = "EUCAST", + guideline = getOption("AMR_guideline", "EUCAST"), uti = NULL, conserve_capped_values = FALSE, add_intrinsic_resistance = FALSE, @@ -426,7 +436,7 @@ as.rsi.mic <- function(x, as.rsi.disk <- function(x, mo = NULL, ab = deparse(substitute(x)), - guideline = "EUCAST", + guideline = getOption("AMR_guideline", "EUCAST"), uti = NULL, add_intrinsic_resistance = FALSE, reference_data = AMR::rsi_translation, @@ -451,7 +461,7 @@ as.rsi.disk <- function(x, as.rsi.data.frame <- function(x, ..., col_mo = NULL, - guideline = "EUCAST", + guideline = getOption("AMR_guideline", "EUCAST"), uti = NULL, conserve_capped_values = FALSE, add_intrinsic_resistance = FALSE, @@ -720,7 +730,7 @@ as_rsi_method <- function(method_short, if (is.null(mo)) { stop_("No information was supplied about the microorganisms (missing argument `mo` and no column of class 'mo' found). See ?as.rsi.\n\n", "To transform certain columns with e.g. mutate(), use `data %>% mutate(across(..., as.rsi, mo = x))`, where x is your column with microorganisms.\n", - "To tranform all ", method_long, " in a data set, use `data %>% as.rsi()` or `data %>% mutate(across(where(is.", method_short, "), as.rsi))`.", + "To tranform all ", method_long, " in a data set, use `data %>% as.rsi()` or `data %>% mutate_if(is.", method_short, ", as.rsi)`.", call = FALSE ) } @@ -737,7 +747,7 @@ as_rsi_method <- function(method_short, mo.bak <- mo } # be sure to take current taxonomy, as the rsi_translation data set only contains current taxonomy - mo <- suppressWarnings(suppressMessages(as.mo(mo, keep_synonyms = FALSE))) + mo <- suppressWarnings(suppressMessages(as.mo(mo, keep_synonyms = FALSE, inf0 = FALSE))) guideline_coerced <- get_guideline(guideline, reference_data) if (is.na(ab)) { message_("Returning NAs for unknown drug: '", font_bold(ab.bak), @@ -756,10 +766,21 @@ as_rsi_method <- function(method_short, if (length(uti) == 1) { uti <- rep(uti, length(x)) } - + + if (isTRUE(add_intrinsic_resistance) && guideline_coerced %unlike% "EUCAST") { + if (message_not_thrown_before("as.rsi", "intrinsic")) { + warning_("in `as.rsi()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.") + } + } + agent_formatted <- paste0("'", font_bold(ab.bak), "'") agent_name <- ab_name(ab, tolower = TRUE, language = NULL) - if (generalise_antibiotic_name(ab) != generalise_antibiotic_name(agent_name)) { + if (generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)) { + agent_formatted <- paste0( + agent_formatted, + " (", ab, ")" + ) + } else if (generalise_antibiotic_name(ab) != generalise_antibiotic_name(agent_name)) { agent_formatted <- paste0( agent_formatted, " (", ifelse(ab.bak == ab, "", @@ -778,265 +799,208 @@ as_rsi_method <- function(method_short, appendLF = FALSE, as_note = FALSE ) + + msg_note <- function(messages) { + for (i in seq_len(length(messages))) { + messages[i] <- word_wrap(extra_indent = 5, messages[i]) + } + message(font_green(font_bold(" * NOTE *\n")), + paste0(" ", font_black(AMR_env$bullet_icon)," ", font_black(messages, collapse = NULL) , collapse = "\n")) + } method <- method_short metadata_mo <- get_mo_uncertainties() - x_bak <- data.frame(x_mo = paste0(x, mo), stringsAsFactors = FALSE) - df <- unique(data.frame(x, mo, x_mo = paste0(x, mo), stringsAsFactors = FALSE)) - x <- df$x - mo <- df$mo - + df <- data.frame(values = x, + mo = mo, + result = NA_rsi_, + uti = uti, + stringsAsFactors = FALSE) if (method == "mic") { - x <- as.mic(x) # when as.rsi.mic is called directly + # when as.rsi.mic is called directly + df$values <- as.mic(df$values) } else if (method == "disk") { - x <- as.disk(x) # when as.rsi.disk is called directly + # when as.rsi.disk is called directly + df$values <- as.disk(df$values) } rise_warning <- FALSE rise_note <- FALSE - method_param <- toupper(method) - - genera <- mo_genus(mo, language = NULL) - mo_genus <- as.mo(genera, language = NULL) - mo_family <- as.mo(mo_family(mo, language = NULL)) - mo_order <- as.mo(mo_order(mo, language = NULL)) - if (any(genera == "Staphylococcus", na.rm = TRUE)) { - mo_becker <- as.mo(mo, Becker = TRUE) - } else { - mo_becker <- mo - } - if (any(genera == "Streptococcus", na.rm = TRUE)) { - mo_lancefield <- as.mo(mo, Lancefield = TRUE) - } else { - mo_lancefield <- mo - } - mo_other <- as.mo(rep("UNKNOWN", length(mo))) - - new_rsi <- rep(NA_character_, length(x)) - ab_param <- ab - + method_coerced <- toupper(method) + ab_coerced <- ab + mo_coerced <- mo + if (identical(reference_data, AMR::rsi_translation)) { - trans <- reference_data %pm>% - subset(guideline == guideline_coerced & method == method_param & ab == ab_param) - if (ab_param == "AMX" && nrow(trans) == 0) { - ab_param <- "AMP" - if (message_not_thrown_before("as.rsi", "AMP_for_AMX")) { - message_("(using ampicillin rules)", appendLF = FALSE, as_note = FALSE) - } - trans <- reference_data %pm>% - subset(guideline == guideline_coerced & method == method_param & ab == ab_param) + breakpoints <- reference_data %pm>% + subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced) + if (ab_coerced == "AMX" && nrow(breakpoints) == 0) { + ab_coerced <- "AMP" + breakpoints <- reference_data %pm>% + subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced) } } else { - trans <- reference_data %pm>% - subset(method == method_param & ab == ab_param) + breakpoints <- reference_data %pm>% + subset(method == method_coerced & ab == ab_coerced) } - - if (nrow(trans) == 0) { - message_(" OK.", add_fn = list(font_green), as_note = FALSE) + + msgs <- character(0) + if (nrow(breakpoints) == 0) { + # apparently no breakpoints found + msg_note(paste0("No ", method_coerced, " breakpoints available for ", + suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))), + " (", ab_coerced, ")")) load_mo_uncertainties(metadata_mo) - return(set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE), - new_class = c("rsi", "ordered", "factor") - )) + return(rep(NA_rsi_, nrow(df))) } - - trans$lookup <- paste(trans$mo, trans$ab) - - lookup_mo <- paste(mo, ab_param) - lookup_genus <- paste(mo_genus, ab_param) - lookup_family <- paste(mo_family, ab_param) - lookup_order <- paste(mo_order, ab_param) - lookup_becker <- paste(mo_becker, ab_param) - lookup_lancefield <- paste(mo_lancefield, ab_param) - lookup_other <- paste(mo_other, ab_param) - - any_is_intrinsic_resistant <- FALSE - - for (i in seq_len(length(x))) { + + if (guideline_coerced %like% "EUCAST") { + any_is_intrinsic_resistant <- FALSE add_intrinsic_resistance_to_AMR_env() - is_intrinsic_r <- paste(mo[i], ab_param) %in% AMR_env$intrinsic_resistant - any_is_intrinsic_resistant <- any_is_intrinsic_resistant | is_intrinsic_r - - if (isTRUE(add_intrinsic_resistance) && isTRUE(is_intrinsic_r)) { - if (guideline_coerced %unlike% "EUCAST") { - if (message_not_thrown_before("as.rsi", "intrinsic")) { - warning_("in `as.rsi()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.") - } - } else { - new_rsi[i] <- "R" - next - } + } + + # run the rules + for (mo_unique in unique(df$mo)) { + + rows <- which(df$mo == mo_unique) + values <- df[rows, "values", drop = TRUE] + uti <- df[rows, "uti", drop = TRUE] + new_rsi <- rep(NA_rsi_, length(rows)) + + # find different mo properties + mo_current_genus <- as.mo(mo_genus(mo_unique, language = NULL)) + mo_current_family <- as.mo(mo_family(mo_unique, language = NULL)) + mo_current_order <- as.mo(mo_order(mo_unique, language = NULL)) + mo_current_class <- as.mo(mo_class(mo_unique, language = NULL)) + if (mo_genus(mo_unique, language = NULL) == "Staphylococcus") { + mo_current_becker <- as.mo(mo_unique, Becker = TRUE) + } else { + mo_current_becker <- mo_unique } - - get_record <- trans %pm>% - subset(lookup %in% c( - lookup_mo[i], - lookup_genus[i], - lookup_family[i], - lookup_order[i], - lookup_becker[i], - lookup_lancefield[i], - lookup_other[i] - )) - - if (NROW(get_record) == 0) { - if (mo_rank(mo[i]) %in% c("kingdom", "phylum", "class", "order")) { - mo_formatted <- suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE))) - } else { - mo_formatted <- font_italic(suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE)))) - } - message_(font_green(font_bold(" NOTE.\n")), - font_black("No ", method_param, " breakpoints available for ", mo_formatted, - " / ", - suppressMessages(suppressWarnings(ab_name(ab_param, language = NULL, tolower = TRUE))), - " (", ab_param, ")", collapse = NULL) - ) - rise_note <- TRUE - next + if (mo_genus(mo_unique, language = NULL) == "Streptococcus") { + mo_current_lancefield <- as.mo(mo_unique, Lancefield = TRUE) + } else { + mo_current_lancefield <- mo_unique } - - if (isTRUE(uti[i])) { - get_record <- get_record %pm>% + mo_current_other <- as.mo("UNKNOWN") + # formatted for notes + mo_formatted <- suppressMessages(suppressWarnings(mo_fullname(mo_unique, language = NULL, keep_synonyms = FALSE))) + if (!mo_rank(mo_unique) %in% c("kingdom", "phylum", "class", "order")) { + mo_formatted <- font_italic(mo_formatted) + } + ab_formatted <- paste0(suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))), + " (", ab_coerced, ")") + + # gather all available breakpoints for current MO and sort on taxonomic rank + # (this will prefer species breakpoints over order breakpoints) + breakpoints_current <- breakpoints %pm>% + subset(mo %in% c(mo_current_genus, mo_current_family, + mo_current_order, mo_current_class, + mo_current_becker, mo_current_lancefield, + mo_current_other)) + + if (any(df[rows, "uti", drop = TRUE], na.rm = TRUE)) { + breakpoints_current <- breakpoints_current %pm>% # be as specific as possible (i.e. prefer species over genus): # the below `pm_desc(uti)` will put `TRUE` on top and FALSE on bottom pm_arrange(rank_index, pm_desc(uti)) # 'uti' is a column in data set 'rsi_translation' } else { - get_record <- get_record %pm>% + breakpoints_current <- breakpoints_current %pm>% # sort UTI = FALSE first, then UTI = TRUE pm_arrange(rank_index, uti) } - - # warning section - records_same_mo <- get_record[get_record$mo == get_record[1, "mo", drop = TRUE], , drop = FALSE] - if (nrow(get_record) == 1 && all(get_record$uti == TRUE) && uti[i] %in% c(FALSE, NA) && message_not_thrown_before("as.rsi", "uti", ab_param)) { - # uti not set as TRUE, but there are only a UTI breakpoints available, so throw warning - warning_("in `as.rsi()`: interpretation of ", font_bold(ab_name(ab_param, tolower = TRUE)), " is only available for (uncomplicated) urinary tract infections (UTI) for some microorganisms, thus assuming `uti = TRUE`. See ?as.rsi.") + + # throw notes for different body sites + if (nrow(breakpoints_current) == 1 && all(breakpoints_current$uti == TRUE) && any(uti %in% c(FALSE, NA)) && message_not_thrown_before("as.rsi", "uti", ab_coerced)) { + # only UTI breakpoints available + warning_("in `as.rsi()`: interpretation of ", font_bold(ab_formatted), " is only available for (uncomplicated) urinary tract infections (UTI) for some microorganisms, thus assuming `uti = TRUE`. See `?as.rsi`.") rise_warning <- TRUE - } else if (nrow(records_same_mo) > 1 && length(unique(records_same_mo$site)) > 1 && is.na(uti[i]) && all(c(TRUE, FALSE) %in% records_same_mo$uti, na.rm = TRUE) && message_not_thrown_before("as.rsi", "siteUTI", records_same_mo$mo[1], ab_param)) { - # uti not set and both UTI and non-UTI breakpoints available, so throw warning - if (mo_rank(mo[i]) %in% c("kingdom", "phylum", "class", "order")) { - mo_formatted <- suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE))) - } else { - mo_formatted <- font_italic(suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE)))) - } - message_(font_green(font_bold(" NOTE.\n")), - font_black("Breakpoints for UTI ", font_underline("and"), " non-UTI available for ", mo_formatted, - " / ", - suppressMessages(suppressWarnings(ab_name(ab_param, language = NULL, tolower = TRUE))), - " (", ab_param, ") - assuming non-UTI. Use argument `uti` to set which isolates are from urine. See ?as.rsi.", collapse = NULL), - as_note = FALSE - ) - rise_note <- TRUE - get_record <- get_record %pm>% + } else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && any(is.na(uti)) && all(c(TRUE, FALSE) %in% breakpoints_current$uti, na.rm = TRUE) && message_not_thrown_before("as.rsi", "siteUTI", mo_unique, ab_coerced)) { + # both UTI and Non-UTI breakpoints available + msgs <- c(msgs, paste0("Breakpoints for UTI ", font_underline("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming non-UTI. Use argument `uti` to set which isolates are from urine. See `?as.rsi`.")) + breakpoints_current <- breakpoints_current %pm>% pm_filter(uti == FALSE) - rise_warning <- TRUE - } else if (nrow(records_same_mo) > 1 && length(unique(records_same_mo$site)) > 1 && all(records_same_mo$uti == FALSE, na.rm = TRUE) && message_not_thrown_before("as.rsi", "siteOther", records_same_mo$mo[1], ab_param)) { - # breakpoints for multiple body sites available, so throw warning - site <- get_record[1L, "site", drop = FALSE] + } else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && all(breakpoints_current$uti == FALSE, na.rm = TRUE) && message_not_thrown_before("as.rsi", "siteOther", mo_unique, ab_coerced)) { + # breakpoints for multiple body sites available + site <- breakpoints_current[1L, "site", drop = FALSE] # this is the one we'll take if (is.na(site)) { site <- paste0("an unspecified body site") } else { - site <- paste0("body site '", get_record[1L, "site", drop = FALSE], "'") + site <- paste0("body site '", site, "'") } - if (mo_rank(mo[i]) %in% c("kingdom", "phylum", "class", "order")) { - mo_formatted <- suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE))) - } else { - mo_formatted <- font_italic(suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE)))) - } - message_(font_green(font_bold(" NOTE.\n")), - font_black("Breakpoints available for ", mo_formatted, - " / ", - suppressMessages(suppressWarnings(ab_name(records_same_mo$ab[1], language = NULL, tolower = TRUE))), - paste0(" - assuming ", site), collapse = NULL), - as_note = FALSE - ) - rise_note <- TRUE + msgs <- c(msgs, paste0("Multiple breakpoints available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, ".")) } - - if (NROW(get_record) > 0) { - # get the best hit: the top one - get_record <- get_record[1L, , drop = FALSE] - if (is.na(x[i]) | (is.na(get_record$breakpoint_S) & is.na(get_record$breakpoint_R))) { - new_rsi[i] <- NA_character_ - } else if (method == "mic") { - new_rsi[i] <- quick_case_when( - isTRUE(conserve_capped_values) & isTRUE(x[i] %like% "^<[0-9]") ~ "S", - isTRUE(conserve_capped_values) & isTRUE(x[i] %like% "^>[0-9]") ~ "R", - # these basically call `<=.mic()` and `>=.mic()`: - isTRUE(x[i] <= get_record$breakpoint_S) ~ "S", - guideline_coerced %like% "EUCAST" & isTRUE(x[i] > get_record$breakpoint_R) ~ "R", - guideline_coerced %like% "CLSI" & isTRUE(x[i] >= get_record$breakpoint_R) ~ "R", - # return "I" when not match the bottom or top - !is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R) ~ "I", + + # first check if mo is intrinsic resistant + if (isTRUE(add_intrinsic_resistance) && guideline_coerced %like% "EUCAST" && paste(mo_unique, ab_coerced) %in% AMR_env$intrinsic_resistant) { + msgs <- c(msgs, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, "")) + new_rsi <- rep(as.rsi("R"), length(rows)) + + } else { + # then run the rules + breakpoints_current <- breakpoints_current[1L, , drop = FALSE] + + if (method == "mic") { + new_rsi <- quick_case_when( + is.na(values) ~ NA_rsi_, + values <= breakpoints_current$breakpoint_S ~ as.rsi("S"), + guideline_coerced %like% "EUCAST" & values > breakpoints_current$breakpoint_R ~ as.rsi("R"), + guideline_coerced %like% "CLSI" & values >= breakpoints_current$breakpoint_R ~ as.rsi("R"), + # return "I" when breakpoints are in the middle + !is.na(breakpoints_current$breakpoint_S) & !is.na(breakpoints_current$breakpoint_R) ~ as.rsi("I"), # and NA otherwise - TRUE ~ NA_character_ + TRUE ~ NA_rsi_ ) + } else if (method == "disk") { - new_rsi[i] <- quick_case_when( - isTRUE(as.double(x[i]) >= as.double(get_record$breakpoint_S)) ~ "S", - guideline_coerced %like% "EUCAST" & isTRUE(as.double(x[i]) < as.double(get_record$breakpoint_R)) ~ "R", - guideline_coerced %like% "CLSI" & isTRUE(as.double(x[i]) <= as.double(get_record$breakpoint_R)) ~ "R", - # return "I" when not match the bottom or top - !is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R) ~ "I", + new_rsi <- quick_case_when( + is.na(values) ~ NA_rsi_, + as.double(values) >= as.double(breakpoints_current$breakpoint_S) ~ as.rsi("S"), + guideline_coerced %like% "EUCAST" & as.double(values) < as.double(breakpoints_current$breakpoint_R) ~ as.rsi("R"), + guideline_coerced %like% "CLSI" & as.double(values) <= as.double(breakpoints_current$breakpoint_R) ~ as.rsi("R"), + # return "I" when breakpoints are in the middle + !is.na(breakpoints_current$breakpoint_S) & !is.na(breakpoints_current$breakpoint_R) ~ as.rsi("I"), # and NA otherwise - TRUE ~ NA_character_ + TRUE ~ NA_rsi_ ) } # write to verbose output AMR_env$rsi_interpretation_history <- rbind( AMR_env$rsi_interpretation_history, + # recycling 1 to 2 rows does not seem to work, which is why rep() was added data.frame( - datetime = Sys.time(), - index = i, - ab_userinput = ab.bak[1], - ab_actual = ab[1], - mo_userinput = mo.bak[1], - mo_actual = mo[1], - guideline = guideline_coerced, - ref_table = get_record[, "ref_tbl", drop = TRUE], - method = method, - input = as.double(x[i]), - outcome = new_rsi[i], - breakpoint_S_R = paste0(get_record[, "breakpoint_S", drop = TRUE], "-", get_record[, "breakpoint_R", drop = TRUE]), + datetime = rep(Sys.time(), length(rows)), + index = rows, + ab_input = rep(ab.bak, length(rows)), + ab_guideline = rep(ab_coerced, length(rows)), + mo_input = rep(mo.bak[match(mo_unique, df$mo)][1], length(rows)), + mo_guideline = rep(breakpoints_current[, "mo", drop = TRUE], length(rows)), + guideline = rep(guideline_coerced, length(rows)), + ref_table = rep(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)), + method = rep(method_coerced, length(rows)), + input = as.double(values), + outcome = as.rsi(new_rsi), + breakpoint_S_R = rep(paste0(breakpoints_current[, "breakpoint_S", drop = TRUE], "-", breakpoints_current[, "breakpoint_R", drop = TRUE]), length(rows)), stringsAsFactors = FALSE ) ) } + + df[rows, "result"] <- new_rsi } - - if (any_is_intrinsic_resistant & guideline_coerced %like% "EUCAST" & !isTRUE(add_intrinsic_resistance)) { - # found some intrinsic resistance, but was not applied - if (message_not_thrown_before("as.rsi", "unapplied_instrinsic")) { - warning_("in `as.rsi()`: found intrinsic resistance in some bug/drug combinations, although it was not applied.\nUse `as.rsi(..., add_intrinsic_resistance = TRUE)` to apply it.") - } - rise_warning <- TRUE - } - - new_rsi <- x_bak %pm>% - pm_left_join(data.frame( - x_mo = paste0(x, mo), new_rsi, - stringsAsFactors = FALSE - ), - by = "x_mo" - ) %pm>% - pm_pull(new_rsi) - if (!isTRUE(rise_note)) { - # notes already a have green "NOTE" text by this point - if (isTRUE(rise_warning)) { - message_(" WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE) - } else { - message_(" OK.", add_fn = list(font_green), as_note = FALSE) - } + if (isTRUE(rise_warning)) { + message(font_yellow(font_bold(" * WARNING *"))) + } else if (length(msgs) == 0) { + message(font_green(" OK.")) + } else { + msg_note(sort(msgs)) } load_mo_uncertainties(metadata_mo) - - set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE), - new_class = c("rsi", "ordered", "factor") - ) + + df$result } #' @rdname as.rsi @@ -1051,8 +1015,8 @@ rsi_interpretation_history <- function(clean = FALSE) { message_("No results to return. Run `as.rsi()` on MIC values or disk diffusion zones first to see a 'logbook' data set here.") return(invisible(NULL)) } - out$ab_actual <- as.ab(out$ab_actual) - out$mo_actual <- as.mo(out$mo_actual) + out$ab_guideline <- as.ab(out$ab_guideline) + out$mo_guideline <- as.mo(out$mo_guideline) out$outcome <- as.rsi(out$outcome) # keep stored for next use if (isTRUE(clean)) { @@ -1074,7 +1038,7 @@ pillar_shaft.rsi <- function(x, ...) { if (has_colour()) { # colours will anyway not work when has_colour() == FALSE, # but then the indentation should also not be applied - out[is.na(x)] <- font_grey(" NA") + out[is.na(x)] <- font_grey(" NA") out[x == "R"] <- font_red_bg(" R ") out[x == "S"] <- font_green_bg(" S ") out[x == "I"] <- font_orange_bg(" I ") diff --git a/R/rsi_calc.R b/R/rsi_calc.R index 31bb7d59..50c6a03a 100755 --- a/R/rsi_calc.R +++ b/R/rsi_calc.R @@ -161,8 +161,7 @@ rsi_calc <- function(..., if (print_warning == TRUE) { if (message_not_thrown_before("rsi_calc")) { warning_("Increase speed by transforming to class 'rsi' on beforehand:\n", - " your_data %>% mutate_if(is.rsi.eligible, as.rsi)\n", - " your_data %>% mutate(across(where(is.rsi.eligible), as.rsi))", + " your_data %>% mutate_if(is.rsi.eligible, as.rsi)", call = FALSE ) } diff --git a/R/zzz.R b/R/zzz.R index 5e41b98c..ad80c86b 100755 --- a/R/zzz.R +++ b/R/zzz.R @@ -82,8 +82,10 @@ is_latex <- tryCatch(import_fn("is_latex_output", "knitr", error_on_fail = FALSE if (utf8_supported && !is_latex) { # \u2139 is a symbol officially named 'information source' AMR_env$info_icon <- "\u2139" + AMR_env$bullet_icon <- "\u2022" } else { AMR_env$info_icon <- "i" + AMR_env$bullet_icon <- "*" } .onLoad <- function(lib, pkg) { @@ -97,12 +99,12 @@ if (utf8_supported && !is_latex) { s3_register("pillar::pillar_shaft", "rsi") s3_register("pillar::pillar_shaft", "mic") s3_register("pillar::pillar_shaft", "disk") - s3_register("tibble::type_sum", "ab") - s3_register("tibble::type_sum", "av") - s3_register("tibble::type_sum", "mo") - s3_register("tibble::type_sum", "rsi") - s3_register("tibble::type_sum", "mic") - s3_register("tibble::type_sum", "disk") + s3_register("pillar::type_sum", "ab") + s3_register("pillar::type_sum", "av") + s3_register("pillar::type_sum", "mo") + s3_register("pillar::type_sum", "rsi") + s3_register("pillar::type_sum", "mic") + s3_register("pillar::type_sum", "disk") # Support for frequency tables from the cleaner package s3_register("cleaner::freq", "mo") s3_register("cleaner::freq", "rsi") diff --git a/inst/tinytest/test-zzz.R b/inst/tinytest/test-zzz.R index 73a74104..7dcd4c00 100644 --- a/inst/tinytest/test-zzz.R +++ b/inst/tinytest/test-zzz.R @@ -102,7 +102,7 @@ extended_functions <- c( "autoplot" = "ggplot2", "pillar_shaft" = "pillar", "get_skimmers" = "skimr", - "type_sum" = "tibble", + "type_sum" = "pillar", "vec_cast" = "vctrs", "vec_math" = "vctrs", "vec_ptype2" = "vctrs" diff --git a/man/as.rsi.Rd b/man/as.rsi.Rd index 5cad6542..c8cd5d6a 100755 --- a/man/as.rsi.Rd +++ b/man/as.rsi.Rd @@ -36,7 +36,7 @@ is.rsi.eligible(x, threshold = 0.05) x, mo = NULL, ab = deparse(substitute(x)), - guideline = "EUCAST", + guideline = getOption("AMR_guideline", "EUCAST"), uti = NULL, conserve_capped_values = FALSE, add_intrinsic_resistance = FALSE, @@ -48,7 +48,7 @@ is.rsi.eligible(x, threshold = 0.05) x, mo = NULL, ab = deparse(substitute(x)), - guideline = "EUCAST", + guideline = getOption("AMR_guideline", "EUCAST"), uti = NULL, add_intrinsic_resistance = FALSE, reference_data = AMR::rsi_translation, @@ -59,7 +59,7 @@ is.rsi.eligible(x, threshold = 0.05) x, ..., col_mo = NULL, - guideline = "EUCAST", + guideline = getOption("AMR_guideline", "EUCAST"), uti = NULL, conserve_capped_values = FALSE, add_intrinsic_resistance = FALSE, @@ -79,7 +79,7 @@ rsi_interpretation_history(clean = FALSE) \item{ab}{any (vector of) text that can be coerced to a valid antimicrobial drug code with \code{\link[=as.ab]{as.ab()}}} -\item{guideline}{defaults to EUCAST 2022 (the latest implemented EUCAST guideline in the \link{rsi_translation} data set), supports EUCAST (2013-2022) and CLSI (2013-2022), see \emph{Details}} +\item{guideline}{defaults to EUCAST 2022 (the latest implemented EUCAST guideline in the \link{rsi_translation} data set), but can be set with the \link[=options]{option} \code{AMR_guideline}. Supports EUCAST (2013-2022) and CLSI (2013-2022), see \emph{Details}.} \item{uti}{(Urinary Tract Infection) A vector with \link{logical}s (\code{TRUE} or \code{FALSE}) to specify whether a UTI specific interpretation from the guideline should be chosen. For using \code{\link[=as.rsi]{as.rsi()}} on a \link{data.frame}, this can also be a column containing \link{logical}s or when left blank, the data set will be searched for a column 'specimen', and rows within this column containing 'urin' (such as 'urine', 'urina') will be regarded isolates from a UTI. See \emph{Examples}.} @@ -109,8 +109,8 @@ The \code{\link[=as.rsi]{as.rsi()}} function works in four ways: \itemize{ \item Using \code{dplyr}, R/SI interpretation can be done very easily with either: -\if{html}{\out{
}}\preformatted{your_data \%>\% mutate_if(is.mic, as.rsi) # until dplyr 1.0.0 -your_data \%>\% mutate(across(where(is.mic), as.rsi)) # since dplyr 1.0.0 +\if{html}{\out{
}}\preformatted{your_data \%>\% mutate_if(is.mic, as.rsi) +your_data \%>\% mutate(across(where(is.mic), as.rsi)) }\if{html}{\out{
}} \item Operators like "<=" will be stripped before interpretation. When using \code{conserve_capped_values = TRUE}, an MIC value of e.g. ">2" will always return "R", even if the breakpoint according to the chosen guideline is ">=4". This is to prevent that capped values from raw laboratory data would not be treated conservatively. The default behaviour (\code{conserve_capped_values = FALSE}) considers ">2" to be lower than ">=4" and might in this case return "S" or "I". } @@ -118,8 +118,8 @@ your_data \%>\% mutate(across(where(is.mic), as.rsi)) # since dplyr 1.0.0 \itemize{ \item Using \code{dplyr}, R/SI interpretation can be done very easily with either: -\if{html}{\out{
}}\preformatted{your_data \%>\% mutate_if(is.disk, as.rsi) # until dplyr 1.0.0 -your_data \%>\% mutate(across(where(is.disk), as.rsi)) # since dplyr 1.0.0 +\if{html}{\out{
}}\preformatted{your_data \%>\% mutate_if(is.disk, as.rsi) +your_data \%>\% mutate(across(where(is.disk), as.rsi)) }\if{html}{\out{
}} } \item For \strong{interpreting a complete data set}, with automatic determination of MIC values, disk diffusion diameters, microorganism names or codes, and antimicrobial test results. This is done very simply by running \code{as.rsi(your_data)}. @@ -133,6 +133,15 @@ For points 2, 3 and 4: Use \code{\link[=rsi_interpretation_history]{rsi_interpre For interpreting MIC values as well as disk diffusion diameters, currently implemented guidelines are EUCAST (2013-2022) and CLSI (2013-2022). Thus, the \code{guideline} argument must be set to e.g., \code{"EUCAST 2022"} or \code{"CLSI 2022"}. By simply using \code{"EUCAST"} (the default) or \code{"CLSI"} as input, the latest included version of that guideline will automatically be selected. You can set your own data set using the \code{reference_data} argument. The \code{guideline} argument will then be ignored. + +You can set the default guideline with the \code{AMR_guideline} \link[=options]{option} (e.g. in your \code{.Rprofile} file), such as: + +\if{html}{\out{
}}\preformatted{ options(AMR_guideline = "CLSI") + options(AMR_guideline = "CLSI 2018") + options(AMR_guideline = "EUCAST 2020") + # or to reset: + options(AMR_guideline = NULL) +}\if{html}{\out{
}} } \subsection{After Interpretation}{