P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 19:26:13 +01:00
Code Releases Activity

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

Browse Source
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 Package: AMR
Version: 1.8.2.9052 Version: 1.8.2.9053
Date: 2022-11-17 Date: 2022-11-24
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by 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! 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()` * Support for using antibiotic selectors in scoped `dplyr` verbs (with or without `vars()`), such as in: `... %>% summarise_at(aminoglycosides(), resistance)`, see `resistance()`
### Changed ### Changed
* Fix for using `as.rsi()` on certain EUCAST breakpoints for MIC values * Fixes and changes for using `as.rsi()`:
* Fix for using `as.rsi()` on `NA` values (e.g. `as.rsi(as.disk(NA), ...)`) * On certain EUCAST breakpoints for MIC values
* Fix for using `as.rsi()` on bug-drug combinations with multiple breakpoints for different body sites * On `NA` values (e.g. `as.rsi(as.disk(NA), ...)`)
* 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) * 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. * `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()` * 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 * 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)` * 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 * 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* * 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 # format backticks
msg <- gsub("(`.+?`)", font_grey_bg("\\1"), msg) msg <- gsub("`(.+?)`", font_grey_bg("\\1"), msg)
# clean introduced whitespace between fullstops # clean introduced whitespace between fullstops
msg <- gsub("[.] +[.]", "..", msg) msg <- gsub("[.] +[.]", "..", msg)
@ -968,7 +968,7 @@ unique_call_id <- function(entire_session = FALSE, match_fn = NULL) {
if (!isTRUE(in_test)) { if (!isTRUE(in_test)) {
for (i in seq_len(length(calls))) { for (i in seq_len(length(calls))) {
call_clean <- gsub("[^a-zA-Z0-9_().-]", "", as.character(calls[[i]]), perl = TRUE) 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( return(c(
envir = gsub("<environment: (.*)>", "\\1", utils::capture.output(sys.frames()[[1]]), perl = TRUE), envir = gsub("<environment: (.*)>", "\\1", utils::capture.output(sys.frames()[[1]]), perl = TRUE),
call = paste0(deparse(calls[[i]]), collapse = "") call = paste0(deparse(calls[[i]]), collapse = "")
@ -1171,9 +1171,19 @@ font_italic <- function(..., collapse = " ") {
font_underline <- function(..., collapse = " ") { font_underline <- function(..., collapse = " ") {
try_colour(..., before = "\033[4m", after = "\033[24m", collapse = 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) { font_stripstyle <- function(x) {
# remove URLs
x <- gsub("\033]8;;(.*?)\a.*?\033]8;;\a", "\\1", x)
# from crayon:::ansi_regex # 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, ...) { progress_ticker <- function(n = 1, n_min = 0, print = TRUE, ...) {

283
R/mdro.R
View File

@ -194,6 +194,10 @@ mdro <- function(x = NULL,
meet_criteria(verbose, 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) 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 info.bak <- info
# don't thrown info's more than once per call # don't thrown info's more than once per call
if (isTRUE(info)) { if (isTRUE(info)) {
@ -256,8 +260,8 @@ mdro <- function(x = NULL,
txt <- paste0( txt <- paste0(
"Determining MDROs based on custom rules", "Determining MDROs based on custom rules",
ifelse(isTRUE(attributes(guideline)$as_factor), 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$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$author <- "Magiorakos AP, Srinivasan A, Carey RB, ..., Vatopoulos A, Weber JT, Monnet DL"
guideline$version <- NA 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" guideline$type <- "MDRs/XDRs/PDRs"
} else if (guideline$code == "eucast3.1") { } else if (guideline$code == "eucast3.1") {
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Exceptional Phenotypes Tables\"" guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Exceptional Phenotypes Tables\""
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)" guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
guideline$version <- "3.1, 2016" 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" guideline$type <- "EUCAST Exceptional Phenotypes"
} else if (guideline$code == "eucast3.2") { } else if (guideline$code == "eucast3.2") {
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Unusual Phenotypes\"" guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Unusual Phenotypes\""
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)" guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
guideline$version <- "3.2, February 2020" 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" guideline$type <- "EUCAST Unusual Phenotypes"
} else if (guideline$code == "eucast3.3") { } else if (guideline$code == "eucast3.3") {
guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Unusual Phenotypes\"" guideline$name <- "EUCAST Expert Rules, \"Intrinsic Resistance and Unusual Phenotypes\""
guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)" guideline$author <- "EUCAST (European Committee on Antimicrobial Susceptibility Testing)"
guideline$version <- "3.3, October 2021" 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" guideline$type <- "EUCAST Unusual Phenotypes"
} else if (guideline$code == "tb") { } else if (guideline$code == "tb") {
guideline$name <- "Companion handbook to the WHO guidelines for the programmatic management of drug-resistant tuberculosis" guideline$name <- "Companion handbook to the WHO guidelines for the programmatic management of drug-resistant tuberculosis"
guideline$author <- "WHO (World Health Organization)" guideline$author <- "WHO (World Health Organization)"
guideline$version <- "WHO/HTM/TB/2014.11, 2014" 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" guideline$type <- "MDR-TB's"
# support per country: # 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$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$author <- "M\u00fcller J, Voss A, K\u00f6ck R, ..., Kern WV, Wendt C, Friedrich AW"
guideline$version <- NA 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" guideline$type <- "MRGNs"
} else if (guideline$code == "brmo") { } else if (guideline$code == "brmo") {
guideline$name <- "WIP-Richtlijn Bijzonder Resistente Micro-organismen (BRMO)" guideline$name <- "WIP-Richtlijn Bijzonder Resistente Micro-organismen (BRMO)"
guideline$author <- "RIVM (Rijksinstituut voor de Volksgezondheid)" guideline$author <- "RIVM (Rijksinstituut voor de Volksgezondheid)"
guideline$version <- "Revision as of December 2017" 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" guideline$type <- "BRMOs"
} else { } else {
stop("This guideline is currently unsupported: ", guideline$code, call. = FALSE) 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(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", 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("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", word_wrap(paste0(font_bold("Author(s): "), guideline$author), extra_indent = 11, as_note = FALSE), "\n",
ifelse(!is.na(guideline$version), ifelse(!is.na(guideline$version),
paste0(word_wrap(paste0(font_bold("Version: "), guideline$version), extra_indent = 11, as_note = FALSE), "\n"), paste0(word_wrap(paste0(font_bold("Version: "), guideline$version), extra_indent = 11, as_note = FALSE), "\n"),
"" ""
), ),
paste0(font_bold("Source: "), guideline$source_url), paste0(font_bold("Source: "), guideline$source_url),
"\n\n", "\n\n",
sep = "" sep = ""
) )
} }
@ -847,7 +851,7 @@ mdro <- function(x = NULL,
search_function <- all search_function <- all
} }
x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]), x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]),
stringsAsFactors = FALSE stringsAsFactors = FALSE
)) ))
rows_affected <- vapply( rows_affected <- vapply(
FUN.VALUE = logical(1), FUN.VALUE = logical(1),
@ -874,6 +878,9 @@ mdro <- function(x = NULL,
if (length(rows) > 0) { if (length(rows) > 0) {
# function specific for the CMI paper of 2012 (Magiorakos et al.) # function specific for the CMI paper of 2012 (Magiorakos et al.)
lst_vector <- unlist(lst)[!is.na(unlist(lst))] 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] <- as.data.frame(lapply(
x[, lst_vector, drop = FALSE], x[, lst_vector, drop = FALSE],
function(col) as.rsi(col) 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) # 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]), 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)) 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 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 == "faecium"), ab_NA(IPM)] <- NA
x[which(x$genus == "Enterococcus" & x$species == "faecalis"), ab_NA(QDA)] <- NA x[which(x$genus == "Enterococcus" & x$species == "faecalis"), ab_NA(QDA)] <- NA
x[which((x$genus == "Providencia" & x$species == "rettgeri") | 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 == "Escherichia" & x$species == "hermannii"), ab_NA(c(TCC, TZP))] <- NA
x[which((x$genus == "Citrobacter" & x$species == "freundii") | x[which((x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Enterobacter" & x$species == "aerogenes") | (x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") | | (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") | (x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Morganella" & x$species == "morganii") | (x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CZO)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CZO)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") | x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CXM)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CXM)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") | x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "mirabilis") | (x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TGC)] <- NA (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TGC)] <- NA
x[which((x$genus == "Citrobacter" & x$species == "koseri") | x[which((x$genus == "Citrobacter" & x$species == "koseri") |
(x$genus == "Citrobacter" & x$species == "freundii") | (x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Enterobacter" & x$species == "aerogenes") | (x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") | | (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Escherichia" & x$species == "hermannii") | (x$genus == "Escherichia" & x$species == "hermannii") |
(x$genus == "Hafnia" & x$species == "alvei") | (x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Klebsiella") | (x$genus == "Klebsiella") |
(x$genus == "Morganella" & x$species == "morganii") | (x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") | (x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMP)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMP)] <- NA
x[which((x$genus == "Citrobacter" & x$species == "freundii") | x[which((x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Enterobacter" & x$species == "aerogenes") | (x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") | | (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") | (x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Morganella" & x$species == "morganii") | (x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") | (x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMC)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMC)] <- NA
x[which((x$genus == "Citrobacter" & x$species == "freundii") | x[which((x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Citrobacter" & x$species == "koseri") | (x$genus == "Citrobacter" & x$species == "koseri") |
(x$genus == "Enterobacter" & x$species == "aerogenes") | (x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017) (x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") | | (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") | (x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(SAM)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(SAM)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") | x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "mirabilis") | (x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") | (x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(COL)] <- NA (x$genus == "Serratia" & x$species == "marcescens")), ab_NA(COL)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") | x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "mirabilis") | (x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TCY)] <- NA (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TCY)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") | x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") | (x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") | (x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") | (x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(DOX, MNO))] <- NA (x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(DOX, MNO))] <- NA
x$classes_in_guideline <- NA_integer_ x$classes_in_guideline <- NA_integer_
x$classes_available <- NA_integer_ x$classes_available <- NA_integer_
@ -1201,8 +1208,8 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, 3,
which(x$order == "Enterobacterales" | which(x$order == "Enterobacterales" |
(x$genus == "Pseudomonas" & x$species == "aeruginosa") | (x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"), x$genus == "Acinetobacter"),
COL, COL,
"all" "all"
) )
@ -1294,10 +1301,10 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, 3,
which((x$order == "Enterobacterales" & which((x$order == "Enterobacterales" &
!x$family == "Morganellaceae" & !x$family == "Morganellaceae" &
!(x$genus == "Serratia" & x$species == "marcescens")) | !(x$genus == "Serratia" & x$species == "marcescens")) |
(x$genus == "Pseudomonas" & x$species == "aeruginosa") | (x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"), x$genus == "Acinetobacter"),
COL, COL,
"all" "all"
) )
@ -1396,10 +1403,10 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, 3,
which((x$order == "Enterobacterales" & which((x$order == "Enterobacterales" &
!x$family == "Morganellaceae" & !x$family == "Morganellaceae" &
!(x$genus == "Serratia" & x$species == "marcescens")) | !(x$genus == "Serratia" & x$species == "marcescens")) |
(x$genus == "Pseudomonas" & x$species == "aeruginosa") | (x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"), x$genus == "Acinetobacter"),
COL, COL,
"all" "all"
) )
@ -1498,11 +1505,11 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
2, # 3MRGN 2, # 3MRGN
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
(x$genus == "Acinetobacter" & x$species == "baumannii")) & (x$genus == "Acinetobacter" & x$species == "baumannii")) &
try_ab(x[, PIP, 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[, 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[, IPM, drop = TRUE] != "R") | try_ab(x[, MEM, drop = TRUE] != "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")), try_ab(x[, CIP, drop = TRUE] == "R")),
c(PIP, CTX, CAZ, IPM, MEM, CIP), c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any" "any"
) )
@ -1510,11 +1517,11 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, # 4MRGN, overwrites 3MRGN if applicable 3, # 4MRGN, overwrites 3MRGN if applicable
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
(x$genus == "Acinetobacter" & x$species == "baumannii")) & (x$genus == "Acinetobacter" & x$species == "baumannii")) &
try_ab(x[, PIP, 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[, 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[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")), try_ab(x[, CIP, drop = TRUE] == "R")),
c(PIP, CTX, CAZ, IPM, MEM, CIP), c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any" "any"
) )
@ -1522,8 +1529,8 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, # 4MRGN, overwrites 3MRGN if applicable 3, # 4MRGN, overwrites 3MRGN if applicable
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
(x$genus == "Acinetobacter" & x$species == "baumannii")) & (x$genus == "Acinetobacter" & x$species == "baumannii")) &
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R"))), (try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R"))),
c(IPM, MEM), c(IPM, MEM),
"any" "any"
) )
@ -1531,12 +1538,12 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
2, # 3MRGN, if only 1 group is S 2, # 3MRGN, if only 1 group is S
which(x$genus == "Pseudomonas" & x$species == "aeruginosa" & which(x$genus == "Pseudomonas" & x$species == "aeruginosa" &
try_ab(x[, PIP, drop = TRUE] == "S") + try_ab(x[, PIP, drop = TRUE] == "S") +
try_ab(x[, CTX, drop = TRUE] == "S") + try_ab(x[, CTX, drop = TRUE] == "S") +
try_ab(x[, CAZ, drop = TRUE] == "S") + try_ab(x[, CAZ, drop = TRUE] == "S") +
try_ab(x[, IPM, drop = TRUE] == "S") + try_ab(x[, IPM, drop = TRUE] == "S") +
try_ab(x[, MEM, drop = TRUE] == "S") + try_ab(x[, MEM, drop = TRUE] == "S") +
try_ab(x[, CIP, drop = TRUE] == "S") == 1), try_ab(x[, CIP, drop = TRUE] == "S") == 1),
c(PIP, CTX, CAZ, IPM, MEM, CIP), c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any" "any"
) )
@ -1544,10 +1551,10 @@ mdro <- function(x = NULL,
trans_tbl( trans_tbl(
3, # 4MRGN otherwise 3, # 4MRGN otherwise
which((x$genus == "Pseudomonas" & x$species == "aeruginosa") & which((x$genus == "Pseudomonas" & x$species == "aeruginosa") &
try_ab(x[, PIP, 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[, 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[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")), try_ab(x[, CIP, drop = TRUE] == "R")),
c(PIP, CTX, CAZ, IPM, MEM, CIP), c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any" "any"
) )
@ -1613,10 +1620,10 @@ mdro <- function(x = NULL,
) )
if (!ab_missing(MEM) && !ab_missing(IPM) && if (!ab_missing(MEM) && !ab_missing(IPM) &&
!ab_missing(GEN) && !ab_missing(TOB) && !ab_missing(GEN) && !ab_missing(TOB) &&
!ab_missing(CIP) && !ab_missing(CIP) &&
!ab_missing(CAZ) && !ab_missing(CAZ) &&
!ab_missing(TZP)) { !ab_missing(TZP)) {
x$psae <- 0 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[, 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"] 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$second <- drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK)
x$xdr <- x$mdr & x$xdr & x$second x$xdr <- x$mdr & x$xdr & x$second
x$MDRO <- ifelse(x$xdr, 5, x$MDRO <- ifelse(x$xdr, 5,
ifelse(x$mdr, 4, ifelse(x$mdr, 4,
ifelse(x$poly, 3, ifelse(x$poly, 3,
ifelse(x$mono, 2, ifelse(x$mono, 2,
1 1
) )
) )
) )
) )
# keep all real TB, make other species NA # keep all real TB, make other species NA
x$MDRO <- ifelse(x$fullname == "Mycobacterium tuberculosis", x$MDRO, NA_real_) x$MDRO <- ifelse(x$fullname == "Mycobacterium tuberculosis", x$MDRO, NA_real_)
@ -1754,7 +1761,7 @@ mdro <- function(x = NULL,
# Fill in blanks ---- # Fill in blanks ----
# for rows that have no results # for rows that have no results
x_transposed <- as.list(as.data.frame(t(x[, cols_ab, drop = FALSE]), x_transposed <- as.list(as.data.frame(t(x[, cols_ab, drop = FALSE]),
stringsAsFactors = FALSE stringsAsFactors = FALSE
)) ))
rows_empty <- which(vapply( rows_empty <- which(vapply(
FUN.VALUE = logical(1), 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) meet_criteria(as_factor, allow_class = "logical", has_length = 1)
dots <- tryCatch(list(...), dots <- tryCatch(list(...),
error = function(e) "error" error = function(e) "error"
) )
stop_if( stop_if(
identical(dots, "error"), identical(dots, "error"),
@ -1898,8 +1905,8 @@ c.custom_mdro_guideline <- function(x, ..., as_factor = NULL) {
} }
for (g in list(...)) { for (g in list(...)) {
stop_ifnot(inherits(g, "custom_mdro_guideline"), stop_ifnot(inherits(g, "custom_mdro_guideline"),
"for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`", "for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`",
call = FALSE call = FALSE
) )
vals <- attributes(x)$values vals <- attributes(x)$values
if (!all(attributes(g)$values %in% vals)) { if (!all(attributes(g)$values %in% vals)) {
@ -1949,24 +1956,24 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
reasons <- character(length = NROW(df)) reasons <- character(length = NROW(df))
for (i in seq_len(n_dots)) { for (i in seq_len(n_dots)) {
qry <- tryCatch(eval(parse(text = guideline[[i]]$query), envir = df, enclos = parent.frame()), qry <- tryCatch(eval(parse(text = guideline[[i]]$query), envir = df, enclos = parent.frame()),
error = function(e) { error = function(e) {
AMR_env$err_msg <- e$message AMR_env$err_msg <- e$message
return("error") return("error")
} }
) )
if (identical(qry, "error")) { if (identical(qry, "error")) {
warning_("in `custom_mdro_guideline()`: rule ", i, warning_("in `custom_mdro_guideline()`: rule ", i,
" (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ", " (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
AMR_env$err_msg, AMR_env$err_msg,
call = FALSE, call = FALSE,
add_fn = font_red add_fn = font_red
) )
next next
} }
stop_ifnot(is.logical(qry), "in custom_mdro_guideline(): rule ", i, " (`", guideline[[i]]$query, stop_ifnot(is.logical(qry), "in custom_mdro_guideline(): rule ", i, " (`", guideline[[i]]$query,
"`) must return `TRUE` or `FALSE`, not ", "`) must return `TRUE` or `FALSE`, not ",
format_class(class(qry), plural = FALSE), format_class(class(qry), plural = FALSE),
call = FALSE call = FALSE
) )
new_mdros <- which(qry == TRUE & out == "") new_mdros <- which(qry == TRUE & out == "")

6
R/mo.R
View File

@ -181,8 +181,9 @@ as.mo <- function(x,
x_lower <- tolower(x) x_lower <- tolower(x)
if (any(trimws2(x_lower) %like_case% "complex$", na.rm = TRUE)) { complexes <- x[trimws2(x_lower) %like_case% "complex$"]
warning_("in `as.mo()`: translation of complexes is not supported at the moment - the input text 'complex' was ignored.", call = FALSE) 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 # WHONET: xxx = no growth
@ -935,6 +936,7 @@ convert_colloquial_input <- function(x) {
out[x %like_case% "^fung(us|i)"] <- "F_FUNGUS" out[x %like_case% "^fung(us|i)"] <- "F_FUNGUS"
# Salmonella city names, starting with capital species name - they are all S. enterica # 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.bak %like_case% "[sS]almonella [A-Z][a-z]+ ?.*" & x %unlike% "typhi"] <- "B_SLMNL_ENTR"
out[x %like_case% "salmonella group"] <- "B_SLMNL" out[x %like_case% "salmonella group"] <- "B_SLMNL"

386
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 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*. #' @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 #' @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 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 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. #' @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. #' 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: #' * 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_if(is.mic, as.rsi)
#' your_data %>% mutate(across(where(is.mic), as.rsi)) # since dplyr 1.0.0 #' 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". #' * 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. #' 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: #' * 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_if(is.disk, as.rsi)
#' your_data %>% mutate(across(where(is.disk), as.rsi)) # since dplyr 1.0.0 #' 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)`. #' 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. #' 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 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. #' 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, as.rsi.mic <- function(x,
mo = NULL, mo = NULL,
ab = deparse(substitute(x)), ab = deparse(substitute(x)),
guideline = "EUCAST", guideline = getOption("AMR_guideline", "EUCAST"),
uti = NULL, uti = NULL,
conserve_capped_values = FALSE, conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE, add_intrinsic_resistance = FALSE,
@ -426,7 +436,7 @@ as.rsi.mic <- function(x,
as.rsi.disk <- function(x, as.rsi.disk <- function(x,
mo = NULL, mo = NULL,
ab = deparse(substitute(x)), ab = deparse(substitute(x)),
guideline = "EUCAST", guideline = getOption("AMR_guideline", "EUCAST"),
uti = NULL, uti = NULL,
add_intrinsic_resistance = FALSE, add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation, reference_data = AMR::rsi_translation,
@ -451,7 +461,7 @@ as.rsi.disk <- function(x,
as.rsi.data.frame <- function(x, as.rsi.data.frame <- function(x,
..., ...,
col_mo = NULL, col_mo = NULL,
guideline = "EUCAST", guideline = getOption("AMR_guideline", "EUCAST"),
uti = NULL, uti = NULL,
conserve_capped_values = FALSE, conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE, add_intrinsic_resistance = FALSE,
@ -720,7 +730,7 @@ as_rsi_method <- function(method_short,
if (is.null(mo)) { 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", 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 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 call = FALSE
) )
} }
@ -737,7 +747,7 @@ as_rsi_method <- function(method_short,
mo.bak <- mo mo.bak <- mo
} }
# be sure to take current taxonomy, as the rsi_translation data set only contains current taxonomy # 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) guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab)) { if (is.na(ab)) {
message_("Returning NAs for unknown drug: '", font_bold(ab.bak), 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)) 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_formatted <- paste0("'", font_bold(ab.bak), "'")
agent_name <- ab_name(ab, tolower = TRUE, language = NULL) 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 <- paste0(
agent_formatted, agent_formatted,
" (", ifelse(ab.bak == ab, "", " (", ifelse(ab.bak == ab, "",
@ -779,264 +800,207 @@ as_rsi_method <- function(method_short,
as_note = 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 method <- method_short
metadata_mo <- get_mo_uncertainties() metadata_mo <- get_mo_uncertainties()
x_bak <- data.frame(x_mo = paste0(x, mo), stringsAsFactors = FALSE) df <- data.frame(values = x,
df <- unique(data.frame(x, mo, x_mo = paste0(x, mo), stringsAsFactors = FALSE)) mo = mo,
x <- df$x result = NA_rsi_,
mo <- df$mo uti = uti,
stringsAsFactors = FALSE)
if (method == "mic") { 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") { } 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_warning <- FALSE
rise_note <- FALSE rise_note <- FALSE
method_param <- toupper(method) method_coerced <- toupper(method)
ab_coerced <- ab
genera <- mo_genus(mo, language = NULL) mo_coerced <- mo
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
if (identical(reference_data, AMR::rsi_translation)) { if (identical(reference_data, AMR::rsi_translation)) {
trans <- reference_data %pm>% breakpoints <- reference_data %pm>%
subset(guideline == guideline_coerced & method == method_param & ab == ab_param) subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
if (ab_param == "AMX" && nrow(trans) == 0) { if (ab_coerced == "AMX" && nrow(breakpoints) == 0) {
ab_param <- "AMP" ab_coerced <- "AMP"
if (message_not_thrown_before("as.rsi", "AMP_for_AMX")) { breakpoints <- reference_data %pm>%
message_("(using ampicillin rules)", appendLF = FALSE, as_note = FALSE) subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
}
trans <- reference_data %pm>%
subset(guideline == guideline_coerced & method == method_param & ab == ab_param)
} }
} else { } else {
trans <- reference_data %pm>% breakpoints <- reference_data %pm>%
subset(method == method_param & ab == ab_param) subset(method == method_coerced & ab == ab_coerced)
} }
if (nrow(trans) == 0) { msgs <- character(0)
message_(" OK.", add_fn = list(font_green), as_note = FALSE) 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) load_mo_uncertainties(metadata_mo)
return(set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE), return(rep(NA_rsi_, nrow(df)))
new_class = c("rsi", "ordered", "factor")
))
} }
trans$lookup <- paste(trans$mo, trans$ab) if (guideline_coerced %like% "EUCAST") {
any_is_intrinsic_resistant <- FALSE
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))) {
add_intrinsic_resistance_to_AMR_env() 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)) { # run the rules
if (guideline_coerced %unlike% "EUCAST") { for (mo_unique in unique(df$mo)) {
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.") rows <- which(df$mo == mo_unique)
} values <- df[rows, "values", drop = TRUE]
} else { uti <- df[rows, "uti", drop = TRUE]
new_rsi[i] <- "R" new_rsi <- rep(NA_rsi_, length(rows))
next
} # 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
} }
if (mo_genus(mo_unique, language = NULL) == "Streptococcus") {
get_record <- trans %pm>% mo_current_lancefield <- as.mo(mo_unique, Lancefield = TRUE)
subset(lookup %in% c( } else {
lookup_mo[i], mo_current_lancefield <- mo_unique
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
} }
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])) { # gather all available breakpoints for current MO and sort on taxonomic rank
get_record <- get_record %pm>% # (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): # 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 # 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' pm_arrange(rank_index, pm_desc(uti)) # 'uti' is a column in data set 'rsi_translation'
} else { } else {
get_record <- get_record %pm>% breakpoints_current <- breakpoints_current %pm>%
# sort UTI = FALSE first, then UTI = TRUE # sort UTI = FALSE first, then UTI = TRUE
pm_arrange(rank_index, uti) pm_arrange(rank_index, uti)
} }
# warning section # throw notes for different body sites
records_same_mo <- get_record[get_record$mo == get_record[1, "mo", drop = TRUE], , drop = FALSE] 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)) {
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)) { # only UTI breakpoints available
# 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_formatted), " is only available for (uncomplicated) urinary tract infections (UTI) for some microorganisms, thus assuming `uti = TRUE`. See `?as.rsi`.")
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.")
rise_warning <- TRUE 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)) { } 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)) {
# uti not set and both UTI and non-UTI breakpoints available, so throw warning # both UTI and Non-UTI breakpoints available
if (mo_rank(mo[i]) %in% c("kingdom", "phylum", "class", "order")) { 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`."))
mo_formatted <- suppressMessages(suppressWarnings(mo_shortname(mo[i], language = NULL, keep_synonyms = FALSE))) breakpoints_current <- breakpoints_current %pm>%
} 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>%
pm_filter(uti == FALSE) pm_filter(uti == FALSE)
rise_warning <- TRUE } 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)) {
} 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
# breakpoints for multiple body sites available, so throw warning site <- breakpoints_current[1L, "site", drop = FALSE] # this is the one we'll take
site <- get_record[1L, "site", drop = FALSE]
if (is.na(site)) { if (is.na(site)) {
site <- paste0("an unspecified body site") site <- paste0("an unspecified body site")
} else { } 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")) { msgs <- c(msgs, paste0("Multiple breakpoints available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, "."))
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
} }
if (NROW(get_record) > 0) { # first check if mo is intrinsic resistant
# get the best hit: the top one if (isTRUE(add_intrinsic_resistance) && guideline_coerced %like% "EUCAST" && paste(mo_unique, ab_coerced) %in% AMR_env$intrinsic_resistant) {
get_record <- get_record[1L, , drop = FALSE] msgs <- c(msgs, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, ""))
if (is.na(x[i]) | (is.na(get_record$breakpoint_S) & is.na(get_record$breakpoint_R))) { new_rsi <- rep(as.rsi("R"), length(rows))
new_rsi[i] <- NA_character_
} else if (method == "mic") { } else {
new_rsi[i] <- quick_case_when( # then run the rules
isTRUE(conserve_capped_values) & isTRUE(x[i] %like% "^<[0-9]") ~ "S", breakpoints_current <- breakpoints_current[1L, , drop = FALSE]
isTRUE(conserve_capped_values) & isTRUE(x[i] %like% "^>[0-9]") ~ "R",
# these basically call `<=.mic()` and `>=.mic()`: if (method == "mic") {
isTRUE(x[i] <= get_record$breakpoint_S) ~ "S", new_rsi <- quick_case_when(
guideline_coerced %like% "EUCAST" & isTRUE(x[i] > get_record$breakpoint_R) ~ "R", is.na(values) ~ NA_rsi_,
guideline_coerced %like% "CLSI" & isTRUE(x[i] >= get_record$breakpoint_R) ~ "R", values <= breakpoints_current$breakpoint_S ~ as.rsi("S"),
# return "I" when not match the bottom or top guideline_coerced %like% "EUCAST" & values > breakpoints_current$breakpoint_R ~ as.rsi("R"),
!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R) ~ "I", 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 # and NA otherwise
TRUE ~ NA_character_ TRUE ~ NA_rsi_
) )
} else if (method == "disk") { } else if (method == "disk") {
new_rsi[i] <- quick_case_when( new_rsi <- quick_case_when(
isTRUE(as.double(x[i]) >= as.double(get_record$breakpoint_S)) ~ "S", is.na(values) ~ NA_rsi_,
guideline_coerced %like% "EUCAST" & isTRUE(as.double(x[i]) < as.double(get_record$breakpoint_R)) ~ "R", as.double(values) >= as.double(breakpoints_current$breakpoint_S) ~ as.rsi("S"),
guideline_coerced %like% "CLSI" & isTRUE(as.double(x[i]) <= as.double(get_record$breakpoint_R)) ~ "R", guideline_coerced %like% "EUCAST" & as.double(values) < as.double(breakpoints_current$breakpoint_R) ~ as.rsi("R"),
# return "I" when not match the bottom or top guideline_coerced %like% "CLSI" & as.double(values) <= as.double(breakpoints_current$breakpoint_R) ~ as.rsi("R"),
!is.na(get_record$breakpoint_S) & !is.na(get_record$breakpoint_R) ~ "I", # 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 # and NA otherwise
TRUE ~ NA_character_ TRUE ~ NA_rsi_
) )
} }
# write to verbose output # write to verbose output
AMR_env$rsi_interpretation_history <- rbind( AMR_env$rsi_interpretation_history <- rbind(
AMR_env$rsi_interpretation_history, AMR_env$rsi_interpretation_history,
# recycling 1 to 2 rows does not seem to work, which is why rep() was added
data.frame( data.frame(
datetime = Sys.time(), datetime = rep(Sys.time(), length(rows)),
index = i, index = rows,
ab_userinput = ab.bak[1], ab_input = rep(ab.bak, length(rows)),
ab_actual = ab[1], ab_guideline = rep(ab_coerced, length(rows)),
mo_userinput = mo.bak[1], mo_input = rep(mo.bak[match(mo_unique, df$mo)][1], length(rows)),
mo_actual = mo[1], mo_guideline = rep(breakpoints_current[, "mo", drop = TRUE], length(rows)),
guideline = guideline_coerced, guideline = rep(guideline_coerced, length(rows)),
ref_table = get_record[, "ref_tbl", drop = TRUE], ref_table = rep(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)),
method = method, method = rep(method_coerced, length(rows)),
input = as.double(x[i]), input = as.double(values),
outcome = new_rsi[i], outcome = as.rsi(new_rsi),
breakpoint_S_R = paste0(get_record[, "breakpoint_S", drop = TRUE], "-", get_record[, "breakpoint_R", drop = TRUE]), breakpoint_S_R = rep(paste0(breakpoints_current[, "breakpoint_S", drop = TRUE], "-", breakpoints_current[, "breakpoint_R", drop = TRUE]), length(rows)),
stringsAsFactors = FALSE stringsAsFactors = FALSE
) )
) )
} }
df[rows, "result"] <- new_rsi
} }
if (any_is_intrinsic_resistant & guideline_coerced %like% "EUCAST" & !isTRUE(add_intrinsic_resistance)) { if (isTRUE(rise_warning)) {
# found some intrinsic resistance, but was not applied message(font_yellow(font_bold(" * WARNING *")))
if (message_not_thrown_before("as.rsi", "unapplied_instrinsic")) { } else if (length(msgs) == 0) {
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.") message(font_green(" OK."))
} } else {
rise_warning <- TRUE msg_note(sort(msgs))
}
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)
}
} }
load_mo_uncertainties(metadata_mo) load_mo_uncertainties(metadata_mo)
set_clean_class(factor(new_rsi, levels = c("S", "I", "R"), ordered = TRUE), df$result
new_class = c("rsi", "ordered", "factor")
)
} }
#' @rdname as.rsi #' @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.") 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)) return(invisible(NULL))
} }
out$ab_actual <- as.ab(out$ab_actual) out$ab_guideline <- as.ab(out$ab_guideline)
out$mo_actual <- as.mo(out$mo_actual) out$mo_guideline <- as.mo(out$mo_guideline)
out$outcome <- as.rsi(out$outcome) out$outcome <- as.rsi(out$outcome)
# keep stored for next use # keep stored for next use
if (isTRUE(clean)) { if (isTRUE(clean)) {
@ -1074,7 +1038,7 @@ pillar_shaft.rsi <- function(x, ...) {
if (has_colour()) { if (has_colour()) {
# colours will anyway not work when has_colour() == FALSE, # colours will anyway not work when has_colour() == FALSE,
# but then the indentation should also not be applied # 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 == "R"] <- font_red_bg(" R ")
out[x == "S"] <- font_green_bg(" S ") out[x == "S"] <- font_green_bg(" S ")
out[x == "I"] <- font_orange_bg(" I ") 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 (print_warning == TRUE) {
if (message_not_thrown_before("rsi_calc")) { if (message_not_thrown_before("rsi_calc")) {
warning_("Increase speed by transforming to class 'rsi' on beforehand:\n", warning_("Increase speed by transforming to class 'rsi' on beforehand:\n",
" your_data %>% mutate_if(is.rsi.eligible, as.rsi)\n", " your_data %>% mutate_if(is.rsi.eligible, as.rsi)",
" your_data %>% mutate(across(where(is.rsi.eligible), as.rsi))",
call = FALSE 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) { if (utf8_supported && !is_latex) {
# \u2139 is a symbol officially named 'information source' # \u2139 is a symbol officially named 'information source'
AMR_env$info_icon <- "\u2139" AMR_env$info_icon <- "\u2139"
AMR_env$bullet_icon <- "\u2022"
} else { } else {
AMR_env$info_icon <- "i" AMR_env$info_icon <- "i"
AMR_env$bullet_icon <- "*"
} }
.onLoad <- function(lib, pkg) { .onLoad <- function(lib, pkg) {
@ -97,12 +99,12 @@ if (utf8_supported && !is_latex) {
s3_register("pillar::pillar_shaft", "rsi") s3_register("pillar::pillar_shaft", "rsi")
s3_register("pillar::pillar_shaft", "mic") s3_register("pillar::pillar_shaft", "mic")
s3_register("pillar::pillar_shaft", "disk") s3_register("pillar::pillar_shaft", "disk")
s3_register("tibble::type_sum", "ab") s3_register("pillar::type_sum", "ab")
s3_register("tibble::type_sum", "av") s3_register("pillar::type_sum", "av")
s3_register("tibble::type_sum", "mo") s3_register("pillar::type_sum", "mo")
s3_register("tibble::type_sum", "rsi") s3_register("pillar::type_sum", "rsi")
s3_register("tibble::type_sum", "mic") s3_register("pillar::type_sum", "mic")
s3_register("tibble::type_sum", "disk") s3_register("pillar::type_sum", "disk")
# Support for frequency tables from the cleaner package # Support for frequency tables from the cleaner package
s3_register("cleaner::freq", "mo") s3_register("cleaner::freq", "mo")
s3_register("cleaner::freq", "rsi") s3_register("cleaner::freq", "rsi")

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

@ -102,7 +102,7 @@ extended_functions <- c(
"autoplot" = "ggplot2", "autoplot" = "ggplot2",
"pillar_shaft" = "pillar", "pillar_shaft" = "pillar",
"get_skimmers" = "skimr", "get_skimmers" = "skimr",
"type_sum" = "tibble", "type_sum" = "pillar",
"vec_cast" = "vctrs", "vec_cast" = "vctrs",
"vec_math" = "vctrs", "vec_math" = "vctrs",
"vec_ptype2" = "vctrs" "vec_ptype2" = "vctrs"

25
man/as.rsi.Rd
View File

@ -36,7 +36,7 @@ is.rsi.eligible(x, threshold = 0.05)
x, x,
mo = NULL, mo = NULL,
ab = deparse(substitute(x)), ab = deparse(substitute(x)),
guideline = "EUCAST", guideline = getOption("AMR_guideline", "EUCAST"),
uti = NULL, uti = NULL,
conserve_capped_values = FALSE, conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE, add_intrinsic_resistance = FALSE,
@ -48,7 +48,7 @@ is.rsi.eligible(x, threshold = 0.05)
x, x,
mo = NULL, mo = NULL,
ab = deparse(substitute(x)), ab = deparse(substitute(x)),
guideline = "EUCAST", guideline = getOption("AMR_guideline", "EUCAST"),
uti = NULL, uti = NULL,
add_intrinsic_resistance = FALSE, add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation, reference_data = AMR::rsi_translation,
@ -59,7 +59,7 @@ is.rsi.eligible(x, threshold = 0.05)
x, x,
..., ...,
col_mo = NULL, col_mo = NULL,
guideline = "EUCAST", guideline = getOption("AMR_guideline", "EUCAST"),
uti = NULL, uti = NULL,
conserve_capped_values = FALSE, conserve_capped_values = FALSE,
add_intrinsic_resistance = 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{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}.} \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{ \itemize{
\item Using \code{dplyr}, R/SI interpretation can be done very easily with either: \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 \if{html}{\out{<div class="sourceCode">}}\preformatted{your_data \%>\% mutate_if(is.mic, as.rsi)
your_data \%>\% mutate(across(where(is.mic), as.rsi)) # since dplyr 1.0.0 your_data \%>\% mutate(across(where(is.mic), as.rsi))
}\if{html}{\out{</div>}} }\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". \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{ \itemize{
\item Using \code{dplyr}, R/SI interpretation can be done very easily with either: \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 \if{html}{\out{<div class="sourceCode">}}\preformatted{your_data \%>\% mutate_if(is.disk, as.rsi)
your_data \%>\% mutate(across(where(is.disk), as.rsi)) # since dplyr 1.0.0 your_data \%>\% mutate(across(where(is.disk), as.rsi))
}\if{html}{\out{</div>}} }\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)}. \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). 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. 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}{ \subsection{After Interpretation}{