P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-09 11:01:57 +02:00
Code Releases Activity

add scale_x_mic()

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2023-12-03 01:06:00 +01:00
parent 4c11a7bd9c
commit 6f417d0ef2
9 changed files with 208 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
R/aa_helper_functions.R
View File

@ -862,12 +862,20 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
object <- tolower(object)
is_in <- tolower(is_in)
}
stop_ifnot(all(object %in% is_in, na.rm = TRUE), "argument `", obj_name, "` ",
is_in.bak <- is_in
if ("logical" %in% allow_class) {
is_in <- is_in[!is_in %in% c("TRUE", "FALSE")]
}
or_values <- vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class)))
if ("logical" %in% allow_class) {
or_values <- paste0(or_values, ", or TRUE or FALSE")
}
stop_ifnot(all(object %in% is_in.bak, na.rm = TRUE), "argument `", obj_name, "` ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"must be either ",
"must only contain values "
),
vector_or(is_in, quotes = !isTRUE(any(c("double", "numeric", "integer") %in% allow_class))),
or_values,
ifelse(allow_NA == TRUE, ", or NA", ""),
call = call_depth
)
@ -1551,7 +1559,7 @@ readRDS_AMR <- function(file, refhook = NULL) {
match <- function(x, table, ...) {
if (!is.null(AMR_env$chmatch) && inherits(x, "character") && inherits(table, "character")) {
# data.table::chmatch() is much faster than base::match() for character
AMR_env$chmatch(x, table, ...)
tryCatch(AMR_env$chmatch(x, table, ...), error = function(e) base::match(x, table, ...))
} else {
base::match(x, table, ...)
}
@ -1559,7 +1567,7 @@ match <- function(x, table, ...) {
`%in%` <- function(x, table) {
if (!is.null(AMR_env$chin) && inherits(x, "character") && inherits(table, "character")) {
# data.table::`%chin%`() is much faster than base::`%in%`() for character
AMR_env$chin(x, table)
tryCatch(AMR_env$chin(x, table), error = function(e) base::`%in%`(x, table))
} else {
base::`%in%`(x, table)
}

44
R/mic.R
View File

@ -64,10 +64,10 @@ valid_mic_levels <- c(
FUN.VALUE = character(45), operators,
function(x) paste0(x, c(10:98)[9:98 %% 2 == TRUE])
))),
c(t(vapply(
FUN.VALUE = character(17), operators,
function(x) paste0(x, sort(c(2^c(7:11), 192, 80 * c(2:12))))
)))
unique(c(t(vapply(
FUN.VALUE = character(22), operators,
function(x) paste0(x, sort(c(2^c(7:12), 192 * c(1:5), 80 * c(2:12))))
))))
)
#' Transform Input to Minimum Inhibitory Concentrations (MIC)
@ -76,6 +76,7 @@ valid_mic_levels <- c(
#' @rdname as.mic
#' @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 ... 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)))`).
#'
@ -161,15 +162,24 @@ valid_mic_levels <- c(
#' if (require("ggplot2")) {
#' autoplot(mic_data, mo = "E. coli", ab = "cipro", language = "nl") # Dutch
#' }
as.mic <- function(x, na.rm = FALSE) {
as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (is.mic(x)) {
meet_criteria(keep_operators, allow_class = c("character", "logical"), is_in = c("all", "none", "edges", FALSE, TRUE), has_length = 1)
if (isTRUE(keep_operators)) {
keep_operators <- "all"
} else if (isFALSE(keep_operators)) {
keep_operators <- "none"
}
if (is.mic(x) && (keep_operators == "all" || !any(x %like% "[>=<]", na.rm = TRUE))) {
x
} else {
x.bak <- NULL
if (is.numeric(x)) {
x <- format(x, scientific = FALSE)
x.bak <- format(x, scientific = FALSE)
# MICs never need more than 4 decimals, so:
x <- format(round(x, 4), scientific = FALSE)
} else {
x <- as.character(unlist(x))
}
@ -177,7 +187,9 @@ as.mic <- function(x, na.rm = FALSE) {
x <- x[!is.na(x)]
}
x[trimws2(x) == ""] <- NA
x.bak <- x
if (is.null(x.bak)) {
x.bak <- x
}
# comma to period
x <- gsub(",", ".", x, fixed = TRUE)
@ -238,6 +250,16 @@ as.mic <- function(x, na.rm = FALSE) {
call = FALSE
)
}
if (keep_operators == "none" && !all(is.na(x))) {
x <- gsub("[>=<]", "", x)
} else if (keep_operators == "edges" && !all(is.na(x))) {
dbls <- as.double(gsub("[>=<]", "", x))
x[dbls == min(dbls, na.rm = TRUE)] <- paste0("<=", min(dbls, na.rm = TRUE))
x[dbls == max(dbls, na.rm = TRUE)] <- paste0(">=", max(dbls, na.rm = TRUE))
keep <- x[dbls == max(dbls, na.rm = TRUE) | dbls == min(dbls, na.rm = TRUE)]
x[!x %in% keep] <- gsub("[>=<]", "", x[!x %in% keep])
}
set_clean_class(factor(x, levels = valid_mic_levels, ordered = TRUE),
new_class = c("mic", "ordered", "factor")
@ -302,8 +324,8 @@ pillar_shaft.mic <- function(x, ...) {
operators[!is.na(operators) & operators != ""] <- font_silver(operators[!is.na(operators) & operators != ""], collapse = NULL)
out <- trimws(paste0(operators, trimws(format(crude_numbers))))
out[is.na(x)] <- font_na(NA)
# maketrailing zeroes almost invisible
out[out %like% "[.]"] <- gsub("([.]?0+)$", font_white("\\1"), out[out %like% "[.]"], perl = TRUE)
# make trailing zeroes less visible
out[out %like% "[.]"] <- gsub("([.]?0+)$", font_silver("\\1"), out[out %like% "[.]"], perl = TRUE)
create_pillar_column(out, align = "right", width = max(nchar(font_stripstyle(out))))
}

104
R/plot.R
View File

@ -29,8 +29,10 @@
#' Plotting for Classes `sir`, `mic` and `disk`
#'
#' @description
#' Functions to plot classes `sir`, `mic` and `disk`, with support for base \R and `ggplot2`.
#'
#' Especially [scale_x_mic()] is a relevant wrapper to plot MIC values for `ggplot2`. It allows custom MIC ranges and to plot intermediate log2 levels for missing MIC values.
#' @param x,object values created with [as.mic()], [as.disk()] or [as.sir()] (or their `random_*` variants, such as [random_mic()])
#' @param mo any (vector of) text that can be coerced to a valid microorganism code with [as.mo()]
#' @param ab any (vector of) text that can be coerced to a valid antimicrobial drug code with [as.ab()]
@ -322,6 +324,89 @@ fortify.mic <- function(object, ...) {
)
}
#' @export
#' @inheritParams as.mic
#' @param mic_range a manual range to plot the MIC values, e.g., `mic_range = c(0.001, 32)`. Use `NA` to set no limit on one side, e.g., `mic_range = c(NA, 32)`.
#' @param drop,guide,position,na.translate arguments passed on to [ggplot2::scale_x_discrete()]
#' @rdname plot
#' @examples
#'
#' # Plotting using scale_x_mic()
#' \donttest{
#' if (require("ggplot2")) {
#' mic_plot <- ggplot(data.frame(mics = as.mic(c(0.125, "<=4", 4, 8, 32, ">=32")),
#' counts = c(1, 1, 2, 2, 3, 3)),
#' aes(mics, counts)) +
#' geom_col()
#' mic_plot +
#' labs(title = "without scale_x_mic()")
#' }
#' if (require("ggplot2")) {
#' mic_plot +
#' scale_x_mic() +
#' labs(title = "with scale_x_mic()")
#' }
#' if (require("ggplot2")) {
#' mic_plot +
#' scale_x_mic(keep_operators = "all") +
#' labs(title = "with scale_x_mic() keeping all operators")
#' }
#' if (require("ggplot2")) {
#' mic_plot +
#' scale_x_mic(mic_range = c(1, 128)) +
#' labs(title = "with scale_x_mic() using a manual range")
#' }
#' }
scale_x_mic <- function(keep_operators = "edges", mic_range = NULL, ..., drop = FALSE, guide = waiver(), position = "bottom", na.translate = TRUE) {
meet_criteria(keep_operators, allow_class = c("character", "logical"), is_in = c("all", "none", "edges", FALSE, TRUE), has_length = 1)
meet_criteria(mic_range, allow_class = c("numeric", "integer", "logical"), has_length = 2, allow_NA = TRUE, allow_NULL = TRUE)
stop_ifnot(all(mic_range %in% c(levels(as.mic(1)), NA)),
"Values in `mic_range` must be valid MIC values")
stop_ifnot_installed("ggplot2")
ggplot2::ggproto(NULL, ggplot2::ScaleDiscretePosition,
aesthetics = c("x", "xmin", "xmax", "xend"),
na.translate = na.translate,
drop = drop,
guide = guide,
position = position,
transform = function(x, keep_ops = keep_operators, mic_rng = mic_range) {
if (!is.null(mic_rng)) {
min_mic <- mic_rng[1]
max_mic <- mic_rng[2]
if (!is.na(min_mic)) {
x[x < as.mic(min_mic)] <- as.mic(min_mic)
}
if (!is.na(max_mic)) {
x[x > as.mic(max_mic)] <- as.mic(max_mic)
}
}
# transform MICs to only keep required operators
x <- as.mic(x, keep_operators = ifelse(keep_ops == "edges", "none", keep_ops))
# get range betwen min and max of MICs
expanded <- plot_prepare_table(x,
expand = TRUE,
keep_operators = ifelse(keep_ops == "edges", "none", keep_ops),
mic_range = mic_rng)
if (keep_ops == "edges") {
names(expanded)[1] <- paste0("<=", names(expanded)[1])
names(expanded)[length(expanded)] <- paste0(">=", names(expanded)[length(expanded)])
}
# MICs contain all MIC levels, so strip this to only existing levels and their intermediate values
out <- factor(names(expanded),
levels = names(expanded),
ordered = TRUE)
# and only keep the ones in the data
if (keep_ops == "edges") {
out <- out[match(x, as.double(as.mic(out, keep_operators = "all")))]
} else {
out <- out[match(x, out)]
}
out
},
...)
}
#' @method plot disk
#' @export
#' @importFrom graphics barplot axis mtext legend
@ -714,15 +799,26 @@ fortify.sir <- function(object, ...) {
)
}
plot_prepare_table <- function(x, expand) {
plot_prepare_table <- function(x, expand, keep_operators = "all", mic_range = NULL) {
x <- x[!is.na(x)]
stop_if(length(x) == 0, "no observations to plot", call = FALSE)
if (is.mic(x)) {
x <- as.mic(x, keep_operators = keep_operators)
if (expand == TRUE) {
# expand range for MIC by adding factors of 2 from lowest to highest so all MICs in between also print
valid_lvls <- levels(x)
extra_range <- max(x) / 2
while (min(extra_range) / 2 > min(x)) {
extra_range <- max(x)
min_range <- min(x)
if (!is.null(mic_range)) {
if (!is.na(mic_range[2])) {
extra_range <- as.mic(mic_range[2]) * 2
}
if (!is.na(mic_range[1])) {
min_range <- as.mic(mic_range[1])
}
}
extra_range <- extra_range / 2
while (min(extra_range) / 2 > min_range) {
extra_range <- c(min(extra_range) / 2, extra_range)
}
nms <- extra_range

BIN
R/sysdata.rda
View File

Binary file not shown.