mirror of
https://github.com/msberends/AMR.git
synced 2025-07-12 23:01:51 +02:00
fix SIR interpretation
This commit is contained in:
@ -30,7 +30,7 @@
|
||||
#' Define Custom EUCAST Rules
|
||||
#'
|
||||
#' Define custom EUCAST rules for your organisation or specific analysis and use the output of this function in [eucast_rules()].
|
||||
#' @param ... rules in [formula][base::tilde] notation, see *Examples*
|
||||
#' @param ... rules in [formula][base::tilde] notation, see below for instructions, and in *Examples*
|
||||
#' @details
|
||||
#' Some organisations have their own adoption of EUCAST rules. This function can be used to define custom EUCAST rules to be used in the [eucast_rules()] function.
|
||||
#' @section How it works:
|
||||
@ -89,11 +89,24 @@
|
||||
#' #> 2 Klebsiella pneumoniae R R S
|
||||
#' ```
|
||||
#'
|
||||
#' ### Usage of antibiotic group names
|
||||
#' ### Usage of multiple antibiotics and antibiotic group names
|
||||
#'
|
||||
#' You can define antibiotic groups instead of single antibiotics for the rule consequence, which is the part *after* the tilde (~). In the examples above, the antibiotic group `aminopenicillins` includes both ampicillin and amoxicillin.
|
||||
#'
|
||||
#' Rules can also be applied to multiple antibiotics and antibiotic groups simultaneously. Use the `c()` function to combine multiple antibiotics. For instance, the following example sets all aminopenicillins and ureidopenicillins to "R" if column TZP (piperacillin/tazobactam) is "R":
|
||||
#'
|
||||
#' ```r
|
||||
#' x <- custom_eucast_rules(TZP == "R" ~ c(aminopenicillins, ureidopenicillins) == "R")
|
||||
#' x
|
||||
#' #> A set of custom EUCAST rules:
|
||||
#' #>
|
||||
#' #> 1. If TZP is "R" then set to "R":
|
||||
#' #> amoxicillin (AMX), ampicillin (AMP), azlocillin (AZL), mezlocillin (MEZ), piperacillin (PIP), piperacillin/tazobactam (TZP)
|
||||
#' ```
|
||||
#'
|
||||
#' It is possible to define antibiotic groups instead of single antibiotics for the rule consequence, the part *after* the tilde. In above examples, the antibiotic group `aminopenicillins` is used to include ampicillin and amoxicillin. The following groups are allowed (case-insensitive). Within parentheses are the drugs that will be matched when running the rule.
|
||||
#' These `r length(DEFINED_AB_GROUPS)` antibiotic groups are allowed in the rules (case-insensitive) and can be used in any combination:
|
||||
#'
|
||||
#' `r paste0(" * ", sapply(DEFINED_AB_GROUPS, function(x) paste0("\"", tolower(gsub("^AB_", "", x)), "\"\\cr(", vector_and(ab_name(eval(parse(text = x), envir = asNamespace("AMR")), language = NULL, tolower = TRUE), quotes = FALSE), ")"), USE.NAMES = FALSE), "\n", collapse = "")`
|
||||
#' `r paste0(" * ", sapply(DEFINED_AB_GROUPS, function(x) paste0(tolower(gsub("^AB_", "", x)), "\\cr(", vector_and(ab_name(eval(parse(text = x), envir = asNamespace("AMR")), language = NULL, tolower = TRUE), quotes = FALSE), ")"), USE.NAMES = FALSE), "\n", collapse = "")`
|
||||
#' @returns A [list] containing the custom rules
|
||||
#' @export
|
||||
#' @examples
|
||||
@ -156,24 +169,34 @@ custom_eucast_rules <- function(...) {
|
||||
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see `?custom_eucast_rules`"
|
||||
)
|
||||
result_group <- as.character(result)[[2]]
|
||||
if (paste0("AB_", toupper(result_group), "S") %in% DEFINED_AB_GROUPS) {
|
||||
# support for e.g. 'aminopenicillin' if user meant 'aminopenicillins'
|
||||
result_group <- paste0(result_group, "s")
|
||||
result_group<- as.character(str2lang(result_group))
|
||||
result_group <- result_group[result_group != "c"]
|
||||
result_group_agents <- character(0)
|
||||
for (j in seq_len(length(result_group))) {
|
||||
if (paste0("AB_", toupper(result_group[j]), "S") %in% DEFINED_AB_GROUPS) {
|
||||
# support for e.g. 'aminopenicillin' if user meant 'aminopenicillins'
|
||||
result_group[j] <- paste0(result_group[j], "s")
|
||||
}
|
||||
if (paste0("AB_", toupper(result_group[j])) %in% DEFINED_AB_GROUPS) {
|
||||
result_group_agents <- c(result_group_agents,
|
||||
eval(parse(text = paste0("AB_", toupper(result_group[j]))), envir = asNamespace("AMR")))
|
||||
} else {
|
||||
out_group <- tryCatch(
|
||||
suppressWarnings(as.ab(result_group[j],
|
||||
fast_mode = TRUE,
|
||||
flag_multiple_results = FALSE
|
||||
)),
|
||||
error = function(e) NA_character_
|
||||
)
|
||||
if (!all(is.na(out_group))) {
|
||||
result_group_agents <- c(result_group_agents, out_group)
|
||||
}
|
||||
}
|
||||
}
|
||||
if (paste0("AB_", toupper(result_group)) %in% DEFINED_AB_GROUPS) {
|
||||
result_group <- eval(parse(text = paste0("AB_", toupper(result_group))), envir = asNamespace("AMR"))
|
||||
} else {
|
||||
result_group <- tryCatch(
|
||||
suppressWarnings(as.ab(result_group,
|
||||
fast_mode = TRUE,
|
||||
flag_multiple_results = FALSE
|
||||
)),
|
||||
error = function(e) NA_character_
|
||||
)
|
||||
}
|
||||
|
||||
result_group_agents <- result_group_agents[!is.na(result_group_agents)]
|
||||
|
||||
stop_if(
|
||||
any(is.na(result_group)),
|
||||
length(result_group_agents) == 0,
|
||||
"this result of rule ", i, " could not be translated to a single antimicrobial drug/group: \"",
|
||||
as.character(result)[[2]], "\".\n\nThe input can be a name or code of an antimicrobial drug, or be one of: ",
|
||||
vector_or(tolower(gsub("AB_", "", DEFINED_AB_GROUPS)), quotes = FALSE), "."
|
||||
@ -186,7 +209,7 @@ custom_eucast_rules <- function(...) {
|
||||
)
|
||||
result_value <- as.sir(result_value)
|
||||
|
||||
out[[i]]$result_group <- result_group
|
||||
out[[i]]$result_group <- result_group_agents
|
||||
out[[i]]$result_value <- result_value
|
||||
}
|
||||
|
||||
|
||||
29
R/sir.R
29
R/sir.R
@ -532,6 +532,8 @@ as.sir.data.frame <- function(x,
|
||||
} else if (length(host) == 1 && as.character(host) %in% colnames(x)) {
|
||||
host <- x[[as.character(host)]]
|
||||
}
|
||||
} else {
|
||||
host <- breakpoint_type
|
||||
}
|
||||
|
||||
# -- UTIs
|
||||
@ -731,6 +733,8 @@ get_guideline <- function(guideline, reference_data) {
|
||||
convert_host <- function(x, lang = get_AMR_locale()) {
|
||||
x <- trimws2(tolower(as.character(x)))
|
||||
x_out <- rep(NA_character_, length(x))
|
||||
x_out[trimws2(tolower(x)) == "human"] <- "human"
|
||||
x_out[trimws2(tolower(x)) == "ecoff"] <- "ecoff"
|
||||
# this order is based on: clinical_breakpoints |> filter(type == "animal") |> count(host, sort = TRUE)
|
||||
x_out[is.na(x_out) & (x %like% "dog|canine" | x %like% translate_AMR("dog|dogs|canine", lang))] <- "dogs"
|
||||
x_out[is.na(x_out) & (x %like% "cattle|bovine" | x %like% translate_AMR("cattle|bovine", lang))] <- "cattle"
|
||||
@ -739,6 +743,7 @@ convert_host <- function(x, lang = get_AMR_locale()) {
|
||||
x_out[is.na(x_out) & (x %like% "horse|equine" | x %like% translate_AMR("horse|horses|equine", lang))] <- "horse"
|
||||
x_out[is.na(x_out) & (x %like% "aqua|fish" | x %like% translate_AMR("aquatic|fish", lang))] <- "aquatic"
|
||||
x_out[is.na(x_out) & (x %like% "bird|chicken|poultry|avia" | x %like% translate_AMR("bird|birds|poultry", lang))] <- "poultry"
|
||||
x_out[x_out == "ecoff"] <- "ECOFF"
|
||||
x_out
|
||||
}
|
||||
|
||||
@ -794,12 +799,10 @@ as_sir_method <- function(method_short,
|
||||
}
|
||||
breakpoint_type <- "animal"
|
||||
} else {
|
||||
host <- NA_character_
|
||||
host <- breakpoint_type
|
||||
}
|
||||
}
|
||||
host <- convert_host(host)
|
||||
host <- tolower(host)
|
||||
host[host == "ecoff"] <- "ECOFF"
|
||||
|
||||
if (message_not_thrown_before("as.sir", "sir_interpretation_history")) {
|
||||
message_("Run `sir_interpretation_history()` afterwards to retrieve a logbook with all the details of the breakpoint interpretations. Note that some ", ifelse(breakpoint_type == "animal", "animal hosts and ", ""), "microorganisms might not have breakpoints for each antimicrobial drug in ", guideline_coerced, ".\n\n")
|
||||
@ -887,15 +890,15 @@ as_sir_method <- function(method_short,
|
||||
if (length(ab) == 1) {
|
||||
ab <- rep(ab, length(x))
|
||||
}
|
||||
if (length(host) == 1) {
|
||||
host <- rep(host, length(x))
|
||||
}
|
||||
if (is.null(uti)) {
|
||||
uti <- NA
|
||||
}
|
||||
if (length(uti) == 1) {
|
||||
uti <- rep(uti, length(x))
|
||||
}
|
||||
if (length(host) == 1) {
|
||||
host <- rep(host, 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.")
|
||||
@ -906,7 +909,7 @@ as_sir_method <- function(method_short,
|
||||
agent_name <- ab_name(ab, tolower = TRUE, language = NULL)
|
||||
same_ab <- generalise_antibiotic_name(ab) == generalise_antibiotic_name(agent_name)
|
||||
same_ab.bak <- generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)
|
||||
agent_formatted[same_ab.bak] <- paste0(agent_formatted[same_ab.bak], " (", ab, ")")
|
||||
agent_formatted[same_ab.bak] <- paste0(agent_formatted[same_ab.bak], " (", ab[same_ab.bak], ")")
|
||||
agent_formatted[!same_ab.bak & !same_ab] <- paste0(agent_formatted[!same_ab.bak & !same_ab],
|
||||
" (", ifelse(ab.bak[!same_ab.bak & !same_ab] == ab[!same_ab.bak & !same_ab],
|
||||
"",
|
||||
@ -915,13 +918,12 @@ as_sir_method <- function(method_short,
|
||||
")")
|
||||
# this intro text will also be printed in the progress bar if the `progress` package is installed
|
||||
intro_txt <- paste0("Interpreting ", method_long, ": ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
|
||||
ifelse(length(unique(agent_formatted)) == 1, unique(agent_formatted), vector_and(ab, quotes = FALSE)),
|
||||
ifelse(length(unique(agent_formatted)) == 1, unique(agent_formatted), paste0("for ", vector_and(ab, quotes = FALSE))),
|
||||
mo_var_found,
|
||||
ifelse(identical(reference_data, AMR::clinical_breakpoints),
|
||||
paste0(", ", font_bold(guideline_coerced)),
|
||||
""),
|
||||
"... ")
|
||||
message_(intro_txt, appendLF = FALSE, as_note = FALSE)
|
||||
|
||||
msg_note <- function(messages) {
|
||||
messages <- unique(messages)
|
||||
@ -1009,6 +1011,10 @@ as_sir_method <- function(method_short,
|
||||
add_intrinsic_resistance_to_AMR_env()
|
||||
}
|
||||
|
||||
if (nrow(df_unique) < 10) {
|
||||
# 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)
|
||||
}
|
||||
p <- progress_ticker(n = nrow(df_unique), n_min = 10, title = font_blue(intro_txt), only_bar_percent = TRUE)
|
||||
has_progress_bar <- !is.null(import_fn("progress_bar", "progress", error_on_fail = FALSE)) && nrow(df_unique) >= 10
|
||||
on.exit(close(p))
|
||||
@ -1018,12 +1024,13 @@ as_sir_method <- function(method_short,
|
||||
p$tick()
|
||||
mo_current <- df_unique[i, "mo", drop = TRUE]
|
||||
ab_current <- df_unique[i, "ab", drop = TRUE]
|
||||
host_current <- df_unique[i, "host", drop = TRUE]
|
||||
uti_current <- df_unique[i, "uti", drop = TRUE]
|
||||
if (is.na(uti_current)) {
|
||||
# no preference, so no filter on UTIs
|
||||
rows <- which(df$mo == mo_current)
|
||||
rows <- which(df$mo == mo_current & df$ab == ab_current & df$host == host_current)
|
||||
} else {
|
||||
rows <- which(df$mo == mo_current & df$uti == uti_current)
|
||||
rows <- which(df$mo == mo_current & df$ab == ab_current & df$host == host_current & df$uti == uti_current)
|
||||
}
|
||||
values <- df[rows, "values", drop = TRUE]
|
||||
new_sir <- rep(NA_sir_, length(rows))
|
||||
|
||||
Reference in New Issue
Block a user