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:
@ -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(
|
||||
|
||||
@ -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, ...) {
|
||||
|
||||
@ -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
|
||||
#' )
|
||||
#'
|
||||
|
||||
204
R/eucast_rules.R
204
R/eucast_rules.R
@ -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)) {
|
||||
|
||||
2
R/mic.R
2
R/mic.R
@ -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)])
|
||||
}
|
||||
|
||||
58
R/plotting.R
58
R/plotting.R
@ -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
|
||||
}
|
||||
|
||||
|
||||
@ -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
151
R/sir.R
@ -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)
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
Reference in New Issue
Block a user