1
0
mirror of https://github.com/msberends/AMR.git synced 2025-07-10 22:22:19 +02:00

(v2.1.1.9225) fix geom_hline()/_vline() in MIC plotting, add EUCAT 1.2 in full, add London contribs, fix mo codes, add Kleb pneu complex

This commit is contained in:
2025-03-26 17:19:17 +01:00
parent 8deaf2c8eb
commit e6f88241b2
53 changed files with 552 additions and 334 deletions

View File

@ -81,14 +81,14 @@ EUCAST_VERSION_EXPERT_RULES <- list(
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"
# )
# )
EUCAST_VERSION_EXPECTED_PHENOTYPES <- list(
"1.2" = list(
version_txt = "v1.2",
year = 2023,
title = "'EUCAST Expected Resistant Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes"
)
)
TAXONOMY_VERSION <- list(
GBIF = list(

View File

@ -458,6 +458,14 @@ streptogramins <- function(only_sir_columns = FALSE, return_all = TRUE, ...) {
amr_select_exec("streptogramins", only_sir_columns = only_sir_columns, return_all = return_all)
}
#' @rdname antimicrobial_selectors
#' @export
sulfonamides <- function(only_sir_columns = FALSE, return_all = TRUE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(return_all, allow_class = "logical", has_length = 1)
amr_select_exec("sulfonamides", only_sir_columns = only_sir_columns, return_all = return_all)
}
#' @rdname antimicrobial_selectors
#' @export
tetracyclines <- function(only_sir_columns = FALSE, only_treatable = TRUE, return_all = TRUE, ...) {

View File

@ -69,7 +69,7 @@
#' #> 1 Escherichia coli R S S
#' #> 2 Klebsiella pneumoniae R S S
#'
#' eucast_rules(df, rules = "custom", custom_rules = x, info = FALSE)
#' eucast_rules(df, rules = "custom", custom_rules = x, info = FALSE, overwrite = TRUE)
#' #> mo TZP ampi cipro
#' #> 1 Escherichia coli R R S
#' #> 2 Klebsiella pneumoniae R R S
@ -83,7 +83,7 @@
#' y <- custom_eucast_rules(TZP == "S" & genus == "Klebsiella" ~ aminopenicillins == "S",
#' TZP == "R" & genus == "Klebsiella" ~ aminopenicillins == "R")
#'
#' eucast_rules(df, rules = "custom", custom_rules = y, info = FALSE)
#' eucast_rules(df, rules = "custom", custom_rules = y, info = FALSE, overwrite = TRUE)
#' #> mo TZP ampi cipro
#' #> 1 Escherichia coli R S S
#' #> 2 Klebsiella pneumoniae R R S
@ -121,6 +121,7 @@
#' rules = "custom",
#' custom_rules = x,
#' info = FALSE,
#' overwrite = TRUE,
#' verbose = TRUE
#' )
#'

View File

@ -61,11 +61,11 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' To improve the interpretation of the antibiogram before EUCAST rules are applied, some non-EUCAST rules can applied at default, see *Details*.
#' @param x a data set with antimicrobials columns, such as `amox`, `AMX` and `AMC`
#' @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_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 rules a [character] vector that specifies which rules should be applied. Must be one or more of `"breakpoints"`, `"expected_phenotypes"`, `"expert"`, `"other"`, `"custom"`, `"all"`, and defaults to `c("breakpoints", "expected_phenotypes")`. The default value can be set to another value using the package option [`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 `r vector_or(names(EUCAST_VERSION_BREAKPOINTS), reverse = TRUE)`.
#' @param version_expected_phenotypes the version number to use for the EUCAST Expected Phenotypes. Can be `r vector_or(names(EUCAST_VERSION_EXPECTED_PHENOTYPES), 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 antimicrobial, see section *Antimicrobials* below
#' @param ab any (vector of) text that can be coerced to a valid antimicrobial drug code with [as.ab()]
@ -146,14 +146,14 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#'
#'
#' # apply EUCAST rules: some results wil be changed
#' b <- eucast_rules(a)
#' b <- eucast_rules(a, overwrite = TRUE)
#'
#' head(b)
#'
#'
#' # do not apply EUCAST rules, but rather get a data.frame
#' # containing all details about the transformations:
#' c <- eucast_rules(a, verbose = TRUE)
#' c <- eucast_rules(a, overwrite = TRUE, verbose = TRUE)
#' head(c)
#' }
#'
@ -165,11 +165,11 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
eucast_rules <- function(x,
col_mo = NULL,
info = interactive(),
rules = getOption("AMR_eucastrules", default = c("breakpoints", "expert")),
rules = getOption("AMR_eucastrules", default = c("breakpoints", "expected_phenotypes")),
verbose = FALSE,
version_breakpoints = 14.0,
version_expected_phenotypes = 1.2,
version_expertrules = 3.3,
# TODO version_resistant_phenotypes = 1.2,
ampc_cephalosporin_resistance = NA,
only_sir_columns = FALSE,
custom_rules = NULL,
@ -178,11 +178,11 @@ eucast_rules <- function(x,
meet_criteria(x, allow_class = "data.frame")
meet_criteria(col_mo, allow_class = "character", has_length = 1, is_in = colnames(x), allow_NULL = TRUE)
meet_criteria(info, allow_class = "logical", has_length = 1)
meet_criteria(rules, allow_class = "character", has_length = c(1, 2, 3, 4, 5), is_in = c("breakpoints", "expert", "other", "all", "custom"))
meet_criteria(rules, allow_class = "character", has_length = c(1, 2, 3, 4, 5, 6), is_in = c("breakpoints", "expected_phenotypes", "expert", "other", "all", "custom"))
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_expected_phenotypes, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_EXPECTED_PHENOTYPES)))
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)
@ -209,13 +209,8 @@ eucast_rules <- function(x,
}
breakpoints_info <- EUCAST_VERSION_BREAKPOINTS[[which(as.double(names(EUCAST_VERSION_BREAKPOINTS)) == version_breakpoints)]]
expected_phenotypes_info <- EUCAST_VERSION_EXPECTED_PHENOTYPES[[which(as.double(names(EUCAST_VERSION_EXPECTED_PHENOTYPES)) == version_expected_phenotypes)]]
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")
}
if (interactive() && isTRUE(verbose) && isTRUE(info)) {
txt <- paste0(
@ -390,6 +385,24 @@ eucast_rules <- function(x,
}
suppressWarnings(as.sir(x))
}
expand_groups <- function(entry) {
parts <- trimws(strsplit(entry, ",")[[1]])
group_names <- tolower(AMR::microorganisms.groups$mo_group_name)
mo_names <- AMR::microorganisms.groups$mo_name
group_names_lc <- tolower(group_names)
result <- unlist(lapply(parts, function(part) {
match_idx <- which(group_names_lc == tolower(part))
if (length(match_idx) > 0) {
mo_names[match_idx]
} else {
part
}
}))
# only the ones with genus or genus/species, not subspecies (as genus_species will be matched)
spaces <- vapply(FUN.VALUE = integer(1), strsplit(result, " "), length)
result <- result[spaces < 3]
return(paste0(unique(result), collapse = ", "))
}
# Preparing the data ------------------------------------------------------
@ -442,15 +455,6 @@ eucast_rules <- function(x,
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
}
if (any(x$genus == "Staphylococcus", na.rm = TRUE)) {
all_staph <- AMR_env$MO_lookup[which(AMR_env$MO_lookup$genus == "Staphylococcus"), , drop = FALSE]
all_staph$CNS_CPS <- suppressWarnings(mo_name(all_staph$mo, Becker = "all", language = NULL, info = FALSE))
}
if (any(x$genus == "Streptococcus", na.rm = TRUE)) {
all_strep <- AMR_env$MO_lookup[which(AMR_env$MO_lookup$genus == "Streptococcus"), , drop = FALSE]
all_strep$Lancefield <- suppressWarnings(mo_name(all_strep$mo, Lancefield = TRUE, language = NULL, info = FALSE))
}
n_added <- 0
n_changed <- 0
@ -577,7 +581,17 @@ eucast_rules <- function(x,
} else {
if (isTRUE(info)) {
cat("\n")
message_("Skipping inheritance rules defined by this AMR package, such as setting trimethoprim (TMP) = R where trimethoprim/sulfamethoxazole (SXT) = R. Add \"other\" or \"all\" to the `rules` argument to apply those rules.")
message_(paste0(
font_red("Skipping inhibitor-inheritance rules defined by this AMR package: setting "),
font_green_bg(" S "),
font_red(" to drug+inhibitor where drug is "),
font_green_bg(" S "),
font_red(", and setting "),
font_rose_bg(" R "),
font_red(" to drug where drug+inhibitor is "),
font_rose_bg(" R "),
font_red(". Add \"other\" or \"all\" to the `rules` argument to apply those rules.")
))
}
}
@ -592,26 +606,43 @@ eucast_rules <- function(x,
eucast_notification_shown <- FALSE
if (!is.null(list(...)$eucast_rules_df)) {
# this allows: eucast_rules(x, eucast_rules_df = AMR:::EUCAST_RULES_DF %>% filter(is.na(have_these_values)))
eucast_rules_df <- list(...)$eucast_rules_df
eucast_rules_df_total <- list(...)$eucast_rules_df
} else {
# otherwise internal data file, created in data-raw/_pre_commit_checks.R
eucast_rules_df <- EUCAST_RULES_DF
eucast_rules_df_total <- EUCAST_RULES_DF
}
## filter on user-set guideline versions ----
eucast_rules_df <- data.frame()
if (any(c("all", "breakpoints") %in% rules)) {
eucast_rules_df <- subset(
eucast_rules_df,
reference.rule_group %unlike% "breakpoint" |
(reference.rule_group %like% "breakpoint" & reference.version == version_breakpoints)
)
eucast_rules_df <- eucast_rules_df %pm>%
rbind_AMR(eucast_rules_df_total %pm>%
subset(reference.rule_group %like% "breakpoint" & reference.version == version_breakpoints))
# eucast_rules_df <- subset(
# eucast_rules_df,
# reference.rule_group %unlike% "breakpoint" |
# (reference.rule_group %like% "breakpoint" & reference.version == version_breakpoints)
# )
}
if (any(c("all", "expected_phenotypes") %in% rules)) {
eucast_rules_df <- eucast_rules_df %pm>%
rbind_AMR(eucast_rules_df_total %pm>%
subset(reference.rule_group %like% "expected" & reference.version == version_expected_phenotypes))
# eucast_rules_df <- subset(
# eucast_rules_df,
# reference.rule_group %unlike% "expected" |
# (reference.rule_group %like% "expected" & reference.version == version_expected_phenotypes)
# )
}
if (any(c("all", "expert") %in% rules)) {
eucast_rules_df <- subset(
eucast_rules_df,
reference.rule_group %unlike% "expert" |
(reference.rule_group %like% "expert" & reference.version == version_expertrules)
)
eucast_rules_df <- eucast_rules_df %pm>%
rbind_AMR(eucast_rules_df_total %pm>%
subset(reference.rule_group %like% "expert" & reference.version == version_expertrules))
# eucast_rules_df <- subset(
# eucast_rules_df,
# reference.rule_group %unlike% "expert" |
# (reference.rule_group %like% "expert" & reference.version == version_expertrules)
# )
}
## filter out AmpC de-repressed cephalosporin-resistant mutants ----
# no need to filter on version number here - the rules contain these version number, so are inherently filtered
@ -657,6 +688,9 @@ eucast_rules <- function(x,
if (rule_group_current %like% "breakpoint" && !any(c("all", "breakpoints") %in% rules)) {
next
}
if (rule_group_current %like% "expected" && !any(c("all", "expected_phenotypes") %in% rules)) {
next
}
if (rule_group_current %like% "expert" && !any(c("all", "expert") %in% rules)) {
next
}
@ -677,6 +711,7 @@ eucast_rules <- function(x,
)
}
}
if (i == 1) {
rule_previous <- ""
rule_group_previous <- ""
@ -712,15 +747,25 @@ eucast_rules <- function(x,
)
),
ifelse(
rule_group_current %like% "expert",
rule_group_current %like% "expected",
paste0(
"\n",
word_wrap(
expertrules_info$title, " (",
font_red(paste0(expertrules_info$version_txt, ", ", expertrules_info$year)), ")\n"
expected_phenotypes_info$title, " (",
font_red(paste0(expected_phenotypes_info$version_txt, ", ", expected_phenotypes_info$year)), ")\n"
)
),
""
ifelse(
rule_group_current %like% "expert",
paste0(
"\n",
word_wrap(
expertrules_info$title, " (",
font_red(paste0(expertrules_info$version_txt, ", ", expertrules_info$year)), ")\n"
)
),
"" # Default empty string if none of the conditions are met
)
)
)
), "\n")
@ -743,47 +788,15 @@ eucast_rules <- function(x,
if_mo_property <- trimws(eucast_rules_df[i, "if_mo_property", drop = TRUE])
like_is_one_of <- trimws(eucast_rules_df[i, "like.is.one_of", drop = TRUE])
mo_value <- trimws(eucast_rules_df[i, "this_value", drop = TRUE])
source_antibiotics <- eucast_rules_df[i, "and_these_antibiotics", drop = TRUE]
source_value <- trimws(unlist(strsplit(eucast_rules_df[i, "have_these_values", drop = TRUE], ",", fixed = TRUE)))
target_antibiotics <- eucast_rules_df[i, "then_change_these_antibiotics", drop = TRUE]
target_value <- eucast_rules_df[i, "to_value", drop = TRUE]
# be sure to comprise all coagulase-negative/-positive staphylococci when they are mentioned
if (mo_value %like% "coagulase" && any(x$genus == "Staphylococcus", na.rm = TRUE)) {
if (mo_value %like% "negative") {
eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(
all_staph[which(all_staph$CNS_CPS %like% "negative"),
"fullname",
drop = TRUE
],
collapse = "|"
),
")$"
)
} else {
eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(
all_staph[which(all_staph$CNS_CPS %like% "positive"),
"fullname",
drop = TRUE
],
collapse = "|"
),
")$"
)
}
like_is_one_of <- "like"
}
# be sure to comprise all beta-haemolytic Streptococci (Lancefield groups A, B, C and G) when they are mentioned
if (mo_value %like% "group [ABCG]" && any(x$genus == "Streptococcus", na.rm = TRUE)) {
eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(
all_strep[which(all_strep$Lancefield %like% "group [ABCG]"),
"fullname",
drop = TRUE
],
collapse = "|"
),
")$"
)
like_is_one_of <- "like"
# if amo_value contains a group name, expand that name with all species in it
if (any(trimws(strsplit(mo_value, ",")[[1]]) %in% AMR::microorganisms.groups$mo_group_name, na.rm = TRUE)) {
like_is_one_of <- "one_of"
mo_value <- expand_groups(mo_value)
}
if (like_is_one_of == "is") {
@ -802,13 +815,8 @@ eucast_rules <- function(x,
stop("invalid value for column 'like.is.one_of'", call. = FALSE)
}
source_antibiotics <- eucast_rules_df[i, "and_these_antibiotics", drop = TRUE]
source_value <- trimws(unlist(strsplit(eucast_rules_df[i, "have_these_values", drop = TRUE], ",", fixed = TRUE)))
target_antibiotics <- eucast_rules_df[i, "then_change_these_antibiotics", drop = TRUE]
target_value <- eucast_rules_df[i, "to_value", drop = TRUE]
if (is.na(source_antibiotics)) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value),
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value | x$fullname %like% mo_value),
error = function(e) integer(0)
)
} else {
@ -820,25 +828,17 @@ eucast_rules <- function(x,
rows <- integer(0)
} else if (length(source_antibiotics) == 1) {
rows <- tryCatch(
which(x[, if_mo_property, drop = TRUE] %like% mo_value &
which((x[, if_mo_property, drop = TRUE] %like% mo_value | x$fullname %like% mo_value) &
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
error = function(e) integer(0)
)
} else if (length(source_antibiotics) == 2) {
rows <- tryCatch(
which(x[, if_mo_property, drop = TRUE] %like% mo_value &
which((x[, if_mo_property, drop = TRUE] %like% mo_value | x$fullname %like% mo_value) &
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L] &
as.sir_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
error = function(e) integer(0)
)
# nolint start
# } else if (length(source_antibiotics) == 3) {
# rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value
# & as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]
# & as.sir_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]
# & as.sir_no_warning(x[, source_antibiotics[3L]]) == source_value[3L]),
# error = function(e) integer(0))
# nolint end
} else {
stop_("only 2 antimicrobials supported for source_antibiotics")
}
@ -855,7 +855,10 @@ eucast_rules <- function(x,
rule_text, rule_group_current, rule_current,
ifelse(rule_group_current %like% "breakpoint",
paste0(breakpoints_info$title, " ", breakpoints_info$version_txt, ", ", breakpoints_info$year),
paste0(expertrules_info$title, " ", expertrules_info$version_txt, ", ", expertrules_info$year)
ifelse(rule_group_current %like% "expected",
paste0(expected_phenotypes_info$title, " ", expected_phenotypes_info$version_txt, ", ", expected_phenotypes_info$year),
paste0(expertrules_info$title, " ", expertrules_info$version_txt, ", ", expertrules_info$year)
)
)
),
rows = rows,
@ -1130,7 +1133,12 @@ edit_sir <- function(x,
if (any(!vapply(FUN.VALUE = logical(1), x[, cols, drop = FALSE], is.sir), na.rm = TRUE)) {
track_changes$sir_warn <- cols[!vapply(FUN.VALUE = logical(1), x[, cols, drop = FALSE], is.sir)]
}
non_SIR <- is.na(new_edits[rows, cols]) | !(new_edits[rows, cols] == "S" | new_edits[rows, cols] == "I" | new_edits[rows, cols] == "R" | new_edits[rows, cols] == "SDD" | new_edits[rows, cols] == "NI")
isNA <- is.na(new_edits[rows, cols])
isSIR <- !isNA & (new_edits[rows, cols] == "S" | new_edits[rows, cols] == "I" | new_edits[rows, cols] == "R" | new_edits[rows, cols] == "SDD" | new_edits[rows, cols] == "NI")
non_SIR <- !isSIR
if (isFALSE(overwrite) && any(isSIR) && message_not_thrown_before("edit_sir.warning_overwrite")) {
warning_("Some values had SIR values and were not overwritten, since `overwrite = FALSE`.")
}
tryCatch(
# insert into original table
if (isTRUE(overwrite)) {

View File

@ -333,7 +333,7 @@ rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE) {
x <- as.mic(x, keep_operators = ifelse(keep_operators == "edges", "none", keep_operators))
if (isTRUE(as.mic)) {
if (keep_operators == "edges" && length(x) > 1) {
if (keep_operators == "edges" && length(unique(x)) > 1) {
x[x == min(x, na.rm = TRUE)] <- paste0("<=", x[x == min(x, na.rm = TRUE)])
x[x == max(x, na.rm = TRUE)] <- paste0(">=", x[x == max(x, na.rm = TRUE)])
}

View File

@ -243,31 +243,47 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
as.double(rescale_mic(x = as.double(as.mic(x)), keep_operators = keep_operators, mic_range = mic_range, as.mic = TRUE))
}
scale$transform_df <- function(self, df) {
self$mic_values_rescaled <- rescale_mic(x = as.double(as.mic(df[[aest]])), keep_operators = keep_operators, mic_range = mic_range, as.mic = TRUE)
# create new breaks and labels here
lims <- range(self$mic_values_rescaled, na.rm = TRUE)
# support inner and outer 'mic_range' settings (e.g., the data ranges 0.5-8 and 'mic_range' is set to 0.025-32)
if (!is.null(mic_range) && !is.na(mic_range[1]) && !is.na(lims[1]) && mic_range[1] < lims[1]) {
lims[1] <- mic_range[1]
}
if (!is.null(mic_range) && !is.na(mic_range[2]) && !is.na(lims[2]) && mic_range[2] > lims[2]) {
lims[2] <- mic_range[2]
}
ind_min <- which(COMMON_MIC_VALUES <= lims[1])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES <= lims[1]] - lims[1]))] # Closest index where COMMON_MIC_VALUES <= lims[1]
ind_max <- which(COMMON_MIC_VALUES >= lims[2])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES >= lims[2]] - lims[2]))] # Closest index where COMMON_MIC_VALUES >= lims[2]
if (!aest %in% colnames(df)) {
# support for geom_hline() and geom_vline()
if ("yintercept" %in% colnames(df)) {
aest_val <- "yintercept"
} else if ("xintercept" %in% colnames(df)) {
aest_val <- "xintercept"
} else {
stop_("No support for plotting df with `scale_", aest, "_mic()` with columns ", vector_and(colnames(df), sort = FALSE))
}
out <- rescale_mic(x = as.double(as.mic(df[[aest_val]])), keep_operators = "none", mic_range = NULL, as.mic = TRUE)
if (!is.null(self$mic_values_rescaled) && any(out < min(self$mic_values_rescaled, na.rm = TRUE) | out > max(self$mic_values_rescaled, na.rm = TRUE), na.rm = TRUE)) {
warning_("The value for `", aest_val, "` is outside the plotted MIC range, consider using/updating the `mic_range` argument in `scale_", aest, "_mic()`.")
}
df[[aest_val]] <- log2(as.double(out))
} else {
self$mic_values_rescaled <- rescale_mic(x = as.double(as.mic(df[[aest]])), keep_operators = keep_operators, mic_range = mic_range, as.mic = TRUE)
# create new breaks and labels here
lims <- range(self$mic_values_rescaled, na.rm = TRUE)
# support inner and outer 'mic_range' settings (e.g., the data ranges 0.5-8 and 'mic_range' is set to 0.025-32)
if (!is.null(mic_range) && !is.na(mic_range[1]) && !is.na(lims[1]) && mic_range[1] < lims[1]) {
lims[1] <- mic_range[1]
}
if (!is.null(mic_range) && !is.na(mic_range[2]) && !is.na(lims[2]) && mic_range[2] > lims[2]) {
lims[2] <- mic_range[2]
}
ind_min <- which(COMMON_MIC_VALUES <= lims[1])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES <= lims[1]] - lims[1]))] # Closest index where COMMON_MIC_VALUES <= lims[1]
ind_max <- which(COMMON_MIC_VALUES >= lims[2])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES >= lims[2]] - lims[2]))] # Closest index where COMMON_MIC_VALUES >= lims[2]
self$mic_values_levels <- as.mic(COMMON_MIC_VALUES[ind_min:ind_max])
self$mic_values_levels <- as.mic(COMMON_MIC_VALUES[ind_min:ind_max])
if (keep_operators %in% c("edges", "all") && length(self$mic_values_levels) > 1) {
self$mic_values_levels[1] <- paste0("<=", self$mic_values_levels[1])
self$mic_values_levels[length(self$mic_values_levels)] <- paste0(">=", self$mic_values_levels[length(self$mic_values_levels)])
}
if (keep_operators %in% c("edges", "all") && length(unique(self$mic_values_levels)) > 1) {
self$mic_values_levels[1] <- paste0("<=", self$mic_values_levels[1])
self$mic_values_levels[length(self$mic_values_levels)] <- paste0(">=", self$mic_values_levels[length(self$mic_values_levels)])
}
self$mic_values_log <- log2(as.double(self$mic_values_rescaled))
if (aest == "y" && "group" %in% colnames(df)) {
df$group <- as.integer(factor(df$x))
self$mic_values_log <- log2(as.double(self$mic_values_rescaled))
if (aest == "y" && "group" %in% colnames(df) && "x" %in% colnames(df)) {
df$group <- as.integer(factor(df$x))
}
df[[aest]] <- self$mic_values_log
}
df[[aest]] <- self$mic_values_log
df
}

