P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-02-22 19:10:03 +01:00
Code Releases Activity
671d657fd8
AMR/R/plotting.R

1399 lines
54 KiB
R
Executable File
Raw Blame History

# ==================================================================== #
# TITLE: #
# AMR: An R Package for Working with Antimicrobial Resistance Data #
# #
# SOURCE CODE: #
# https://github.com/msberends/AMR #
# #
# PLEASE CITE THIS SOFTWARE AS: #
# Berends MS, Luz CF, Friedrich AW, et al. (2022). #
# AMR: An R Package for Working with Antimicrobial Resistance Data. #
# Journal of Statistical Software, 104(3), 1-31. #
# https://doi.org/10.18637/jss.v104.i03 #
# #
# Developed at the University of Groningen and the University Medical #
# Center Groningen in The Netherlands, in collaboration with many #
# colleagues from around the world, see our website. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# We created this package for both routine data analysis and academic #
# research and it was publicly released in the hope that it will be #
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
# #
# Visit our website for the full manual and a complete tutorial about #
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Plotting Helpers for AMR Data Analysis
#'
#' @description
#' Functions to plot classes `sir`, `mic` and `disk`, with support for base \R and `ggplot2`.
#'
#' Especially the `scale_*_mic()` functions are relevant wrappers to plot MIC values for `ggplot2`. They 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()]
#' @param guideline interpretation guideline to use - the default is the latest included EUCAST guideline, see *Details*
#' @param main,title title of the plot
#' @param xlab,ylab axis title
#' @param colours_SIR colours to use for filling in the bars, must be a vector of three values (in the order S, I and R). The default colours are colour-blind friendly.
#' @param language language to be used to translate 'Susceptible', 'Increased exposure'/'Intermediate' and 'Resistant' - the default is system language (see [get_AMR_locale()]) and can be overwritten by setting the package option [`AMR_locale`][AMR-options], e.g. `options(AMR_locale = "de")`, see [translate]. Use `language = NULL` to prevent translation.
#' @param expand a [logical] to indicate whether the range on the x axis should be expanded between the lowest and highest value. For MIC values, intermediate values will be factors of 2 starting from the highest MIC value. For disk diameters, the whole diameter range will be filled.
#' @param aesthetics aesthetics to apply the colours to - the default is "fill" but can also be (a combination of) "alpha", "colour", "fill", "linetype", "shape" or "size"
#' @param eucast_I a [logical] to indicate whether the 'I' must be interpreted as "Susceptible, under increased exposure". Will be `TRUE` if the default [AMR interpretation guideline][as.sir()] is set to EUCAST (which is the default). With `FALSE`, it will be interpreted as "Intermediate".
#' @inheritParams as.sir
#' @inheritParams ggplot_sir
#' @inheritParams proportion
#' @details
#' ### The `scale_*_mic()` Functions
#'
#' The functions [scale_x_mic()], [scale_y_mic()], [scale_colour_mic()], and [scale_fill_mic()] functions allow to plot the [mic][as.mic()] class (MIC values) on a continuous, logarithmic scale. They also allow to rescale the MIC range with an 'inside' or 'outside' range if required, and retain the signs in MIC values if desired. Missing intermediate log2 levels will be plotted too.
#'
#' ### The `scale_*_sir()` Functions
#'
#' The functions [scale_x_sir()], [scale_colour_sir()], and [scale_fill_sir()] functions allow to plot the [sir][as.sir()] class in the right order (`r paste(levels(NA_sir_), collapse = " < ")`). At default, they translate the S/I/R values to an interpretative text ("Susceptible", "Resistant", etc.) in any of the `r length(AMR:::LANGUAGES_SUPPORTED)` supported languages (use `language = NULL` to keep S/I/R). Also, except for [scale_x_sir()], they set colour-blind friendly colours to the `colour` and `fill` aesthetics.
#'
#' ### Additional `ggplot2` Functions
#'
#' This package contains more functions that extend the `ggplot2` package, to help in visualising AMR data results. All these functions are internally used by [ggplot_sir()] too.
#'
#' * [facet_sir()] creates 2d plots (at default based on S/I/R) using [ggplot2::facet_wrap()].
#' * [scale_y_percent()] transforms the y axis to a 0 to 100% range using [ggplot2::scale_y_continuous()].
#' * [scale_sir_colours()] allows to set colours to any aesthetic, even for `shape` or `linetype`.
#' * [theme_sir()] is a [ggplot2 theme][[ggplot2::theme()] with minimal distraction.
#' * [labels_sir_count()] print datalabels on the bars with percentage and number of isolates, using [ggplot2::geom_text()].
#'
#' The interpretation of "I" will be named "Increased exposure" for all EUCAST guidelines since 2019, and will be named "Intermediate" in all other cases.
#'
#' For interpreting MIC values as well as disk diffusion diameters, the default guideline is `r AMR::clinical_breakpoints$guideline[1]`, unless the package option [`AMR_guideline`][AMR-options] is set. See [as.sir()] for more information.
#' @name plot
#' @rdname plot
#' @return The `autoplot()` functions return a [`ggplot`][ggplot2::ggplot()] model that is extendible with any `ggplot2` function.
#' @param ... arguments passed on to methods
#' @examples
#' some_mic_values <- random_mic(size = 100)
#' some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
#' some_sir_values <- random_sir(50, prob_SIR = c(0.55, 0.05, 0.30))
#'
#'
#' # Plotting using base R's plot() ---------------------------------------
#'
#' plot(some_mic_values)
#' plot(some_disk_values)
#' plot(some_sir_values)
#'
#' # when providing the microorganism and antibiotic, colours will show interpretations:
#' plot(some_mic_values, mo = "S. aureus", ab = "ampicillin")
#' plot(some_disk_values, mo = "Escherichia coli", ab = "cipro")
#' plot(some_disk_values, mo = "Escherichia coli", ab = "cipro", language = "nl")
#'
#'
#' # Plotting using scale_x_mic() -----------------------------------------
#' \donttest{
#' if (require("ggplot2")) {
#' mic_plot <- ggplot(data.frame(mics = as.mic(c(0.25, "<=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, 16)) +
#' labs(title = "with scale_x_mic() using a manual 'within' range")
#' }
#' if (require("ggplot2")) {
#' mic_plot +
#' scale_x_mic(mic_range = c(0.032, 256)) +
#' labs(title = "with scale_x_mic() using a manual 'outside' range")
#' }
#'
#'
#' # Plotting using scale_y_mic() -----------------------------------------
#' some_groups <- sample(LETTERS[1:5], 20, replace = TRUE)
#'
#' if (require("ggplot2")) {
#' ggplot(data.frame(mic = some_mic_values,
#' group = some_groups),
#' aes(group, mic)) +
#' geom_boxplot() +
#' geom_violin(linetype = 2, colour = "grey", fill = NA) +
#' scale_y_mic()
#' }
#' if (require("ggplot2")) {
#' ggplot(data.frame(mic = some_mic_values,
#' group = some_groups),
#' aes(group, mic)) +
#' geom_boxplot() +
#' geom_violin(linetype = 2, colour = "grey", fill = NA) +
#' scale_y_mic(mic_range = c(NA, 2))
#' }
#'
#'
#' # Plotting using scale_fill_mic() -----------------------------------------
#' some_counts <- as.integer(runif(20, 5, 50))
#'
#' if (require("ggplot2")) {
#' ggplot(data.frame(mic = some_mic_values,
#' group = some_groups,
#' counts = some_counts),
#' aes(group, counts, fill = mic)) +
#' geom_col() +
#' scale_fill_mic(mic_range = c(0.5, 16))
#' }
#'
#' # Plotting using scale_x_sir() -----------------------------------------
#' if (require("ggplot2")) {
#' ggplot(data.frame(x = c("I", "R", "S"),
#' y = c(45,323, 573)),
#' aes(x, y)) +
#' geom_col() +
#' scale_x_sir()
#' }
#'
#'
#' # Plotting using scale_y_mic() and scale_colour_sir() ------------------
#' if (require("ggplot2")) {
#' plain <- ggplot(data.frame(mic = some_mic_values,
#' group = some_groups,
#' sir = as.sir(some_mic_values,
#' mo = "E. coli",
#' ab = "cipro")),
#' aes(x = group, y = mic, colour = sir)) +
#' theme_minimal() +
#' geom_boxplot(fill = NA, colour = "grey") +
#' geom_jitter(width = 0.25)
#'
#' plain
#' }
#' if (require("ggplot2")) {
#' # and now with our MIC and SIR scale functions:
#' plain +
#' scale_y_mic() +
#' scale_colour_sir()
#' }
#' if (require("ggplot2")) {
#' plain +
#' scale_y_mic(mic_range = c(0.005, 32), name = "Our MICs!") +
#' scale_colour_sir(language = "nl", eucast_I = FALSE,
#' name = "In Dutch!")
#' }
#'
#'
#' # Plotting using ggplot2's autoplot() ----------------------------------
#' if (require("ggplot2")) {
#' autoplot(some_mic_values)
#' }
#' if (require("ggplot2")) {
#' autoplot(some_disk_values, mo = "Escherichia coli", ab = "cipro")
#' }
#' if (require("ggplot2")) {
#' autoplot(some_sir_values)
#' }
#'
#'
#' # Plotting using scale_y_percent() -------------------------------------
#' if (require("ggplot2")) {
#' p <- ggplot(data.frame(mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
#' counts = c(1, 1, 2, 2, 3, 3)),
#' aes(mics, counts / sum(counts))) +
#' geom_col()
#' print(p)
#'
#' p2 <- p +
#' scale_y_percent() +
#' theme_sir()
#' print(p2)
#'
#' p +
#' scale_y_percent(breaks = seq(from = 0, to = 1, by = 0.1),
#' limits = c(0, 1)) +
#' theme_sir()
#' }
#' }
NULL
create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
ggplot_fn <- getExportedValue(paste0("scale_", aest, "_continuous"),
ns = asNamespace("ggplot2"))
args <- list(...)
breaks_set <- args$breaks
if (!is.null(args$limits)) {
stop_ifnot(is.null(mic_range),
"In `scale_", aest, "_mic()`, `limits` cannot be combined with `mic_range`, as they working identically. Use `mic_range` OR `limits`.", call = FALSE)
mic_range <- args$limits
}
# do not take these arguments into account, as they will be overwritten and seem to allow weird behaviour if set anyway
args[c("aesthetics", "trans", "transform", "transform_df", "breaks", "labels", "limits")] <- NULL
scale <- do.call(ggplot_fn, args)
scale$transform <- function(x) {
as.double(rescale_mic(x = as.double(x), keep_operators = keep_operators, mic_range = mic_range, as.mic = TRUE))
}
scale$transform_df <- function(self, df) {
self$`.values_rescaled` <- rescale_mic(x = as.double(df[[aest]]), keep_operators = keep_operators, mic_range = mic_range, as.mic = TRUE)
# create new breaks and labels here
lims <- range(self$`.values_rescaled`)
if (!is.na(mic_range[1]) && mic_range[1] < lims[1]) {
lims[1] <- mic_range[1]
}
if (!is.na(mic_range[2]) && mic_range[2] > lims[2]) {
lims[2] <- mic_range[2]
}
ind_min <- which(COMMON_MIC_VALUES <= lims[1])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES <= lims[1]] - lims[1]))] # Closest index where COMMON_MIC_VALUES <= lims[1]
ind_max <- which(COMMON_MIC_VALUES >= lims[2])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES >= lims[2]] - lims[2]))] # Closest index where COMMON_MIC_VALUES >= lims[2]
self$`.values_levels` <- as.mic(COMMON_MIC_VALUES[ind_min:ind_max])
if (keep_operators %in% c("edges", "all") && length(self$`.values_levels`) > 1) {
self$`.values_levels`[1] <- paste0("<=", self$`.values_levels`[1])
self$`.values_levels`[length(self$`.values_levels`)] <- paste0(">=", self$`.values_levels`[length(self$`.values_levels`)])
}
self$`.values_log` <- log2(as.double(self$`.values_rescaled`))
if (aest == "y" && "group" %in% colnames(df)) {
df$group <- as.integer(factor(df$x))
}
df[[aest]] <- self$`.values_log`
df
}
scale$breaks <- function(..., self) {
if (!is.null(breaks_set)) {
if (is.function(breaks_set)) {
breaks_set(...)
} else {
log2(as.mic(breaks_set))
}
} else {
log2(as.mic(self$`.values_levels`))
}
}
scale$labels <- function(..., self) {
if (is.null(breaks_set)) {
self$`.values_levels`
} else {
breaks <- tryCatch(scale$breaks(), error = function(e) NULL)
if (!is.null(breaks)) {
# for when breaks are set by the user
2 ^ breaks
} else {
self$`.values_levels`
}
}
}
scale$limits <- function(x, ..., self) {
rng <- range(log2(as.mic(self$`.values_levels`)))
# add 0.5 extra space
rng <- c(rng[1] - 0.5, rng[2] + 0.5)
if (!is.na(x[1]) && x[1] == 0) {
# scale that start at 0 must remain so, e.g. in case of geom_col()
rng[1] <- 0
}
rng
}
scale
}
#' @export
#' @inheritParams as.mic
#' @rdname plot
scale_x_mic <- function(keep_operators = "edges", mic_range = NULL, ...) {
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", "mic"), has_length = 2, allow_NA = TRUE, allow_NULL = TRUE)
create_scale_mic("x", keep_operators = keep_operators, mic_range = mic_range, ...)
}
#' @export
#' @inheritParams as.mic
#' @rdname plot
scale_y_mic <- function(keep_operators = "edges", mic_range = NULL, ...) {
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", "mic"), has_length = 2, allow_NA = TRUE, allow_NULL = TRUE)
create_scale_mic("y", keep_operators = keep_operators, mic_range = mic_range, ...)
}
#' @export
#' @inheritParams as.mic
#' @rdname plot
scale_colour_mic <- function(keep_operators = "edges", mic_range = NULL, ...) {
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", "mic"), has_length = 2, allow_NA = TRUE, allow_NULL = TRUE)
create_scale_mic("colour", keep_operators = keep_operators, mic_range = mic_range, ...)
}
#' @export
#' @rdname plot
#' @usage NULL
scale_color_mic <- scale_colour_mic
#' @export
#' @inheritParams as.mic
#' @rdname plot
scale_fill_mic <- function(keep_operators = "edges", mic_range = NULL, ...) {
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", "mic"), has_length = 2, allow_NA = TRUE, allow_NULL = TRUE)
create_scale_mic("fill", keep_operators = keep_operators, mic_range = mic_range, ...)
}
create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
args <- list(...)
args[c("value", "labels", "limits")] <- NULL
if (identical(aesthetics, "x")) {
ggplot_fn <- ggplot2::scale_x_discrete
} else {
ggplot_fn <- ggplot2::scale_discrete_manual
args <- c(args,
list(aesthetics = aesthetics,
values = c(S = colours_SIR[1],
SDD = colours_SIR[2],
I = colours_SIR[2],
R = colours_SIR[3],
NI = "grey30")))
}
scale <- do.call(ggplot_fn, args)
scale$labels <- function(x) {
stop_ifnot(all(x %in% c(levels(NA_sir_), NA)),
"Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see `?as.sir`.",
call = FALSE)
x <- as.character(as.sir(x))
if (!is.null(language)) {
x[x == "S"] <- "(S) Susceptible"
x[x == "SDD"] <- "(SDD) Susceptible dose-dependent"
if (eucast_I == TRUE) {
x[x == "I"] <- "(I) Susceptible, incr. exp."
} else {
x[x == "I"] <- "(I) Intermediate"
}
x[x == "R"] <- "(R) Resistant"
x[x == "NI"] <- "(NI) Not interpretable"
x <- translate_AMR(x, language = language)
}
x
}
scale$limits <- function(x, ...) {
# force SIR in the right order
as.character(sort(factor(x, levels = levels(NA_sir_))))
}
scale
}
#' @rdname plot
#' @export
scale_x_sir <- function(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
eucast_I = getOption("AMR_guideline", "EUCAST") == "EUCAST",
...) {
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language)
meet_criteria(eucast_I, allow_class = "logical", has_length = 1)
create_scale_sir(aesthetics = "x", colours_SIR = colours_SIR, language = language, eucast_I = eucast_I)
}
#' @rdname plot
#' @export
scale_colour_sir <- function(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
eucast_I = getOption("AMR_guideline", "EUCAST") == "EUCAST",
...) {
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language)
meet_criteria(eucast_I, allow_class = "logical", has_length = 1)
args <- list(...)
args$colours_SIR <- colours_SIR
args$language <- language
args$eucast_I <- eucast_I
if (is.null(args$aesthetics)) {
args$aesthetics <- "colour"
}
do.call(create_scale_sir, args)
}
#' @export
#' @rdname plot
#' @usage NULL
scale_color_sir <- scale_colour_sir
#' @rdname plot
#' @export
scale_fill_sir <- function(colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
eucast_I = getOption("AMR_guideline", "EUCAST") == "EUCAST",
...) {
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language)
meet_criteria(eucast_I, allow_class = "logical", has_length = 1)
args <- list(...)
args$colours_SIR <- colours_SIR
args$language <- language
args$eucast_I <- eucast_I
if (is.null(args$aesthetics)) {
args$aesthetics <- "fill"
}
do.call(create_scale_sir, args)
}
#' @method plot mic
#' @importFrom graphics barplot axis mtext legend
#' @export
#' @rdname plot
plot.mic <- function(x,
mo = NULL,
ab = NULL,
guideline = getOption("AMR_guideline", "EUCAST"),
main = deparse(substitute(x)),
ylab = translate_AMR("Frequency", language = language),
xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
...) {
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
x <- as.mic(x) # make sure that currently implemented MIC levels are used
if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
x <- plotrange_as_table(x, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_SIR = colours_SIR,
fn = as.mic,
language = language,
method = "MIC",
include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type,
...
)
barplot(x,
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE
)
axis(2, seq(0, max(x)))
if (!is.null(cols_sub$sub)) {
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
}
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)) {
legend_txt <- c(legend_txt, "(S) Susceptible")
legend_col <- colours_SIR[1]
}
if (any(cols_sub$cols == colours_SIR[2] & 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[2])
}
if (any(cols_sub$cols == colours_SIR[3] & cols_sub$count > 0)) {
legend_txt <- c(legend_txt, "(R) Resistant")
legend_col <- c(legend_col, colours_SIR[3])
}
legend("top",
x.intersp = 0.5,
legend = translate_into_language(legend_txt, language = language),
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55"
)
}
}
#' @method barplot mic
#' @export
#' @noRd
barplot.mic <- function(height,
mo = NULL,
ab = NULL,
guideline = getOption("AMR_guideline", "EUCAST"),
main = deparse(substitute(height)),
ylab = translate_AMR("Frequency", language = language),
xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
...) {
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
main <- gsub(" +", " ", paste0(main, collapse = " "))
height <- as.mic(height) # make sure that currently implemented MIC levels are used
plot(
x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_SIR = colours_SIR,
...
)
}
#' @method autoplot mic
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
autoplot.mic <- function(object,
mo = NULL,
ab = NULL,
guideline = getOption("AMR_guideline", "EUCAST"),
title = deparse(substitute(object)),
ylab = translate_AMR("Frequency", language = language),
xlab = translate_AMR("Minimum Inhibitory Concentration (mg/L)", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(title, allow_class = "character", allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
if ("main" %in% names(list(...))) {
title <- list(...)$main
}
if (!is.null(title)) {
title <- gsub(" +", " ", paste0(title, collapse = " "))
}
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(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_SIR = colours_SIR,
fn = as.mic,
language = language,
method = "MIC",
include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type,
...
)
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[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
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"
),
language = language
),
ordered = TRUE
)
p <- ggplot2::ggplot(df)
if (any(colours_SIR %in% cols_sub$cols)) {
vals <- c(
"(S) Susceptible" = colours_SIR[1],
"(SDD) Susceptible dose-dependent" = colours_SIR[2],
"(I) Susceptible, incr. exp." = colours_SIR[2],
"(I) Intermediate" = colours_SIR[2],
"(R) Resistant" = colours_SIR[3]
)
names(vals) <- translate_into_language(names(vals), language = language)
p <- p +
ggplot2::geom_col(ggplot2::aes(x = mic, y = count, fill = cols)) +
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
ggplot2::scale_fill_manual(
values = vals,
name = NULL,
limits = force
)
} else {
p <- p +
ggplot2::geom_col(ggplot2::aes(x = mic, y = count))
}
p +
ggplot2::labs(title = title, x = xlab, y = ylab, subtitle = cols_sub$sub)
}
#' @method fortify mic
#' @noRd
# will be exported using s3_register() in R/zzz.R
fortify.mic <- function(object, ...) {
object <- as.mic(object) # make sure that currently implemented MIC levels are used
stats::setNames(
as.data.frame(plotrange_as_table(object, expand = FALSE)),
c("x", "y")
)
}
#' @method plot disk
#' @export
#' @importFrom graphics barplot axis mtext legend
#' @rdname plot
plot.disk <- function(x,
main = deparse(substitute(x)),
ylab = translate_AMR("Frequency", language = language),
xlab = translate_AMR("Disk diffusion diameter (mm)", language = language),
mo = NULL,
ab = NULL,
guideline = getOption("AMR_guideline", "EUCAST"),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
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)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
x <- plotrange_as_table(x, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_SIR = colours_SIR,
fn = as.disk,
language = language,
method = "disk",
include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type,
...
)
barplot(x,
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE
)
axis(2, seq(0, max(x)))
if (!is.null(cols_sub$sub)) {
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
}
if (any(colours_SIR %in% cols_sub$cols)) {
legend_txt <- character(0)
legend_col <- character(0)
if (any(cols_sub$cols == colours_SIR[3] & cols_sub$count > 0)) {
legend_txt <- "(R) Resistant"
legend_col <- colours_SIR[3]
}
if (any(cols_sub$cols == colours_SIR[2] & 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[2])
}
if (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])
}
legend("top",
x.intersp = 0.5,
legend = translate_into_language(legend_txt, language = language),
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55"
)
}
}
#' @method barplot disk
#' @export
#' @noRd
barplot.disk <- function(height,
main = deparse(substitute(height)),
ylab = translate_AMR("Frequency", language = language),
xlab = translate_AMR("Disk diffusion diameter (mm)", language = language),
mo = NULL,
ab = NULL,
guideline = getOption("AMR_guideline", "EUCAST"),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
...) {
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
main <- gsub(" +", " ", paste0(main, collapse = " "))
plot(
x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_SIR = colours_SIR,
...
)
}
#' @method autoplot disk
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
autoplot.disk <- function(object,
mo = NULL,
ab = NULL,
title = deparse(substitute(object)),
ylab = translate_AMR("Frequency", language = language),
xlab = translate_AMR("Disk diffusion diameter (mm)", language = language),
guideline = getOption("AMR_guideline", "EUCAST"),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"),
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(title, allow_class = "character", allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(mo, allow_class = c("mo", "character"), allow_NULL = TRUE)
meet_criteria(ab, allow_class = c("ab", "character"), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
if ("main" %in% names(list(...))) {
title <- list(...)$main
}
if (!is.null(title)) {
title <- gsub(" +", " ", paste0(title, collapse = " "))
}
x <- plotrange_as_table(object, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_SIR = colours_SIR,
fn = as.disk,
language = language,
method = "disk",
include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type,
...
)
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[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
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"
),
language = language
),
ordered = TRUE
)
p <- ggplot2::ggplot(df)
if (any(colours_SIR %in% cols_sub$cols)) {
vals <- c(
"(S) Susceptible" = colours_SIR[1],
"(SDD) Susceptible dose-dependent" = colours_SIR[2],
"(I) Susceptible, incr. exp." = colours_SIR[2],
"(I) Intermediate" = colours_SIR[2],
"(R) Resistant" = colours_SIR[3]
)
names(vals) <- translate_into_language(names(vals), language = language)
p <- p +
ggplot2::geom_col(ggplot2::aes(x = disk, y = count, fill = cols)) +
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
ggplot2::scale_fill_manual(
values = vals,
name = NULL,
limits = force
)
} else {
p <- p +
ggplot2::geom_col(ggplot2::aes(x = disk, y = count))
}
p +
ggplot2::labs(title = title, x = xlab, y = ylab, subtitle = cols_sub$sub)
}
#' @method fortify disk
#' @noRd
# will be exported using s3_register() in R/zzz.R
fortify.disk <- function(object, ...) {
stats::setNames(
as.data.frame(plotrange_as_table(object, expand = FALSE)),
c("x", "y")
)
}
#' @method plot sir
#' @export
#' @importFrom graphics plot text axis
#' @rdname plot
plot.sir <- function(x,
ylab = translate_AMR("Percentage", language = language),
xlab = translate_AMR("Antimicrobial Interpretation", language = language),
main = deparse(substitute(x)),
language = get_AMR_locale(),
...) {
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
data <- as.data.frame(table(x), stringsAsFactors = FALSE)
colnames(data) <- c("x", "n")
data$s <- round((data$n / sum(data$n)) * 100, 1)
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))
}
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)
ymax <- pm_if_else(max(data$s) > 95, 105, 100)
plot(
x = data$x,
y = data$s,
lwd = 2,
ylim = c(0, ymax),
ylab = ylab,
xlab = xlab,
main = main,
axes = FALSE
)
# x axis
axis(side = 1, at = 1:pm_n_distinct(data$x), labels = levels(data$x), lwd = 0)
# y axis, 0-100%
axis(side = 2, at = seq(0, 100, 5))
text(
x = data$x,
y = data$s + 4,
labels = paste0(data$s, "% (n = ", data$n, ")")
)
}
#' @method barplot sir
#' @importFrom graphics barplot axis
#' @export
#' @noRd
barplot.sir <- function(height,
main = deparse(substitute(height)),
xlab = translate_AMR("Antimicrobial Interpretation", language = language),
ylab = translate_AMR("Frequency", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
...) {
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
language <- validate_language(language)
meet_criteria(expand, allow_class = "logical", has_length = 1)
if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3)
}
# add SDD and N to colours
colours_SIR <- c(colours_SIR[1:2], colours_SIR[2], colours_SIR[3], "#888888")
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)]
# plot it
barplot(x,
col = colours_SIR,
xlab = xlab,
main = main,
ylab = ylab,
axes = FALSE
)
axis(2, seq(0, max(x)))
}
#' @method autoplot sir
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
autoplot.sir <- function(object,
title = deparse(substitute(object)),
xlab = translate_AMR("Antimicrobial Interpretation", language = language),
ylab = translate_AMR("Frequency", language = language),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(title, allow_class = "character", allow_NULL = TRUE)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
if ("main" %in% names(list(...))) {
title <- list(...)$main
}
if (!is.null(title)) {
title <- gsub(" +", " ", paste0(title, collapse = " "))
}
if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3)
}
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]
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)
ggplot2::scale_fill_manual(
values = c(
"S" = colours_SIR[1],
"SDD" = colours_SIR[2],
"I" = colours_SIR[2],
"R" = colours_SIR[3],
"NI" = "#888888"
),
limits = force
) +
ggplot2::labs(title = title, x = xlab, y = ylab) +
ggplot2::theme(legend.position = "none")
}
#' @method fortify sir
#' @noRd
# will be exported using s3_register() in R/zzz.R
fortify.sir <- function(object, ...) {
stats::setNames(
as.data.frame(table(object)),
c("x", "y")
)
}
plotrange_as_table <- function(x, expand, keep_operators = "all", mic_range = NULL) {
x <- x[!is.na(x)]
if (is.mic(x)) {
x <- as.mic(x, keep_operators = keep_operators)
if (expand == TRUE) {
# expand range for MIC by adding common intermediate factors levels
if (!is.null(mic_range) && !all(is.na(mic_range))) {
# base on mic_range
`%na_or%` <- function(x, y) if (is.na(x)) y else x
extra_range <- COMMON_MIC_VALUES[COMMON_MIC_VALUES >= (mic_range[1] %na_or% min(x, na.rm = TRUE)) & COMMON_MIC_VALUES <= (mic_range[2] %na_or% max(x, na.rm = TRUE))]
} else {
# base on x
extra_range <- COMMON_MIC_VALUES[COMMON_MIC_VALUES > min(x, na.rm = TRUE) & COMMON_MIC_VALUES < max(x, na.rm = TRUE)]
}
# remove the ones that are in 25% range of user values
extra_range <- extra_range[!vapply(FUN.VALUE = logical(1), extra_range, function(r) any(abs(r - x) / x < 0.25, na.rm = TRUE))]
nms <- extra_range
extra_range <- rep(0, length(extra_range))
names(extra_range) <- nms
x <- table(droplevels(x, as.mic = FALSE))
extra_range <- extra_range[!names(extra_range) %in% names(x) & names(extra_range) %in% VALID_MIC_LEVELS]
x <- as.table(c(x, extra_range))
} else {
x <- table(droplevels(x, as.mic = FALSE))
}
x <- x[order(as.double(as.mic(names(x))))]
} else if (is.disk(x)) {
if (expand == TRUE) {
# expand range for disks from lowest to highest so all mm's in between also print
extra_range <- rep(0, max(x) - min(x) - 1)
names(extra_range) <- seq(min(x) + 1, max(x) - 1)
x <- table(x)
extra_range <- extra_range[!names(extra_range) %in% names(x)]
x <- as.table(c(x, extra_range))
} else {
x <- table(x)
}
x <- x[order(as.double(names(x)))]
}
as.table(x)
}
ggplot2_get_from_dots <- function(arg, default, ...) {
dots <- list(...)
if (!arg %in% names(dots)) {
default
} else {
dots[[arg]]
}
}
plot_name_of_I <- function(guideline) {
if (guideline %unlike% "CLSI" && as.double(gsub("[^0-9]+", "", guideline)) >= 2019) {
# interpretation since 2019
"Susceptible, incr. exp."
} else {
# interpretation until 2019
"Intermediate"
}
}
plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, fn, language, method, breakpoint_type, include_PKPD, ...) {
stop_if(length(x) == 0, "no observations to plot", call = FALSE)
guideline <- get_guideline(guideline, AMR::clinical_breakpoints)
# store previous interpretations to backup
sir_history <- AMR_env$sir_interpretation_history
# and clear previous interpretations
AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE]
if (!is.null(mo) && !is.null(ab)) {
# interpret and give colour based on MIC values
mo <- as.mo(mo)
moname <- mo_name(mo, language = language)
ab <- as.ab(ab)
abname <- ab_name(ab, language = language)
sir <- suppressWarnings(suppressMessages(as.sir(fn(names(x)), mo = mo, ab = ab, guideline = guideline, include_screening = FALSE, include_PKPD = include_PKPD, breakpoint_type = breakpoint_type, ...)))
guideline_txt <- guideline
if (all(is.na(sir))) {
sir_screening <- suppressWarnings(suppressMessages(as.sir(fn(names(x)), mo = mo, ab = ab, guideline = guideline, include_screening = TRUE, include_PKPD = include_PKPD, breakpoint_type = breakpoint_type, ...)))
if (!all(is.na(sir_screening))) {
message_(
"Only ", guideline, " ", method, " interpretations found for ",
ab_name(ab, language = NULL, tolower = TRUE), " in ", italicise(moname), " for screening"
)
sir <- sir_screening
guideline_txt <- paste0("(Screen, ", guideline_txt, ")")
} else {
message_(
"No ", guideline, " ", method, " interpretations found for ",
ab_name(ab, language = NULL, tolower = TRUE), " in ", italicise(moname)
)
guideline_txt <- paste0("(", guideline_txt, ")")
}
} else {
if (isTRUE(list(...)$uti)) {
guideline_txt <- paste("UTIs,", guideline_txt)
}
ref_tbl <- paste0('"', unique(AMR_env$sir_interpretation_history$ref_table), '"', collapse = "/")
guideline_txt <- paste0("(", guideline_txt, ": ", ref_tbl, ")")
}
cols <- character(length = length(sir))
cols[is.na(sir)] <- "#BEBEBE"
cols[sir == "S"] <- colours_SIR[1]
cols[sir == "SDD"] <- colours_SIR[2]
cols[sir == "I"] <- colours_SIR[2]
cols[sir == "R"] <- colours_SIR[3]
cols[sir == "NI"] <- "#888888"
sub <- bquote(.(abname) ~ "-" ~ italic(.(moname)) ~ .(guideline_txt))
} else {
cols <- "#BEBEBE"
sub <- NULL
}
# restore previous interpretations to backup
AMR_env$sir_interpretation_history <- sir_history
list(cols = cols, count = as.double(x), sub = sub, guideline = guideline)
}
#' @rdname plot
#' @export
facet_sir <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
facet <- facet[1]
stop_ifnot_installed("ggplot2")
meet_criteria(facet, allow_class = "character", has_length = 1)
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
facet_deparse <- deparse(substitute(facet))
if (facet_deparse != "facet") {
facet <- facet_deparse
}
if (facet %like% '".*"') {
facet <- substr(facet, 2, nchar(facet) - 1)
}
if (tolower(facet) %in% tolower(c("SIR", "sir", "interpretations", "result"))) {
facet <- "interpretation"
} else if (tolower(facet) %in% tolower(c("ab", "abx", "antibiotics"))) {
facet <- "antibiotic"
}
ggplot2::facet_wrap(facets = facet, scales = "free_x", nrow = nrow)
}
#' @rdname plot
#' @export
scale_y_percent <- function(breaks = function(x) seq(0, max(x, na.rm = TRUE), 0.1), limits = c(0, NA)) {
stop_ifnot_installed("ggplot2")
meet_criteria(breaks, allow_class = c("numeric", "integer", "function"))
meet_criteria(limits, allow_class = c("numeric", "integer"), has_length = 2, allow_NULL = TRUE, allow_NA = TRUE)
if (!is.function(breaks) && all(breaks[breaks != 0] > 1)) {
breaks <- breaks / 100
}
ggplot2::scale_y_continuous(
breaks = breaks,
labels = if (is.function(breaks)) function(x) percentage(breaks(x)) else percentage(breaks),
limits = limits
)
}
#' @rdname plot
#' @export
scale_sir_colours <- function(...,
aesthetics,
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B")) {
stop_ifnot_installed("ggplot2")
meet_criteria(aesthetics, allow_class = "character", is_in = c("alpha", "colour", "color", "fill", "linetype", "shape", "size"))
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
if ("fill" %in% aesthetics && message_not_thrown_before("scale_sir_colours", "fill", entire_session = TRUE)) {
warning_("Using `scale_sir_colours()` for the `fill` aesthetic has been superseded by `scale_fill_sir()`, please use that instead. This warning will be shown once per session.")
}
if (any(c("colour", "color") %in% aesthetics) && message_not_thrown_before("scale_sir_colours", "colour", entire_session = TRUE)) {
warning_("Using `scale_sir_colours()` for the `colour` aesthetic has been superseded by `scale_colour_sir()`, please use that instead. This warning will be shown once per session.")
}
if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3)
}
# behaviour until AMR pkg v1.5.0 and also when coming from ggplot_sir()
if ("colours" %in% names(list(...))) {
original_cols <- c(
S = colours_SIR[1],
SI = colours_SIR[1],
I = colours_SIR[2],
IR = colours_SIR[3],
R = colours_SIR[3]
)
colours <- replace(original_cols, names(list(...)$colours), list(...)$colours)
# limits = force is needed in ggplot2 3.3.4 and 3.3.5, see here;
# https://github.com/tidyverse/ggplot2/issues/4511#issuecomment-866185530
return(ggplot2::scale_fill_manual(values = colours, limits = force, aesthetics = aesthetics))
}
if (identical(unlist(list(...)), FALSE)) {
return(invisible())
}
names_susceptible <- c(
"S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible"),
"replacement",
drop = TRUE
])
)
names_incr_exposure <- c(
"I", "intermediate", "increased exposure", "incr. exposure",
"Increased exposure", "Incr. exposure", "Susceptible, incr. exp.",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Intermediate"),
"replacement",
drop = TRUE
]),
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible, incr. exp."),
"replacement",
drop = TRUE
])
)
names_resistant <- c(
"R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Resistant"),
"replacement",
drop = TRUE
])
)
susceptible <- rep(colours_SIR[1], length(names_susceptible))
names(susceptible) <- names_susceptible
incr_exposure <- rep(colours_SIR[2], length(names_incr_exposure))
names(incr_exposure) <- names_incr_exposure
resistant <- rep(colours_SIR[3], length(names_resistant))
names(resistant) <- names_resistant
original_cols <- c(susceptible, incr_exposure, resistant)
dots <- c(...)
# replace S, I, R as colours: scale_sir_colours(mydatavalue = "S")
dots[dots == "S"] <- colours_SIR[1]
dots[dots == "I"] <- colours_SIR[2]
dots[dots == "R"] <- colours_SIR[3]
cols <- replace(original_cols, names(dots), dots)
# limits = force is needed in ggplot2 3.3.4 and 3.3.5, see here;
# https://github.com/tidyverse/ggplot2/issues/4511#issuecomment-866185530
ggplot2::scale_discrete_manual(aesthetics = aesthetics, values = cols, limits = force)
}
#' @export
#' @rdname plot
#' @usage NULL
scale_sir_colors <- scale_sir_colours
#' @rdname plot
#' @export
theme_sir <- function() {
stop_ifnot_installed("ggplot2")
ggplot2::theme_minimal(base_size = 10) +
ggplot2::theme(
panel.grid.major.x = ggplot2::element_blank(),
panel.grid.minor = ggplot2::element_blank(),
panel.grid.major.y = ggplot2::element_line(colour = "grey75"),
# center title and subtitle
plot.title = ggplot2::element_text(hjust = 0.5),
plot.subtitle = ggplot2::element_text(hjust = 0.5)
)
}
#' @rdname plot
#' @export
labels_sir_count <- function(position = NULL,
x = "antibiotic",
translate_ab = "name",
minimum = 30,
language = get_AMR_locale(),
combine_SI = TRUE,
datalabels.size = 3,
datalabels.colour = "grey15") {
stop_ifnot_installed("ggplot2")
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
meet_criteria(x, allow_class = "character", has_length = 1)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
language <- validate_language(language)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
if (is.null(position)) {
position <- "fill"
}
if (identical(position, "fill")) {
position <- ggplot2::position_fill(vjust = 0.5, reverse = TRUE)
}
x_name <- x
ggplot2::geom_text(
mapping = utils::modifyList(ggplot2::aes(), list(label = str2lang("lbl"), x = str2lang(x), y = str2lang("value"))),
position = position,
inherit.aes = FALSE,
size = datalabels.size,
colour = datalabels.colour,
lineheight = 0.75,
data = function(x) {
transformed <- sir_df(
data = x,
translate_ab = translate_ab,
combine_SI = combine_SI,
minimum = minimum,
language = language
)
transformed$gr <- transformed[, x_name, drop = TRUE]
transformed %pm>%
pm_group_by(gr) %pm>%
pm_mutate(lbl = paste0("n=", isolates)) %pm>%
pm_ungroup() %pm>%
pm_select(-gr)
}
)
}
View Git Blame Copy Permalink