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

first edits

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2023-01-19 20:42:46 +01:00
parent 593d740b84
commit 3152f1a1ce
109 changed files with 1361 additions and 1327 deletions
Download Patch File Download Diff File Expand all files Collapse all files

57
R/aa_amr-package.R Executable file
View File

@ -0,0 +1,57 @@
# ==================================================================== #
# TITLE #
# AMR: An R Package for Working with Antimicrobial Resistance Data #
# #
# SOURCE #
# https://github.com/msberends/AMR #
# #
# CITE AS #
# Berends MS, Luz CF, Friedrich AW, Sinha BNM, Albers CJ, Glasner C #
# (2022). AMR: An R Package for Working with Antimicrobial Resistance #
# Data. Journal of Statistical Software, 104(3), 1-31. #
# doi: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/ #
# ==================================================================== #
#' The `AMR` Package
#'
#' @description
#' Welcome to the `AMR` package.
#'
#' The `AMR` package is a [free and open-source](https://msberends.github.io/AMR#copyright) R package with [zero dependencies](https://en.wikipedia.org/wiki/Dependency_hell) to simplify the analysis and prediction of Antimicrobial Resistance (AMR) and to work with microbial and antimicrobial data and properties, by using evidence-based methods. **Our aim is to provide a standard** for clean and reproducible AMR data analysis, that can therefore empower epidemiological analyses to continuously enable surveillance and treatment evaluation in any setting. [Many different researchers](https://msberends.github.io/AMR/authors.html) from around the globe are continually helping us to make this a successful and durable project!
#'
#' This work was published in the Journal of Statistical Software (Volume 104(3); [DOI 10.18637/jss.v104.i03](https://doi.org/10.18637/jss.v104.i03)) and formed the basis of two PhD theses ([DOI 10.33612/diss.177417131](https://doi.org/10.33612/diss.177417131) and [DOI 10.33612/diss.192486375](https://doi.org/10.33612/diss.192486375)).
#'
#' After installing this package, R knows [**`r format_included_data_number(AMR::microorganisms)`**](https://msberends.github.io/AMR/reference/microorganisms.html) (updated December 2022) and all [**~600 antibiotic, antimycotic and antiviral drugs**](https://msberends.github.io/AMR/reference/antibiotics.html) by name and code (including ATC, EARS-Net, ASIARS-Net, PubChem, LOINC and SNOMED CT), and knows all about valid SIR and MIC values. The integral breakpoint guidelines from CLSI and EUCAST are included from the last 10 years. It supports and can read any data format, including WHONET data. This package works on Windows, macOS and Linux with all versions of R since R-3.0 (April 2013). **It was designed to work in any setting, including those with very limited resources**. It was created for both routine data analysis and academic research at the Faculty of Medical Sciences of the [University of Groningen](https://www.rug.nl), in collaboration with non-profit organisations [Certe Medical Diagnostics and Advice Foundation](https://www.certe.nl) and [University Medical Center Groningen](https://www.umcg.nl).
#'
#' The `AMR` package is available in English, Chinese, Danish, Dutch, French, German, Greek, Italian, Japanese, Polish, Portuguese, Russian, Spanish, Swedish, Turkish and Ukrainian. Antimicrobial drug (group) names and colloquial microorganism names are provided in these languages.
#' @section Reference Data Publicly Available:
#' All data sets in this `AMR` package (about microorganisms, antibiotics, SIR interpretation, EUCAST rules, etc.) are publicly and freely available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. We also provide tab-separated plain text files that are machine-readable and suitable for input in any software program, such as laboratory information systems. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @source
#' To cite AMR in publications use:
#'
#' Berends MS, Luz CF, Friedrich AW, Sinha BNM, Albers CJ, Glasner C (2022). "AMR: An R Package for Working with Antimicrobial Resistance Data." _Journal of Statistical Software_, *104*(3), 1-31. \doi{10.18637/jss.v104.i03}.
#'
#' A BibTeX entry for LaTeX users is:
#'
#' \preformatted{
#' `r format(citation("AMR"), style = "bib")`
#' }
#' @name AMR
#' @keywords internal
#' @rdname AMR
"_PACKAGE"

58
R/deprecated.R → R/aa_deprecated.R
View File

@ -32,5 +32,59 @@
#' These functions are so-called '[Deprecated]'. **They will be removed in a future release.** Using the functions will give a warning with the name of the function it has been replaced by (if there is one).
#' @keywords internal
#' @name AMR-deprecated
# @export
NULL
#' @rdname AMR-deprecated
#' @export
as.rsi <- function(...) {
deprecation_warning("as.rsi", "as.sir")
as.sir(...)
}
#' @rdname AMR-deprecated
#' @export
is.rsi.eligible <- function(...) {
deprecation_warning("is.rsi.eligible", "is_sir_eligible")
is_sir_eligible(...)
}
# NAMESPACE NALOPEN
# will be exported using s3_register() in R/zzz.R
pillar_shaft.rsi <- function(x, ...) {
out <- trimws(format(x))
if (has_colour()) {
# colours will anyway not work when has_colour() == FALSE,
# but then the indentation should also not be applied
out[is.na(x)] <- font_grey(" NA")
out[x == "S"] <- font_green_bg(" S ")
out[x == "I"] <- font_orange_bg(" I ")
out[x == "R"] <- font_red_bg(" R ")
}
create_pillar_column(out, align = "left", width = 5)
}
type_sum.rsi <- function(x, ...) {
deprecation_warning("as.rsi", "as.sir", "Transform your old 'rsi' class to the new 'sir' with `as.sir()` using e.g.:\n your_data %>% mutate_if(~inherits(.x, \"rsi\"), as.sir)")
"rsi"
}
#' @method print rsi
#' @export
#' @noRd
print.rsi <- function(x, ...) {
deprecation_warning("as.rsi", "as.sir", "Transform your old 'rsi' class to the new 'sir' with `as.sir()`")
print(x, ...)
}
deprecation_warning <- function(old, new = NULL, extra_msg = NULL) {
env <- paste0("deprecated_", old)
if (!env %in% names(AMR_env)) {
AMR_env[[paste0("deprecated_", old)]] <- 1
warning_(ifelse(is.null(new),
paste0("The `", old, "()` function is no longer in use"),
paste0("The `", old, "()` function has been replaced with `", new, "()`")),
", see `?AMR-deprecated`.",
ifelse(!is.null(extra_msg),
paste0(" ", extra_msg),
""),
"\nThis warning will be shown once per session.")
}
}

6
R/aa_globals.R
View File

