P281424
/
AMR
mirror of https://github.com/msberends/AMR
1
0
Fork 0
Code Releases Activity

(v1.5.0.9025) big plot and ggplot generics update

pull/67/head
dr. M.S. (Matthijs) Berends 2021-02-25 10:33:08 +01:00
parent 31ceba5441
commit a673407904
42 changed files with 1058 additions and 842 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR
Version: 1.5.0.9024
Date: 2021-02-22
Version: 1.5.0.9025
Date: 2021-02-25
Title: Antimicrobial Resistance Data Analysis
Authors@R: c(
person(role = c("aut", "cre"),

3
NAMESPACE
View File

@ -32,6 +32,7 @@ S3method(as.rsi,data.frame)
S3method(as.rsi,default)
S3method(as.rsi,disk)
S3method(as.rsi,mic)
S3method(barplot,disk)
S3method(barplot,mic)
S3method(barplot,rsi)
S3method(c,ab)
@ -242,7 +243,7 @@ export(theme_rsi)
importFrom(graphics,arrows)
importFrom(graphics,axis)
importFrom(graphics,barplot)
importFrom(graphics,par)
importFrom(graphics,mtext)
importFrom(graphics,plot)
importFrom(graphics,points)
importFrom(graphics,text)

9
NEWS.md
View File

@ -1,5 +1,5 @@
# AMR 1.5.0.9024
## <small>Last updated: 22 February 2021</small>
# AMR 1.5.0.9025
## <small>Last updated: 25 February 2021</small>
### New
* Support for EUCAST Clinical Breakpoints v11.0 (2021), effective in the `eucast_rules()` function and in `as.rsi()` to interpret MIC and disk diffusion values. This is now the default guideline in this package.
@ -23,6 +23,7 @@
```
* Support for custom MDRO guidelines, using the new `custom_mdro_guideline()` function, please see `mdro()` for additional info
* Function `isolate_identifier()`, which will paste a microorganism code with all antimicrobial results of a data set into one string for each row. This is useful to compare isolates, e.g. between institutions or regions, when there is no genotyping available.
* `ggplot()` generics for classes `<mic>` and `<disk>`
* Function `mo_is_yeast()`, which determines whether a microorganism is a member of the taxonomic class Saccharomycetes or the taxonomic order Saccharomycetales:
```r
mo_kingdom(c("Aspergillus", "Candida"))
@ -54,12 +55,14 @@
* `is.rsi.eligible()` now detects if the column name resembles an antibiotic name or code and now returns `TRUE` immediately if the input contains any of the values "R", "S" or "I". This drastically improves speed, also for a lot of other functions that rely on automatic determination of antibiotic columns.
* Functions `get_episode()` and `is_new_episode()` now support less than a day as value for argument `episode_days` (e.g., to include one patient/test per hour)
* Argument `ampc_cephalosporin_resistance` in `eucast_rules()` now also applies to value "I" (not only "S")
* Updated colours of values R, S and I in tibble printing
* Updated `plot()` functions for classes `<mic>`, `<disk>` and `<rsi>` - the former two now support colouring if you supply the microorganism and antimicrobial agent
* Updated colours to colour-blind friendly version for values R, S and I in tibble printing and for all plot methods (`ggplot_rsi()` and using `plot()` on classes `<mic>`, `<disk>` and `<rsi>`)
* Functions `print()` and `summary()` on a Principal Components Analysis object (`pca()`) now print additional group info if the original data was grouped using `dplyr::group_by()`
* Improved speed and reliability of `guess_ab_col()`. As this also internally improves the reliability of `first_isolate()` and `mdro()`, this might have a slight impact on the results of those functions.
* Fix for `mo_name()` when used in other languages than English
* The `like()` function (and its fast alias `%like%`) now always use Perl compatibility, improving speed for many functions in this package (e.g., `as.mo()` is now up to 4 times faster)
* *Staphylococcus cornubiensis* is now correctly categorised as coagulase-positive
* `random_disk()` and `random_mic()` now have an expanded range in their randomisation
### Other
* Big documentation updates

9
R/aa_helper_functions.R
View File

@ -879,13 +879,16 @@ font_green_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[42m", after = "\033[49m", collapse = collapse)
}
font_rsi_R_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[48;5;210m", after = "\033[49m", collapse = collapse)
#ED553B
try_colour(..., before = "\033[48;5;203m", after = "\033[49m", collapse = collapse)
}
font_rsi_S_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[48;5;113m", after = "\033[49m", collapse = collapse)
#3CAEA3
try_colour(..., before = "\033[48;5;79m", after = "\033[49m", collapse = collapse)
}
font_rsi_I_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[48;5;185m", after = "\033[49m", collapse = collapse)
#F6D55C
try_colour(..., before = "\033[48;5;222m", after = "\033[49m", collapse = collapse)
}
font_red_bg <- function(..., collapse = " ") {
try_colour(..., before = "\033[41m", after = "\033[49m", collapse = collapse)

13
R/amr.R
View File

@ -73,16 +73,3 @@
#' @name AMR
#' @rdname AMR
NULL
#' Plotting for Classes `rsi`, `mic` and `disk`
#'
#' Functions to print classes of the `AMR` package.
#' @inheritSection lifecycle Stable Lifecycle
#' @inheritSection AMR Read more on Our Website!
#' @param ... Arguments passed on to functions
#' @inheritParams base::plot
#' @inheritParams graphics::barplot
#' @name plot
#' @rdname plot
#' @keywords internal
NULL

24
R/disk.R
View File

@ -145,30 +145,6 @@ print.disk <- function(x, ...) {
print(as.integer(x), quote = FALSE)
}
#' @method plot disk
#' @export
#' @importFrom graphics barplot axis
#' @rdname plot
plot.disk <- function(x,
main = paste("Disk zones values of", deparse(substitute(x))),
ylab = "Frequency",
xlab = "Disk diffusion (mm)",
axes = FALSE,
...) {
meet_criteria(main, allow_class = "character", has_length = 1)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(axes, allow_class = "logical", has_length = 1)
barplot(table(x),
ylab = ylab,
xlab = xlab,
axes = axes,
main = main,
...)
axis(2, seq(0, max(table(x))))
}
#' @method [ disk
#' @export
#' @noRd

33
R/ggplot_rsi.R
View File

@ -36,7 +36,8 @@
#' @param facet variable to split plots by, either `"interpretation"` (default) or `"antibiotic"` or a grouping variable
#' @inheritParams proportion
#' @param nrow (when using `facet`) number of rows
#' @param colours a named vector with colours for the bars. The names must be one or more of: S, SI, I, IR, R or be `FALSE` to use default [ggplot2][ggplot2::ggplot()] colours.
#' @param colours a named vector with colours for the bars. The names must be one or more of: S, SI, I, IR, R or be `FALSE` for standard [ggplot2][ggplot2::ggplot()] colours. The default colours are colour-blind friendly.
#' @param aesthetics aesthetics to apply the colours to, defaults to "fill" but can also be "colour" or "both"
#' @param datalabels show datalabels using [labels_rsi_count()]
#' @param datalabels.size size of the datalabels
#' @param datalabels.colour colour of the datalabels
@ -364,25 +365,27 @@ scale_y_percent <- function(breaks = seq(0, 1, 0.1), limits = NULL) {
#' @rdname ggplot_rsi
#' @export
scale_rsi_colours <- function(colours = c(S = "#61a8ff",
SI = "#61a8ff",
I = "#61f7ff",
IR = "#ff6961",
R = "#ff6961")) {
scale_rsi_colours <- function(colours = c(S = "#3CAEA3",
SI = "#3CAEA3",
I = "#F6D55C",
IR = "#ED553B",
R = "#ED553B"),
aesthetics = "fill") {
stop_ifnot_installed("ggplot2")
meet_criteria(colours, allow_class = c("character", "logical"))
# previous colour: palette = "RdYlGn"
# previous colours: values = c("#b22222", "#ae9c20", "#7cfc00")
meet_criteria(aesthetics, allow_class = c("character"), has_length = c(1, 2), is_in = c("colour", "color", "fill", "both"))
if (!identical(colours, FALSE)) {
original_cols <- c(S = "#61a8ff",
SI = "#61a8ff",
I = "#61f7ff",
IR = "#ff6961",
R = "#ff6961")
if ("both" %in% aesthetics) {
aesthetics <- c("colour", "fill")
}
original_cols <- c(S = "#3CAEA3",
SI = "#3CAEA3",
I = "#F6D55C",
IR = "#ED553B",
R = "#ED553B")
colours <- replace(original_cols, names(colours), colours)
ggplot2::scale_fill_manual(values = colours)
ggplot2::scale_fill_manual(values = colours, aesthetics = aesthetics)
}
}

83
R/like.R
View File

@ -25,7 +25,7 @@
#' Pattern Matching with Keyboard Shortcut
#'
#' Convenient wrapper around [grep()] to match a pattern: `x %like% pattern`. It always returns a [`logical`] vector and is always case-insensitive (use `x %like_case% pattern` for case-sensitive matching). Also, `pattern` can be as long as `x` to compare items of each index in both vectors, or they both can have the same length to iterate over all cases.
#' Convenient wrapper around [grepl()] to match a pattern: `x %like% pattern`. It always returns a [`logical`] vector and is always case-insensitive (use `x %like_case% pattern` for case-sensitive matching). Also, `pattern` can be as long as `x` to compare items of each index in both vectors, or they both can have the same length to iterate over all cases.
#' @inheritSection lifecycle Stable Lifecycle
#' @param x a character vector where matches are sought, or an object which can be coerced by [as.character()] to a character vector.
#' @param pattern a character string containing a regular expression (or [character] string for `fixed = TRUE`) to be matched in the given character vector. Coerced by [as.character()] to a character string if possible. If a [character] vector of length 2 or more is supplied, the first element is used with a warning.
@ -43,7 +43,7 @@
#'
#' Using RStudio? The text `%like%` can also be directly inserted in your code from the Addins menu and can have its own Keyboard Shortcut like `Ctrl+Shift+L` or `Cmd+Shift+L` (see `Tools` > `Modify Keyboard Shortcuts...`).
#' @source Idea from the [`like` function from the `data.table` package](https://github.com/Rdatatable/data.table/blob/master/R/like.R)
#' @seealso [grep()]
#' @seealso [grepl()]
#' @inheritSection AMR Read more on Our Website!
#' @examples
#' # simple test
@ -53,13 +53,17 @@
#' #> TRUE
#' b %like% a
#' #> FALSE
#'
#' # also supports multiple patterns, length must be equal to x
#'
#' # also supports multiple patterns
#' a <- c("Test case", "Something different", "Yet another thing")
#' b <- c( "case", "diff", "yet")
#' a %like% b
#' #> TRUE TRUE TRUE
#'
#' a[1] %like% b
#' #> TRUE FALSE FALSE
#' a %like% b[1]
#' #> TRUE FALSE FALSE
#'
#' # get isolates whose name start with 'Ent' or 'ent'
#' \donttest{
#' if (require("dplyr")) {
@ -71,7 +75,11 @@ like <- function(x, pattern, ignore.case = TRUE) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(pattern, allow_NA = FALSE)
meet_criteria(ignore.case, allow_class = "logical", has_length = 1)
if (all(is.na(x))) {
return(rep(FALSE, length(x)))
}
# set to fixed if no regex found
fixed <- !any(is_possibly_regex(pattern))
if (ignore.case == TRUE) {
@ -79,53 +87,26 @@ like <- function(x, pattern, ignore.case = TRUE) {
x <- tolower(x)
pattern <- tolower(pattern)
}
if (length(pattern) > 1 & length(x) == 1) {
x <- rep(x, length(pattern))
}
if (all(is.na(x))) {
return(rep(FALSE, length(x)))
}
if (length(pattern) > 1) {
res <- vector(length = length(pattern))
if (length(x) != length(pattern)) {
if (length(x) == 1) {
x <- rep(x, length(pattern))
}
# return TRUE for every 'x' that matches any 'pattern', FALSE otherwise
for (i in seq_len(length(res))) {
if (is.factor(x[i])) {
res[i] <- as.integer(x[i]) %in% grep(pattern[i], levels(x[i]), ignore.case = FALSE, fixed = fixed)
} else {
res[i] <- grepl(pattern[i], x[i], ignore.case = FALSE, fixed = fixed, perl = !fixed)
}
}
res <- vapply(FUN.VALUE = logical(1), pattern, function(pttrn) grepl(pttrn, x, ignore.case = FALSE, fixed = fixed))
res2 <- as.logical(rowSums(res))
# get only first item of every hit in pattern
res2[duplicated(res)] <- FALSE
res2[rowSums(res) == 0] <- NA
return(res2)
} else {
# x and pattern are of same length, so items with each other
for (i in seq_len(length(res))) {
if (is.factor(x[i])) {
res[i] <- as.integer(x[i]) %in% grep(pattern[i], levels(x[i]), ignore.case = FALSE, fixed = fixed, perl = !fixed)
} else {
res[i] <- grepl(pattern[i], x[i], ignore.case = FALSE, fixed = fixed, perl = !fixed)
}
}
return(res)
}
}
# the regular way how grepl works; just one pattern against one or more x
if (is.factor(x)) {
as.integer(x) %in% grep(pattern, levels(x), ignore.case = FALSE, fixed = fixed, perl = !fixed)
} else {
x <- as.character(x)
}
if (length(pattern) == 1) {
grepl(pattern, x, ignore.case = FALSE, fixed = fixed, perl = !fixed)
} else {
if (length(x) == 1) {
x <- rep(x, length(pattern))
} else if (length(pattern) != length(x)) {
stop_("arguments `x` and `pattern` must be of same length, or either one must be 1")
}
mapply(FUN = grepl,
pattern,
x,
MoreArgs = list(ignore.case = FALSE, fixed = fixed, perl = !fixed),
SIMPLIFY = TRUE,
USE.NAMES = FALSE)
}
}

57
R/mic.R
View File

@ -53,8 +53,9 @@
#' ab = "AMX",
#' guideline = "EUCAST")
#'
#' # plot MIC values, see ?plot
#' plot(mic_data)
#' barplot(mic_data)
#' plot(mic_data, mo = "E. coli", ab = "cipro")
as.mic <- function(x, na.rm = FALSE) {
meet_criteria(x, allow_class = c("mic", "character", "numeric", "integer"), allow_NA = TRUE)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
@ -175,9 +176,11 @@ as.numeric.mic <- function(x, ...) {
#' @method droplevels mic
#' @export
#' @noRd
droplevels.mic <- function(x, exclude = if (any(is.na(levels(x)))) NULL else NA, ...) {
droplevels.mic <- function(x, exclude = if (any(is.na(levels(x)))) NULL else NA, as.mic = TRUE, ...) {
x <- droplevels.factor(x, exclude = exclude, ...)
class(x) <- c("mic", "ordered", "factor")
if (as.mic == TRUE) {
class(x) <- c("mic", "ordered", "factor")
}
x
}
@ -221,54 +224,6 @@ summary.mic <- function(object, ...) {
value
}
#' @method plot mic
#' @export
#' @importFrom graphics barplot axis
#' @rdname plot
plot.mic <- function(x,
main = paste("MIC values of", deparse(substitute(x))),
ylab = "Frequency",
xlab = "MIC value",
axes = FALSE,
...) {
meet_criteria(main, allow_class = "character", has_length = 1)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(axes, allow_class = "logical", has_length = 1)
barplot(table(as.double(x)),
ylab = ylab,
xlab = xlab,
axes = axes,
main = main,
...)
axis(2, seq(0, max(table(as.double(x)))))
}
#' @method barplot mic
#' @export
#' @importFrom graphics barplot axis
#' @rdname plot
barplot.mic <- function(height,
main = paste("MIC values of", deparse(substitute(height))),
ylab = "Frequency",
xlab = "MIC value",
axes = FALSE,
...) {
meet_criteria(main, allow_class = "character", has_length = 1)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(axes, allow_class = "logical", has_length = 1)
barplot(table(as.double(height)),
ylab = ylab,
xlab = xlab,
axes = axes,
main = main,
...)
axis(2, seq(0, max(table(as.double(height)))))
}
#' @method [ mic
#' @export
#' @noRd

552
R/plot.R 100644
View File

@ -0,0 +1,552 @@
# ==================================================================== #
# TITLE #
# Antimicrobial Resistance (AMR) Data Analysis for R #
# #
# SOURCE #
# https://github.com/msberends/AMR #
# #
# LICENCE #
# (c) 2018-2021 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. #
# #
# 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 for Classes `rsi`, `mic` and `disk`
#'
#' Functions to plot classes `rsi`, `mic` and `disk`, with support for base R and `ggplot2`.
#' @inheritSection lifecycle Stable Lifecycle
#' @inheritSection AMR Read more on Our Website!
#' @param x MIC values created with [as.mic()] or disk diffusion values created with [as.disk()]
#' @param mapping aesthetic mappings to use for [`ggplot()`][ggplot2::ggplot()]
#' @param main,title title of the plot
#' @param xlab,ylab axis title
#' @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 code with [as.ab()]
#' @param guideline interpretation guideline to use, defaults to the latest included EUCAST guideline, see *Details*
#' @param colours_RSI colours to use for filling in the bars, must be a vector of three values (in the order R, S and I). The default colours are colour-blind friendly.
#' @param expand 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 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 `ggplot` functions return a [`ggplot`][ggplot2::ggplot()] model that is extendible with any `ggplot2` function.
#' @param ... arguments passed on to [as.rsi()]
#' @examples
#' some_mic_values <- random_mic(size = 100)
#' some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
#'
#' plot(some_mic_values)
#' plot(some_disk_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")
#'
#' if (require("ggplot2")) {
#' ggplot(some_mic_values)
#' ggplot(some_disk_values, mo = "Escherichia coli", ab = "cipro")
#' }
NULL
#' @method plot mic
#' @importFrom graphics barplot axis mtext
#' @export
#' @rdname plot
plot.mic <- function(x,
main = paste("MIC values of", deparse(substitute(x))),
ylab = "Frequency",
xlab = "Minimum Inhibitory Concentration (mg/L)",
mo = NULL,
ab = NULL,
guideline = "EUCAST",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
expand = TRUE,
...) {
meet_criteria(main, allow_class = "character")
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_RSI, allow_class = "character", has_length = c(1, 3))
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_and_sub(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
...)
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)
axis(2, seq(0, max(as.double(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)
if (colours_RSI[2] %in% cols_sub$cols) {
legend_txt <- "Susceptible"
legend_col <- colours_RSI[2]
}
if (colours_RSI[3] %in% cols_sub$cols) {
legend_txt <- c(legend_txt, "Incr. exposure")
legend_col <- c(legend_col, colours_RSI[3])
}
if (colours_RSI[1] %in% cols_sub$cols) {
legend_txt <- c(legend_txt, "Resistant")
legend_col <- c(legend_col, colours_RSI[1])
}
legend("top",
x.intersp = 0.5,
legend = legend_txt,
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
bg = "#FFFFFF55")
}
}
#' @method barplot mic
#' @export
#' @noRd
barplot.mic <- function(height,
main = paste("MIC values of", deparse(substitute(height))),
ylab = "Frequency",
xlab = "Minimum Inhibitory Concentration (mg/L)",
mo = NULL,
ab = NULL,
guideline = "EUCAST",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
expand = TRUE,
...) {
meet_criteria(main, allow_class = "character")
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_RSI, allow_class = "character", has_length = c(1, 3))
main <- gsub(" +", " ", paste0(main, collapse = " "))
plot(x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...)
}
#' @method ggplot mic
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
ggplot.mic <- function(data,
mapping = NULL,
title = paste("MIC values of", deparse(substitute(data))),
ylab = "Frequency",
xlab = "Minimum Inhibitory Concentration (mg/L)",
mo = NULL,
ab = NULL,
guideline = "EUCAST",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
expand = TRUE,
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(title, allow_class = "character")
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_RSI, allow_class = "character", has_length = c(1, 3))
title <- gsub(" +", " ", paste0(title, collapse = " "))
x <- plot_prepare_table(data, expand = expand)
cols_sub <- plot_colours_and_sub(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
...)
df <- as.data.frame(x, stringsAsFactors = TRUE)
colnames(df) <- c("mic", "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]] <- "Incr. exposure"
df$cols <- factor(df$cols,
levels = c("Susceptible", "Incr. exposure", "Resistant"),
ordered = TRUE)
if (!is.null(mapping)) {
p <- ggplot2::ggplot(df, mapping = mapping)
} else {
p <- ggplot2::ggplot(df)
}
if (any(colours_RSI %in% cols_sub$cols)) {
p <- p +
ggplot2::geom_col(aes(x = mic, y = count, fill = cols)) +
ggplot2::scale_fill_manual(values = c("Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Incr. exposure" = colours_RSI[3]),,
name = NULL)
} else {
p <- p +
ggplot2::geom_col(aes(x = mic, y = count))
}
p +
ggplot2::labs(title = title, x = xlab, y = ylab, subtitle = cols_sub$sub)
}
#' @method plot disk
#' @export
#' @importFrom graphics barplot axis mtext
#' @rdname plot
plot.disk <- function(x,
main = paste("Disk zones values of", deparse(substitute(x))),
ylab = "Frequency",
xlab = "Disk diffusion diameter (mm)",
mo = NULL,
ab = NULL,
guideline = "EUCAST",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
expand = TRUE,
...) {
meet_criteria(main, allow_class = "character")
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_RSI, allow_class = "character", has_length = c(1, 3))
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_and_sub(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
...)
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)
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)
if (colours_RSI[1] %in% cols_sub$cols) {
legend_txt <- "Resistant"
legend_col <- colours_RSI[1]
}
if (colours_RSI[3] %in% cols_sub$cols) {
legend_txt <- c(legend_txt, "Incr. exposure")
legend_col <- c(legend_col, colours_RSI[3])
}
if (colours_RSI[2] %in% cols_sub$cols) {
legend_txt <- c(legend_txt, "Susceptible")
legend_col <- c(legend_col, colours_RSI[2])
}
legend("top",
x.intersp = 0.5,
legend = legend_txt,
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
bg = "#FFFFFF55")
}
}
#' @method barplot disk
#' @export
#' @noRd
barplot.disk <- function(height,
main = paste("Disk zones values of", deparse(substitute(height))),
ylab = "Frequency",
xlab = "Disk diffusion diameter (mm)",
mo = NULL,
ab = NULL,
guideline = "EUCAST",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
expand = TRUE,
...) {
meet_criteria(main, allow_class = "character")
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_RSI, allow_class = "character", has_length = c(1, 3))
main <- gsub(" +", " ", paste0(main, collapse = " "))
plot(x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...)
}
#' @method ggplot disk
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
ggplot.disk <- function(data,
mapping = NULL,
title = paste("Disk zones values of", deparse(substitute(data))),
ylab = "Frequency",
xlab = "Disk diffusion diameter (mm)",
mo = NULL,
ab = NULL,
guideline = "EUCAST",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
expand = TRUE,
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(title, allow_class = "character")
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_RSI, allow_class = "character", has_length = c(1, 3))
title <- gsub(" +", " ", paste0(title, collapse = " "))
x <- plot_prepare_table(data, expand = expand)
cols_sub <- plot_colours_and_sub(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
...)
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]] <- "Incr. exposure"
df$cols <- factor(df$cols,
levels = c("Resistant", "Incr. exposure", "Susceptible"),
ordered = TRUE)
if (!is.null(mapping)) {
p <- ggplot2::ggplot(df, mapping = mapping)
} else {
p <- ggplot2::ggplot(df)
}
if (any(colours_RSI %in% cols_sub$cols)) {
p <- p +
ggplot2::geom_col(aes(x = disk, y = count, fill = cols)) +
ggplot2::scale_fill_manual(values = c("Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Incr. exposure" = colours_RSI[3]),
name = NULL)
} else {
p <- p +
ggplot2::geom_col(aes(x = disk, y = count))
}
p +
ggplot2::labs(title = title, x = xlab, y = ylab, sub = cols_sub$sub)
}
plot_prepare_table <- function(x, expand) {
if (is.mic(x)) {
if (expand == TRUE) {
# expand range for MIC by adding factors of 2 from lowest to highest so all MICs in between also print
extra_range <- max(as.double(x)) / 2
while (min(extra_range) / 2 > min(as.double(x))) {
extra_range <- c(min(extra_range) / 2, extra_range)
}
extra_range <- setNames(rep(0, length(extra_range)), extra_range)
x <- table(droplevels(x, as.mic = FALSE))
extra_range <- extra_range[!names(extra_range) %in% names(x)]
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)
}
plot_colours_and_sub <- function(x, mo, ab, guideline, colours_RSI, fn, ...) {
if (!is.null(mo) && !is.null(ab)) {
# interpret and give colour based on MIC values
mo <- as.mo(mo)
ab <- as.ab(ab)
guideline <- get_guideline(guideline, AMR::rsi_translation)
rsi <- suppressWarnings(suppressMessages(as.rsi(fn(names(x)), mo = mo, ab = ab, guideline = guideline, ...)))
cols <- character(length = length(rsi))
cols[is.na(rsi)] <- "#BEBEBE"
cols[rsi == "R"] <- colours_RSI[1]
cols[rsi == "S"] <- colours_RSI[2]
cols[rsi == "I"] <- colours_RSI[3]
moname <- mo_name(mo, language = NULL)
abname <- ab_name(ab, language = NULL)
if (all(cols == "#BEBEBE")) {
message_("No ", guideline, " interpretations found for ",
ab_name(ab, language = NULL, tolower = TRUE), " in ", moname)
guideline <- ""
} else {
guideline <- paste0("(following ", guideline, ")")
}
sub <- bquote(.(abname)~"in"~italic(.(moname))~.(guideline))
} else {
cols <- "#BEBEBE"
sub <- NULL
}
list(cols = cols, sub = sub)
}
#' @method plot rsi
#' @export
#' @importFrom graphics plot text axis
#' @rdname plot
plot.rsi <- function(x,
ylab = "Percentage",
xlab = "Antimicrobial Interpretation",
main = paste("Resistance Overview of", deparse(substitute(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)
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)
}
if (!"I" %in% data$x) {
data <- rbind(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
}
if (!"R" %in% data$x) {
data <- rbind(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
}
data$x <- factor(data$x, levels = c("R", "S", "I"), 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 rsi
#' @importFrom graphics barplot axis
#' @export
#' @noRd
barplot.rsi <- function(height,
main = paste("Resistance Overview of", deparse(substitute(height))),
xlab = "Antimicrobial Interpretation",
ylab = "Frequency",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
expand = TRUE,
...) {
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(main, allow_class = "character", has_length = 1)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
x <- table(height)
x <- x[c(3, 1, 2)]
barplot(x,
col = colours_RSI,
xlab = xlab,
main = main,
ylab = ylab,
axes = FALSE)
axis(2, seq(0, max(x)))
}

10
R/random.R
View File

@ -25,7 +25,7 @@
#' Random MIC Values/Disk Zones/RSI Generation
#'
#' These functions can be used for generating random MIC values and disk diffusion diameters, for AMR data analysis practice.
#' These functions can be used for generating random MIC values and disk diffusion diameters, for AMR data analysis practice. By providing a microorganism and antimicrobial agent, the generated results will reflect reality as much as possible.
#' @inheritSection lifecycle Maturing Lifecycle
#' @param size desired size of the returned vector
#' @param mo any character that can be coerced to a valid microorganism code with [as.mo()]
@ -111,8 +111,8 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
if (log(set_range_max, 2) %% 1 == 0) {
# return powers of 2
valid_range <- unique(as.double(valid_range))
# add one higher MIC level to set_range_max
set_range_max <- 2 ^ (log(set_range_max, 2) + 1)
# add 1-3 higher MIC levels to set_range_max
set_range_max <- 2 ^ (log(set_range_max, 2) + sample(c(1:3), 1))
set_range <- as.mic(valid_range[log(valid_range, 2) %% 1 == 0 & valid_range <= set_range_max])
} else {
# no power of 2, return factors of 2 to left and right side
@ -121,8 +121,8 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
}
return(as.mic(sample(set_range, size = size, replace = TRUE)))
} else if (type == "DISK") {
set_range <- seq(from = as.integer(min(df$breakpoint_R)),
to = as.integer(max(df$breakpoint_S)),
set_range <- seq(from = as.integer(min(df$breakpoint_R) / 1.25),
to = as.integer(max(df$breakpoint_S) * 1.25),
by = 1)
out <- sample(set_range, size = size, replace = TRUE)
out[out < 6] <- sample(c(6:10), length(out[out < 6]), replace = TRUE)

110
R/rsi.R
View File

@ -252,12 +252,13 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
}
#' @export
# extra param: warn (never throw warning)
as.rsi.default <- function(x, ...) {
if (is.rsi(x)) {
return(x)
}
if (inherits(x, "integer") & all(x %in% c(1:3, NA))) {
if (inherits(x, c("integer", "numeric", "double")) && all(x %in% c(1:3, NA))) {
x[x == 1] <- "S"
x[x == 2] <- "I"
x[x == 3] <- "R"
@ -265,11 +266,11 @@ as.rsi.default <- function(x, ...) {
} else if (!all(is.na(x)) && !identical(levels(x), c("S", "I", "R"))) {
if (!any(x %like% "(R|S|I)", na.rm = TRUE)) {
# check if they are actually MICs or disks now that the antibiotic name is valid
# check if they are actually MICs or disks
if (all_valid_mics(x)) {
warning_("The input seems to be MIC values. Transform them with as.mic() before running as.rsi() to interpret them.")
warning_("The input seems to be MIC values. Transform them with `as.mic()` before running `as.rsi()` to interpret them.")
} else if (all_valid_disks(x)) {
warning_("The input seems to be disk diffusion values. Transform them with as.disk() before running as.rsi() to interpret them.")
warning_("The input seems to be disk diffusion values. Transform them with `as.disk()` before running `as.rsi()` to interpret them.")
}
}
@ -1010,107 +1011,6 @@ summary.rsi <- function(object, ...) {
value
}
#' @method plot rsi
#' @export
#' @importFrom graphics plot text axis
#' @rdname plot
plot.rsi <- function(x,
lwd = 2,
ylim = NULL,
ylab = "Percentage",
xlab = "Antimicrobial Interpretation",
main = paste("Resistance Overview of", deparse(substitute(x))),
axes = FALSE,
...) {
meet_criteria(lwd, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(ylim, allow_class = c("numeric", "integer"), allow_NULL = TRUE)
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)
meet_criteria(axes, allow_class = "logical", has_length = 1)
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)
}
if (!"I" %in% data$x) {
data <- rbind(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
}
if (!"R" %in% data$x) {
data <- rbind(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
}
# don't use as.rsi() here, it will confuse plot()
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 = lwd,
ylim = c(0, ymax),
ylab = ylab,
xlab = xlab,
main = main,
axes = axes,
...)
# 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 rsi
#' @export
#' @importFrom graphics barplot axis par
#' @rdname plot
barplot.rsi <- function(height,
col = c("chartreuse4", "chartreuse3", "brown3"),
xlab = ifelse(beside, "Antimicrobial Interpretation", ""),
main = paste("Resistance Overview of", deparse(substitute(height))),
ylab = "Frequency",
beside = TRUE,
axes = beside,
...) {
meet_criteria(col, allow_class = "character", has_length = 3)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(main, allow_class = "character", has_length = 1)
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(beside, allow_class = "logical", has_length = 1)
meet_criteria(axes, allow_class = "logical", has_length = 1)
if (axes == TRUE) {
par(mar = c(5, 4, 4, 2) + 0.1)
} else {
par(mar = c(2, 4, 4, 2) + 0.1)
}
barplot(as.matrix(table(height)),
col = col,
xlab = xlab,
main = main,
ylab = ylab,
beside = beside,
axes = FALSE,
...)
# y axis, 0-100%
axis(side = 2, at = seq(0, max(table(height)) + max(table(height)) * 1.1, by = 25))
if (axes == TRUE && beside == TRUE) {
axis(side = 1, labels = levels(height), at = c(1, 2, 3) + 0.5, lwd = 0)
}
}
#' @method [<- rsi
#' @export
#' @noRd

2
R/zzz.R
View File

@ -50,6 +50,8 @@ pkg_env$mo_failed <- character(0)
s3_register("skimr::get_skimmers", "rsi")
s3_register("skimr::get_skimmers", "mic")
s3_register("skimr::get_skimmers", "disk")
s3_register("ggplot2::ggplot", "mic")
s3_register("ggplot2::ggplot", "disk")
# if mo source exists, fire it up (see mo_source())
try({

BIN
data-raw/AMR_latest.tar.gz
View File

Binary file not shown.

2
docs/404.html
View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="https://msberends.github.io/AMR//index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.5.0.9024</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.5.0.9025</span>
</span>
</div>

2
docs/LICENSE-text.html
View File

@ -81,7 +81,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.5.0.9024</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.5.0.9025</span>
</span>
</div>

76
docs/articles/benchmarks.html
View File

@ -39,7 +39,7 @@
</button>
<span class="navbar-brand">
<a class="navbar-link" href="../index.html">AMR (for R)</a>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.5.0.9024</span>
<span class="version label label-default" data-toggle="tooltip" data-placement="bottom" title="Latest development version">1.5.0.9025</span>
</span>
</div>
@ -226,19 +226,19 @@
times <span class="op">=</span> <span class="fl">25</span><span class="op">)</span>
<span class="fu"><a href="https://rdrr.io/r/base/print.html">print</a></span><span class="op">(</span><span class="va">S.aureus</span>, unit <span class="op">=</span> <span class="st">"ms"</span>, signif <span class="op">=</span> <span class="fl">2</span><span class="op">)</span>
<span class="co"># Unit: milliseconds</span>
<span class="co"># expr min lq mean median uq max neval</span>
<span class="co"># as.mo("sau") 9.3 10 11.0 10 11.0 13.0 25</span>
<span class="co"># as.mo("stau") 52.0 55 73.0 58 92.0 100.0 25</span>
<span class="co"># as.mo("STAU") 50.0 54 73.0 58 96.0 110.0 25</span>
<span class="co"># as.mo("staaur") 9.7 10 14.0 11 12.0 57.0 25</span>
<span class="co"># as.mo("STAAUR") 8.9 10 14.0 10 11.0 52.0 25</span>
<span class="co"># as.mo("S. aureus") 26.0 28 41.0 29 67.0 76.0 25</span>
<span class="co"># as.mo("S aureus") 27.0 28 41.0 30 65.0 76.0 25</span>
<span class="co"># as.mo("Staphylococcus aureus") 2.6 3 3.2 3 3.3 4.6 25</span>
<span class="co"># as.mo("Staphylococcus aureus (MRSA)") 240.0 260 270.0 260 270.0 380.0 25</span>
<span class="co"># as.mo("Sthafilokkockus aaureuz") 160.0 190 200.0 200 200.0 300.0 25</span>
<span class="co"># as.mo("MRSA") 9.3 10 15.0 10 12.0 49.0 25</span>
<span class="co"># as.mo("VISA") 18.0 19 31.0 21 54.0 67.0 25</span></code></pre></div>
<span class="co"># expr min lq mean median uq max neval</span>
<span class="co"># as.mo("sau") 10 11.0 15 11.0 13.0 47 25</span>
<span class="co"># as.mo("stau") 56 57.0 75 62.0 95.0 100 25</span>
<span class="co"># as.mo("STAU") 54 56.0 67 58.0 66.0 110 25</span>
<span class="co"># as.mo("staaur") 10 11.0 12 11.0 12.0 13 25</span>
<span class="co"># as.mo("STAAUR") 10 11.0 16 11.0 12.0 50 25</span>
<span class="co"># as.mo("S. aureus") 28 31.0 46 33.0 65.0 71 25</span>
<span class="co"># as.mo("S aureus") 29 30.0 42 33.0 64.0 67 25</span>
<span class="co"># as.mo("Staphylococcus aureus") 3 3.2 5 3.3 3.7 40 25</span>
<span class="co"># as.mo("Staphylococcus aureus (MRSA)") 240 260.0 270 270.0 280.0 290 25</span>
<span class="co"># as.mo("Sthafilokkockus aaureuz") 170 200.0 210 200.0 210.0 280 25</span>
<span class="co"># as.mo("MRSA") 10 11.0 17 11.0 13.0 51 25</span>
<span class="co"># as.mo("VISA") 19 20.0 36 21.0 50.0 150 25</span></code></pre></div>
<p><img src="benchmarks_files/figure-html/unnamed-chunk-4-1.png" width="750"></p>
<p>In the table above, all measurements are shown in milliseconds (thousands of seconds). A value of 5 milliseconds means it can determine 200 input values per second. It case of 200 milliseconds, this is only 5 input values per second. It is clear that accepted taxonomic names are extremely fast, but some variations are up to 200 times slower to determine.</p>
<p>To improve performance, we implemented two important algorithms to save unnecessary calculations: <strong>repetitive results</strong> and <strong>already precalculated results</strong>.</p>
@ -260,8 +260,8 @@
<span class="co"># what do these values look like? They are of class &lt;mo&gt;:</span>
<span class="fu"><a href="https://rdrr.io/r/utils/head.html">head</a></span><span class="op">(</span><span class="va">x</span><span class="op">)</span>
<span class="co"># Class &lt;mo&gt;</span>
<span class="co"># [1] B_STPHY_AURS B_STRPT_GRPC B_STPHY_CONS B_STPHY_EPDR B_STRPT_PNMN</span>
<span class="co"># [6] B_PROTS_VLGR</span>
<span class="co"># [1] B_ESCHR_COLI B_PROTS_MRBL B_PROTS_MRBL B_PROTS_MRBL B_STPHY_CONS</span>
<span class="co"># [6] B_ENTRC</span>
<span class="co"># as the example_isolates data set has 2,000 rows, we should have 2 million items</span>
<span class="fu"><a href="https://rdrr.io/r/base/length.html">length</a></span><span class="op">(</span><span class="va">x</span><span class="op">)</span>
@ -277,8 +277,8 @@
<span class="fu"><a href="https://rdrr.io/r/base/print.html">print</a></span><span class="op">(</span><span class="va">run_it</span>, unit <span class="op">=</span> <span class="st">"ms"</span>, signif <span class="op">=</span> <span class="fl">3</span><span class="op">)</span>
<span class="co"># Unit: milliseconds</span>
<span class="co"># expr min lq mean median uq max neval</span>
<span class="co"># mo_name(x) 157 187 222 206 224 372 10</span></code></pre></div>
<p>So getting official taxonomic names of 2,000,000 (!!) items consisting of 90 unique values only takes 0.206 seconds. That is 2.471 milliseconds per unique item on average. You only lose time on your unique input values.</p>
<span class="co"># mo_name(x) 160 189 224 201 228 356 10</span></code></pre></div>
<p>So getting official taxonomic names of 2,000,000 (!!) items consisting of 90 unique values only takes 0.201 seconds. That is 101 nanoseconds on average. You only lose time on your unique input values.</p>
</div>
<div id="precalculated-results" class="section level3">
<h3 class="hasAnchor">
@ -291,10 +291,10 @@
times <span class="op">=</span> <span class="fl">10</span><span class="op">)</span>
<span class="fu"><a href="https://rdrr.io/r/base/print.html">print</a></span><span class="op">(</span><span class="va">run_it</span>, unit <span class="op">=</span> <span class="st">"ms"</span>, signif <span class="op">=</span> <span class="fl">3</span><span class="op">)</span>
<span class="co"># Unit: milliseconds</span>
<span class="co"># expr min lq mean median uq max neval</span>
<span class="co"># A 6.97 7.10 7.55 7.21 8.18 8.32 10</span>
<span class="co"># B 23.70 24.20 36.30 26.30 29.00 89.70 10</span>
<span class="co"># C 1.53 1.65 1.80 1.76 2.00 2.19 10</span></code></pre></div>
<span class="co"># expr min lq mean median uq max neval</span>
<span class="co"># A 6.80 7.17 7.46 7.54 7.81 8.0 10</span>
<span class="co"># B 24.30 25.80 31.60 26.20 28.80 75.6 10</span>
<span class="co"># C 1.59 1.70 1.89 1.84 2.02 2.5 10</span></code></pre></div>
<p>So going from <code><a href="../reference/mo_property.html">mo_name("Staphylococcus aureus")</a></code> to <code>"Staphylococcus aureus"</code> takes 0.0018 seconds - it doesn’t even start calculating <em>if the result would be the same as the expected resulting value</em>. That goes for all helper functions:</p>
<div class="sourceCode" id="cb5"><pre class="downlit sourceCode r">
<code class="sourceCode R"><span class="va">run_it</span> <span class="op">&lt;-</span> <span class="fu"><a href="https://rdrr.io/pkg/microbenchmark/man/microbenchmark.html">microbenchmark</a></span><span class="op">(</span>A <span class="op">=</span> <span class="fu"><a href="../reference/mo_property.html">mo_species</a></span><span class="op">(</span><span class="st">"aureus"</span><span class="op">)</span>,
@ -309,14 +309,14 @@
<span class="fu"><a href="https://rdrr.io/r/base/print.html">print</a></span><span class="op">(</span><span class="va">run_it</span>, unit <span class="op">=</span> <span class="st">"ms"</span>, signif <span class="op">=</span> <span class="fl">3</span><span class="op">)</span>
<span class="co"># Unit: milliseconds</span>
<span class="co"># expr min lq mean median uq max neval</span>
<span class="co"># A 1.44 1.72 1.69 1.74 1.75 1.78 10</span>
<span class="co"># B 1.47 1.55 1.67 1.73 1.74 1.89 10</span>
<span class="co"># C 1.52 1.59 1.73 1.74 1.89 1.91 10</span>
<span class="co"># D 1.46 1.51 1.64 1.64 1.75 1.89 10</span>
<span class="co"># E 1.42 1.47 1.60 1.52 1.71 1.97 10</span>
<span class="co"># F 1.44 1.71 1.69 1.72 1.75 1.88 10</span>
<span class="co"># G 1.42 1.50 1.68 1.61 1.73 2.36 10</span>
<span class="co"># H 1.52 1.54 1.66 1.71 1.73 1.87 10</span></code></pre></div>
<span class="co"># A 1.25 1.28 1.39 1.39 1.50 1.56 10</span>
<span class="co"># B 1.17 1.19 1.41 1.43 1.48 1.92 10</span>
<span class="co"># C 1.20 1.33 1.43 1.46 1.50 1.61 10</span>
<span class="co"># D 1.43 1.45 1.50 1.49 1.53 1.61 10</span>
<span class="co"># E 1.26 1.40 1.45 1.43 1.49 1.81 10</span>
<span class="co"># F 1.15 1.17 1.32 1.26 1.44 1.69 10</span>
<span class="co"># G 1.19 1.25 1.37 1.35 1.47 1.58 10</span>
<span class="co"># H 1.20 1.25 1.46 1.31 1.53 2.33 10</span></code></pre></div>
<p>Of course, when running <code><a href="../reference/mo_property.html">mo_phylum("Firmicutes")</a></code> the function has zero knowledge about the actual microorganism, namely <em>S. aureus</em>. But since the result would be <code>"Firmicutes"</code> anyway, there is no point in calculating the result. And because this package contains all phyla of all known bacteria, it can just return the initial value immediately.</p>
</div>
<div id="results-in-other-languages" class="section level3">
@ -343,14 +343,14 @@
times <span class="op">=</span> <span class="fl">100</span><span class="op">)</span>
<span class="fu"><a href="https://rdrr.io/r/base/print.html">print</a></span><span class="op">(</span><span class="va">run_it</span>, unit <span class="op">=</span> <span class="st">"ms"</span>, signif <span class="op">=</span> <span class="fl">4</span><span class="op">)</span>
<span class="co"># Unit: milliseconds</span>
<span class="co"># expr min lq mean median uq max neval</span>
<span class="co"># en 17.12 17.40 22.65 17.54 18.39 78.39 100</span>
<span class="co"># de 19.93 20.26 22.60 20.48 20.97 81.27 100</span>