P281424
/
AMR
mirror of https://github.com/msberends/AMR.git
1
0
Fork 0
Code Releases Activity

revised `as.rsi()`, fix for `mdro()`

This commit is contained in:
dr. M.S. (Matthijs) Berends 2022-11-24 20:29:00 +01:00
parent 05d536ebb7
commit 31fb81c382
10 changed files with 450 additions and 453 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@ -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

14
NEWS.md
View File

@ -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*

16
R/aa_helper_functions.R
View File

@ -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("<environment: (.*)>", "\\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, ...) {

415
R/mdro.R
View File

@ -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,

6
R/mo.R
View File

@ -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"

404
R/rsi.R
View File

@ -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 ")

3
R/rsi_calc.R
View File

@ -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
)
}

14
R/zzz.R
View File

@ -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")

2
inst/tinytest/test-zzz.R
View File

@ -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"

25
man/as.rsi.Rd
View File

@ -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{<div class="sourceCode">}}\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{<div class="sourceCode">}}\preformatted{your_data \%>\% mutate_if(is.mic, as.rsi)
your_data \%>\% mutate(across(where(is.mic), as.rsi))
}\if{html}{\out{</div>}}
\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{<div class="sourceCode">}}\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{<div class="sourceCode">}}\preformatted{your_data \%>\% mutate_if(is.disk, as.rsi)
your_data \%>\% mutate(across(where(is.disk), as.rsi))
}\if{html}{\out{</div>}}
}
\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{<div class="sourceCode">}}\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{</div>}}
}
\subsection{After Interpretation}{