mirror of
https://github.com/msberends/AMR.git
synced 2026-03-25 04:52:25 +01:00
(v3.0.1.9040) fix MIC plotting
This commit is contained in:
@@ -1,6 +1,6 @@
|
||||
Package: AMR
|
||||
Version: 3.0.1.9039
|
||||
Date: 2026-03-23
|
||||
Version: 3.0.1.9040
|
||||
Date: 2026-03-24
|
||||
Title: Antimicrobial Resistance Data Analysis
|
||||
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
|
||||
data analysis and to work with microbial and antimicrobial properties by
|
||||
|
||||
3
NEWS.md
3
NEWS.md
@@ -1,4 +1,4 @@
|
||||
# AMR 3.0.1.9039
|
||||
# AMR 3.0.1.9040
|
||||
|
||||
### New
|
||||
* Integration with the **tidymodels** framework to allow seamless use of SIR, MIC and disk data in modelling pipelines via `recipes`
|
||||
@@ -23,6 +23,7 @@
|
||||
* Fixed a bug in `as.ab()` where certain AB codes containing "PH" or "TH" (such as `ETH`, `MTH`, `PHE`, `PHN`, `STH`, `THA`, `THI1`) would incorrectly return `NA` when combined in a vector with any untranslatable value (#245)
|
||||
* Fixed a bug in `antibiogram()` for when no antimicrobials are set
|
||||
* Fixed a bug in `as.sir()` where for numeric input the arguments `S`, `I`, and `R` would not be considered (#244)
|
||||
* Fixed a bug in plotting MIC values when `keep_operators = "all"`
|
||||
* Fixed some foreign translations of antimicrobial drugs
|
||||
* Fixed a bug for printing column names to the console when using `mutate_at(vars(...), as.mic)` (#249)
|
||||
* Fixed a bug to disregard `NI` for susceptibility proportion functions
|
||||
|
||||
2
R/ab.R
2
R/ab.R
@@ -529,7 +529,7 @@ NA_ab_ <- set_clean_class(NA_character_,
|
||||
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, ab)
|
||||
pillar_shaft.ab <- function(x, ...) {
|
||||
out <- trimws(format(x))
|
||||
out[is.na(x)] <- font_na(NA)
|
||||
out[is.na(x)] <- pillar::style_na(NA)
|
||||
|
||||
# add the names to the drugs as mouse-over!
|
||||
if (in_rstudio()) {
|
||||
|
||||
4
R/av.R
4
R/av.R
@@ -511,8 +511,8 @@ is.av <- function(x) {
|
||||
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, av)
|
||||
pillar_shaft.av <- function(x, ...) {
|
||||
out <- trimws(format(x))
|
||||
out[!is.na(x)] <- gsub("+", font_subtle("+"), out[!is.na(x)], fixed = TRUE)
|
||||
out[is.na(x)] <- font_na(NA)
|
||||
out[!is.na(x)] <- gsub("+", pillar::style_subtle("+"), out[!is.na(x)], fixed = TRUE)
|
||||
out[is.na(x)] <- pillar::style_na(NA)
|
||||
create_pillar_column(out, align = "left", min_width = 4)
|
||||
}
|
||||
|
||||
|
||||
2
R/disk.R
2
R/disk.R
@@ -162,7 +162,7 @@ is.disk <- function(x) {
|
||||
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, disk)
|
||||
pillar_shaft.disk <- function(x, ...) {
|
||||
out <- trimws(format(x))
|
||||
out[is.na(x)] <- font_na(NA)
|
||||
out[is.na(x)] <- pillar::style_na(NA)
|
||||
create_pillar_column(out, align = "right", width = 2)
|
||||
}
|
||||
|
||||
|
||||
13
R/mic.R
13
R/mic.R
@@ -322,6 +322,7 @@ NA_mic_ <- set_clean_class(factor(NA, levels = VALID_MIC_LEVELS, ordered = TRUE)
|
||||
#' @export
|
||||
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))
|
||||
mic_range <- gsub("[.]0+$", "", mic_range)
|
||||
@@ -448,16 +449,12 @@ pillar_shaft.mic <- function(x, ...) {
|
||||
crude_numbers <- as.double(x)
|
||||
operators <- gsub("[^<=>]+", "", as.character(x))
|
||||
# colourise operators
|
||||
operators[!is.na(operators) & operators != ""] <- font_silver(operators[!is.na(operators) & operators != ""], collapse = NULL)
|
||||
operators[!is.na(operators) & operators != ""] <- pillar::style_subtle(operators[!is.na(operators) & operators != ""])
|
||||
out <- trimws(paste0(operators, trimws(format(crude_numbers))))
|
||||
out[is.na(x)] <- font_na(NA)
|
||||
out[is.na(x)] <- pillar::style_na(NA)
|
||||
# make trailing zeroes less visible
|
||||
if (is_dark()) {
|
||||
fn <- font_silver
|
||||
} else {
|
||||
fn <- font_white
|
||||
}
|
||||
out[out %like% "[.]"] <- gsub("([.]?0+)$", fn("\\1"), out[out %like% "[.]"], perl = TRUE)
|
||||
out[out %like% "[.]"] <- gsub("([.]?0+)$", pillar::style_subtle("\\1"), out[out %like% "[.]"], perl = TRUE)
|
||||
|
||||
create_pillar_column(out, align = "right", width = max(nchar(font_stripstyle(out))))
|
||||
}
|
||||
|
||||
|
||||
10
R/mo.R
10
R/mo.R
@@ -648,13 +648,13 @@ pillar_shaft.mo <- function(x, ...) {
|
||||
add_MO_lookup_to_AMR_env()
|
||||
out <- trimws(format(x))
|
||||
# grey out the kingdom (part until first "_")
|
||||
out[!is.na(x)] <- gsub("^([A-Z]+_)(.*)", paste0(font_subtle("\\1"), "\\2"), out[!is.na(x)], perl = TRUE)
|
||||
out[!is.na(x)] <- gsub("^([A-Z]+_)(.*)", paste0(pillar::style_subtle("\\1"), "\\2"), out[!is.na(x)], perl = TRUE)
|
||||
# and grey out every _
|
||||
out[!is.na(x)] <- gsub("_", font_subtle("_"), out[!is.na(x)])
|
||||
out[!is.na(x)] <- gsub("_", pillar::style_subtle("_"), out[!is.na(x)])
|
||||
|
||||
# markup NA and UNKNOWN
|
||||
out[is.na(x)] <- font_na(" NA")
|
||||
out[x == "UNKNOWN"] <- font_na(" UNKNOWN")
|
||||
out[is.na(x)] <- pillar::style_na(" NA")
|
||||
out[x == "UNKNOWN"] <- pillar::style_na(" UNKNOWN")
|
||||
|
||||
# markup manual codes
|
||||
out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo] <- font_blue(out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo], collapse = NULL)
|
||||
@@ -673,7 +673,7 @@ pillar_shaft.mo <- function(x, ...) {
|
||||
(!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) {
|
||||
# markup old mo codes
|
||||
out[!x %in% all_mos] <- font_italic(
|
||||
font_na(x[!x %in% all_mos],
|
||||
pillar::style_na(x[!x %in% all_mos],
|
||||
collapse = NULL
|
||||
),
|
||||
collapse = NULL
|
||||
|
||||
39
R/plotting.R
39
R/plotting.R
@@ -266,7 +266,7 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
||||
}
|
||||
out[[aest_val]] <- log2(as.double(mics))
|
||||
} 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)
|
||||
self$mic_values_rescaled <- rescale_mic(x = as.character(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)
|
||||
@@ -280,11 +280,21 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
||||
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])
|
||||
if (length(unique(self$mic_values_levels)) > 1) {
|
||||
if (keep_operators == "all" && !all(self$mic_values_rescaled %in% self$mic_values_levels, na.rm = TRUE)) {
|
||||
self$mic_values_levels <- unique(sort(c(self$mic_values_levels, self$mic_values_rescaled)))
|
||||
|
||||
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)])
|
||||
# collision = same log2 position, but different string labels
|
||||
log_positions <- log2(as.double(self$mic_values_levels))
|
||||
dup_positions <- log_positions[duplicated(log_positions) | duplicated(log_positions, fromLast = TRUE)]
|
||||
colliding_labels <- as.character(self$mic_values_levels)[log_positions %in% dup_positions]
|
||||
self$warn_keep_all_operators <- length(unique(colliding_labels)) > 1
|
||||
} else if (keep_operators == "edges") {
|
||||
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)) {
|
||||
@@ -312,7 +322,26 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
||||
}
|
||||
scale$labels <- function(..., self) {
|
||||
if (is.null(self$mic_breaks_set)) {
|
||||
self$mic_values_levels
|
||||
if (isTRUE(self$warn_keep_all_operators)) {
|
||||
lookup <- tapply(
|
||||
as.character(self$mic_values_rescaled),
|
||||
self$mic_values_log,
|
||||
function(x) paste(unique(x), collapse = ", ")
|
||||
)
|
||||
level_log <- as.character(log2(as.double(self$mic_values_levels)))
|
||||
|
||||
if (any(grepl(", ", lookup))) {
|
||||
warning_("Using {.arg keep_operators = \"all\"} caused MIC values with different operators to share the same log2 position on the axis. These have been combined into a single label (e.g., {.val ", lookup[grepl(", ", lookup)][1], "}).", call = FALSE)
|
||||
}
|
||||
|
||||
ifelse(
|
||||
level_log %in% names(lookup),
|
||||
lookup[level_log],
|
||||
as.character(self$mic_values_levels)
|
||||
)
|
||||
} else {
|
||||
self$mic_values_levels
|
||||
}
|
||||
} else {
|
||||
breaks <- tryCatch(scale$breaks(), error = function(e) NULL)
|
||||
if (!is.null(breaks)) {
|
||||
|
||||
26
R/sir.R
26
R/sir.R
@@ -1729,7 +1729,7 @@ as_sir_method <- function(method_short,
|
||||
pm_filter(uti == FALSE)
|
||||
notes_current <- paste0(
|
||||
notes_current, "\n",
|
||||
paste0("Breakpoints for UTI ", font_bold("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, ". Use argument {.arg uti} to set which isolates are from urine. See {.help [{.fun as.sir}](AMR::as.sir)}.")
|
||||
paste0("Breakpoints for UTI ", font_bold("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, ". Use argument `uti` to set which isolates are from urine. See `?as.sir`.")
|
||||
)
|
||||
} else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && all(breakpoints_current$uti == FALSE, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteOther", mo_current, ab_current)) {
|
||||
# breakpoints for multiple body sites available
|
||||
@@ -1919,7 +1919,7 @@ as_sir_method <- function(method_short,
|
||||
host = vectorise_log_entry(breakpoints_current[, "host", drop = TRUE], length(rows)),
|
||||
input = vectorise_log_entry(as.character(input_clean), length(rows)),
|
||||
outcome = vectorise_log_entry(as.sir(new_sir), length(rows)),
|
||||
notes = cli_to_plain(font_stripstyle(notes_current)),
|
||||
notes = font_stripstyle(notes_current),
|
||||
guideline = vectorise_log_entry(guideline_current, length(rows)),
|
||||
ref_table = vectorise_log_entry(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)),
|
||||
uti = vectorise_log_entry(breakpoints_current[, "uti", drop = TRUE], length(rows)),
|
||||
@@ -2010,15 +2010,19 @@ pillar_shaft.sir <- function(x, ...) {
|
||||
if (has_colour()) {
|
||||
# colours will anyway not work when has_colour() == FALSE,
|
||||
# but then the indentation should also not be applied
|
||||
out[is.na(x)] <- font_grey(" NA")
|
||||
out[x == "S"] <- font_green_bg(" S ")
|
||||
out[x == "SDD"] <- font_green_lighter_bg(" SDD ")
|
||||
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 "))
|
||||
out[is.na(x)] <- pillar::style_subtle(" NA")
|
||||
out[x == "S"] <- font_green_bg(" S ") # has font_black internally
|
||||
out[x == "SDD"] <- font_green_lighter_bg(" SDD ") # has font_black internally
|
||||
if (getOption("AMR_guideline", "EUCAST")[1] == "EUCAST") {
|
||||
out[x == "I"] <- font_green_lighter_bg(" I ") # has font_black internally
|
||||
} else {
|
||||
out[x == "I"] <- font_orange_bg(" I ") # has font_black internally
|
||||
}
|
||||
out[x == "R"] <- font_rose_bg(" R ") # has font_black internally
|
||||
out[x == "NI"] <- font_grey_bg(font_black(" NI ", adapt = FALSE))
|
||||
out[x == "WT"] <- font_green_bg(" WT ") # has font_black internally
|
||||
out[x == "NWT"] <- font_rose_bg(" NWT ") # has font_black internally
|
||||
out[x == "NS"] <- font_rose_bg(" NS ") # has font_black internally
|
||||
}
|
||||
create_pillar_column(out, align = "left", width = 5)
|
||||
}
|
||||
|
||||
@@ -131,6 +131,8 @@ test_that("test-zzz.R", {
|
||||
"availableCores" = "parallelly",
|
||||
# pillar
|
||||
"pillar_shaft" = "pillar",
|
||||
"style_na" = "pillar",
|
||||
"style_subtle" = "pillar",
|
||||
"tbl_format_footer" = "pillar",
|
||||
"tbl_sum" = "pillar",
|
||||
"type_sum" = "pillar",
|
||||
|
||||
Reference in New Issue
Block a user