mirror of
https://github.com/msberends/AMR.git
synced 2026-11-15 22:20:47 +01:00
dr. M.S. (Matthijs) Berends
179eec584f
The full rebuild of clinical_breakpoints also assigns Salmonella serovars and the Bacteroides fragilis complex correctly and adds ECOFFs for Neocosmospora solani. The rebuilt microorganisms.codes is not included, since it remaps WHONET codes that need review first.
247 lines
8.2 KiB
R
Executable File
247 lines
8.2 KiB
R
Executable File
# ==================================================================== #
|
|
# 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://amr-for-r.org #
|
|
# ==================================================================== #
|
|
|
|
#' Transform Input to Disk Diffusion Diameters
|
|
#'
|
|
#' This transforms a vector to a new class [`disk`], which is a disk diffusion growth zone size (around an antibiotic disk) in millimetres between 0 and 50.
|
|
#' @rdname as.disk
|
|
#' @param x Vector.
|
|
#' @param na.rm A [logical] indicating whether missing values should be removed.
|
|
#' @details Interpret disk values as SIR values with [as.sir()]. It supports guidelines from EUCAST and CLSI.
|
|
#'
|
|
#' Disk diffusion growth zone sizes must be between 0 and 50 millimetres. Decimal values are rounded up. All input values outside the 0-50 range, including values higher than 50, return `NA` with a warning.
|
|
#' @return An [integer] with additional class [`disk`]
|
|
#' @aliases disk
|
|
#' @export
|
|
#' @seealso [as.sir()]
|
|
#' @examples
|
|
#' # transform existing disk zones to the `disk` class (using base R)
|
|
#' df <- data.frame(
|
|
#' microorganism = "Escherichia coli",
|
|
#' AMP = 20,
|
|
#' CIP = 14,
|
|
#' GEN = 18,
|
|
#' TOB = 16
|
|
#' )
|
|
#' df[, 2:5] <- lapply(df[, 2:5], as.disk)
|
|
#' str(df)
|
|
#'
|
|
#' \donttest{
|
|
#' # transforming is easier with dplyr:
|
|
#' if (require("dplyr")) {
|
|
#' df %>% mutate(across(AMP:TOB, as.disk))
|
|
#' }
|
|
#' }
|
|
#'
|
|
#' # interpret disk values, see ?as.sir
|
|
#' as.sir(
|
|
#' x = as.disk(18),
|
|
#' mo = "Strep pneu", # `mo` will be coerced with as.mo()
|
|
#' ab = "ampicillin", # and `ab` with as.ab()
|
|
#' guideline = "EUCAST"
|
|
#' )
|
|
#'
|
|
#' # interpret whole data set, pretend to be all from urinary tract infections:
|
|
#' as.sir(df, uti = TRUE)
|
|
as.disk <- function(x, na.rm = FALSE) {
|
|
meet_criteria(x, allow_NA = TRUE)
|
|
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
|
|
|
|
if (!is.disk(x)) {
|
|
x <- unlist(x)
|
|
if (isTRUE(na.rm)) {
|
|
x <- x[!is.na(x)]
|
|
}
|
|
x[trimws2(x) == ""] <- NA
|
|
x.bak <- x
|
|
|
|
na_before <- length(x[is.na(x)])
|
|
|
|
# extract a plausible numeric disk zone value from character input
|
|
extract_disk_value <- function(x) {
|
|
x <- as.character(x)
|
|
# normalise decimal separators
|
|
x <- gsub(",", ".", x, fixed = TRUE)
|
|
# strip known context: leading/trailing whitespace, SIR interpretations,
|
|
# comparison operators, semicolons, and surrounding whitespace
|
|
x <- trimws(x)
|
|
# remove trailing SIR interpretation (e.g., "42; S", "28 R")
|
|
x <- gsub("[;[:space:]]+[SIRsir]$", "", x)
|
|
# remove leading comparison operators (e.g., ">=20", "<=6")
|
|
x <- gsub("^[<>=]+\\s*", "", x)
|
|
x <- trimws(x)
|
|
# now the remainder must be a plausible standalone number
|
|
out <- rep(NA_real_, length(x))
|
|
is_numeric <- grepl("^[0-9]+\\.?[0-9]*$", x)
|
|
out[is_numeric] <- as.double(x[is_numeric])
|
|
out
|
|
}
|
|
|
|
# round up and coerce to integer
|
|
x <- as.integer(ceiling(extract_disk_value(x)))
|
|
# valid disk diffusion zones: 0-50 mm
|
|
x[x < 0 | x > 50] <- NA_integer_
|
|
|
|
na_after <- length(x[is.na(x)])
|
|
|
|
if (na_before != na_after) {
|
|
list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %pm>%
|
|
unique() %pm>%
|
|
sort() %pm>%
|
|
vector_and(quotes = TRUE)
|
|
cur_col <- get_current_column()
|
|
warning_("in {.help [{.fun as.disk}](AMR::as.disk)}: ", na_after - na_before, " result",
|
|
ifelse(na_after - na_before > 1, "s", ""),
|
|
ifelse(is.null(cur_col), "", paste0(" in column {.field ", font_bold(cur_col, collapse = NULL), "}")),
|
|
" truncated (",
|
|
round(((na_after - na_before) / length(x)) * 100),
|
|
"%) that were invalid disk zones: ",
|
|
list_missing,
|
|
call = FALSE
|
|
)
|
|
}
|
|
}
|
|
set_clean_class(as.integer(x),
|
|
new_class = c("disk", "integer")
|
|
)
|
|
}
|
|
|
|
all_valid_disks <- function(x) {
|
|
if (!inherits(x, c("disk", "character", "numeric", "integer"))) {
|
|
return(FALSE)
|
|
}
|
|
x_disk <- tryCatch(suppressWarnings(as.disk(x[!is.na(x)])),
|
|
error = function(e) NA
|
|
)
|
|
!anyNA(x_disk) && !all(is.na(x))
|
|
}
|
|
|
|
#' @rdname as.disk
|
|
#' @details `NA_disk_` is a missing value of the new `disk` class.
|
|
#' @export
|
|
NA_disk_ <- set_clean_class(as.integer(NA_real_),
|
|
new_class = c("disk", "integer")
|
|
)
|
|
|
|
#' @rdname as.disk
|
|
#' @export
|
|
is.disk <- function(x) {
|
|
inherits(x, "disk")
|
|
}
|
|
|
|
# this prevents the requirement for putting the dependency in Imports:
|
|
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, disk)
|
|
pillar_shaft.disk <- function(x, ...) {
|
|
out <- trimws(format(x))
|
|
out[is.na(x)] <- pillar::style_na(NA)
|
|
create_pillar_column(out, align = "right", width = 2)
|
|
}
|
|
|
|
#' @method print disk
|
|
#' @export
|
|
#' @noRd
|
|
print.disk <- function(x, ...) {
|
|
cat(format_inline_("Class {.cls disk}\n"))
|
|
print(as.integer(x), quote = FALSE)
|
|
}
|
|
|
|
#' @method [ disk
|
|
#' @export
|
|
#' @noRd
|
|
"[.disk" <- function(x, ...) {
|
|
y <- NextMethod()
|
|
attributes(y) <- attributes(x)
|
|
y
|
|
}
|
|
#' @method [[ disk
|
|
#' @export
|
|
#' @noRd
|
|
"[[.disk" <- function(x, ...) {
|
|
y <- NextMethod()
|
|
attributes(y) <- attributes(x)
|
|
y
|
|
}
|
|
#' @method [<- disk
|
|
#' @export
|
|
#' @noRd
|
|
"[<-.disk" <- function(i, j, ..., value) {
|
|
value <- as.disk(value)
|
|
y <- NextMethod()
|
|
attributes(y) <- attributes(i)
|
|
y
|
|
}
|
|
#' @method [[<- disk
|
|
#' @export
|
|
#' @noRd
|
|
"[[<-.disk" <- function(i, j, ..., value) {
|
|
value <- as.disk(value)
|
|
y <- NextMethod()
|
|
attributes(y) <- attributes(i)
|
|
y
|
|
}
|
|
#' @method c disk
|
|
#' @export
|
|
#' @noRd
|
|
c.disk <- function(...) {
|
|
as.disk(unlist(lapply(list(...), as.character)))
|
|
}
|
|
|
|
#' @method unique disk
|
|
#' @export
|
|
#' @noRd
|
|
unique.disk <- function(x, incomparables = FALSE, ...) {
|
|
y <- NextMethod()
|
|
attributes(y) <- attributes(x)
|
|
y
|
|
}
|
|
|
|
#' @method rep disk
|
|
#' @export
|
|
#' @noRd
|
|
rep.disk <- function(x, ...) {
|
|
y <- NextMethod()
|
|
attributes(y) <- attributes(x)
|
|
y
|
|
}
|
|
|
|
# this prevents the requirement for putting the dependency in Imports:
|
|
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(skimr::get_skimmers, disk)
|
|
get_skimmers.disk <- function(column) {
|
|
column <- as.integer(column)
|
|
skimr::sfl(
|
|
skim_type = "disk",
|
|
p0 = ~ stats::quantile(column, probs = 0, na.rm = TRUE, names = FALSE),
|
|
p25 = ~ stats::quantile(column, probs = 0.25, na.rm = TRUE, names = FALSE),
|
|
p50 = ~ stats::quantile(column, probs = 0.5, na.rm = TRUE, names = FALSE),
|
|
p75 = ~ stats::quantile(column, probs = 0.75, na.rm = TRUE, names = FALSE),
|
|
p100 = ~ stats::quantile(column, probs = 1, na.rm = TRUE, names = FALSE),
|
|
hist = ~ skimr::inline_hist(stats::na.omit(column), 10)
|
|
)
|
|
}
|