mirror of
https://github.com/msberends/AMR.git
synced 2024-12-25 07:26:12 +01:00
revised as.rsi(), fix for mdro()
This commit is contained in:
parent
05d536ebb7
commit
31fb81c382
@ -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
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!
|
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*
|
||||||
|
|||||||
@ -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, ...) {
|
||||||
|
|||||||
415
R/mdro.R
415
R/mdro.R
@ -193,13 +193,17 @@ mdro <- function(x = NULL,
|
|||||||
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
|
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
|
||||||
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)) {
|
||||||
info <- message_not_thrown_before("mdro")
|
info <- message_not_thrown_before("mdro")
|
||||||
}
|
}
|
||||||
|
|
||||||
if (interactive() && isTRUE(verbose) && isTRUE(info)) {
|
if (interactive() && isTRUE(verbose) && isTRUE(info)) {
|
||||||
txt <- paste0(
|
txt <- paste0(
|
||||||
"WARNING: In Verbose mode, the mdro() function does not return the MDRO results, but instead returns a data set in logbook form with extensive info about which isolates would be MDRO-positive, or why they are not.",
|
"WARNING: In Verbose mode, the mdro() function does not return the MDRO results, but instead returns a data set in logbook form with extensive info about which isolates would be MDRO-positive, or why they are not.",
|
||||||
@ -217,7 +221,7 @@ mdro <- function(x = NULL,
|
|||||||
return(x)
|
return(x)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
group_msg <- ""
|
group_msg <- ""
|
||||||
if (isTRUE(info.bak)) {
|
if (isTRUE(info.bak)) {
|
||||||
# print group name if used in dplyr::group_by()
|
# print group name if used in dplyr::group_by()
|
||||||
@ -239,15 +243,15 @@ mdro <- function(x = NULL,
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# force regular [data.frame], not a tibble or data.table
|
# force regular [data.frame], not a tibble or data.table
|
||||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||||
|
|
||||||
if (pct_required_classes > 1) {
|
if (pct_required_classes > 1) {
|
||||||
# allow pct_required_classes = 75 -> pct_required_classes = 0.75
|
# allow pct_required_classes = 75 -> pct_required_classes = 0.75
|
||||||
pct_required_classes <- pct_required_classes / 100
|
pct_required_classes <- pct_required_classes / 100
|
||||||
}
|
}
|
||||||
|
|
||||||
guideline.bak <- guideline
|
guideline.bak <- guideline
|
||||||
if (is.list(guideline)) {
|
if (is.list(guideline)) {
|
||||||
# Custom MDRO guideline ---------------------------------------------------
|
# Custom MDRO guideline ---------------------------------------------------
|
||||||
@ -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 = " < ")),
|
||||||
""
|
""
|
||||||
),
|
),
|
||||||
"."
|
"."
|
||||||
)
|
)
|
||||||
@ -310,7 +314,7 @@ mdro <- function(x = NULL,
|
|||||||
"invalid guideline: ", guideline.bak
|
"invalid guideline: ", guideline.bak
|
||||||
)
|
)
|
||||||
guideline <- list(code = guideline)
|
guideline <- list(code = guideline)
|
||||||
|
|
||||||
# try to find columns based on type
|
# try to find columns based on type
|
||||||
# -- mo
|
# -- mo
|
||||||
if (is.null(col_mo)) {
|
if (is.null(col_mo)) {
|
||||||
@ -325,55 +329,55 @@ mdro <- function(x = NULL,
|
|||||||
col_mo <- "mo"
|
col_mo <- "mo"
|
||||||
}
|
}
|
||||||
stop_if(is.null(col_mo), "`col_mo` must be set")
|
stop_if(is.null(col_mo), "`col_mo` must be set")
|
||||||
|
|
||||||
if (guideline$code == "cmi2012") {
|
if (guideline$code == "cmi2012") {
|
||||||
guideline$name <- "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance."
|
guideline$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:
|
||||||
} else if (guideline$code == "mrgn") {
|
} else if (guideline$code == "mrgn") {
|
||||||
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)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (guideline$code == "cmi2012") {
|
if (guideline$code == "cmi2012") {
|
||||||
cols_ab <- get_column_abx(
|
cols_ab <- get_column_abx(
|
||||||
x = x,
|
x = x,
|
||||||
@ -618,7 +622,7 @@ mdro <- function(x = NULL,
|
|||||||
}
|
}
|
||||||
cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"])))
|
cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"])))
|
||||||
}
|
}
|
||||||
|
|
||||||
# nolint start
|
# nolint start
|
||||||
AMC <- cols_ab["AMC"]
|
AMC <- cols_ab["AMC"]
|
||||||
AMK <- cols_ab["AMK"]
|
AMK <- cols_ab["AMK"]
|
||||||
@ -763,13 +767,13 @@ mdro <- function(x = NULL,
|
|||||||
abx_tb <- abx_tb[!is.na(abx_tb)]
|
abx_tb <- abx_tb[!is.na(abx_tb)]
|
||||||
stop_if(guideline$code == "tb" & length(abx_tb) == 0, "no antimycobacterials found in data set")
|
stop_if(guideline$code == "tb" & length(abx_tb) == 0, "no antimycobacterials found in data set")
|
||||||
# nolint end
|
# nolint end
|
||||||
|
|
||||||
if (isTRUE(combine_SI)) {
|
if (isTRUE(combine_SI)) {
|
||||||
search_result <- "R"
|
search_result <- "R"
|
||||||
} else {
|
} else {
|
||||||
search_result <- c("R", "I")
|
search_result <- c("R", "I")
|
||||||
}
|
}
|
||||||
|
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
if (isTRUE(combine_SI)) {
|
if (isTRUE(combine_SI)) {
|
||||||
cat(font_red("\nOnly results with 'R' are considered as resistance. Use `combine_SI = FALSE` to also consider 'I' as resistance.\n"))
|
cat(font_red("\nOnly results with 'R' are considered as resistance. Use `combine_SI = FALSE` to also consider 'I' as resistance.\n"))
|
||||||
@ -777,18 +781,18 @@ mdro <- function(x = NULL,
|
|||||||
cat(font_red("\nResults with 'R' or 'I' are considered as resistance. Use `combine_SI = TRUE` to only consider 'R' as resistance.\n"))
|
cat(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 = ""
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
ab_missing <- function(ab) {
|
ab_missing <- function(ab) {
|
||||||
isTRUE(ab %in% c(NULL, NA)) | length(ab) == 0
|
isTRUE(ab %in% c(NULL, NA)) | length(ab) == 0
|
||||||
}
|
}
|
||||||
@ -800,7 +804,7 @@ mdro <- function(x = NULL,
|
|||||||
out[is.na(out)] <- FALSE
|
out[is.na(out)] <- FALSE
|
||||||
out
|
out
|
||||||
}
|
}
|
||||||
|
|
||||||
# antibiotic classes
|
# antibiotic classes
|
||||||
# nolint start
|
# nolint start
|
||||||
aminoglycosides <- c(TOB, GEN)
|
aminoglycosides <- c(TOB, GEN)
|
||||||
@ -811,7 +815,7 @@ mdro <- function(x = NULL,
|
|||||||
carbapenems <- c(DOR, ETP, IPM, MEM, MEV)
|
carbapenems <- c(DOR, ETP, IPM, MEM, MEV)
|
||||||
fluoroquinolones <- c(CIP, ENX, FLE, GAT, GEM, GRX, LVX, LOM, MFX, NOR, OFX, PAZ, PEF, PRU, RFL, SPX, TMX, TVA)
|
fluoroquinolones <- c(CIP, ENX, FLE, GAT, GEM, GRX, LVX, LOM, MFX, NOR, OFX, PAZ, PEF, PRU, RFL, SPX, TMX, TVA)
|
||||||
# nolint end
|
# nolint end
|
||||||
|
|
||||||
# helper function for editing the table
|
# helper function for editing the table
|
||||||
trans_tbl <- function(to, rows, cols, any_all) {
|
trans_tbl <- function(to, rows, cols, any_all) {
|
||||||
cols <- cols[!ab_missing(cols)]
|
cols <- cols[!ab_missing(cols)]
|
||||||
@ -840,14 +844,14 @@ mdro <- function(x = NULL,
|
|||||||
)
|
)
|
||||||
}
|
}
|
||||||
)
|
)
|
||||||
|
|
||||||
if (any_all == "any") {
|
if (any_all == "any") {
|
||||||
search_function <- any
|
search_function <- any
|
||||||
} else if (any_all == "all") {
|
} else if (any_all == "all") {
|
||||||
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),
|
||||||
@ -866,7 +870,7 @@ mdro <- function(x = NULL,
|
|||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
trans_tbl2 <- function(txt, rows, lst) {
|
trans_tbl2 <- function(txt, rows, lst) {
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
message_(txt, "...", appendLF = FALSE, as_note = FALSE)
|
message_(txt, "...", appendLF = FALSE, as_note = FALSE)
|
||||||
@ -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)
|
||||||
@ -892,7 +899,7 @@ mdro <- function(x = NULL,
|
|||||||
))
|
))
|
||||||
}
|
}
|
||||||
)
|
)
|
||||||
|
|
||||||
if (isTRUE(verbose)) {
|
if (isTRUE(verbose)) {
|
||||||
x[rows, "columns_nonsusceptible"] <<- vapply(
|
x[rows, "columns_nonsusceptible"] <<- vapply(
|
||||||
FUN.VALUE = character(1),
|
FUN.VALUE = character(1),
|
||||||
@ -920,17 +927,17 @@ 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
|
||||||
}
|
}
|
||||||
|
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]))
|
x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]))
|
||||||
# rename col_mo to prevent interference with joined columns
|
# rename col_mo to prevent interference with joined columns
|
||||||
colnames(x)[colnames(x) == col_mo] <- ".col_mo"
|
colnames(x)[colnames(x) == col_mo] <- ".col_mo"
|
||||||
@ -941,12 +948,12 @@ mdro <- function(x = NULL,
|
|||||||
x$row_number <- seq_len(nrow(x))
|
x$row_number <- seq_len(nrow(x))
|
||||||
x$reason <- paste0("not covered by ", toupper(guideline$code), " guideline")
|
x$reason <- paste0("not covered by ", toupper(guideline$code), " guideline")
|
||||||
x$columns_nonsusceptible <- ""
|
x$columns_nonsusceptible <- ""
|
||||||
|
|
||||||
if (guideline$code == "cmi2012") {
|
if (guideline$code == "cmi2012") {
|
||||||
# CMI, 2012 ---------------------------------------------------------------
|
# CMI, 2012 ---------------------------------------------------------------
|
||||||
# Non-susceptible = R and I
|
# Non-susceptible = R and I
|
||||||
# (see header 'Approaches to Creating Definitions for MDR, XDR and PDR' in paper)
|
# (see header 'Approaches to Creating Definitions for MDR, XDR and PDR' in paper)
|
||||||
|
|
||||||
# take amoxicillin if ampicillin is unavailable
|
# take amoxicillin if ampicillin is unavailable
|
||||||
if (is.na(AMP) && !is.na(AMX)) {
|
if (is.na(AMP) && !is.na(AMX)) {
|
||||||
if (isTRUE(verbose)) {
|
if (isTRUE(verbose)) {
|
||||||
@ -967,87 +974,87 @@ mdro <- function(x = NULL,
|
|||||||
}
|
}
|
||||||
CTX <- CRO
|
CTX <- CRO
|
||||||
}
|
}
|
||||||
|
|
||||||
# intrinsic resistant must not be considered for the determination of MDR,
|
# intrinsic resistant must not be considered for the determination of MDR,
|
||||||
# so let's just remove them, meticulously following the paper
|
# so let's just remove them, meticulously following the paper
|
||||||
x[which(x$genus == "Enterococcus" & x$species == "faecium"), ab_NA(IPM)] <- NA
|
x[which(x$genus == "Enterococcus" & x$species == "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_
|
||||||
x$classes_affected <- NA_integer_
|
x$classes_affected <- NA_integer_
|
||||||
|
|
||||||
# now add the MDR levels to the data
|
# now add the MDR levels to the data
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
2,
|
2,
|
||||||
@ -1149,7 +1156,7 @@ mdro <- function(x = NULL,
|
|||||||
c(TCY, DOX, MNO)
|
c(TCY, DOX, MNO)
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
# now set MDROs:
|
# now set MDROs:
|
||||||
# MDR (=2): >=3 classes affected
|
# MDR (=2): >=3 classes affected
|
||||||
x[which(x$classes_affected >= 3), "MDRO"] <- 2
|
x[which(x$classes_affected >= 3), "MDRO"] <- 2
|
||||||
@ -1161,7 +1168,7 @@ mdro <- function(x = NULL,
|
|||||||
" out of ", x$classes_available[which(x$classes_affected >= 3)], " available classes"
|
" out of ", x$classes_available[which(x$classes_affected >= 3)], " available classes"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# XDR (=3): all but <=2 classes affected
|
# XDR (=3): all but <=2 classes affected
|
||||||
x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3
|
x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3
|
||||||
if (isTRUE(verbose)) {
|
if (isTRUE(verbose)) {
|
||||||
@ -1170,7 +1177,7 @@ mdro <- function(x = NULL,
|
|||||||
" out of ", x$classes_in_guideline[which(x$MDRO == 3)], " classes)"
|
" out of ", x$classes_in_guideline[which(x$MDRO == 3)], " classes)"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# PDR (=4): all drugs are R
|
# PDR (=4): all drugs are R
|
||||||
x[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available), "MDRO"] <- 4
|
x[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available), "MDRO"] <- 4
|
||||||
if (isTRUE(verbose)) {
|
if (isTRUE(verbose)) {
|
||||||
@ -1181,7 +1188,7 @@ mdro <- function(x = NULL,
|
|||||||
ifelse(!isTRUE(combine_SI), " or I", "")
|
ifelse(!isTRUE(combine_SI), " or I", "")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# not enough classes available
|
# not enough classes available
|
||||||
x[which(x$MDRO %in% c(1, 3) & x$classes_available < floor(x$classes_in_guideline * pct_required_classes)), "MDRO"] <- -1
|
x[which(x$MDRO %in% c(1, 3) & x$classes_available < floor(x$classes_in_guideline * pct_required_classes)), "MDRO"] <- -1
|
||||||
if (isTRUE(verbose)) {
|
if (isTRUE(verbose)) {
|
||||||
@ -1191,18 +1198,18 @@ mdro <- function(x = NULL,
|
|||||||
" (~", percentage(pct_required_classes), " of ", x$classes_in_guideline[which(x$MDRO == -1)], ")"
|
" (~", percentage(pct_required_classes), " of ", x$classes_in_guideline[which(x$MDRO == -1)], ")"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# add antibiotic names of resistant ones to verbose output
|
# add antibiotic names of resistant ones to verbose output
|
||||||
}
|
}
|
||||||
|
|
||||||
if (guideline$code == "eucast3.1") {
|
if (guideline$code == "eucast3.1") {
|
||||||
# EUCAST 3.1 --------------------------------------------------------------
|
# EUCAST 3.1 --------------------------------------------------------------
|
||||||
# Table 5
|
# Table 5
|
||||||
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"
|
||||||
)
|
)
|
||||||
@ -1287,17 +1294,17 @@ mdro <- function(x = NULL,
|
|||||||
"any"
|
"any"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (guideline$code == "eucast3.2") {
|
if (guideline$code == "eucast3.2") {
|
||||||
# EUCAST 3.2 --------------------------------------------------------------
|
# EUCAST 3.2 --------------------------------------------------------------
|
||||||
# Table 6
|
# Table 6
|
||||||
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"
|
||||||
)
|
)
|
||||||
@ -1388,7 +1395,7 @@ mdro <- function(x = NULL,
|
|||||||
"any"
|
"any"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (guideline$code == "eucast3.3") {
|
if (guideline$code == "eucast3.3") {
|
||||||
# EUCAST 3.3 --------------------------------------------------------------
|
# EUCAST 3.3 --------------------------------------------------------------
|
||||||
# note: this guideline is equal to EUCAST 3.2 - no MDRO insights changed
|
# note: this guideline is equal to EUCAST 3.2 - no MDRO insights changed
|
||||||
@ -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"
|
||||||
)
|
)
|
||||||
@ -1490,72 +1497,72 @@ mdro <- function(x = NULL,
|
|||||||
"any"
|
"any"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (guideline$code == "mrgn") {
|
if (guideline$code == "mrgn") {
|
||||||
# Germany -----------------------------------------------------------------
|
# Germany -----------------------------------------------------------------
|
||||||
|
|
||||||
# Table 1
|
# Table 1
|
||||||
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"
|
||||||
)
|
)
|
||||||
|
|
||||||
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"
|
||||||
)
|
)
|
||||||
|
|
||||||
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"
|
||||||
)
|
)
|
||||||
|
|
||||||
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"
|
||||||
)
|
)
|
||||||
|
|
||||||
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"
|
||||||
)
|
)
|
||||||
|
|
||||||
x[which(x$MDRO == 2), "reason"] <- "3MRGN"
|
x[which(x$MDRO == 2), "reason"] <- "3MRGN"
|
||||||
x[which(x$MDRO == 3), "reason"] <- "4MRGN"
|
x[which(x$MDRO == 3), "reason"] <- "4MRGN"
|
||||||
}
|
}
|
||||||
|
|
||||||
if (guideline$code == "brmo") {
|
if (guideline$code == "brmo") {
|
||||||
# Netherlands -------------------------------------------------------------
|
# Netherlands -------------------------------------------------------------
|
||||||
aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)]
|
aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)]
|
||||||
@ -1568,7 +1575,7 @@ mdro <- function(x = NULL,
|
|||||||
if (length(ESBLs) != 2) {
|
if (length(ESBLs) != 2) {
|
||||||
ESBLs <- character(0)
|
ESBLs <- character(0)
|
||||||
}
|
}
|
||||||
|
|
||||||
# Table 1
|
# Table 1
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
3,
|
3,
|
||||||
@ -1576,21 +1583,21 @@ mdro <- function(x = NULL,
|
|||||||
c(aminoglycosides, fluoroquinolones),
|
c(aminoglycosides, fluoroquinolones),
|
||||||
"all"
|
"all"
|
||||||
)
|
)
|
||||||
|
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
2,
|
2,
|
||||||
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
|
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
|
||||||
carbapenems,
|
carbapenems,
|
||||||
"any"
|
"any"
|
||||||
)
|
)
|
||||||
|
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
2,
|
2,
|
||||||
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
|
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
|
||||||
ESBLs,
|
ESBLs,
|
||||||
"all"
|
"all"
|
||||||
)
|
)
|
||||||
|
|
||||||
# Table 2
|
# Table 2
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
2,
|
2,
|
||||||
@ -1604,19 +1611,19 @@ mdro <- function(x = NULL,
|
|||||||
c(aminoglycosides, fluoroquinolones),
|
c(aminoglycosides, fluoroquinolones),
|
||||||
"all"
|
"all"
|
||||||
)
|
)
|
||||||
|
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
3,
|
3,
|
||||||
which(x$genus == "Stenotrophomonas" & x$species == "maltophilia"),
|
which(x$genus == "Stenotrophomonas" & x$species == "maltophilia"),
|
||||||
SXT,
|
SXT,
|
||||||
"all"
|
"all"
|
||||||
)
|
)
|
||||||
|
|
||||||
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"]
|
||||||
@ -1636,7 +1643,7 @@ mdro <- function(x = NULL,
|
|||||||
x$genus == "Pseudomonas" & x$species == "aeruginosa" &
|
x$genus == "Pseudomonas" & x$species == "aeruginosa" &
|
||||||
x$psae >= 3
|
x$psae >= 3
|
||||||
), "reason"] <- paste0("at least 3 classes contain R", ifelse(!isTRUE(combine_SI), " or I", ""))
|
), "reason"] <- paste0("at least 3 classes contain R", ifelse(!isTRUE(combine_SI), " or I", ""))
|
||||||
|
|
||||||
# Table 3
|
# Table 3
|
||||||
trans_tbl(
|
trans_tbl(
|
||||||
3,
|
3,
|
||||||
@ -1657,7 +1664,7 @@ mdro <- function(x = NULL,
|
|||||||
"all"
|
"all"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (guideline$code == "tb") {
|
if (guideline$code == "tb") {
|
||||||
# Tuberculosis ------------------------------------------------------------
|
# Tuberculosis ------------------------------------------------------------
|
||||||
prepare_drug <- function(ab) {
|
prepare_drug <- function(ab) {
|
||||||
@ -1694,7 +1701,7 @@ mdro <- function(x = NULL,
|
|||||||
ab != "R"
|
ab != "R"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
x$mono_count <- 0
|
x$mono_count <- 0
|
||||||
x[drug_is_R(INH), "mono_count"] <- x[drug_is_R(INH), "mono_count", drop = TRUE] + 1
|
x[drug_is_R(INH), "mono_count"] <- x[drug_is_R(INH), "mono_count", drop = TRUE] + 1
|
||||||
x[drug_is_R(RIF), "mono_count"] <- x[drug_is_R(RIF), "mono_count", drop = TRUE] + 1
|
x[drug_is_R(RIF), "mono_count"] <- x[drug_is_R(RIF), "mono_count", drop = TRUE] + 1
|
||||||
@ -1702,7 +1709,7 @@ mdro <- function(x = NULL,
|
|||||||
x[drug_is_R(PZA), "mono_count"] <- x[drug_is_R(PZA), "mono_count", drop = TRUE] + 1
|
x[drug_is_R(PZA), "mono_count"] <- x[drug_is_R(PZA), "mono_count", drop = TRUE] + 1
|
||||||
x[drug_is_R(RIB), "mono_count"] <- x[drug_is_R(RIB), "mono_count", drop = TRUE] + 1
|
x[drug_is_R(RIB), "mono_count"] <- x[drug_is_R(RIB), "mono_count", drop = TRUE] + 1
|
||||||
x[drug_is_R(RFP), "mono_count"] <- x[drug_is_R(RFP), "mono_count", drop = TRUE] + 1
|
x[drug_is_R(RFP), "mono_count"] <- x[drug_is_R(RFP), "mono_count", drop = TRUE] + 1
|
||||||
|
|
||||||
x$mono <- x$mono_count > 0
|
x$mono <- x$mono_count > 0
|
||||||
x$poly <- x$mono_count > 1 & drug_is_not_R(RIF) & drug_is_not_R(INH)
|
x$poly <- x$mono_count > 1 & drug_is_not_R(RIF) & drug_is_not_R(INH)
|
||||||
x$mdr <- drug_is_R(RIF) & drug_is_R(INH)
|
x$mdr <- drug_is_R(RIF) & drug_is_R(INH)
|
||||||
@ -1710,19 +1717,19 @@ mdro <- function(x = NULL,
|
|||||||
x$second <- drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK)
|
x$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_)
|
||||||
x$reason <- "PDR/MDR/XDR criteria were met"
|
x$reason <- "PDR/MDR/XDR criteria were met"
|
||||||
}
|
}
|
||||||
|
|
||||||
# some more info on negative results
|
# some more info on negative results
|
||||||
if (isTRUE(verbose)) {
|
if (isTRUE(verbose)) {
|
||||||
if (guideline$code == "cmi2012") {
|
if (guideline$code == "cmi2012") {
|
||||||
@ -1738,7 +1745,7 @@ mdro <- function(x = NULL,
|
|||||||
x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R"
|
x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R"
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
if (isTRUE(info.bak)) {
|
if (isTRUE(info.bak)) {
|
||||||
cat(group_msg)
|
cat(group_msg)
|
||||||
if (sum(!is.na(x$MDRO)) == 0) {
|
if (sum(!is.na(x$MDRO)) == 0) {
|
||||||
@ -1750,11 +1757,11 @@ 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),
|
||||||
@ -1768,7 +1775,7 @@ mdro <- function(x = NULL,
|
|||||||
} else {
|
} else {
|
||||||
cat("\n")
|
cat("\n")
|
||||||
}
|
}
|
||||||
|
|
||||||
# Results ----
|
# Results ----
|
||||||
if (guideline$code == "cmi2012") {
|
if (guideline$code == "cmi2012") {
|
||||||
if (any(x$MDRO == -1, na.rm = TRUE)) {
|
if (any(x$MDRO == -1, na.rm = TRUE)) {
|
||||||
@ -1815,7 +1822,7 @@ mdro <- function(x = NULL,
|
|||||||
ordered = TRUE
|
ordered = TRUE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (isTRUE(verbose)) {
|
if (isTRUE(verbose)) {
|
||||||
colnames(x)[colnames(x) == col_mo] <- "microorganism"
|
colnames(x)[colnames(x) == col_mo] <- "microorganism"
|
||||||
x$microorganism <- mo_name(x$microorganism, language = NULL)
|
x$microorganism <- mo_name(x$microorganism, language = NULL)
|
||||||
@ -1837,9 +1844,9 @@ mdro <- function(x = NULL,
|
|||||||
#' @export
|
#' @export
|
||||||
custom_mdro_guideline <- function(..., as_factor = TRUE) {
|
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"),
|
||||||
@ -1853,7 +1860,7 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
|
|||||||
inherits(dots[[i]], "formula"),
|
inherits(dots[[i]], "formula"),
|
||||||
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?mdro`"
|
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?mdro`"
|
||||||
)
|
)
|
||||||
|
|
||||||
# Query
|
# Query
|
||||||
qry <- dots[[i]][[2]]
|
qry <- dots[[i]][[2]]
|
||||||
if (inherits(qry, "call")) {
|
if (inherits(qry, "call")) {
|
||||||
@ -1869,14 +1876,14 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
|
|||||||
qry <- gsub(" *([&|+-/*^><==]+) *", " \\1 ", qry)
|
qry <- gsub(" *([&|+-/*^><==]+) *", " \\1 ", qry)
|
||||||
qry <- gsub("'", "\"", qry, fixed = TRUE)
|
qry <- gsub("'", "\"", qry, fixed = TRUE)
|
||||||
out[[i]]$query <- as.expression(qry)
|
out[[i]]$query <- as.expression(qry)
|
||||||
|
|
||||||
# Value
|
# Value
|
||||||
val <- tryCatch(eval(dots[[i]][[3]]), error = function(e) NULL)
|
val <- tryCatch(eval(dots[[i]][[3]]), error = function(e) NULL)
|
||||||
stop_if(is.null(val), "rule ", i, " must return a valid value, it now returns an error: ", tryCatch(eval(dots[[i]][[3]]), error = function(e) e$message))
|
stop_if(is.null(val), "rule ", i, " must return a valid value, it now returns an error: ", tryCatch(eval(dots[[i]][[3]]), error = function(e) e$message))
|
||||||
stop_if(length(val) > 1, "rule ", i, " must return a value of length 1, not ", length(val))
|
stop_if(length(val) > 1, "rule ", i, " must return a value of length 1, not ", length(val))
|
||||||
out[[i]]$value <- as.character(val)
|
out[[i]]$value <- as.character(val)
|
||||||
}
|
}
|
||||||
|
|
||||||
names(out) <- paste0("rule", seq_len(n_dots))
|
names(out) <- paste0("rule", seq_len(n_dots))
|
||||||
out <- set_clean_class(out, new_class = c("custom_mdro_guideline", "list"))
|
out <- set_clean_class(out, new_class = c("custom_mdro_guideline", "list"))
|
||||||
attr(out, "values") <- unname(c("Negative", vapply(FUN.VALUE = character(1), unclass(out), function(x) x$value)))
|
attr(out, "values") <- unname(c("Negative", vapply(FUN.VALUE = character(1), unclass(out), function(x) x$value)))
|
||||||
@ -1898,8 +1905,8 @@ c.custom_mdro_guideline <- function(x, ..., as_factor = NULL) {
|
|||||||
}
|
}
|
||||||
for (g in list(...)) {
|
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,28 +1956,28 @@ 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 == "")
|
||||||
|
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
cat(word_wrap(
|
cat(word_wrap(
|
||||||
"- Custom MDRO rule ", i, ": `", as.character(guideline[[i]]$query),
|
"- Custom MDRO rule ", i, ": `", as.character(guideline[[i]]$query),
|
||||||
@ -1986,11 +1993,11 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
|
|||||||
}
|
}
|
||||||
out[out == ""] <- "Negative"
|
out[out == ""] <- "Negative"
|
||||||
reasons[out == "Negative"] <- "no rules matched"
|
reasons[out == "Negative"] <- "no rules matched"
|
||||||
|
|
||||||
if (isTRUE(attributes(guideline)$as_factor)) {
|
if (isTRUE(attributes(guideline)$as_factor)) {
|
||||||
out <- factor(out, levels = attributes(guideline)$values, ordered = TRUE)
|
out <- factor(out, levels = attributes(guideline)$values, ordered = TRUE)
|
||||||
}
|
}
|
||||||
|
|
||||||
columns_nonsusceptible <- as.data.frame(t(df[, is.rsi(df), drop = FALSE] == "R"))
|
columns_nonsusceptible <- as.data.frame(t(df[, is.rsi(df), drop = FALSE] == "R"))
|
||||||
columns_nonsusceptible <- vapply(
|
columns_nonsusceptible <- vapply(
|
||||||
FUN.VALUE = character(1),
|
FUN.VALUE = character(1),
|
||||||
@ -1998,7 +2005,7 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
|
|||||||
function(x) paste0(rownames(columns_nonsusceptible)[which(x)], collapse = " ")
|
function(x) paste0(rownames(columns_nonsusceptible)[which(x)], collapse = " ")
|
||||||
)
|
)
|
||||||
columns_nonsusceptible[is.na(out)] <- NA_character_
|
columns_nonsusceptible[is.na(out)] <- NA_character_
|
||||||
|
|
||||||
data.frame(
|
data.frame(
|
||||||
row_number = seq_len(NROW(df)),
|
row_number = seq_len(NROW(df)),
|
||||||
MDRO = out,
|
MDRO = out,
|
||||||
|
|||||||
6
R/mo.R
6
R/mo.R
@ -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"
|
||||||
|
|
||||||
|
|||||||
404
R/rsi.R
404
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 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)`.
|
||||||
#'
|
#'
|
||||||
@ -71,6 +71,16 @@
|
|||||||
#' For interpreting MIC values as well as disk diffusion diameters, currently implemented guidelines are EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`).
|
#' For interpreting MIC values as well as disk diffusion diameters, currently implemented guidelines are EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`).
|
||||||
#'
|
#'
|
||||||
#' Thus, the `guideline` argument must be set to e.g., ``r paste0('"', subset(rsi_translation, guideline %like% "EUCAST")$guideline[1], '"')`` or ``r paste0('"', subset(rsi_translation, guideline %like% "CLSI")$guideline[1], '"')``. By simply using `"EUCAST"` (the default) or `"CLSI"` as input, the latest included version of that guideline will automatically be selected. You can set your own data set using the `reference_data` argument. The `guideline` argument will then be ignored.
|
#' 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
|
||||||
#'
|
#'
|
||||||
@ -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),
|
||||||
@ -756,10 +766,21 @@ as_rsi_method <- function(method_short,
|
|||||||
if (length(uti) == 1) {
|
if (length(uti) == 1) {
|
||||||
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, "",
|
||||||
@ -778,265 +799,208 @@ as_rsi_method <- function(method_short,
|
|||||||
appendLF = FALSE,
|
appendLF = FALSE,
|
||||||
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
|
|
||||||
|
# run the rules
|
||||||
if (isTRUE(add_intrinsic_resistance) && isTRUE(is_intrinsic_r)) {
|
for (mo_unique in unique(df$mo)) {
|
||||||
if (guideline_coerced %unlike% "EUCAST") {
|
|
||||||
if (message_not_thrown_before("as.rsi", "intrinsic")) {
|
rows <- which(df$mo == mo_unique)
|
||||||
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.")
|
values <- df[rows, "values", drop = TRUE]
|
||||||
}
|
uti <- df[rows, "uti", drop = TRUE]
|
||||||
} else {
|
new_rsi <- rep(NA_rsi_, length(rows))
|
||||||
new_rsi[i] <- "R"
|
|
||||||
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")
|
||||||
if (isTRUE(uti[i])) {
|
# formatted for notes
|
||||||
get_record <- get_record %pm>%
|
mo_formatted <- suppressMessages(suppressWarnings(mo_fullname(mo_unique, language = NULL, keep_synonyms = FALSE)))
|
||||||
|
if (!mo_rank(mo_unique) %in% c("kingdom", "phylum", "class", "order")) {
|
||||||
|
mo_formatted <- font_italic(mo_formatted)
|
||||||
|
}
|
||||||
|
ab_formatted <- paste0(suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
|
||||||
|
" (", ab_coerced, ")")
|
||||||
|
|
||||||
|
# gather all available breakpoints for current MO and sort on taxonomic rank
|
||||||
|
# (this will prefer species breakpoints over order breakpoints)
|
||||||
|
breakpoints_current <- breakpoints %pm>%
|
||||||
|
subset(mo %in% c(mo_current_genus, mo_current_family,
|
||||||
|
mo_current_order, mo_current_class,
|
||||||
|
mo_current_becker, mo_current_lancefield,
|
||||||
|
mo_current_other))
|
||||||
|
|
||||||
|
if (any(df[rows, "uti", drop = TRUE], na.rm = TRUE)) {
|
||||||
|
breakpoints_current <- breakpoints_current %pm>%
|
||||||
# be as specific as possible (i.e. prefer species over genus):
|
# 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)) {
|
|
||||||
# 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)) {
|
if (isTRUE(rise_warning)) {
|
||||||
# notes already a have green "NOTE" text by this point
|
message(font_yellow(font_bold(" * WARNING *")))
|
||||||
if (isTRUE(rise_warning)) {
|
} else if (length(msgs) == 0) {
|
||||||
message_(" WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE)
|
message(font_green(" OK."))
|
||||||
} else {
|
} else {
|
||||||
message_(" OK.", add_fn = list(font_green), as_note = FALSE)
|
msg_note(sort(msgs))
|
||||||
}
|
|
||||||
}
|
}
|
||||||
|
|
||||||
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 ")
|
||||||
|
|||||||
@ -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
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) {
|
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")
|
||||||
|
|||||||
@ -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"
|
||||||
|
|||||||
@ -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}{
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user