P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-08 22:41:52 +02:00
Code Releases Activity

styled, unit test fix

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2022-08-28 10:31:50 +02:00
parent 4cb1db4554
commit 4d050aef7c
147 changed files with 10897 additions and 8169 deletions
Download Patch File Download Diff File Expand all files Collapse all files

420
R/plot.R
View File

@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@ -24,7 +24,7 @@
# ==================================================================== #
#' Plotting for Classes `rsi`, `mic` and `disk`
#'
#'
#' Functions to plot classes `rsi`, `mic` and `disk`, with support for base \R and `ggplot2`.
#' @param x,object values created with [as.mic()], [as.disk()] or [as.rsi()] (or their `random_*` variants, such as [random_mic()])
@ -38,30 +38,30 @@
#' @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.
#' @details
#' 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, supported guidelines to be used as input for the `guideline` argument are: `r vector_and(AMR::rsi_translation$guideline, quotes = TRUE, reverse = TRUE)`.
#'
#'
#' Simply using `"CLSI"` or `"EUCAST"` as input will automatically select the latest version of that guideline.
#' @name plot
#' @rdname plot
#' @return The `autoplot()` functions return a [`ggplot`][ggplot2::ggplot()] model that is extendible with any `ggplot2` function.
#'
#'
#' The `fortify()` functions return a [data.frame] as an extension for usage in the [ggplot2::ggplot()] function.
#' @param ... arguments passed on to methods
#' @examples
#' @examples
#' some_mic_values <- random_mic(size = 100)
#' some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
#' some_rsi_values <- random_rsi(50, prob_RSI = c(0.30, 0.55, 0.05))
#'
#'
#' plot(some_mic_values)
#' plot(some_disk_values)
#' plot(some_rsi_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 = "uk")
#'
#'
#' \donttest{
#' if (require("ggplot2")) {
#' autoplot(some_mic_values)
@ -95,7 +95,7 @@ plot.mic <- function(x,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@ -103,34 +103,37 @@ plot.mic <- function(x,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
x <- plot_prepare_table(x, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
language = language,
...)
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
language = language,
...
)
barplot(x,
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_RSI %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE)
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_RSI %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_RSI %in% cols_sub$cols)) {
legend_txt <- character(0)
legend_col <- character(0)
@ -146,16 +149,17 @@ plot.mic <- function(x,
legend_txt <- c(legend_txt, "Resistant")
legend_col <- c(legend_col, colours_RSI[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")
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"
)
}
}
@ -182,7 +186,7 @@ barplot.mic <- function(height,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@ -190,18 +194,20 @@ barplot.mic <- function(height,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
plot(x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...)
plot(
x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...
)
}
#' @method autoplot mic
@ -228,7 +234,7 @@ autoplot.mic <- function(object,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@ -236,23 +242,25 @@ autoplot.mic <- function(object,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if ("main" %in% names(list(...))) {
title <- list(...)$main
}
if (!is.null(title)) {
title <- gsub(" +", " ", paste0(title, collapse = " "))
}
x <- plot_prepare_table(object, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
language = language,
...)
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
language = language,
...
)
df <- as.data.frame(x, stringsAsFactors = TRUE)
colnames(df) <- c("mic", "count")
df$cols <- cols_sub$cols
@ -260,28 +268,34 @@ autoplot.mic <- function(object,
df$cols[df$cols == colours_RSI[2]] <- "Susceptible"
df$cols[df$cols == colours_RSI[3]] <- plot_name_of_I(cols_sub$guideline)
df$cols <- factor(translate_into_language(df$cols, language = language),
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
language = language),
ordered = TRUE)
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
language = language
),
ordered = TRUE
)
p <- ggplot2::ggplot(df)
if (any(colours_RSI %in% cols_sub$cols)) {
vals <- c("Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3])
vals <- c(
"Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3]
)
names(vals) <- translate_into_language(names(vals), language = language)
p <- p +
ggplot2::geom_col(ggplot2::aes(x = mic, y = count, fill = cols)) +
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)
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)
}
@ -290,8 +304,10 @@ autoplot.mic <- function(object,
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
fortify.mic <- function(object, ...) {
stats::setNames(as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y"))
stats::setNames(
as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y")
)
}
#' @method plot disk
@ -318,7 +334,7 @@ plot.disk <- function(x,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@ -326,35 +342,38 @@ plot.disk <- function(x,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
x <- plot_prepare_table(x, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
language = language,
...)
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
language = language,
...
)
barplot(x,
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_RSI %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE)
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_RSI %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_RSI %in% cols_sub$cols)) {
legend_txt <- character(0)
legend_col <- character(0)
@ -370,15 +389,16 @@ plot.disk <- function(x,
legend_txt <- c(legend_txt, "Susceptible")
legend_col <- c(legend_col, colours_RSI[2])
}
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")
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"
)
}
}
@ -405,7 +425,7 @@ barplot.disk <- function(height,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@ -413,18 +433,20 @@ barplot.disk <- function(height,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
plot(x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...)
plot(
x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...
)
}
#' @method autoplot disk
@ -451,7 +473,7 @@ autoplot.disk <- function(object,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@ -459,53 +481,61 @@ autoplot.disk <- function(object,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if ("main" %in% names(list(...))) {
title <- list(...)$main
}
if (!is.null(title)) {
title <- gsub(" +", " ", paste0(title, collapse = " "))
}
x <- plot_prepare_table(object, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
language = language,
...)
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
language = language,
...
)
df <- as.data.frame(x, stringsAsFactors = TRUE)
colnames(df) <- c("disk", "count")
df$cols <- cols_sub$cols
df$cols[df$cols == colours_RSI[1]] <- "Resistant"
df$cols[df$cols == colours_RSI[2]] <- "Susceptible"
df$cols[df$cols == colours_RSI[3]] <- plot_name_of_I(cols_sub$guideline)
df$cols <- factor(translate_into_language(df$cols, language = language),
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
language = language),
ordered = TRUE)
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
language = language
),
ordered = TRUE
)
p <- ggplot2::ggplot(df)
if (any(colours_RSI %in% cols_sub$cols)) {
vals <- c("Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3])
vals <- c(
"Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3]
)
names(vals) <- translate_into_language(names(vals), language = language)
p <- p +
ggplot2::geom_col(ggplot2::aes(x = disk, y = count, fill = cols)) +
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)
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)
}
@ -514,8 +544,10 @@ autoplot.disk <- function(object,
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
fortify.disk <- function(object, ...) {
stats::setNames(as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y"))
stats::setNames(
as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y")
)
}
#' @method plot rsi
@ -531,7 +563,7 @@ plot.rsi <- function(x,
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)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@ -539,44 +571,51 @@ plot.rsi <- function(x,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
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(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
}
if (!"I" %in% data$x) {
data <- rbind(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
}
if (!"R" %in% data$x) {
data <- rbind(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
}
data$x <- factor(data$x, levels = c("S", "I", "R"), 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)
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, ")"))
text(
x = data$x,
y = data$s + 4,
labels = paste0(data$s, "% (n = ", data$n, ")")
)
}
@ -598,7 +637,7 @@ barplot.rsi <- function(height,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@ -606,22 +645,23 @@ barplot.rsi <- function(height,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
} else {
colours_RSI <- c(colours_RSI[2], colours_RSI[3], colours_RSI[1])
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
x <- table(height)
x <- x[c(1, 2, 3)]
barplot(x,
col = colours_RSI,
xlab = xlab,
main = main,
ylab = ylab,
axes = FALSE)
col = colours_RSI,
xlab = xlab,
main = main,
ylab = ylab,
axes = FALSE
)
axis(2, seq(0, max(x)))
}
@ -640,7 +680,7 @@ autoplot.rsi <- function(object,
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@ -648,27 +688,31 @@ autoplot.rsi <- function(object,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if ("main" %in% names(list(...))) {
title <- list(...)$main
}
if (!is.null(title)) {
title <- gsub(" +", " ", paste0(title, collapse = " "))
}
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
}
df <- as.data.frame(table(object), stringsAsFactors = TRUE)
colnames(df) <- c("rsi", "count")
ggplot2::ggplot(df) +
ggplot2::geom_col(ggplot2::aes(x = rsi, y = count, fill = rsi)) +
ggplot2::geom_col(ggplot2::aes(x = rsi, y = count, fill = rsi)) +
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
ggplot2::scale_fill_manual(values = c("R" = colours_RSI[1],
"S" = colours_RSI[2],
"I" = colours_RSI[3]),
limits = force) +
ggplot2::scale_fill_manual(
values = c(
"R" = colours_RSI[1],
"S" = colours_RSI[2],
"I" = colours_RSI[3]
),
limits = force
) +
ggplot2::labs(title = title, x = xlab, y = ylab) +
ggplot2::theme(legend.position = "none")
}
@ -677,8 +721,10 @@ autoplot.rsi <- function(object,
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
fortify.rsi <- function(object, ...) {
stats::setNames(as.data.frame(table(object)),
c("x", "y"))
stats::setNames(
as.data.frame(table(object)),
c("x", "y")
)
}
plot_prepare_table <- function(x, expand) {
@ -743,8 +789,10 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_RSI, f
moname <- mo_name(mo, language = language)
abname <- ab_name(ab, language = language)
if (all(cols == "#BEBEBE")) {
message_("No ", guideline, " interpretations found for ",
ab_name(ab, language = NULL, tolower = TRUE), " in ", moname)
message_(
"No ", guideline, " interpretations found for ",
ab_name(ab, language = NULL, tolower = TRUE), " in ", moname
)
guideline_txt <- ""
} else {
guideline_txt <- guideline
@ -753,7 +801,7 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_RSI, f
}
guideline_txt <- paste0("(", guideline_txt, ")")
}
sub <- bquote(.(abname)~"-"~italic(.(moname))~.(guideline_txt))
sub <- bquote(.(abname) ~ "-" ~ italic(.(moname)) ~ .(guideline_txt))
} else {
cols <- "#BEBEBE"
sub <- NULL