mirror of
https://github.com/msberends/AMR.git
synced 2026-02-09 09:12:59 +01:00
(v3.0.1.9019) Wildtype/Non-wildtype support, and start with interpretive_rules()
Fixes #246 Fixes #254 Fixes #255 Fixes #256
This commit is contained in:
@@ -685,8 +685,12 @@ format_included_data_number <- function(data) {
|
||||
vector_or <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, initial_captital = FALSE, last_sep = " or ") {
|
||||
# makes unique and sorts, and this also removed NAs
|
||||
v <- unique(v)
|
||||
has_na <- anyNA(v)
|
||||
if (isTRUE(sort)) {
|
||||
v <- sort(v)
|
||||
if (has_na) {
|
||||
v <- c(v, NA)
|
||||
}
|
||||
}
|
||||
if (isTRUE(reverse)) {
|
||||
v <- rev(v)
|
||||
@@ -708,18 +712,25 @@ vector_or <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, initial_ca
|
||||
# class 'sir' should be sorted like this
|
||||
v <- c("S", "I", "R")
|
||||
}
|
||||
if (identical(v, c("I", "NI", "R", "S", "SDD"))) {
|
||||
if (identical(v, sort(VALID_SIR_LEVELS))) {
|
||||
# class 'sir' should be sorted like this
|
||||
v <- c("S", "SDD", "I", "R", "NI")
|
||||
v <- VALID_SIR_LEVELS
|
||||
}
|
||||
# oxford comma
|
||||
if (last_sep %in% c(" or ", " and ") && length(v) > 2) {
|
||||
last_sep <- paste0(",", last_sep)
|
||||
}
|
||||
NAs <- which(is.na(v))
|
||||
|
||||
if (is.numeric(v)) {
|
||||
v <- trimws(vapply(FUN.VALUE = character(1), v, format, scientific = FALSE))
|
||||
}
|
||||
quoted <- paste0(quotes, v, quotes)
|
||||
quoted[NAs] <- "NA"
|
||||
# all commas except for last item, so will become '"val1", "val2", "val3" or "val4"'
|
||||
paste0(
|
||||
paste0(quotes, v[seq_len(length(v) - 1)], quotes, collapse = ", "),
|
||||
last_sep, paste0(quotes, v[length(v)], quotes)
|
||||
paste(quoted[seq_len(length(quoted) - 1)], collapse = ", "),
|
||||
last_sep, quoted[length(quoted)]
|
||||
)
|
||||
}
|
||||
|
||||
@@ -1097,11 +1108,14 @@ format_custom_query_rule <- function(query, colours = has_colour()) {
|
||||
query <- gsub("any\\((.*)\\)$", paste0(font_black("any of "), "\\1"), query)
|
||||
query <- gsub("all\\((.*)\\)$", paste0(font_black("all of "), "\\1"), query)
|
||||
if (colours == TRUE) {
|
||||
query <- gsub("[\"']R[\"']", font_rose_bg(" R "), query)
|
||||
query <- gsub("[\"']SDD[\"']", font_orange_bg(" SDD "), query)
|
||||
query <- gsub("[\"']S[\"']", font_green_bg(" S "), query)
|
||||
query <- gsub("[\"']NI[\"']", font_grey_bg(font_black(" NI ")), query)
|
||||
query <- gsub("[\"']SDD[\"']", font_orange_bg(" SDD "), query)
|
||||
query <- gsub("[\"']I[\"']", font_orange_bg(" I "), query)
|
||||
query <- gsub("[\"']R[\"']", font_rose_bg(" R "), query)
|
||||
query <- gsub("[\"']NI[\"']", font_grey_bg(font_black(" NI ")), query)
|
||||
query <- gsub("[\"']WT[\"']", font_green_bg(" SDD "), query)
|
||||
query <- gsub("[\"']NWT[\"']", font_rose_bg(" I "), query)
|
||||
query <- gsub("[\"']NS[\"']", font_rose_bg(" R "), query)
|
||||
}
|
||||
# replace the black colour 'stops' with blue colour 'starts'
|
||||
query <- gsub("\033[39m", "\033[34m", as.character(query), fixed = TRUE)
|
||||
|
||||
@@ -839,10 +839,10 @@ c.amr_selector <- function(...) {
|
||||
|
||||
all_any_amr_selector <- function(type, ..., na.rm = TRUE) {
|
||||
cols_ab <- c(...)
|
||||
result <- cols_ab[toupper(cols_ab) %in% c("S", "SDD", "I", "R", "NI")]
|
||||
result <- cols_ab[toupper(cols_ab) %in% VALID_SIR_LEVELS]
|
||||
if (length(result) == 0) {
|
||||
message_("Filtering ", type, " of columns ", vector_and(font_bold(cols_ab, collapse = NULL), quotes = "'"), ' to contain value "S", "I" or "R"')
|
||||
result <- c("S", "SDD", "I", "R", "NI")
|
||||
result <- VALID_SIR_LEVELS
|
||||
}
|
||||
cols_ab <- cols_ab[!cols_ab %in% result]
|
||||
df <- get_current_data(arg_name = NA, call = -3)
|
||||
@@ -951,7 +951,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
|
||||
}
|
||||
}
|
||||
# this is `!=`, so turn around the values
|
||||
sir <- c("S", "SDD", "I", "R", "NI")
|
||||
sir <- VALID_SIR_LEVELS
|
||||
e2 <- sir[sir != e2]
|
||||
structure(all_any_amr_selector(type = type, e1, e2),
|
||||
class = c("amr_selector_any_all", "logical")
|
||||
|
||||
@@ -560,12 +560,11 @@ antibiogram.default <- function(x,
|
||||
next
|
||||
} else {
|
||||
# determine whether this new column should contain S, I, R, or NA
|
||||
S_values <- c("S", "WT")
|
||||
if (isTRUE(combine_SI)) {
|
||||
S_values <- c("S", "SDD", "I")
|
||||
} else {
|
||||
S_values <- "S"
|
||||
S_values <- c(S_values, "SDD", "I")
|
||||
}
|
||||
other_values <- setdiff(c("S", "SDD", "I", "R"), S_values)
|
||||
other_values <- setdiff(c("S", "SDD", "I", "R", "WT", "NWT", "NS"), S_values)
|
||||
x_transposed <- as.list(as.data.frame(t(x[, abx, drop = FALSE]), stringsAsFactors = FALSE))
|
||||
if (isTRUE(only_all_tested)) {
|
||||
x[new_colname] <- as.sir(vapply(FUN.VALUE = character(1), x_transposed, function(x) ifelse(anyNA(x), NA_character_, ifelse(any(x %in% S_values), "S", "R")), USE.NAMES = FALSE))
|
||||
@@ -615,10 +614,9 @@ antibiogram.default <- function(x,
|
||||
|
||||
counts <- out
|
||||
|
||||
out$n_susceptible <- out$S + out$WT
|
||||
if (isTRUE(combine_SI)) {
|
||||
out$n_susceptible <- out$S + out$I + out$SDD
|
||||
} else {
|
||||
out$n_susceptible <- out$S
|
||||
out$n_susceptible <- out$n_susceptible + out$I + out$SDD
|
||||
}
|
||||
if (all(out$n_tested < minimum, na.rm = TRUE) && wisca == FALSE) {
|
||||
warning_("All combinations had less than `minimum = ", minimum, "` results, returning an empty antibiogram")
|
||||
|
||||
@@ -43,7 +43,7 @@
|
||||
#' @details The function [format()] calculates the resistance per bug-drug combination and returns a table ready for reporting/publishing. Use `combine_SI = TRUE` (default) to test R vs. S+I and `combine_SI = FALSE` to test R+I vs. S. This table can also directly be used in R Markdown / Quarto without the need for e.g. [knitr::kable()].
|
||||
#' @export
|
||||
#' @rdname bug_drug_combinations
|
||||
#' @return The function [bug_drug_combinations()] returns a [data.frame] with columns "mo", "ab", "S", "SDD", "I", "R", and "total".
|
||||
#' @return The function [bug_drug_combinations()] returns a [data.frame] with columns "mo", "ab", "S", "SDD", "I", "R", "WT, "NWT", and "total".
|
||||
#' @examples
|
||||
#' # example_isolates is a data set available in the AMR package.
|
||||
#' # run ?example_isolates for more info.
|
||||
@@ -111,6 +111,8 @@ bug_drug_combinations <- function(x,
|
||||
SDD = integer(0),
|
||||
I = integer(0),
|
||||
R = integer(0),
|
||||
WT = integer(0),
|
||||
NWT = integer(0),
|
||||
total = integer(0),
|
||||
total_rows = integer(0),
|
||||
stringsAsFactors = FALSE
|
||||
@@ -133,6 +135,9 @@ bug_drug_combinations <- function(x,
|
||||
I = m["I", ],
|
||||
R = m["R", ],
|
||||
NI = m["NI", ],
|
||||
WT = m["WT", ],
|
||||
NWT = m["NWT", ],
|
||||
NS = m["NS", ],
|
||||
na = m[which(is.na(rownames(m))), ],
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
@@ -146,8 +151,11 @@ bug_drug_combinations <- function(x,
|
||||
I = merged$I,
|
||||
R = merged$R,
|
||||
NI = merged$NI,
|
||||
total = merged$S + merged$SDD + merged$I + merged$R + merged$NI,
|
||||
total_rows = merged$S + merged$SDD + merged$I + merged$R + merged$NI + merged$na,
|
||||
WT = merged$WT,
|
||||
NWT = merged$NWT,
|
||||
NS = merged$NS,
|
||||
total = merged$S + merged$SDD + merged$I + merged$R + merged$NI + merged$WT + merged$NWT + merged$NS,
|
||||
total_rows = merged$S + merged$SDD + merged$I + merged$R + merged$NI + merged$WT + merged$NWT + merged$NS + merged$na,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
if (data_has_groups) {
|
||||
@@ -229,12 +237,17 @@ format.bug_drug_combinations <- function(x,
|
||||
I = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$I[i], na.rm = TRUE)),
|
||||
R = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$R[i], na.rm = TRUE)),
|
||||
NI = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$NI[i], na.rm = TRUE)),
|
||||
WT = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$WT[i], na.rm = TRUE)),
|
||||
NWT = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$NWT[i], na.rm = TRUE)),
|
||||
NS = vapply(FUN.VALUE = double(1), idx, function(i) sum(x$NS[i], na.rm = TRUE)),
|
||||
total = vapply(FUN.VALUE = double(1), idx, function(i) {
|
||||
sum(x$S[i], na.rm = TRUE) +
|
||||
sum(x$SDD[i], na.rm = TRUE) +
|
||||
sum(x$I[i], na.rm = TRUE) +
|
||||
sum(x$R[i], na.rm = TRUE) +
|
||||
sum(x$NI[i], na.rm = TRUE)
|
||||
sum(x$WT[i], na.rm = TRUE) +
|
||||
sum(x$NWT[i], na.rm = TRUE) +
|
||||
sum(x$NS[i], na.rm = TRUE)
|
||||
}),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
@@ -246,10 +259,10 @@ format.bug_drug_combinations <- function(x,
|
||||
if (remove_intrinsic_resistant == TRUE) {
|
||||
x <- subset(x, R != total)
|
||||
}
|
||||
|
||||
x$isolates <- x$R + x$NWT
|
||||
if (combine_SI == TRUE) {
|
||||
x$isolates <- x$R
|
||||
} else {
|
||||
x$isolates <- x$R + x$I + x$SDD
|
||||
x$isolates <- x$isolates + x$I + x$SDD
|
||||
}
|
||||
|
||||
give_ab_name <- function(ab, format, language) {
|
||||
|
||||
12
R/count.R
12
R/count.R
@@ -122,7 +122,7 @@
|
||||
count_resistant <- function(..., only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = "R",
|
||||
ab_result = c("R", "NWT", "NS"),
|
||||
only_all_tested = only_all_tested,
|
||||
only_count = TRUE
|
||||
),
|
||||
@@ -135,7 +135,7 @@ count_resistant <- function(..., only_all_tested = FALSE) {
|
||||
count_susceptible <- function(..., only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = c("S", "SDD", "I"),
|
||||
ab_result = c("S", "SDD", "I", "WT"),
|
||||
only_all_tested = only_all_tested,
|
||||
only_count = TRUE
|
||||
),
|
||||
@@ -161,7 +161,7 @@ count_S <- function(..., only_all_tested = FALSE) {
|
||||
count_SI <- function(..., only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = c("S", "SDD", "I"),
|
||||
ab_result = c("S", "SDD", "I", "WT"),
|
||||
only_all_tested = only_all_tested,
|
||||
only_count = TRUE
|
||||
),
|
||||
@@ -187,7 +187,7 @@ count_I <- function(..., only_all_tested = FALSE) {
|
||||
count_IR <- function(..., only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = c("I", "SDD", "R"),
|
||||
ab_result = c("I", "SDD", "R", "NWT"),
|
||||
only_all_tested = only_all_tested,
|
||||
only_count = TRUE
|
||||
),
|
||||
@@ -200,7 +200,7 @@ count_IR <- function(..., only_all_tested = FALSE) {
|
||||
count_R <- function(..., only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = "R",
|
||||
ab_result = c("R", "NWT", "NS"),
|
||||
only_all_tested = only_all_tested,
|
||||
only_count = TRUE
|
||||
),
|
||||
@@ -213,7 +213,7 @@ count_R <- function(..., only_all_tested = FALSE) {
|
||||
count_all <- function(..., only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = c("S", "SDD", "I", "R", "NI"),
|
||||
ab_result = VALID_SIR_LEVELS,
|
||||
only_all_tested = only_all_tested,
|
||||
only_count = TRUE
|
||||
),
|
||||
|
||||
@@ -220,8 +220,8 @@ custom_eucast_rules <- function(...) {
|
||||
result_value <- as.character(result)[[3]]
|
||||
result_value[result_value == "NA"] <- NA
|
||||
stop_ifnot(
|
||||
result_value %in% c("S", "SDD", "I", "R", "NI", NA),
|
||||
"the resulting value of rule ", i, " must be either \"S\", \"SDD\", \"I\", \"R\", \"NI\" or NA"
|
||||
result_value %in% c(VALID_SIR_LEVELS, NA),
|
||||
paste0("the resulting value of rule ", i, " must be either ", vector_or(c(VALID_SIR_LEVELS, NA), sort = FALSE))
|
||||
)
|
||||
result_value <- as.sir(result_value)
|
||||
|
||||
|
||||
@@ -246,7 +246,7 @@ first_isolate <- function(x = NULL,
|
||||
FUN.VALUE = logical(1),
|
||||
X = x,
|
||||
# check only first 10,000 rows
|
||||
FUN = function(x) any(as.character(x[1:10000]) %in% c("S", "SDD", "I", "R", "NI"), na.rm = TRUE),
|
||||
FUN = function(x) any(as.character(x[1:10000]) %in% VALID_SIR_LEVELS, na.rm = TRUE),
|
||||
USE.NAMES = FALSE
|
||||
))
|
||||
if (method == "phenotype-based" && !any_col_contains_sir) {
|
||||
|
||||
@@ -53,15 +53,21 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
|
||||
vector_and(txt, quotes = FALSE)
|
||||
}
|
||||
|
||||
#' Apply EUCAST Rules
|
||||
#' Apply Interpretive Rules
|
||||
#'
|
||||
#' @description
|
||||
#' Apply rules from clinical breakpoints notes and expected resistant phenotypes as defined by the European Committee on Antimicrobial Susceptibility Testing (EUCAST, <https://www.eucast.org>), see *Source*. Use [eucast_dosage()] to get a [data.frame] with advised dosages of a certain bug-drug combination, which is based on the [dosage] data set.
|
||||
#' **WORK IN PROGRESS**
|
||||
#'
|
||||
#' To improve the interpretation of the antibiogram before EUCAST rules are applied, some non-EUCAST rules can applied at default, see *Details*.
|
||||
# TODO Remove this remark before next release
|
||||
#' **The `interpretive_rules()` function is new, to allow CLSI 'rules' too. The old `eucast_rules()` function will stay as a wrapper, but we need to generalise more parts of the underlying code to allow more than just EUCAST.**
|
||||
#'
|
||||
#' Apply rules from clinical breakpoints notes and expected resistant phenotypes as defined by e.g. the European Committee on Antimicrobial Susceptibility Testing (EUCAST, <https://www.eucast.org>), see *Source*. Use [eucast_dosage()] to get a [data.frame] with advised dosages of a certain bug-drug combination, which is based on the [dosage] data set.
|
||||
#'
|
||||
#' To improve the interpretation of the antibiogram before CLSI/EUCAST interpretive rules are applied, some AMR-specific rules can be 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"`, `"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 guideline A guideline name, either "EUCAST" (default) or "CLSI". This can be set with the package option [`AMR_guideline`][AMR-options].
|
||||
#' @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_interpretive_rules`][AMR-options]: `options(AMR_interpretive_rules = "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)`.
|
||||
@@ -100,9 +106,9 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
|
||||
#'
|
||||
#' Important examples include amoxicillin and amoxicillin/clavulanic acid, and trimethoprim and trimethoprim/sulfamethoxazole. Needless to say, for these rules to work, both drugs must be available in the data set.
|
||||
#'
|
||||
#' Since these rules are not officially approved by EUCAST, they are not applied at default. To use these rules, include `"other"` to the `rules` argument, or use `eucast_rules(..., rules = "all")`. You can also set the package option [`AMR_eucastrules`][AMR-options], i.e. run `options(AMR_eucastrules = "all")`.
|
||||
#' Since these rules are not officially approved by EUCAST, they are not applied at default. To use these rules, include `"other"` to the `rules` argument, or use `eucast_rules(..., rules = "all")`. You can also set the package option [`AMR_interpretive_rules`][AMR-options], i.e. run `options(AMR_interpretive_rules = "all")`.
|
||||
#' @aliases EUCAST
|
||||
#' @rdname eucast_rules
|
||||
#' @rdname interpretive_rules
|
||||
#' @export
|
||||
#' @return The input of `x`, possibly with edited values of antimicrobials. Or, if `verbose = TRUE`, a [data.frame] with all original and new values of the affected bug-drug combinations.
|
||||
#' @source
|
||||
@@ -156,21 +162,23 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
|
||||
#' eucast_dosage(c("tobra", "genta", "cipro"), "iv")
|
||||
#'
|
||||
#' eucast_dosage(c("tobra", "genta", "cipro"), "iv", version_breakpoints = 10)
|
||||
eucast_rules <- function(x,
|
||||
col_mo = NULL,
|
||||
info = interactive(),
|
||||
rules = getOption("AMR_eucastrules", default = c("breakpoints", "expected_phenotypes")),
|
||||
verbose = FALSE,
|
||||
version_breakpoints = 15.0,
|
||||
version_expected_phenotypes = 1.2,
|
||||
version_expertrules = 3.3,
|
||||
ampc_cephalosporin_resistance = NA,
|
||||
only_sir_columns = any(is.sir(x)),
|
||||
custom_rules = NULL,
|
||||
overwrite = FALSE,
|
||||
...) {
|
||||
interpretive_rules <- function(x,
|
||||
col_mo = NULL,
|
||||
guideline = getOption("AMR_guideline", "EUCAST"),
|
||||
info = interactive(),
|
||||
rules = getOption("AMR_interpretive_rules", default = c("breakpoints", "expected_phenotypes")),
|
||||
verbose = FALSE,
|
||||
version_breakpoints = 15.0,
|
||||
version_expected_phenotypes = 1.2,
|
||||
version_expertrules = 3.3,
|
||||
ampc_cephalosporin_resistance = NA,
|
||||
only_sir_columns = any(is.sir(x)),
|
||||
custom_rules = NULL,
|
||||
overwrite = FALSE,
|
||||
...) {
|
||||
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(guideline, allow_class = "character", has_length = 1, is_in = c("EUCAST", "CLSI"))
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
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)
|
||||
@@ -1092,6 +1100,25 @@ eucast_rules <- function(x,
|
||||
}
|
||||
}
|
||||
|
||||
#' @rdname interpretive_rules
|
||||
#' @export
|
||||
eucast_rules <- function(x,
|
||||
rules = getOption("AMR_interpretive_rules", default = c("breakpoints", "expected_phenotypes")),
|
||||
...) {
|
||||
if (!is.null(getOption("AMR_eucastrules", default = NULL))) {
|
||||
warning_("The global option `AMR_eucastrules` that you have set is now invalid was ignored - set `AMR_interpretive_rules` instead. See `?AMR-options`.")
|
||||
}
|
||||
interpretive_rules(x = x, guideline = "EUCAST", rules = rules, ...)
|
||||
}
|
||||
|
||||
#' @rdname interpretive_rules
|
||||
#' @export
|
||||
clsi_rules <- function(x,
|
||||
rules = getOption("AMR_interpretive_rules", default = c("breakpoints", "expected_phenotypes")),
|
||||
...) {
|
||||
interpretive_rules(x = x, guideline = "CLSI", rules = rules, ...)
|
||||
}
|
||||
|
||||
# helper function for editing the table ----
|
||||
edit_sir <- function(x,
|
||||
to,
|
||||
@@ -1131,7 +1158,7 @@ edit_sir <- function(x,
|
||||
track_changes$sir_warn <- cols[!vapply(FUN.VALUE = logical(1), x[, cols, drop = FALSE], is.sir)]
|
||||
}
|
||||
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")
|
||||
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" | new_edits[rows, cols] == "WT" | new_edits[rows, cols] == "NWT" | new_edits[rows, cols] == "NS")
|
||||
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`.")
|
||||
@@ -1230,7 +1257,7 @@ edit_sir <- function(x,
|
||||
return(track_changes)
|
||||
}
|
||||
|
||||
#' @rdname eucast_rules
|
||||
#' @rdname interpretive_rules
|
||||
#' @export
|
||||
eucast_dosage <- function(ab, administration = "iv", version_breakpoints = 15) {
|
||||
meet_criteria(ab, allow_class = c("character", "numeric", "integer", "factor"))
|
||||
@@ -282,6 +282,9 @@ generate_antimicrobials_string <- function(df) {
|
||||
function(x) {
|
||||
x <- toupper(as.character(x))
|
||||
x[x == "SDD"] <- "I"
|
||||
x[x == "WT"] <- "S"
|
||||
x[x == "NWT"] <- "R"
|
||||
x[x == "NS"] <- "R"
|
||||
# ignore "NI" here, no use for determining first isolates
|
||||
x[!x %in% c("S", "I", "R")] <- "."
|
||||
paste(x)
|
||||
@@ -311,11 +314,7 @@ antimicrobials_equal <- function(y,
|
||||
|
||||
key2sir <- function(val) {
|
||||
val <- strsplit(val, "", fixed = TRUE)[[1L]]
|
||||
val.int <- rep(NA_real_, length(val))
|
||||
val.int[val == "S"] <- 1
|
||||
val.int[val %in% c("I", "SDD")] <- 2
|
||||
val.int[val == "R"] <- 3
|
||||
val.int
|
||||
as.double(as.sir(val))
|
||||
}
|
||||
# only run on uniques
|
||||
uniq <- unique(c(y, z))
|
||||
|
||||
2
R/mdro.R
2
R/mdro.R
@@ -777,7 +777,7 @@ mdro <- function(x = NULL,
|
||||
sum(vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
group_tbl,
|
||||
function(group) any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% c("S", "SDD", "I", "R"))
|
||||
function(group) any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% VALID_SIR_LEVELS[VALID_SIR_LEVELS != "NI"])
|
||||
))
|
||||
}
|
||||
)
|
||||
|
||||
34
R/mic.R
34
R/mic.R
@@ -63,6 +63,7 @@ COMMON_MIC_VALUES <- c(
|
||||
#' @param x A [character] or [numeric] vector.
|
||||
#' @param na.rm A [logical] indicating whether missing values should be removed.
|
||||
#' @param keep_operators A [character] specifying how to handle operators (such as `>` and `<=`) in the input. Accepts one of three values: `"all"` (or `TRUE`) to keep all operators, `"none"` (or `FALSE`) to remove all operators, or `"edges"` to keep operators only at both ends of the range.
|
||||
#' @param round_to_next_log2 A [logical] to round up all values to the next log2 level, that are not either `r vector_or(COMMON_MIC_VALUES, quotes = F)`. Values that are already in this list (with or without operators), are left unchanged (including any operators).
|
||||
#' @param ... Arguments passed on to methods.
|
||||
#' @details To interpret MIC values as SIR values, use [as.sir()] on MIC values. It supports guidelines from EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`).
|
||||
#'
|
||||
@@ -157,10 +158,12 @@ COMMON_MIC_VALUES <- c(
|
||||
#' if (require("ggplot2")) {
|
||||
#' autoplot(mic_data, mo = "E. coli", ab = "cipro", language = "nl") # Dutch
|
||||
#' }
|
||||
as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
|
||||
as.mic <- function(x, na.rm = FALSE, keep_operators = "all", round_to_next_log2 = FALSE) {
|
||||
meet_criteria(x, allow_NA = TRUE)
|
||||
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(keep_operators, allow_class = c("character", "logical"), is_in = c("all", "none", "edges", FALSE, TRUE), has_length = 1)
|
||||
meet_criteria(round_to_next_log2, allow_class = "logical", has_length = 1)
|
||||
|
||||
if (isTRUE(keep_operators)) {
|
||||
keep_operators <- "all"
|
||||
} else if (isFALSE(keep_operators)) {
|
||||
@@ -168,6 +171,9 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
|
||||
}
|
||||
|
||||
if (is.mic(x) && (keep_operators == "all" || !any(x %like% "[>=<]", na.rm = TRUE))) {
|
||||
if (isTRUE(round_to_next_log2)) {
|
||||
x <- roundup_to_nearest_log2(x)
|
||||
}
|
||||
if (!identical(levels(x), VALID_MIC_LEVELS)) {
|
||||
# might be from an older AMR version - just update MIC factor levels
|
||||
x <- set_clean_class(factor(as.character(x), levels = VALID_MIC_LEVELS, ordered = TRUE),
|
||||
@@ -279,6 +285,10 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
|
||||
x[!x %in% keep] <- gsub("[>=<]", "", x[!x %in% keep])
|
||||
}
|
||||
|
||||
if (isTRUE(round_to_next_log2)) {
|
||||
x <- roundup_to_nearest_log2(x)
|
||||
}
|
||||
|
||||
set_clean_class(factor(x, levels = VALID_MIC_LEVELS, ordered = TRUE),
|
||||
new_class = c("mic", "ordered", "factor")
|
||||
)
|
||||
@@ -305,7 +315,7 @@ NA_mic_ <- set_clean_class(factor(NA, levels = VALID_MIC_LEVELS, ordered = TRUE)
|
||||
#' @rdname as.mic
|
||||
#' @param mic_range A manual range to rescale the MIC values, e.g., `mic_range = c(0.001, 32)`. Use `NA` to prevent rescaling on one side, e.g., `mic_range = c(NA, 32)`.
|
||||
#' @export
|
||||
rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE) {
|
||||
rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE, round_to_next_log2 = FALSE) {
|
||||
meet_criteria(mic_range, allow_class = c("numeric", "integer", "logical", "mic"), has_length = 2, allow_NA = TRUE, allow_NULL = TRUE)
|
||||
if (is.numeric(mic_range)) {
|
||||
mic_range <- trimws(format(mic_range, scientific = FALSE))
|
||||
@@ -336,7 +346,7 @@ rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE) {
|
||||
x[x > max_mic] <- max_mic
|
||||
}
|
||||
|
||||
x <- as.mic(x, keep_operators = ifelse(keep_operators == "edges", "none", keep_operators))
|
||||
x <- as.mic(x, keep_operators = ifelse(keep_operators == "edges", "none", keep_operators), round_to_next_log2 = round_to_next_log2)
|
||||
|
||||
if (isTRUE(as.mic)) {
|
||||
if (keep_operators == "edges" && length(unique(x)) > 1) {
|
||||
@@ -605,6 +615,24 @@ get_skimmers.mic <- function(column) {
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
roundup_to_nearest_log2 <- function(x) {
|
||||
x_dbl <- suppressWarnings(as.double(gsub("[>=<]", "", x)))
|
||||
x_new <- vapply(
|
||||
FUN.VALUE = double(1),
|
||||
x_dbl,
|
||||
function(val) {
|
||||
if (is.na(val)) {
|
||||
NA_real_
|
||||
} else {
|
||||
COMMON_MIC_VALUES[which(COMMON_MIC_VALUES >= val)][1]
|
||||
}
|
||||
}
|
||||
)
|
||||
x[!x_dbl %in% COMMON_MIC_VALUES] <- x_new[!x_dbl %in% COMMON_MIC_VALUES]
|
||||
x
|
||||
}
|
||||
|
||||
# Miscellaneous mathematical functions ------------------------------------
|
||||
|
||||
#' @method mean mic
|
||||
|
||||
146
R/plotting.R
146
R/plotting.R
@@ -399,7 +399,12 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
|
||||
args,
|
||||
list(
|
||||
aesthetics = aesthetics,
|
||||
values = c(colours_SIR, NI = "grey30")
|
||||
values = c(colours_SIR,
|
||||
NI = "grey30",
|
||||
WT = unname(colours_SIR[1]),
|
||||
NWT = unname(colours_SIR[4]),
|
||||
NS = unname(colours_SIR[4])
|
||||
)
|
||||
)
|
||||
)
|
||||
}
|
||||
@@ -424,6 +429,9 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
|
||||
x[x == "SI"] <- "(S/I) Susceptible"
|
||||
x[x == "IR"] <- "(I/R) Non-susceptible"
|
||||
x[x == "NI"] <- "(NI) Non-interpretable"
|
||||
x[x == "WT"] <- "(WT) Wildtype"
|
||||
x[x == "NWT"] <- "(NWT) Non-wildtype"
|
||||
x[x == "NS"] <- "(NS) Non-susceptible"
|
||||
x <- translate_AMR(x, language = language)
|
||||
}
|
||||
x
|
||||
@@ -537,11 +545,16 @@ plot.mic <- function(x,
|
||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
|
||||
language <- validate_language(language)
|
||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(include_PKPD, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(breakpoint_type, allow_class = "character", is_in = AMR::clinical_breakpoints$type, has_length = 1)
|
||||
|
||||
x <- as.mic(x) # make sure that currently implemented MIC levels are used
|
||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||
colours_SIR <- expand_SIR_colours(colours_SIR)
|
||||
|
||||
# wildtype/Non-wildtype
|
||||
is_wt_nwt <- identical(breakpoint_type, "ECOFF")
|
||||
|
||||
x <- plotrange_as_table(x, expand = expand)
|
||||
cols_sub <- plot_colours_subtitle_guideline(
|
||||
x = x,
|
||||
@@ -572,10 +585,14 @@ plot.mic <- function(x,
|
||||
if (any(colours_SIR %in% cols_sub$cols)) {
|
||||
legend_txt <- character(0)
|
||||
legend_col <- character(0)
|
||||
if (any(cols_sub$cols == colours_SIR[1] & cols_sub$count > 0)) {
|
||||
if (!is_wt_nwt & any(cols_sub$cols == colours_SIR[1] & cols_sub$count > 0)) {
|
||||
legend_txt <- c(legend_txt, "(S) Susceptible")
|
||||
legend_col <- colours_SIR[1]
|
||||
}
|
||||
if (is_wt_nwt & any(cols_sub$cols == colours_SIR[1] & cols_sub$count > 0)) {
|
||||
legend_txt <- c(legend_txt, "(WT) Wildtype")
|
||||
legend_col <- colours_SIR[1]
|
||||
}
|
||||
if (any(cols_sub$cols == colours_SIR[2] & cols_sub$count > 0)) {
|
||||
legend_txt <- c(legend_txt, "(SDD) Susceptible dose-dependent")
|
||||
legend_col <- c(legend_col, colours_SIR[2])
|
||||
@@ -584,10 +601,14 @@ plot.mic <- function(x,
|
||||
legend_txt <- c(legend_txt, paste("(I)", plot_name_of_I(cols_sub$guideline)))
|
||||
legend_col <- c(legend_col, colours_SIR[3])
|
||||
}
|
||||
if (any(cols_sub$cols == colours_SIR[4] & cols_sub$count > 0)) {
|
||||
if (!is_wt_nwt & any(cols_sub$cols == colours_SIR[4] & cols_sub$count > 0)) {
|
||||
legend_txt <- c(legend_txt, "(R) Resistant")
|
||||
legend_col <- c(legend_col, colours_SIR[4])
|
||||
}
|
||||
if (is_wt_nwt & any(cols_sub$cols == colours_SIR[4] & cols_sub$count > 0)) {
|
||||
legend_txt <- c(legend_txt, "(NWT) Non-wildtype")
|
||||
legend_col <- c(legend_col, colours_SIR[4])
|
||||
}
|
||||
|
||||
legend("top",
|
||||
x.intersp = 0.5,
|
||||
@@ -680,6 +701,8 @@ autoplot.mic <- function(object,
|
||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
|
||||
language <- validate_language(language)
|
||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(include_PKPD, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(breakpoint_type, allow_class = "character", is_in = AMR::clinical_breakpoints$type, has_length = 1)
|
||||
|
||||
if ("main" %in% names(list(...))) {
|
||||
title <- list(...)$main
|
||||
@@ -690,6 +713,9 @@ autoplot.mic <- function(object,
|
||||
|
||||
colours_SIR <- expand_SIR_colours(colours_SIR)
|
||||
|
||||
# wildtype/Non-wildtype
|
||||
is_wt_nwt <- identical(breakpoint_type, "ECOFF")
|
||||
|
||||
object <- as.mic(object) # make sure that currently implemented MIC levels are used
|
||||
x <- plotrange_as_table(object, expand = expand)
|
||||
cols_sub <- plot_colours_subtitle_guideline(
|
||||
@@ -708,17 +734,21 @@ autoplot.mic <- function(object,
|
||||
df <- as.data.frame(x, stringsAsFactors = TRUE)
|
||||
colnames(df) <- c("mic", "count")
|
||||
df$cols <- cols_sub$cols
|
||||
df$cols[df$cols == colours_SIR[1]] <- "(S) Susceptible"
|
||||
df$cols[df$cols == colours_SIR[1] & !is_wt_nwt] <- "(S) Susceptible"
|
||||
df$cols[df$cols == colours_SIR[1] & is_wt_nwt] <- "(WT) Wildtype"
|
||||
df$cols[df$cols == colours_SIR[2]] <- "(SDD) Susceptible dose-dependent"
|
||||
df$cols[df$cols == colours_SIR[3]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
|
||||
df$cols[df$cols == colours_SIR[4]] <- "(R) Resistant"
|
||||
df$cols[df$cols == colours_SIR[4] & !is_wt_nwt] <- "(R) Resistant"
|
||||
df$cols[df$cols == colours_SIR[4] & is_wt_nwt] <- "(NWT) Non-wildtype"
|
||||
df$cols <- factor(translate_into_language(df$cols, language = language),
|
||||
levels = translate_into_language(
|
||||
c(
|
||||
"(S) Susceptible",
|
||||
"(SDD) Susceptible dose-dependent",
|
||||
paste("(I)", plot_name_of_I(cols_sub$guideline)),
|
||||
"(R) Resistant"
|
||||
"(R) Resistant",
|
||||
"(WT) Wildtype",
|
||||
"(NWT) Non-wildtype"
|
||||
),
|
||||
language = language
|
||||
),
|
||||
@@ -733,7 +763,9 @@ autoplot.mic <- function(object,
|
||||
"(I) Susceptible, incr. exp." = colours_SIR[3],
|
||||
"(I) Intermediate" = colours_SIR[3],
|
||||
"(R) Resistant" = colours_SIR[4],
|
||||
"(NI) Non-interpretable" = "grey30"
|
||||
"(NI) Non-interpretable" = "grey30",
|
||||
"(WT) Wildtype" = colours_SIR[1],
|
||||
"(NWT) Non-wildtype" = colours_SIR[4]
|
||||
)
|
||||
names(vals) <- translate_into_language(names(vals), language = language)
|
||||
p <- p +
|
||||
@@ -797,10 +829,15 @@ plot.disk <- function(x,
|
||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
|
||||
language <- validate_language(language)
|
||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(include_PKPD, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(breakpoint_type, allow_class = "character", is_in = AMR::clinical_breakpoints$type, has_length = 1)
|
||||
|
||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||
colours_SIR <- expand_SIR_colours(colours_SIR)
|
||||
|
||||
# wildtype/Non-wildtype
|
||||
is_wt_nwt <- identical(breakpoint_type, "ECOFF")
|
||||
|
||||
x <- plotrange_as_table(x, expand = expand)
|
||||
cols_sub <- plot_colours_subtitle_guideline(
|
||||
x = x,
|
||||
@@ -832,10 +869,14 @@ plot.disk <- function(x,
|
||||
if (any(colours_SIR %in% cols_sub$cols)) {
|
||||
legend_txt <- character(0)
|
||||
legend_col <- character(0)
|
||||
if (any(cols_sub$cols == colours_SIR[4] & cols_sub$count > 0)) {
|
||||
if (!is_wt_nwt & any(cols_sub$cols == colours_SIR[4] & cols_sub$count > 0)) {
|
||||
legend_txt <- "(R) Resistant"
|
||||
legend_col <- colours_SIR[4]
|
||||
}
|
||||
if (is_wt_nwt & any(cols_sub$cols == colours_SIR[4] & cols_sub$count > 0)) {
|
||||
legend_txt <- "(NWT) Non-wildtype"
|
||||
legend_col <- colours_SIR[4]
|
||||
}
|
||||
if (any(cols_sub$cols == colours_SIR[3] & cols_sub$count > 0)) {
|
||||
legend_txt <- c(legend_txt, paste("(I)", plot_name_of_I(cols_sub$guideline)))
|
||||
legend_col <- c(legend_col, colours_SIR[3])
|
||||
@@ -844,10 +885,14 @@ plot.disk <- function(x,
|
||||
legend_txt <- c(legend_txt, "(SDD) Susceptible dose-dependent")
|
||||
legend_col <- c(legend_col, colours_SIR[2])
|
||||
}
|
||||
if (any(cols_sub$cols == colours_SIR[1] & cols_sub$count > 0)) {
|
||||
if (!is_wt_nwt & any(cols_sub$cols == colours_SIR[1] & cols_sub$count > 0)) {
|
||||
legend_txt <- c(legend_txt, "(S) Susceptible")
|
||||
legend_col <- c(legend_col, colours_SIR[1])
|
||||
}
|
||||
if (is_wt_nwt & any(cols_sub$cols == colours_SIR[1] & cols_sub$count > 0)) {
|
||||
legend_txt <- c(legend_txt, "(WT) Wildtype")
|
||||
legend_col <- c(legend_col, colours_SIR[1])
|
||||
}
|
||||
legend("top",
|
||||
x.intersp = 0.5,
|
||||
legend = translate_into_language(legend_txt, language = language),
|
||||
@@ -879,6 +924,8 @@ barplot.disk <- function(height,
|
||||
),
|
||||
language = get_AMR_locale(),
|
||||
expand = TRUE,
|
||||
include_PKPD = getOption("AMR_include_PKPD", TRUE),
|
||||
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
|
||||
...) {
|
||||
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
|
||||
meet_criteria(ylab, allow_class = "character", has_length = 1)
|
||||
@@ -889,6 +936,8 @@ barplot.disk <- function(height,
|
||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
|
||||
language <- validate_language(language)
|
||||
meet_criteria(expand, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(include_PKPD, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(breakpoint_type, allow_class = "character", is_in = AMR::clinical_breakpoints$type, has_length = 1)
|
||||
|
||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||
|
||||
@@ -901,6 +950,10 @@ barplot.disk <- function(height,
|
||||
ab = ab,
|
||||
guideline = guideline,
|
||||
colours_SIR = colours_SIR,
|
||||
language = language,
|
||||
expand = expand,
|
||||
include_PKPD = include_PKPD,
|
||||
breakpoint_type = breakpoint_type,
|
||||
...
|
||||
)
|
||||
}
|
||||
@@ -947,6 +1000,9 @@ autoplot.disk <- function(object,
|
||||
|
||||
colours_SIR <- expand_SIR_colours(colours_SIR)
|
||||
|
||||
# wildtype/Non-wildtype
|
||||
is_wt_nwt <- identical(breakpoint_type, "ECOFF")
|
||||
|
||||
x <- plotrange_as_table(object, expand = expand)
|
||||
cols_sub <- plot_colours_subtitle_guideline(
|
||||
x = x,
|
||||
@@ -964,23 +1020,26 @@ autoplot.disk <- function(object,
|
||||
df <- as.data.frame(x, stringsAsFactors = TRUE)
|
||||
colnames(df) <- c("disk", "count")
|
||||
df$cols <- cols_sub$cols
|
||||
df$cols[df$cols == colours_SIR[1]] <- "(S) Susceptible"
|
||||
df$cols[df$cols == colours_SIR[1] & !is_wt_nwt] <- "(S) Susceptible"
|
||||
df$cols[df$cols == colours_SIR[1] & is_wt_nwt] <- "(WT) Wildtype"
|
||||
df$cols[df$cols == colours_SIR[2]] <- "(SDD) Susceptible dose-dependent"
|
||||
df$cols[df$cols == colours_SIR[3]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
|
||||
df$cols[df$cols == colours_SIR[4]] <- "(R) Resistant"
|
||||
df$cols[df$cols == colours_SIR[4] & !is_wt_nwt] <- "(R) Resistant"
|
||||
df$cols[df$cols == colours_SIR[4] & is_wt_nwt] <- "(NWT) Non-wildtype"
|
||||
df$cols <- factor(translate_into_language(df$cols, language = language),
|
||||
levels = translate_into_language(
|
||||
c(
|
||||
"(S) Susceptible",
|
||||
paste("(I)", plot_name_of_I(cols_sub$guideline)),
|
||||
"(R) Resistant"
|
||||
"(R) Resistant",
|
||||
"(WT) Wildtype",
|
||||
"(NWT) Non-wildtype"
|
||||
),
|
||||
language = language
|
||||
),
|
||||
ordered = TRUE
|
||||
)
|
||||
p <- ggplot2::ggplot(df)
|
||||
|
||||
if (any(colours_SIR %in% cols_sub$cols)) {
|
||||
vals <- c(
|
||||
"(S) Susceptible" = colours_SIR[1],
|
||||
@@ -988,7 +1047,9 @@ autoplot.disk <- function(object,
|
||||
"(I) Susceptible, incr. exp." = colours_SIR[3],
|
||||
"(I) Intermediate" = colours_SIR[3],
|
||||
"(R) Resistant" = colours_SIR[4],
|
||||
"(NI) Non-interpretable" = "grey30"
|
||||
"(NI) Non-interpretable" = "grey30",
|
||||
"(WT) Wildtype" = colours_SIR[1],
|
||||
"(NWT) Non-wildtype" = colours_SIR[4]
|
||||
)
|
||||
names(vals) <- translate_into_language(names(vals), language = language)
|
||||
p <- p +
|
||||
@@ -1036,25 +1097,25 @@ plot.sir <- function(x,
|
||||
data <- as.data.frame(table(x), stringsAsFactors = FALSE)
|
||||
colnames(data) <- c("x", "n")
|
||||
data$s <- round((data$n / sum(data$n)) * 100, 1)
|
||||
data <- data[which(data$n > 0), ]
|
||||
|
||||
if (!"S" %in% data$x) {
|
||||
data <- rbind_AMR(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||
}
|
||||
if (!"SDD" %in% data$x) {
|
||||
data <- rbind_AMR(data, data.frame(x = "SDD", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||
}
|
||||
if (!"I" %in% data$x) {
|
||||
data <- rbind_AMR(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||
}
|
||||
if (!"R" %in% data$x) {
|
||||
data <- rbind_AMR(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||
}
|
||||
if (!"NI" %in% data$x) {
|
||||
data <- rbind_AMR(data, data.frame(x = "NI", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||
if (!all(data$x %in% c("WT", "NWT"), na.rm = TRUE)) {
|
||||
# # be sure to have at least S, I, and R
|
||||
if (!"S" %in% data$x) {
|
||||
data <- rbind_AMR(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||
}
|
||||
if (!"I" %in% data$x) {
|
||||
data <- rbind_AMR(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||
}
|
||||
if (!"R" %in% data$x) {
|
||||
data <- rbind_AMR(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE))
|
||||
}
|
||||
lvls <- VALID_SIR_LEVELS[VALID_SIR_LEVELS %in% c(data$x, c("S", "I", "R"))]
|
||||
} else {
|
||||
lvls <- c("WT", "NWT")
|
||||
}
|
||||
|
||||
data <- data[!(data$n == 0 & data$x %in% c("SDD", "I", "NI")), , drop = FALSE]
|
||||
data$x <- factor(data$x, levels = intersect(unique(data$x), c("S", "SDD", "I", "R", "NI")), ordered = TRUE)
|
||||
data$x <- factor(data$x, levels = lvls, ordered = TRUE)
|
||||
|
||||
ymax <- pm_if_else(max(data$s) > 95, 105, 100)
|
||||
|
||||
@@ -1069,7 +1130,7 @@ plot.sir <- function(x,
|
||||
axes = FALSE
|
||||
)
|
||||
# x axis
|
||||
axis(side = 1, at = 1:pm_n_distinct(data$x), labels = levels(data$x), lwd = 0)
|
||||
axis(side = 1, at = seq_along(lvls), labels = lvls, lwd = 0)
|
||||
# y axis, 0-100%
|
||||
axis(side = 2, at = seq(0, 100, 5))
|
||||
|
||||
@@ -1112,9 +1173,14 @@ barplot.sir <- function(height,
|
||||
main <- gsub(" +", " ", paste0(main, collapse = " "))
|
||||
|
||||
x <- table(height)
|
||||
# remove missing I, SDD, and N
|
||||
colours_SIR <- colours_SIR[!(names(x) %in% c("SDD", "I", "NI") & x == 0)]
|
||||
x <- x[!(names(x) %in% c("SDD", "I", "NI") & x == 0)]
|
||||
if (all(height %in% c("WT", "NWT"), na.rm = TRUE)) {
|
||||
colours_SIR <- colours_SIR[c(1, 4)]
|
||||
x <- x[names(x) %in% c("WT", "NWT")]
|
||||
} else {
|
||||
# remove missing I, SDD, and N
|
||||
colours_SIR <- colours_SIR[!(names(x) %in% c("SDD", "I", "NI") & x == 0)]
|
||||
x <- x[!(names(x) %in% c("SDD", "I", "NI") & x == 0)]
|
||||
}
|
||||
# plot it
|
||||
barplot(x,
|
||||
col = colours_SIR,
|
||||
@@ -1160,6 +1226,11 @@ autoplot.sir <- function(object,
|
||||
df <- as.data.frame(table(object), stringsAsFactors = TRUE)
|
||||
colnames(df) <- c("x", "n")
|
||||
df <- df[!(df$n == 0 & df$x %in% c("SDD", "I", "NI")), , drop = FALSE]
|
||||
if (all(object %in% c("WT", "NWT"), na.rm = TRUE)) {
|
||||
df <- df[which(df$x %in% c("WT", "NWT")), ]
|
||||
} else {
|
||||
df <- df[which(!df$x %in% c("WT", "NWT", "NS")), ]
|
||||
}
|
||||
ggplot2::ggplot(df) +
|
||||
ggplot2::geom_col(ggplot2::aes(x = x, y = n, fill = x)) +
|
||||
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
|
||||
@@ -1169,7 +1240,9 @@ autoplot.sir <- function(object,
|
||||
"SDD" = colours_SIR[2],
|
||||
"I" = colours_SIR[3],
|
||||
"R" = colours_SIR[4],
|
||||
"NI" = "grey30"
|
||||
"NI" = "grey30",
|
||||
"WT" = colours_SIR[1],
|
||||
"NWT" = colours_SIR[4]
|
||||
),
|
||||
limits = force
|
||||
) +
|
||||
@@ -1298,6 +1371,9 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, f
|
||||
cols[sir == "I"] <- colours_SIR[3]
|
||||
cols[sir == "R"] <- colours_SIR[4]
|
||||
cols[sir == "NI"] <- "grey30"
|
||||
cols[sir == "WT"] <- colours_SIR[1]
|
||||
cols[sir == "NWT"] <- colours_SIR[4]
|
||||
cols[sir == "NS"] <- colours_SIR[4]
|
||||
sub <- bquote(.(abname) ~ "-" ~ italic(.(moname)) ~ .(guideline_txt))
|
||||
} else {
|
||||
cols <- "#BEBEBE"
|
||||
|
||||
@@ -231,7 +231,7 @@ resistance <- function(...,
|
||||
only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = "R",
|
||||
ab_result = c("R", "NWT", "NS"),
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
only_all_tested = only_all_tested,
|
||||
@@ -249,7 +249,7 @@ susceptibility <- function(...,
|
||||
only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = c("S", "SDD", "I"),
|
||||
ab_result = c("S", "SDD", "I", "WT"),
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
only_all_tested = only_all_tested,
|
||||
@@ -269,7 +269,7 @@ sir_confidence_interval <- function(...,
|
||||
confidence_level = 0.95,
|
||||
side = "both",
|
||||
collapse = FALSE) {
|
||||
meet_criteria(ab_result, allow_class = c("character", "sir"), has_length = c(1:5), is_in = c("S", "SDD", "I", "R", "NI"))
|
||||
meet_criteria(ab_result, allow_class = c("character", "sir"), has_length = seq_along(VALID_SIR_LEVELS), is_in = VALID_SIR_LEVELS)
|
||||
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
|
||||
meet_criteria(as_percent, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(only_all_tested, allow_class = "logical", has_length = 1)
|
||||
@@ -287,7 +287,7 @@ sir_confidence_interval <- function(...,
|
||||
)
|
||||
n <- tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = c("S", "SDD", "I", "R", "NI"),
|
||||
ab_result = VALID_SIR_LEVELS,
|
||||
only_all_tested = only_all_tested,
|
||||
only_count = TRUE
|
||||
),
|
||||
@@ -341,7 +341,7 @@ proportion_R <- function(...,
|
||||
only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = "R",
|
||||
ab_result = c("R", "NWT", "NS"),
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
only_all_tested = only_all_tested,
|
||||
@@ -359,7 +359,7 @@ proportion_IR <- function(...,
|
||||
only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = c("I", "SDD", "R"),
|
||||
ab_result = c("I", "SDD", "R", "NWT", "NS"),
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
only_all_tested = only_all_tested,
|
||||
@@ -395,7 +395,7 @@ proportion_SI <- function(...,
|
||||
only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = c("S", "I", "SDD"),
|
||||
ab_result = c("S", "I", "SDD", "WT"),
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
only_all_tested = only_all_tested,
|
||||
@@ -413,7 +413,7 @@ proportion_S <- function(...,
|
||||
only_all_tested = FALSE) {
|
||||
tryCatch(
|
||||
sir_calc(...,
|
||||
ab_result = "S",
|
||||
ab_result = c("S", "WT"),
|
||||
minimum = minimum,
|
||||
as_percent = as_percent,
|
||||
only_all_tested = only_all_tested,
|
||||
|
||||
76
R/sir.R
76
R/sir.R
@@ -27,6 +27,8 @@
|
||||
# how to conduct AMR data analysis: https://amr-for-r.org #
|
||||
# ==================================================================== #
|
||||
|
||||
VALID_SIR_LEVELS <- c("S", "SDD", "I", "R", "NI", "WT", "NWT", "NS")
|
||||
|
||||
#' Interpret MIC and Disk Diffusion as SIR, or Clean Existing SIR Data
|
||||
#'
|
||||
#' @description Clean up existing SIR values, or interpret minimum inhibitory concentration (MIC) values and disk diffusion diameters according to EUCAST or CLSI. [as.sir()] transforms the input to a new class [`sir`], which is an ordered [factor] containing the levels `S`, `SDD`, `I`, `R`, `NI`.
|
||||
@@ -58,6 +60,7 @@
|
||||
#' * `>=` and `>` always return `"R"`, regardless of the breakpoint.
|
||||
#'
|
||||
#' The default `"conservative"` setting ensures cautious handling of uncertain values while preserving interpretability. This option can also be set with the package option [`AMR_capped_mic_handling`][AMR-options].
|
||||
#' @param as_wt_nwt A [logical] to return `"WT"`/`"NWT"` instead of `"S"`/`"R"`. Defaults to `TRUE` when using ECOFFs, i.e., when `breakpoint_type` is set to `"ECOFF"`.
|
||||
#' @param add_intrinsic_resistance *(only useful when using a EUCAST guideline)* a [logical] to indicate whether intrinsic antibiotic resistance must also be considered for applicable bug-drug combinations, meaning that e.g. ampicillin will always return "R" in *Klebsiella* species. Determination is based on the [intrinsic_resistant] data set, that itself is based on `r format_eucast_version_nr(3.3)`.
|
||||
#' @param substitute_missing_r_breakpoint A [logical] to indicate that a missing clinical breakpoints for R (resistant) must be substituted with R - the default is `FALSE`. Some (especially CLSI) breakpoints only have a breakpoint for S, meaning that the outcome can only be `"S"` or `NA`. Setting this to `TRUE` will convert the `NA`s in these cases to `"R"`. Can also be set with the package option [`AMR_substitute_missing_r_breakpoint`][AMR-options].
|
||||
#' @param include_screening A [logical] to indicate that clinical breakpoints for screening are allowed - the default is `FALSE`. Can also be set with the package option [`AMR_include_screening`][AMR-options].
|
||||
@@ -398,7 +401,7 @@ as_sir_structure <- function(x,
|
||||
ref_breakpoints = NULL) {
|
||||
structure(
|
||||
factor(as.character(unlist(unname(x))),
|
||||
levels = c("S", "SDD", "I", "R", "NI"),
|
||||
levels = VALID_SIR_LEVELS,
|
||||
ordered = TRUE
|
||||
),
|
||||
# TODO for #170
|
||||
@@ -454,9 +457,9 @@ is_sir_eligible <- function(x, threshold = 0.05) {
|
||||
%in% class(x))) {
|
||||
# no transformation needed
|
||||
return(FALSE)
|
||||
} else if (!all(is.na(x)) && all(x %in% c("S", "SDD", "I", "R", "NI", NA, "s", "sdd", "i", "r", "ni"))) {
|
||||
} else if (!all(is.na(x)) && all(x %in% c(VALID_SIR_LEVELS, tolower(VALID_SIR_LEVELS), NA))) {
|
||||
return(TRUE)
|
||||
} else if (!all(is.na(x)) && !any(c("S", "SDD", "I", "R", "NI") %in% gsub("([SIR])\\1+", "\\1", gsub("[^A-Z]", "", toupper(unique(x[1:10000])), perl = TRUE), perl = TRUE), na.rm = TRUE)) {
|
||||
} else if (!all(is.na(x)) && !any(VALID_SIR_LEVELS %in% gsub("([SIR])\\1+", "\\1", gsub("[^A-Z]", "", toupper(unique(x[1:10000])), perl = TRUE), perl = TRUE), na.rm = TRUE)) {
|
||||
return(FALSE)
|
||||
} else {
|
||||
x <- x[!is.na(x) & !is.null(x) & !x %in% c("", "-", "NULL")]
|
||||
@@ -486,7 +489,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 S,I,R,NI,SDD,WT,NWT,NS 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, defaults to `TRUE` only in [interactive sessions][base::interactive()].
|
||||
# extra param: warn (logical, to never throw a warning)
|
||||
as.sir.default <- function(x,
|
||||
@@ -495,13 +498,19 @@ as.sir.default <- function(x,
|
||||
R = "^(R|3)+$",
|
||||
NI = "^(N|NI|V|4)+$",
|
||||
SDD = "^(SDD|D|H|5)+$",
|
||||
WT = "^(WT|6)+$",
|
||||
NWT = "^(NWT|7)+$",
|
||||
NS = "^(NS|8)+$",
|
||||
info = interactive(),
|
||||
...) {
|
||||
meet_criteria(S, allow_class = c("character", "numeric", "integer"), has_length = 1)
|
||||
meet_criteria(I, allow_class = c("character", "numeric", "integer"), has_length = 1)
|
||||
meet_criteria(R, allow_class = c("character", "numeric", "integer"), has_length = 1)
|
||||
meet_criteria(NI, allow_class = c("character", "numeric", "integer"), has_length = 1)
|
||||
meet_criteria(SDD, allow_class = c("character", "numeric", "integer"), has_length = 1)
|
||||
meet_criteria(S, allow_class = c("character", "numeric", "integer", "factor"), has_length = 1)
|
||||
meet_criteria(I, allow_class = c("character", "numeric", "integer", "factor"), has_length = 1)
|
||||
meet_criteria(R, allow_class = c("character", "numeric", "integer", "factor"), has_length = 1)
|
||||
meet_criteria(NI, allow_class = c("character", "numeric", "integer", "factor"), has_length = 1)
|
||||
meet_criteria(SDD, allow_class = c("character", "numeric", "integer", "factor"), has_length = 1)
|
||||
meet_criteria(WT, allow_class = c("character", "numeric", "integer", "factor"), has_length = 1)
|
||||
meet_criteria(NWT, allow_class = c("character", "numeric", "integer", "factor"), has_length = 1)
|
||||
meet_criteria(NS, allow_class = c("character", "numeric", "integer", "factor"), has_length = 1)
|
||||
meet_criteria(info, allow_class = "logical", has_length = 1)
|
||||
if (inherits(x, "sir")) {
|
||||
return(as_sir_structure(x))
|
||||
@@ -516,7 +525,7 @@ as.sir.default <- function(x,
|
||||
x[x.bak == 1] <- names(lbls[lbls == 1])
|
||||
x[x.bak == 2] <- names(lbls[lbls == 2])
|
||||
x[x.bak == 3] <- names(lbls[lbls == 3])
|
||||
} else if (!all(is.na(x)) && !identical(levels(x), c("S", "SDD", "I", "R", "NI")) && !all(x %in% c("S", "SDD", "I", "R", "NI", NA))) {
|
||||
} else if (!all(is.na(x)) && !identical(levels(x), VALID_SIR_LEVELS) && !all(x %in% c(VALID_SIR_LEVELS, NA))) {
|
||||
if (all(x %unlike% "(S|I|R)", na.rm = TRUE) && !all(x %in% c(1, 2, 3, 4, 5), na.rm = TRUE)) {
|
||||
# check if they are actually MICs or disks
|
||||
if (all_valid_mics(x)) {
|
||||
@@ -557,7 +566,7 @@ as.sir.default <- function(x,
|
||||
x[x %like% "not|non"] <- "NI"
|
||||
x[x %like% "([^a-z]|^)int(er(mediate)?)?|incr.*exp"] <- "I"
|
||||
x[x %like% "dose"] <- "SDD"
|
||||
mtch <- grepl(paste0("(", S, "|", I, "|", R, "|", NI, "|", SDD, "|[A-Z]+)"), x, perl = TRUE)
|
||||
mtch <- grepl(paste0("(", S, "|", I, "|", R, "|", NI, "|", SDD, "|", WT, "|", NWT, "|", NS, "|[A-Z]+)"), x, perl = TRUE)
|
||||
x[!mtch] <- ""
|
||||
# apply regexes set by user
|
||||
x[x %like% S] <- "S"
|
||||
@@ -565,22 +574,31 @@ as.sir.default <- function(x,
|
||||
x[x %like% R] <- "R"
|
||||
x[x %like% NI] <- "NI"
|
||||
x[x %like% SDD] <- "SDD"
|
||||
x[!x %in% c("S", "SDD", "I", "R", "NI")] <- NA_character_
|
||||
x[x %like% WT] <- "WT"
|
||||
x[x %like% NWT] <- "NWT"
|
||||
x[x %like% NS] <- "NS"
|
||||
x[!x %in% VALID_SIR_LEVELS] <- NA_character_
|
||||
na_after <- length(x[is.na(x) | x == ""])
|
||||
|
||||
if (!isFALSE(list(...)$warn)) { # so as.sir(..., warn = FALSE) will never throw a warning
|
||||
if (all(x.bak %in% c(1, 2, 3, 4, 5), na.rm = TRUE) && message_not_thrown_before("as.sir", "numeric_interpretation", x, x.bak)) {
|
||||
if (all(x.bak %in% c(1:8), na.rm = TRUE) && message_not_thrown_before("as.sir", "numeric_interpretation", x, x.bak)) {
|
||||
out1 <- unique(x[x.bak == 1])
|
||||
out2 <- unique(x[x.bak == 2])
|
||||
out3 <- unique(x[x.bak == 3])
|
||||
out4 <- unique(x[x.bak == 4])
|
||||
out5 <- unique(x[x.bak == 5])
|
||||
out6 <- unique(x[x.bak == 6])
|
||||
out7 <- unique(x[x.bak == 7])
|
||||
out8 <- unique(x[x.bak == 8])
|
||||
out <- c(
|
||||
ifelse(length(out1) > 0, paste0("1 as \"", out1, "\""), NA_character_),
|
||||
ifelse(length(out2) > 0, paste0("2 as \"", out2, "\""), NA_character_),
|
||||
ifelse(length(out3) > 0, paste0("3 as \"", out3, "\""), NA_character_),
|
||||
ifelse(length(out4) > 0, paste0("4 as \"", out4, "\""), NA_character_),
|
||||
ifelse(length(out5) > 0, paste0("5 as \"", out5, "\""), NA_character_)
|
||||
ifelse(length(out5) > 0, paste0("5 as \"", out5, "\""), NA_character_),
|
||||
ifelse(length(out6) > 0, paste0("6 as \"", out6, "\""), NA_character_),
|
||||
ifelse(length(out7) > 0, paste0("7 as \"", out7, "\""), NA_character_),
|
||||
ifelse(length(out8) > 0, paste0("8 as \"", out8, "\""), NA_character_)
|
||||
)
|
||||
message_("in `as.sir()`: Interpreting input value ", vector_and(out[!is.na(out)], quotes = FALSE, sort = FALSE))
|
||||
}
|
||||
@@ -615,6 +633,7 @@ as.sir.mic <- function(x,
|
||||
guideline = getOption("AMR_guideline", "EUCAST"),
|
||||
uti = NULL,
|
||||
capped_mic_handling = getOption("AMR_capped_mic_handling", "standard"),
|
||||
as_wt_nwt = identical(breakpoint_type, "ECOFF"),
|
||||
add_intrinsic_resistance = FALSE,
|
||||
reference_data = AMR::clinical_breakpoints,
|
||||
substitute_missing_r_breakpoint = getOption("AMR_substitute_missing_r_breakpoint", FALSE),
|
||||
@@ -636,6 +655,7 @@ as.sir.mic <- function(x,
|
||||
guideline = guideline,
|
||||
uti = uti,
|
||||
capped_mic_handling = capped_mic_handling,
|
||||
as_wt_nwt = as_wt_nwt,
|
||||
add_intrinsic_resistance = add_intrinsic_resistance,
|
||||
reference_data = reference_data,
|
||||
substitute_missing_r_breakpoint = substitute_missing_r_breakpoint,
|
||||
@@ -658,6 +678,7 @@ as.sir.disk <- function(x,
|
||||
ab = deparse(substitute(x)),
|
||||
guideline = getOption("AMR_guideline", "EUCAST"),
|
||||
uti = NULL,
|
||||
as_wt_nwt = identical(breakpoint_type, "ECOFF"),
|
||||
add_intrinsic_resistance = FALSE,
|
||||
reference_data = AMR::clinical_breakpoints,
|
||||
substitute_missing_r_breakpoint = getOption("AMR_substitute_missing_r_breakpoint", FALSE),
|
||||
@@ -678,6 +699,7 @@ as.sir.disk <- function(x,
|
||||
guideline = guideline,
|
||||
uti = uti,
|
||||
capped_mic_handling = "standard", # will be ignored for non-MIC anyway
|
||||
as_wt_nwt = as_wt_nwt,
|
||||
add_intrinsic_resistance = add_intrinsic_resistance,
|
||||
reference_data = reference_data,
|
||||
substitute_missing_r_breakpoint = substitute_missing_r_breakpoint,
|
||||
@@ -702,6 +724,7 @@ as.sir.data.frame <- function(x,
|
||||
guideline = getOption("AMR_guideline", "EUCAST"),
|
||||
uti = NULL,
|
||||
capped_mic_handling = getOption("AMR_capped_mic_handling", "standard"),
|
||||
as_wt_nwt = identical(breakpoint_type, "ECOFF"),
|
||||
add_intrinsic_resistance = FALSE,
|
||||
reference_data = AMR::clinical_breakpoints,
|
||||
substitute_missing_r_breakpoint = getOption("AMR_substitute_missing_r_breakpoint", FALSE),
|
||||
@@ -720,6 +743,7 @@ as.sir.data.frame <- function(x,
|
||||
meet_criteria(guideline, allow_class = "character")
|
||||
meet_criteria(uti, allow_class = c("logical", "character"), allow_NULL = TRUE, allow_NA = TRUE)
|
||||
meet_criteria(capped_mic_handling, allow_class = "character", has_length = 1, is_in = c("none", "conservative", "standard", "lenient"))
|
||||
meet_criteria(as_wt_nwt, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(reference_data, allow_class = "data.frame")
|
||||
meet_criteria(substitute_missing_r_breakpoint, allow_class = "logical", has_length = 1)
|
||||
@@ -899,6 +923,7 @@ as.sir.data.frame <- function(x,
|
||||
guideline = guideline,
|
||||
uti = uti,
|
||||
capped_mic_handling = capped_mic_handling,
|
||||
as_wt_nwt = as_wt_nwt,
|
||||
add_intrinsic_resistance = add_intrinsic_resistance,
|
||||
reference_data = reference_data,
|
||||
substitute_missing_r_breakpoint = substitute_missing_r_breakpoint,
|
||||
@@ -926,6 +951,7 @@ as.sir.data.frame <- function(x,
|
||||
ab = ab_col,
|
||||
guideline = guideline,
|
||||
uti = uti,
|
||||
as_wt_nwt = as_wt_nwt,
|
||||
add_intrinsic_resistance = add_intrinsic_resistance,
|
||||
reference_data = reference_data,
|
||||
substitute_missing_r_breakpoint = substitute_missing_r_breakpoint,
|
||||
@@ -988,7 +1014,7 @@ as.sir.data.frame <- function(x,
|
||||
on.exit(parallel::stopCluster(cl), add = TRUE)
|
||||
parallel::clusterExport(cl, varlist = c(
|
||||
"x", "x.bak", "x_mo", "ab_cols", "types",
|
||||
"capped_mic_handling", "add_intrinsic_resistance",
|
||||
"capped_mic_handling", "as_wt_nwt", "add_intrinsic_resistance",
|
||||
"reference_data", "substitute_missing_r_breakpoint", "include_screening", "include_PKPD",
|
||||
"breakpoint_type", "guideline", "host", "uti", "info", "verbose",
|
||||
"col_mo", "AMR_env", "conserve_capped_values",
|
||||
@@ -1101,6 +1127,7 @@ as_sir_method <- function(method_short,
|
||||
guideline,
|
||||
uti,
|
||||
capped_mic_handling,
|
||||
as_wt_nwt,
|
||||
add_intrinsic_resistance,
|
||||
reference_data,
|
||||
substitute_missing_r_breakpoint,
|
||||
@@ -1123,6 +1150,7 @@ as_sir_method <- function(method_short,
|
||||
meet_criteria(guideline, allow_class = "character", has_length = c(1, length(x)), .call_depth = -2)
|
||||
meet_criteria(uti, allow_class = c("logical", "character"), has_length = c(1, length(x)), allow_NULL = TRUE, allow_NA = TRUE, .call_depth = -2)
|
||||
meet_criteria(capped_mic_handling, allow_class = "character", has_length = 1, is_in = c("none", "conservative", "standard", "lenient"), .call_depth = -2)
|
||||
meet_criteria(as_wt_nwt, allow_class = "logical", has_length = 1, .call_depth = -2)
|
||||
meet_criteria(add_intrinsic_resistance, allow_class = "logical", has_length = 1, .call_depth = -2)
|
||||
meet_criteria(reference_data, allow_class = "data.frame", .call_depth = -2)
|
||||
meet_criteria(substitute_missing_r_breakpoint, allow_class = "logical", has_length = 1, .call_depth = -2)
|
||||
@@ -1409,8 +1437,7 @@ as_sir_method <- function(method_short,
|
||||
if (is.na(mic_val)) {
|
||||
return(NA_real_)
|
||||
} else {
|
||||
# find the smallest log2 level that is >= mic_val
|
||||
log2_val <- log2_levels[which(log2_levels >= as.double(mic_val))][1]
|
||||
log2_val <- COMMON_MIC_VALUES[which(COMMON_MIC_VALUES >= as.double(mic_val))][1]
|
||||
if (!is.na(log2_val) && as.double(mic_val) != log2_val) {
|
||||
if (message_not_thrown_before("as.sir", "CLSI", "MICupscaling")) {
|
||||
warning_("Some MICs were converted to the nearest higher log2 level, following the CLSI interpretation guideline.")
|
||||
@@ -1863,6 +1890,12 @@ as_sir_method <- function(method_short,
|
||||
)
|
||||
}
|
||||
|
||||
# rewrite S/R to WT/NWT if needed
|
||||
if (isTRUE(as_wt_nwt)) {
|
||||
new_sir[new_sir == "S"] <- "WT"
|
||||
new_sir[new_sir == "R"] <- "NWT"
|
||||
}
|
||||
|
||||
# write to verbose output
|
||||
notes_current <- gsub("\n\n", "\n", trimws2(notes_current), fixed = TRUE)
|
||||
notes_current[notes_current == ""] <- NA_character_
|
||||
@@ -1977,6 +2010,9 @@ pillar_shaft.sir <- function(x, ...) {
|
||||
out[x == "I"] <- font_orange_bg(" I ")
|
||||
out[x == "R"] <- font_rose_bg(" R ")
|
||||
out[x == "NI"] <- font_grey_bg(font_black(" NI "))
|
||||
out[x == "WT"] <- font_green_bg(font_black(" WT "))
|
||||
out[x == "NWT"] <- font_rose_bg(font_black(" NWT "))
|
||||
out[x == "NS"] <- font_rose_bg(font_black(" NS "))
|
||||
}
|
||||
create_pillar_column(out, align = "left", width = 5)
|
||||
}
|
||||
@@ -2073,9 +2109,9 @@ print.sir <- function(x, ...) {
|
||||
#' @export
|
||||
as.double.sir <- function(x, ...) {
|
||||
dbls <- rep(NA_real_, length(x))
|
||||
dbls[x == "S"] <- 1
|
||||
dbls[x %in% c("SDD", "I")] <- 2
|
||||
dbls[x == "R"] <- 3
|
||||
dbls[x %in% c("S", "WT")] <- 1
|
||||
dbls[x %in% c("I", "SDD")] <- 2
|
||||
dbls[x %in% c("R", "NWT", "NS")] <- 3
|
||||
dbls
|
||||
}
|
||||
|
||||
|
||||
18
R/sir_calc.R
18
R/sir_calc.R
@@ -41,7 +41,7 @@ sir_calc <- function(...,
|
||||
as_percent = FALSE,
|
||||
only_all_tested = FALSE,
|
||||
only_count = FALSE) {
|
||||
meet_criteria(ab_result, allow_class = c("character", "numeric", "integer"), has_length = c(1:5))
|
||||
meet_criteria(ab_result, allow_class = c("character", "sir"), has_length = seq_along(VALID_SIR_LEVELS), is_in = VALID_SIR_LEVELS)
|
||||
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
|
||||
meet_criteria(as_percent, allow_class = "logical", has_length = 1)
|
||||
meet_criteria(only_all_tested, allow_class = "logical", has_length = 1)
|
||||
@@ -117,6 +117,8 @@ sir_calc <- function(...,
|
||||
print_warning <- FALSE
|
||||
|
||||
ab_result <- as.sir(ab_result)
|
||||
denominator_vals <- levels(ab_result)
|
||||
denominator_vals <- denominator_vals[denominator_vals != "NI"]
|
||||
|
||||
if (is.data.frame(x)) {
|
||||
sir_integrity_check <- character(0)
|
||||
@@ -148,7 +150,7 @@ sir_calc <- function(...,
|
||||
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(anyNA(y))))
|
||||
} else {
|
||||
# may contain NAs in any column
|
||||
other_values <- setdiff(c(NA, levels(ab_result)), ab_result)
|
||||
other_values <- setdiff(c(NA, denominator_vals), ab_result)
|
||||
if ("SDD" %in% ab_result && "SDD" %in% unlist(x_transposed) && message_not_thrown_before("sir_calc", only_count, ab_result, entire_session = TRUE)) {
|
||||
message_("Note that `", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "()` will also include dose-dependent susceptibility, 'SDD'. This note will be shown once for this session.", as_note = FALSE)
|
||||
}
|
||||
@@ -165,7 +167,7 @@ sir_calc <- function(...,
|
||||
message_("Note that `", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "()` will also include dose-dependent susceptibility, 'SDD'. This note will be shown once for this session.", as_note = FALSE)
|
||||
}
|
||||
numerator <- sum(x %in% ab_result, na.rm = TRUE)
|
||||
denominator <- sum(x %in% levels(ab_result), na.rm = TRUE)
|
||||
denominator <- sum(x %in% denominator_vals, na.rm = TRUE)
|
||||
}
|
||||
|
||||
if (print_warning == TRUE) {
|
||||
@@ -259,13 +261,13 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
|
||||
for (i in seq_len(ncol(data))) {
|
||||
# transform SIR columns
|
||||
if (is.sir(data[, i, drop = TRUE])) {
|
||||
data[, i] <- as.character(data[, i, drop = TRUE])
|
||||
data[, i] <- as.character(as.sir(data[, i, drop = TRUE]))
|
||||
data[which(data[, i, drop = TRUE] %in% c("S", "SDD", "WT")), i] <- "S"
|
||||
data[which(data[, i, drop = TRUE] %in% c("R", "NWT", "NS")), i] <- "R"
|
||||
if (isTRUE(combine_SI)) {
|
||||
if ("SDD" %in% data[, i, drop = TRUE] && message_not_thrown_before("sir_calc_df", combine_SI, entire_session = TRUE)) {
|
||||
message_("Note that `sir_calc_df()` will also count dose-dependent susceptibility, 'SDD', as 'SI' when `combine_SI = TRUE`. This note will be shown once for this session.", as_note = FALSE)
|
||||
}
|
||||
data[, i] <- gsub("(I|S|SDD)", "SI", data[, i, drop = TRUE])
|
||||
data[which(data[, i, drop = TRUE] %in% c("I", "S")), i] <- "SI"
|
||||
}
|
||||
data[which(!data[, i, drop = TRUE] %in% c("S", "SI", "I", "R")), i] <- NA_character_
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
BIN
R/sysdata.rda
BIN
R/sysdata.rda
Binary file not shown.
Reference in New Issue
Block a user