View File

@ -146,10 +146,10 @@ random_exec <- function(method_type, size, mo = NULL, ab = NULL) {
}
out <- as.mic(sample(mic_range_new, size = size, replace = TRUE))
# 50% chance that lowest will get <= and highest will get >=
if (stats::runif(1) > 0.5) {
if (stats::runif(1) > 0.5 && length(unique(out)) > 1) {
out[out == min(out)] <- paste0("<=", out[out == min(out)])
}
if (stats::runif(1) > 0.5) {
if (stats::runif(1) > 0.5 && length(unique(out)) > 1) {
out[out == max(out)] <- paste0(">=", out[out == max(out)])
}
return(out)

151
R/sir.R
View File

@ -464,6 +464,7 @@ is_sir_eligible <- function(x, threshold = 0.05) {
#' @rdname as.sir
#' @export
#' @param S,I,R,NI,SDD a case-independent [regular expression][base::regex] to translate input to this result. This regular expression will be run *after* all non-letters and whitespaces are removed from the input.
#' @param info a [logical] to print information about the process
# extra param: warn (logical, to never throw a warning)
as.sir.default <- function(x,
S = "^(S|U)+$",
@ -471,7 +472,14 @@ as.sir.default <- function(x,
R = "^(R)+$",
NI = "^(N|NI|V)+$",
SDD = "^(SDD|D|H)+$",
info = TRUE,
...) {
meet_criteria(S, allow_class = "character", has_length = 1)
meet_criteria(I, allow_class = "character", has_length = 1)
meet_criteria(R, allow_class = "character", has_length = 1)
meet_criteria(NI, allow_class = "character", has_length = 1)
meet_criteria(SDD, allow_class = "character", has_length = 1)
meet_criteria(info, allow_class = "logical", has_length = 1)
if (inherits(x, "sir")) {
return(as_sir_structure(x))
}
@ -591,6 +599,7 @@ as.sir.mic <- function(x,
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
host = NULL,
verbose = FALSE,
info = TRUE,
conserve_capped_values = NULL,
...) {
as_sir_method(
@ -610,6 +619,8 @@ as.sir.mic <- function(x,
breakpoint_type = breakpoint_type,
host = host,
verbose = verbose,
info = info,
conserve_capped_values = conserve_capped_values,
...
)
}
@ -629,6 +640,7 @@ as.sir.disk <- function(x,
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
host = NULL,
verbose = FALSE,
info = TRUE,
...) {
as_sir_method(
method_short = "disk",
@ -667,6 +679,7 @@ as.sir.data.frame <- function(x,
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
host = NULL,
verbose = FALSE,
info = TRUE,
conserve_capped_values = NULL) {
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)
@ -681,6 +694,7 @@ as.sir.data.frame <- function(x,
meet_criteria(breakpoint_type, allow_class = "character", is_in = reference_data$type, has_length = 1)
meet_criteria(host, allow_class = c("character", "factor"), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(info, allow_class = "logical", has_length = 1)
x.bak <- x
for (i in seq_len(ncol(x))) {
# don't keep factors, overwriting them is hard
@ -697,10 +711,10 @@ as.sir.data.frame <- function(x,
# -- host
if (missing(breakpoint_type) && any(host %in% clinical_breakpoints$host[!clinical_breakpoints$host %in% c("human", "ECOFF")], na.rm = TRUE)) {
message_("Assuming `breakpoint_type = \"animal\"` since `host` contains animal species.")
if (isTRUE(info)) message_("Assuming `breakpoint_type = \"animal\"` since `host` contains animal species.")
breakpoint_type <- "animal"
} else if (any(!suppressMessages(convert_host(host)) %in% c("human", "ECOFF"), na.rm = TRUE)) {
message_("Assuming `breakpoint_type = \"animal\"`.")
if (isTRUE(info)) message_("Assuming `breakpoint_type = \"animal\"`.")
breakpoint_type <- "animal"
}
if (breakpoint_type == "animal") {
@ -745,13 +759,15 @@ as.sir.data.frame <- function(x,
} else {
plural <- c("", "s", "a ")
}
message_(
"Assuming value", plural[1], " ",
vector_and(values, quotes = TRUE),
" in column '", font_bold(col_specimen),
"' reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1],
".\n Use `as.sir(uti = FALSE)` to prevent this."
)
if (isTRUE(info)) {
message_(
"Assuming value", plural[1], " ",
vector_and(values, quotes = TRUE),
" in column '", font_bold(col_specimen),
"' reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1],
".\n Use `as.sir(uti = FALSE)` to prevent this."
)
}
} else {
# no data about UTI's found
uti <- NULL
@ -833,6 +849,8 @@ as.sir.data.frame <- function(x,
breakpoint_type = breakpoint_type,
host = host,
verbose = verbose,
info = info,
conserve_capped_values = conserve_capped_values,
is_data.frame = TRUE
)
} else if (types[i] == "disk") {
@ -854,6 +872,7 @@ as.sir.data.frame <- function(x,
breakpoint_type = breakpoint_type,
host = host,
verbose = verbose,
info = info,
is_data.frame = TRUE
)
} else if (types[i] == "sir") {
@ -863,24 +882,28 @@ as.sir.data.frame <- function(x,
if (!all(x[, ab_cols[i], drop = TRUE] %in% c("S", "SDD", "I", "R", "NI", NA), na.rm = TRUE)) {
show_message <- TRUE
# only print message if values are not already clean
message_("Cleaning values in column '", font_bold(ab), "' (",
ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ")... ",
appendLF = FALSE,
as_note = FALSE
)
if (isTRUE(info)) {
message_("Cleaning values in column '", font_bold(ab), "' (",
ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ")... ",
appendLF = FALSE,
as_note = FALSE
)
}
} else if (!is.sir(x.bak[, ab_cols[i], drop = TRUE])) {
show_message <- TRUE
# only print message if class not already set
message_("Assigning class 'sir' to already clean column '", font_bold(ab), "' (",
ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE, language = NULL), ")... ",
appendLF = FALSE,
as_note = FALSE
)
if (isTRUE(info)) {
message_("Assigning class 'sir' to already clean column '", font_bold(ab), "' (",
ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE, language = NULL), ")... ",
appendLF = FALSE,
as_note = FALSE
)
}
}
x[, ab_cols[i]] <- as.sir.default(x = as.character(x[, ab_cols[i], drop = TRUE]))
if (show_message == TRUE) {
if (show_message == TRUE && isTRUE(info)) {
message(font_green_bg(" OK "))
}
}
@ -963,6 +986,7 @@ as_sir_method <- function(method_short,
breakpoint_type,
host,
verbose,
info,
conserve_capped_values = NULL,
...) {
if (isTRUE(conserve_capped_values)) {
@ -984,6 +1008,7 @@ as_sir_method <- function(method_short,
meet_criteria(breakpoint_type, allow_class = "character", is_in = reference_data$type, has_length = 1, .call_depth = -2)
meet_criteria(host, allow_class = c("character", "factor"), allow_NULL = TRUE, allow_NA = TRUE, .call_depth = -2)
meet_criteria(verbose, allow_class = "logical", has_length = 1, .call_depth = -2)
meet_criteria(info, allow_class = "logical", has_length = 1, .call_depth = -2)
# backward compatibilty
dots <- list(...)
@ -996,7 +1021,7 @@ as_sir_method <- function(method_short,
guideline_coerced <- get_guideline(guideline, reference_data)
if (message_not_thrown_before("as.sir", "sir_interpretation_history")) {
if (isTRUE(info) && message_not_thrown_before("as.sir", "sir_interpretation_history")) {
message()
message_("Run `sir_interpretation_history()` afterwards to retrieve a logbook with all the details of the breakpoint interpretations.\n\n", add_fn = font_green)
}
@ -1007,13 +1032,13 @@ as_sir_method <- function(method_short,
if (breakpoint_type == "animal") {
if (is.null(host)) {
host <- "dogs"
if (message_not_thrown_before("as.sir", "host_missing")) {
if (isTRUE(info) && message_not_thrown_before("as.sir", "host_missing")) {
message_("Animal hosts not set in `host`, assuming `host = \"dogs\"`, since these have the highest breakpoint availability.\n\n")
}
}
} else {
if (!is.null(host) && !all(toupper(as.character(host)) %in% c("HUMAN", "ECOFF"))) {
if (message_not_thrown_before("as.sir", "assumed_breakpoint_animal")) {
if (isTRUE(info) && message_not_thrown_before("as.sir", "assumed_breakpoint_animal")) {
message_("Assuming `breakpoint_type = \"animal\"`, since `host` is set.", ifelse(guideline_coerced %like% "EUCAST", " Do you also need to set `guideline = \"CLSI\"`?", ""), "\n\n")
}
breakpoint_type <- "animal"
@ -1038,12 +1063,12 @@ as_sir_method <- function(method_short,
}
host.bak <- host
host <- convert_host(host)
if (any(is.na(host) & !is.na(host.bak)) && message_not_thrown_before("as.sir", "missing_hosts")) {
if (any(is.na(host) & !is.na(host.bak)) && isTRUE(info) && message_not_thrown_before("as.sir", "missing_hosts")) {
warning_("The following animal host(s) could not be coerced: ", vector_and(host.bak[is.na(host) & !is.na(host.bak)]), immediate = TRUE)
message() # new line
}
# TODO add a switch to turn this off? In interactive sessions perhaps ask the user. Default should be On.
# if (breakpoint_type == "animal" && message_not_thrown_before("as.sir", "host_missing_breakpoints")) {
# if (breakpoint_type == "animal" && isTRUE(info) && message_not_thrown_before("as.sir", "host_missing_breakpoints")) {
# if (guideline_coerced %like% "CLSI") {
# message_("Please note that in the absence of specific veterinary breakpoints for certain animal hosts, the CLSI guideline VET09 will be applied where possible.\n\n")
# }
@ -1144,11 +1169,13 @@ as_sir_method <- function(method_short,
# be sure to take current taxonomy, as the 'clinical_breakpoints' data set only contains current taxonomy
mo <- suppressWarnings(suppressMessages(as.mo(mo, keep_synonyms = FALSE, info = FALSE)))
if (all(is.na(ab))) {
message_("Returning NAs for unknown antibiotic: ", vector_and(ab.bak, sort = FALSE, quotes = TRUE),
". Rename this column to a valid name or code, and check the output with `as.ab()`.",
add_fn = font_red,
as_note = FALSE
)
if (isTRUE(info)) {
message_("Returning NAs for unknown antibiotic: ", vector_and(ab.bak, sort = FALSE, quotes = TRUE),
". Rename this column to a valid name or code, and check the output with `as.ab()`.",
add_fn = font_red,
as_note = FALSE
)
}
return(as.sir(rep(NA, length(x))))
}
if (length(mo) == 1) {
@ -1168,8 +1195,10 @@ as_sir_method <- function(method_short,
uti <- rep(uti, length(x))
}
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %unlike% "EUCAST") {
if (message_not_thrown_before("as.sir", "intrinsic")) {
warning_("in `as.sir()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
if (isTRUE(info) && message_not_thrown_before("as.sir", "intrinsic")) {
message_("in `as.sir()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.",
add_fn = font_red
)
}
}
@ -1269,7 +1298,7 @@ as_sir_method <- function(method_short,
add_intrinsic_resistance_to_AMR_env()
}
if (nrow(df_unique) < 10 || nrow(breakpoints) == 0) {
if (isTRUE(info) && nrow(df_unique) < 10 || nrow(breakpoints) == 0) {
# only print intro under 10 items, otherwise progressbar will print this and then it will be printed double
message_(intro_txt, appendLF = FALSE, as_note = FALSE)
}
@ -1279,14 +1308,16 @@ as_sir_method <- function(method_short,
if (nrow(breakpoints) == 0) {
# apparently no breakpoints found
message(
paste0(font_rose_bg(" WARNING "), "\n"),
font_black(paste0(
" ", AMR_env$bullet_icon, " No ", guideline_coerced, " ", method_coerced, " breakpoints available for ",
suppressMessages(suppressWarnings(ab_name(unique(ab_coerced), language = NULL, tolower = TRUE))),
" (", unique(ab_coerced), ")."
), collapse = "\n")
)
if (isTRUE(info)) {
message(
paste0(font_rose_bg(" WARNING "), "\n"),
font_black(paste0(
" ", AMR_env$bullet_icon, " No ", guideline_coerced, " ", method_coerced, " breakpoints available for ",
suppressMessages(suppressWarnings(ab_name(unique(ab_coerced), language = NULL, tolower = TRUE))),
" (", unique(ab_coerced), ")."
), collapse = "\n")
)
}
load_mo_uncertainties(metadata_mo)
return(rep(NA_sir_, nrow(df)))
@ -1609,26 +1640,28 @@ as_sir_method <- function(method_short,
close(p)
# printing messages
if (has_progress_bar == TRUE) {
# the progress bar has overwritten the intro text, so:
message_(intro_txt, appendLF = FALSE, as_note = FALSE)
}
if (length(notes) > 0) {
if (isTRUE(rise_warning)) {
message(font_rose_bg(" WARNING "))
} else {
message(font_yellow_bg(" NOTE "))
if (isTRUE(info)) {
if (has_progress_bar == TRUE) {
# the progress bar has overwritten the intro text, so:
message_(intro_txt, appendLF = FALSE, as_note = FALSE)
}
notes <- unique(notes)
if (isTRUE(verbose) || length(notes) == 1 || NROW(AMR_env$sir_interpretation_history) == 0) {
for (i in seq_along(notes)) {
message(word_wrap(" ", AMR_env$bullet_icon, " ", notes[i], add_fn = font_black))
if (length(notes) > 0) {
if (isTRUE(rise_warning)) {
message(font_rose_bg(" WARNING "))
} else {
message(font_yellow_bg(" NOTE "))
}
notes <- unique(notes)
if (isTRUE(verbose) || length(notes) == 1 || NROW(AMR_env$sir_interpretation_history) == 0) {
for (i in seq_along(notes)) {
message(word_wrap(" ", AMR_env$bullet_icon, " ", notes[i], add_fn = font_black))
}
} else {
message(word_wrap(" ", AMR_env$bullet_icon, " There were multiple notes. Print or View `sir_interpretation_history()` to examine them, or use `as.sir(..., verbose = TRUE)` next time to directly print them here.", add_fn = font_black))
}
} else {
message(word_wrap(" ", AMR_env$bullet_icon, " There were multiple notes. Print or View `sir_interpretation_history()` to examine them, or use `as.sir(..., verbose = TRUE)` next time to directly print them here.", add_fn = font_black))
message(font_green_bg(" OK "))
}
} else {
message(font_green_bg(" OK "))
}
load_mo_uncertainties(metadata_mo)

Binary file not shown.