mirror of
https://github.com/msberends/AMR.git
synced 2024-12-25 06:46:11 +01:00
revised as.rsi()
, fix for mdro()
This commit is contained in:
parent
05d536ebb7
commit
31fb81c382
@ -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
14
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*
|
||||
|
@ -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, ...) {
|
||||
|
283
R/mdro.R
283
R/mdro.R
@ -194,6 +194,10 @@ mdro <- function(x = NULL,
|
||||
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)) {
|
||||
@ -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 = " < ")),
|
||||
""
|
||||
),
|
||||
"."
|
||||
)
|
||||
@ -330,31 +334,31 @@ mdro <- function(x = NULL,
|
||||
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:
|
||||
@ -362,13 +366,13 @@ mdro <- function(x = NULL,
|
||||
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)
|
||||
@ -777,15 +781,15 @@ 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 = ""
|
||||
)
|
||||
}
|
||||
|
||||
@ -847,7 +851,7 @@ mdro <- function(x = NULL,
|
||||
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),
|
||||
@ -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)
|
||||
@ -920,7 +927,7 @@ 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
|
||||
@ -973,76 +980,76 @@ mdro <- function(x = NULL,
|
||||
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_
|
||||
@ -1201,8 +1208,8 @@ mdro <- function(x = NULL,
|
||||
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"
|
||||
)
|
||||
@ -1294,10 +1301,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"
|
||||
)
|
||||
@ -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"
|
||||
)
|
||||
@ -1498,11 +1505,11 @@ mdro <- function(x = NULL,
|
||||
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"
|
||||
)
|
||||
@ -1510,11 +1517,11 @@ mdro <- function(x = NULL,
|
||||
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"
|
||||
)
|
||||
@ -1522,8 +1529,8 @@ mdro <- function(x = NULL,
|
||||
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"
|
||||
)
|
||||
@ -1531,12 +1538,12 @@ mdro <- function(x = NULL,
|
||||
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"
|
||||
)
|
||||
@ -1544,10 +1551,10 @@ mdro <- function(x = NULL,
|
||||
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"
|
||||
)
|
||||
@ -1613,10 +1620,10 @@ mdro <- function(x = NULL,
|
||||
)
|
||||
|
||||
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"]
|
||||
@ -1710,13 +1717,13 @@ 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_)
|
||||
@ -1754,7 +1761,7 @@ 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),
|
||||
@ -1839,7 +1846,7 @@ 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"),
|
||||
@ -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,24 +1956,24 @@ 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 == "")
|
||||
|
6
R/mo.R
6
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"
|
||||
|
||||
|
386
R/rsi.R
386
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)`.
|
||||
#'
|
||||
@ -72,6 +72,16 @@
|
||||
#'
|
||||
#' 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
|
||||
#'
|
||||
#' After using [as.rsi()], you can use the [eucast_rules()] defined by EUCAST to (1) apply inferred susceptibility and resistance based on results of other antimicrobials and (2) apply intrinsic resistance based on taxonomic properties of a microorganism.
|
||||
@ -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),
|
||||
@ -757,9 +767,20 @@ as_rsi_method <- function(method_short,
|
||||
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, "",
|
||||
@ -779,264 +800,207 @@ as_rsi_method <- function(method_short,
|
||||
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
|
||||
}
|
||||
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, ")")
|
||||
|
||||
if (isTRUE(uti[i])) {
|
||||
get_record <- get_record %pm>%
|
||||
# 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 ")
|
||||
|
@ -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
14
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")
|
||||
|
@ -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"
|
||||
|
@ -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}{
|
||||
|
Loading…
Reference in New Issue
Block a user