mirror of
https://github.com/msberends/AMR.git
synced 2025-07-08 16:42:10 +02:00
Update clinical breakpoints and fix some as.mo() bugs (#117)
* Updates clinical breakpoints EUCAST/CLSI 2023, fixes #102, fixes #112, fixes #113, fixes #114, fixes #115 * docs * implement ecoffs * unit tests
This commit is contained in:
Dr. Matthijs Berends
committed by
GitHub
GitHub
parent
9591688811
commit
f065945d7b
@ -36,7 +36,7 @@
|
||||
#'
|
||||
#' This work was published in the Journal of Statistical Software (Volume 104(3); \doi{jss.v104.i03}) and formed the basis of two PhD theses (\doi{10.33612/diss.177417131} and \doi{10.33612/diss.192486375}).
|
||||
#'
|
||||
#' After installing this package, R knows [**`r format_included_data_number(AMR::microorganisms)` microorganisms**](https://msberends.github.io/AMR/reference/microorganisms.html) (updated `r format(TAXONOMY_VERSION$GBIF$accessed_date, "%B %Y")`) and all [**`r format_included_data_number(nrow(AMR::antibiotics) + nrow(AMR::antivirals))` antibiotic, antimycotic and antiviral drugs**](https://msberends.github.io/AMR/reference/antibiotics.html) by name and code (including ATC, EARS-Net, ASIARS-Net, PubChem, LOINC and SNOMED CT), and knows all about valid SIR and MIC values. The integral breakpoint guidelines from CLSI and EUCAST are included from the last 10 years. It supports and can read any data format, including WHONET data. This package works on Windows, macOS and Linux with all versions of R since R-3.0 (April 2013). **It was designed to work in any setting, including those with very limited resources**. It was created for both routine data analysis and academic research at the Faculty of Medical Sciences of the [University of Groningen](https://www.rug.nl), in collaboration with non-profit organisations [Certe Medical Diagnostics and Advice Foundation](https://www.certe.nl) and [University Medical Center Groningen](https://www.umcg.nl).
|
||||
#' After installing this package, R knows [**`r format_included_data_number(AMR::microorganisms)` microorganisms**](https://msberends.github.io/AMR/reference/microorganisms.html) (updated `r format(TAXONOMY_VERSION$GBIF$accessed_date, "%B %Y")`) and all [**`r format_included_data_number(nrow(AMR::antibiotics) + nrow(AMR::antivirals))` antibiotic, antimycotic and antiviral drugs**](https://msberends.github.io/AMR/reference/antibiotics.html) by name and code (including ATC, EARS-Net, ASIARS-Net, PubChem, LOINC and SNOMED CT), and knows all about valid SIR and MIC values. The integral clinical breakpoint guidelines from CLSI and EUCAST are included, even with epidemiological cut-off (ECOFF) values. It supports and can read any data format, including WHONET data. This package works on Windows, macOS and Linux with all versions of R since R-3.0 (April 2013). **It was designed to work in any setting, including those with very limited resources**. It was created for both routine data analysis and academic research at the Faculty of Medical Sciences of the [University of Groningen](https://www.rug.nl), in collaboration with non-profit organisations [Certe Medical Diagnostics and Advice Foundation](https://www.certe.nl) and [University Medical Center Groningen](https://www.umcg.nl).
|
||||
#'
|
||||
#' The `AMR` package is available in `r vector_and(vapply(FUN.VALUE = character(1), LANGUAGES_SUPPORTED_NAMES, function(x) x$exonym), quotes = FALSE, sort = FALSE)`. Antimicrobial drug (group) names and colloquial microorganism names are provided in these languages.
|
||||
#' @section Reference Data Publicly Available:
|
||||
|
||||
@ -30,6 +30,12 @@
|
||||
# add new version numbers here, and add the rules themselves to "data-raw/eucast_rules.tsv" and clinical_breakpoints
|
||||
# (sourcing "data-raw/_pre_commit_hook.R" will process the TSV file)
|
||||
EUCAST_VERSION_BREAKPOINTS <- list(
|
||||
"13.0" = list(
|
||||
version_txt = "v13.0",
|
||||
year = 2023,
|
||||
title = "'EUCAST Clinical Breakpoint Tables'",
|
||||
url = "https://www.eucast.org/clinical_breakpoints/"
|
||||
),
|
||||
"12.0" = list(
|
||||
version_txt = "v12.0",
|
||||
year = 2022,
|
||||
@ -50,10 +56,10 @@ EUCAST_VERSION_BREAKPOINTS <- list(
|
||||
)
|
||||
)
|
||||
EUCAST_VERSION_EXPERT_RULES <- list(
|
||||
"3.1" = list(
|
||||
version_txt = "v3.1",
|
||||
year = 2016,
|
||||
title = "'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes'",
|
||||
"3.3" = list(
|
||||
version_txt = "v3.3",
|
||||
year = 2021,
|
||||
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
|
||||
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
|
||||
),
|
||||
"3.2" = list(
|
||||
@ -62,10 +68,18 @@ EUCAST_VERSION_EXPERT_RULES <- list(
|
||||
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
|
||||
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
|
||||
),
|
||||
"3.3" = list(
|
||||
version_txt = "v3.3",
|
||||
year = 2021,
|
||||
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
|
||||
"3.1" = list(
|
||||
version_txt = "v3.1",
|
||||
year = 2016,
|
||||
title = "'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes'",
|
||||
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
|
||||
)
|
||||
)
|
||||
EUCAST_VERSION_RESISTANTPHENOTYPES <- list(
|
||||
"1.2" = list(
|
||||
version_txt = "v1.2",
|
||||
year = 2023,
|
||||
title = "'Expected Resistant Phenotypes'",
|
||||
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
|
||||
)
|
||||
)
|
||||
|
||||
@ -37,6 +37,7 @@
|
||||
#' * `AMR_guideline` \cr Used for setting the default guideline for interpreting MIC values and disk diffusion diameters with [as.sir()]. Can be only the guideline name (e.g., `"CLSI"`) or the name with a year (e.g. `"CLSI 2019"`). The default to the latest implemented EUCAST guideline, currently \code{"`r clinical_breakpoints$guideline[1]`"}. Supported guideline are currently EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`).
|
||||
#' * `AMR_ignore_pattern` \cr A [regular expression][base::regex] to ignore (i.e., make `NA`) any match given in [as.mo()] and all [`mo_*`][mo_property()] functions.
|
||||
#' * `AMR_include_PKPD` \cr A [logical] to use in [as.sir()], to indicate that PK/PD clinical breakpoints must be applied as a last resort - the default is `TRUE`.
|
||||
#' * `AMR_ecoff` \cr A [logical] use in [as.sir()], to indicate that ECOFF (Epidemiological Cut-Off) values must be used - the default is `FALSE`.
|
||||
#' * `AMR_include_screening` \cr A [logical] to use in [as.sir()], to indicate that clinical breakpoints for screening are allowed - the default is `FALSE`.
|
||||
#' * `AMR_keep_synonyms` \cr A [logical] to use in [as.mo()] and all [`mo_*`][mo_property()] functions, to indicate if old, previously valid taxonomic names must be preserved and not be corrected to currently accepted names. The default is `FALSE`.
|
||||
#' * `AMR_cleaning_regex` \cr A [regular expression][base::regex] (case-insensitive) to use in [as.mo()] and all [`mo_*`][mo_property()] functions, to clean the user input. The default is the outcome of [mo_cleaning_regex()], which removes texts between brackets and texts such as "species" and "serovar".
|
||||
|
||||
@ -620,7 +620,7 @@ administrable_iv <- function(only_sir_columns = FALSE, ...) {
|
||||
|
||||
#' @rdname antibiotic_class_selectors
|
||||
#' @inheritParams eucast_rules
|
||||
#' @details The [not_intrinsic_resistant()] function can be used to only select antibiotic columns that pose no intrinsic resistance for the microorganisms in the data set. For example, if a data set contains only microorganism codes or names of *E. coli* and *K. pneumoniae* and contains a column "vancomycin", this column will be removed (or rather, unselected) using this function. It currently applies `r format_eucast_version_nr(names(EUCAST_VERSION_EXPERT_RULES[length(EUCAST_VERSION_EXPERT_RULES)]))` to determine intrinsic resistance, using the [eucast_rules()] function internally. Because of this determination, this function is quite slow in terms of performance.
|
||||
#' @details The [not_intrinsic_resistant()] function can be used to only select antibiotic columns that pose no intrinsic resistance for the microorganisms in the data set. For example, if a data set contains only microorganism codes or names of *E. coli* and *K. pneumoniae* and contains a column "vancomycin", this column will be removed (or rather, unselected) using this function. It currently applies `r format_eucast_version_nr(names(EUCAST_VERSION_EXPERT_RULES[1]))` to determine intrinsic resistance, using the [eucast_rules()] function internally. Because of this determination, this function is quite slow in terms of performance.
|
||||
#' @export
|
||||
not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, version_expertrules = 3.3, ...) {
|
||||
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
||||
|
||||
8
R/data.R
8
R/data.R
@ -257,8 +257,11 @@
|
||||
#' - `disk_dose`\cr Dose of the used disk diffusion method
|
||||
#' - `breakpoint_S`\cr Lowest MIC value or highest number of millimetres that leads to "S"
|
||||
#' - `breakpoint_R`\cr Highest MIC value or lowest number of millimetres that leads to "R"
|
||||
#' - `ecoff`\cr Epidemiological cut-off (ECOFF) value, used in antimicrobial susceptibility testing to differentiate between wild-type and non-wild-type strains of bacteria or fungi (use [`as.sir(..., ecoff = TRUE)`][as.sir()] to interpret raw data using ECOFF values)
|
||||
#' - `uti`\cr A [logical] value (`TRUE`/`FALSE`) to indicate whether the rule applies to a urinary tract infection (UTI)
|
||||
#' @details
|
||||
#' Clinical breakpoints are validated through [WHONET](https://whonet.org), a free desktop Windows application developed and supported by the WHO Collaborating Centre for Surveillance of Antimicrobial Resistance. More can be read on [their website](https://whonet.org).
|
||||
#'
|
||||
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
|
||||
#'
|
||||
#' They **allow for machine reading EUCAST and CLSI guidelines**, which is almost impossible with the MS Excel and PDF files distributed by EUCAST and CLSI.
|
||||
@ -296,11 +299,8 @@
|
||||
#' - `administration`\cr Route of administration, either `r vector_or(dosage$administration)`
|
||||
#' - `notes`\cr Additional dosage notes
|
||||
#' - `original_txt`\cr Original text in the PDF file of EUCAST
|
||||
#' - `eucast_version`\cr Version number of the EUCAST Clinical Breakpoints guideline to which these dosages apply
|
||||
#' - `eucast_version`\cr Version number of the EUCAST Clinical Breakpoints guideline to which these dosages apply, either `r vector_or(dosage$eucast_version, quotes = FALSE, sort = TRUE, reverse = TRUE)`
|
||||
#' @details
|
||||
#' This data set is based on `r format_eucast_version_nr(12.0)` and `r format_eucast_version_nr(11.0)`.
|
||||
#'
|
||||
#' ### Direct download
|
||||
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
|
||||
#' @examples
|
||||
#' dosage
|
||||
|
||||
@ -63,8 +63,9 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
|
||||
#' @param info a [logical] to indicate whether progress should be printed to the console - the default is only print while in interactive sessions
|
||||
#' @param rules a [character] vector that specifies which rules should be applied. Must be one or more of `"breakpoints"`, `"expert"`, `"other"`, `"custom"`, `"all"`, and defaults to `c("breakpoints", "expert")`. The default value can be set to another value using the [package option][AMR-options] [`AMR_eucastrules`][AMR-options]: `options(AMR_eucastrules = "all")`. If using `"custom"`, be sure to fill in argument `custom_rules` too. Custom rules can be created with [custom_eucast_rules()].
|
||||
#' @param verbose a [logical] to turn Verbose mode on and off (default is off). In Verbose mode, the function does not apply rules to the data, but instead returns a data set in logbook form with extensive info about which rows and columns would be effected and in which way. Using Verbose mode takes a lot more time.
|
||||
#' @param version_breakpoints the version number to use for the EUCAST Clinical Breakpoints guideline. Can be either `r vector_or(names(EUCAST_VERSION_BREAKPOINTS), reverse = TRUE)`.
|
||||
#' @param version_expertrules the version number to use for the EUCAST Expert Rules and Intrinsic Resistance guideline. Can be either `r vector_or(names(EUCAST_VERSION_EXPERT_RULES), reverse = TRUE)`.
|
||||
#' @param version_breakpoints the version number to use for the EUCAST Clinical Breakpoints guideline. Can be `r vector_or(names(EUCAST_VERSION_BREAKPOINTS), reverse = TRUE)`.
|
||||
#' @param version_expertrules the version number to use for the EUCAST Expert Rules and Intrinsic Resistance guideline. Can be `r vector_or(names(EUCAST_VERSION_EXPERT_RULES), reverse = TRUE)`.
|
||||
#' @param version_resistant_phenotypes the version number to use for the EUCAST Expected Resistant Phenotypes. Can be `r vector_or(names(EUCAST_VERSION_RESISTANTPHENOTYPES), reverse = TRUE)`.
|
||||
#' @param ampc_cephalosporin_resistance a [character] value that should be applied to cefotaxime, ceftriaxone and ceftazidime for AmpC de-repressed cephalosporin-resistant mutants - the default is `NA`. Currently only works when `version_expertrules` is `3.2` and higher; these version of '*EUCAST Expert Rules on Enterobacterales*' state that results of cefotaxime, ceftriaxone and ceftazidime should be reported with a note, or results should be suppressed (emptied) for these three drugs. A value of `NA` (the default) for this argument will remove results for these three drugs, while e.g. a value of `"R"` will make the results for these drugs resistant. Use `NULL` or `FALSE` to not alter results for these three drugs of AmpC de-repressed cephalosporin-resistant mutants. Using `TRUE` is equal to using `"R"`. \cr For *EUCAST Expert Rules* v3.2, this rule applies to: `r vector_and(gsub("[^a-zA-Z ]+", "", unlist(strsplit(EUCAST_RULES_DF[which(EUCAST_RULES_DF$reference.version %in% c(3.2, 3.3) & EUCAST_RULES_DF$reference.rule %like% "ampc"), "this_value"][1], "|", fixed = TRUE))), quotes = "*")`.
|
||||
#' @param ... column name of an antibiotic, see section *Antibiotics* below
|
||||
#' @param ab any (vector of) text that can be coerced to a valid antibiotic drug code with [as.ab()]
|
||||
@ -167,6 +168,7 @@ eucast_rules <- function(x,
|
||||
verbose = FALSE,
|
||||
version_breakpoints = 12.0,
|
||||
version_expertrules = 3.3,
|
||||
version_resistant_phenotypes = 1.2,
|
||||
ampc_cephalosporin_resistance = NA,
|
||||
only_sir_columns = FALSE,
|
||||
custom_rules = NULL,
|
||||
@ -178,6 +180,7 @@ eucast_rules <- function(x,
|
||||
meet_criteria(verbose, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(version_breakpoints, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_BREAKPOINTS)))
|
||||
meet_criteria(version_expertrules, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_EXPERT_RULES)))
|
||||
meet_criteria(version_resistant_phenotypes, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_RESISTANTPHENOTYPES)))
|
||||
meet_criteria(ampc_cephalosporin_resistance, allow_class = c("logical", "character", "sir"), has_length = 1, allow_NA = TRUE, allow_NULL = TRUE)
|
||||
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(custom_rules, allow_class = "custom_eucast_rules", allow_NULL = TRUE)
|
||||
@ -205,7 +208,8 @@ eucast_rules <- function(x,
|
||||
|
||||
breakpoints_info <- EUCAST_VERSION_BREAKPOINTS[[which(as.double(names(EUCAST_VERSION_BREAKPOINTS)) == version_breakpoints)]]
|
||||
expertrules_info <- EUCAST_VERSION_EXPERT_RULES[[which(as.double(names(EUCAST_VERSION_EXPERT_RULES)) == version_expertrules)]]
|
||||
|
||||
resistantphenotypes_info <- EUCAST_VERSION_RESISTANTPHENOTYPES[[which(as.double(names(EUCAST_VERSION_RESISTANTPHENOTYPES)) == version_resistant_phenotypes)]]
|
||||
|
||||
# support old setting (until AMR v1.3.0)
|
||||
if (missing(rules) && !is.null(getOption("AMR.eucast_rules"))) {
|
||||
rules <- getOption("AMR.eucast_rules")
|
||||
@ -1185,7 +1189,7 @@ edit_sir <- function(x,
|
||||
|
||||
#' @rdname eucast_rules
|
||||
#' @export
|
||||
eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 12.0) {
|
||||
eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 13.0) {
|
||||
meet_criteria(ab, allow_class = c("character", "numeric", "integer", "factor"))
|
||||
meet_criteria(administration, allow_class = "character", is_in = dosage$administration[!is.na(dosage$administration)], has_length = 1)
|
||||
meet_criteria(version_breakpoints, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_BREAKPOINTS)))
|
||||
|
||||
50
R/mo.R
50
R/mo.R
@ -171,10 +171,11 @@ as.mo <- function(x,
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
if (tryCatch(all(x %in% c(AMR_env$MO_lookup$mo, NA)) &&
|
||||
isFALSE(Becker) &&
|
||||
isFALSE(Lancefield), error = function(e) FALSE)) {
|
||||
|
||||
if (tryCatch(all(x %in% c(AMR_env$MO_lookup$mo, NA)), error = function(e) FALSE) &&
|
||||
isFALSE(Becker) &&
|
||||
isFALSE(Lancefield) &&
|
||||
isTRUE(keep_synonyms)) {
|
||||
# don't look into valid MO codes, just return them
|
||||
# is.mo() won't work - MO codes might change between package versions
|
||||
return(set_clean_class(x, new_class = c("mo", "character")))
|
||||
@ -266,6 +267,8 @@ as.mo <- function(x,
|
||||
x_out <- trimws2(gsub(" +", " ", x_out, perl = TRUE))
|
||||
x_search_cleaned <- x_out
|
||||
x_out <- tolower(x_out)
|
||||
# when x_search_cleaned are only capitals (such as in codes), make them lowercase to increase matching score
|
||||
x_search_cleaned[x_search_cleaned == toupper(x_search_cleaned)] <- x_out[x_search_cleaned == toupper(x_search_cleaned)]
|
||||
|
||||
# first check if cleaning led to an exact result, case-insensitive
|
||||
if (x_out %in% AMR_env$MO_lookup$fullname_lower) {
|
||||
@ -297,15 +300,19 @@ as.mo <- function(x,
|
||||
} else if (length(x_parts) > 3) {
|
||||
first_chars <- paste0("(^| )[", paste(substr(x_parts, 1, 1), collapse = ""), "]")
|
||||
filtr <- which(AMR_env$MO_lookup$full_first %like_case% first_chars)
|
||||
} else if (nchar(x_out) == 3) {
|
||||
# no space and 3 characters - probably a code such as SAU or ECO
|
||||
msg <<- c(msg, paste0("Input \"", x_search, "\" was assumed to be a microorganism code - tried to match on \"", substr(x_out, 1, 1), AMR_env$dots, " ", substr(x_out, 2, 3), AMR_env$dots, "\""))
|
||||
filtr <- which(AMR_env$MO_lookup$fullname_lower %like_case% paste0("(^| )", substr(x_out, 1, 1), ".* ", substr(x_out, 2, 3)))
|
||||
} else if (nchar(x_out) == 4) {
|
||||
# no space and 4 characters - probably a code such as STAU or ESCO
|
||||
msg <- c(msg, paste0("Input \"", x_search, "\" was assumed to be a microorganism code - tried to match on ", vector_and(c(substr(x_out, 1, 2), substr(x_out, 3, 4)), sort = FALSE)))
|
||||
msg <<- c(msg, paste0("Input \"", x_search, "\" was assumed to be a microorganism code - tried to match on \"", substr(x_out, 1, 2), AMR_env$dots, " ", substr(x_out, 3, 4), AMR_env$dots, "\""))
|
||||
filtr <- which(AMR_env$MO_lookup$fullname_lower %like_case% paste0("(^| )", substr(x_out, 1, 2), ".* ", substr(x_out, 3, 4)))
|
||||
} else if (nchar(x_out) <= 6) {
|
||||
# no space and 5-6 characters - probably a code such as STAAUR or ESCCOL
|
||||
first_part <- paste0(substr(x_out, 1, 2), "[a-z]*", substr(x_out, 3, 3))
|
||||
second_part <- substr(x_out, 4, nchar(x_out))
|
||||
msg <- c(msg, paste0("Input \"", x_search, "\" was assumed to be a microorganism code - tried to match on ", vector_and(c(gsub("[a-z]*", "(...)", first_part, fixed = TRUE), second_part), sort = FALSE)))
|
||||
msg <<- c(msg, paste0("Input \"", x_search, "\" was assumed to be a microorganism code - tried to match on \"", gsub("[a-z]*", AMR_env$dots, first_part, fixed = TRUE), " ", second_part, AMR_env$dots, "\""))
|
||||
filtr <- which(AMR_env$MO_lookup$fullname_lower %like_case% paste0("(^| )", first_part, ".* ", second_part))
|
||||
} else {
|
||||
# for genus or species or subspecies
|
||||
@ -328,15 +335,18 @@ as.mo <- function(x,
|
||||
minimum_matching_score_current <- minimum_matching_score_current / AMR_env$MO_lookup$prevalence[match(mo_to_search, AMR_env$MO_lookup$fullname)]
|
||||
# correct back for kingdom
|
||||
minimum_matching_score_current <- minimum_matching_score_current / AMR_env$MO_lookup$kingdom_index[match(mo_to_search, AMR_env$MO_lookup$fullname)]
|
||||
minimum_matching_score_current <- pmax(minimum_matching_score_current, m)
|
||||
if (length(m) > 1 && all(m <= 0.55, na.rm = TRUE)) {
|
||||
# if the highest score is 0.5, we have nothing serious - 0.5 is the lowest for pathogenic group 1
|
||||
# make everything NA so the results will get removed below
|
||||
m[seq_len(length(m))] <- NA_real_
|
||||
}
|
||||
} else {
|
||||
# minimum_matching_score was set, so remove everything below it
|
||||
m[m < minimum_matching_score] <- NA_real_
|
||||
minimum_matching_score_current <- minimum_matching_score
|
||||
}
|
||||
|
||||
if (sum(m >= minimum_matching_score_current) > 10) {
|
||||
# at least 10 are left over, make the ones under `m` NA
|
||||
m[m < minimum_matching_score_current] <- NA_real_
|
||||
}
|
||||
|
||||
top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs
|
||||
if (length(top_hits) == 0) {
|
||||
warning_("No hits found for \"", x_search, "\" with minimum_matching_score = ", ifelse(is.null(minimum_matching_score), paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"), minimum_matching_score), ". Try setting this value lower or even to 0.", call = FALSE)
|
||||
@ -815,7 +825,7 @@ rep.mo <- function(x, ...) {
|
||||
print.mo_uncertainties <- function(x, n = 10, ...) {
|
||||
more_than_50 <- FALSE
|
||||
if (NROW(x) == 0) {
|
||||
cat(word_wrap("No uncertainties to show. Only uncertainties of the last call of `as.mo()` or any `mo_*()` function are stored.\n\n", add_fn = font_blue))
|
||||
cat(word_wrap("No uncertainties to show. Only uncertainties of the last call to `as.mo()` or any `mo_*()` function are stored.\n\n", add_fn = font_blue))
|
||||
return(invisible(NULL))
|
||||
} else if (NROW(x) > 50) {
|
||||
more_than_50 <- TRUE
|
||||
@ -833,20 +843,20 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
|
||||
|
||||
if (has_colour()) {
|
||||
cat(word_wrap("Colour keys: ",
|
||||
col_red(" 0.000-0.499 "),
|
||||
col_orange(" 0.500-0.599 "),
|
||||
col_yellow(" 0.600-0.699 "),
|
||||
col_green(" 0.700-1.000"),
|
||||
col_red(" 0.000-0.549 "),
|
||||
col_orange(" 0.550-0.649 "),
|
||||
col_yellow(" 0.650-0.749 "),
|
||||
col_green(" 0.750-1.000"),
|
||||
add_fn = font_blue
|
||||
), font_green_bg(" "), "\n", sep = "")
|
||||
}
|
||||
|
||||
score_set_colour <- function(text, scores) {
|
||||
# set colours to scores
|
||||
text[scores >= 0.7] <- col_green(text[scores >= 0.7])
|
||||
text[scores >= 0.6 & scores < 0.7] <- col_yellow(text[scores >= 0.6 & scores < 0.7])
|
||||
text[scores >= 0.5 & scores < 0.6] <- col_orange(text[scores >= 0.5 & scores < 0.6])
|
||||
text[scores < 0.5] <- col_red(text[scores < 0.5])
|
||||
text[scores >= 0.75] <- col_green(text[scores >= 0.75])
|
||||
text[scores >= 0.65 & scores < 0.75] <- col_yellow(text[scores >= 0.65 & scores < 0.75])
|
||||
text[scores >= 0.55 & scores < 0.65] <- col_orange(text[scores >= 0.55 & scores < 0.65])
|
||||
text[scores < 0.55] <- col_red(text[scores < 0.55])
|
||||
text
|
||||
}
|
||||
|
||||
|
||||
@ -136,11 +136,11 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
|
||||
# get highest/lowest +/- random 1 to 3 higher factors of two
|
||||
max_range <- mic_range[min(
|
||||
length(mic_range),
|
||||
which(mic_range == max(df$breakpoint_R)) + sample(c(1:3), 1)
|
||||
which(mic_range == max(df$breakpoint_R, na.rm = TRUE)) + sample(c(1:3), 1)
|
||||
)]
|
||||
min_range <- mic_range[max(
|
||||
1,
|
||||
which(mic_range == min(df$breakpoint_S)) - sample(c(1:3), 1)
|
||||
which(mic_range == min(df$breakpoint_S, na.rm = TRUE)) - sample(c(1:3), 1)
|
||||
)]
|
||||
|
||||
mic_range_new <- mic_range[mic_range <= max_range & mic_range >= min_range]
|
||||
@ -158,8 +158,8 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
|
||||
return(out)
|
||||
} else if (type == "DISK") {
|
||||
set_range <- seq(
|
||||
from = as.integer(min(df$breakpoint_R) / 1.25),
|
||||
to = as.integer(max(df$breakpoint_S) * 1.25),
|
||||
from = as.integer(min(df$breakpoint_R, na.rm = TRUE) / 1.25),
|
||||
to = as.integer(max(df$breakpoint_S, na.rm = TRUE) * 1.25),
|
||||
by = 1
|
||||
)
|
||||
out <- sample(set_range, size = size, replace = TRUE)
|
||||
|
||||
51
R/sir.R
51
R/sir.R
@ -43,6 +43,7 @@
|
||||
#' @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 include_screening a [logical] to indicate that clinical breakpoints for screening are allowed - the default is `FALSE`. Can also be set with the [package option][AMR-options] [`AMR_include_screening`][AMR-options].
|
||||
#' @param include_PKPD a [logical] to indicate that PK/PD clinical breakpoints must be applied as a last resort - the default is `TRUE`. Can also be set with the [package option][AMR-options] [`AMR_include_PKPD`][AMR-options].
|
||||
#' @param ecoff a [logical] to indicate that ECOFF (Epidemiological Cut-Off) values must be used **instead** of other clinical breakpoints - the default is `FALSE`. Can also be set with the [package option][AMR-options] [`AMR_ecoff`][AMR-options].
|
||||
#' @param reference_data a [data.frame] to be used for interpretation, which defaults to the [clinical_breakpoints] 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 [clinical_breakpoints] data set (same column names and column types). Please note that the `guideline` argument will be ignored when `reference_data` is manually set.
|
||||
#' @param threshold maximum fraction of invalid antimicrobial interpretations of `x`, see *Examples*
|
||||
#' @param ... for using on a [data.frame]: names of columns to apply [as.sir()] on (supports tidy selection such as `column1:column4`). Otherwise: arguments passed on to methods.
|
||||
@ -428,6 +429,7 @@ as.sir.mic <- function(x,
|
||||
reference_data = AMR::clinical_breakpoints,
|
||||
include_screening = getOption("AMR_include_screening", FALSE),
|
||||
include_PKPD = getOption("AMR_include_PKPD", TRUE),
|
||||
ecoff = getOption("AMR_ecoff", FALSE),
|
||||
...) {
|
||||
as_sir_method(
|
||||
method_short = "mic",
|
||||
@ -442,6 +444,7 @@ as.sir.mic <- function(x,
|
||||
reference_data = reference_data,
|
||||
include_screening = include_screening,
|
||||
include_PKPD = include_PKPD,
|
||||
ecoff = ecoff,
|
||||
...
|
||||
)
|
||||
}
|
||||
@ -457,6 +460,7 @@ as.sir.disk <- function(x,
|
||||
reference_data = AMR::clinical_breakpoints,
|
||||
include_screening = getOption("AMR_include_screening", FALSE),
|
||||
include_PKPD = getOption("AMR_include_PKPD", TRUE),
|
||||
ecoff = getOption("AMR_ecoff", FALSE),
|
||||
...) {
|
||||
as_sir_method(
|
||||
method_short = "disk",
|
||||
@ -471,6 +475,7 @@ as.sir.disk <- function(x,
|
||||
reference_data = reference_data,
|
||||
include_screening = include_screening,
|
||||
include_PKPD = include_PKPD,
|
||||
ecoff = ecoff,
|
||||
...
|
||||
)
|
||||
}
|
||||
@ -486,7 +491,8 @@ as.sir.data.frame <- function(x,
|
||||
add_intrinsic_resistance = FALSE,
|
||||
reference_data = AMR::clinical_breakpoints,
|
||||
include_screening = getOption("AMR_include_screening", FALSE),
|
||||
include_PKPD = getOption("AMR_include_PKPD", TRUE)) {
|
||||
include_PKPD = getOption("AMR_include_PKPD", TRUE),
|
||||
ecoff = getOption("AMR_ecoff", FALSE)) {
|
||||
meet_criteria(x, allow_class = "data.frame") # will also check for dimensions > 0
|
||||
meet_criteria(col_mo, allow_class = "character", is_in = colnames(x), allow_NULL = TRUE)
|
||||
meet_criteria(guideline, allow_class = "character", has_length = 1)
|
||||
@ -494,6 +500,9 @@ as.sir.data.frame <- function(x,
|
||||
meet_criteria(conserve_capped_values, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(reference_data, allow_class = "data.frame")
|
||||
meet_criteria(include_screening, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(include_PKPD, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(ecoff, allow_class = "logical", has_length = 1)
|
||||
|
||||
x.bak <- x
|
||||
for (i in seq_len(ncol(x))) {
|
||||
@ -625,6 +634,7 @@ as.sir.data.frame <- function(x,
|
||||
reference_data = reference_data,
|
||||
include_screening = include_screening,
|
||||
include_PKPD = include_PKPD,
|
||||
ecoff = ecoff,
|
||||
is_data.frame = TRUE
|
||||
)
|
||||
} else if (types[i] == "disk") {
|
||||
@ -642,6 +652,7 @@ as.sir.data.frame <- function(x,
|
||||
reference_data = reference_data,
|
||||
include_screening = include_screening,
|
||||
include_PKPD = include_PKPD,
|
||||
ecoff = ecoff,
|
||||
is_data.frame = TRUE
|
||||
)
|
||||
} else if (types[i] == "sir") {
|
||||
@ -711,6 +722,7 @@ as_sir_method <- function(method_short,
|
||||
reference_data,
|
||||
include_screening,
|
||||
include_PKPD,
|
||||
ecoff,
|
||||
...) {
|
||||
meet_criteria(x, allow_NA = TRUE, .call_depth = -2)
|
||||
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE, .call_depth = -2)
|
||||
@ -722,6 +734,7 @@ as_sir_method <- function(method_short,
|
||||
meet_criteria(reference_data, allow_class = "data.frame", .call_depth = -2)
|
||||
meet_criteria(include_screening, allow_class = "logical", has_length = 1, .call_depth = -2)
|
||||
meet_criteria(include_PKPD, allow_class = "logical", has_length = 1, .call_depth = -2)
|
||||
meet_criteria(ecoff, allow_class = "logical", has_length = 1, .call_depth = -2)
|
||||
check_reference_data(reference_data, .call_depth = -2)
|
||||
|
||||
# for dplyr's across()
|
||||
@ -818,15 +831,19 @@ as_sir_method <- function(method_short,
|
||||
)
|
||||
}
|
||||
message_("=> Interpreting ", method_long, " of ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
|
||||
agent_formatted,
|
||||
mo_var_found,
|
||||
" according to ", ifelse(identical(reference_data, AMR::clinical_breakpoints),
|
||||
font_bold(guideline_coerced),
|
||||
"manually defined 'reference_data'"
|
||||
),
|
||||
"... ",
|
||||
appendLF = FALSE,
|
||||
as_note = FALSE
|
||||
agent_formatted,
|
||||
mo_var_found,
|
||||
" according to ",
|
||||
ifelse(isTRUE(ecoff),
|
||||
"ECOFF values of ",
|
||||
""),
|
||||
ifelse(identical(reference_data, AMR::clinical_breakpoints),
|
||||
font_bold(guideline_coerced),
|
||||
"manually defined 'reference_data'"
|
||||
),
|
||||
"... ",
|
||||
appendLF = FALSE,
|
||||
as_note = FALSE
|
||||
)
|
||||
|
||||
msg_note <- function(messages) {
|
||||
@ -863,7 +880,7 @@ as_sir_method <- function(method_short,
|
||||
method_coerced <- toupper(method)
|
||||
ab_coerced <- ab
|
||||
mo_coerced <- mo
|
||||
|
||||
|
||||
if (identical(reference_data, AMR::clinical_breakpoints)) {
|
||||
breakpoints <- reference_data %pm>%
|
||||
subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
|
||||
@ -887,7 +904,17 @@ as_sir_method <- function(method_short,
|
||||
breakpoints <- breakpoints %pm>%
|
||||
subset(mo != "UNKNOWN" & ref_tbl %unlike% "PK.*PD")
|
||||
}
|
||||
|
||||
if (isFALSE(ecoff)) {
|
||||
# remove ECOFF interpretations from the breakpoints table
|
||||
breakpoints <- breakpoints %pm>%
|
||||
subset(ref_tbl != "ECOFF")
|
||||
} else {
|
||||
# keep only ECOFF interpretations from the breakpoints table
|
||||
breakpoints <- breakpoints %pm>%
|
||||
subset(ref_tbl == "ECOFF") %pm>%
|
||||
pm_mutate(breakpoint_S = ecoff, breakpoint_R = ecoff)
|
||||
}
|
||||
|
||||
msgs <- character(0)
|
||||
if (nrow(breakpoints) == 0) {
|
||||
# apparently no breakpoints found
|
||||
|
||||
2
R/zzz.R
2
R/zzz.R
@ -83,9 +83,11 @@ if (utf8_supported && !is_latex) {
|
||||
# \u2139 is a symbol officially named 'information source'
|
||||
AMR_env$info_icon <- "\u2139"
|
||||
AMR_env$bullet_icon <- "\u2022"
|
||||
AMR_env$dots <- "\u2026"
|
||||
} else {
|
||||
AMR_env$info_icon <- "i"
|
||||
AMR_env$bullet_icon <- "*"
|
||||
AMR_env$dots <- "..."
|
||||
}
|
||||
|
||||
.onLoad <- function(lib, pkg) {
|
||||
|
||||
Reference in New Issue
Block a user