@ -27,7 +27,7 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
# add new version numbers here, and add the rules themselves to "data-raw/eucast_rules.tsv" and rsi_translation
# add new version numbers here, and add the rules themselves to "data-raw/eucast_rules.tsv" and clinical_breakpoints
# (sourcing "data-raw/_pre_commit_hook.R" will process the TSV file)
EUCAST_VERSION_BREAKPOINTS <- list(
"12.0" = list(
@ -148,8 +148,8 @@ globalVariables(c(
"reference.rule_group",
"reference.version",
"rowid",
"rsi",
"rsi_translation",
"sir",
"clinical_breakpoints",
"rule_group",
"rule_name",
"se_max",

14
R/aa_helper_functions.R
View File

@ -515,7 +515,7 @@ stop_ <- function(..., call = TRUE) {
if (isTRUE(call)) {
call <- as.character(sys.call(-1)[1])
} else {
# so you can go back more than 1 call, as used in rsi_calc(), that now throws a reference to e.g. n_rsi()
# so you can go back more than 1 call, as used in sir_calc(), that now throws a reference to e.g. n_sir()
call <- as.character(sys.call(call)[1])
}
msg <- paste0("in ", call, "(): ", msg)
@ -626,7 +626,7 @@ create_eucast_ab_documentation <- function() {
# separate drugs, such as `AMX`
val <- as.ab(val)
} else {
val <- as.rsi(NA)
val <- as.sir(NA)
}
ab <- c(ab, val)
}
@ -666,7 +666,7 @@ vector_or <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, initial_ca
return(paste0(quotes, v, quotes))
}
if (identical(v, c("I", "R", "S"))) {
# class 'rsi' should be sorted like this
# class 'sir' should be sorted like this
v <- c("R", "S", "I")
}
# all commas except for last item, so will become '"val1", "val2", "val3" or "val4"'
@ -710,7 +710,7 @@ format_class <- function(class, plural = FALSE) {
if ("custom_eucast_rules" %in% class) {
class <- "input created with `custom_eucast_rules()`"
}
if (any(c("mo", "ab", "rsi") %in% class)) {
if (any(c("mo", "ab", "sir") %in% class)) {
class <- paste0("of class <", class[1L], ">")
}
class[class == class.bak] <- paste0("of class <", class[class == class.bak], ">")
@ -1140,18 +1140,18 @@ font_grey_bg <- function(..., collapse = " ") {
}
}
font_red_bg <- function(..., collapse = " ") {
# this is #ed553b (picked to be colourblind-safe with other RSI colours)
# this is #ed553b (picked to be colourblind-safe with other SIR colours)
try_colour(font_black(..., collapse = collapse), before = "\033[48;5;203m", after = "\033[49m", collapse = collapse)
}
font_orange_bg <- function(..., collapse = " ") {
# this is #f6d55c (picked to be colourblind-safe with other RSI colours)
# this is #f6d55c (picked to be colourblind-safe with other SIR colours)
try_colour(font_black(..., collapse = collapse), before = "\033[48;5;222m", after = "\033[49m", collapse = collapse)
}
font_yellow_bg <- function(..., collapse = " ") {
try_colour(font_black(..., collapse = collapse), before = "\033[48;5;228m", after = "\033[49m", collapse = collapse)
}
font_green_bg <- function(..., collapse = " ") {
# this is #3caea3 (picked to be colourblind-safe with other RSI colours)
# this is #3caea3 (picked to be colourblind-safe with other SIR colours)
try_colour(font_black(..., collapse = collapse), before = "\033[48;5;79m", after = "\033[49m", collapse = collapse)
}
font_purple_bg <- function(..., collapse = " ") {

6
R/ab.R
View File

@ -88,9 +88,9 @@
#' \donttest{
#' if (require("dplyr")) {
#'
#' # you can quickly rename 'rsi' columns using set_ab_names() with dplyr:
#' # you can quickly rename 'sir' columns using set_ab_names() with dplyr:
#' example_isolates %>%
#' set_ab_names(where(is.rsi), property = "atc")
#' set_ab_names(where(is.sir), property = "atc")
#' }
#' }
as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
@ -632,7 +632,7 @@ rep.ab <- function(x, ...) {
generalise_antibiotic_name <- function(x) {
x <- toupper(x)
# remove suffices
x <- gsub("_(MIC|RSI|DIS[CK])$", "", x, perl = TRUE)
x <- gsub("_(MIC|RSI|SIR|DIS[CK])$", "", x, perl = TRUE)
# remove disk concentrations, like LVX_NM -> LVX
x <- gsub("_[A-Z]{2}[0-9_.]{0,3}$", "", x, perl = TRUE)
# remove part between brackets if that's followed by another string

4
R/ab_property.R
View File

@ -116,7 +116,7 @@
#' head()
#'
#' example_isolates %>%
#' set_ab_names(where(is.rsi)) %>%
#' set_ab_names(where(is.sir)) %>%
#' colnames()
#'
#' example_isolates %>%
@ -372,7 +372,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
} else {
df <- data
}
vars <- get_column_abx(df, info = FALSE, only_rsi_columns = FALSE, sort = FALSE, fn = "set_ab_names")
vars <- get_column_abx(df, info = FALSE, only_sir_columns = FALSE, sort = FALSE, fn = "set_ab_names")
if (length(vars) == 0) {
message_("No columns with antibiotic results found for `set_ab_names()`, leaving names unchanged.")
return(data)

186
R/ab_selectors.R
View File

@ -32,7 +32,7 @@
#' These functions allow for filtering rows and selecting columns based on antibiotic test results that are of a specific antibiotic class or group, without the need to define the columns or antibiotic abbreviations. In short, if you have a column name that resembles an antimicrobial drug, it will be picked up by any of these functions that matches its pharmaceutical class: "cefazolin", "CZO" and "J01DB04" will all be picked up by [cephalosporins()].
#' @param ab_class an antimicrobial class or a part of it, such as `"carba"` and `"carbapenems"`. The columns `group`, `atc_group1` and `atc_group2` of the [antibiotics] data set will be searched (case-insensitive) for this value.
#' @param filter an [expression] to be evaluated in the [antibiotics] data set, such as `name %like% "trim"`
#' @param only_rsi_columns a [logical] to indicate whether only columns of class `rsi` must be selected (defaults to `FALSE`), see [as.rsi()]
#' @param only_sir_columns a [logical] to indicate whether only columns of class `sir` must be selected (defaults to `FALSE`), see [as.sir()]
#' @param only_treatable a [logical] to indicate whether antimicrobial drugs should be excluded that are only for laboratory tests (defaults to `TRUE`), such as gentamicin-high (`GEH`) and imipenem/EDTA (`IPE`)
#' @param ... ignored, only in place to allow future extensions
#' @details
@ -188,23 +188,23 @@
#' }
#' }
ab_class <- function(ab_class,
only_rsi_columns = FALSE,
only_sir_columns = FALSE,
only_treatable = TRUE,
...) {
meet_criteria(ab_class, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
ab_select_exec(NULL, only_rsi_columns = only_rsi_columns, ab_class_args = ab_class, only_treatable = only_treatable)
ab_select_exec(NULL, only_sir_columns = only_sir_columns, ab_class_args = ab_class, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
#' @details The [ab_selector()] function can be used to internally filter the [antibiotics] data set on any results, see *Examples*. It allows for filtering on a (part of) a certain name, and/or a group name or even a minimum of DDDs for oral treatment. This function yields the highest flexibility, but is also the least user-friendly, since it requires a hard-coded filter to set.
#' @export
ab_selector <- function(filter,
only_rsi_columns = FALSE,
only_sir_columns = FALSE,
only_treatable = TRUE,
...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
# get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
@ -212,7 +212,7 @@ ab_selector <- function(filter,
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
info = FALSE, only_sir_columns = only_sir_columns,
sort = FALSE, fn = "ab_selector"
)
call <- substitute(filter)
@ -234,194 +234,194 @@ ab_selector <- function(filter,
#' @rdname antibiotic_class_selectors
#' @export
aminoglycosides <- function(only_rsi_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
aminoglycosides <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
ab_select_exec("aminoglycosides", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
ab_select_exec("aminoglycosides", only_sir_columns = only_sir_columns, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
#' @export
aminopenicillins <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("aminopenicillins", only_rsi_columns = only_rsi_columns)
aminopenicillins <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("aminopenicillins", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
antifungals <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("antifungals", only_rsi_columns = only_rsi_columns)
antifungals <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("antifungals", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
antimycobacterials <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("antimycobacterials", only_rsi_columns = only_rsi_columns)
antimycobacterials <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("antimycobacterials", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
betalactams <- function(only_rsi_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
betalactams <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
ab_select_exec("betalactams", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
ab_select_exec("betalactams", only_sir_columns = only_sir_columns, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
#' @export
carbapenems <- function(only_rsi_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
carbapenems <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
ab_select_exec("carbapenems", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
ab_select_exec("carbapenems", only_sir_columns = only_sir_columns, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins", only_rsi_columns = only_rsi_columns)
cephalosporins <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_1st <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins_1st", only_rsi_columns = only_rsi_columns)
cephalosporins_1st <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins_1st", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_2nd <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins_2nd", only_rsi_columns = only_rsi_columns)
cephalosporins_2nd <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins_2nd", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_3rd <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins_3rd", only_rsi_columns = only_rsi_columns)
cephalosporins_3rd <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins_3rd", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_4th <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins_4th", only_rsi_columns = only_rsi_columns)
cephalosporins_4th <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins_4th", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_5th <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins_5th", only_rsi_columns = only_rsi_columns)
cephalosporins_5th <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("cephalosporins_5th", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
fluoroquinolones <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("fluoroquinolones", only_rsi_columns = only_rsi_columns)
fluoroquinolones <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("fluoroquinolones", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
glycopeptides <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("glycopeptides", only_rsi_columns = only_rsi_columns)
glycopeptides <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("glycopeptides", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
lincosamides <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("lincosamides", only_rsi_columns = only_rsi_columns)
lincosamides <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("lincosamides", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
lipoglycopeptides <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("lipoglycopeptides", only_rsi_columns = only_rsi_columns)
lipoglycopeptides <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("lipoglycopeptides", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
macrolides <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("macrolides", only_rsi_columns = only_rsi_columns)
macrolides <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("macrolides", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
oxazolidinones <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("oxazolidinones", only_rsi_columns = only_rsi_columns)
oxazolidinones <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("oxazolidinones", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
penicillins <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("penicillins", only_rsi_columns = only_rsi_columns)
penicillins <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("penicillins", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
polymyxins <- function(only_rsi_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
polymyxins <- function(only_sir_columns = FALSE, only_treatable = TRUE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
ab_select_exec("polymyxins", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
ab_select_exec("polymyxins", only_sir_columns = only_sir_columns, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
#' @export
streptogramins <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("streptogramins", only_rsi_columns = only_rsi_columns)
streptogramins <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("streptogramins", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
quinolones <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("quinolones", only_rsi_columns = only_rsi_columns)
quinolones <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("quinolones", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
tetracyclines <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("tetracyclines", only_rsi_columns = only_rsi_columns)
tetracyclines <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("tetracyclines", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
trimethoprims <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("trimethoprims", only_rsi_columns = only_rsi_columns)
trimethoprims <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("trimethoprims", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
ureidopenicillins <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("ureidopenicillins", only_rsi_columns = only_rsi_columns)
ureidopenicillins <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
ab_select_exec("ureidopenicillins", only_sir_columns = only_sir_columns)
}
#' @rdname antibiotic_class_selectors
#' @details The [administrable_per_os()] and [administrable_iv()] functions also rely on the [antibiotics] data set - antibiotic columns will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the [antibiotics] data set.
#' @export
administrable_per_os <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
administrable_per_os <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
# get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
info = FALSE, only_sir_columns = only_sir_columns,
sort = FALSE, fn = "administrable_per_os"
)
agents_all <- AMR_env$AB_lookup[which(!is.na(AMR_env$AB_lookup$oral_ddd)), "ab", drop = TRUE]
@ -452,14 +452,14 @@ administrable_per_os <- function(only_rsi_columns = FALSE, ...) {
#' @rdname antibiotic_class_selectors
#' @export
administrable_iv <- function(only_rsi_columns = FALSE, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
administrable_iv <- function(only_sir_columns = FALSE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
# get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
info = FALSE, only_sir_columns = only_sir_columns,
sort = FALSE, fn = "administrable_iv"
)
agents_all <- AMR_env$AB_lookup[which(!is.na(AMR_env$AB_lookup$iv_ddd)), "ab", drop = TRUE]
@ -480,14 +480,14 @@ administrable_iv <- function(only_rsi_columns = FALSE, ...) {
#' @inheritParams eucast_rules
#' @details The [not_intrinsic_resistant()] function can be used to only select antibiotic columns that pose no intrinsic resistance for the microorganisms in the data set. For example, if a data set contains only microorganism codes or names of *E. coli* and *K. pneumoniae* and contains a column "vancomycin", this column will be removed (or rather, unselected) using this function. It currently applies `r format_eucast_version_nr(names(EUCAST_VERSION_EXPERT_RULES[length(EUCAST_VERSION_EXPERT_RULES)]))` to determine intrinsic resistance, using the [eucast_rules()] function internally. Because of this determination, this function is quite slow in terms of performance.
#' @export
not_intrinsic_resistant <- function(only_rsi_columns = FALSE, col_mo = NULL, version_expertrules = 3.3, ...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, version_expertrules = 3.3, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
# get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
info = FALSE, only_sir_columns = only_sir_columns,
sort = FALSE, fn = "not_intrinsic_resistant"
)
# intrinsic vars
@ -530,7 +530,7 @@ not_intrinsic_resistant <- function(only_rsi_columns = FALSE, col_mo = NULL, ver
}
ab_select_exec <- function(function_name,
only_rsi_columns = FALSE,
only_sir_columns = FALSE,
only_treatable = FALSE,
ab_class_args = NULL) {
# get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
@ -538,7 +538,7 @@ ab_select_exec <- function(function_name,
vars_df <- get_current_data(arg_name = NA, call = -3)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
info = FALSE, only_sir_columns = only_sir_columns,
sort = FALSE, fn = function_name
)

2
R/age.R
View File

@ -172,7 +172,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
#' filter(mo == as.mo("Escherichia coli")) %>%
#' group_by(age_group = age_groups(age)) %>%
#' select(age_group, CIP) %>%
#' ggplot_rsi(
#' ggplot_sir(
#' x = "age_group",
#' minimum = 0,
#' x.title = "Age Group",

76
R/amr.R
View File

@ -1,76 +0,0 @@
# ==================================================================== #
# TITLE #
# AMR: An R Package for Working with Antimicrobial Resistance Data #
# #
# SOURCE #
# https://github.com/msberends/AMR #
# #
# CITE AS #
# Berends MS, Luz CF, Friedrich AW, Sinha BNM, Albers CJ, Glasner C #
# (2022). AMR: An R Package for Working with Antimicrobial Resistance #
# Data. Journal of Statistical Software, 104(3), 1-31. #
# doi: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/ #
# ==================================================================== #
#' The `AMR` Package
#'
#' @description
#' Welcome to the `AMR` package.
#'
#' `AMR` is a free, open-source and independent \R package to simplify the analysis and prediction of Antimicrobial Resistance (AMR) and to work with microbial and antimicrobial data and properties, by using evidence-based methods. Our aim is to provide a standard for clean and reproducible antimicrobial resistance data analysis, that can therefore empower epidemiological analyses to continuously enable surveillance and treatment evaluation in any setting.
#'
#' This work was published in the Journal of Statistical Software (Volume 104(3); \doi{10.18637/jss.v104.i03}) and formed the basis of two PhD theses (\doi{10.33612/diss.177417131} and \doi{10.33612/diss.192486375}).
#'
#' After installing this package, \R knows `r format_included_data_number(microorganisms)` distinct microbial species and all `r format_included_data_number(rbind(antibiotics[, "name", drop = FALSE], antivirals[, "name", drop = FALSE]))` antibiotic, antimycotic and antiviral drugs by name and code (including ATC, EARS-NET, LOINC and SNOMED CT), and knows all about valid R/SI and MIC values. It supports any data format, including WHONET/EARS-Net data.
#'
#' This package is fully independent of any other \R package and works on Windows, macOS and Linux with all versions of \R since R-3.0.0 (April 2013). It was designed to work in any setting, including those with very limited resources. It was created for both routine data analysis and academic research at the Faculty of Medical Sciences of the University of Groningen, in collaboration with non-profit organisations Certe Medical Diagnostics and Advice and University Medical Center Groningen. This \R package is actively maintained and free software; you can freely use and distribute it for both personal and commercial (but not patent) purposes under the terms of the GNU General Public License version 2.0 (GPL-2), as published by the Free Software Foundation.
#'
#' This package can be used for:
#' - Reference for the taxonomy of microorganisms, since the package contains all microbial (sub)species from the List of Prokaryotic names with Standing in Nomenclature (LPSN) and the Global Biodiversity Information Facility (GBIF)
#' - Interpreting raw MIC and disk diffusion values, based on any CLSI or EUCAST guideline from the last 10 years
#' - Retrieving antimicrobial drug names, doses and forms of administration from clinical health care records
#' - Determining first isolates to be used for AMR data analysis
#' - Calculating antimicrobial resistance
#' - Determining multi-drug resistance (MDR) / multi-drug resistant organisms (MDRO)
#' - Calculating (empirical) susceptibility of both mono therapy and combination therapies
#' - Predicting future antimicrobial resistance using regression models
#' - Getting properties for any microorganism (such as Gram stain, species, genus or family)
#' - Getting properties for any antibiotic (such as name, code of EARS-Net/ATC/LOINC/PubChem, defined daily dose or trade name)
#' - Plotting antimicrobial resistance
#' - Applying EUCAST expert rules
#' - Getting SNOMED codes of a microorganism, or getting properties of a microorganism based on a SNOMED code
#' - Getting LOINC codes of an antibiotic, or getting properties of an antibiotic based on a LOINC code
#' - Machine reading the EUCAST and CLSI guidelines from 2011-2020 to translate MIC values and disk diffusion diameters to R/SI
#' - Principal component analysis for AMR
#'
#' @section Reference Data Publicly Available:
#' All data sets in this `AMR` package (about microorganisms, antibiotics, R/SI interpretation, EUCAST rules, etc.) are publicly and freely available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. We also provide tab-separated plain text files that are machine-readable and suitable for input in any software program, such as laboratory information systems. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @source
#' To cite AMR in publications use:
#'
#' Berends MS, Luz CF, Friedrich AW, Sinha BNM, Albers CJ, Glasner C (2022). "AMR: An R Package for Working with Antimicrobial Resistance Data." _Journal of Statistical Software_, *104*(3), 1-31. \doi{10.18637/jss.v104.i03}.
#'
#' A BibTeX entry for LaTeX users is:
#'
#' \preformatted{
#' `r format(citation("AMR"), style = "bib")`
#' }
#' @name AMR
#' @keywords internal
#' @rdname AMR
"_PACKAGE"

4
R/availability.R
View File

@ -41,7 +41,7 @@
#' if (require("dplyr")) {
#' example_isolates %>%
#' filter(mo == as.mo("Escherichia coli")) %>%
#' select_if(is.rsi) %>%
#' select_if(is.sir) %>%
#' availability()
#' }
#' }
@ -55,7 +55,7 @@ availability <- function(tbl, width = NULL) {
1 - sum(is.na(x)) / length(x)
})
n <- vapply(FUN.VALUE = double(1), tbl, function(x) length(x[!is.na(x)]))
R <- vapply(FUN.VALUE = double(1), tbl, function(x) ifelse(is.rsi(x), resistance(x, minimum = 0), NA_real_))
R <- vapply(FUN.VALUE = double(1), tbl, function(x) ifelse(is.sir(x), resistance(x, minimum = 0), NA_real_))
R_print <- character(length(R))
R_print[!is.na(R)] <- percentage(R[!is.na(R)])
R_print[is.na(R)] <- ""

12
R/bug_drug_combinations.R
View File

@ -37,7 +37,7 @@
#' @param FUN the function to call on the `mo` column to transform the microorganism codes, defaults to [mo_shortname()]
#' @param translate_ab a [character] of length 1 containing column names of the [antibiotics] data set
#' @param ... arguments passed on to `FUN`
#' @inheritParams rsi_df
#' @inheritParams sir_sf
#' @inheritParams base::formatC
#' @details The function [format()] calculates the resistance per bug-drug combination. Use `combine_SI = TRUE` (default) to test R vs. S+I and `combine_SI = FALSE` to test R+I vs. S.
#' @export
@ -67,7 +67,7 @@ bug_drug_combinations <- function(x,
col_mo = NULL,
FUN = mo_shortname,
...) {
meet_criteria(x, allow_class = "data.frame", contains_column_class = "rsi")
meet_criteria(x, allow_class = "data.frame", contains_column_class = "sir")
meet_criteria(col_mo, allow_class = "character", is_in = colnames(x), has_length = 1, allow_NULL = TRUE)
meet_criteria(FUN, allow_class = "function", has_length = 1)
@ -90,10 +90,10 @@ bug_drug_combinations <- function(x,
if (is_null_or_grouped_tbl(x.bak)) {
data_has_groups <- TRUE
groups <- setdiff(names(attributes(x.bak)$groups), ".rows")
x <- x[, c(groups, col_mo, colnames(x)[vapply(FUN.VALUE = logical(1), x, is.rsi)]), drop = FALSE]
x <- x[, c(groups, col_mo, colnames(x)[vapply(FUN.VALUE = logical(1), x, is.sir)]), drop = FALSE]
} else {
data_has_groups <- FALSE
x <- x[, c(col_mo, names(which(vapply(FUN.VALUE = logical(1), x, is.rsi)))), drop = FALSE]
x <- x[, c(col_mo, names(which(vapply(FUN.VALUE = logical(1), x, is.sir)))), drop = FALSE]
}
run_it <- function(x) {
@ -113,8 +113,8 @@ bug_drug_combinations <- function(x,
}
for (i in seq_len(length(unique_mo))) {
# filter on MO group and only select R/SI columns
x_mo_filter <- x[which(x[, col_mo, drop = TRUE] == unique_mo[i]), names(which(vapply(FUN.VALUE = logical(1), x, is.rsi))), drop = FALSE]
# filter on MO group and only select SIR columns
x_mo_filter <- x[which(x[, col_mo, drop = TRUE] == unique_mo[i]), names(which(vapply(FUN.VALUE = logical(1), x, is.sir))), drop = FALSE]
# turn and merge everything
pivot <- lapply(x_mo_filter, function(x) {
m <- as.matrix(table(x))

56
R/count.R
View File

@ -32,16 +32,16 @@
#' @description These functions can be used to count resistant/susceptible microbial isolates. All functions support quasiquotation with pipes, can be used in `summarise()` from the `dplyr` package and also support grouped variables, see *Examples*.
#'
#' [count_resistant()] should be used to count resistant isolates, [count_susceptible()] should be used to count susceptible isolates.
#' @param ... one or more vectors (or columns) with antibiotic interpretations. They will be transformed internally with [as.rsi()] if needed.
#' @param ... one or more vectors (or columns) with antibiotic interpretations. They will be transformed internally with [as.sir()] if needed.
#' @inheritParams proportion
#' @inheritSection as.rsi Interpretation of R and S/I
#' @inheritSection as.sir Interpretation of R and S/I
#' @details These functions are meant to count isolates. Use the [resistance()]/[susceptibility()] functions to calculate microbial resistance/susceptibility.
#'
#' The function [count_resistant()] is equal to the function [count_R()]. The function [count_susceptible()] is equal to the function [count_SI()].
#'
#' The function [n_rsi()] is an alias of [count_all()]. They can be used to count all available isolates, i.e. where all input antibiotics have an available result (S, I or R). Their use is equal to `n_distinct()`. Their function is equal to `count_susceptible(...) + count_resistant(...)`.
#' The function [n_sir()] is an alias of [count_all()]. They can be used to count all available isolates, i.e. where all input antibiotics have an available result (S, I or R). Their use is equal to `n_distinct()`. Their function is equal to `count_susceptible(...) + count_resistant(...)`.
#'
#' The function [count_df()] takes any variable from `data` that has an [`rsi`] class (created with [as.rsi()]) and counts the number of S's, I's and R's. It also supports grouped variables. The function [rsi_df()] works exactly like [count_df()], but adds the percentage of S, I and R.
#' The function [count_df()] takes any variable from `data` that has an [`sir`] class (created with [as.sir()]) and counts the number of S's, I's and R's. It also supports grouped variables. The function [sir_sf()] works exactly like [count_df()], but adds the percentage of S, I and R.
#' @inheritSection proportion Combination Therapy
#' @seealso [`proportion_*`][proportion] to calculate microbial resistance and susceptibility.
#' @return An [integer]
@ -66,14 +66,14 @@
#'
#' # Count all available isolates
#' count_all(example_isolates$AMX)
#' n_rsi(example_isolates$AMX)
#' n_sir(example_isolates$AMX)
#'
#' # n_rsi() is an alias of count_all().
#' # n_sir() is an alias of count_all().
#' # Since it counts all available isolates, you can
#' # calculate back to count e.g. susceptible isolates.
#' # These results are the same:
#' count_susceptible(example_isolates$AMX)
#' susceptibility(example_isolates$AMX) * n_rsi(example_isolates$AMX)
#' susceptibility(example_isolates$AMX) * n_sir(example_isolates$AMX)
#'
#' # dplyr -------------------------------------------------------------
#' \donttest{
@ -85,7 +85,7 @@
#' I = count_I(CIP),
#' S = count_S(CIP),
#' n1 = count_all(CIP), # the actual total; sum of all three
#' n2 = n_rsi(CIP), # same - analogous to n_distinct
#' n2 = n_sir(CIP), # same - analogous to n_distinct
#' total = n()
#' ) # NOT the number of tested isolates!
#'
@ -93,7 +93,7 @@
#' # (i.e., in this data set columns GEN, TOB, AMK, KAN)
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(across(aminoglycosides(), n_rsi))
#' summarise(across(aminoglycosides(), n_sir))
#'
#' # Count co-resistance between amoxicillin/clav acid and gentamicin,
#' # so we can see that combination therapy does a lot more than mono therapy.
@ -121,12 +121,12 @@
#' }
count_resistant <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = "R",
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -134,12 +134,12 @@ count_resistant <- function(..., only_all_tested = FALSE) {
#' @export
count_susceptible <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = c("S", "I"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -147,12 +147,12 @@ count_susceptible <- function(..., only_all_tested = FALSE) {
#' @export
count_R <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = "R",
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -163,12 +163,12 @@ count_IR <- function(..., only_all_tested = FALSE) {
message_("Using `count_IR()` is discouraged; use `count_resistant()` instead to not consider \"I\" being resistant. This note will be shown once for this session.", as_note = FALSE)
}
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = c("I", "R"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -176,12 +176,12 @@ count_IR <- function(..., only_all_tested = FALSE) {
#' @export
count_I <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = "I",
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -189,12 +189,12 @@ count_I <- function(..., only_all_tested = FALSE) {
#' @export
count_SI <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = c("S", "I"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -205,12 +205,12 @@ count_S <- function(..., only_all_tested = FALSE) {
message_("Using `count_S()` is discouraged; use `count_susceptible()` instead to also consider \"I\" being susceptible. This note will be shown once for this session.", as_note = FALSE)
}
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = "S",
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -218,18 +218,18 @@ count_S <- function(..., only_all_tested = FALSE) {
#' @export
count_all <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = c("S", "I", "R"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
#' @rdname count
#' @export
n_rsi <- count_all
n_sir <- count_all
#' @rdname count
#' @export
@ -238,7 +238,7 @@ count_df <- function(data,
language = get_AMR_locale(),
combine_SI = TRUE) {
tryCatch(
rsi_calc_df(
sir_calc_df(
type = "count",
data = data,
translate_ab = translate_ab,
@ -246,6 +246,6 @@ count_df <- function(data,
combine_SI = combine_SI,
confidence_level = 0.95 # doesn't matter, will be removed
),
error = function(e) stop_(gsub("in rsi_calc_df(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc_df(): ", "", e$message, fixed = TRUE), call = -5)
)
}

4
R/custom_antimicrobials.R
View File

@ -112,8 +112,8 @@
#' # even antibiotic selectors work
#' x <- data.frame(
#' random_column = "some value",
#' coflu = as.rsi("S"),
#' ampicillin = as.rsi("R")
#' coflu = as.sir("S"),
#' ampicillin = as.sir("R")
#' )
#' x
#' x[, betalactams()]

8
R/custom_eucast_rules.R
View File

@ -61,9 +61,9 @@
#'
#' ```r
#' df <- data.frame(mo = c("Escherichia coli", "Klebsiella pneumoniae"),
#' TZP = as.rsi("R"),
#' ampi = as.rsi("S"),
#' cipro = as.rsi("S"))
#' TZP = as.sir("R"),
#' ampi = as.sir("S"),
#' cipro = as.sir("S"))
#' df
#' #> mo TZP ampi cipro
#' #> 1 Escherichia coli R S S
@ -184,7 +184,7 @@ custom_eucast_rules <- function(...) {
result_value %in% c("R", "S", "I", NA),
"the resulting value of rule ", i, " must be either \"R\", \"S\", \"I\" or NA"
)
result_value <- as.rsi(result_value)
result_value <- as.sir(result_value)
out[[i]]$result_group <- result_group
out[[i]]$result_value <- result_value

2
R/custom_microorganisms.R
View File

@ -37,7 +37,7 @@
#'
#' There are two ways to automate this process:
#'
#' **Method 1:** Using the [option `AMR_custom_mo`][AMR-options], which is the preferred method. To use this method:
#' **Method 1:** Using the option [`AMR_custom_mo`][AMR-options], which is the preferred method. To use this method:
#'
#' 1. Create a data set in the structure of the [microorganisms] data set (containing at the very least column "genus") and save it with [saveRDS()] to a location of choice, e.g. `"~/my_custom_mo.rds"`, or any remote location.
#'

18
R/data.R
View File

@ -173,7 +173,7 @@
#' - `gender`\cr Gender of the patient, either `r vector_or(example_isolates$gender)`
#' - `ward`\cr Ward type where the patient was admitted, either `r vector_or(example_isolates$ward)`
#' - `mo`\cr ID of microorganism created with [as.mo()], see also the [microorganisms] data set
#' - `PEN:RIF`\cr `r sum(vapply(FUN.VALUE = logical(1), example_isolates, is.rsi))` different antibiotics with class [`rsi`] (see [as.rsi()]); these column names occur in the [antibiotics] data set and can be translated with [set_ab_names()] or [ab_name()]
#' - `PEN:RIF`\cr `r sum(vapply(FUN.VALUE = logical(1), example_isolates, is.sir))` different antibiotics with class [`sir`] (see [as.sir()]); these column names occur in the [antibiotics] data set and can be translated with [set_ab_names()] or [ab_name()]
#' @details
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @examples
@ -188,7 +188,7 @@
#' - `date`\cr date of receipt at the laboratory
#' - `hospital`\cr ID of the hospital, from A to C
#' - `bacteria`\cr info about microorganism that can be transformed with [as.mo()], see also [microorganisms]
#' - `AMX:GEN`\cr 4 different antibiotics that have to be transformed with [as.rsi()]
#' - `AMX:GEN`\cr 4 different antibiotics that have to be transformed with [as.sir()]
#' @details
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @examples
@ -224,19 +224,19 @@
#' - `Inducible clindamycin resistance`\cr Clindamycin can be induced?
#' - `Comment`\cr Other comments
#' - `Date of data entry`\cr [Date] this data was entered in WHONET
#' - `AMP_ND10:CIP_EE`\cr `r sum(vapply(FUN.VALUE = logical(1), WHONET, is.rsi))` different antibiotics. You can lookup the abbreviations in the [antibiotics] data set, or use e.g. [`ab_name("AMP")`][ab_name()] to get the official name immediately. Before analysis, you should transform this to a valid antibiotic class, using [as.rsi()].
#' - `AMP_ND10:CIP_EE`\cr `r sum(vapply(FUN.VALUE = logical(1), WHONET, is.sir))` different antibiotics. You can lookup the abbreviations in the [antibiotics] data set, or use e.g. [`ab_name("AMP")`][ab_name()] to get the official name immediately. Before analysis, you should transform this to a valid antibiotic class, using [as.sir()].
#' @details
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @examples
#' WHONET
"WHONET"
#' Data Set for R/SI Interpretation
#' Data Set with Clinical Breakpoints for SIR Interpretation
#'
#' Data set containing reference data to interpret MIC and disk diffusion to R/SI values, according to international guidelines. Currently implemented guidelines are EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`). Use [as.rsi()] to transform MICs or disks measurements to R/SI values.
#' @format A [tibble][tibble::tibble] with `r format(nrow(rsi_translation), big.mark = ",")` observations and `r ncol(rsi_translation)` variables:
#' Data set containing clinical breakpoints to interpret MIC and disk diffusion to SIR values, according to international guidelines. Currently implemented guidelines are EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`). Use [as.sir()] to transform MICs or disks measurements to SIR values.
#' @format A [tibble][tibble::tibble] with `r format(nrow(clinical_breakpoints), big.mark = ",")` observations and `r ncol(clinical_breakpoints)` variables:
#' - `guideline`\cr Name of the guideline
#' - `method`\cr Either `r vector_or(rsi_translation$method)`
#' - `method`\cr Either `r vector_or(clinical_breakpoints$method)`
#' - `site`\cr Body site, e.g. "Oral" or "Respiratory"
#' - `mo`\cr Microbial ID, see [as.mo()]
#' - `rank_index`\cr Taxonomic rank index of `mo` from 1 (subspecies/infraspecies) to 5 (unknown microorganism)
@ -252,8 +252,8 @@
#' They **allow for machine reading EUCAST and CLSI guidelines**, which is almost impossible with the MS Excel and PDF files distributed by EUCAST and CLSI.
#' @seealso [intrinsic_resistant]
#' @examples
#' rsi_translation
"rsi_translation"
#' clinical_breakpoints
"clinical_breakpoints"
#' Data Set with Bacterial Intrinsic Resistance
#'

10
R/disk.R
View File

@ -33,13 +33,13 @@
#' @rdname as.disk
#' @param x vector
#' @param na.rm a [logical] indicating whether missing values should be removed
#' @details Interpret disk values as RSI values with [as.rsi()]. It supports guidelines from EUCAST and CLSI.
#' @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 6 and 50 millimetres. Values higher than 50 but lower than 100 will be maximised to 50. All others input values outside the 6-50 range will return `NA`.
#' @return An [integer] with additional class [`disk`]
#' @aliases disk
#' @export
#' @seealso [as.rsi()]
#' @seealso [as.sir()]
#' @examples
#' # transform existing disk zones to the `disk` class (using base R)
#' df <- data.frame(
@ -59,8 +59,8 @@
#' }
#' }
#'
#' # interpret disk values, see ?as.rsi
#' as.rsi(
#' # 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()
@ -68,7 +68,7 @@
#' )
#'
#' # interpret whole data set, pretend to be all from urinary tract infections:
#' as.rsi(df, uti = TRUE)
#' as.sir(df, uti = TRUE)
as.disk <- function(x, na.rm = FALSE) {
meet_criteria(x, allow_class = c("disk", "character", "numeric", "integer"), allow_NA = TRUE)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)

84
R/eucast_rules.R
View File

@ -69,11 +69,11 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' @param ... column name of an antibiotic, see section *Antibiotics* below
#' @param ab any (vector of) text that can be coerced to a valid antibiotic drug code with [as.ab()]
#' @param administration route of administration, either `r vector_or(dosage$administration)`
#' @param only_rsi_columns a [logical] to indicate whether only antibiotic columns must be detected that were transformed to class `rsi` (see [as.rsi()]) on beforehand (defaults to `FALSE`)
#' @param only_sir_columns a [logical] to indicate whether only antibiotic columns must be detected that were transformed to class `sir` (see [as.sir()]) on beforehand (defaults to `FALSE`)
#' @param custom_rules custom rules to apply, created with [custom_eucast_rules()]
#' @inheritParams first_isolate
#' @details
#' **Note:** This function does not translate MIC values to RSI values. Use [as.rsi()] for that. \cr
#' **Note:** This function does not translate MIC values to SIR values. Use [as.sir()] for that. \cr
#' **Note:** When ampicillin (AMP, J01CA01) is not available but amoxicillin (AMX, J01CA04) is, the latter will be used for all rules where there is a dependency on ampicillin. These drugs are interchangeable when it comes to expression of antimicrobial resistance. \cr
#'
#' The file containing all EUCAST rules is located here: <https://github.com/msberends/AMR/blob/main/data-raw/eucast_rules.tsv>. **Note:** Old taxonomic names are replaced with the current taxonomy where applicable. For example, *Ochrobactrum anthropi* was renamed to *Brucella anthropi* in 2020; the original EUCAST rules v3.1 and v3.2 did not yet contain this new taxonomic name. The `AMR` package contains the full microbial taxonomy updated until `r documentation_date(max(TAXONOMY_VERSION$GBIF$accessed_date, TAXONOMY_VERSION$LPSN$accessed_date))`, see [microorganisms].
@ -168,7 +168,7 @@ eucast_rules <- function(x,
version_breakpoints = 12.0,
version_expertrules = 3.3,
ampc_cephalosporin_resistance = NA,
only_rsi_columns = FALSE,
only_sir_columns = FALSE,
custom_rules = NULL,
...) {
meet_criteria(x, allow_class = "data.frame")
@ -178,8 +178,8 @@ eucast_rules <- function(x,
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(version_breakpoints, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_BREAKPOINTS)))
meet_criteria(version_expertrules, allow_class = c("numeric", "integer"), has_length = 1, is_in = as.double(names(EUCAST_VERSION_EXPERT_RULES)))
meet_criteria(ampc_cephalosporin_resistance, allow_class = c("logical", "character", "rsi"), has_length = 1, allow_NA = TRUE, allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(ampc_cephalosporin_resistance, allow_class = c("logical", "character", "sir"), has_length = 1, allow_NA = TRUE, allow_NULL = TRUE)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(custom_rules, allow_class = "custom_eucast_rules", allow_NULL = TRUE)
if ("custom" %in% rules && is.null(custom_rules)) {
@ -240,7 +240,7 @@ eucast_rules <- function(x,
}
warned <- FALSE
warn_lacking_rsi_class <- character(0)
warn_lacking_sir_class <- character(0)
txt_ok <- function(n_added, n_changed, warned = FALSE) {
if (warned == FALSE) {
if (n_added + n_changed == 0) {
@ -309,7 +309,7 @@ eucast_rules <- function(x,
hard_dependencies = NULL,
verbose = verbose,
info = info,
only_rsi_columns = only_rsi_columns,
only_sir_columns = only_sir_columns,
fn = "eucast_rules",
...
)
@ -376,11 +376,11 @@ eucast_rules <- function(x,
}
}
}
as.rsi_no_warning <- function(x) {
if (is.rsi(x)) {
as.sir_no_warning <- function(x) {
if (is.sir(x)) {
return(x)
}
suppressWarnings(as.rsi(x))
suppressWarnings(as.sir(x))
}
# Preparing the data ------------------------------------------------------
@ -389,8 +389,8 @@ eucast_rules <- function(x,
rowid = character(0),
col = character(0),
mo_fullname = character(0),
old = as.rsi(character(0)),
new = as.rsi(character(0)),
old = as.sir(character(0)),
new = as.sir(character(0)),
rule = character(0),
rule_group = character(0),
rule_name = character(0),
@ -493,14 +493,14 @@ eucast_rules <- function(x,
extra_indent = 6
))
}
run_changes <- edit_rsi(
run_changes <- edit_sir(
x = x,
to = "R",
rule = c(
rule_current, "Other rules", "",
paste0("Non-EUCAST: AMR package v", utils::packageDescription("AMR")$Version)
),
rows = which(as.rsi_no_warning(x[, col_enzyme, drop = TRUE]) == "R"),
rows = which(as.sir_no_warning(x[, col_enzyme, drop = TRUE]) == "R"),
cols = col_base,
last_verbose_info = verbose_info,
original_data = x.bak,
@ -512,7 +512,7 @@ eucast_rules <- function(x,
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
x <- run_changes$output
warn_lacking_rsi_class <- c(warn_lacking_rsi_class, run_changes$rsi_warn)
warn_lacking_sir_class <- c(warn_lacking_sir_class, run_changes$sir_warn)
# Print number of new changes
if (isTRUE(info)) {
# print only on last one of rules in this group
@ -534,14 +534,14 @@ eucast_rules <- function(x,
extra_indent = 6
))
}
run_changes <- edit_rsi(
run_changes <- edit_sir(
x = x,
to = "S",
rule = c(
rule_current, "Other rules", "",
paste0("Non-EUCAST: AMR package v", utils::packageDescription("AMR")$Version)
),
rows = which(as.rsi_no_warning(x[, col_base, drop = TRUE]) == "S"),
rows = which(as.sir_no_warning(x[, col_base, drop = TRUE]) == "S"),
cols = col_enzyme,
last_verbose_info = verbose_info,
original_data = x.bak,
@ -553,7 +553,7 @@ eucast_rules <- function(x,
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
x <- run_changes$output
warn_lacking_rsi_class <- c(warn_lacking_rsi_class, run_changes$rsi_warn)
warn_lacking_sir_class <- c(warn_lacking_sir_class, run_changes$sir_warn)
# Print number of new changes
if (isTRUE(info)) {
# print only on last one of rules in this group
@ -788,21 +788,21 @@ eucast_rules <- function(x,
rows <- integer(0)
} else if (length(source_antibiotics) == 1) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value &
as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
error = function(e) integer(0)
)
} else if (length(source_antibiotics) == 2) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value &
as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L] &
as.rsi_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L] &
as.sir_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
error = function(e) integer(0)
)
# nolint start
# } else if (length(source_antibiotics) == 3) {
# rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value
# & as.rsi_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]
# & as.rsi_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]
# & as.rsi_no_warning(x[, source_antibiotics[3L]]) == source_value[3L]),
# & as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]
# & as.sir_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]
# & as.sir_no_warning(x[, source_antibiotics[3L]]) == source_value[3L]),
# error = function(e) integer(0))
# nolint end
} else {
@ -814,7 +814,7 @@ eucast_rules <- function(x,
# Apply rule on data ------------------------------------------------------
# this will return the unique number of changes
run_changes <- edit_rsi(
run_changes <- edit_sir(
x = x,
to = target_value,
rule = c(
@ -836,7 +836,7 @@ eucast_rules <- function(x,
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
x <- run_changes$output
warn_lacking_rsi_class <- c(warn_lacking_rsi_class, run_changes$rsi_warn)
warn_lacking_sir_class <- c(warn_lacking_sir_class, run_changes$sir_warn)
# Print number of new changes ---------------------------------------------
if (isTRUE(info) && rule_next != rule_current) {
# print only on last one of rules in this group
@ -878,7 +878,7 @@ eucast_rules <- function(x,
))
warned <- FALSE
}
run_changes <- edit_rsi(
run_changes <- edit_sir(
x = x,
to = target_value,
rule = c(
@ -902,7 +902,7 @@ eucast_rules <- function(x,
n_changed <- n_changed + run_changes$changed
verbose_info <- run_changes$verbose_info
x <- run_changes$output
warn_lacking_rsi_class <- c(warn_lacking_rsi_class, run_changes$rsi_warn)
warn_lacking_sir_class <- c(warn_lacking_sir_class, run_changes$sir_warn)
# Print number of new changes ---------------------------------------------
if (isTRUE(info) && rule_next != rule_current) {
# print only on last one of rules in this group
@ -1017,19 +1017,19 @@ eucast_rules <- function(x,
}
}
if (length(warn_lacking_rsi_class) > 0) {
warn_lacking_rsi_class <- unique(warn_lacking_rsi_class)
if (length(warn_lacking_sir_class) > 0) {
warn_lacking_sir_class <- unique(warn_lacking_sir_class)
# take order from original data set
warn_lacking_rsi_class <- warn_lacking_rsi_class[order(colnames(x.bak))]
warn_lacking_rsi_class <- warn_lacking_rsi_class[!is.na(warn_lacking_rsi_class)]
warn_lacking_sir_class <- warn_lacking_sir_class[order(colnames(x.bak))]
warn_lacking_sir_class <- warn_lacking_sir_class[!is.na(warn_lacking_sir_class)]
warning_(
"in `eucast_rules()`: not all columns with antimicrobial results are of class 'rsi'. Transform them on beforehand, with e.g.:\n",
" - ", x_deparsed, " %>% as.rsi(", ifelse(length(warn_lacking_rsi_class) == 1,
warn_lacking_rsi_class,
paste0(warn_lacking_rsi_class[1], ":", warn_lacking_rsi_class[length(warn_lacking_rsi_class)])
"in `eucast_rules()`: not all columns with antimicrobial results are of class 'sir'. Transform them on beforehand, with e.g.:\n",
" - ", x_deparsed, " %>% as.sir(", ifelse(length(warn_lacking_sir_class) == 1,
warn_lacking_sir_class,
paste0(warn_lacking_sir_class[1], ":", warn_lacking_sir_class[length(warn_lacking_sir_class)])
), ")\n",
" - ", x_deparsed, " %>% mutate_if(is.rsi.eligible, as.rsi)\n",
" - ", x_deparsed, " %>% mutate(across(where(is.rsi.eligible), as.rsi))"
" - ", x_deparsed, " %>% mutate_if(is_sir_eligible, as.sir)\n",
" - ", x_deparsed, " %>% mutate(across(where(is_sir_eligible), as.sir))"
)
}
@ -1051,7 +1051,7 @@ eucast_rules <- function(x,
}
# helper function for editing the table ----
edit_rsi <- function(x,
edit_sir <- function(x,
to,
rule,
rows,
@ -1069,7 +1069,7 @@ edit_rsi <- function(x,
changed = 0,
output = x,
verbose_info = last_verbose_info,
rsi_warn = character(0)
sir_warn = character(0)
)
txt_error <- function() {
@ -1084,8 +1084,8 @@ edit_rsi <- function(x,
if (length(rows) > 0 && length(cols) > 0) {
new_edits <- x
if (any(!vapply(FUN.VALUE = logical(1), x[, cols, drop = FALSE], is.rsi), na.rm = TRUE)) {
track_changes$rsi_warn <- cols[!vapply(FUN.VALUE = logical(1), x[, cols, drop = FALSE], is.rsi)]
if (any(!vapply(FUN.VALUE = logical(1), x[, cols, drop = FALSE], is.sir), na.rm = TRUE)) {
track_changes$sir_warn <- cols[!vapply(FUN.VALUE = logical(1), x[, cols, drop = FALSE], is.sir)]
}
tryCatch(
# insert into original table

24
R/first_isolate.R
View File

@ -48,7 +48,7 @@
#' @param points_threshold minimum number of points to require before differences in the antibiogram will lead to inclusion of an isolate when `type = "points"`, see *Details*
#' @param info a [logical] to indicate info should be printed, defaults to `TRUE` only in interactive mode
#' @param include_unknown a [logical] to indicate whether 'unknown' microorganisms should be included too, i.e. microbial code `"UNKNOWN"`, which defaults to `FALSE`. For WHONET users, this means that all records with organism code `"con"` (*contamination*) will be excluded at default. Isolates with a microbial ID of `NA` will always be excluded as first isolate.
#' @param include_untested_rsi a [logical] to indicate whether also rows without antibiotic results are still eligible for becoming a first isolate. Use `include_untested_rsi = FALSE` to always return `FALSE` for such rows. This checks the data set for columns of class `rsi` and consequently requires transforming columns with antibiotic results using [as.rsi()] first.
#' @param include_untested_sir a [logical] to indicate whether also rows without antibiotic results are still eligible for becoming a first isolate. Use `include_untested_sir = FALSE` to always return `FALSE` for such rows. This checks the data set for columns of class `sir` and consequently requires transforming columns with antibiotic results using [as.sir()] first.
#' @param ... arguments passed on to [first_isolate()] when using [filter_first_isolate()], otherwise arguments passed on to [key_antimicrobials()] (such as `universal`, `gram_negative`, `gram_positive`)
#' @details
#' To conduct epidemiological analyses on antimicrobial resistance data, only so-called first isolates should be included to prevent overestimation and underestimation of antimicrobial resistance. Different methods can be used to do so, see below.
@ -176,7 +176,7 @@ first_isolate <- function(x = NULL,
points_threshold = 2,
info = interactive(),
include_unknown = FALSE,
include_untested_rsi = TRUE,
include_untested_sir = TRUE,
...) {
if (is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
@ -228,19 +228,19 @@ first_isolate <- function(x = NULL,
meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(info, allow_class = "logical", has_length = 1)
meet_criteria(include_unknown, allow_class = "logical", has_length = 1)
meet_criteria(include_untested_rsi, allow_class = "logical", has_length = 1)
meet_criteria(include_untested_sir, allow_class = "logical", has_length = 1)
# remove data.table, grouping from tibbles, etc.
x <- as.data.frame(x, stringsAsFactors = FALSE)
any_col_contains_rsi <- any(vapply(
any_col_contains_sir <- any(vapply(
FUN.VALUE = logical(1),
X = x,
# check only first 10,000 rows
FUN = function(x) any(as.character(x[1:10000]) %in% c("R", "S", "I"), na.rm = TRUE),
USE.NAMES = FALSE
))
if (method == "phenotype-based" && !any_col_contains_rsi) {
if (method == "phenotype-based" && !any_col_contains_sir) {
method <- "episode-based"
}
if (isTRUE(info) && message_not_thrown_before("first_isolate", "method")) {
@ -285,13 +285,13 @@ first_isolate <- function(x = NULL,
type <- "keyantimicrobials"
}
if (type == "points") {
x$keyantimicrobials <- all_antimicrobials(x, only_rsi_columns = FALSE)
x$keyantimicrobials <- all_antimicrobials(x, only_sir_columns = FALSE)
col_keyantimicrobials <- "keyantimicrobials"
} else if (type == "keyantimicrobials" && is.null(col_keyantimicrobials)) {
col_keyantimicrobials <- search_type_in_df(x = x, type = "keyantimicrobials", info = info)
if (is.null(col_keyantimicrobials)) {
# still not found as a column, create it ourselves
x$keyantimicrobials <- key_antimicrobials(x, only_rsi_columns = FALSE, col_mo = col_mo, ...)
x$keyantimicrobials <- key_antimicrobials(x, only_sir_columns = FALSE, col_mo = col_mo, ...)
col_keyantimicrobials <- "keyantimicrobials"
}
}
@ -581,13 +581,13 @@ first_isolate <- function(x = NULL,
x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE
# handle isolates without antibiogram
if (include_untested_rsi == FALSE && any(is.rsi(x))) {
rsi_all_NA <- which(unname(vapply(
if (include_untested_sir == FALSE && any(is.sir(x))) {
sir_all_NA <- which(unname(vapply(
FUN.VALUE = logical(1),
as.data.frame(t(x[, is.rsi(x), drop = FALSE])),
function(rsi_values) all(is.na(rsi_values))
as.data.frame(t(x[, is.sir(x), drop = FALSE])),
function(sir_values) all(is.na(sir_values))
)))
x[rsi_all_NA, "newvar_first_isolate"] <- FALSE
x[sir_all_NA, "newvar_first_isolate"] <- FALSE
}
# arrange back according to original sorting again

2
R/ggplot_pca.R
View File

@ -76,7 +76,7 @@
#' genus = mo_genus(mo)
#' ) %>% # and genus as we do here;
#' filter(n() >= 30) %>% # filter on only 30 results per group
#' summarise_if(is.rsi, resistance) # then get resistance of all drugs
#' summarise_if(is.sir, resistance) # then get resistance of all drugs
#'
#' # now conduct PCA for certain antimicrobial drugs
#' pca_result <- resistance_data %>%

94
R/ggplot_rsi.R → R/ggplot_sir.R
View File

@ -30,7 +30,7 @@
#' AMR Plots with `ggplot2`
#'
#' Use these functions to create bar plots for AMR data analysis. All functions rely on [ggplot2][ggplot2::ggplot()] functions.
#' @param data a [data.frame] with column(s) of class [`rsi`] (see [as.rsi()])
#' @param data a [data.frame] with column(s) of class [`sir`] (see [as.sir()])
#' @param position position adjustment of bars, either `"fill"`, `"stack"` or `"dodge"`
#' @param x variable to show on x axis, either `"antibiotic"` (default) or `"interpretation"` or a grouping variable
#' @param fill variable to categorise using the plots legend, either `"antibiotic"` (default) or `"interpretation"` or a grouping variable
@ -41,7 +41,7 @@
#' @param nrow (when using `facet`) number of rows
#' @param colours a named vactor with colour to be used for filling. The default colours are colour-blind friendly.
#' @param aesthetics aesthetics to apply the colours to, defaults to "fill" but can also be (a combination of) "alpha", "colour", "fill", "linetype", "shape" or "size"
#' @param datalabels show datalabels using [labels_rsi_count()]
#' @param datalabels show datalabels using [labels_sir_count()]
#' @param datalabels.size size of the datalabels
#' @param datalabels.colour colour of the datalabels
#' @param title text to show as title of the plot
@ -49,24 +49,24 @@
#' @param caption text to show as caption of the plot
#' @param x.title text to show as x axis description
#' @param y.title text to show as y axis description
#' @param ... other arguments passed on to [geom_rsi()] or, in case of [scale_rsi_colours()], named values to set colours. The default colours are colour-blind friendly, while maintaining the convention that e.g. 'susceptible' should be green and 'resistant' should be red. See *Examples*.
#' @param ... other arguments passed on to [geom_sir()] or, in case of [scale_sir_colours()], named values to set colours. The default colours are colour-blind friendly, while maintaining the convention that e.g. 'susceptible' should be green and 'resistant' should be red. See *Examples*.
#' @details At default, the names of antibiotics will be shown on the plots using [ab_name()]. This can be set with the `translate_ab` argument. See [count_df()].
#'
#' ### The Functions
#' [geom_rsi()] will take any variable from the data that has an [`rsi`] class (created with [as.rsi()]) using [rsi_df()] and will plot bars with the percentage R, I and S. The default behaviour is to have the bars stacked and to have the different antibiotics on the x axis.
#' [geom_sir()] will take any variable from the data that has an [`sir`] class (created with [as.sir()]) using [sir_sf()] and will plot bars with the percentage S, I, and R. The default behaviour is to have the bars stacked and to have the different antibiotics on the x axis.
#'
#' [facet_rsi()] creates 2d plots (at default based on S/I/R) using [ggplot2::facet_wrap()].
#' [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_rsi_colours()] sets colours to the bars (green for S, yellow for I, and red for R). with multilingual support. The default colours are colour-blind friendly, while maintaining the convention that e.g. 'susceptible' should be green and 'resistant' should be red.
#' [scale_sir_colours()] sets colours to the bars (green for S, yellow for I, and red for R). with multilingual support. The default colours are colour-blind friendly, while maintaining the convention that e.g. 'susceptible' should be green and 'resistant' should be red.
#'
#' [theme_rsi()] is a [ggplot2 theme][[ggplot2::theme()] with minimal distraction.
#' [theme_sir()] is a [ggplot2 theme][[ggplot2::theme()] with minimal distraction.
#'
#' [labels_rsi_count()] print datalabels on the bars with percentage and amount of isolates using [ggplot2::geom_text()].
#' [labels_sir_count()] print datalabels on the bars with percentage and amount of isolates using [ggplot2::geom_text()].
#'
#' [ggplot_rsi()] is a wrapper around all above functions that uses data as first input. This makes it possible to use this function after a pipe (`%>%`). See *Examples*.
#' @rdname ggplot_rsi
#' [ggplot_sir()] is a wrapper around all above functions that uses data as first input. This makes it possible to use this function after a pipe (`%>%`). See *Examples*.
#' @rdname ggplot_sir
#' @export
#' @examples
#' \donttest{
@ -74,39 +74,39 @@
#'
#' # get antimicrobial results for drugs against a UTI:
#' ggplot(example_isolates %>% select(AMX, NIT, FOS, TMP, CIP)) +
#' geom_rsi()
#' geom_sir()
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # prettify the plot using some additional functions:
#' df <- example_isolates %>% select(AMX, NIT, FOS, TMP, CIP)
#' ggplot(df) +
#' geom_rsi() +
#' geom_sir() +
#' scale_y_percent() +
#' scale_rsi_colours() +
#' labels_rsi_count() +
#' theme_rsi()
#' scale_sir_colours() +
#' labels_sir_count() +
#' theme_sir()
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # or better yet, simplify this using the wrapper function - a single command:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi()
#' ggplot_sir()
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # get only proportions and no counts:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi(datalabels = FALSE)
#' ggplot_sir(datalabels = FALSE)
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # add other ggplot2 arguments as you like:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi(
#' ggplot_sir(
#' width = 0.5,
#' colour = "black",
#' size = 1,
@ -119,7 +119,7 @@
#' # you can alter the colours with colour names:
#' example_isolates %>%
#' select(AMX) %>%
#' ggplot_rsi(colours = c(SI = "yellow"))
#' ggplot_sir(colours = c(SI = "yellow"))
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
@ -132,7 +132,7 @@
#' ) %>%
#' ggplot() +
#' geom_col(aes(x = x, y = y, fill = z)) +
#' scale_rsi_colours(Value4 = "S", Value5 = "I", Value6 = "R")
#' scale_sir_colours(Value4 = "S", Value5 = "I", Value6 = "R")
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
@ -146,14 +146,14 @@
#' # age_groups() is also a function in this AMR package:
#' group_by(age_group = age_groups(age)) %>%
#' select(age_group, CIP) %>%
#' ggplot_rsi(x = "age_group")
#' ggplot_sir(x = "age_group")
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # a shorter version which also adjusts data label colours:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi(colours = FALSE)
#' ggplot_sir(colours = FALSE)
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
@ -163,7 +163,7 @@
#' # select only UTI-specific drugs
#' select(ward, AMX, NIT, FOS, TMP, CIP) %>%
#' group_by(ward) %>%
#' ggplot_rsi(
#' ggplot_sir(
#' x = "ward",
#' facet = "antibiotic",
#' nrow = 1,
@ -173,7 +173,7 @@
#' )
#' }
#' }
ggplot_rsi <- function(data,
ggplot_sir <- function(data,
position = NULL,
x = "antibiotic",
fill = "interpretation",
@ -203,7 +203,7 @@ ggplot_rsi <- function(data,
y.title = "Proportion",
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(data, allow_class = "data.frame", contains_column_class = "rsi")
meet_criteria(data, allow_class = "data.frame", contains_column_class = "sir")
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(fill, allow_class = "character", has_length = 1)
@ -249,15 +249,15 @@ ggplot_rsi <- function(data,
}
p <- ggplot2::ggplot(data = data) +
geom_rsi(
geom_sir(
position = position, x = x, fill = fill, translate_ab = translate_ab,
minimum = minimum, language = language,
combine_SI = combine_SI, ...
) +
theme_rsi()
theme_sir()
if (fill == "interpretation") {
p <- p + scale_rsi_colours(colours = colours)
p <- p + scale_sir_colours(colours = colours)
}
if (identical(position, "fill")) {
@ -266,7 +266,7 @@ ggplot_rsi <- function(data,
}
if (datalabels == TRUE) {
p <- p + labels_rsi_count(
p <- p + labels_sir_count(
position = position,
x = x,
translate_ab = translate_ab,
@ -279,7 +279,7 @@ ggplot_rsi <- function(data,
}
if (!is.null(facet)) {
p <- p + facet_rsi(facet = facet, nrow = nrow)
p <- p + facet_sir(facet = facet, nrow = nrow)
}
p <- p + ggplot2::labs(
@ -293,9 +293,9 @@ ggplot_rsi <- function(data,
p
}
#' @rdname ggplot_rsi
#' @rdname ggplot_sir
#' @export
geom_rsi <- function(position = NULL,
geom_sir <- function(position = NULL,
x = c("antibiotic", "interpretation"),
fill = "interpretation",
translate_ab = "name",
@ -334,13 +334,13 @@ geom_rsi <- function(position = NULL,
if (tolower(x) %in% tolower(c("ab", "abx", "antibiotics"))) {
x <- "antibiotic"
} else if (tolower(x) %in% tolower(c("SIR", "RSI", "interpretations", "result"))) {
} else if (tolower(x) %in% tolower(c("SIR", "sir", "interpretations", "result"))) {
x <- "interpretation"
}
ggplot2::geom_col(
data = function(x) {
rsi_df(
sir_sf(
data = x,
translate_ab = translate_ab,
language = language,
@ -354,9 +354,9 @@ geom_rsi <- function(position = NULL,
)
}
#' @rdname ggplot_rsi
#' @rdname ggplot_sir
#' @export
facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
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)
@ -371,7 +371,7 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
facet <- substr(facet, 2, nchar(facet) - 1)
}
if (tolower(facet) %in% tolower(c("SIR", "RSI", "interpretations", "result"))) {
if (tolower(facet) %in% tolower(c("SIR", "sir", "interpretations", "result"))) {
facet <- "interpretation"
} else if (tolower(facet) %in% tolower(c("ab", "abx", "antibiotics"))) {
facet <- "antibiotic"
@ -380,7 +380,7 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
ggplot2::facet_wrap(facets = facet, scales = "free_x", nrow = nrow)
}
#' @rdname ggplot_rsi
#' @rdname ggplot_sir
#' @export
scale_y_percent <- function(breaks = seq(0, 1, 0.1), limits = NULL) {
stop_ifnot_installed("ggplot2")
@ -397,13 +397,13 @@ scale_y_percent <- function(breaks = seq(0, 1, 0.1), limits = NULL) {
)
}
#' @rdname ggplot_rsi
#' @rdname ggplot_sir
#' @export
scale_rsi_colours <- function(...,
scale_sir_colours <- function(...,
aesthetics = "fill") {
stop_ifnot_installed("ggplot2")
meet_criteria(aesthetics, allow_class = "character", is_in = c("alpha", "colour", "color", "fill", "linetype", "shape", "size"))
# behaviour until AMR pkg v1.5.0 and also when coming from ggplot_rsi()
# behaviour until AMR pkg v1.5.0 and also when coming from ggplot_sir()
if ("colours" %in% names(list(...))) {
original_cols <- c(
S = "#3CAEA3",
@ -457,7 +457,7 @@ scale_rsi_colours <- function(...,
original_cols <- c(susceptible, incr_exposure, resistant)
dots <- c(...)
# replace S, I, R as colours: scale_rsi_colours(mydatavalue = "S")
# replace S, I, R as colours: scale_sir_colours(mydatavalue = "S")
dots[dots == "S"] <- "#3CAEA3"
dots[dots == "I"] <- "#F6D55C"
dots[dots == "R"] <- "#ED553B"
@ -467,9 +467,9 @@ scale_rsi_colours <- function(...,
ggplot2::scale_discrete_manual(aesthetics = aesthetics, values = cols, limits = force)
}
#' @rdname ggplot_rsi
#' @rdname ggplot_sir
#' @export
theme_rsi <- function() {
theme_sir <- function() {
stop_ifnot_installed("ggplot2")
ggplot2::theme_minimal(base_size = 10) +
ggplot2::theme(
@ -482,9 +482,9 @@ theme_rsi <- function() {
)
}
#' @rdname ggplot_rsi
#' @rdname ggplot_sir
#' @export
labels_rsi_count <- function(position = NULL,
labels_sir_count <- function(position = NULL,
x = "antibiotic",
translate_ab = "name",
minimum = 30,
@ -521,7 +521,7 @@ labels_rsi_count <- function(position = NULL,
colour = datalabels.colour,
lineheight = 0.75,
data = function(x) {
transformed <- rsi_df(
transformed <- sir_sf(
data = x,
translate_ab = translate_ab,
combine_SI = combine_SI,

26
R/guess_ab_col.R
View File

@ -33,7 +33,7 @@
#' @param x a [data.frame]
#' @param search_string a text to search `x` for, will be checked with [as.ab()] if this value is not a column in `x`
#' @param verbose a [logical] to indicate whether additional info should be printed
#' @param only_rsi_columns a [logical] to indicate whether only antibiotic columns must be detected that were transformed to class `rsi` (see [as.rsi()]) on beforehand (defaults to `FALSE`)
#' @param only_sir_columns a [logical] to indicate whether only antibiotic columns must be detected that were transformed to class `sir` (see [as.sir()]) on beforehand (defaults to `FALSE`)
#' @details You can look for an antibiotic (trade) name or abbreviation and it will search `x` and the [antibiotics] data set for any column containing a name or code of that antibiotic.
#' @return A column name of `x`, or `NULL` when no result is found.
#' @export
@ -57,11 +57,11 @@
#' guess_ab_col(df, "ampicillin")
#' guess_ab_col(df, "J01CR02")
#' guess_ab_col(df, as.ab("augmentin"))
guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_rsi_columns = FALSE) {
guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_sir_columns = FALSE) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(search_string, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if (is.null(x) && is.null(search_string)) {
return(as.name("guess_ab_col"))
@ -70,7 +70,7 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_r
}
all_found <- get_column_abx(x,
info = verbose, only_rsi_columns = only_rsi_columns,
info = verbose, only_sir_columns = only_sir_columns,
verbose = verbose, fn = "guess_ab_col"
)
search_string.ab <- suppressWarnings(as.ab(search_string))
@ -102,7 +102,7 @@ get_column_abx <- function(x,
hard_dependencies = NULL,
verbose = FALSE,
info = TRUE,
only_rsi_columns = FALSE,
only_sir_columns = FALSE,
sort = TRUE,
reuse_previous_result = TRUE,
fn = NULL) {
@ -125,8 +125,8 @@ get_column_abx <- function(x,
new_cols <- colnames(x)[!colnames(x) %in% AMR_env$get_column_abx.checked_cols]
if (length(new_cols) > 0) {
# these columns did not exist in the last call, so add them
new_cols_rsi <- get_column_abx(x[, new_cols, drop = FALSE], reuse_previous_result = FALSE, info = FALSE, sort = FALSE)
current <- c(current, new_cols_rsi)
new_cols_sir <- get_column_abx(x[, new_cols, drop = FALSE], reuse_previous_result = FALSE, info = FALSE, sort = FALSE)
current <- c(current, new_cols_sir)
# order according to columns in current call
current <- current[match(colnames(x)[colnames(x) %in% current], current)]
}
@ -144,7 +144,7 @@ get_column_abx <- function(x,
meet_criteria(hard_dependencies, allow_class = "character", allow_NULL = TRUE)
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(info, allow_class = "logical", has_length = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(sort, allow_class = "logical", has_length = 1)
if (isTRUE(info)) {
@ -153,8 +153,8 @@ get_column_abx <- function(x,
x <- as.data.frame(x, stringsAsFactors = FALSE)
x.bak <- x
if (only_rsi_columns == TRUE) {
x <- x[, which(is.rsi(x)), drop = FALSE]
if (only_sir_columns == TRUE) {
x <- x[, which(is.sir(x)), drop = FALSE]
}
if (NROW(x) > 10000) {
@ -171,7 +171,7 @@ get_column_abx <- function(x,
}
# only check columns that are a valid AB code, ATC code, name, abbreviation or synonym,
# or already have the 'rsi' class (as.rsi)
# or already have the 'sir' class (as.sir)
# and that they have no more than 50% invalid values
vectr_antibiotics <- unlist(AMR_env$AB_lookup$generalised_all)
vectr_antibiotics <- vectr_antibiotics[!is.na(vectr_antibiotics) & nchar(vectr_antibiotics) >= 3]
@ -180,8 +180,8 @@ get_column_abx <- function(x,
colnames(x),
function(col, df = x) {
if (generalise_antibiotic_name(col) %in% vectr_antibiotics ||
is.rsi(x[, col, drop = TRUE]) ||
is.rsi.eligible(x[, col, drop = TRUE], threshold = 0.5)
is.sir(x[, col, drop = TRUE]) ||
is_sir_eligible(x[, col, drop = TRUE], threshold = 0.5)
) {
return(col)
} else {

18
R/key_antimicrobials.R
View File

@ -37,7 +37,7 @@
#' @param gram_negative names of antibiotic drugs for **Gram-positives**, case-insensitive. Set to `NULL` to ignore. See *Details* for the default antibiotic drugs
#' @param gram_positive names of antibiotic drugs for **Gram-negatives**, case-insensitive. Set to `NULL` to ignore. See *Details* for the default antibiotic drugs
#' @param antifungal names of antifungal drugs for **fungi**, case-insensitive. Set to `NULL` to ignore. See *Details* for the default antifungal drugs
#' @param only_rsi_columns a [logical] to indicate whether only columns must be included that were transformed to class `rsi` (see [as.rsi()]) on beforehand (defaults to `FALSE`)
#' @param only_sir_columns a [logical] to indicate whether only columns must be included that were transformed to class `sir` (see [as.sir()]) on beforehand (defaults to `FALSE`)
#' @param ... ignored, only in place to allow future extensions
#' @details
#' The [key_antimicrobials()] and [all_antimicrobials()] functions are context-aware. This means that the `x` argument can be left blank if used inside a [data.frame] call, see *Examples*.
@ -135,7 +135,7 @@ key_antimicrobials <- function(x = NULL,
"anidulafungin", "caspofungin", "fluconazole",
"miconazole", "nystatin", "voriconazole"
),
only_rsi_columns = FALSE,
only_sir_columns = FALSE,
...) {
if (is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
@ -148,11 +148,11 @@ key_antimicrobials <- function(x = NULL,
meet_criteria(gram_negative, allow_class = "character", allow_NULL = TRUE)
meet_criteria(gram_positive, allow_class = "character", allow_NULL = TRUE)
meet_criteria(antifungal, allow_class = "character", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
# force regular data.frame, not a tibble or data.table
x <- as.data.frame(x, stringsAsFactors = FALSE)
cols <- get_column_abx(x, info = FALSE, only_rsi_columns = only_rsi_columns, fn = "key_antimicrobials")
cols <- get_column_abx(x, info = FALSE, only_sir_columns = only_sir_columns, fn = "key_antimicrobials")
# try to find columns based on type
# -- mo
@ -247,7 +247,7 @@ key_antimicrobials <- function(x = NULL,
#' @rdname key_antimicrobials
#' @export
all_antimicrobials <- function(x = NULL,
only_rsi_columns = FALSE,
only_sir_columns = FALSE,
...) {
if (is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
@ -255,12 +255,12 @@ all_antimicrobials <- function(x = NULL,
x <- tryCatch(get_current_data(arg_name = "x", call = -2), error = function(e) x)
}
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
# force regular data.frame, not a tibble or data.table
x <- as.data.frame(x, stringsAsFactors = FALSE)
cols <- get_column_abx(x,
only_rsi_columns = only_rsi_columns, info = FALSE,
only_sir_columns = only_sir_columns, info = FALSE,
sort = FALSE, fn = "all_antimicrobials"
)
@ -339,12 +339,12 @@ antimicrobials_equal <- function(y,
# - no change is 0 points
# - I <-> S|R is 0.5 point
# - S|R <-> R|S is 1 point
# use the levels of as.rsi (S = 1, I = 2, R = 3)
# use the levels of as.sir (S = 1, I = 2, R = 3)
# and divide by 2 (S = 0.5, I = 1, R = 1.5)
(sum(abs(a - b), na.rm = TRUE) / 2) < points_threshold
} else {
if (ignore_I == TRUE) {
ind <- which(a == 2 | b == 2) # since as.double(as.rsi("I")) == 2
ind <- which(a == 2 | b == 2) # since as.double(as.sir("I")) == 2
a[ind] <- NA_real_
b[ind] <- NA_real_
}

60
R/mdro.R
View File

@ -127,7 +127,7 @@
#' ```
#'
#' The rules set (the `custom` object in this case) could be exported to a shared file location using [saveRDS()] if you collaborate with multiple users. The custom rules set could then be imported using [readRDS()].
#' @inheritSection as.rsi Interpretation of R and S/I
#' @inheritSection as.sir Interpretation of R and S/I
#' @return
#' - CMI 2012 paper - function [mdr_cmi2012()] or [mdro()]:\cr
#' Ordered [factor] with levels `Negative` < `Multi-drug-resistant (MDR)` < `Extensively drug-resistant (XDR)` < `Pandrug-resistant (PDR)`
@ -175,7 +175,7 @@ mdro <- function(x = NULL,
pct_required_classes = 0.5,
combine_SI = TRUE,
verbose = FALSE,
only_rsi_columns = FALSE,
only_sir_columns = FALSE,
...) {
if (is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
@ -192,10 +192,10 @@ mdro <- function(x = NULL,
meet_criteria(pct_required_classes, allow_class = "numeric", has_length = 1)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if (!any(is.rsi.eligible(x))) {
stop_("There were no possible R/SI columns found in the data set. Transform columns with `as.rsi()` for valid antimicrobial interpretations.")
if (!any(is_sir_eligible(x))) {
stop_("There were no possible SIR columns found in the data set. Transform columns with `as.sir()` for valid antimicrobial interpretations.")
}
info.bak <- info
@ -499,7 +499,7 @@ mdro <- function(x = NULL,
),
verbose = verbose,
info = info,
only_rsi_columns = only_rsi_columns,
only_sir_columns = only_sir_columns,
fn = "mdro",
...
)
@ -532,7 +532,7 @@ mdro <- function(x = NULL,
),
verbose = verbose,
info = info,
only_rsi_columns = only_rsi_columns,
only_sir_columns = only_sir_columns,
fn = "mdro",
...
)
@ -565,7 +565,7 @@ mdro <- function(x = NULL,
),
verbose = verbose,
info = info,
only_rsi_columns = only_rsi_columns,
only_sir_columns = only_sir_columns,
fn = "mdro",
...
)
@ -584,7 +584,7 @@ mdro <- function(x = NULL,
),
verbose = verbose,
info = info,
only_rsi_columns = only_rsi_columns,
only_sir_columns = only_sir_columns,
fn = "mdro",
...
)
@ -601,7 +601,7 @@ mdro <- function(x = NULL,
),
verbose = verbose,
info = info,
only_rsi_columns = only_rsi_columns,
only_sir_columns = only_sir_columns,
fn = "mdro",
...
)
@ -610,7 +610,7 @@ mdro <- function(x = NULL,
x = x,
verbose = verbose,
info = info,
only_rsi_columns = only_rsi_columns,
only_sir_columns = only_sir_columns,
fn = "mdro",
...
)
@ -823,7 +823,7 @@ mdro <- function(x = NULL,
if (length(rows) > 0 && length(cols) > 0) {
x[, cols] <- as.data.frame(lapply(
x[, cols, drop = FALSE],
function(col) as.rsi(col)
function(col) as.sir(col)
),
stringsAsFactors = FALSE
)
@ -883,7 +883,7 @@ mdro <- function(x = NULL,
x[, lst_vector] <- as.data.frame(lapply(
x[, lst_vector, drop = FALSE],
function(col) as.rsi(col)
function(col) as.sir(col)
),
stringsAsFactors = FALSE
)
@ -1675,7 +1675,7 @@ mdro <- function(x = NULL,
ab <- x[, ab, drop = TRUE]
}
}
ab <- as.character(as.rsi(ab))
ab <- as.character(as.sir(ab))
ab[is.na(ab)] <- ""
ab
}
@ -1998,7 +1998,7 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
out <- factor(out, levels = attributes(guideline)$values, ordered = TRUE)
}
columns_nonsusceptible <- as.data.frame(t(df[, is.rsi(df), drop = FALSE] == "R"))
columns_nonsusceptible <- as.data.frame(t(df[, as.sir(df), drop = FALSE] == "R"))
columns_nonsusceptible <- vapply(
FUN.VALUE = character(1),
columns_nonsusceptible,
@ -2017,60 +2017,60 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
#' @rdname mdro
#' @export
brmo <- function(x = NULL, only_rsi_columns = FALSE, ...) {
brmo <- function(x = NULL, only_sir_columns = FALSE, ...) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
stop_if(
"guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function"
)
mdro(x = x, only_rsi_columns = only_rsi_columns, guideline = "BRMO", ...)
mdro(x = x, only_sir_columns = only_sir_columns, guideline = "BRMO", ...)
}
#' @rdname mdro
#' @export
mrgn <- function(x = NULL, only_rsi_columns = FALSE, ...) {
mrgn <- function(x = NULL, only_sir_columns = FALSE, ...) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
stop_if(
"guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function"
)
mdro(x = x, only_rsi_columns = only_rsi_columns, guideline = "MRGN", ...)
mdro(x = x, only_sir_columns = only_sir_columns, guideline = "MRGN", ...)
}
#' @rdname mdro
#' @export
mdr_tb <- function(x = NULL, only_rsi_columns = FALSE, ...) {
mdr_tb <- function(x = NULL, only_sir_columns = FALSE, ...) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
stop_if(
"guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function"
)
mdro(x = x, only_rsi_columns = only_rsi_columns, guideline = "TB", ...)
mdro(x = x, only_sir_columns = only_sir_columns, guideline = "TB", ...)
}
#' @rdname mdro
#' @export
mdr_cmi2012 <- function(x = NULL, only_rsi_columns = FALSE, ...) {
mdr_cmi2012 <- function(x = NULL, only_sir_columns = FALSE, ...) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
stop_if(
"guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function"
)
mdro(x = x, only_rsi_columns = only_rsi_columns, guideline = "CMI2012", ...)
mdro(x = x, only_sir_columns = only_sir_columns, guideline = "CMI2012", ...)
}
#' @rdname mdro
#' @export
eucast_exceptional_phenotypes <- function(x = NULL, only_rsi_columns = FALSE, ...) {
eucast_exceptional_phenotypes <- function(x = NULL, only_sir_columns = FALSE, ...) {
meet_criteria(x, allow_class = "data.frame", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
stop_if(
"guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function"
)
mdro(x = x, only_rsi_columns = only_rsi_columns, guideline = "EUCAST", ...)
mdro(x = x, only_sir_columns = only_sir_columns, guideline = "EUCAST", ...)
}

10
R/mean_amr_distance.R
View File

@ -30,14 +30,14 @@
#' Calculate the Mean AMR Distance
#'
#' Calculates a normalised mean for antimicrobial resistance between multiple observations, to help to identify similar isolates without comparing antibiograms by hand.
#' @param x a vector of class [rsi][as.rsi()], [mic][as.mic()] or [disk][as.disk()], or a [data.frame] containing columns of any of these classes
#' @param x a vector of class [rsi][as.sir()], [mic][as.mic()] or [disk][as.disk()], or a [data.frame] containing columns of any of these classes
#' @param ... variables to select (supports [tidyselect language][tidyselect::language] such as `column1:column4` and `where(is.mic)`, and can thus also be [antibiotic selectors][ab_selector()]
#' @param combine_SI a [logical] to indicate whether all values of S and I must be merged into one, so the input only consists of S+I vs. R (susceptible vs. resistant), defaults to `TRUE`
#' @details The mean AMR distance is effectively [the Z-score](https://en.wikipedia.org/wiki/Standard_score); a normalised numeric value to compare AMR test results which can help to identify similar isolates, without comparing antibiograms by hand.
#'
#' MIC values (see [as.mic()]) are transformed with [log2()] first; their distance is thus calculated as `(log2(x) - mean(log2(x))) / sd(log2(x))`.
#'
#' R/SI values (see [as.rsi()]) are transformed using `"S"` = 1, `"I"` = 2, and `"R"` = 3. If `combine_SI` is `TRUE` (default), the `"I"` will be considered to be 1.
#' SIR values (see [as.sir()]) are transformed using `"S"` = 1, `"I"` = 2, and `"R"` = 3. If `combine_SI` is `TRUE` (default), the `"I"` will be considered to be 1.
#'
#' For data sets, the mean AMR distance will be calculated per column, after which the mean per row will be returned, see *Examples*.
#'
@ -46,7 +46,7 @@
#' Isolates with distances less than 0.01 difference from each other should be considered similar. Differences lower than 0.025 should be considered suspicious.
#' @export
#' @examples
#' rsi <- random_rsi(10)
#' rsi <- random_sir(10)
#' rsi
#' mean_amr_distance(rsi)
#'
@ -62,7 +62,7 @@
#'
#' y <- data.frame(
#' id = LETTERS[1:10],
#' amox = random_rsi(10, ab = "amox", mo = "Escherichia coli"),
#' amox = random_sir(10, ab = "amox", mo = "Escherichia coli"),
#' cipr = random_disk(10, ab = "cipr", mo = "Escherichia coli"),
#' gent = random_mic(10, ab = "gent", mo = "Escherichia coli"),
#' tobr = random_mic(10, ab = "tobr", mo = "Escherichia coli")
@ -115,7 +115,7 @@ mean_amr_distance.disk <- function(x, ...) {
#' @rdname mean_amr_distance
#' @export
mean_amr_distance.rsi <- function(x, ..., combine_SI = TRUE) {
mean_amr_distance.sir <- function(x, ..., combine_SI = TRUE) {
meet_criteria(combine_SI, allow_class = "logical", has_length = 1, .call_depth = -1)
if (isTRUE(combine_SI)) {
x[x == "I"] <- "S"

10
R/mic.R
View File

@ -77,7 +77,7 @@ valid_mic_levels <- c(
#' @param x a [character] or [numeric] vector
#' @param na.rm a [logical] indicating whether missing values should be removed
#' @param ... arguments passed on to methods
#' @details To interpret MIC values as RSI values, use [as.rsi()] on MIC values. It supports guidelines from EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`).
#' @details To interpret MIC values as SIR values, use [as.sir()] on MIC values. It supports guidelines from EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`).
#'
#' This class for MIC values is a quite a special data type: formally it is an ordered [factor] with valid MIC values as [factor] levels (to make sure only valid MIC values are retained), but for any mathematical operation it acts as decimal numbers:
#'
@ -123,13 +123,13 @@ valid_mic_levels <- c(
#' @return Ordered [factor] with additional class [`mic`], that in mathematical operations acts as decimal numbers. Bare in mind that the outcome of any mathematical operation on MICs will return a [numeric] value.
#' @aliases mic
#' @export
#' @seealso [as.rsi()]
#' @seealso [as.sir()]
#' @examples
#' mic_data <- as.mic(c(">=32", "1.0", "1", "1.00", 8, "<=0.128", "8", "16", "16"))
#' mic_data
#' is.mic(mic_data)
#'
#' # this can also coerce combined MIC/RSI values:
#' # this can also coerce combined MIC/SIR values:
#' as.mic("<=0.002; S")
#'
#' # mathematical processing treats MICs as numeric values
@ -138,13 +138,13 @@ valid_mic_levels <- c(
#' all(mic_data < 512)
#'
#' # interpret MIC values
#' as.rsi(
#' as.sir(
#' x = as.mic(2),
#' mo = as.mo("Streptococcus pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST"
#' )
#' as.rsi(
#' as.sir(
#' x = as.mic(c(0.01, 2, 4, 8)),
#' mo = as.mo("Streptococcus pneumoniae"),
#' ab = "AMX",

2
R/pca.R
View File

@ -52,7 +52,7 @@
#' genus = mo_genus(mo)
#' ) %>% # and genus as we do here;
#' filter(n() >= 30) %>% # filter on only 30 results per group
#' summarise_if(is.rsi, resistance) # then get resistance of all drugs
#' summarise_if(is.sir, resistance) # then get resistance of all drugs
#'
#' # now conduct PCA for certain antimicrobial drugs
#' pca_result <- resistance_data %>%

186
R/plot.R
View File

@ -27,23 +27,23 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Plotting for Classes `rsi`, `mic` and `disk`
#' Plotting for Classes `sir`, `mic` and `disk`
#'
#' Functions to plot classes `rsi`, `mic` and `disk`, with support for base \R and `ggplot2`.
#' Functions to plot classes `sir`, `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()])
#' @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, defaults to the latest included EUCAST guideline, see *Details*
#' @param main,title title of the plot
#' @param xlab,ylab axis title
#' @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 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', defaults to system language (see [get_AMR_locale()]) and can be overwritten by setting the option `AMR_locale`, e.g. `options(AMR_locale = "de")`, see [translate]. Use `language = NULL` or `language = ""` 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.
#' @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)`.
#' 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::clinical_breakpoints$guideline, quotes = TRUE, reverse = TRUE)`.
#'
#' Simply using `"CLSI"` or `"EUCAST"` as input will automatically select the latest version of that guideline.
#' @name plot
@ -55,11 +55,11 @@
#' @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))
#' some_sir_values <- random_sir(50, prob_SIR = c(0.55, 0.05, 0.30))
#'
#' plot(some_mic_values)
#' plot(some_disk_values)
#' plot(some_rsi_values)
#' plot(some_sir_values)
#'
#' # when providing the microorganism and antibiotic, colours will show interpretations:
#' plot(some_mic_values, mo = "S. aureus", ab = "ampicillin")
@ -74,7 +74,7 @@
#' autoplot(some_disk_values, mo = "Escherichia coli", ab = "cipro")
#' }
#' if (require("ggplot2")) {
#' autoplot(some_rsi_values)
#' autoplot(some_sir_values)
#' }
#' }
NULL
@ -90,7 +90,7 @@ plot.mic <- function(x,
main = deparse(substitute(x)),
ylab = "Frequency",
xlab = "Minimum Inhibitory Concentration (mg/L)",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
...) {
@ -100,7 +100,7 @@ plot.mic <- function(x,
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_RSI, allow_class = "character", has_length = c(1, 3))
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)
@ -112,8 +112,8 @@ plot.mic <- function(x,
xlab <- translate_into_language(xlab, language = language)
}
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
@ -124,7 +124,7 @@ plot.mic <- function(x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
colours_SIR = colours_SIR,
fn = as.mic,
language = language,
...
@ -132,7 +132,7 @@ plot.mic <- function(x,
barplot(x,
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_RSI %in% cols_sub$cols), 1.1, 1)),
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE
@ -142,20 +142,20 @@ plot.mic <- function(x,
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
}
if (any(colours_RSI %in% cols_sub$cols)) {
if (any(colours_SIR %in% cols_sub$cols)) {
legend_txt <- character(0)
legend_col <- character(0)
if (any(cols_sub$cols == colours_RSI[2] & cols_sub$count > 0)) {
if (any(cols_sub$cols == colours_SIR[1] & cols_sub$count > 0)) {
legend_txt <- "Susceptible"
legend_col <- colours_RSI[2]
legend_col <- colours_SIR[1]
}
if (any(cols_sub$cols == colours_RSI[3] & cols_sub$count > 0)) {
if (any(cols_sub$cols == colours_SIR[2] & cols_sub$count > 0)) {
legend_txt <- c(legend_txt, plot_name_of_I(cols_sub$guideline))
legend_col <- c(legend_col, colours_RSI[3])
legend_col <- c(legend_col, colours_SIR[2])
}
if (any(cols_sub$cols == colours_RSI[1] & cols_sub$count > 0)) {
if (any(cols_sub$cols == colours_SIR[3] & cols_sub$count > 0)) {
legend_txt <- c(legend_txt, "Resistant")
legend_col <- c(legend_col, colours_RSI[1])
legend_col <- c(legend_col, colours_SIR[3])
}
legend("top",
@ -181,7 +181,7 @@ barplot.mic <- function(height,
main = deparse(substitute(height)),
ylab = "Frequency",
xlab = "Minimum Inhibitory Concentration (mg/L)",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
...) {
@ -191,7 +191,7 @@ barplot.mic <- function(height,
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))
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)
@ -213,7 +213,7 @@ barplot.mic <- function(height,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
colours_SIR = colours_SIR,
...
)
}
@ -228,7 +228,7 @@ autoplot.mic <- function(object,
title = deparse(substitute(object)),
ylab = "Frequency",
xlab = "Minimum Inhibitory Concentration (mg/L)",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
...) {
@ -239,7 +239,7 @@ autoplot.mic <- function(object,
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_RSI, allow_class = "character", has_length = c(1, 3))
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)
@ -264,7 +264,7 @@ autoplot.mic <- function(object,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
colours_SIR = colours_SIR,
fn = as.mic,
language = language,
...
@ -272,9 +272,9 @@ autoplot.mic <- function(object,
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]] <- plot_name_of_I(cols_sub$guideline)
df$cols[df$cols == colours_SIR[1]] <- "Susceptible"
df$cols[df$cols == colours_SIR[2]] <- plot_name_of_I(cols_sub$guideline)
df$cols[df$cols == colours_SIR[3]] <- "Resistant"
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
@ -283,12 +283,12 @@ autoplot.mic <- function(object,
)
p <- ggplot2::ggplot(df)
if (any(colours_RSI %in% cols_sub$cols)) {
if (any(colours_SIR %in% cols_sub$cols)) {
vals <- c(
"Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3]
"Susceptible" = colours_SIR[1],
"Susceptible, incr. exp." = colours_SIR[2],
"Intermediate" = colours_SIR[2],
"Resistant" = colours_SIR[3]
)
names(vals) <- translate_into_language(names(vals), language = language)
p <- p +
@ -329,7 +329,7 @@ plot.disk <- function(x,
mo = NULL,
ab = NULL,
guideline = "EUCAST",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
...) {
@ -339,7 +339,7 @@ plot.disk <- function(x,
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))
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)
@ -351,8 +351,8 @@ plot.disk <- function(x,
xlab <- translate_into_language(xlab, language = language)
}
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
@ -363,7 +363,7 @@ plot.disk <- function(x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
colours_SIR = colours_SIR,
fn = as.disk,
language = language,
...
@ -372,7 +372,7 @@ plot.disk <- function(x,
barplot(x,
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_RSI %in% cols_sub$cols), 1.1, 1)),
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE
@ -382,20 +382,20 @@ plot.disk <- function(x,
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
}
if (any(colours_RSI %in% cols_sub$cols)) {
if (any(colours_SIR %in% cols_sub$cols)) {
legend_txt <- character(0)
legend_col <- character(0)
if (any(cols_sub$cols == colours_RSI[1] & cols_sub$count > 0)) {
if (any(cols_sub$cols == colours_SIR[3] & cols_sub$count > 0)) {
legend_txt <- "Resistant"
legend_col <- colours_RSI[1]
legend_col <- colours_SIR[3]
}
if (any(cols_sub$cols == colours_RSI[3] & cols_sub$count > 0)) {
if (any(cols_sub$cols == colours_SIR[2] & cols_sub$count > 0)) {
legend_txt <- c(legend_txt, plot_name_of_I(cols_sub$guideline))
legend_col <- c(legend_col, colours_RSI[3])
legend_col <- c(legend_col, colours_SIR[2])
}
if (any(cols_sub$cols == colours_RSI[2] & cols_sub$count > 0)) {
if (any(cols_sub$cols == colours_SIR[1] & cols_sub$count > 0)) {
legend_txt <- c(legend_txt, "Susceptible")
legend_col <- c(legend_col, colours_RSI[2])
legend_col <- c(legend_col, colours_SIR[1])
}
legend("top",
x.intersp = 0.5,
@ -420,7 +420,7 @@ barplot.disk <- function(height,
mo = NULL,
ab = NULL,
guideline = "EUCAST",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
...) {
@ -430,7 +430,7 @@ barplot.disk <- function(height,
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))
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)
@ -452,7 +452,7 @@ barplot.disk <- function(height,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
colours_SIR = colours_SIR,
...
)
}
@ -467,7 +467,7 @@ autoplot.disk <- function(object,
ylab = "Frequency",
xlab = "Disk diffusion diameter (mm)",
guideline = "EUCAST",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
colours_SIR = c("#3CAEA3", "#F6D55C", "#ED553B"),
language = get_AMR_locale(),
expand = TRUE,
...) {
@ -478,7 +478,7 @@ autoplot.disk <- function(object,
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))
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)
@ -503,7 +503,7 @@ autoplot.disk <- function(object,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
colours_SIR = colours_SIR,
fn = as.disk,
language = language,
...
@ -512,9 +512,9 @@ autoplot.disk <- function(object,
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[df$cols == colours_SIR[1]] <- "Susceptible"
df$cols[df$cols == colours_SIR[2]] <- plot_name_of_I(cols_sub$guideline)
df$cols[df$cols == colours_SIR[3]] <- "Resistant"
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
@ -523,12 +523,12 @@ autoplot.disk <- function(object,
)
p <- ggplot2::ggplot(df)
if (any(colours_RSI %in% cols_sub$cols)) {
if (any(colours_SIR %in% cols_sub$cols)) {
vals <- c(
"Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3]
"Susceptible" = colours_SIR[1],
"Susceptible, incr. exp." = colours_SIR[2],
"Intermediate" = colours_SIR[2],
"Resistant" = colours_SIR[3]
)
names(vals) <- translate_into_language(names(vals), language = language)
p <- p +
@ -558,11 +558,11 @@ fortify.disk <- function(object, ...) {
)
}
#' @method plot rsi
#' @method plot sir
#' @export
#' @importFrom graphics plot text axis
#' @rdname plot
plot.rsi <- function(x,
plot.sir <- function(x,
ylab = "Percentage",
xlab = "Antimicrobial Interpretation",
main = deparse(substitute(x)),
@ -627,22 +627,22 @@ plot.rsi <- function(x,
}
#' @method barplot rsi
#' @method barplot sir
#' @importFrom graphics barplot axis
#' @export
#' @noRd
barplot.rsi <- function(height,
barplot.sir <- function(height,
main = deparse(substitute(height)),
xlab = "Antimicrobial Interpretation",
ylab = "Frequency",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
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_RSI, allow_class = "character", has_length = c(1, 3))
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)
@ -654,17 +654,15 @@ barplot.rsi <- function(height,
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])
if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
x <- table(height)
x <- x[c(1, 2, 3)]
barplot(x,
col = colours_RSI,
col = colours_SIR,
xlab = xlab,
main = main,
ylab = ylab,
@ -673,21 +671,21 @@ barplot.rsi <- function(height,
axis(2, seq(0, max(x)))
}
#' @method autoplot rsi
#' @method autoplot sir
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
autoplot.rsi <- function(object,
autoplot.sir <- function(object,
title = deparse(substitute(object)),
xlab = "Antimicrobial Interpretation",
ylab = "Frequency",
colours_RSI = c("#ED553B", "#3CAEA3", "#F6D55C"),
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_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3))
# translate if not specifically set
if (missing(ylab)) {
@ -704,20 +702,20 @@ autoplot.rsi <- function(object,
title <- gsub(" +", " ", paste0(title, collapse = " "))
}
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
if (length(colours_SIR) == 1) {
colours_SIR <- rep(colours_SIR, 3)
}
df <- as.data.frame(table(object), stringsAsFactors = TRUE)
colnames(df) <- c("rsi", "count")
colnames(df) <- c("sir", "count")
ggplot2::ggplot(df) +
ggplot2::geom_col(ggplot2::aes(x = rsi, y = count, fill = rsi)) +
ggplot2::geom_col(ggplot2::aes(x = sir, y = count, fill = sir)) +
# 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]
"S" = colours_SIR[1],
"I" = colours_SIR[2],
"R" = colours_SIR[3]
),
limits = force
) +
@ -725,10 +723,10 @@ autoplot.rsi <- function(object,
ggplot2::theme(legend.position = "none")
}
#' @method fortify rsi
#' @method fortify sir
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
fortify.rsi <- function(object, ...) {
fortify.sir <- function(object, ...) {
stats::setNames(
as.data.frame(table(object)),
c("x", "y")
@ -782,18 +780,18 @@ plot_name_of_I <- function(guideline) {
}
}
plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_RSI, fn, language, ...) {
guideline <- get_guideline(guideline, AMR::rsi_translation)
plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_SIR, fn, language, ...) {
guideline <- get_guideline(guideline, AMR::clinical_breakpoints)
if (!is.null(mo) && !is.null(ab)) {
# interpret and give colour based on MIC values
mo <- as.mo(mo)
ab <- as.ab(ab)
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]
sir <- suppressWarnings(suppressMessages(as.sir(fn(names(x)), mo = mo, ab = ab, guideline = guideline, ...)))
cols <- character(length = length(sir))
cols[is.na(sir)] <- "#BEBEBE"
cols[sir == "S"] <- colours_SIR[1]
cols[sir == "I"] <- colours_SIR[2]
cols[sir == "R"] <- colours_SIR[3]
moname <- mo_name(mo, language = language)
abname <- ab_name(ab, language = language)
if (all(cols == "#BEBEBE")) {

76
R/proportion.R
View File

@ -32,28 +32,28 @@
#' @description These functions can be used to calculate the (co-)resistance or susceptibility of microbial isolates (i.e. percentage of S, SI, I, IR or R). All functions support quasiquotation with pipes, can be used in `summarise()` from the `dplyr` package and also support grouped variables, see *Examples*.
#'
#' [resistance()] should be used to calculate resistance, [susceptibility()] should be used to calculate susceptibility.\cr
#' @param ... one or more vectors (or columns) with antibiotic interpretations. They will be transformed internally with [as.rsi()] if needed. Use multiple columns to calculate (the lack of) co-resistance: the probability where one of two drugs have a resistant or susceptible result. See *Examples*.
#' @param ... one or more vectors (or columns) with antibiotic interpretations. They will be transformed internally with [as.sir()] if needed. Use multiple columns to calculate (the lack of) co-resistance: the probability where one of two drugs have a resistant or susceptible result. See *Examples*.
#' @param minimum the minimum allowed number of available (tested) isolates. Any isolate count lower than `minimum` will return `NA` with a warning. The default number of `30` isolates is advised by the Clinical and Laboratory Standards Institute (CLSI) as best practice, see *Source*.
#' @param as_percent a [logical] to indicate whether the output must be returned as a hundred fold with % sign (a character). A value of `0.123456` will then be returned as `"12.3%"`.
#' @param only_all_tested (for combination therapies, i.e. using more than one variable for `...`): a [logical] to indicate that isolates must be tested for all antibiotics, see section *Combination Therapy* below
#' @param data a [data.frame] containing columns with class [`rsi`] (see [as.rsi()])
#' @param data a [data.frame] containing columns with class [`sir`] (see [as.sir()])
#' @param translate_ab a column name of the [antibiotics] data set to translate the antibiotic abbreviations to, using [ab_property()]
#' @inheritParams ab_property
#' @param combine_SI a [logical] to indicate whether all values of S and I must be merged into one, so the output only consists of S+I vs. R (susceptible vs. resistant), defaults to `TRUE`
#' @param ab_result antibiotic results to test against, must be one of more values of "R", "S", "I"
#' @param confidence_level the confidence level for the returned confidence interval. For the calculation, the number of S or SI isolates, and R isolates are compared with the total number of available isolates with R, S, or I by using [binom.test()], i.e., the Clopper-Pearson method.
#' @param side the side of the confidence interval to return. Defaults to `"both"` for a length 2 vector, but can also be (abbreviated as) `"min"`/`"left"`/`"lower"`/`"less"` or `"max"`/`"right"`/`"higher"`/`"greater"`.
#' @inheritSection as.rsi Interpretation of R and S/I
#' @inheritSection as.sir Interpretation of R and S/I
#' @details
#' The function [resistance()] is equal to the function [proportion_R()]. The function [susceptibility()] is equal to the function [proportion_SI()].
#'
#' Use [rsi_confidence_interval()] to calculate the confidence interval, which relies on [binom.test()], i.e., the Clopper-Pearson method. This function returns a vector of length 2 at default for antimicrobial *resistance*. Change the `side` argument to "left"/"min" or "right"/"max" to return a single value, and change the `ab_result` argument to e.g. `c("S", "I")` to test for antimicrobial *susceptibility*, see Examples.
#' Use [sir_confidence_interval()] to calculate the confidence interval, which relies on [binom.test()], i.e., the Clopper-Pearson method. This function returns a vector of length 2 at default for antimicrobial *resistance*. Change the `side` argument to "left"/"min" or "right"/"max" to return a single value, and change the `ab_result` argument to e.g. `c("S", "I")` to test for antimicrobial *susceptibility*, see Examples.
#'
#' **Remember that you should filter your data to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them in your data set.
#'
#' These functions are not meant to count isolates, but to calculate the proportion of resistance/susceptibility. Use the [`count()`][AMR::count()] functions to count isolates. The function [susceptibility()] is essentially equal to `count_susceptible() / count_all()`. *Low counts can influence the outcome - the `proportion` functions may camouflage this, since they only return the proportion (albeit being dependent on the `minimum` argument).*
#'
#' The function [proportion_df()] takes any variable from `data` that has an [`rsi`] class (created with [as.rsi()]) and calculates the proportions R, I and S. It also supports grouped variables. The function [rsi_df()] works exactly like [proportion_df()], but adds the number of isolates.
#' The function [proportion_df()] takes any variable from `data` that has an [`sir`] class (created with [as.sir()]) and calculates the proportions S, I, and R. It also supports grouped variables. The function [sir_sf()] works exactly like [proportion_df()], but adds the number of isolates.
#' @section Combination Therapy:
#' When using more than one variable for `...` (= combination therapy), use `only_all_tested` to only count isolates that are tested for all antibiotics/variables that you test them for. See this example for two antibiotics, Drug A and Drug B, about how [susceptibility()] works to calculate the %SI:
#'
@ -102,14 +102,14 @@
#' # base R ------------------------------------------------------------
#' # determines %R
#' resistance(example_isolates$AMX)
#' rsi_confidence_interval(example_isolates$AMX)
#' rsi_confidence_interval(example_isolates$AMX,
#' sir_confidence_interval(example_isolates$AMX)
#' sir_confidence_interval(example_isolates$AMX,
#' confidence_level = 0.975
#' )
#'
#' # determines %S+I:
#' susceptibility(example_isolates$AMX)
#' rsi_confidence_interval(example_isolates$AMX,
#' sir_confidence_interval(example_isolates$AMX,
#' ab_result = c("S", "I")
#' )
#'
@ -127,16 +127,16 @@
#' group_by(ward) %>%
#' summarise(
#' r = resistance(CIP),
#' n = n_rsi(CIP)
#' ) # n_rsi works like n_distinct in dplyr, see ?n_rsi
#' n = n_sir(CIP)
#' ) # n_sir works like n_distinct in dplyr, see ?n_sir
#' }
#' if (require("dplyr")) {
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(
#' cipro_R = resistance(CIP),
#' ci_min = rsi_confidence_interval(CIP, side = "min"),
#' ci_max = rsi_confidence_interval(CIP, side = "max"),
#' ci_min = sir_confidence_interval(CIP, side = "min"),
#' ci_max = sir_confidence_interval(CIP, side = "max"),
#' )
#' }
#' if (require("dplyr")) {
@ -157,7 +157,7 @@
#' R = resistance(CIP, as_percent = TRUE),
#' SI = susceptibility(CIP, as_percent = TRUE),
#' n1 = count_all(CIP), # the actual total; sum of all three
#' n2 = n_rsi(CIP), # same - analogous to n_distinct
#' n2 = n_sir(CIP), # same - analogous to n_distinct
#' total = n()
#' ) # NOT the number of tested isolates!
#'
@ -206,11 +206,11 @@
#' proportion_df(translate = FALSE)
#'
#' # It also supports grouping variables
#' # (use rsi_df to also include the count)
#' # (use sir_sf to also include the count)
#' example_isolates %>%
#' select(ward, AMX, CIP) %>%
#' group_by(ward) %>%
#' rsi_df(translate = FALSE)
#' sir_sf(translate = FALSE)
#' }
#' }
resistance <- function(...,
@ -218,14 +218,14 @@ resistance <- function(...,
as_percent = FALSE,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = "R",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -236,50 +236,50 @@ susceptibility <- function(...,
as_percent = FALSE,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = c("S", "I"),
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
#' @rdname proportion
#' @export
rsi_confidence_interval <- function(...,
sir_confidence_interval <- function(...,
ab_result = "R",
minimum = 30,
as_percent = FALSE,
only_all_tested = FALSE,
confidence_level = 0.95,
side = "both") {
meet_criteria(ab_result, allow_class = c("character", "rsi"), has_length = c(1, 2, 3), is_in = c("R", "S", "I"))
meet_criteria(ab_result, allow_class = c("character", "sir"), has_length = c(1, 2, 3), is_in = c("R", "S", "I"))
meet_criteria(confidence_level, allow_class = "numeric", is_positive = TRUE, has_length = 1)
meet_criteria(side, allow_class = "character", has_length = 1, is_in = c("both", "b", "left", "l", "lower", "lowest", "less", "min", "right", "r", "higher", "highest", "greater", "g", "max"))
x <- tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = ab_result,
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
n <- tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = c("S", "I", "R"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
if (n < minimum) {
warning_("Introducing NA: ",
ifelse(n == 0, "no", paste("only", n)),
" results available for `rsi_confidence_interval()` (`minimum` = ", minimum, ").",
" results available for `sir_confidence_interval()` (`minimum` = ", minimum, ").",
call = FALSE
)
if (as_percent == TRUE) {
@ -311,14 +311,14 @@ proportion_R <- function(...,
as_percent = FALSE,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = "R",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -329,14 +329,14 @@ proportion_IR <- function(...,
as_percent = FALSE,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = c("I", "R"),
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -347,14 +347,14 @@ proportion_I <- function(...,
as_percent = FALSE,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = "I",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -365,14 +365,14 @@ proportion_SI <- function(...,
as_percent = FALSE,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = c("S", "I"),
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -383,14 +383,14 @@ proportion_S <- function(...,
as_percent = FALSE,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
sir_calc(...,
ab_result = "S",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(gsub("in rsi_calc(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
}
@ -404,7 +404,7 @@ proportion_df <- function(data,
combine_SI = TRUE,
confidence_level = 0.95) {
tryCatch(
rsi_calc_df(
sir_calc_df(
type = "proportion",
data = data,
translate_ab = translate_ab,
@ -414,6 +414,6 @@ proportion_df <- function(data,
combine_SI = combine_SI,
confidence_level = confidence_level
),
error = function(e) stop_(gsub("in rsi_calc_df(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc_df(): ", "", e$message, fixed = TRUE), call = -5)
)
}

16
R/random.R
View File

@ -27,17 +27,17 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Random MIC Values/Disk Zones/RSI Generation
#' Random MIC Values/Disk Zones/SIR Generation
#'
#' 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 drug, the generated results will reflect reality as much as possible.
#' @param size desired size of the returned vector. If used in a [data.frame] call or `dplyr` verb, will get the current (group) size if left blank.
#' @param mo any [character] that can be coerced to a valid microorganism code with [as.mo()]
#' @param ab any [character] that can be coerced to a valid antimicrobial drug code with [as.ab()]
#' @param prob_RSI a vector of length 3: the probabilities for "R" (1st value), "S" (2nd value) and "I" (3rd value)
#' @param prob_SIR a vector of length 3: the probabilities for "S" (1st value), "I" (2nd value) and "R" (3rd value)
#' @param ... ignored, only in place to allow future extensions
#' @details The base \R function [sample()] is used for generating values.
#'
#' Generated values are based on the EUCAST `r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))` guideline as implemented in the [rsi_translation] data set. To create specific generated values per bug or drug, set the `mo` and/or `ab` argument.
#' Generated values are based on the EUCAST `r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))` guideline as implemented in the [clinical_breakpoints] data set. To create specific generated values per bug or drug, set the `mo` and/or `ab` argument.
#' @return class `mic` for [random_mic()] (see [as.mic()]) and class `disk` for [random_disk()] (see [as.disk()])
#' @name random
#' @rdname random
@ -45,7 +45,7 @@
#' @examples
#' random_mic(25)
#' random_disk(25)
#' random_rsi(25)
#' random_sir(25)
#'
#' \donttest{
#' # make the random generation more realistic by setting a bug and/or drug:
@ -81,17 +81,17 @@ random_disk <- function(size = NULL, mo = NULL, ab = NULL, ...) {
#' @rdname random
#' @export
random_rsi <- function(size = NULL, prob_RSI = c(0.33, 0.33, 0.33), ...) {
random_sir <- function(size = NULL, prob_SIR = c(0.33, 0.33, 0.33), ...) {
meet_criteria(size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE, allow_NULL = TRUE)
meet_criteria(prob_RSI, allow_class = c("numeric", "integer"), has_length = 3)
meet_criteria(prob_SIR, allow_class = c("numeric", "integer"), has_length = 3)
if (is.null(size)) {
size <- NROW(get_current_data(arg_name = "size", call = -3))
}
sample(as.rsi(c("R", "S", "I")), size = size, replace = TRUE, prob = prob_RSI)
sample(as.sir(c("S", "I", "R")), size = size, replace = TRUE, prob = prob_SIR)
}
random_exec <- function(type, size, mo = NULL, ab = NULL) {
df <- rsi_translation %pm>%
df <- clinical_breakpoints %pm>%
pm_filter(guideline %like% "EUCAST") %pm>%
pm_arrange(pm_desc(guideline)) %pm>%
subset(guideline == max(guideline) &

12
R/resistance_predict.R
View File

@ -44,7 +44,7 @@
#' @param main title of the plot
#' @param ribbon a [logical] to indicate whether a ribbon should be shown (default) or error bars
#' @param ... arguments passed on to functions
#' @inheritSection as.rsi Interpretation of R and S/I
#' @inheritSection as.sir Interpretation of R and S/I
#' @inheritParams first_isolate
#' @inheritParams graphics::plot
#' @details Valid options for the statistical model (argument `model`) are:
@ -76,7 +76,7 @@
#' plot(x)
#' \donttest{
#' if (require("ggplot2")) {
#' ggplot_rsi_predict(x)
#' ggplot_sir_predict(x)
#' }
#'
#' # using dplyr:
@ -156,7 +156,7 @@ resistance_predict <- function(x,
}
df <- x
df[, col_ab] <- droplevels(as.rsi(df[, col_ab, drop = TRUE]))
df[, col_ab] <- droplevels(as.sir(df[, col_ab, drop = TRUE]))
if (I_as_S == TRUE) {
# then I as S
df[, col_ab] <- gsub("I", "S", df[, col_ab, drop = TRUE], fixed = TRUE)
@ -286,7 +286,7 @@ resistance_predict <- function(x,
#' @rdname resistance_predict
#' @export
rsi_predict <- resistance_predict
sir_predict <- resistance_predict
#' @method plot resistance_predict
#' @export
@ -341,7 +341,7 @@ plot.resistance_predict <- function(x, main = paste("Resistance Prediction of",
#' @rdname resistance_predict
#' @export
ggplot_rsi_predict <- function(x,
ggplot_sir_predict <- function(x,
main = paste("Resistance Prediction of", x_name),
ribbon = TRUE,
...) {
@ -402,7 +402,7 @@ autoplot.resistance_predict <- function(object,
x_name <- paste0(ab_name(attributes(object)$ab), " (", attributes(object)$ab, ")")
meet_criteria(main, allow_class = "character", has_length = 1)
meet_criteria(ribbon, allow_class = "logical", has_length = 1)
ggplot_rsi_predict(x = object, main = main, ribbon = ribbon, ...)
ggplot_sir_predict(x = object, main = main, ribbon = ribbon, ...)
}
#' @method fortify resistance_predict

378
R/rsi.R → R/sir.R
View File

@ -27,50 +27,50 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Interpret MIC and Disk Values, or Clean Raw R/SI Data
#' Interpret MIC and Disk Values, or Clean Raw SIR Data
#'
#' Interpret minimum inhibitory concentration (MIC) values and disk diffusion diameters according to EUCAST or CLSI, or clean up existing R/SI values. This transforms the input to a new class [`rsi`], which is an ordered [factor] with levels `S < I < R`.
#' @rdname as.rsi
#' Interpret minimum inhibitory concentration (MIC) values and disk diffusion diameters according to EUCAST or CLSI, or clean up existing SIR values. This transforms the input to a new class [`sir`], which is an ordered [factor] with levels `S < I < R`.
#' @rdname as.sir
#' @param x vector of values (for class [`mic`]: MIC values in mg/L, for class [`disk`]: a disk diffusion radius in millimetres)
#' @param mo any (vector of) text that can be coerced to valid microorganism codes with [as.mo()], can be left empty to determine it automatically
#' @param ab any (vector of) text that can be coerced to a valid antimicrobial drug code with [as.ab()]
#' @param uti (Urinary Tract Infection) A vector with [logical]s (`TRUE` or `FALSE`) to specify whether a UTI specific interpretation from the guideline should be chosen. For using [as.rsi()] on a [data.frame], this can also be a column containing [logical]s or when left blank, the data set will be searched for a column 'specimen', and rows within this column containing 'urin' (such as 'urine', 'urina') will be regarded isolates from a UTI. See *Examples*.
#' @param uti (Urinary Tract Infection) A vector with [logical]s (`TRUE` or `FALSE`) to specify whether a UTI specific interpretation from the guideline should be chosen. For using [as.sir()] on a [data.frame], this can also be a column containing [logical]s or when left blank, the data set will be searched for a column 'specimen', and rows within this column containing 'urin' (such as 'urine', 'urina') will be regarded isolates from a UTI. See *Examples*.
#' @inheritParams first_isolate
#' @param guideline defaults to EUCAST `r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))` (the latest implemented EUCAST guideline in the [rsi_translation] data set), but can be set with the [option][options()] `AMR_guideline`. Supports EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`), see *Details*.
#' @param guideline defaults to EUCAST `r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))` (the latest implemented EUCAST guideline in the [clinical_breakpoints] data set), but can be set with the [option][options()] `AMR_guideline`. Supports EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`), see *Details*.
#' @param conserve_capped_values a [logical] to indicate that MIC values starting with `">"` (but not `">="`) must always return "R" , and that MIC values starting with `"<"` (but not `"<="`) must always return "S"
#' @param add_intrinsic_resistance *(only useful when using a EUCAST guideline)* a [logical] to indicate whether intrinsic antibiotic resistance must also be considered for applicable bug-drug combinations, meaning that e.g. ampicillin will always return "R" in *Klebsiella* species. Determination is based on the [intrinsic_resistant] data set, that itself is based on `r format_eucast_version_nr(3.3)`.
#' @param reference_data a [data.frame] to be used for interpretation, which defaults to the [rsi_translation] data set. Changing this argument allows for using own interpretation guidelines. This argument must contain a data set that is equal in structure to the [rsi_translation] data set (same column names and column types). Please note that the `guideline` argument will be ignored when `reference_data` is manually set.
#' @param reference_data a [data.frame] to be used for interpretation, which defaults to the [clinical_breakpoints] data set. Changing this argument allows for using own interpretation guidelines. This argument must contain a data set that is equal in structure to the [clinical_breakpoints] data set (same column names and column types). Please note that the `guideline` argument will be ignored when `reference_data` is manually set.
#' @param threshold maximum fraction of invalid antimicrobial interpretations of `x`, see *Examples*
#' @param ... for using on a [data.frame]: names of columns to apply [as.rsi()] on (supports tidy selection such as `column1:column4`). Otherwise: arguments passed on to methods.
#' @param ... for using on a [data.frame]: names of columns to apply [as.sir()] on (supports tidy selection such as `column1:column4`). Otherwise: arguments passed on to methods.
#' @details
#' ### How it Works
#'
#' The [as.rsi()] function works in four ways:
#' The [as.sir()] function works in four ways:
#'
#' 1. For **cleaning raw / untransformed data**. The data will be cleaned to only contain values S, I and R and will try its best to determine this with some intelligence. For example, mixed values with R/SI interpretations and MIC values such as `"<0.25; S"` will be coerced to `"S"`. Combined interpretations for multiple test methods (as seen in laboratory records) such as `"S; S"` will be coerced to `"S"`, but a value like `"S; I"` will return `NA` with a warning that the input is unclear.
#' 1. For **cleaning raw / untransformed data**. The data will be cleaned to only contain values S, I and R and will try its best to determine this with some intelligence. For example, mixed values with SIR interpretations and MIC values such as `"<0.25; S"` will be coerced to `"S"`. Combined interpretations for multiple test methods (as seen in laboratory records) such as `"S; S"` will be coerced to `"S"`, but a value like `"S; I"` will return `NA` with a warning that the input is unclear.
#'
#' 2. For **interpreting minimum inhibitory concentration (MIC) values** according to EUCAST or CLSI. You must clean your MIC values first using [as.mic()], that also gives your columns the new data class [`mic`]. Also, be sure to have a column with microorganism names or codes. It will be found automatically, but can be set manually using the `mo` argument.
#' * Using `dplyr`, R/SI interpretation can be done very easily with either:
#' * Using `dplyr`, SIR interpretation can be done very easily with either:
#' ```
#' your_data %>% mutate_if(is.mic, as.rsi)
#' your_data %>% mutate(across(where(is.mic), as.rsi))
#' your_data %>% mutate_if(is.mic, as.sir)
#' your_data %>% mutate(across(where(is.mic), as.sir))
#' ```
#' * Operators like "<=" will be stripped before interpretation. When using `conserve_capped_values = TRUE`, an MIC value of e.g. ">2" will always return "R", even if the breakpoint according to the chosen guideline is ">=4". This is to prevent that capped values from raw laboratory data would not be treated conservatively. The default behaviour (`conserve_capped_values = FALSE`) considers ">2" to be lower than ">=4" and might in this case return "S" or "I".
#' 3. For **interpreting disk diffusion diameters** according to EUCAST or CLSI. You must clean your disk zones first using [as.disk()], that also gives your columns the new data class [`disk`]. Also, be sure to have a column with microorganism names or codes. It will be found automatically, but can be set manually using the `mo` argument.
#' * Using `dplyr`, R/SI interpretation can be done very easily with either:
#' * Using `dplyr`, SIR interpretation can be done very easily with either:
#' ```
#' your_data %>% mutate_if(is.disk, as.rsi)
#' your_data %>% mutate(across(where(is.disk), as.rsi))
#' your_data %>% mutate_if(is.disk, as.sir)
#' your_data %>% mutate(across(where(is.disk), as.sir))
#' ```
#' 4. For **interpreting a complete data set**, with automatic determination of MIC values, disk diffusion diameters, microorganism names or codes, and antimicrobial test results. This is done very simply by running `as.rsi(your_data)`.
#' 4. For **interpreting a complete data set**, with automatic determination of MIC values, disk diffusion diameters, microorganism names or codes, and antimicrobial test results. This is done very simply by running `as.sir(your_data)`.
#'
#' For points 2, 3 and 4: Use [rsi_interpretation_history()] to retrieve a [data.frame] (or [tibble][tibble::tibble()] if the `tibble` package is installed) with all results of the last [as.rsi()] call.
#' For points 2, 3 and 4: Use [sir_interpretation_history()] to retrieve a [data.frame] (or [tibble][tibble::tibble()] if the `tibble` package is installed) with all results of the last [as.sir()] call.
#'
#' ### Supported Guidelines
#'
#' For interpreting MIC values as well as disk diffusion diameters, currently implemented guidelines are EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`).
#' For interpreting MIC values as well as disk diffusion diameters, currently implemented guidelines are EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`).
#'
#' Thus, the `guideline` argument must be set to e.g., ``r paste0('"', subset(rsi_translation, guideline %like% "EUCAST")$guideline[1], '"')`` or ``r paste0('"', subset(rsi_translation, guideline %like% "CLSI")$guideline[1], '"')``. By simply using `"EUCAST"` (the default) or `"CLSI"` as input, the latest included version of that guideline will automatically be selected. You can set your own data set using the `reference_data` argument. The `guideline` argument will then be ignored.
#' Thus, the `guideline` argument must be set to e.g., ``r paste0('"', subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline[1], '"')`` or ``r paste0('"', subset(clinical_breakpoints, guideline %like% "CLSI")$guideline[1], '"')``. By simply using `"EUCAST"` (the default) or `"CLSI"` as input, the latest included version of that guideline will automatically be selected. You can set your own data set using the `reference_data` argument. The `guideline` argument will then be ignored.
#'
#' You can set the default guideline with the `AMR_guideline` [option][options()] (e.g. in your `.Rprofile` file), such as:
#'
@ -84,17 +84,17 @@
#'
#' ### After Interpretation
#'
#' After using [as.rsi()], you can use the [eucast_rules()] defined by EUCAST to (1) apply inferred susceptibility and resistance based on results of other antimicrobials and (2) apply intrinsic resistance based on taxonomic properties of a microorganism.
#' After using [as.sir()], you can use the [eucast_rules()] defined by EUCAST to (1) apply inferred susceptibility and resistance based on results of other antimicrobials and (2) apply intrinsic resistance based on taxonomic properties of a microorganism.
#'
#' ### Machine-Readable Interpretation Guidelines
#'
#' The repository of this package [contains a machine-readable version](https://github.com/msberends/AMR/blob/main/data-raw/rsi_translation.txt) of all guidelines. This is a CSV file consisting of `r format(nrow(AMR::rsi_translation), big.mark = ",")` rows and `r ncol(AMR::rsi_translation)` columns. This file is machine-readable, since it contains one row for every unique combination of the test method (MIC or disk diffusion), the antimicrobial drug and the microorganism. **This allows for easy implementation of these rules in laboratory information systems (LIS)**. Note that it only contains interpretation guidelines for humans - interpretation guidelines from CLSI for animals were removed.
#' The repository of this package [contains a machine-readable version](https://github.com/msberends/AMR/blob/main/data-raw/clinical_breakpoints.txt) of all guidelines. This is a CSV file consisting of `r format(nrow(AMR::clinical_breakpoints), big.mark = ",")` rows and `r ncol(AMR::clinical_breakpoints)` columns. This file is machine-readable, since it contains one row for every unique combination of the test method (MIC or disk diffusion), the antimicrobial drug and the microorganism. **This allows for easy implementation of these rules in laboratory information systems (LIS)**. Note that it only contains interpretation guidelines for humans - interpretation guidelines from CLSI for animals were removed.
#'
#' ### Other
#'
#' The function [is.rsi()] detects if the input contains class `rsi`. If the input is a [data.frame], it iterates over all columns and returns a [logical] vector.
#' The function [is.sir()] detects if the input contains class `sir`. If the input is a [data.frame], it iterates over all columns and returns a [logical] vector.
#'
#' The function [is.rsi.eligible()] returns `TRUE` when a columns contains at most 5% invalid antimicrobial interpretations (not S and/or I and/or R), and `FALSE` otherwise. The threshold of 5% can be set with the `threshold` argument. If the input is a [data.frame], it iterates over all columns and returns a [logical] vector.
#' The function [is_sir_eligible()] returns `TRUE` when a columns contains at most 5% invalid antimicrobial interpretations (not S and/or I and/or R), and `FALSE` otherwise. The threshold of 5% can be set with the `threshold` argument. If the input is a [data.frame], it iterates over all columns and returns a [logical] vector.
#' @section Interpretation of R and S/I:
#' In 2019, the European Committee on Antimicrobial Susceptibility Testing (EUCAST) has decided to change the definitions of susceptibility testing categories R and S/I as shown below (<https://www.eucast.org/newsiandr/>).
#'
@ -106,20 +106,20 @@
#' A microorganism is categorised as *Susceptible, Increased exposure* when there is a high likelihood of therapeutic success because exposure to the agent is increased by adjusting the dosing regimen or by its concentration at the site of infection.
#'
#' This AMR package honours this insight. Use [susceptibility()] (equal to [proportion_SI()]) to determine antimicrobial susceptibility and [count_susceptible()] (equal to [count_SI()]) to count susceptible isolates.
#' @return Ordered [factor] with new class `rsi`
#' @aliases rsi
#' @return Ordered [factor] with new class `sir`
#' @aliases sir
#' @export
#' @seealso [as.mic()], [as.disk()], [as.mo()]
#' @source
#' For interpretations of minimum inhibitory concentration (MIC) values and disk diffusion diameters:
#'
#' - **M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data**, `r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`, *Clinical and Laboratory Standards Institute* (CLSI). <https://clsi.org/standards/products/microbiology/documents/m39/>.
#' - **M100 Performance Standard for Antimicrobial Susceptibility Testing**, `r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`, *Clinical and Laboratory Standards Institute* (CLSI). <https://clsi.org/standards/products/microbiology/documents/m100/>.
#' - **Breakpoint tables for interpretation of MICs and zone diameters**, `r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`, *European Committee on Antimicrobial Susceptibility Testing* (EUCAST). <https://www.eucast.org/clinical_breakpoints>.
#' - **M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data**, `r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`, *Clinical and Laboratory Standards Institute* (CLSI). <https://clsi.org/standards/products/microbiology/documents/m39/>.
#' - **M100 Performance Standard for Antimicrobial Susceptibility Testing**, `r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`, *Clinical and Laboratory Standards Institute* (CLSI). <https://clsi.org/standards/products/microbiology/documents/m100/>.
#' - **Breakpoint tables for interpretation of MICs and zone diameters**, `r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`, *European Committee on Antimicrobial Susceptibility Testing* (EUCAST). <https://www.eucast.org/clinical_breakpoints>.
#' @inheritSection AMR Reference Data Publicly Available
#' @examples
#' example_isolates
#' summary(example_isolates) # see all R/SI results at a glance
#' summary(example_isolates) # see all SIR results at a glance
#'
#' # For INTERPRETING disk diffusion and MIC values -----------------------
#'
@ -132,20 +132,20 @@
#' TOB = as.disk(16),
#' ERY = "R"
#' )
#' as.rsi(df)
#' as.sir(df)
#'
#' # return a 'logbook' about the results:
#' rsi_interpretation_history()
#' sir_interpretation_history()
#'
#' # for single values
#' as.rsi(
#' as.sir(
#' x = as.mic(2),
#' mo = as.mo("S. pneumoniae"),
#' ab = "AMP",
#' guideline = "EUCAST"
#' )
#'
#' as.rsi(
#' as.sir(
#' x = as.disk(18),
#' mo = "Strep pneu", # `mo` will be coerced with as.mo()
#' ab = "ampicillin", # and `ab` with as.ab()
@ -155,14 +155,14 @@
#' \donttest{
#' # the dplyr way
#' if (require("dplyr")) {
#' df %>% mutate_if(is.mic, as.rsi)
#' df %>% mutate_if(function(x) is.mic(x) | is.disk(x), as.rsi)
#' df %>% mutate(across(where(is.mic), as.rsi))
#' df %>% mutate_at(vars(AMP:TOB), as.rsi)
#' df %>% mutate(across(AMP:TOB, as.rsi))
#' df %>% mutate_if(is.mic, as.sir)
#' df %>% mutate_if(function(x) is.mic(x) | is.disk(x), as.sir)
#' df %>% mutate(across(where(is.mic), as.sir))
#' df %>% mutate_at(vars(AMP:TOB), as.sir)
#' df %>% mutate(across(AMP:TOB, as.sir))
#'
#' df %>%
#' mutate_at(vars(AMP:TOB), as.rsi, mo = .$microorganism)
#' mutate_at(vars(AMP:TOB), as.sir, mo = .$microorganism)
#'
#' # to include information about urinary tract infections (UTI)
#' data.frame(
@ -170,74 +170,74 @@
#' NIT = c("<= 2", 32),
#' from_the_bladder = c(TRUE, FALSE)
#' ) %>%
#' as.rsi(uti = "from_the_bladder")
#' as.sir(uti = "from_the_bladder")
#'
#' data.frame(
#' mo = "E. coli",
#' NIT = c("<= 2", 32),
#' specimen = c("urine", "blood")
#' ) %>%
#' as.rsi() # automatically determines urine isolates
#' as.sir() # automatically determines urine isolates
#'
#' df %>%
#' mutate_at(vars(AMP:TOB), as.rsi, mo = "E. coli", uti = TRUE)
#' mutate_at(vars(AMP:TOB), as.sir, mo = "E. coli", uti = TRUE)
#' }
#'
#' # For CLEANING existing R/SI values ------------------------------------
#' # For CLEANING existing SIR values ------------------------------------
#'
#' as.rsi(c("S", "I", "R", "A", "B", "C"))
#' as.rsi("<= 0.002; S") # will return "S"
#' rsi_data <- as.rsi(c(rep("S", 474), rep("I", 36), rep("R", 370)))
#' is.rsi(rsi_data)
#' plot(rsi_data) # for percentages
#' barplot(rsi_data) # for frequencies
#' as.sir(c("S", "I", "R", "A", "B", "C"))
#' as.sir("<= 0.002; S") # will return "S"
#' sir_data <- as.sir(c(rep("S", 474), rep("I", 36), rep("R", 370)))
#' is.sir(sir_data)
#' plot(sir_data) # for percentages
#' barplot(sir_data) # for frequencies
#'
#' # the dplyr way
#' if (require("dplyr")) {
#' example_isolates %>%
#' mutate_at(vars(PEN:RIF), as.rsi)
#' mutate_at(vars(PEN:RIF), as.sir)
#' # same:
#' example_isolates %>%
#' as.rsi(PEN:RIF)
#' as.sir(PEN:RIF)
#'
#' # fastest way to transform all columns with already valid AMR results to class `rsi`:
#' # fastest way to transform all columns with already valid AMR results to class `sir`:
#' example_isolates %>%
#' mutate_if(is.rsi.eligible, as.rsi)
#' mutate_if(is_sir_eligible, as.sir)
#'
#' # since dplyr 1.0.0, this can also be:
#' # example_isolates %>%
#' # mutate(across(where(is.rsi.eligible), as.rsi))
#' # mutate(across(where(is_sir_eligible), as.sir))
#' }
#' }
as.rsi <- function(x, ...) {
UseMethod("as.rsi")
as.sir <- function(x, ...) {
UseMethod("as.sir")
}
#' @rdname as.rsi
#' @details `NA_rsi_` is a missing value of the new `rsi` class, analogous to e.g. base \R's [`NA_character_`][base::NA].
#' @rdname as.sir
#' @details `NA_sir_` is a missing value of the new `sir` class, analogous to e.g. base \R's [`NA_character_`][base::NA].
#' @export
NA_rsi_ <- set_clean_class(factor(NA, levels = c("S", "I", "R"), ordered = TRUE),
new_class = c("rsi", "ordered", "factor")
NA_sir_ <- set_clean_class(factor(NA, levels = c("S", "I", "R"), ordered = TRUE),
new_class = c("sir", "ordered", "factor")
)
#' @rdname as.rsi
#' @rdname as.sir
#' @export
is.rsi <- function(x) {
is.sir <- function(x) {
if (inherits(x, "data.frame")) {
unname(vapply(FUN.VALUE = logical(1), x, is.rsi))
unname(vapply(FUN.VALUE = logical(1), x, is.sir))
} else {
inherits(x, "rsi")
inherits(x, "sir")
}
}
#' @rdname as.rsi
#' @rdname as.sir
#' @export
is.rsi.eligible <- function(x, threshold = 0.05) {
is_sir_eligible <- function(x, threshold = 0.05) {
meet_criteria(threshold, allow_class = "numeric", has_length = 1)
if (inherits(x, "data.frame")) {
# iterate this function over all columns
return(unname(vapply(FUN.VALUE = logical(1), x, is.rsi.eligible)))
return(unname(vapply(FUN.VALUE = logical(1), x, is_sir_eligible)))
}
stop_if(NCOL(x) > 1, "`x` must be a one-dimensional vector.")
@ -270,7 +270,7 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
if (!is.na(ab)) {
# this is a valid antibiotic drug code
message_(
"Column '", font_bold(cur_col), "' is as.rsi()-eligible (despite only having empty values), since it seems to be ",
"Column '", font_bold(cur_col), "' is SIR eligible (despite only having empty values), since it seems to be ",
ab_name(ab, language = NULL, tolower = TRUE), " (", ab, ")"
)
return(TRUE)
@ -280,7 +280,7 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
return(FALSE)
}
# transform all values and see if it meets the set threshold
checked <- suppressWarnings(as.rsi(x))
checked <- suppressWarnings(as.sir(x))
outcome <- sum(is.na(checked)) / length(x)
outcome <= threshold
}
@ -288,8 +288,8 @@ is.rsi.eligible <- function(x, threshold = 0.05) {
#' @export
# extra param: warn (logical, to never throw a warning)
as.rsi.default <- function(x, ...) {
if (is.rsi(x)) {
as.sir.default <- function(x, ...) {
if (is.sir(x)) {
return(x)
}
@ -316,9 +316,9 @@ as.rsi.default <- function(x, ...) {
if (all(x %unlike% "(R|S|I)", na.rm = TRUE)) {
# check if they are actually MICs or disks
if (all_valid_mics(x)) {
warning_("in `as.rsi()`: the input seems to contain MIC values. You can transform them with `as.mic()` before running `as.rsi()` to interpret them.")
warning_("in `as.sir()`: the input seems to contain MIC values. You can transform them with `as.mic()` before running `as.sir()` to interpret them.")
} else if (all_valid_disks(x)) {
warning_("in `as.rsi()`: the input seems to contain disk diffusion values. You can transform them with `as.disk()` before running `as.rsi()` to interpret them.")
warning_("in `as.sir()`: the input seems to contain disk diffusion values. You can transform them with `as.disk()` before running `as.sir()` to interpret them.")
}
}
@ -368,14 +368,14 @@ as.rsi.default <- function(x, ...) {
x[!x %in% c("S", "I", "R")] <- NA_character_
na_after <- length(x[is.na(x) | x == ""])
if (!isFALSE(list(...)$warn)) { # so as.rsi(..., warn = FALSE) will never throw a warning
if (!isFALSE(list(...)$warn)) { # so as.sir(..., warn = FALSE) will never throw a warning
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %pm>%
unique() %pm>%
sort() %pm>%
vector_and(quotes = TRUE)
cur_col <- get_current_column()
warning_("in `as.rsi()`: ", na_after - na_before, " result",
warning_("in `as.sir()`: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (",
@ -385,38 +385,38 @@ as.rsi.default <- function(x, ...) {
call = FALSE
)
}
if (any(toupper(x.bak[!is.na(x.bak)]) == "U") && message_not_thrown_before("as.rsi", "U")) {
warning_("in `as.rsi()`: 'U' was interpreted as 'S', following some laboratory systems")
if (any(toupper(x.bak[!is.na(x.bak)]) == "U") && message_not_thrown_before("as.sir", "U")) {
warning_("in `as.sir()`: 'U' was interpreted as 'S', following some laboratory systems")
}
if (any(toupper(x.bak[!is.na(x.bak)]) == "D") && message_not_thrown_before("as.rsi", "D")) {
warning_("in `as.rsi()`: 'D' (dose-dependent) was interpreted as 'I', following some laboratory systems")
if (any(toupper(x.bak[!is.na(x.bak)]) == "D") && message_not_thrown_before("as.sir", "D")) {
warning_("in `as.sir()`: 'D' (dose-dependent) was interpreted as 'I', following some laboratory systems")
}
if (any(toupper(x.bak[!is.na(x.bak)]) == "SDD") && message_not_thrown_before("as.rsi", "SDD")) {
warning_("in `as.rsi()`: 'SDD' (susceptible dose-dependent, coined by CLSI) was interpreted as 'I' to comply with EUCAST's 'I'")
if (any(toupper(x.bak[!is.na(x.bak)]) == "SDD") && message_not_thrown_before("as.sir", "SDD")) {
warning_("in `as.sir()`: 'SDD' (susceptible dose-dependent, coined by CLSI) was interpreted as 'I' to comply with EUCAST's 'I'")
}
if (any(toupper(x.bak[!is.na(x.bak)]) == "H") && message_not_thrown_before("as.rsi", "H")) {
warning_("in `as.rsi()`: 'H' was interpreted as 'I', following some laboratory systems")
if (any(toupper(x.bak[!is.na(x.bak)]) == "H") && message_not_thrown_before("as.sir", "H")) {
warning_("in `as.sir()`: 'H' was interpreted as 'I', following some laboratory systems")
}
}
}
set_clean_class(factor(x, levels = c("S", "I", "R"), ordered = TRUE),
new_class = c("rsi", "ordered", "factor")
new_class = c("sir", "ordered", "factor")
)
}
#' @rdname as.rsi
#' @rdname as.sir
#' @export
as.rsi.mic <- function(x,
as.sir.mic <- function(x,
mo = NULL,
ab = deparse(substitute(x)),
guideline = getOption("AMR_guideline", "EUCAST"),
uti = NULL,
conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
reference_data = AMR::clinical_breakpoints,
...) {
as_rsi_method(
as_sir_method(
method_short = "mic",
method_long = "MIC values",
x = x,
@ -431,17 +431,17 @@ as.rsi.mic <- function(x,
)
}
#' @rdname as.rsi
#' @rdname as.sir
#' @export
as.rsi.disk <- function(x,
as.sir.disk <- function(x,
mo = NULL,
ab = deparse(substitute(x)),
guideline = getOption("AMR_guideline", "EUCAST"),
uti = NULL,
add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation,
reference_data = AMR::clinical_breakpoints,
...) {
as_rsi_method(
as_sir_method(
method_short = "disk",
method_long = "disk diffusion zones",
x = x,
@ -456,16 +456,16 @@ as.rsi.disk <- function(x,
)
}
#' @rdname as.rsi
#' @rdname as.sir
#' @export
as.rsi.data.frame <- function(x,
as.sir.data.frame <- function(x,
...,
col_mo = NULL,
guideline = getOption("AMR_guideline", "EUCAST"),
uti = NULL,
conserve_capped_values = FALSE,
add_intrinsic_resistance = FALSE,
reference_data = AMR::rsi_translation) {
reference_data = AMR::clinical_breakpoints) {
meet_criteria(x, allow_class = "data.frame") # will also check for dimensions > 0
meet_criteria(col_mo, allow_class = "character", is_in = colnames(x), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1)
@ -525,7 +525,7 @@ as.rsi.data.frame <- function(x,
vector_and(values, quotes = TRUE),
" in column '", font_bold(col_specimen),
"' reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1],
".\n Use `as.rsi(uti = FALSE)` to prevent this."
".\n Use `as.sir(uti = FALSE)` to prevent this."
)
} else {
# no data about UTI's found
@ -576,7 +576,7 @@ as.rsi.data.frame <- function(x,
types[vapply(FUN.VALUE = logical(1), x.bak[, ab_cols, drop = FALSE], is.mic)] <- "mic"
types[types == "" & vapply(FUN.VALUE = logical(1), x[, ab_cols, drop = FALSE], all_valid_disks)] <- "disk"
types[types == "" & vapply(FUN.VALUE = logical(1), x[, ab_cols, drop = FALSE], all_valid_mics)] <- "mic"
types[types == "" & !vapply(FUN.VALUE = logical(1), x.bak[, ab_cols, drop = FALSE], is.rsi)] <- "rsi"
types[types == "" & !vapply(FUN.VALUE = logical(1), x.bak[, ab_cols, drop = FALSE], is.sir)] <- "sir"
if (any(types %in% c("mic", "disk"), na.rm = TRUE)) {
# now we need an mo column
stop_if(is.null(col_mo), "`col_mo` must be set")
@ -593,7 +593,7 @@ as.rsi.data.frame <- function(x,
pm_pull(ab_cols[i]) %pm>%
as.character() %pm>%
as.mic() %pm>%
as.rsi(
as.sir(
mo = x_mo,
mo.bak = x[, col_mo, drop = TRUE],
ab = ab_cols[i],
@ -609,7 +609,7 @@ as.rsi.data.frame <- function(x,
pm_pull(ab_cols[i]) %pm>%
as.character() %pm>%
as.disk() %pm>%
as.rsi(
as.sir(
mo = x_mo,
mo.bak = x[, col_mo, drop = TRUE],
ab = ab_cols[i],
@ -619,7 +619,7 @@ as.rsi.data.frame <- function(x,
reference_data = reference_data,
is_data.frame = TRUE
)
} else if (types[i] == "rsi") {
} else if (types[i] == "sir") {
show_message <- FALSE
ab <- ab_cols[i]
ab_coerced <- suppressWarnings(as.ab(ab))
@ -632,17 +632,17 @@ as.rsi.data.frame <- function(x,
appendLF = FALSE,
as_note = FALSE
)
} else if (!is.rsi(x.bak[, ab_cols[i], drop = TRUE])) {
} else if (!is.sir(x.bak[, ab_cols[i], drop = TRUE])) {
show_message <- TRUE
# only print message if class not already set
message_("=> Assigning class 'rsi' to already clean column '", font_bold(ab), "' (",
message_("=> Assigning class 'sir' to already clean column '", font_bold(ab), "' (",
ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE, language = NULL), ")... ",
appendLF = FALSE,
as_note = FALSE
)
}
x[, ab_cols[i]] <- as.rsi.default(x = as.character(x[, ab_cols[i], drop = TRUE]))
x[, ab_cols[i]] <- as.sir.default(x = as.character(x[, ab_cols[i], drop = TRUE]))
if (show_message == TRUE) {
message_(" OK.", add_fn = list(font_green), as_note = FALSE)
}
@ -653,7 +653,7 @@ as.rsi.data.frame <- function(x,
}
get_guideline <- function(guideline, reference_data) {
if (!identical(reference_data, AMR::rsi_translation)) {
if (!identical(reference_data, AMR::clinical_breakpoints)) {
return(guideline)
}
guideline_param <- toupper(guideline)
@ -674,7 +674,7 @@ get_guideline <- function(guideline, reference_data) {
guideline_param
}
as_rsi_method <- function(method_short,
as_sir_method <- function(method_short,
method_long,
x,
mo,
@ -728,15 +728,15 @@ as_rsi_method <- function(method_short,
)
}
if (is.null(mo)) {
stop_("No information was supplied about the microorganisms (missing argument `mo` and no column of class 'mo' found). See ?as.rsi.\n\n",
"To transform certain columns with e.g. mutate(), use `data %>% mutate(across(..., as.rsi, mo = x))`, where x is your column with microorganisms.\n",
"To tranform all ", method_long, " in a data set, use `data %>% as.rsi()` or `data %>% mutate_if(is.", method_short, ", as.rsi)`.",
stop_("No information was supplied about the microorganisms (missing argument `mo` and no column of class 'mo' found). See ?as.sir.\n\n",
"To transform certain columns with e.g. mutate(), use `data %>% mutate(across(..., as.sir, mo = x))`, where x is your column with microorganisms.\n",
"To tranform all ", method_long, " in a data set, use `data %>% as.sir()` or `data %>% mutate_if(is.", method_short, ", as.sir)`.",
call = FALSE
)
}
if (length(ab) == 1 && ab %like% paste0("as.", method_short)) {
stop_("No unambiguous name was supplied about the antibiotic (argument `ab`). See ?as.rsi.", call = FALSE)
stop_("No unambiguous name was supplied about the antibiotic (argument `ab`). See ?as.sir.", call = FALSE)
}
ab.bak <- ab
@ -746,7 +746,7 @@ as_rsi_method <- function(method_short,
} else {
mo.bak <- mo
}
# be sure to take current taxonomy, as the rsi_translation data set only contains current taxonomy
# be sure to take current taxonomy, as the clinical_breakpoints data set only contains current taxonomy
mo <- suppressWarnings(suppressMessages(as.mo(mo, keep_synonyms = FALSE, inf0 = FALSE)))
guideline_coerced <- get_guideline(guideline, reference_data)
if (is.na(ab)) {
@ -755,7 +755,7 @@ as_rsi_method <- function(method_short,
add_fn = font_red,
as_note = FALSE
)
return(as.rsi(rep(NA, length(x))))
return(as.sir(rep(NA, length(x))))
}
if (length(mo) == 1) {
mo <- rep(mo, length(x))
@ -768,8 +768,8 @@ as_rsi_method <- function(method_short,
}
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %unlike% "EUCAST") {
if (message_not_thrown_before("as.rsi", "intrinsic")) {
warning_("in `as.rsi()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
if (message_not_thrown_before("as.sir", "intrinsic")) {
warning_("in `as.sir()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
}
}
@ -791,7 +791,7 @@ as_rsi_method <- function(method_short,
message_("=> Interpreting ", method_long, " of ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
agent_formatted,
mo_var_found,
" according to ", ifelse(identical(reference_data, AMR::rsi_translation),
" according to ", ifelse(identical(reference_data, AMR::clinical_breakpoints),
font_bold(guideline_coerced),
"manually defined 'reference_data'"
),
@ -814,14 +814,14 @@ as_rsi_method <- function(method_short,
df <- data.frame(values = x,
mo = mo,
result = NA_rsi_,
result = NA_sir_,
uti = uti,
stringsAsFactors = FALSE)
if (method == "mic") {
# when as.rsi.mic is called directly
# when as.sir.mic is called directly
df$values <- as.mic(df$values)
} else if (method == "disk") {
# when as.rsi.disk is called directly
# when as.sir.disk is called directly
df$values <- as.disk(df$values)
}
@ -831,7 +831,7 @@ as_rsi_method <- function(method_short,
ab_coerced <- ab
mo_coerced <- mo
if (identical(reference_data, AMR::rsi_translation)) {
if (identical(reference_data, AMR::clinical_breakpoints)) {
breakpoints <- reference_data %pm>%
subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
if (ab_coerced == "AMX" && nrow(breakpoints) == 0) {
@ -851,7 +851,7 @@ as_rsi_method <- function(method_short,
suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
" (", ab_coerced, ")"))
load_mo_uncertainties(metadata_mo)
return(rep(NA_rsi_, nrow(df)))
return(rep(NA_sir_, nrow(df)))
}
if (guideline_coerced %like% "EUCAST") {
@ -865,7 +865,7 @@ as_rsi_method <- function(method_short,
rows <- which(df$mo == mo_unique)
values <- df[rows, "values", drop = TRUE]
uti <- df[rows, "uti", drop = TRUE]
new_rsi <- rep(NA_rsi_, length(rows))
new_sir <- rep(NA_sir_, length(rows))
# find different mo properties
mo_current_genus <- as.mo(mo_genus(mo_unique, language = NULL))
@ -903,7 +903,7 @@ as_rsi_method <- function(method_short,
breakpoints_current <- breakpoints_current %pm>%
# be as specific as possible (i.e. prefer species over genus):
# the below `pm_desc(uti)` will put `TRUE` on top and FALSE on bottom
pm_arrange(rank_index, pm_desc(uti)) # 'uti' is a column in data set 'rsi_translation'
pm_arrange(rank_index, pm_desc(uti)) # 'uti' is a column in data set 'clinical_breakpoints'
} else {
breakpoints_current <- breakpoints_current %pm>%
# sort UTI = FALSE first, then UTI = TRUE
@ -911,16 +911,16 @@ as_rsi_method <- function(method_short,
}
# throw notes for different body sites
if (nrow(breakpoints_current) == 1 && all(breakpoints_current$uti == TRUE) && any(uti %in% c(FALSE, NA)) && message_not_thrown_before("as.rsi", "uti", ab_coerced)) {
if (nrow(breakpoints_current) == 1 && all(breakpoints_current$uti == TRUE) && any(uti %in% c(FALSE, NA)) && message_not_thrown_before("as.sir", "uti", ab_coerced)) {
# only UTI breakpoints available
warning_("in `as.rsi()`: interpretation of ", font_bold(ab_formatted), " is only available for (uncomplicated) urinary tract infections (UTI) for some microorganisms, thus assuming `uti = TRUE`. See `?as.rsi`.")
warning_("in `as.sir()`: interpretation of ", font_bold(ab_formatted), " is only available for (uncomplicated) urinary tract infections (UTI) for some microorganisms, thus assuming `uti = TRUE`. See `?as.sir`.")
rise_warning <- TRUE
} else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && any(is.na(uti)) && all(c(TRUE, FALSE) %in% breakpoints_current$uti, na.rm = TRUE) && message_not_thrown_before("as.rsi", "siteUTI", mo_unique, ab_coerced)) {
} else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && any(is.na(uti)) && all(c(TRUE, FALSE) %in% breakpoints_current$uti, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteUTI", mo_unique, ab_coerced)) {
# both UTI and Non-UTI breakpoints available
msgs <- c(msgs, paste0("Breakpoints for UTI ", font_underline("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming non-UTI. Use argument `uti` to set which isolates are from urine. See `?as.rsi`."))
msgs <- c(msgs, paste0("Breakpoints for UTI ", font_underline("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming non-UTI. Use argument `uti` to set which isolates are from urine. See `?as.sir`."))
breakpoints_current <- breakpoints_current %pm>%
pm_filter(uti == FALSE)
} else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && all(breakpoints_current$uti == FALSE, na.rm = TRUE) && message_not_thrown_before("as.rsi", "siteOther", mo_unique, ab_coerced)) {
} else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && all(breakpoints_current$uti == FALSE, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteOther", mo_unique, ab_coerced)) {
# breakpoints for multiple body sites available
site <- breakpoints_current[1L, "site", drop = FALSE] # this is the one we'll take
if (is.na(site)) {
@ -934,40 +934,40 @@ as_rsi_method <- function(method_short,
# first check if mo is intrinsic resistant
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %like% "EUCAST" && paste(mo_unique, ab_coerced) %in% AMR_env$intrinsic_resistant) {
msgs <- c(msgs, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, ""))
new_rsi <- rep(as.rsi("R"), length(rows))
new_sir <- rep(as.sir("R"), length(rows))
} else {
# then run the rules
breakpoints_current <- breakpoints_current[1L, , drop = FALSE]
if (method == "mic") {
new_rsi <- quick_case_when(
is.na(values) ~ NA_rsi_,
values <= breakpoints_current$breakpoint_S ~ as.rsi("S"),
guideline_coerced %like% "EUCAST" & values > breakpoints_current$breakpoint_R ~ as.rsi("R"),
guideline_coerced %like% "CLSI" & values >= breakpoints_current$breakpoint_R ~ as.rsi("R"),
new_sir <- quick_case_when(
is.na(values) ~ NA_sir_,
values <= breakpoints_current$breakpoint_S ~ as.sir("S"),
guideline_coerced %like% "EUCAST" & values > breakpoints_current$breakpoint_R ~ as.sir("R"),
guideline_coerced %like% "CLSI" & values >= breakpoints_current$breakpoint_R ~ as.sir("R"),
# return "I" when breakpoints are in the middle
!is.na(breakpoints_current$breakpoint_S) & !is.na(breakpoints_current$breakpoint_R) ~ as.rsi("I"),
!is.na(breakpoints_current$breakpoint_S) & !is.na(breakpoints_current$breakpoint_R) ~ as.sir("I"),
# and NA otherwise
TRUE ~ NA_rsi_
TRUE ~ NA_sir_
)
} else if (method == "disk") {
new_rsi <- quick_case_when(
is.na(values) ~ NA_rsi_,
as.double(values) >= as.double(breakpoints_current$breakpoint_S) ~ as.rsi("S"),
guideline_coerced %like% "EUCAST" & as.double(values) < as.double(breakpoints_current$breakpoint_R) ~ as.rsi("R"),
guideline_coerced %like% "CLSI" & as.double(values) <= as.double(breakpoints_current$breakpoint_R) ~ as.rsi("R"),
new_sir <- quick_case_when(
is.na(values) ~ NA_sir_,
as.double(values) >= as.double(breakpoints_current$breakpoint_S) ~ as.sir("S"),
guideline_coerced %like% "EUCAST" & as.double(values) < as.double(breakpoints_current$breakpoint_R) ~ as.sir("R"),
guideline_coerced %like% "CLSI" & as.double(values) <= as.double(breakpoints_current$breakpoint_R) ~ as.sir("R"),
# return "I" when breakpoints are in the middle
!is.na(breakpoints_current$breakpoint_S) & !is.na(breakpoints_current$breakpoint_R) ~ as.rsi("I"),
!is.na(breakpoints_current$breakpoint_S) & !is.na(breakpoints_current$breakpoint_R) ~ as.sir("I"),
# and NA otherwise
TRUE ~ NA_rsi_
TRUE ~ NA_sir_
)
}
# write to verbose output
AMR_env$rsi_interpretation_history <- rbind(
AMR_env$rsi_interpretation_history,
AMR_env$sir_interpretation_history <- rbind(
AMR_env$sir_interpretation_history,
# recycling 1 to 2 rows does not seem to work, which is why rep() was added
data.frame(
datetime = rep(Sys.time(), length(rows)),
@ -980,14 +980,14 @@ as_rsi_method <- function(method_short,
ref_table = rep(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)),
method = rep(method_coerced, length(rows)),
input = as.double(values),
outcome = as.rsi(new_rsi),
outcome = as.sir(new_sir),
breakpoint_S_R = rep(paste0(breakpoints_current[, "breakpoint_S", drop = TRUE], "-", breakpoints_current[, "breakpoint_R", drop = TRUE]), length(rows)),
stringsAsFactors = FALSE
)
)
}
df[rows, "result"] <- new_rsi
df[rows, "result"] <- new_sir
}
if (isTRUE(rise_warning)) {
@ -1003,26 +1003,26 @@ as_rsi_method <- function(method_short,
df$result
}
#' @rdname as.rsi
#' @rdname as.sir
#' @param clean a [logical] to indicate whether previously stored results should be forgotten after returning the 'logbook' with results
#' @export
rsi_interpretation_history <- function(clean = FALSE) {
sir_interpretation_history <- function(clean = FALSE) {
meet_criteria(clean, allow_class = "logical", has_length = 1)
out.bak <- AMR_env$rsi_interpretation_history
out.bak <- AMR_env$sir_interpretation_history
out <- out.bak
if (NROW(out) == 0) {
message_("No results to return. Run `as.rsi()` on MIC values or disk diffusion zones first to see a 'logbook' data set here.")
message_("No results to return. Run `as.sir()` on MIC values or disk diffusion zones first to see a 'logbook' data set here.")
return(invisible(NULL))
}
out$ab_guideline <- as.ab(out$ab_guideline)
out$mo_guideline <- as.mo(out$mo_guideline)
out$outcome <- as.rsi(out$outcome)
out$outcome <- as.sir(out$outcome)
# keep stored for next use
if (isTRUE(clean)) {
AMR_env$rsi_interpretation_history <- AMR_env$rsi_interpretation_history[0, , drop = FALSE]
AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE]
} else {
AMR_env$rsi_interpretation_history <- out.bak
AMR_env$sir_interpretation_history <- out.bak
}
if (pkg_is_available("tibble", also_load = FALSE)) {
@ -1033,26 +1033,26 @@ rsi_interpretation_history <- function(clean = FALSE) {
}
# will be exported using s3_register() in R/zzz.R
pillar_shaft.rsi <- function(x, ...) {
pillar_shaft.sir <- function(x, ...) {
out <- trimws(format(x))
if (has_colour()) {
# colours will anyway not work when has_colour() == FALSE,
# but then the indentation should also not be applied
out[is.na(x)] <- font_grey(" NA")
out[x == "R"] <- font_red_bg(" R ")
out[x == "S"] <- font_green_bg(" S ")
out[x == "I"] <- font_orange_bg(" I ")
out[x == "R"] <- font_red_bg(" R ")
}
create_pillar_column(out, align = "left", width = 5)
}
# will be exported using s3_register() in R/zzz.R
type_sum.rsi <- function(x, ...) {
"rsi"
type_sum.sir <- function(x, ...) {
"sir"
}
# will be exported using s3_register() in R/zzz.R
freq.rsi <- function(x, ...) {
freq.sir <- function(x, ...) {
x_name <- deparse(substitute(x))
x_name <- gsub(".*[$]", "", x_name)
if (x_name %in% c("x", ".")) {
@ -1096,7 +1096,7 @@ freq.rsi <- function(x, ...) {
# will be exported using s3_register() in R/zzz.R
get_skimmers.rsi <- function(column) {
get_skimmers.sir <- function(column) {
# get the variable name 'skim_variable'
name_call <- function(.data) {
calls <- sys.calls()
@ -1104,7 +1104,7 @@ get_skimmers.rsi <- function(column) {
calls_txt <- vapply(calls, function(x) paste(deparse(x), collapse = ""), FUN.VALUE = character(1))
if (any(calls_txt %like% "skim_variable", na.rm = TRUE)) {
ind <- which(calls_txt %like% "skim_variable")[1L]
vars <- tryCatch(eval(parse(text = ".data$skim_variable$rsi"), envir = frms[[ind]]),
vars <- tryCatch(eval(parse(text = ".data$skim_variable$sir"), envir = frms[[ind]]),
error = function(e) NULL
)
tryCatch(ab_name(as.character(calls[[length(calls)]][[2]]), language = NULL),
@ -1116,7 +1116,7 @@ get_skimmers.rsi <- function(column) {
}
skimr::sfl(
skim_type = "rsi",
skim_type = "sir",
ab_name = name_call,
count_R = count_R,
count_S = count_susceptible,
@ -1127,27 +1127,27 @@ get_skimmers.rsi <- function(column) {
)
}
#' @method print rsi
#' @method print sir
#' @export
#' @noRd
print.rsi <- function(x, ...) {
cat("Class 'rsi'\n")
print.sir <- function(x, ...) {
cat("Class 'sir'\n")
print(as.character(x), quote = FALSE)
}
#' @method droplevels rsi
#' @method droplevels sir
#' @export
#' @noRd
droplevels.rsi <- function(x, exclude = if (any(is.na(levels(x)))) NULL else NA, ...) {
droplevels.sir <- function(x, exclude = if (any(is.na(levels(x)))) NULL else NA, ...) {
x <- droplevels.factor(x, exclude = exclude, ...)
class(x) <- c("rsi", "ordered", "factor")
class(x) <- c("sir", "ordered", "factor")
x
}
#' @method summary rsi
#' @method summary sir
#' @export
#' @noRd
summary.rsi <- function(object, ...) {
summary.sir <- function(object, ...) {
x <- object
n <- sum(!is.na(x))
S <- sum(x == "S", na.rm = TRUE)
@ -1163,7 +1163,7 @@ summary.rsi <- function(object, ...) {
x
}
value <- c(
"Class" = "rsi",
"Class" = "sir",
"%R" = paste0(pad(percentage(R / n, digits = 1)), " (n=", R, ")"),
"%SI" = paste0(pad(percentage((S + I) / n, digits = 1)), " (n=", S + I, ")"),
"- %S" = paste0(pad(percentage(S / n, digits = 1)), " (n=", S, ")"),
@ -1173,59 +1173,59 @@ summary.rsi <- function(object, ...) {
value
}
#' @method [<- rsi
#' @method [<- sir
#' @export
#' @noRd
"[<-.rsi" <- function(i, j, ..., value) {
value <- as.rsi(value)
"[<-.sir" <- function(i, j, ..., value) {
value <- as.sir(value)
y <- NextMethod()
attributes(y) <- attributes(i)
y
}
#' @method [[<- rsi
#' @method [[<- sir
#' @export
#' @noRd
"[[<-.rsi" <- function(i, j, ..., value) {
value <- as.rsi(value)
"[[<-.sir" <- function(i, j, ..., value) {
value <- as.sir(value)
y <- NextMethod()
attributes(y) <- attributes(i)
y
}
#' @method c rsi
#' @method c sir
#' @export
#' @noRd
c.rsi <- function(...) {
as.rsi(unlist(lapply(list(...), as.character)))
c.sir <- function(...) {
as.sir(unlist(lapply(list(...), as.character)))
}
#' @method unique rsi
#' @method unique sir
#' @export
#' @noRd
unique.rsi <- function(x, incomparables = FALSE, ...) {
unique.sir <- function(x, incomparables = FALSE, ...) {
y <- NextMethod()
attributes(y) <- attributes(x)
y
}
#' @method rep rsi
#' @method rep sir
#' @export
#' @noRd
rep.rsi <- function(x, ...) {
rep.sir <- function(x, ...) {
y <- NextMethod()
attributes(y) <- attributes(x)
y
}
check_reference_data <- function(reference_data) {
if (!identical(reference_data, AMR::rsi_translation)) {
class_rsi <- vapply(FUN.VALUE = character(1), rsi_translation, function(x) paste0("<", class(x), ">", collapse = " and "))
if (!identical(reference_data, AMR::clinical_breakpoints)) {
class_sir <- vapply(FUN.VALUE = character(1), clinical_breakpoints, function(x) paste0("<", class(x), ">", collapse = " and "))
class_ref <- vapply(FUN.VALUE = character(1), reference_data, function(x) paste0("<", class(x), ">", collapse = " and "))
if (!all(names(class_rsi) == names(class_ref))) {
stop_("`reference_data` must have the same column names as the 'rsi_translation' data set.", call = -2)
if (!all(names(class_sir) == names(class_ref))) {
stop_("`reference_data` must have the same column names as the 'clinical_breakpoints' data set.", call = -2)
}
if (!all(class_rsi == class_ref)) {
class_rsi[class_rsi != class_ref][1]
stop_("`reference_data` must be the same structure as the 'rsi_translation' data set. Column '", names(class_ref[class_rsi != class_ref][1]), "' is of class ", class_ref[class_rsi != class_ref][1], ", but should be of class ", class_rsi[class_rsi != class_ref][1], ".", call = -2)
if (!all(class_sir == class_ref)) {
class_sir[class_sir != class_ref][1]
stop_("`reference_data` must be the same structure as the 'clinical_breakpoints' data set. Column '", names(class_ref[class_sir != class_ref][1]), "' is of class ", class_ref[class_sir != class_ref][1], ", but should be of class ", class_sir[class_sir != class_ref][1], ".", call = -2)
}
}
}

44
R/rsi_calc.R → R/sir_calc.R
View File

@ -34,7 +34,7 @@ dots2vars <- function(...) {
as.character(dots)[2:length(dots)]
}
rsi_calc <- function(...,
sir_calc <- function(...,
ab_result,
minimum = 0,
as_percent = FALSE,
@ -78,7 +78,7 @@ rsi_calc <- function(...,
}
if (length(dots) == 0 || all(dots == "df")) {
# for complete data.frames, like example_isolates %pm>% select(AMC, GEN) %pm>% proportion_S()
# and the old rsi function, which has "df" as name of the first argument
# and the old sir function, which has "df" as name of the first argument
x <- dots_df
} else {
# get dots that are in column names already, and the ones that will be once evaluated using dots_df or global env
@ -115,21 +115,21 @@ rsi_calc <- function(...,
print_warning <- FALSE
ab_result <- as.rsi(ab_result)
ab_result <- as.sir(ab_result)
if (is.data.frame(x)) {
rsi_integrity_check <- character(0)
sir_integrity_check <- character(0)
for (i in seq_len(ncol(x))) {
# check integrity of columns: force 'rsi' class
if (!is.rsi(x[, i, drop = TRUE])) {
rsi_integrity_check <- c(rsi_integrity_check, as.character(x[, i, drop = TRUE]))
x[, i] <- suppressWarnings(as.rsi(x[, i, drop = TRUE])) # warning will be given later
# check integrity of columns: force 'sir' class
if (!is.sir(x[, i, drop = TRUE])) {
sir_integrity_check <- c(sir_integrity_check, as.character(x[, i, drop = TRUE]))
x[, i] <- suppressWarnings(as.sir(x[, i, drop = TRUE])) # warning will be given later
print_warning <- TRUE
}
}
if (length(rsi_integrity_check) > 0) {
if (length(sir_integrity_check) > 0) {
# this will give a warning for invalid results, of all input columns (so only 1 warning)
rsi_integrity_check <- as.rsi(rsi_integrity_check)
sir_integrity_check <- as.sir(sir_integrity_check)
}
x_transposed <- as.list(as.data.frame(t(x), stringsAsFactors = FALSE))
@ -150,8 +150,8 @@ rsi_calc <- function(...,
}
} else {
# x is not a data.frame
if (!is.rsi(x)) {
x <- as.rsi(x)
if (!is.sir(x)) {
x <- as.sir(x)
print_warning <- TRUE
}
numerator <- sum(x %in% ab_result, na.rm = TRUE)
@ -159,9 +159,9 @@ rsi_calc <- function(...,
}
if (print_warning == TRUE) {
if (message_not_thrown_before("rsi_calc")) {
warning_("Increase speed by transforming to class 'rsi' on beforehand:\n",
" your_data %>% mutate_if(is.rsi.eligible, as.rsi)",
if (message_not_thrown_before("sir_calc")) {
warning_("Increase speed by transforming to class 'sir' on beforehand:\n",
" your_data %>% mutate_if(is_sir_eligible, as.sir)",
call = FALSE
)
}
@ -213,7 +213,7 @@ rsi_calc <- function(...,
}
}
rsi_calc_df <- function(type, # "proportion", "count" or "both"
sir_calc_df <- function(type, # "proportion", "count" or "both"
data,
translate_ab = "name",
language = get_AMR_locale(),
@ -222,7 +222,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
combine_SI = TRUE,
confidence_level = 0.95) {
meet_criteria(type, is_in = c("proportion", "count", "both"), has_length = 1)
meet_criteria(data, allow_class = "data.frame", contains_column_class = "rsi")
meet_criteria(data, allow_class = "data.frame", contains_column_class = "sir")
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
@ -237,16 +237,16 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
if (is_null_or_grouped_tbl(data)) {
data_has_groups <- TRUE
groups <- setdiff(names(attributes(data)$groups), ".rows")
data <- data[, c(groups, colnames(data)[vapply(FUN.VALUE = logical(1), data, is.rsi)]), drop = FALSE]
data <- data[, c(groups, colnames(data)[vapply(FUN.VALUE = logical(1), data, is.sir)]), drop = FALSE]
} else {
data_has_groups <- FALSE
data <- data[, colnames(data)[vapply(FUN.VALUE = logical(1), data, is.rsi)], drop = FALSE]
data <- data[, colnames(data)[vapply(FUN.VALUE = logical(1), data, is.sir)], drop = FALSE]
}
data <- as.data.frame(data, stringsAsFactors = FALSE)
if (isTRUE(combine_SI)) {
for (i in seq_len(ncol(data))) {
if (is.rsi(data[, i, drop = TRUE])) {
if (is.sir(data[, i, drop = TRUE])) {
data[, i] <- as.character(data[, i, drop = TRUE])
data[, i] <- gsub("(I|S)", "SI", data[, i, drop = TRUE])
}
@ -348,7 +348,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
if (isTRUE(combine_SI)) {
out$interpretation <- factor(out$interpretation, levels = c("SI", "R"), ordered = TRUE)
} else {
# don't use as.rsi() here, as it would add the class 'rsi' and we would like
# don't use as.sir() here, as it would add the class 'sir' and we would like
# the same data structure as output, regardless of input
out$interpretation <- factor(out$interpretation, levels = c("S", "I", "R"), ordered = TRUE)
}
@ -372,5 +372,5 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
rownames(out) <- NULL
out <- as_original_data_class(out, class(data.bak)) # will remove tibble groups
structure(out, class = c("rsi_df", class(out)))
structure(out, class = c("sir_sf", class(out)))
}

6
R/rsi_df.R → R/sir_df.R
View File

@ -29,7 +29,7 @@
#' @rdname proportion
#' @export
rsi_df <- function(data,
sir_sf <- function(data,
translate_ab = "name",
language = get_AMR_locale(),
minimum = 30,
@ -37,7 +37,7 @@ rsi_df <- function(data,
combine_SI = TRUE,
confidence_level = 0.95) {
tryCatch(
rsi_calc_df(
sir_calc_df(
type = "both",
data = data,
translate_ab = translate_ab,
@ -47,6 +47,6 @@ rsi_df <- function(data,
combine_SI = combine_SI,
confidence_level = confidence_level
),
error = function(e) stop_(gsub("in rsi_calc_df(): ", "", e$message, fixed = TRUE), call = -5)
error = function(e) stop_(gsub("in sir_calc_df(): ", "", e$message, fixed = TRUE), call = -5)
)
}

BIN
R/sysdata.rda
View File

Binary file not shown.

10
R/vctrs.R
View File

@ -142,15 +142,15 @@ vec_math.mic <- function(.fn, x, ...) {
}
# S3: rsi
vec_ptype2.character.rsi <- function(x, y, ...) {
vec_ptype2.character.sir <- function(x, y, ...) {
x
}
vec_ptype2.rsi.character <- function(x, y, ...) {
vec_ptype2.sir.character <- function(x, y, ...) {
y
}
vec_cast.character.rsi <- function(x, to, ...) {
vec_cast.character.sir <- function(x, to, ...) {
as.character(x)
}
vec_cast.rsi.character <- function(x, to, ...) {
as.rsi(x)
vec_cast.sir.character <- function(x, to, ...) {
as.sir(x)
}

22
R/zzz.R
View File

@ -55,7 +55,7 @@ AMR_env$av_previously_coerced <- data.frame(
av = character(0),
stringsAsFactors = FALSE
)
AMR_env$rsi_interpretation_history <- data.frame(
AMR_env$sir_interpretation_history <- data.frame(
datetime = Sys.time()[0],
index = integer(0),
ab_input = character(0),
@ -97,32 +97,34 @@ if (utf8_supported && !is_latex) {
s3_register("pillar::pillar_shaft", "ab")
s3_register("pillar::pillar_shaft", "av")
s3_register("pillar::pillar_shaft", "mo")
s3_register("pillar::pillar_shaft", "rsi")
s3_register("pillar::pillar_shaft", "sir")
s3_register("pillar::pillar_shaft", "rsi") # TODO deprecate in a later version
s3_register("pillar::pillar_shaft", "mic")
s3_register("pillar::pillar_shaft", "disk")
s3_register("pillar::type_sum", "ab")
s3_register("pillar::type_sum", "av")
s3_register("pillar::type_sum", "mo")
s3_register("pillar::type_sum", "sir")
s3_register("pillar::type_sum", "rsi")
s3_register("pillar::type_sum", "mic")
s3_register("pillar::type_sum", "disk")
# Support for frequency tables from the cleaner package
s3_register("cleaner::freq", "mo")
s3_register("cleaner::freq", "rsi")
s3_register("cleaner::freq", "sir")
# Support for skim() from the skimr package
if (pkg_is_available("skimr", also_load = FALSE, min_version = "2.0.0")) {
s3_register("skimr::get_skimmers", "mo")
s3_register("skimr::get_skimmers", "rsi")
s3_register("skimr::get_skimmers", "sir")
s3_register("skimr::get_skimmers", "mic")
s3_register("skimr::get_skimmers", "disk")
}
# Support for autoplot() from the ggplot2 package
s3_register("ggplot2::autoplot", "rsi")
s3_register("ggplot2::autoplot", "sir")
s3_register("ggplot2::autoplot", "mic")
s3_register("ggplot2::autoplot", "disk")
s3_register("ggplot2::autoplot", "resistance_predict")
# Support for fortify from the ggplot2 package
s3_register("ggplot2::fortify", "rsi")
s3_register("ggplot2::fortify", "sir")
s3_register("ggplot2::fortify", "mic")
s3_register("ggplot2::fortify", "disk")
# Support vctrs package for use in e.g. dplyr verbs
@ -165,10 +167,10 @@ if (utf8_supported && !is_latex) {
s3_register("vctrs::vec_cast", "mic.double")
s3_register("vctrs::vec_math", "mic")
# S3: rsi
s3_register("vctrs::vec_ptype2", "character.rsi")
s3_register("vctrs::vec_ptype2", "rsi.character")
s3_register("vctrs::vec_cast", "character.rsi")
s3_register("vctrs::vec_cast", "rsi.character")
s3_register("vctrs::vec_ptype2", "character.sir")
s3_register("vctrs::vec_ptype2", "sir.character")
s3_register("vctrs::vec_cast", "character.sir")
s3_register("vctrs::vec_cast", "sir.character")
# if mo source exists, fire it up (see mo_source())
if (tryCatch(file.exists(getOption("AMR_mo_source", "~/mo_source.rds")), error = function(e) FALSE)) {