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

(v2.1.1.9163) cleanup

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2025-02-27 14:04:29 +01:00
parent 68efddab3d
commit 07efc292bc
73 changed files with 2187 additions and 1715 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
.github/workflows/lintr.yaml vendored
View File

@ -56,9 +56,15 @@ jobs:
extra-packages: |
any::lintr
any::cyclocomp
any::roxygen2
any::devtools
any::usethis
- name: Lint
run: |
# no not check these folders
rm -rf data-raw
rm -rf tests
# old: lintr::lint_package(linters = lintr::with_defaults(line_length_linter = NULL, trailing_whitespace_linter = NULL, object_name_linter = NULL, cyclocomp_linter = NULL, object_length_linter = lintr::object_length_linter(length = 50L)), exclusions = list("R/aa_helper_pm_functions.R"))
# now get ALL linters, not just default ones
linters <- getNamespaceExports(asNamespace("lintr"))
@ -67,7 +73,7 @@ jobs:
linters <- linters[!grepl("^(closed_curly|open_curly|paren_brace|semicolon_terminator|consecutive_stopifnot|no_tab|single_quotes|unnecessary_nested_if|unneeded_concatenation)_linter$", linters)]
linters <- linters[linters != "linter"]
# and the ones we find unnnecessary
linters <- linters[!grepl("^(extraction_operator|implicit_integer|line_length|object_name|nonportable_path|is)_linter$", linters)]
linters <- linters[!grepl("^(extraction_operator|implicit_integer|line_length|object_length|object_name|object_usage|nonportable_path|is)_linter$", linters)]
# put the functions in a list
linters_list <- lapply(linters, function(l) eval(parse(text = paste0("lintr::", l, "()")), envir = asNamespace("lintr")))
names(linters_list) <- linters

4
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR
Version: 2.1.1.9160
Date: 2025-02-26
Version: 2.1.1.9163
Date: 2025-02-27
Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by

6
NEWS.md
View File

@ -1,4 +1,4 @@
# AMR 2.1.1.9160
# AMR 2.1.1.9163
*(this beta version will eventually become v3.0. We're happy to reach a new major milestone soon, which will be all about the new One Health support! Install this beta using [the instructions here](https://msberends.github.io/AMR/#latest-development-version).)*
@ -62,6 +62,7 @@ This package now supports not only tools for AMR data analysis in clinical setti
* Added Amorolfine (`AMO`, D01AE16), which is now also part of the `antifungals()` selector
* Added Efflux (`EFF`), to allow mapping to AMRFinderPlus
* Added Tigemonam (`TNM`), a monobactam
* Added over 1,500 trade names
* MICs
* Added as valid levels: 4096, 6 powers of 0.0625, and 5 powers of 192 (192, 384, 576, 768, 960)
* Fixed a bug in `as.mic()` that failed translation of scientifically formatted numbers
@ -76,12 +77,11 @@ This package now supports not only tools for AMR data analysis in clinical setti
* `mo_info()` now contains an extra element `rank` and `group_members` (with the contents of the new `mo_group_members()` function)
* Updated all ATC codes from WHOCC
* Updated all antibiotic DDDs from WHOCC
* Added over 1,500 trade names for antibiotics
* Fix for using a manual value for `mo_transform` in `antibiogram()`
* Fixed a bug for when `antibiogram()` returns an empty data set
* Fix for mapping 'high level' antibiotics in `as.ab()` (amphotericin B-high, gentamicin-high, kanamycin-high, streptomycin-high, tobramycin-high)
* Improved overall algorithm of `as.ab()` for better performance and accuracy, including the new function `as_reset_session()` to remove earlier coercions.
* Improved overall algorithm of `as.mo()` for better performance and accuracy. Specifically:
* Improved overall algorithm of `as.mo()` for better performance and accuracy, specifically:
* More weight is given to genus and species combinations in cases where the subspecies is miswritten, so that the result will be the correct genus and species
* Genera from the World Health Organization's (WHO) Priority Pathogen List now have the highest prevalence
* Fixed a bug for `sir_confidence_interval()` when there are no isolates available

2
PythonPackage/AMR/AMR.egg-info/PKG-INFO
View File

@ -1,6 +1,6 @@
Metadata-Version: 2.2
Name: AMR
Version: 2.1.1.9160
Version: 2.1.1.9163
Summary: A Python wrapper for the AMR R package
Home-page: https://github.com/msberends/AMR
Author: Matthijs Berends

4
PythonPackage/AMR/AMR/__init__.py
View File

@ -28,8 +28,6 @@ from .functions import age_groups
from .functions import antibiogram
from .functions import wisca
from .functions import retrieve_wisca_parameters
from .functions import amr_class
from .functions import amr_selector
from .functions import aminoglycosides
from .functions import aminopenicillins
from .functions import antifungals
@ -61,6 +59,8 @@ from .functions import streptogramins
from .functions import tetracyclines
from .functions import trimethoprims
from .functions import ureidopenicillins
from .functions import amr_class
from .functions import amr_selector
from .functions import administrable_per_os
from .functions import administrable_iv
from .functions import not_intrinsic_resistant

12
PythonPackage/AMR/AMR/functions.py
View File

@ -114,12 +114,6 @@ def wisca(x, *args, **kwargs):
def retrieve_wisca_parameters(wisca_model, *args, **kwargs):
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
return convert_to_python(amr_r.retrieve_wisca_parameters(wisca_model, *args, **kwargs))
def amr_class(amr_class, *args, **kwargs):
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
return convert_to_python(amr_r.amr_class(amr_class, *args, **kwargs))
def amr_selector(filter, *args, **kwargs):
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
return convert_to_python(amr_r.amr_selector(filter, *args, **kwargs))
def aminoglycosides(only_sir_columns = False, *args, **kwargs):
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
return convert_to_python(amr_r.aminoglycosides(only_sir_columns = False, *args, **kwargs))
@ -213,6 +207,12 @@ def trimethoprims(only_sir_columns = False, *args, **kwargs):
def ureidopenicillins(only_sir_columns = False, *args, **kwargs):
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
return convert_to_python(amr_r.ureidopenicillins(only_sir_columns = False, *args, **kwargs))
def amr_class(amr_class, *args, **kwargs):
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
return convert_to_python(amr_r.amr_class(amr_class, *args, **kwargs))
def amr_selector(filter, *args, **kwargs):
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
return convert_to_python(amr_r.amr_selector(filter, *args, **kwargs))
def administrable_per_os(only_sir_columns = False, *args, **kwargs):
"""See our website of the R package for the manual: https://msberends.github.io/AMR/index.html"""
return convert_to_python(amr_r.administrable_per_os(only_sir_columns = False, *args, **kwargs))

BIN
PythonPackage/AMR/dist/amr-2.1.1.9160-py3-none-any.whl vendored
View File

Binary file not shown.

BIN
PythonPackage/AMR/dist/amr-2.1.1.9160.tar.gz vendored
View File

Binary file not shown.

BIN
PythonPackage/AMR/dist/amr-2.1.1.9163-py3-none-any.whl vendored Normal file
View File

Binary file not shown.

BIN
PythonPackage/AMR/dist/amr-2.1.1.9163.tar.gz vendored Normal file
View File

Binary file not shown.

2
PythonPackage/AMR/setup.py
View File

@ -2,7 +2,7 @@ from setuptools import setup, find_packages
setup(
name='AMR',
version='2.1.1.9160',
version='2.1.1.9163',
packages=find_packages(),
install_requires=[
'rpy2',

42
R/aa_helper_functions.R
View File

@ -511,22 +511,32 @@ word_wrap <- function(...,
# format backticks
if (pkg_is_available("cli") &&
tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE) &&
tryCatch(getExportedValue("isAvailable", ns = asNamespace("rstudioapi"))(), error = function(e) return(FALSE)) &&
tryCatch(getExportedValue("versionInfo", ns = asNamespace("rstudioapi"))()$version > "2023.6.0.0", error = function(e) return(FALSE))) {
tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE) &&
tryCatch(getExportedValue("isAvailable", ns = asNamespace("rstudioapi"))(), error = function(e) {
return(FALSE)
}) &&
tryCatch(getExportedValue("versionInfo", ns = asNamespace("rstudioapi"))()$version > "2023.6.0.0", error = function(e) {
return(FALSE)
})) {
# we are in a recent version of RStudio, so do something nice: add links to our help pages in the console.
parts <- strsplit(msg, "`", fixed = TRUE)[[1]]
cmds <- parts %in% paste0(ls(envir = asNamespace("AMR")), "()")
# functions with a dot are not allowed: https://github.com/rstudio/rstudio/issues/11273#issuecomment-1156193252
# lead them to the help page of our package
parts[cmds & parts %like% "[.]"] <- font_url(url = paste0("ide:help:AMR::", gsub("()", "", parts[cmds & parts %like% "[.]"], fixed = TRUE)),
txt = parts[cmds & parts %like% "[.]"])
parts[cmds & parts %like% "[.]"] <- font_url(
url = paste0("ide:help:AMR::", gsub("()", "", parts[cmds & parts %like% "[.]"], fixed = TRUE)),
txt = parts[cmds & parts %like% "[.]"]
)
# otherwise, give a 'click to run' popup
parts[cmds & parts %unlike% "[.]"] <- font_url(url = paste0("ide:run:AMR::", parts[cmds & parts %unlike% "[.]"]),
txt = parts[cmds & parts %unlike% "[.]"])
parts[cmds & parts %unlike% "[.]"] <- font_url(
url = paste0("ide:run:AMR::", parts[cmds & parts %unlike% "[.]"]),
txt = parts[cmds & parts %unlike% "[.]"]
)
# text starting with `?` must also lead to the help page
parts[parts %like% "^[?]"] <- font_url(url = paste0("ide:help:AMR::", gsub("()", "", gsub("^[?]", "", parts[parts %like% "^[?]"]), fixed = TRUE)),
txt = parts[parts %like% "^[?]"])
parts[parts %like% "^[?]"] <- font_url(
url = paste0("ide:help:AMR::", gsub("()", "", gsub("^[?]", "", parts[parts %like% "^[?]"]), fixed = TRUE)),
txt = parts[parts %like% "^[?]"]
)
msg <- paste0(parts, collapse = "`")
}
msg <- gsub("`(.+?)`", font_grey_bg("\\1"), msg)
@ -965,9 +975,11 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
ascertain_sir_classes <- function(x, obj_name) {
sirs <- vapply(FUN.VALUE = logical(1), x, is.sir)
if (!any(sirs, na.rm = TRUE)) {
warning_("the data provided in argument `", obj_name,
"` should contain at least one column of class 'sir'. Eligible SIR column were now guessed. ",
"See `?as.sir`.")
warning_(
"the data provided in argument `", obj_name,
"` should contain at least one column of class 'sir'. Eligible SIR column were now guessed. ",
"See `?as.sir`."
)
sirs_eligible <- is_sir_eligible(x)
for (col in colnames(x)[sirs_eligible]) {
x[[col]] <- as.sir(x[[col]])
@ -1322,8 +1334,10 @@ progress_ticker <- function(n = 1, n_min = 0, print = TRUE, clear = TRUE, title
# a close()-method was also added, see below for that
pb <- progress_bar$new(
show_after = 0,
format = paste0(title,
ifelse(only_bar_percent == TRUE, "[:bar] :percent", "[:bar] :percent (:current/:total,:eta)")),
format = paste0(
title,
ifelse(only_bar_percent == TRUE, "[:bar] :percent", "[:bar] :percent (:current/:total,:eta)")
),
clear = clear,
total = n
)

102
R/ab.R
View File

@ -102,7 +102,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
# all valid AB codes, but not yet right class or might have additional attributes as AMR selector
attributes(x) <- NULL
return(set_clean_class(x,
new_class = c("ab", "character")
new_class = c("ab", "character")
))
}
@ -198,8 +198,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
next
}
if (identical(x[i], "") ||
# prevent "bacteria" from coercing to TMP, since Bacterial is a brand name of it:
identical(tolower(x[i]), "bacteria")) {
# prevent "bacteria" from coercing to TMP, since Bacterial is a brand name of it:
identical(tolower(x[i]), "bacteria")) {
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
next
}
@ -213,7 +213,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
if (fast_mode == FALSE && flag_multiple_results == TRUE && x[i] %like% "[ ]") {
from_text <- tryCatch(suppressWarnings(ab_from_text(x[i], translate_ab = FALSE)[[1]]),
error = function(e) character(0)
error = function(e) character(0)
)
} else {
from_text <- character(0)
@ -327,31 +327,39 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
# More uncertain results ----
if (fast_mode == FALSE) {
ab_df <- AMR_env$AB_lookup
ab_df$length_name <- nchar(ab_df$generalised_name)
# now retrieve Levensthein distance for name, synonyms, and translated names
ab_df$lev_name <- as.double(utils::adist(x[i], ab_df$generalised_name,
ignore.case = FALSE,
fixed = TRUE,
costs = c(insertions = 1, deletions = 1, substitutions = 2),
counts = FALSE))
ab_df$lev_syn <- vapply(FUN.VALUE = double(1),
ab_df$generalised_synonyms,
function(y) ifelse(length(y[nchar(y) >= 5]) == 0,
999,
min(as.double(utils::adist(x[i], y[nchar(y) >= 5], ignore.case = FALSE,
fixed = TRUE,
costs = c(insertions = 1, deletions = 1, substitutions = 2),
counts = FALSE)), na.rm = TRUE)),
USE.NAMES = FALSE)
ignore.case = FALSE,
fixed = TRUE,
costs = c(insertions = 1, deletions = 1, substitutions = 2),
counts = FALSE
))
ab_df$lev_syn <- vapply(
FUN.VALUE = double(1),
ab_df$generalised_synonyms,
function(y) {
ifelse(length(y[nchar(y) >= 5]) == 0,
999,
min(as.double(utils::adist(x[i], y[nchar(y) >= 5],
ignore.case = FALSE,
fixed = TRUE,
costs = c(insertions = 1, deletions = 1, substitutions = 2),
counts = FALSE
)), na.rm = TRUE)
)
},
USE.NAMES = FALSE
)
if (!is.null(language) && language != "en") {
ab_df$trans <- generalise_antibiotic_name(translate_AMR(ab_df$name, language = language))
ab_df$lev_trans <- as.double(utils::adist(x[i], ab_df$trans,
ignore.case = FALSE,
fixed = TRUE,
costs = c(insertions = 1, deletions = 1, substitutions = 2),
counts = FALSE))
ignore.case = FALSE,
fixed = TRUE,
costs = c(insertions = 1, deletions = 1, substitutions = 2),
counts = FALSE
))
} else {
ab_df$lev_trans <- ab_df$lev_name
}
@ -431,13 +439,17 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
paste0(
'"', x_uncertain, '" (assumed ',
ab_name(AMR_env$ab_previously_coerced$ab[which(AMR_env$ab_previously_coerced$x_bak %in% x_uncertain)], language = NULL, tolower = TRUE),
", ", AMR_env$ab_previously_coerced$ab[which(AMR_env$ab_previously_coerced$x_bak %in% x_uncertain)], ")"),
quotes = FALSE)
", ", AMR_env$ab_previously_coerced$ab[which(AMR_env$ab_previously_coerced$x_bak %in% x_uncertain)], ")"
),
quotes = FALSE
)
} else {
examples <- paste0(nr2char(length(x_uncertain)), " antimicrobials")
}
message_("Antimicrobial translation was uncertain for ", examples,
". If required, use `add_custom_antimicrobials()` to add custom entries.")
message_(
"Antimicrobial translation was uncertain for ", examples,
". If required, use `add_custom_antimicrobials()` to add custom entries."
)
}
}
@ -447,7 +459,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
}
set_clean_class(x_result,
new_class = c("ab", "character")
new_class = c("ab", "character")
)
}
@ -476,8 +488,10 @@ pillar_shaft.ab <- function(x, ...) {
# add the names to the drugs as mouse-over!
if (tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE)) {
out[!is.na(x)] <- font_url(url = paste0(x[!is.na(x)], ": ", ab_name(x[!is.na(x)])),
txt = out[!is.na(x)])
out[!is.na(x)] <- font_url(
url = paste0(x[!is.na(x)], ": ", ab_name(x[!is.na(x)])),
txt = out[!is.na(x)]
)
}
create_pillar_column(out, align = "left", min_width = 4)
@ -494,12 +508,14 @@ type_sum.ab <- function(x, ...) {
print.ab <- function(x, ...) {
if (!is.null(attributes(x)$amr_selector)) {
function_name <- attributes(x)$amr_selector
message_("This 'ab' vector was retrieved using `" , function_name, "()`, which should normally be used inside a `dplyr` verb or `data.frame` call, e.g.:\n",
" ", AMR_env$bullet_icon, " your_data %>% select(", function_name, "())\n",
" ", AMR_env$bullet_icon, " your_data %>% select(column_a, column_b, ", function_name, "())\n",
" ", AMR_env$bullet_icon, " your_data %>% filter(any(", function_name, "() == \"R\"))\n",
" ", AMR_env$bullet_icon, " your_data[, ", function_name, "()]\n",
" ", AMR_env$bullet_icon, " your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]")
message_(
"This 'ab' vector was retrieved using `", function_name, "()`, which should normally be used inside a `dplyr` verb or `data.frame` call, e.g.:\n",
" ", AMR_env$bullet_icon, " your_data %>% select(", function_name, "())\n",
" ", AMR_env$bullet_icon, " your_data %>% select(column_a, column_b, ", function_name, "())\n",
" ", AMR_env$bullet_icon, " your_data %>% filter(any(", function_name, "() == \"R\"))\n",
" ", AMR_env$bullet_icon, " your_data[, ", function_name, "()]\n",
" ", AMR_env$bullet_icon, " your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]"
)
}
cat("Class 'ab'\n")
print(as.character(x), quote = FALSE)
@ -614,9 +630,9 @@ get_translate_ab <- function(translate_ab) {
} else {
translate_ab <- tolower(translate_ab)
stop_ifnot(translate_ab %in% colnames(AMR::antibiotics),
"invalid value for 'translate_ab', this must be a column name of the antibiotics data set\n",
"or TRUE (equals 'name') or FALSE to not translate at all.",
call = FALSE
"invalid value for 'translate_ab', this must be a column name of the antibiotics data set\n",
"or TRUE (equals 'name') or FALSE to not translate at all.",
call = FALSE
)
translate_ab
}
@ -633,11 +649,11 @@ create_AB_AV_lookup <- function(df) {
new_df$generalised_all <- unname(lapply(
as.list(as.data.frame(
t(new_df[,
c(
colnames(new_df)[colnames(new_df) %in% c("ab", "av", "atc", "cid", "name")],
colnames(new_df)[colnames(new_df) %like% "generalised"]
),
drop = FALSE
c(
colnames(new_df)[colnames(new_df) %in% c("ab", "av", "atc", "cid", "name")],
colnames(new_df)[colnames(new_df) %like% "generalised"]
),
drop = FALSE
]),
stringsAsFactors = FALSE
)),

200
R/amr_selectors.R
View File

@ -231,57 +231,6 @@
#' dt[any(carbapenems() == "S"), penicillins(), with = FALSE]
#' }
#' }
amr_class <- function(amr_class,
only_sir_columns = FALSE,
only_treatable = TRUE,
return_all = TRUE,
...) {
meet_criteria(amr_class, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
meet_criteria(return_all, allow_class = "logical", has_length = 1)
amr_select_exec(NULL, only_sir_columns = only_sir_columns, amr_class_args = amr_class, only_treatable = only_treatable, return_all = return_all)
}
#' @rdname antimicrobial_selectors
#' @details The [amr_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
amr_selector <- function(filter,
only_sir_columns = FALSE,
only_treatable = TRUE,
return_all = TRUE,
...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
meet_criteria(return_all, 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_sir_columns = only_sir_columns,
sort = FALSE, fn = "amr_selector", return_all = return_all
)
call <- substitute(filter)
agents <- tryCatch(AMR_env$AB_lookup[which(eval(call, envir = AMR_env$AB_lookup)), "ab", drop = TRUE],
error = function(e) stop_(e$message, call = -5)
)
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(
function_name = "amr_selector",
agents = agents,
ab_group = NULL,
examples = "",
call = call
)
structure(unname(agents),
class = c("amr_selector", "character")
)
}
#' @rdname antimicrobial_selectors
#' @export
aminoglycosides <- function(only_sir_columns = FALSE, only_treatable = TRUE, return_all = TRUE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
@ -536,6 +485,57 @@ ureidopenicillins <- function(only_sir_columns = FALSE, return_all = TRUE, ...)
#' @rdname antimicrobial_selectors
#' @details The [administrable_per_os()] and [administrable_iv()] functions also rely on the [antibiotics] data set - antimicrobials will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the [antibiotics] data set.
#' @export
amr_class <- function(amr_class,
only_sir_columns = FALSE,
only_treatable = TRUE,
return_all = TRUE,
...) {
meet_criteria(amr_class, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
meet_criteria(return_all, allow_class = "logical", has_length = 1)
amr_select_exec(NULL, only_sir_columns = only_sir_columns, amr_class_args = amr_class, only_treatable = only_treatable, return_all = return_all)
}
#' @rdname antimicrobial_selectors
#' @details The [amr_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
amr_selector <- function(filter,
only_sir_columns = FALSE,
only_treatable = TRUE,
return_all = TRUE,
...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
meet_criteria(return_all, 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_sir_columns = only_sir_columns,
sort = FALSE, fn = "amr_selector", return_all = return_all
)
call <- substitute(filter)
agents <- tryCatch(AMR_env$AB_lookup[which(eval(call, envir = AMR_env$AB_lookup)), "ab", drop = TRUE],
error = function(e) stop_(e$message, call = -5)
)
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(
function_name = "amr_selector",
agents = agents,
ab_group = NULL,
examples = "",
call = call
)
structure(unname(agents),
class = c("amr_selector", "character")
)
}
#' @rdname antimicrobial_selectors
#' @export
administrable_per_os <- function(only_sir_columns = FALSE, return_all = TRUE, ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
meet_criteria(return_all, allow_class = "logical", has_length = 1)
@ -544,8 +544,8 @@ administrable_per_os <- function(only_sir_columns = FALSE, return_all = TRUE, ..
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_sir_columns = only_sir_columns,
sort = FALSE, fn = "administrable_per_os", return_all = return_all
info = FALSE, only_sir_columns = only_sir_columns,
sort = FALSE, fn = "administrable_per_os", return_all = return_all
)
agents_all <- AMR_env$AB_lookup[which(!is.na(AMR_env$AB_lookup$oral_ddd)), "ab", drop = TRUE]
agents <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$ab %in% ab_in_data & !is.na(AMR_env$AB_lookup$oral_ddd)), "ab", drop = TRUE]
@ -559,8 +559,8 @@ administrable_per_os <- function(only_sir_columns = FALSE, return_all = TRUE, ..
vector_or(
ab_name(
sample(agents_all,
size = min(5, length(agents_all)),
replace = FALSE
size = min(5, length(agents_all)),
replace = FALSE
),
tolower = TRUE,
language = NULL
@ -571,7 +571,7 @@ administrable_per_os <- function(only_sir_columns = FALSE, return_all = TRUE, ..
)
)
structure(unname(agents),
class = c("amr_selector", "character")
class = c("amr_selector", "character")
)
}
@ -585,8 +585,8 @@ administrable_iv <- function(only_sir_columns = FALSE, return_all = TRUE, ...) {
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_sir_columns = only_sir_columns,
sort = FALSE, fn = "administrable_iv", return_all = return_all
info = FALSE, only_sir_columns = only_sir_columns,
sort = FALSE, fn = "administrable_iv", return_all = return_all
)
agents_all <- AMR_env$AB_lookup[which(!is.na(AMR_env$AB_lookup$iv_ddd)), "ab", drop = TRUE]
agents <- AMR_env$AB_lookup[which(AMR_env$AB_lookup$ab %in% ab_in_data & !is.na(AMR_env$AB_lookup$iv_ddd)), "ab", drop = TRUE]
@ -598,7 +598,7 @@ administrable_iv <- function(only_sir_columns = FALSE, return_all = TRUE, ...) {
examples = ""
)
structure(unname(agents),
class = c("amr_selector", "character")
class = c("amr_selector", "character")
)
}
@ -613,21 +613,21 @@ not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, ver
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_sir_columns = only_sir_columns,
sort = FALSE, fn = "not_intrinsic_resistant", return_all = TRUE
info = FALSE, only_sir_columns = only_sir_columns,
sort = FALSE, fn = "not_intrinsic_resistant", return_all = TRUE
)
# intrinsic vars
vars_df_R <- tryCatch(
sapply(
eucast_rules(vars_df,
col_mo = col_mo,
version_expertrules = version_expertrules,
rules = "expert",
info = FALSE
col_mo = col_mo,
version_expertrules = version_expertrules,
rules = "expert",
info = FALSE
),
function(col) {
tryCatch(!any(is.na(col)) && all(col == "R"),
error = function(e) FALSE
error = function(e) FALSE
)
}
),
@ -636,7 +636,7 @@ not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, ver
agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]
if (length(agents) > 0 &&
message_not_thrown_before("not_intrinsic_resistant", sort(agents))) {
message_not_thrown_before("not_intrinsic_resistant", sort(agents))) {
agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
@ -652,7 +652,7 @@ not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, ver
# find columns that are abx, but also intrinsic R
out <- unname(intersect(ab_in_data, vars_df_R))
structure(out,
class = c("amr_selector", "character")
class = c("amr_selector", "character")
)
}
@ -667,11 +667,12 @@ amr_select_exec <- function(function_name,
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
if (!is.null(vars_df)) {
ab_in_data <- get_column_abx(vars_df,
info = FALSE,
only_sir_columns = only_sir_columns,
sort = FALSE,
fn = function_name,
return_all = return_all)
info = FALSE,
only_sir_columns = only_sir_columns,
sort = FALSE,
fn = function_name,
return_all = return_all
)
}
# untreatable drugs
@ -683,8 +684,8 @@ amr_select_exec <- function(function_name,
"in `", function_name, "()`: some drugs were ignored since they cannot be used for treating patients: ",
vector_and(
ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
language = NULL,
tolower = TRUE
language = NULL,
tolower = TRUE
),
quotes = FALSE,
sort = TRUE
@ -727,8 +728,8 @@ amr_select_exec <- function(function_name,
}
examples <- paste0(" (such as ", vector_or(
ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE),
tolower = TRUE,
language = NULL
tolower = TRUE,
language = NULL
),
quotes = FALSE
), ")")
@ -763,7 +764,7 @@ amr_select_exec <- function(function_name,
)
structure(unname(agents),
class = c("amr_selector", "character")
class = c("amr_selector", "character")
)
}
@ -772,7 +773,8 @@ amr_select_exec <- function(function_name,
#' @noRd
print.amr_selector <- function(x, ...) {
warning_("It should never be needed to print an antimicrobial selector class. Are you using data.table? Then add the argument `with = FALSE`, see our examples at `?amr_selector`.",
immediate = TRUE)
immediate = TRUE
)
cat("Class 'amr_selector'\n")
print(as.character(x), quote = FALSE)
}
@ -782,7 +784,7 @@ print.amr_selector <- function(x, ...) {
#' @noRd
c.amr_selector <- function(...) {
structure(unlist(lapply(list(...), as.character)),
class = c("amr_selector", "character")
class = c("amr_selector", "character")
)
}
@ -875,7 +877,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
}
}
structure(all_any_amr_selector(type = type, e1, e2),
class = c("amr_selector_any_all", "logical")
class = c("amr_selector_any_all", "logical")
)
}
@ -903,7 +905,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
sir <- c("S", "SDD", "I", "R", "NI")
e2 <- sir[sir != e2]
structure(all_any_amr_selector(type = type, e1, e2),
class = c("amr_selector_any_all", "logical")
class = c("amr_selector_any_all", "logical")
)
}
@ -914,7 +916,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
# this is only required for base R, since tidyselect has already implemented this
# e.g., for: example_isolates[, penicillins() & administrable_per_os()]
structure(intersect(unclass(e1), unclass(e2)),
class = c("amr_selector", "character")
class = c("amr_selector", "character")
)
}
#' @method | amr_selector
@ -924,7 +926,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
# this is only required for base R, since tidyselect has already implemented this
# e.g., for: example_isolates[, penicillins() | administrable_per_os()]
structure(union(unclass(e1), unclass(e2)),
class = c("amr_selector", "character")
class = c("amr_selector", "character")
)
}
@ -943,8 +945,8 @@ find_ab_group <- function(amr_class_args) {
amr_class_args <- gsub("[^a-zA-Z0-9]", ".*", amr_class_args)
AMR_env$AB_lookup %pm>%
subset(group %like% amr_class_args |
atc_group1 %like% amr_class_args |
atc_group2 %like% amr_class_args) %pm>%
atc_group1 %like% amr_class_args |
atc_group2 %like% amr_class_args) %pm>%
pm_pull(group) %pm>%
unique() %pm>%
tolower() %pm>%
@ -957,23 +959,23 @@ find_ab_names <- function(ab_group, n = 3) {
# try popular first, they have DDDs
drugs <- AMR_env$AB_lookup[which((!is.na(AMR_env$AB_lookup$iv_ddd) | !is.na(AMR_env$AB_lookup$oral_ddd)) &
AMR_env$AB_lookup$name %unlike% " " &
AMR_env$AB_lookup$group %like% ab_group &
AMR_env$AB_lookup$ab %unlike% "[0-9]$"), ]$name
AMR_env$AB_lookup$name %unlike% " " &
AMR_env$AB_lookup$group %like% ab_group &
AMR_env$AB_lookup$ab %unlike% "[0-9]$"), ]$name
if (length(drugs) < n) {
# now try it all
drugs <- AMR_env$AB_lookup[which((AMR_env$AB_lookup$group %like% ab_group |
AMR_env$AB_lookup$atc_group1 %like% ab_group |
AMR_env$AB_lookup$atc_group2 %like% ab_group) &
AMR_env$AB_lookup$ab %unlike% "[0-9]$"), ]$name
AMR_env$AB_lookup$atc_group1 %like% ab_group |
AMR_env$AB_lookup$atc_group2 %like% ab_group) &
AMR_env$AB_lookup$ab %unlike% "[0-9]$"), ]$name
}
if (length(drugs) == 0) {
return("??")
}
vector_or(
ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
tolower = TRUE,
language = NULL
tolower = TRUE,
language = NULL
),
quotes = FALSE
)
@ -999,11 +1001,11 @@ message_agent_names <- function(function_name, agents, ab_group = NULL, examples
message_(
"For `", function_name, "(",
ifelse(function_name == "amr_class",
paste0("\"", amr_class_args, "\""),
ifelse(!is.null(call),
paste0(deparse(call), collapse = " "),
""
)
paste0("\"", amr_class_args, "\""),
ifelse(!is.null(call),
paste0(deparse(call), collapse = " "),
""
)
),
")` using ",
ifelse(length(agents) == 1, "column ", "columns "),

248
R/antibiogram.R
View File

@ -307,12 +307,14 @@
#' antibiogram(example_isolates,
#' antibiotics = aminoglycosides(),
#' ab_transform = "atc",
#' mo_transform = "gramstain")
#' mo_transform = "gramstain"
#' )
#'
#' antibiogram(example_isolates,
#' antibiotics = carbapenems(),
#' ab_transform = "name",
#' mo_transform = "name")
#' mo_transform = "name"
#' )
#'
#'
#' # Combined antibiogram -------------------------------------------------
@ -320,14 +322,16 @@
#' # combined antibiotics yield higher empiric coverage
#' antibiogram(example_isolates,
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
#' mo_transform = "gramstain")
#' mo_transform = "gramstain"
#' )
#'
#' # names of antibiotics do not need to resemble columns exactly:
#' antibiogram(example_isolates,
#' antibiotics = c("Cipro", "cipro + genta"),
#' mo_transform = "gramstain",
#' ab_transform = "name",
#' sep = " & ")
#' sep = " & "
#' )
#'
#'
#' # Syndromic antibiogram ------------------------------------------------
@ -335,7 +339,8 @@
#' # the data set could contain a filter for e.g. respiratory specimens
#' antibiogram(example_isolates,
#' antibiotics = c(aminoglycosides(), carbapenems()),
#' syndromic_group = "ward")
#' syndromic_group = "ward"
#' )
#'
#' # now define a data set with only E. coli
#' ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
@ -348,7 +353,8 @@
#' syndromic_group = ifelse(ex1$ward == "ICU",
#' "UCI", "No UCI"
#' ),
#' language = "es")
#' language = "es"
#' )
#'
#'
#' # WISCA antibiogram ----------------------------------------------------
@ -357,7 +363,8 @@
#' antibiogram(example_isolates,
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
#' syndromic_group = "ward",
#' wisca = TRUE)
#' wisca = TRUE
#' )
#'
#'
#' # Print the output for R Markdown / Quarto -----------------------------
@ -365,7 +372,8 @@
#' ureido <- antibiogram(example_isolates,
#' antibiotics = ureidopenicillins(),
#' syndromic_group = "ward",
#' wisca = TRUE)
#' wisca = TRUE
#' )
#'
#' # in an Rmd file, you would just need to return `ureido` in a chunk,
#' # but to be explicit here:
@ -378,11 +386,13 @@
#'
#' ab1 <- antibiogram(example_isolates,
#' antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
#' mo_transform = "gramstain")
#' mo_transform = "gramstain"
#' )
#' ab2 <- antibiogram(example_isolates,
#' antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
#' mo_transform = "gramstain",
#' syndromic_group = "ward")
#' syndromic_group = "ward"
#' )
#'
#' if (requireNamespace("ggplot2")) {
#' ggplot2::autoplot(ab1)
@ -639,12 +649,14 @@ antibiogram.default <- function(x,
}
long_numeric <- out %pm>%
pm_summarise(coverage = p_susceptible,
lower_ci = lower_ci,
upper_ci = upper_ci,
n_total = n_total,
n_tested = n_tested,
n_susceptible = n_susceptible)
pm_summarise(
coverage = p_susceptible,
lower_ci = lower_ci,
upper_ci = upper_ci,
n_total = n_total,
n_tested = n_tested,
n_susceptible = n_susceptible
)
wisca_parameters <- data.frame()
@ -660,12 +672,14 @@ antibiogram.default <- function(x,
pm_group_by(ab)
}
out_wisca <- out_wisca %pm>%
pm_summarise(coverage = NA_real_,
lower_ci = NA_real_,
upper_ci = NA_real_,
n_total = sum(n_total, na.rm = TRUE),
n_tested = sum(n_tested, na.rm = TRUE),
n_susceptible = sum(n_susceptible, na.rm = TRUE))
pm_summarise(
coverage = NA_real_,
lower_ci = NA_real_,
upper_ci = NA_real_,
n_total = sum(n_total, na.rm = TRUE),
n_tested = sum(n_tested, na.rm = TRUE),
n_susceptible = sum(n_susceptible, na.rm = TRUE)
)
out_wisca$p_susceptible <- out_wisca$n_susceptible / out_wisca$n_tested
if (isTRUE(has_syndromic_group)) {
@ -688,17 +702,19 @@ antibiogram.default <- function(x,
out_current <- out[i, , drop = FALSE]
priors <- calculate_priors(out_current, combine_SI = combine_SI)
out$gamma_posterior[i] = priors$gamma_posterior
out$beta_posterior1[i] = priors$beta_posterior_1
out$beta_posterior2[i] = priors$beta_posterior_2
out$gamma_posterior[i] <- priors$gamma_posterior
out$beta_posterior1[i] <- priors$beta_posterior_1
out$beta_posterior2[i] <- priors$beta_posterior_2
}
wisca_parameters <- out
progress <- progress_ticker(n = length(unique(wisca_parameters$group)) * simulations,
n_min = 25,
print = info,
title = paste("Calculating WISCA for", length(unique(wisca_parameters$group)), "regimens"))
progress <- progress_ticker(
n = length(unique(wisca_parameters$group)) * simulations,
n_min = 25,
print = info,
title = paste("Calculating WISCA for", length(unique(wisca_parameters$group)), "regimens")
)
on.exit(close(progress))
# run WISCA
@ -837,7 +853,7 @@ antibiogram.default <- function(x,
long_to_wide <- function(object) {
if (wisca == TRUE) {
# column `mo` has already been removed, but we create here a surrogate to make the stats::reshape() work since it needs an identifier
object$mo <- 1 #seq_len(NROW(object))
object$mo <- 1 # seq_len(NROW(object))
}
object <- object %pm>%
# an unclassed data.frame is required for stats::reshape()
@ -924,13 +940,14 @@ antibiogram.default <- function(x,
}
out <- structure(as_original_data_class(new_df, class(x), extra_class = "antibiogram"),
has_syndromic_group = has_syndromic_group,
combine_SI = combine_SI,
wisca = wisca,
conf_interval = conf_interval,
formatting_type = formatting_type,
wisca_parameters = as_original_data_class(wisca_parameters, class(x)),
long_numeric = as_original_data_class(long_numeric, class(x)))
has_syndromic_group = has_syndromic_group,
combine_SI = combine_SI,
wisca = wisca,
conf_interval = conf_interval,
formatting_type = formatting_type,
wisca_parameters = as_original_data_class(wisca_parameters, class(x)),
long_numeric = as_original_data_class(long_numeric, class(x))
)
rownames(out) <- NULL
out
}
@ -960,10 +977,12 @@ antibiogram.grouped_df <- function(x,
stop_ifnot(is.null(syndromic_group), "`syndromic_group` must not be set if creating an antibiogram using a grouped tibble. The groups will become the variables over which the antimicrobials are calculated, making `syndromic_groups` redundant.", call = FALSE)
groups <- attributes(x)$groups
n_groups <- NROW(groups)
progress <- progress_ticker(n = n_groups,
n_min = 5,
print = info,
title = paste("Calculating AMR for", n_groups, "groups"))
progress <- progress_ticker(
n = n_groups,
n_min = 5,
print = info,
title = paste("Calculating AMR for", n_groups, "groups")
)
on.exit(close(progress))
out <- NULL
@ -977,24 +996,25 @@ antibiogram.grouped_df <- function(x,
next
}
new_out <- antibiogram(as.data.frame(x)[rows, , drop = FALSE],
antibiotics = antibiotics,
mo_transform = NULL,
ab_transform = ab_transform,
syndromic_group = NULL,
add_total_n = add_total_n,
only_all_tested = only_all_tested,
digits = digits,
formatting_type = formatting_type,
col_mo = col_mo,
language = language,
minimum = minimum,
combine_SI = combine_SI,
sep = sep,
wisca = wisca,
simulations = simulations,
conf_interval = conf_interval,
interval_side = interval_side,
info = FALSE)
antibiotics = antibiotics,
mo_transform = NULL,
ab_transform = ab_transform,
syndromic_group = NULL,
add_total_n = add_total_n,
only_all_tested = only_all_tested,
digits = digits,
formatting_type = formatting_type,
col_mo = col_mo,
language = language,
minimum = minimum,
combine_SI = combine_SI,
sep = sep,
wisca = wisca,
simulations = simulations,
conf_interval = conf_interval,
interval_side = interval_side,
info = FALSE
)
new_wisca_parameters <- attributes(new_out)$wisca_parameters
new_long_numeric <- attributes(new_out)$long_numeric
@ -1039,13 +1059,14 @@ antibiogram.grouped_df <- function(x,
close(progress)
out <- structure(as_original_data_class(out, class(x), extra_class = "antibiogram"),
has_syndromic_group = FALSE,
combine_SI = isTRUE(combine_SI),
wisca = isTRUE(wisca),
conf_interval = conf_interval,
formatting_type = formatting_type,
wisca_parameters = as_original_data_class(wisca_parameters, class(x)),
long_numeric = as_original_data_class(long_numeric, class(x)))
has_syndromic_group = FALSE,
combine_SI = isTRUE(combine_SI),
wisca = isTRUE(wisca),
conf_interval = conf_interval,
formatting_type = formatting_type,
wisca_parameters = as_original_data_class(wisca_parameters, class(x)),
long_numeric = as_original_data_class(long_numeric, class(x))
)
rownames(out) <- NULL
out
}
@ -1069,25 +1090,27 @@ wisca <- function(x,
conf_interval = 0.95,
interval_side = "two-tailed",
info = interactive()) {
antibiogram(x = x,
antibiotics = antibiotics,
ab_transform = ab_transform,
mo_transform = NULL,
syndromic_group = syndromic_group,
add_total_n = add_total_n,
only_all_tested = only_all_tested,
digits = digits,
formatting_type = formatting_type,
col_mo = col_mo,
language = language,
minimum = minimum,
combine_SI = combine_SI,
sep = sep,
wisca = TRUE,
simulations = simulations,
conf_interval = conf_interval,
interval_side = interval_side,
info = info)
antibiogram(
x = x,
antibiotics = antibiotics,
ab_transform = ab_transform,
mo_transform = NULL,
syndromic_group = syndromic_group,
add_total_n = add_total_n,
only_all_tested = only_all_tested,
digits = digits,
formatting_type = formatting_type,
col_mo = col_mo,
language = language,
minimum = minimum,
combine_SI = combine_SI,
sep = sep,
wisca = TRUE,
simulations = simulations,
conf_interval = conf_interval,
interval_side = interval_side,
info = info
)
}
#' @export
@ -1100,15 +1123,15 @@ retrieve_wisca_parameters <- function(wisca_model, ...) {
calculate_priors <- function(data, combine_SI = TRUE) {
# Pathogen incidence (Dirichlet distribution)
gamma_prior <- rep(1, length(unique(data$mo))) # Dirichlet prior
gamma_prior <- rep(1, length(unique(data$mo))) # Dirichlet prior
gamma_posterior <- gamma_prior + data$n_total # Posterior parameters
# Regimen susceptibility (Beta distribution)
beta_prior <- rep(1, length(unique(data$mo))) # Beta prior
r <- data$n_susceptible # Number of pathogens tested susceptible
n <- data$n_tested # n_tested tested
beta_posterior_1 <- beta_prior + r # Posterior alpha
beta_posterior_2 <- beta_prior + (n - r) # Posterior beta
r <- data$n_susceptible # Number of pathogens tested susceptible
n <- data$n_tested # n_tested tested
beta_posterior_1 <- beta_prior + r # Posterior alpha
beta_posterior_2 <- beta_prior + (n - r) # Posterior beta
# Return parameters as a list
list(
@ -1137,9 +1160,11 @@ tbl_format_footer.antibiogram <- function(x, ...) {
if (NROW(x) == 0) {
return(footer)
}
c(footer, font_subtle(paste0("# Use `plot()` or `ggplot2::autoplot()` to create a plot of this antibiogram,\n",
"# or use it directly in R Markdown or ",
font_url("https://quarto.org", "Quarto"), ", see ", word_wrap("?antibiogram"))))
c(footer, font_subtle(paste0(
"# Use `plot()` or `ggplot2::autoplot()` to create a plot of this antibiogram,\n",
"# or use it directly in R Markdown or ",
font_url("https://quarto.org", "Quarto"), ", see ", word_wrap("?antibiogram")
)))
}
#' @export
@ -1148,7 +1173,8 @@ plot.antibiogram <- function(x, ...) {
df <- attributes(x)$long_numeric
if (!"mo" %in% colnames(df)) {
stop_("Plotting antibiograms using `plot()` is only possible if they were not created using dplyr groups. See `?antibiogram` for how to retrieve numeric values in a long format for advanced plotting.",
call = FALSE)
call = FALSE
)
}
if ("syndromic_group" %in% colnames(df)) {
# barplot in base R does not support facets - paste columns together
@ -1180,8 +1206,8 @@ plot.antibiogram <- function(x, ...) {
lower_ci <- df_sub$lower_ci * 100
upper_ci <- df_sub$upper_ci * 100
arrows(
x0 = bp, y0 = lower_ci, # Start of error bar (lower bound)
x1 = bp, y1 = upper_ci, # End of error bar (upper bound)
x0 = bp, y0 = lower_ci, # Start of error bar (lower bound)
x1 = bp, y1 = upper_ci, # End of error bar (upper bound)
angle = 90, code = 3, length = 0.05, col = "black"
)
}
@ -1203,18 +1229,20 @@ autoplot.antibiogram <- function(object, ...) {
df <- attributes(object)$long_numeric
if (!"mo" %in% colnames(df)) {
stop_("Plotting antibiograms using `autoplot()` is only possible if they were not created using dplyr groups. See `?antibiogram` for how to retrieve numeric values in a long format for advanced plotting.",
call = FALSE)
call = FALSE
)
}
out <- ggplot2::ggplot(df,
mapping = ggplot2::aes(
x = ab,
y = coverage * 100,
fill = if ("syndromic_group" %in% colnames(df)) {
syndromic_group
} else {
NULL
}
)) +
mapping = ggplot2::aes(
x = ab,
y = coverage * 100,
fill = if ("syndromic_group" %in% colnames(df)) {
syndromic_group
} else {
NULL
}
)
) +
ggplot2::geom_col(position = ggplot2::position_dodge2(preserve = "single")) +
ggplot2::facet_wrap("mo") +
ggplot2::labs(
@ -1228,9 +1256,11 @@ autoplot.antibiogram <- function(object, ...) {
)
if (isTRUE(attributes(object)$wisca)) {
out <- out +
ggplot2::geom_errorbar(mapping = ggplot2::aes(ymin = lower_ci * 100, ymax = upper_ci * 100),
position = ggplot2::position_dodge2(preserve = "single"),
width = 0.5)
ggplot2::geom_errorbar(
mapping = ggplot2::aes(ymin = lower_ci * 100, ymax = upper_ci * 100),
position = ggplot2::position_dodge2(preserve = "single"),
width = 0.5
)
}
out
}

18
R/bug_drug_combinations.R
View File

@ -127,13 +127,15 @@ bug_drug_combinations <- function(x,
# turn and merge everything
pivot <- lapply(x_mo_filter, function(x) {
m <- as.matrix(table(as.sir(x), useNA = "always"))
data.frame(S = m["S", ],
SDD = m["SDD", ],
I = m["I", ],
R = m["R", ],
NI = m["NI", ],
na = m[which(is.na(rownames(m))), ],
stringsAsFactors = FALSE)
data.frame(
S = m["S", ],
SDD = m["SDD", ],
I = m["I", ],
R = m["R", ],
NI = m["NI", ],
na = m[which(is.na(rownames(m))), ],
stringsAsFactors = FALSE
)
})
merged <- do.call(rbind_AMR, pivot)
out_group <- data.frame(
@ -185,7 +187,7 @@ bug_drug_combinations <- function(x,
out <- as_original_data_class(out, class(x.bak)) # will remove tibble groups
out <- out %pm>% pm_arrange(mo, ab)
class(out) <- c("bug_drug_combinations", if(data_has_groups) "grouped" else NULL, class(out))
class(out) <- c("bug_drug_combinations", if (data_has_groups) "grouped" else NULL, class(out))
rownames(out) <- NULL
out
}

24
R/count.R
View File

@ -167,9 +167,9 @@ count_SI <- function(..., only_all_tested = FALSE) {
}
tryCatch(
sir_calc(...,
ab_result = c("S", "SDD", "I"),
only_all_tested = only_all_tested,
only_count = TRUE
ab_result = c("S", "SDD", "I"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
@ -183,9 +183,9 @@ count_I <- function(..., only_all_tested = FALSE) {
}
tryCatch(
sir_calc(...,
ab_result = c("I", "SDD"),
only_all_tested = only_all_tested,
only_count = TRUE
ab_result = c("I", "SDD"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
@ -199,9 +199,9 @@ count_IR <- function(..., only_all_tested = FALSE) {
}
tryCatch(
sir_calc(...,
ab_result = c("I", "SDD", "R"),
only_all_tested = only_all_tested,
only_count = TRUE
ab_result = c("I", "SDD", "R"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)
@ -212,9 +212,9 @@ count_IR <- function(..., only_all_tested = FALSE) {
count_R <- function(..., only_all_tested = FALSE) {
tryCatch(
sir_calc(...,
ab_result = "R",
only_all_tested = only_all_tested,
only_count = TRUE
ab_result = "R",
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(gsub("in sir_calc(): ", "", e$message, fixed = TRUE), call = -5)
)

12
R/custom_eucast_rules.R
View File

@ -169,7 +169,7 @@ custom_eucast_rules <- function(...) {
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see `?custom_eucast_rules`"
)
result_group <- as.character(result)[[2]]
result_group<- as.character(str2lang(result_group))
result_group <- as.character(str2lang(result_group))
result_group <- result_group[result_group != "c"]
result_group_agents <- character(0)
for (j in seq_len(length(result_group))) {
@ -178,13 +178,15 @@ custom_eucast_rules <- function(...) {
result_group[j] <- paste0(result_group[j], "s")
}
if (paste0("AB_", toupper(result_group[j])) %in% DEFINED_AB_GROUPS) {
result_group_agents <- c(result_group_agents,
eval(parse(text = paste0("AB_", toupper(result_group[j]))), envir = asNamespace("AMR")))
result_group_agents <- c(
result_group_agents,
eval(parse(text = paste0("AB_", toupper(result_group[j]))), envir = asNamespace("AMR"))
)
} else {
out_group <- tryCatch(
suppressWarnings(as.ab(result_group[j],
fast_mode = TRUE,
flag_multiple_results = FALSE
fast_mode = TRUE,
flag_multiple_results = FALSE
)),
error = function(e) NA_character_
)

45
R/custom_microorganisms.R
View File

@ -250,10 +250,13 @@ add_custom_microorganisms <- function(x) {
"_",
trimws(
paste(abbreviate_mo(x$genus, 5),
abbreviate_mo(x$species, 4, hyphen_as_space = TRUE),
abbreviate_mo(x$subspecies, 4, hyphen_as_space = TRUE),
sep = "_"),
whitespace = "_"))
abbreviate_mo(x$species, 4, hyphen_as_space = TRUE),
abbreviate_mo(x$subspecies, 4, hyphen_as_space = TRUE),
sep = "_"
),
whitespace = "_"
)
)
stop_if(anyDuplicated(c(as.character(AMR_env$MO_lookup$mo), x$mo)), "MO codes must be unique and not match existing MO codes of the AMR package")
# add to package ----
@ -309,19 +312,25 @@ abbreviate_mo <- function(x, minlength = 5, prefix = "", hyphen_as_space = FALSE
}
# keep a starting Latin ae
suppressWarnings(
gsub("(\u00C6|\u00E6)+",
"AE",
toupper(
paste0(prefix,
abbreviate(
gsub("^ae",
"\u00E6\u00E6",
x,
ignore.case = TRUE),
minlength = minlength,
use.classes = TRUE,
method = "both.sides",
...
))))
gsub(
"(\u00C6|\u00E6)+",
"AE",
toupper(
paste0(
prefix,
abbreviate(
gsub("^ae",
"\u00E6\u00E6",
x,
ignore.case = TRUE
),
minlength = minlength,
use.classes = TRUE,
method = "both.sides",
...
)
)
)
)
)
}

10
R/eucast_rules.R
View File

@ -462,10 +462,12 @@ eucast_rules <- function(x,
if (isTRUE(info)) {
cat(paste0("\n", font_grey(strrep("-", 0.95 * getOption("width", 100))), "\n"))
cat(word_wrap(
paste0("Rules by the ",
font_bold(paste0("AMR package v", utils::packageDescription("AMR")$Version)),
" (", format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"),
"), see `?eucast_rules`\n")
paste0(
"Rules by the ",
font_bold(paste0("AMR package v", utils::packageDescription("AMR")$Version)),
" (", format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"),
"), see `?eucast_rules`\n"
)
))
cat("\n\n")
}

35
R/first_isolate.R
View File

@ -517,7 +517,8 @@ first_isolate <- function(x = NULL,
if (icu_exclude == TRUE) {
if (isTRUE(info)) {
message_("Excluding ", format(sum(x$newvar_is_icu, na.rm = TRUE), decimal.mark = decimal.mark, big.mark = big.mark), " isolates from ICU.",
add_fn = font_red)
add_fn = font_red
)
}
x[which(x$newvar_is_icu), "newvar_first_isolate"] <- FALSE
} else if (isTRUE(info)) {
@ -673,10 +674,12 @@ duplicated_antibiogram <- function(antibiogram, points_threshold, ignore_I, type
return(FALSE)
}
# first sort on data availability - count the dots and order that ascending so that highest availability of SIR is on top
number_dots <- vapply(FUN.VALUE = integer(1),
antibiogram,
function(x) sum(strsplit(x, "", fixed = TRUE)[[1]] == "."),
USE.NAMES = FALSE)
number_dots <- vapply(
FUN.VALUE = integer(1),
antibiogram,
function(x) sum(strsplit(x, "", fixed = TRUE)[[1]] == "."),
USE.NAMES = FALSE
)
new_order <- order(number_dots, antibiogram)
antibiogram.bak <- antibiogram
antibiogram <- antibiogram[new_order]
@ -684,8 +687,9 @@ duplicated_antibiogram <- function(antibiogram, points_threshold, ignore_I, type
out <- rep(NA, length(antibiogram))
out[1] <- FALSE
out[2] <- antimicrobials_equal(antibiogram[1], antibiogram[2],
ignore_I = ignore_I, points_threshold = points_threshold,
type = type)
ignore_I = ignore_I, points_threshold = points_threshold,
type = type
)
if (length(antibiogram) == 2) {
# fast return, no further check required
return(out)
@ -702,11 +706,18 @@ duplicated_antibiogram <- function(antibiogram, points_threshold, ignore_I, type
for (na in antibiogram[is.na(out)]) {
# check if this antibiogram has any change with other antibiograms
out[which(antibiogram == na)] <- all(
vapply(FUN.VALUE = logical(1),
antibiogram[!is.na(out) & antibiogram != na],
function(y) antimicrobials_equal(y = y, z = na,
ignore_I = ignore_I, points_threshold = points_threshold,
type = type)))
vapply(
FUN.VALUE = logical(1),
antibiogram[!is.na(out) & antibiogram != na],
function(y) {
antimicrobials_equal(
y = y, z = na,
ignore_I = ignore_I, points_threshold = points_threshold,
type = type
)
}
)
)
}
out <- out[order(new_order)]

6
R/ggplot_sir.R
View File

@ -121,8 +121,10 @@
#' ) %>%
#' ggplot() +
#' geom_col(aes(x = x, y = y, fill = z)) +
#' scale_sir_colours(aesthetics = "fill",
#' Value4 = "S", Value5 = "I", Value6 = "R")
#' scale_sir_colours(
#' aesthetics = "fill",
#' Value4 = "S", Value5 = "I", Value6 = "R"
#' )
#' }
#' if (require("ggplot2") && require("dplyr")) {
#' # resistance of ciprofloxacine per age group

40
R/mdro.R
View File

@ -787,7 +787,7 @@ mdro <- function(x = NULL,
search_function <- all
}
x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]),
stringsAsFactors = FALSE
stringsAsFactors = FALSE
))
rows_affected <- vapply(
FUN.VALUE = logical(1),
@ -799,11 +799,13 @@ mdro <- function(x = NULL,
rows_not_to_change <- rows[!rows %in% c(rows_affected, rows_to_change)]
rows_not_to_change <- rows_not_to_change[is.na(x[rows_not_to_change, "reason"])]
if (is.null(reason)) {
reason <- paste0(any_all,
" of the required antibiotics ",
ifelse(any_all == "any", "is", "are"),
" R",
ifelse(!isTRUE(combine_SI), " or I", ""))
reason <- paste0(
any_all,
" of the required antibiotics ",
ifelse(any_all == "any", "is", "are"),
" R",
ifelse(!isTRUE(combine_SI), " or I", "")
)
}
x[rows_to_change, "MDRO"] <<- to
x[rows_to_change, "reason"] <<- reason
@ -1561,9 +1563,9 @@ mdro <- function(x = NULL,
trans_tbl(
3,
rows = which(x[[SXT]] == "R" &
(x[[GEN]] == "R" | x[[TOB]] == "R" | x[[AMK]] == "R") &
(x[[CIP]] == "R" | x[[NOR]] == "R" | x[[LVX]] == "R") &
(x$genus %in% c("Enterobacter", "Providencia") | paste(x$genus, x$species) %in% c("Citrobacter freundii", "Klebsiella aerogenes", "Hafnia alvei", "Morganella morganii"))),
(x[[GEN]] == "R" | x[[TOB]] == "R" | x[[AMK]] == "R") &
(x[[CIP]] == "R" | x[[NOR]] == "R" | x[[LVX]] == "R") &
(x$genus %in% c("Enterobacter", "Providencia") | paste(x$genus, x$species) %in% c("Citrobacter freundii", "Klebsiella aerogenes", "Hafnia alvei", "Morganella morganii"))),
cols = c(SXT, aminoglycosides, fluoroquinolones),
any_all = "any",
reason = "Enterobacterales group II: aminoglycoside + fluoroquinolone + cotrimoxazol"
@ -1571,9 +1573,9 @@ mdro <- function(x = NULL,
trans_tbl(
3,
rows = which(x[[SXT]] == "R" &
x[[GEN]] == "R" &
(x[[CIP]] == "R" | x[[NOR]] == "R" | x[[LVX]] == "R") &
paste(x$genus, x$species) == "Serratia marcescens"),
x[[GEN]] == "R" &
(x[[CIP]] == "R" | x[[NOR]] == "R" | x[[LVX]] == "R") &
paste(x$genus, x$species) == "Serratia marcescens"),
cols = c(SXT, aminoglycosides_serratia_marcescens, fluoroquinolones),
any_all = "any",
reason = "Enterobacterales group II: aminoglycoside + fluoroquinolone + cotrimoxazol"
@ -1583,8 +1585,8 @@ mdro <- function(x = NULL,
trans_tbl(
3,
rows = which((x[[GEN]] == "R" | x[[TOB]] == "R" | x[[AMK]] == "R") &
(x[[CIP]] == "R" | x[[LVX]] == "R") &
x[[col_mo]] %in% AMR::microorganisms.groups$mo[AMR::microorganisms.groups$mo_group_name == "Acinetobacter baumannii complex"]),
(x[[CIP]] == "R" | x[[LVX]] == "R") &
x[[col_mo]] %in% AMR::microorganisms.groups$mo[AMR::microorganisms.groups$mo_group_name == "Acinetobacter baumannii complex"]),
cols = c(aminoglycosides, CIP, LVX),
any_all = "any",
reason = "A. baumannii-calcoaceticus complex: aminoglycoside + ciprofloxacin or levofloxacin"
@ -1729,10 +1731,10 @@ mdro <- function(x = NULL,
)
if (!ab_missing(MEM) && !ab_missing(IPM) &&
!ab_missing(GEN) && !ab_missing(TOB) &&
!ab_missing(CIP) &&
!ab_missing(CAZ) &&
!ab_missing(TZP)) {
!ab_missing(GEN) && !ab_missing(TOB) &&
!ab_missing(CIP) &&
!ab_missing(CAZ) &&
!ab_missing(TZP)) {
x$psae <- 0
x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"]
x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"]
@ -1848,7 +1850,7 @@ mdro <- function(x = NULL,
" (3 required for MDR)"
)
} else {
#x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R"
# x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R"
}
}

84
R/mic.R
View File

@ -39,18 +39,22 @@ VALID_MIC_LEVELS <- c(
)
VALID_MIC_LEVELS <- trimws(gsub("[.]?0+$", "", format(unique(sort(VALID_MIC_LEVELS)), scientific = FALSE), perl = TRUE))
operators <- c("<", "<=", "", ">=", ">")
VALID_MIC_LEVELS <- c(t(vapply(FUN.VALUE = character(length(VALID_MIC_LEVELS)),
c("<", "<=", "", ">=", ">"),
paste0,
VALID_MIC_LEVELS)))
COMMON_MIC_VALUES <- c(0.0001, 0.0002, 0.0005,
0.001, 0.002, 0.004, 0.008,
0.016, 0.032, 0.064,
0.125, 0.25, 0.5,
1, 2, 4, 8,
16, 32, 64,
128, 256, 512,
1024, 2048, 4096)
VALID_MIC_LEVELS <- c(t(vapply(
FUN.VALUE = character(length(VALID_MIC_LEVELS)),
c("<", "<=", "", ">=", ">"),
paste0,
VALID_MIC_LEVELS
)))
COMMON_MIC_VALUES <- c(
0.0001, 0.0002, 0.0005,
0.001, 0.002, 0.004, 0.008,
0.016, 0.032, 0.064,
0.125, 0.25, 0.5,
1, 2, 4, 8,
16, 32, 64,
128, 256, 512,
1024, 2048, 4096
)
#' Transform Input to Minimum Inhibitory Concentrations (MIC)
#'
@ -165,7 +169,8 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
if (!identical(levels(x), VALID_MIC_LEVELS)) {
# might be from an older AMR version - just update MIC factor levels
x <- set_clean_class(factor(as.character(x), levels = VALID_MIC_LEVELS, ordered = TRUE),
new_class = c("mic", "ordered", "factor"))
new_class = c("mic", "ordered", "factor")
)
}
return(x)
}
@ -244,13 +249,13 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
vector_and(quotes = TRUE)
cur_col <- get_current_column()
warning_("in `as.mic()`: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ",
list_missing,
call = FALSE
ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ",
list_missing,
call = FALSE
)
}
@ -265,7 +270,8 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all") {
}
set_clean_class(factor(x, levels = VALID_MIC_LEVELS, ordered = TRUE),
new_class = c("mic", "ordered", "factor"))
new_class = c("mic", "ordered", "factor")
)
}
#' @rdname as.mic
@ -294,10 +300,12 @@ rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE) {
} else if (is.mic(mic_range)) {
mic_range <- as.character(mic_range)
}
stop_ifnot(all(mic_range %in% c(VALID_MIC_LEVELS, NA)),
"Values in `mic_range` must be valid MIC values. ",
"The allowed range is ", format(as.double(as.mic(VALID_MIC_LEVELS)[1]), scientific = FALSE), " to ", format(as.double(as.mic(VALID_MIC_LEVELS)[length(VALID_MIC_LEVELS)]), scientific = FALSE), ". ",
"Unvalid: ", vector_and(mic_range[!mic_range %in% c(VALID_MIC_LEVELS, NA)], quotes = FALSE), ".")
stop_ifnot(
all(mic_range %in% c(VALID_MIC_LEVELS, NA)),
"Values in `mic_range` must be valid MIC values. ",
"The allowed range is ", format(as.double(as.mic(VALID_MIC_LEVELS)[1]), scientific = FALSE), " to ", format(as.double(as.mic(VALID_MIC_LEVELS)[length(VALID_MIC_LEVELS)]), scientific = FALSE), ". ",
"Unvalid: ", vector_and(mic_range[!mic_range %in% c(VALID_MIC_LEVELS, NA)], quotes = FALSE), "."
)
x <- as.mic(x)
if (is.null(mic_range)) {
@ -326,17 +334,19 @@ rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE) {
# create a manual factor with levels only within desired range
expanded <- plotrange_as_table(x,
expand = TRUE,
keep_operators = ifelse(keep_operators == "edges", "none", keep_operators),
mic_range = mic_range)
expand = TRUE,
keep_operators = ifelse(keep_operators == "edges", "none", keep_operators),
mic_range = mic_range
)
if (keep_operators == "edges") {
names(expanded)[1] <- paste0("<=", names(expanded)[1])
names(expanded)[length(expanded)] <- paste0(">=", names(expanded)[length(expanded)])
}
# MICs contain all MIC levels, so strip this to only existing levels and their intermediate values
out <- factor(names(expanded),
levels = names(expanded),
ordered = TRUE)
levels = names(expanded),
ordered = TRUE
)
# and only keep the ones in the data
if (keep_operators == "edges") {
out <- out[match(x, as.double(as.mic(out, keep_operators = "all")))]
@ -393,16 +403,17 @@ all_valid_mics <- function(x) {
return(FALSE)
}
x_mic <- tryCatch(suppressWarnings(as.mic(x[!is.na(x)])),
error = function(e) NA
error = function(e) NA
)
!any(is.na(x_mic)) && !all(is.na(x))
}
# will be exported using s3_register() in R/zzz.R
pillar_shaft.mic <- function(x, ...) {
if(!identical(levels(x), VALID_MIC_LEVELS) && message_not_thrown_before("pillar_shaft.mic")) {
if (!identical(levels(x), VALID_MIC_LEVELS) && message_not_thrown_before("pillar_shaft.mic")) {
warning_(AMR_env$sup_1_icon, " These columns contain an outdated or altered structure - convert with `as.mic()` to update",
call = FALSE)
call = FALSE
)
}
crude_numbers <- as.double(x)
operators <- gsub("[^<=>]+", "", as.character(x))
@ -416,7 +427,7 @@ pillar_shaft.mic <- function(x, ...) {
# will be exported using s3_register() in R/zzz.R
type_sum.mic <- function(x, ...) {
if(!identical(levels(x), VALID_MIC_LEVELS)) {
if (!identical(levels(x), VALID_MIC_LEVELS)) {
paste0("mic", AMR_env$sup_1_icon)
} else {
"mic"
@ -428,7 +439,7 @@ type_sum.mic <- function(x, ...) {
#' @noRd
print.mic <- function(x, ...) {
cat("Class 'mic'")
if(!identical(levels(x), VALID_MIC_LEVELS)) {
if (!identical(levels(x), VALID_MIC_LEVELS)) {
cat(font_red(" with an outdated or altered structure - convert with `as.mic()` to update"))
}
cat("\n")
@ -649,5 +660,6 @@ Summary.mic <- function(..., na.rm = FALSE) {
# NextMethod() cannot be called from an anonymous function (`...`), so we get() the generic directly:
fn <- get(.Generic, envir = .GenericCallEnv)
fn(as.double(c(...)),
na.rm = na.rm)
na.rm = na.rm
)
}

189
R/mo.R
View File

@ -206,9 +206,9 @@ as.mo <- function(x,
add_MO_lookup_to_AMR_env()
if (tryCatch(all(x %in% c(AMR_env$MO_lookup$mo, NA)), error = function(e) FALSE) &&
isFALSE(Becker) &&
isFALSE(Lancefield) &&
isTRUE(keep_synonyms)) {
isFALSE(Becker) &&
isFALSE(Lancefield) &&
isTRUE(keep_synonyms)) {
# don't look into valid MO codes, just return them
# is.mo() won't work - MO codes might change between package versions
return(set_clean_class(x, new_class = c("mo", "character")))
@ -326,14 +326,14 @@ as.mo <- function(x,
minimum_matching_score <- 0.05
} else if (nchar(gsub("[^a-z]", "", x_parts[1], perl = TRUE)) <= 3) {
filtr <- which(MO_lookup_current$full_first == substr(x_parts[1], 1, 1) &
(MO_lookup_current$species_first == substr(x_parts[2], 1, 1) |
MO_lookup_current$subspecies_first == substr(x_parts[2], 1, 1) |
MO_lookup_current$subspecies_first == substr(x_parts[3], 1, 1)))
(MO_lookup_current$species_first == substr(x_parts[2], 1, 1) |
MO_lookup_current$subspecies_first == substr(x_parts[2], 1, 1) |
MO_lookup_current$subspecies_first == substr(x_parts[3], 1, 1)))
} else {
filtr <- which(MO_lookup_current$full_first == substr(x_parts[1], 1, 1) |
MO_lookup_current$species_first == substr(x_parts[2], 1, 1) |
MO_lookup_current$subspecies_first == substr(x_parts[2], 1, 1) |
MO_lookup_current$subspecies_first == substr(x_parts[3], 1, 1))
MO_lookup_current$species_first == substr(x_parts[2], 1, 1) |
MO_lookup_current$subspecies_first == substr(x_parts[2], 1, 1) |
MO_lookup_current$subspecies_first == substr(x_parts[3], 1, 1))
}
} else if (length(x_parts) > 3) {
first_chars <- paste0("(^| )[", paste(substr(x_parts, 1, 1), collapse = ""), "]")
@ -355,8 +355,8 @@ as.mo <- function(x,
} else {
# for genus or species or subspecies
filtr <- which(MO_lookup_current$full_first == substr(x_parts, 1, 1) |
MO_lookup_current$species_first == substr(x_parts, 1, 1) |
MO_lookup_current$subspecies_first == substr(x_parts, 1, 1))
MO_lookup_current$species_first == substr(x_parts, 1, 1) |
MO_lookup_current$subspecies_first == substr(x_parts, 1, 1))
}
if (length(filtr) == 0) {
mo_to_search <- MO_lookup_current$fullname
@ -482,9 +482,9 @@ as.mo <- function(x,
if (any(out %in% AMR_env$MO_lookup$mo[match(post_Becker, AMR_env$MO_lookup$fullname)])) {
if (message_not_thrown_before("as.mo", "becker")) {
warning_("in `as.mo()`: Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ",
vector_and(font_italic(gsub("Staphylococcus", "S.", post_Becker, fixed = TRUE), collapse = NULL), quotes = FALSE),
". Categorisation to CoNS/CoPS was taken from the original scientific publication(s).",
immediate = TRUE, call = FALSE
vector_and(font_italic(gsub("Staphylococcus", "S.", post_Becker, fixed = TRUE), collapse = NULL), quotes = FALSE),
". Categorisation to CoNS/CoPS was taken from the original scientific publication(s).",
immediate = TRUE, call = FALSE
)
}
}
@ -531,7 +531,7 @@ as.mo <- function(x,
# Return class ----
set_clean_class(out,
new_class = c("mo", "character")
new_class = c("mo", "character")
)
}
@ -594,9 +594,11 @@ mo_reset_session <- function() {
#' @rdname as.mo
#' @export
mo_cleaning_regex <- function() {
parts_to_remove <- c("e?spp([^a-z]+|$)", "e?ssp([^a-z]+|$)", "e?ss([^a-z]+|$)", "e?sp([^a-z]+|$)", "e?subsp", "sube?species", "e?species",
"biovar[a-z]*", "biotype", "serovar[a-z]*", "var([^a-z]+|$)", "serogr.?up[a-z]*",
"titer", "dummy", "Ig[ADEGM]", " ?[a-z-]+[-](resistant|susceptible) ?")
parts_to_remove <- c(
"e?spp([^a-z]+|$)", "e?ssp([^a-z]+|$)", "e?ss([^a-z]+|$)", "e?sp([^a-z]+|$)", "e?subsp", "sube?species", "e?species",
"biovar[a-z]*", "biotype", "serovar[a-z]*", "var([^a-z]+|$)", "serogr.?up[a-z]*",
"titer", "dummy", "Ig[ADEGM]", " ?[a-z-]+[-](resistant|susceptible) ?"
)
paste0(
"(",
@ -605,7 +607,8 @@ mo_cleaning_regex <- function() {
"([({]|\\[).+([})]|\\])",
"|(^| )(",
paste0(parts_to_remove[order(1 - nchar(parts_to_remove))], collapse = "|"),
"))")
"))"
)
}
# UNDOCUMENTED METHODS ----------------------------------------------------
@ -627,7 +630,7 @@ pillar_shaft.mo <- function(x, ...) {
out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo] <- font_blue(out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo], collapse = NULL)
df <- tryCatch(get_current_data(arg_name = "x", call = 0),
error = function(e) NULL
error = function(e) NULL
)
if (!is.null(df)) {
mo_cols <- vapply(FUN.VALUE = logical(1), df, is.mo)
@ -637,11 +640,11 @@ pillar_shaft.mo <- function(x, ...) {
all_mos <- c(AMR_env$MO_lookup$mo, NA)
if (!all(x %in% all_mos) ||
(!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) {
(!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) {
# markup old mo codes
out[!x %in% all_mos] <- font_italic(
font_na(x[!x %in% all_mos],
collapse = NULL
collapse = NULL
),
collapse = NULL
)
@ -660,9 +663,13 @@ pillar_shaft.mo <- function(x, ...) {
# add the names to the bugs as mouse-over!
if (tryCatch(isTRUE(getExportedValue("ansi_has_hyperlink_support", ns = asNamespace("cli"))()), error = function(e) FALSE)) {
out[!x %in% c("UNKNOWN", NA)] <- font_url(url = paste0(x[!x %in% c("UNKNOWN", NA)], ": ",
mo_name(x[!x %in% c("UNKNOWN", NA)], keep_synonyms = TRUE)),
txt = out[!x %in% c("UNKNOWN", NA)])
out[!x %in% c("UNKNOWN", NA)] <- font_url(
url = paste0(
x[!x %in% c("UNKNOWN", NA)], ": ",
mo_name(x[!x %in% c("UNKNOWN", NA)], keep_synonyms = TRUE)
),
txt = out[!x %in% c("UNKNOWN", NA)]
)
}
# make it always fit exactly
@ -671,8 +678,8 @@ pillar_shaft.mo <- function(x, ...) {
max_char <- 12
}
create_pillar_column(out,
align = "left",
width = max_char + ifelse(any(x %in% c(NA, "UNKNOWN")), 2, 0)
align = "left",
width = max_char + ifelse(any(x %in% c(NA, "UNKNOWN")), 2, 0)
)
}
@ -695,21 +702,21 @@ freq.mo <- function(x, ...) {
.add_header = list(
`Gram-negative` = paste0(
format(sum(grams == "Gram-negative", na.rm = TRUE),
big.mark = " ",
decimal.mark = "."
big.mark = " ",
decimal.mark = "."
),
" (", percentage(sum(grams == "Gram-negative", na.rm = TRUE) / length(grams),
digits = digits
digits = digits
),
")"
),
`Gram-positive` = paste0(
format(sum(grams == "Gram-positive", na.rm = TRUE),
big.mark = " ",
decimal.mark = "."
big.mark = " ",
decimal.mark = "."
),
" (", percentage(sum(grams == "Gram-positive", na.rm = TRUE) / length(grams),
digits = digits
digits = digits
),
")"
),
@ -883,11 +890,11 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
if (has_colour()) {
cat(word_wrap("Colour keys: ",
col_red(" 0.000-0.549 "),
col_orange(" 0.550-0.649 "),
col_yellow(" 0.650-0.749 "),
col_green(" 0.750-1.000"),
add_fn = font_blue
col_red(" 0.000-0.549 "),
col_orange(" 0.550-0.649 "),
col_yellow(" 0.650-0.749 "),
col_green(" 0.750-1.000"),
add_fn = font_blue
), font_green_bg(" "), "\n", sep = "")
}
@ -944,32 +951,32 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
)
score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3))
txt <- paste(txt,
paste0(
paste0(
"", strrep(font_grey("-"), times = getOption("width", 100)), "\n",
'"', x[i, ]$original_input, '"',
" -> ",
paste0(
font_bold(italicise(x[i, ]$fullname)),
" (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")"
)
),
collapse = "\n"
),
ifelse(x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")],
paste0(
strrep(" ", nchar(x[i, ]$original_input) + 6),
ifelse(x[i, ]$keep_synonyms == FALSE,
# Add note if result was coerced to accepted taxonomic name
font_red(paste0("This outdated taxonomic name was converted to ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL),
# Or add note if result is currently another taxonomic name
font_red(paste0(font_bold("Note: "), "The current name is ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", AMR_env$MO_lookup$ref[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], ")."), collapse = NULL)
)
),
""
),
candidates,
sep = "\n"
paste0(
paste0(
"", strrep(font_grey("-"), times = getOption("width", 100)), "\n",
'"', x[i, ]$original_input, '"',
" -> ",
paste0(
font_bold(italicise(x[i, ]$fullname)),
" (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")"
)
),
collapse = "\n"
),
ifelse(x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")],
paste0(
strrep(" ", nchar(x[i, ]$original_input) + 6),
ifelse(x[i, ]$keep_synonyms == FALSE,
# Add note if result was coerced to accepted taxonomic name
font_red(paste0("This outdated taxonomic name was converted to ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL),
# Or add note if result is currently another taxonomic name
font_red(paste0(font_bold("Note: "), "The current name is ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", AMR_env$MO_lookup$ref[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], ")."), collapse = NULL)
)
),
""
),
candidates,
sep = "\n"
)
txt <- gsub("[\n]+", "\n", txt)
# remove first and last break
@ -1005,8 +1012,8 @@ print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
message_(
"The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":\n",
paste0(" ", AMR_env$bullet_icon, " ", font_italic(x$old[rows], collapse = NULL), x$ref_old[rows],
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
collapse = "\n"
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
collapse = "\n"
),
ifelse(NROW(x) > n, paste0("\n\nOnly the first ", n, " (out of ", NROW(x), ") are shown. Run `print(mo_renamed(), n = ...)` to view more entries (might be slow), or save `mo_renamed()` to an object."), "")
)
@ -1021,25 +1028,25 @@ convert_colloquial_input <- function(x) {
# Streptococci, like GBS = Group B Streptococci (B_STRPT_GRPB)
out[x %like_case% "^g[abcdefghijkl]s$"] <- gsub("g([abcdefghijkl])s",
"B_STRPT_GRP\\U\\1",
x[x %like_case% "^g[abcdefghijkl]s$"],
perl = TRUE
"B_STRPT_GRP\\U\\1",
x[x %like_case% "^g[abcdefghijkl]s$"],
perl = TRUE
)
# Streptococci in different languages, like "estreptococos grupo B"
out[x %like_case% "strepto[ck]o[ck][a-zA-Z ]* [abcdefghijkl]$"] <- gsub(".*e?strepto[ck]o[ck].* ([abcdefghijkl])$",
"B_STRPT_GRP\\U\\1",
x[x %like_case% "strepto[ck]o[ck][a-zA-Z ]* [abcdefghijkl]$"],
perl = TRUE
"B_STRPT_GRP\\U\\1",
x[x %like_case% "strepto[ck]o[ck][a-zA-Z ]* [abcdefghijkl]$"],
perl = TRUE
)
out[x %like_case% "strep[a-z]* group [abcdefghijkl]$"] <- gsub(".* ([abcdefghijkl])$",
"B_STRPT_GRP\\U\\1",
x[x %like_case% "strep[a-z]* group [abcdefghijkl]$"],
perl = TRUE
"B_STRPT_GRP\\U\\1",
x[x %like_case% "strep[a-z]* group [abcdefghijkl]$"],
perl = TRUE
)
out[x %like_case% "group [abcdefghijkl] strepto[ck]o[ck]"] <- gsub(".*group ([abcdefghijkl]) strepto[ck]o[ck].*",
"B_STRPT_GRP\\U\\1",
x[x %like_case% "group [abcdefghijkl] strepto[ck]o[ck]"],
perl = TRUE
"B_STRPT_GRP\\U\\1",
x[x %like_case% "group [abcdefghijkl] strepto[ck]o[ck]"],
perl = TRUE
)
out[x %like_case% "ha?emoly.*strep"] <- "B_STRPT_HAEM"
out[x %like_case% "(strepto.* [abcg, ]{2,4}$)"] <- "B_STRPT_ABCG"
@ -1050,14 +1057,14 @@ convert_colloquial_input <- function(x) {
# Salmonella in different languages, like "Salmonella grupo B"
out[x %like_case% "salmonella.* [abcdefgh]$"] <- gsub(".*salmonella.* ([abcdefgh])$",
"B_SLMNL_GRP\\U\\1",
x[x %like_case% "salmonella.* [abcdefgh]$"],
perl = TRUE
"B_SLMNL_GRP\\U\\1",
x[x %like_case% "salmonella.* [abcdefgh]$"],
perl = TRUE
)
out[x %like_case% "group [abcdefgh] salmonella"] <- gsub(".*group ([abcdefgh]) salmonella*",
"B_SLMNL_GRP\\U\\1",
x[x %like_case% "group [abcdefgh] salmonella"],
perl = TRUE
"B_SLMNL_GRP\\U\\1",
x[x %like_case% "group [abcdefgh] salmonella"],
perl = TRUE
)
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese)
@ -1191,7 +1198,7 @@ replace_old_mo_codes <- function(x, property) {
name <- gsub(" .*", " ", name, fixed = TRUE)
name <- paste0("^", name)
results <- AMR_env$MO_lookup$mo[AMR_env$MO_lookup$kingdom %like_case% kingdom &
AMR_env$MO_lookup$fullname_lower %like_case% name]
AMR_env$MO_lookup$fullname_lower %like_case% name]
if (length(results) > 1) {
all_direct_matches <<- FALSE
}
@ -1228,8 +1235,8 @@ replace_old_mo_codes <- function(x, property) {
"to ", ifelse(n_solved == 1, "a ", ""),
"currently used MO code", ifelse(n_solved == 1, "", "s"),
ifelse(n_unsolved > 0,
paste0(" and ", n_unsolved, " old MO code", ifelse(n_unsolved == 1, "", "s"), " could not be updated."),
"."
paste0(" and ", n_unsolved, " old MO code", ifelse(n_unsolved == 1, "", "s"), " could not be updated."),
"."
)
)
}
@ -1277,8 +1284,10 @@ repair_reference_df <- function(reference_df) {
}
get_mo_uncertainties <- function() {
remember <- list(uncertainties = AMR_env$mo_uncertainties,
failures = AMR_env$mo_failures)
remember <- list(
uncertainties = AMR_env$mo_uncertainties,
failures = AMR_env$mo_failures
)
# empty them, otherwise e.g. mo_shortname("Chlamydophila psittaci") will give 3 notes
AMR_env$mo_uncertainties <- NULL
AMR_env$mo_failures <- NULL
@ -1300,7 +1309,7 @@ synonym_mo_to_accepted_mo <- function(x, fill_in_accepted = FALSE, dataset = AMR
out <- x
is_still_synonym <- dataset$status[match(out, dataset$mo)] == "synonym"
limit <- 0
while(any(is_still_synonym, na.rm = TRUE) && limit < 5) {
while (any(is_still_synonym, na.rm = TRUE) && limit < 5) {
limit <- limit + 1
# make sure to get the latest name, e.g. Fusarium pulicaris robiniae was first renamed to Fusarium roseum, then to Fusarium sambucinum

34
R/mo_property.R
View File

@ -108,10 +108,12 @@
#' mo_url("Klebsiella pneumoniae")
#' mo_is_yeast(c("Candida", "Trichophyton", "Klebsiella"))
#'
#' mo_group_members(c("Streptococcus group A",
#' "Streptococcus group C",
#' "Streptococcus group G",
#' "Streptococcus group L"))
#' mo_group_members(c(
#' "Streptococcus group A",
#' "Streptococcus group C",
#' "Streptococcus group G",
#' "Streptococcus group L"
#' ))
#'
#'
#' # scientific reference -----------------------------------------------------
@ -442,13 +444,16 @@ mo_pathogenicity <- function(x, language = get_AMR_locale(), keep_synonyms = get
kngd <- AMR_env$MO_lookup$kingdom[match(x.mo, AMR_env$MO_lookup$mo)]
rank <- AMR_env$MO_lookup$rank[match(x.mo, AMR_env$MO_lookup$mo)]
out <- factor(case_when_AMR(prev <= 1.15 & kngd == "Bacteria" & rank != "genus" ~ "Pathogenic",
prev < 2 & kngd == "Fungi" ~ "Potentially pathogenic",
prev == 2 & kngd == "Bacteria" ~ "Non-pathogenic",
kngd == "Bacteria" ~ "Potentially pathogenic",
TRUE ~ "Unknown"),
levels = c("Pathogenic", "Potentially pathogenic", "Non-pathogenic", "Unknown"),
ordered = TRUE
out <- factor(
case_when_AMR(
prev <= 1.15 & kngd == "Bacteria" & rank != "genus" ~ "Pathogenic",
prev < 2 & kngd == "Fungi" ~ "Potentially pathogenic",
prev == 2 & kngd == "Bacteria" ~ "Non-pathogenic",
kngd == "Bacteria" ~ "Potentially pathogenic",
TRUE ~ "Unknown"
),
levels = c("Pathogenic", "Potentially pathogenic", "Non-pathogenic", "Unknown"),
ordered = TRUE
)
load_mo_uncertainties(metadata)
@ -872,8 +877,10 @@ mo_info <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("A
info <- lapply(x, function(y) {
c(
list(mo = as.character(y),
rank = mo_rank(y, language = language, keep_synonyms = keep_synonyms)),
list(
mo = as.character(y),
rank = mo_rank(y, language = language, keep_synonyms = keep_synonyms)
),
mo_taxonomy(y, language = language, keep_synonyms = keep_synonyms),
list(
status = mo_status(y, language = language, keep_synonyms = keep_synonyms),
@ -988,7 +995,6 @@ mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ..
} else {
x <- AMR_env$MO_lookup[[property]][match(x, AMR_env$MO_lookup$mo)]
}
} else {
# get microorganisms data set, but remove synonyms if keep_synonyms is FALSE
mo_data_check <- AMR_env$MO_lookup[which(AMR_env$MO_lookup$status %in% if (isTRUE(keep_synonyms)) c("synonym", "accepted") else "accepted"), , drop = FALSE]

224
R/plotting.R
View File

@ -80,7 +80,6 @@
#' some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
#' some_sir_values <- random_sir(50, prob_SIR = c(0.55, 0.05, 0.30))
#'
#'
#' \donttest{
#' # Plotting using ggplot2's autoplot() for MIC, disk, and SIR -----------
#' if (require("ggplot2")) {
@ -92,17 +91,23 @@
#' }
#' if (require("ggplot2")) {
#' # support for 20 languages, various guidelines, and many options
#' autoplot(some_disk_values, mo = "Escherichia coli", ab = "cipro",
#' guideline = "CLSI 2024", language = "no",
#' title = "Disk diffusion from the North")
#' autoplot(some_disk_values,
#' mo = "Escherichia coli", ab = "cipro",
#' guideline = "CLSI 2024", language = "no",
#' title = "Disk diffusion from the North"
#' )
#' }
#'
#'
#' # Plotting using scale_x_mic() -----------------------------------------
#' if (require("ggplot2")) {
#' mic_plot <- ggplot(data.frame(mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
#' counts = c(1, 1, 2, 2, 3, 3)),
#' aes(mics, counts)) +
#' mic_plot <- ggplot(
#' data.frame(
#' mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
#' counts = c(1, 1, 2, 2, 3, 3)
#' ),
#' aes(mics, counts)
#' ) +
#' geom_col()
#' mic_plot +
#' labs(title = "without scale_x_mic()")
@ -133,17 +138,25 @@
#' some_groups <- sample(LETTERS[1:5], 20, replace = TRUE)
#'
#' if (require("ggplot2")) {
#' ggplot(data.frame(mic = some_mic_values,
#' group = some_groups),
#' aes(group, mic)) +
#' ggplot(
#' data.frame(
#' mic = some_mic_values,
#' group = some_groups
#' ),
#' aes(group, mic)
#' ) +
#' geom_boxplot() +
#' geom_violin(linetype = 2, colour = "grey", fill = NA) +
#' scale_y_mic()
#' }
#' if (require("ggplot2")) {
#' ggplot(data.frame(mic = some_mic_values,
#' group = some_groups),
#' aes(group, mic)) +
#' ggplot(
#' data.frame(
#' mic = some_mic_values,
#' group = some_groups
#' ),
#' aes(group, mic)
#' ) +
#' geom_boxplot() +
#' geom_violin(linetype = 2, colour = "grey", fill = NA) +
#' scale_y_mic(mic_range = c(NA, 0.25))
@ -152,9 +165,13 @@
#'
#' # Plotting using scale_x_sir() -----------------------------------------
#' if (require("ggplot2")) {
#' ggplot(data.frame(x = c("I", "R", "S"),
#' y = c(45,323, 573)),
#' aes(x, y)) +
#' ggplot(
#' data.frame(
#' x = c("I", "R", "S"),
#' y = c(45, 323, 573)
#' ),
#' aes(x, y)
#' ) +
#' geom_col() +
#' scale_x_sir()
#' }
@ -162,12 +179,17 @@
#'
#' # Plotting using scale_y_mic() and scale_colour_sir() ------------------
#' if (require("ggplot2")) {
#' plain <- ggplot(data.frame(mic = some_mic_values,
#' group = some_groups,
#' sir = as.sir(some_mic_values,
#' mo = "E. coli",
#' ab = "cipro")),
#' aes(x = group, y = mic, colour = sir)) +
#' plain <- ggplot(
#' data.frame(
#' mic = some_mic_values,
#' group = some_groups,
#' sir = as.sir(some_mic_values,
#' mo = "E. coli",
#' ab = "cipro"
#' )
#' ),
#' aes(x = group, y = mic, colour = sir)
#' ) +
#' theme_minimal() +
#' geom_boxplot(fill = NA, colour = "grey") +
#' geom_jitter(width = 0.25)
@ -183,8 +205,10 @@
#' if (require("ggplot2")) {
#' plain +
#' scale_y_mic(mic_range = c(0.005, 32), name = "Our MICs!") +
#' scale_colour_sir(language = "pt",
#' name = "Support in 20 languages")
#' scale_colour_sir(
#' language = "pt",
#' name = "Support in 20 languages"
#' )
#' }
#' }
#'
@ -203,7 +227,8 @@ NULL
create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
ggplot_fn <- getExportedValue(paste0("scale_", aest, "_continuous"),
ns = asNamespace("ggplot2"))
ns = asNamespace("ggplot2")
)
args <- list(...)
breaks_set <- args$breaks
limits_set <- args$limits
@ -228,8 +253,8 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
if (!is.null(mic_range) && !is.na(mic_range[2]) && !is.na(lims[2]) && mic_range[2] > lims[2]) {
lims[2] <- mic_range[2]
}
ind_min <- which(COMMON_MIC_VALUES <= lims[1])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES <= lims[1]] - lims[1]))] # Closest index where COMMON_MIC_VALUES <= lims[1]
ind_max <- which(COMMON_MIC_VALUES >= lims[2])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES >= lims[2]] - lims[2]))] # Closest index where COMMON_MIC_VALUES >= lims[2]
ind_min <- which(COMMON_MIC_VALUES <= lims[1])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES <= lims[1]] - lims[1]))] # Closest index where COMMON_MIC_VALUES <= lims[1]
ind_max <- which(COMMON_MIC_VALUES >= lims[2])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES >= lims[2]] - lims[2]))] # Closest index where COMMON_MIC_VALUES >= lims[2]
self$mic_values_levels <- as.mic(COMMON_MIC_VALUES[ind_min:ind_max])
@ -264,7 +289,7 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
breaks <- tryCatch(scale$breaks(), error = function(e) NULL)
if (!is.null(breaks)) {
# for when breaks are set by the user
2 ^ breaks
2^breaks
} else {
self$mic_values_levels
}
@ -338,20 +363,27 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
ggplot_fn <- ggplot2::scale_x_discrete
} else {
ggplot_fn <- ggplot2::scale_discrete_manual
args <- c(args,
list(aesthetics = aesthetics,
values = c(S = colours_SIR[1],
SDD = colours_SIR[2],
I = colours_SIR[2],
R = colours_SIR[3],
NI = "grey30")))
args <- c(
args,
list(
aesthetics = aesthetics,
values = c(
S = colours_SIR[1],
SDD = colours_SIR[2],
I = colours_SIR[2],
R = colours_SIR[3],
NI = "grey30"
)
)
)
}
scale <- do.call(ggplot_fn, args)
scale$labels <- function(x) {
stop_ifnot(all(x %in% c(levels(NA_sir_), NA)),
"Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see `?as.sir`.",
call = FALSE)
"Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see `?as.sir`.",
call = FALSE
)
x <- as.character(as.sir(x))
if (!is.null(language)) {
x[x == "S"] <- "(S) Susceptible"
@ -479,12 +511,12 @@ plot.mic <- function(x,
...
)
barplot(x,
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE
)
axis(2, seq(0, max(x)))
if (!is.null(cols_sub$sub)) {
@ -508,14 +540,14 @@ plot.mic <- function(x,
}
legend("top",
x.intersp = 0.5,
legend = translate_into_language(legend_txt, language = language),
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55"
x.intersp = 0.5,
legend = translate_into_language(legend_txt, language = language),
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55"
)
}
}
@ -617,15 +649,15 @@ autoplot.mic <- function(object,
df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
df$cols <- factor(translate_into_language(df$cols, language = language),
levels = translate_into_language(
c(
"(S) Susceptible",
paste("(I)", plot_name_of_I(cols_sub$guideline)),
"(R) Resistant"
),
language = language
),
ordered = TRUE
levels = translate_into_language(
c(
"(S) Susceptible",
paste("(I)", plot_name_of_I(cols_sub$guideline)),
"(R) Resistant"
),
language = language
),
ordered = TRUE
)
p <- ggplot2::ggplot(df)
@ -715,12 +747,12 @@ plot.disk <- function(x,
)
barplot(x,
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_SIR %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE
)
axis(2, seq(0, max(x)))
if (!is.null(cols_sub$sub)) {
@ -743,14 +775,14 @@ plot.disk <- function(x,
legend_col <- c(legend_col, colours_SIR[1])
}
legend("top",
x.intersp = 0.5,
legend = translate_into_language(legend_txt, language = language),
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55"
x.intersp = 0.5,
legend = translate_into_language(legend_txt, language = language),
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55"
)
}
}
@ -850,15 +882,15 @@ autoplot.disk <- function(object,
df$cols[df$cols == colours_SIR[2]] <- paste("(I)", plot_name_of_I(cols_sub$guideline))
df$cols[df$cols == colours_SIR[3]] <- "(R) Resistant"
df$cols <- factor(translate_into_language(df$cols, language = language),
levels = translate_into_language(
c(
"(S) Susceptible",
paste("(I)", plot_name_of_I(cols_sub$guideline)),
"(R) Resistant"
),
language = language
),
ordered = TRUE
levels = translate_into_language(
c(
"(S) Susceptible",
paste("(I)", plot_name_of_I(cols_sub$guideline)),
"(R) Resistant"
),
language = language
),
ordered = TRUE
)
p <- ggplot2::ggplot(df)
@ -992,11 +1024,11 @@ barplot.sir <- function(height,
x <- x[!(names(x) %in% c("SDD", "I", "NI") & x == 0)]
# plot it
barplot(x,
col = colours_SIR,
xlab = xlab,
main = main,
ylab = ylab,
axes = FALSE
col = colours_SIR,
xlab = xlab,
main = main,
ylab = ylab,
axes = FALSE
)
axis(2, seq(0, max(x)))
}
@ -1262,27 +1294,27 @@ scale_sir_colours <- function(...,
names_susceptible <- c(
"S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible"),
"replacement",
drop = TRUE
"replacement",
drop = TRUE
])
)
names_incr_exposure <- c(
"I", "intermediate", "increased exposure", "incr. exposure",
"Increased exposure", "Incr. exposure", "Susceptible, incr. exp.",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Intermediate"),
"replacement",
drop = TRUE
"replacement",
drop = TRUE
]),
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible, incr. exp."),
"replacement",
drop = TRUE
"replacement",
drop = TRUE
])
)
names_resistant <- c(
"R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Resistant"),
"replacement",
drop = TRUE
"replacement",
drop = TRUE
])
)

185
R/sir.R
View File

@ -196,64 +196,92 @@
#' df_long %>%
#' # given a certain data type, e.g. MIC values
#' mutate_if(is.mic, as.sir,
#' mo = "bacteria",
#' ab = "antibiotic",
#' guideline = "CLSI")
#' mo = "bacteria",
#' ab = "antibiotic",
#' guideline = "CLSI"
#' )
#' df_long %>%
#' mutate(across(where(is.mic),
#' function(x) as.sir(x,
#' mo = "bacteria",
#' ab = "antibiotic",
#' guideline = "CLSI")))
#' mutate(across(
#' where(is.mic),
#' function(x) {
#' as.sir(x,
#' mo = "bacteria",
#' ab = "antibiotic",
#' guideline = "CLSI"
#' )
#' }
#' ))
#' df_wide %>%
#' # given certain columns, e.g. from 'cipro' to 'genta'
#' mutate_at(vars(cipro:genta), as.sir,
#' mo = "bacteria",
#' guideline = "CLSI")
#' mo = "bacteria",
#' guideline = "CLSI"
#' )
#' df_wide %>%
#' mutate(across(cipro:genta,
#' function(x) as.sir(x,
#' mo = "bacteria",
#' guideline = "CLSI")))
#' mutate(across(
#' cipro:genta,
#' function(x) {
#' as.sir(x,
#' mo = "bacteria",
#' guideline = "CLSI"
#' )
#' }
#' ))
#'
#' # for veterinary breakpoints, add 'host':
#' df_long$animal_species <- c("cats", "dogs", "horses", "cattle")
#' df_long %>%
#' # given a certain data type, e.g. MIC values
#' mutate_if(is.mic, as.sir,
#' mo = "bacteria",
#' ab = "antibiotic",
#' host = "animal_species",
#' guideline = "CLSI")
#' mo = "bacteria",
#' ab = "antibiotic",
#' host = "animal_species",
#' guideline = "CLSI"
#' )
#' df_long %>%
#' mutate(across(where(is.mic),
#' function(x) as.sir(x,
#' mo = "bacteria",
#' ab = "antibiotic",
#' host = "animal_species",
#' guideline = "CLSI")))
#' mutate(across(
#' where(is.mic),
#' function(x) {
#' as.sir(x,
#' mo = "bacteria",
#' ab = "antibiotic",
#' host = "animal_species",
#' guideline = "CLSI"
#' )
#' }
#' ))
#' df_wide %>%
#' mutate_at(vars(cipro:genta), as.sir,
#' mo = "bacteria",
#' ab = "antibiotic",
#' host = "animal_species",
#' guideline = "CLSI")
#' mo = "bacteria",
#' ab = "antibiotic",
#' host = "animal_species",
#' guideline = "CLSI"
#' )
#' df_wide %>%
#' mutate(across(cipro:genta,
#' function(x) as.sir(x,
#' mo = "bacteria",
#' host = "animal_species",
#' guideline = "CLSI")))
#' mutate(across(
#' cipro:genta,
#' function(x) {
#' as.sir(x,
#' mo = "bacteria",
#' host = "animal_species",
#' guideline = "CLSI"
#' )
#' }
#' ))
#'
#' # to include information about urinary tract infections (UTI)
#' data.frame(mo = "E. coli",
#' nitrofuratoin = c("<= 2", 32),
#' from_the_bladder = c(TRUE, FALSE)) %>%
#' data.frame(
#' mo = "E. coli",
#' nitrofuratoin = c("<= 2", 32),
#' from_the_bladder = c(TRUE, FALSE)
#' ) %>%
#' as.sir(uti = "from_the_bladder")
#'
#' data.frame(mo = "E. coli",
#' nitrofuratoin = c("<= 2", 32),
#' specimen = c("urine", "blood")) %>%
#' data.frame(
#' mo = "E. coli",
#' nitrofuratoin = c("<= 2", 32),
#' specimen = c("urine", "blood")
#' ) %>%
#' as.sir() # automatically determines urine isolates
#'
#' df_wide %>%
@ -326,16 +354,19 @@ as_sir_structure <- function(x,
method = NULL,
ref_tbl = NULL,
ref_breakpoints = NULL) {
out <- structure(factor(as.character(unlist(unname(x))),
levels = c("S", "SDD", "I", "R", "NI"),
ordered = TRUE),
guideline = guideline,
mo = mo,
ab = ab,
method = method,
ref_tbl = ref_tbl,
ref_breakpoints = ref_breakpoints,
class = c("sir", "ordered", "factor"))
out <- structure(
factor(as.character(unlist(unname(x))),
levels = c("S", "SDD", "I", "R", "NI"),
ordered = TRUE
),
guideline = guideline,
mo = mo,
ab = ab,
method = method,
ref_tbl = ref_tbl,
ref_breakpoints = ref_breakpoints,
class = c("sir", "ordered", "factor")
)
}
#' @rdname as.sir
@ -959,7 +990,7 @@ as_sir_method <- function(method_short,
if (!is.null(cur_column_dplyr) && is.data.frame(current_df)) {
# try to get current column, which will only be available when in across()
host <- tryCatch(cur_column_dplyr(),
error = function(e) host
error = function(e) host
)
}
}
@ -986,7 +1017,7 @@ as_sir_method <- function(method_short,
if (!is.null(cur_column_dplyr) && is.data.frame(current_df)) {
# try to get current column, which will only be available when in across()
ab <- tryCatch(cur_column_dplyr(),
error = function(e) ab
error = function(e) ab
)
}
}
@ -1107,20 +1138,26 @@ as_sir_method <- function(method_short,
same_ab <- generalise_antibiotic_name(ab) == generalise_antibiotic_name(agent_name)
same_ab.bak <- generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)
agent_formatted[same_ab.bak] <- paste0(agent_formatted[same_ab.bak], " (", ab[same_ab.bak], ")")
agent_formatted[!same_ab.bak & !same_ab] <- paste0(agent_formatted[!same_ab.bak & !same_ab],
" (", ifelse(ab.bak[!same_ab.bak & !same_ab] == ab[!same_ab.bak & !same_ab],
"",
paste0(ab[!same_ab.bak & !same_ab], ", ")),
agent_name[!same_ab.bak & !same_ab],
")")
agent_formatted[!same_ab.bak & !same_ab] <- paste0(
agent_formatted[!same_ab.bak & !same_ab],
" (", ifelse(ab.bak[!same_ab.bak & !same_ab] == ab[!same_ab.bak & !same_ab],
"",
paste0(ab[!same_ab.bak & !same_ab], ", ")
),
agent_name[!same_ab.bak & !same_ab],
")"
)
# this intro text will also be printed in the progress bar if the `progress` package is installed
intro_txt <- paste0("Interpreting ", method_long, ": ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
ifelse(length(unique(agent_formatted)) == 1, unique(agent_formatted), paste0(vector_and(agent_formatted, quotes = FALSE, sort = FALSE))),
mo_var_found,
ifelse(identical(reference_data, AMR::clinical_breakpoints),
paste0(", ", font_bold(guideline_coerced)),
""),
"... ")
intro_txt <- paste0(
"Interpreting ", method_long, ": ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
ifelse(length(unique(agent_formatted)) == 1, unique(agent_formatted), paste0(vector_and(agent_formatted, quotes = FALSE, sort = FALSE))),
mo_var_found,
ifelse(identical(reference_data, AMR::clinical_breakpoints),
paste0(", ", font_bold(guideline_coerced)),
""
),
"... "
)
# prepare used arguments ----
method <- method_short
@ -1163,7 +1200,7 @@ as_sir_method <- function(method_short,
df$values <- as.disk(df$values)
}
df_unique <- unique(df[ , c("mo", "ab", "uti", "host"), drop = FALSE])
df_unique <- unique(df[, c("mo", "ab", "uti", "host"), drop = FALSE])
# get all breakpoints, use humans as backup for animals
breakpoint_type_lookup <- breakpoint_type
@ -1203,9 +1240,12 @@ as_sir_method <- function(method_short,
# apparently no breakpoints found
message(
paste0(font_rose_bg(" WARNING "), "\n"),
font_black(paste0(" ", AMR_env$bullet_icon, " No ", guideline_coerced, " ", method_coerced, " breakpoints available for ",
suppressMessages(suppressWarnings(ab_name(unique(ab_coerced), language = NULL, tolower = TRUE))),
" (", unique(ab_coerced), ")."), collapse = "\n"))
font_black(paste0(
" ", AMR_env$bullet_icon, " No ", guideline_coerced, " ", method_coerced, " breakpoints available for ",
suppressMessages(suppressWarnings(ab_name(unique(ab_coerced), language = NULL, tolower = TRUE))),
" (", unique(ab_coerced), ")."
), collapse = "\n")
)
load_mo_uncertainties(metadata_mo)
return(rep(NA_sir_, nrow(df)))
@ -1331,20 +1371,17 @@ as_sir_method <- function(method_short,
# vancomycin can take human breakpoints in these hosts
breakpoints_current <- breakpoints_current %pm>% subset(host == "human")
notes_current <- c(notes_current, paste0("Using ", font_bold("human"), " breakpoints for ", ab_formatted, " based on CLSI VET09."))
} else if (host_current %in% c("dogs", "cats") && (mo_current_genus %in% c("B_AMYCS", "B_NOCRD", "B_CMPYL", "B_CRYNB", "B_ENTRC", "B_MYCBC", "B_PSDMN", "B_AERMN") | mo_current_class == "B_[CLS]_BTPRTBCT" | mo_current == "B_LISTR_MNCY")) {
# dog breakpoints if no canine/feline
# TODO do we still have dogs breakpoints at this point???
breakpoints_current <- breakpoints_current %pm>% subset(host == "human") # WRONG
notes_current <- c(notes_current, paste0("Using ", font_bold("human"), " breakpoints for ", mo_formatted, " based on CLSI VET09."))
} else {
# no specific CLSI solution for this, so only filter on current host (if no breakpoints available -> too bad)
breakpoints_current <- breakpoints_current %pm>%
subset(host == host_current)
}
}
}
if (NROW(breakpoints_current) == 0) {
@ -1382,8 +1419,10 @@ as_sir_method <- function(method_short,
# `uti` is a column in the data set
# this will put UTI = FALSE first, then UTI = NA, then UTI = TRUE
pm_mutate(uti_index = ifelse(!is.na(uti) & uti == FALSE, 1,
ifelse(is.na(uti), 2,
3))) %pm>%
ifelse(is.na(uti), 2,
3
)
)) %pm>%
# be as specific as possible (i.e. prefer species over genus):
pm_arrange(rank_index, uti_index)
} else if (uti_current == TRUE) {

1
R/sir_calc.R
View File

@ -254,7 +254,6 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
if (message_not_thrown_before("sir_calc_df", combine_SI, entire_session = TRUE)) {
message_("Note that `sir_calc_df()` will also count dose-dependent susceptibility, 'SDD', as 'SI' when `combine_SI = TRUE`. This note will be shown once for this session.", as_note = FALSE)
}
}
data[, i] <- gsub("(I|S|SDD)", "SI", data[, i, drop = TRUE])
}

9
R/top_n_microorganisms.R
View File

@ -42,15 +42,18 @@
#' @examples
#' # filter to the top 3 species:
#' top_n_microorganisms(example_isolates,
#' n = 3)
#' n = 3
#' )
#'
#' # filter to any species in the top 5 genera:
#' top_n_microorganisms(example_isolates,
#' n = 5, property = "genus")
#' n = 5, property = "genus"
#' )
#'
#' # filter to the top 3 species in each of the top 5 genera:
#' top_n_microorganisms(example_isolates,
#' n = 5, property = "genus", n_for_each = 3)
#' n = 5, property = "genus", n_for_each = 3
#' )
top_n_microorganisms <- function(x, n, property = "fullname", n_for_each = NULL, col_mo = NULL, ...) {
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
meet_criteria(n, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE, is_positive = TRUE)

12
R/vctrs.R
View File

@ -59,7 +59,7 @@ vec_cast.logical.amr_selector_any_all <- function(x, to, ...) {
}
# S3: ab ----
vec_ptype2.ab.default <- function (x, y, ..., x_arg = "", y_arg = "") {
vec_ptype2.ab.default <- function(x, y, ..., x_arg = "", y_arg = "") {
x
}
vec_ptype2.ab.ab <- function(x, y, ...) {
@ -73,7 +73,7 @@ vec_cast.ab.character <- function(x, to, ...) {
}
# S3: av ----
vec_ptype2.av.default <- function (x, y, ..., x_arg = "", y_arg = "") {
vec_ptype2.av.default <- function(x, y, ..., x_arg = "", y_arg = "") {
x
}
vec_ptype2.av.av <- function(x, y, ...) {
@ -87,7 +87,7 @@ vec_cast.av.character <- function(x, to, ...) {
}
# S3: mo ----
vec_ptype2.mo.default <- function (x, y, ..., x_arg = "", y_arg = "") {
vec_ptype2.mo.default <- function(x, y, ..., x_arg = "", y_arg = "") {
x
}
vec_ptype2.mo.mo <- function(x, y, ...) {
@ -108,7 +108,7 @@ vec_ptype_full.disk <- function(x, ...) {
vec_ptype_abbr.disk <- function(x, ...) {
"dsk"
}
vec_ptype2.disk.default <- function (x, y, ..., x_arg = "", y_arg = "") {
vec_ptype2.disk.default <- function(x, y, ..., x_arg = "", y_arg = "") {
NA_disk_[0]
}
vec_ptype2.disk.disk <- function(x, y, ...) {
@ -137,7 +137,7 @@ vec_cast.disk.character <- function(x, to, ...) {
}
# S3: mic ----
vec_ptype2.mic.default <- function (x, y, ..., x_arg = "", y_arg = "") {
vec_ptype2.mic.default <- function(x, y, ..., x_arg = "", y_arg = "") {
# this will make sure that currently implemented MIC levels are returned
NA_mic_[0]
}
@ -181,7 +181,7 @@ vec_arith.mic <- function(op, x, y, ...) {
}
# S3: sir ----
vec_ptype2.sir.default <- function (x, y, ..., x_arg = "", y_arg = "") {
vec_ptype2.sir.default <- function(x, y, ..., x_arg = "", y_arg = "") {
NA_sir_[0]
}
vec_ptype2.sir.sir <- function(x, y, ...) {

6
R/zzz.R
View File

@ -82,10 +82,10 @@ AMR_env$chmatch <- import_fn("chmatch", "data.table", error_on_fail = FALSE)
AMR_env$chin <- import_fn("%chin%", "data.table", error_on_fail = FALSE)
# take cli symbols and error function if available
AMR_env$bullet_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$bullet %or% "*"
AMR_env$bullet_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$bullet %or% "*"
AMR_env$ellipsis_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$ellipsis %or% "..."
AMR_env$info_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$info %or% "i"
AMR_env$sup_1_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$sup_1 %or% "*"
AMR_env$info_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$info %or% "i"
AMR_env$sup_1_icon <- import_fn("symbol", "cli", error_on_fail = FALSE)$sup_1 %or% "*"
AMR_env$cli_abort <- import_fn("cli_abort", "cli", error_on_fail = FALSE)

5
data-raw/_pre_commit_checks.R
View File

@ -627,12 +627,15 @@ suppressMessages(set_AMR_locale("English"))
usethis::ui_info("Checking URLs for redirects")
invisible(urlchecker::url_update("."))
# Style pkg ---------------------------------------------------------------
usethis::ui_info("Styling package")
styler::style_pkg(include_roxygen_examples = FALSE,
exclude_dirs = list.dirs(full.names = FALSE, recursive = FALSE)[!list.dirs(full.names = FALSE, recursive = FALSE) %in% c("R", "tests")])
# Document pkg ------------------------------------------------------------
usethis::ui_info("Documenting package")
suppressMessages(devtools::document(quiet = TRUE))
# Finished ----------------------------------------------------------------
usethis::ui_done("All done")
suppressMessages(reset_AMR_locale())

259
data-raw/gpt_training_text_v2.1.1.9160.txt → data-raw/gpt_training_text_v2.1.1.9163.txt
View File

@ -1,6 +1,6 @@
This knowledge base contains all context you must know about the AMR package for R. You are a GPT trained to be an assistant for the AMR package in R. You are an incredible R specialist, especially trained in this package and in the tidyverse.
First and foremost, you are trained on version 2.1.1.9160. Remember this whenever someone asks which AMR package version you’re at.
First and foremost, you are trained on version 2.1.1.9163. Remember this whenever someone asks which AMR package version you’re at.
Below are the contents of the file, the file, and all the files (documentation) in the package. Every file content is split using 100 hypens.
----------------------------------------------------------------------------------------------------
@ -1984,12 +1984,14 @@ antibiogram(example_isolates,
antibiogram(example_isolates,
antibiotics = aminoglycosides(),
ab_transform = "atc",
mo_transform = "gramstain")
mo_transform = "gramstain"
)
antibiogram(example_isolates,
antibiotics = carbapenems(),
ab_transform = "name",
mo_transform = "name")
mo_transform = "name"
)
# Combined antibiogram -------------------------------------------------
@ -1997,14 +1999,16 @@ antibiogram(example_isolates,
# combined antibiotics yield higher empiric coverage
antibiogram(example_isolates,
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
mo_transform = "gramstain")
mo_transform = "gramstain"
)
# names of antibiotics do not need to resemble columns exactly:
antibiogram(example_isolates,
antibiotics = c("Cipro", "cipro + genta"),
mo_transform = "gramstain",
ab_transform = "name",
sep = " & ")
sep = " & "
)
# Syndromic antibiogram ------------------------------------------------
@ -2012,7 +2016,8 @@ antibiogram(example_isolates,
# the data set could contain a filter for e.g. respiratory specimens
antibiogram(example_isolates,
antibiotics = c(aminoglycosides(), carbapenems()),
syndromic_group = "ward")
syndromic_group = "ward"
)
# now define a data set with only E. coli
ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
@ -2025,7 +2030,8 @@ antibiogram(ex1,
syndromic_group = ifelse(ex1$ward == "ICU",
"UCI", "No UCI"
),
language = "es")
language = "es"
)
# WISCA antibiogram ----------------------------------------------------
@ -2034,7 +2040,8 @@ antibiogram(ex1,
antibiogram(example_isolates,
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
syndromic_group = "ward",
wisca = TRUE)
wisca = TRUE
)
# Print the output for R Markdown / Quarto -----------------------------
@ -2042,7 +2049,8 @@ antibiogram(example_isolates,
ureido <- antibiogram(example_isolates,
antibiotics = ureidopenicillins(),
syndromic_group = "ward",
wisca = TRUE)
wisca = TRUE
)
# in an Rmd file, you would just need to return `ureido` in a chunk,
# but to be explicit here:
@ -2055,11 +2063,13 @@ if (requireNamespace("knitr")) {
ab1 <- antibiogram(example_isolates,
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
mo_transform = "gramstain")
mo_transform = "gramstain"
)
ab2 <- antibiogram(example_isolates,
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
mo_transform = "gramstain",
syndromic_group = "ward")
syndromic_group = "ward"
)
if (requireNamespace("ggplot2")) {
ggplot2::autoplot(ab1)
@ -2181,8 +2191,6 @@ THE PART HEREAFTER CONTAINS CONTENTS FROM FILE 'man/antimicrobial_selectors.Rd':
% Please edit documentation in R/amr_selectors.R
\name{antimicrobial_selectors}
\alias{antimicrobial_selectors}
\alias{amr_class}
\alias{amr_selector}
\alias{aminoglycosides}
\alias{aminopenicillins}
\alias{antifungals}
@ -2214,17 +2222,13 @@ THE PART HEREAFTER CONTAINS CONTENTS FROM FILE 'man/antimicrobial_selectors.Rd':
\alias{tetracyclines}
\alias{trimethoprims}
\alias{ureidopenicillins}
\alias{amr_class}
\alias{amr_selector}
\alias{administrable_per_os}
\alias{administrable_iv}
\alias{not_intrinsic_resistant}
\title{Antimicrobial Selectors}
\usage{
amr_class(amr_class, only_sir_columns = FALSE, only_treatable = TRUE,
return_all = TRUE, ...)
amr_selector(filter, only_sir_columns = FALSE, only_treatable = TRUE,
return_all = TRUE, ...)
aminoglycosides(only_sir_columns = FALSE, only_treatable = TRUE,
return_all = TRUE, ...)
@ -2293,6 +2297,12 @@ trimethoprims(only_sir_columns = FALSE, return_all = TRUE, ...)
ureidopenicillins(only_sir_columns = FALSE, return_all = TRUE, ...)
amr_class(amr_class, only_sir_columns = FALSE, only_treatable = TRUE,
return_all = TRUE, ...)
amr_selector(filter, only_sir_columns = FALSE, only_treatable = TRUE,
return_all = TRUE, ...)
administrable_per_os(only_sir_columns = FALSE, return_all = TRUE, ...)
administrable_iv(only_sir_columns = FALSE, return_all = TRUE, ...)
@ -2301,8 +2311,6 @@ not_intrinsic_resistant(only_sir_columns = FALSE, col_mo = NULL,
version_expertrules = 3.3, ...)
}
\arguments{
\item{amr_class}{an antimicrobial class or a part of it, such as \code{"carba"} and \code{"carbapenems"}. The columns \code{group}, \code{atc_group1} and \code{atc_group2} of the \link{antibiotics} data set will be searched (case-insensitive) for this value.}
\item{only_sir_columns}{a \link{logical} to indicate whether only columns of class \code{sir} must be selected (default is \code{FALSE}), see \code{\link[=as.sir]{as.sir()}}}
\item{only_treatable}{a \link{logical} to indicate whether antimicrobial drugs should be excluded that are only for laboratory tests (default is \code{TRUE}), such as gentamicin-high (\code{GEH}) and imipenem/EDTA (\code{IPE})}
@ -2311,6 +2319,8 @@ not_intrinsic_resistant(only_sir_columns = FALSE, col_mo = NULL,
\item{...}{ignored, only in place to allow future extensions}
\item{amr_class}{an antimicrobial class or a part of it, such as \code{"carba"} and \code{"carbapenems"}. The columns \code{group}, \code{atc_group1} and \code{atc_group2} of the \link{antibiotics} data set will be searched (case-insensitive) for this value.}
\item{filter}{an \link{expression} to be evaluated in the \link{antibiotics} data set, such as \code{name \%like\% "trim"}}
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}) - the default is the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
@ -2339,10 +2349,10 @@ All columns in the data in which these functions are called will be searched for
The \code{\link[=amr_class]{amr_class()}} function can be used to filter/select on a manually defined antimicrobial class. It searches for results in the \link{antibiotics} data set within the columns \code{group}, \code{atc_group1} and \code{atc_group2}.
The \code{\link[=amr_selector]{amr_selector()}} function can be used to internally filter the \link{antibiotics} data set on any results, see \emph{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.
The \code{\link[=administrable_per_os]{administrable_per_os()}} and \code{\link[=administrable_iv]{administrable_iv()}} functions also rely on the \link{antibiotics} data set - antimicrobials will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the \link{antibiotics} data set.
The \code{\link[=amr_selector]{amr_selector()}} function can be used to internally filter the \link{antibiotics} data set on any results, see \emph{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.
The \code{\link[=not_intrinsic_resistant]{not_intrinsic_resistant()}} function can be used to only select antimicrobials 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 \emph{E. coli} and \emph{K. pneumoniae} and contains a column "vancomycin", this column will be removed (or rather, unselected) using this function. It currently applies \href{https://www.eucast.org/expert_rules_and_expected_phenotypes}{'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes' v3.3} (2021) to determine intrinsic resistance, using the \code{\link[=eucast_rules]{eucast_rules()}} function internally. Because of this determination, this function is quite slow in terms of performance.
}
\section{Full list of supported (antimicrobial) classes}{
@ -3538,64 +3548,92 @@ if (require("dplyr")) {
df_long \%>\%
# given a certain data type, e.g. MIC values
mutate_if(is.mic, as.sir,
mo = "bacteria",
ab = "antibiotic",
guideline = "CLSI")
mo = "bacteria",
ab = "antibiotic",
guideline = "CLSI"
)
df_long \%>\%
mutate(across(where(is.mic),
function(x) as.sir(x,
mo = "bacteria",
ab = "antibiotic",
guideline = "CLSI")))
mutate(across(
where(is.mic),
function(x) {
as.sir(x,
mo = "bacteria",
ab = "antibiotic",
guideline = "CLSI"
)
}
))
df_wide \%>\%
# given certain columns, e.g. from 'cipro' to 'genta'
mutate_at(vars(cipro:genta), as.sir,
mo = "bacteria",
guideline = "CLSI")
mo = "bacteria",
guideline = "CLSI"
)
df_wide \%>\%
mutate(across(cipro:genta,
function(x) as.sir(x,
mo = "bacteria",
guideline = "CLSI")))
mutate(across(
cipro:genta,
function(x) {
as.sir(x,
mo = "bacteria",
guideline = "CLSI"
)
}
))
# for veterinary breakpoints, add 'host':
df_long$animal_species <- c("cats", "dogs", "horses", "cattle")
df_long \%>\%
# given a certain data type, e.g. MIC values
mutate_if(is.mic, as.sir,
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI")
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI"
)
df_long \%>\%
mutate(across(where(is.mic),
function(x) as.sir(x,
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI")))
mutate(across(
where(is.mic),
function(x) {
as.sir(x,
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI"
)
}
))
df_wide \%>\%
mutate_at(vars(cipro:genta), as.sir,
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI")
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI"
)
df_wide \%>\%
mutate(across(cipro:genta,
function(x) as.sir(x,
mo = "bacteria",
host = "animal_species",
guideline = "CLSI")))
mutate(across(
cipro:genta,
function(x) {
as.sir(x,
mo = "bacteria",
host = "animal_species",
guideline = "CLSI"
)
}
))
# to include information about urinary tract infections (UTI)
data.frame(mo = "E. coli",
nitrofuratoin = c("<= 2", 32),
from_the_bladder = c(TRUE, FALSE)) \%>\%
data.frame(
mo = "E. coli",
nitrofuratoin = c("<= 2", 32),
from_the_bladder = c(TRUE, FALSE)
) \%>\%
as.sir(uti = "from_the_bladder")
data.frame(mo = "E. coli",
nitrofuratoin = c("<= 2", 32),
specimen = c("urine", "blood")) \%>\%
data.frame(
mo = "E. coli",
nitrofuratoin = c("<= 2", 32),
specimen = c("urine", "blood")
) \%>\%
as.sir() # automatically determines urine isolates
df_wide \%>\%
@ -5624,8 +5662,10 @@ if (require("ggplot2") && require("dplyr")) {
) \%>\%
ggplot() +
geom_col(aes(x = x, y = y, fill = z)) +
scale_sir_colours(aesthetics = "fill",
Value4 = "S", Value5 = "I", Value6 = "R")
scale_sir_colours(
aesthetics = "fill",
Value4 = "S", Value5 = "I", Value6 = "R"
)
}
if (require("ggplot2") && require("dplyr")) {
# resistance of ciprofloxacine per age group
@ -7031,10 +7071,12 @@ mo_rank("Klebsiella pneumoniae")
mo_url("Klebsiella pneumoniae")
mo_is_yeast(c("Candida", "Trichophyton", "Klebsiella"))
mo_group_members(c("Streptococcus group A",
"Streptococcus group C",
"Streptococcus group G",
"Streptococcus group L"))
mo_group_members(c(
"Streptococcus group A",
"Streptococcus group C",
"Streptococcus group G",
"Streptococcus group L"
))
# scientific reference -----------------------------------------------------
@ -7547,7 +7589,6 @@ some_mic_values <- random_mic(size = 100)
some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
some_sir_values <- random_sir(50, prob_SIR = c(0.55, 0.05, 0.30))
\donttest{
# Plotting using ggplot2's autoplot() for MIC, disk, and SIR -----------
if (require("ggplot2")) {
@ -7559,17 +7600,23 @@ if (require("ggplot2")) {
}
if (require("ggplot2")) {
# support for 20 languages, various guidelines, and many options
autoplot(some_disk_values, mo = "Escherichia coli", ab = "cipro",
guideline = "CLSI 2024", language = "no",
title = "Disk diffusion from the North")
autoplot(some_disk_values,
mo = "Escherichia coli", ab = "cipro",
guideline = "CLSI 2024", language = "no",
title = "Disk diffusion from the North"
)
}
# Plotting using scale_x_mic() -----------------------------------------
if (require("ggplot2")) {
mic_plot <- ggplot(data.frame(mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
counts = c(1, 1, 2, 2, 3, 3)),
aes(mics, counts)) +
mic_plot <- ggplot(
data.frame(
mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
counts = c(1, 1, 2, 2, 3, 3)
),
aes(mics, counts)
) +
geom_col()
mic_plot +
labs(title = "without scale_x_mic()")
@ -7600,17 +7647,25 @@ if (require("ggplot2")) {
some_groups <- sample(LETTERS[1:5], 20, replace = TRUE)
if (require("ggplot2")) {
ggplot(data.frame(mic = some_mic_values,
group = some_groups),
aes(group, mic)) +
ggplot(
data.frame(
mic = some_mic_values,
group = some_groups
),
aes(group, mic)
) +
geom_boxplot() +
geom_violin(linetype = 2, colour = "grey", fill = NA) +
scale_y_mic()
}
if (require("ggplot2")) {
ggplot(data.frame(mic = some_mic_values,
group = some_groups),
aes(group, mic)) +
ggplot(
data.frame(
mic = some_mic_values,
group = some_groups
),
aes(group, mic)
) +
geom_boxplot() +
geom_violin(linetype = 2, colour = "grey", fill = NA) +
scale_y_mic(mic_range = c(NA, 0.25))
@ -7619,9 +7674,13 @@ if (require("ggplot2")) {
# Plotting using scale_x_sir() -----------------------------------------
if (require("ggplot2")) {
ggplot(data.frame(x = c("I", "R", "S"),
y = c(45,323, 573)),
aes(x, y)) +
ggplot(
data.frame(
x = c("I", "R", "S"),
y = c(45, 323, 573)
),
aes(x, y)
) +
geom_col() +
scale_x_sir()
}
@ -7629,12 +7688,17 @@ if (require("ggplot2")) {
# Plotting using scale_y_mic() and scale_colour_sir() ------------------
if (require("ggplot2")) {
plain <- ggplot(data.frame(mic = some_mic_values,
group = some_groups,
sir = as.sir(some_mic_values,
mo = "E. coli",
ab = "cipro")),
aes(x = group, y = mic, colour = sir)) +
plain <- ggplot(
data.frame(
mic = some_mic_values,
group = some_groups,
sir = as.sir(some_mic_values,
mo = "E. coli",
ab = "cipro"
)
),
aes(x = group, y = mic, colour = sir)
) +
theme_minimal() +
geom_boxplot(fill = NA, colour = "grey") +
geom_jitter(width = 0.25)
@ -7650,8 +7714,10 @@ if (require("ggplot2")) {
if (require("ggplot2")) {
plain +
scale_y_mic(mic_range = c(0.005, 32), name = "Our MICs!") +
scale_colour_sir(language = "pt",
name = "Support in 20 languages")
scale_colour_sir(
language = "pt",
name = "Support in 20 languages"
)
}
}
@ -8247,15 +8313,18 @@ This function is useful for preprocessing data before creating \link[=antibiogra
\examples{
# filter to the top 3 species:
top_n_microorganisms(example_isolates,
n = 3)
n = 3
)
# filter to any species in the top 5 genera:
top_n_microorganisms(example_isolates,
n = 5, property = "genus")
n = 5, property = "genus"
)
# filter to the top 3 species in each of the top 5 genera:
top_n_microorganisms(example_isolates,
n = 5, property = "genus", n_for_each = 3)
n = 5, property = "genus", n_for_each = 3
)
}
\seealso{
\code{\link[=mo_property]{mo_property()}}, \code{\link[=as.mo]{as.mo()}}, \code{\link[=antibiogram]{antibiogram()}}

30
man/antibiogram.Rd
View File

@ -343,12 +343,14 @@ antibiogram(example_isolates,
antibiogram(example_isolates,
antibiotics = aminoglycosides(),
ab_transform = "atc",
mo_transform = "gramstain")
mo_transform = "gramstain"
)
antibiogram(example_isolates,
antibiotics = carbapenems(),
ab_transform = "name",
mo_transform = "name")
mo_transform = "name"
)
# Combined antibiogram -------------------------------------------------
@ -356,14 +358,16 @@ antibiogram(example_isolates,
# combined antibiotics yield higher empiric coverage
antibiogram(example_isolates,
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
mo_transform = "gramstain")
mo_transform = "gramstain"
)
# names of antibiotics do not need to resemble columns exactly:
antibiogram(example_isolates,
antibiotics = c("Cipro", "cipro + genta"),
mo_transform = "gramstain",
ab_transform = "name",
sep = " & ")
sep = " & "
)
# Syndromic antibiogram ------------------------------------------------
@ -371,7 +375,8 @@ antibiogram(example_isolates,
# the data set could contain a filter for e.g. respiratory specimens
antibiogram(example_isolates,
antibiotics = c(aminoglycosides(), carbapenems()),
syndromic_group = "ward")
syndromic_group = "ward"
)
# now define a data set with only E. coli
ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
@ -384,7 +389,8 @@ antibiogram(ex1,
syndromic_group = ifelse(ex1$ward == "ICU",
"UCI", "No UCI"
),
language = "es")
language = "es"
)
# WISCA antibiogram ----------------------------------------------------
@ -393,7 +399,8 @@ antibiogram(ex1,
antibiogram(example_isolates,
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
syndromic_group = "ward",
wisca = TRUE)
wisca = TRUE
)
# Print the output for R Markdown / Quarto -----------------------------
@ -401,7 +408,8 @@ antibiogram(example_isolates,
ureido <- antibiogram(example_isolates,
antibiotics = ureidopenicillins(),
syndromic_group = "ward",
wisca = TRUE)
wisca = TRUE
)
# in an Rmd file, you would just need to return `ureido` in a chunk,
# but to be explicit here:
@ -414,11 +422,13 @@ if (requireNamespace("knitr")) {
ab1 <- antibiogram(example_isolates,
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
mo_transform = "gramstain")
mo_transform = "gramstain"
)
ab2 <- antibiogram(example_isolates,
antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
mo_transform = "gramstain",
syndromic_group = "ward")
syndromic_group = "ward"
)
if (requireNamespace("ggplot2")) {
ggplot2::autoplot(ab1)

24
man/antimicrobial_selectors.Rd
View File

@ -2,8 +2,6 @@
% Please edit documentation in R/amr_selectors.R
\name{antimicrobial_selectors}
\alias{antimicrobial_selectors}
\alias{amr_class}
\alias{amr_selector}
\alias{aminoglycosides}
\alias{aminopenicillins}
\alias{antifungals}
@ -35,17 +33,13 @@
\alias{tetracyclines}
\alias{trimethoprims}
\alias{ureidopenicillins}
\alias{amr_class}
\alias{amr_selector}
\alias{administrable_per_os}
\alias{administrable_iv}
\alias{not_intrinsic_resistant}
\title{Antimicrobial Selectors}
\usage{
amr_class(amr_class, only_sir_columns = FALSE, only_treatable = TRUE,
return_all = TRUE, ...)
amr_selector(filter, only_sir_columns = FALSE, only_treatable = TRUE,
return_all = TRUE, ...)
aminoglycosides(only_sir_columns = FALSE, only_treatable = TRUE,
return_all = TRUE, ...)
@ -114,6 +108,12 @@ trimethoprims(only_sir_columns = FALSE, return_all = TRUE, ...)
ureidopenicillins(only_sir_columns = FALSE, return_all = TRUE, ...)
amr_class(amr_class, only_sir_columns = FALSE, only_treatable = TRUE,
return_all = TRUE, ...)
amr_selector(filter, only_sir_columns = FALSE, only_treatable = TRUE,
return_all = TRUE, ...)
administrable_per_os(only_sir_columns = FALSE, return_all = TRUE, ...)
administrable_iv(only_sir_columns = FALSE, return_all = TRUE, ...)
@ -122,8 +122,6 @@ not_intrinsic_resistant(only_sir_columns = FALSE, col_mo = NULL,
version_expertrules = 3.3, ...)
}
\arguments{
\item{amr_class}{an antimicrobial class or a part of it, such as \code{"carba"} and \code{"carbapenems"}. The columns \code{group}, \code{atc_group1} and \code{atc_group2} of the \link{antibiotics} data set will be searched (case-insensitive) for this value.}
\item{only_sir_columns}{a \link{logical} to indicate whether only columns of class \code{sir} must be selected (default is \code{FALSE}), see \code{\link[=as.sir]{as.sir()}}}
\item{only_treatable}{a \link{logical} to indicate whether antimicrobial drugs should be excluded that are only for laboratory tests (default is \code{TRUE}), such as gentamicin-high (\code{GEH}) and imipenem/EDTA (\code{IPE})}
@ -132,6 +130,8 @@ not_intrinsic_resistant(only_sir_columns = FALSE, col_mo = NULL,
\item{...}{ignored, only in place to allow future extensions}
\item{amr_class}{an antimicrobial class or a part of it, such as \code{"carba"} and \code{"carbapenems"}. The columns \code{group}, \code{atc_group1} and \code{atc_group2} of the \link{antibiotics} data set will be searched (case-insensitive) for this value.}
\item{filter}{an \link{expression} to be evaluated in the \link{antibiotics} data set, such as \code{name \%like\% "trim"}}
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}) - the default is the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
@ -160,10 +160,10 @@ All columns in the data in which these functions are called will be searched for
The \code{\link[=amr_class]{amr_class()}} function can be used to filter/select on a manually defined antimicrobial class. It searches for results in the \link{antibiotics} data set within the columns \code{group}, \code{atc_group1} and \code{atc_group2}.
The \code{\link[=amr_selector]{amr_selector()}} function can be used to internally filter the \link{antibiotics} data set on any results, see \emph{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.
The \code{\link[=administrable_per_os]{administrable_per_os()}} and \code{\link[=administrable_iv]{administrable_iv()}} functions also rely on the \link{antibiotics} data set - antimicrobials will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the \link{antibiotics} data set.
The \code{\link[=amr_selector]{amr_selector()}} function can be used to internally filter the \link{antibiotics} data set on any results, see \emph{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.
The \code{\link[=not_intrinsic_resistant]{not_intrinsic_resistant()}} function can be used to only select antimicrobials 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 \emph{E. coli} and \emph{K. pneumoniae} and contains a column "vancomycin", this column will be removed (or rather, unselected) using this function. It currently applies \href{https://www.eucast.org/expert_rules_and_expected_phenotypes}{'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes' v3.3} (2021) to determine intrinsic resistance, using the \code{\link[=eucast_rules]{eucast_rules()}} function internally. Because of this determination, this function is quite slow in terms of performance.
}
\section{Full list of supported (antimicrobial) classes}{

106
man/as.sir.Rd
View File

@ -263,64 +263,92 @@ if (require("dplyr")) {
df_long \%>\%
# given a certain data type, e.g. MIC values
mutate_if(is.mic, as.sir,
mo = "bacteria",
ab = "antibiotic",
guideline = "CLSI")
mo = "bacteria",
ab = "antibiotic",
guideline = "CLSI"
)
df_long \%>\%
mutate(across(where(is.mic),
function(x) as.sir(x,
mo = "bacteria",
ab = "antibiotic",
guideline = "CLSI")))
mutate(across(
where(is.mic),
function(x) {
as.sir(x,
mo = "bacteria",
ab = "antibiotic",
guideline = "CLSI"
)
}
))
df_wide \%>\%
# given certain columns, e.g. from 'cipro' to 'genta'
mutate_at(vars(cipro:genta), as.sir,
mo = "bacteria",
guideline = "CLSI")
mo = "bacteria",
guideline = "CLSI"
)
df_wide \%>\%
mutate(across(cipro:genta,
function(x) as.sir(x,
mo = "bacteria",
guideline = "CLSI")))
mutate(across(
cipro:genta,
function(x) {
as.sir(x,
mo = "bacteria",
guideline = "CLSI"
)
}
))
# for veterinary breakpoints, add 'host':
df_long$animal_species <- c("cats", "dogs", "horses", "cattle")
df_long \%>\%
# given a certain data type, e.g. MIC values
mutate_if(is.mic, as.sir,
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI")
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI"
)
df_long \%>\%
mutate(across(where(is.mic),
function(x) as.sir(x,
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI")))
mutate(across(
where(is.mic),
function(x) {
as.sir(x,
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI"
)
}
))
df_wide \%>\%
mutate_at(vars(cipro:genta), as.sir,
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI")
mo = "bacteria",
ab = "antibiotic",
host = "animal_species",
guideline = "CLSI"
)
df_wide \%>\%
mutate(across(cipro:genta,
function(x) as.sir(x,
mo = "bacteria",
host = "animal_species",
guideline = "CLSI")))
mutate(across(
cipro:genta,
function(x) {
as.sir(x,
mo = "bacteria",
host = "animal_species",
guideline = "CLSI"
)
}
))
# to include information about urinary tract infections (UTI)
data.frame(mo = "E. coli",
nitrofuratoin = c("<= 2", 32),
from_the_bladder = c(TRUE, FALSE)) \%>\%
data.frame(
mo = "E. coli",
nitrofuratoin = c("<= 2", 32),
from_the_bladder = c(TRUE, FALSE)
) \%>\%
as.sir(uti = "from_the_bladder")
data.frame(mo = "E. coli",
nitrofuratoin = c("<= 2", 32),
specimen = c("urine", "blood")) \%>\%
data.frame(
mo = "E. coli",
nitrofuratoin = c("<= 2", 32),
specimen = c("urine", "blood")
) \%>\%
as.sir() # automatically determines urine isolates
df_wide \%>\%

6
man/ggplot_sir.Rd
View File

@ -139,8 +139,10 @@ if (require("ggplot2") && require("dplyr")) {
) \%>\%
ggplot() +
geom_col(aes(x = x, y = y, fill = z)) +
scale_sir_colours(aesthetics = "fill",
Value4 = "S", Value5 = "I", Value6 = "R")
scale_sir_colours(
aesthetics = "fill",
Value4 = "S", Value5 = "I", Value6 = "R"
)
}
if (require("ggplot2") && require("dplyr")) {
# resistance of ciprofloxacine per age group

10
man/mo_property.Rd
View File

@ -262,10 +262,12 @@ mo_rank("Klebsiella pneumoniae")
mo_url("Klebsiella pneumoniae")
mo_is_yeast(c("Candida", "Trichophyton", "Klebsiella"))
mo_group_members(c("Streptococcus group A",
"Streptococcus group C",
"Streptococcus group G",
"Streptococcus group L"))
mo_group_members(c(
"Streptococcus group A",
"Streptococcus group C",
"Streptococcus group G",
"Streptococcus group L"
))
# scientific reference -----------------------------------------------------

72
man/plot.Rd
View File

@ -201,7 +201,6 @@ some_mic_values <- random_mic(size = 100)
some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
some_sir_values <- random_sir(50, prob_SIR = c(0.55, 0.05, 0.30))
\donttest{
# Plotting using ggplot2's autoplot() for MIC, disk, and SIR -----------
if (require("ggplot2")) {
@ -213,17 +212,23 @@ if (require("ggplot2")) {
}
if (require("ggplot2")) {
# support for 20 languages, various guidelines, and many options
autoplot(some_disk_values, mo = "Escherichia coli", ab = "cipro",
guideline = "CLSI 2024", language = "no",
title = "Disk diffusion from the North")
autoplot(some_disk_values,
mo = "Escherichia coli", ab = "cipro",
guideline = "CLSI 2024", language = "no",
title = "Disk diffusion from the North"
)
}
# Plotting using scale_x_mic() -----------------------------------------
if (require("ggplot2")) {
mic_plot <- ggplot(data.frame(mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
counts = c(1, 1, 2, 2, 3, 3)),
aes(mics, counts)) +
mic_plot <- ggplot(
data.frame(
mics = as.mic(c(0.25, "<=4", 4, 8, 32, ">=32")),
counts = c(1, 1, 2, 2, 3, 3)
),
aes(mics, counts)
) +
geom_col()
mic_plot +
labs(title = "without scale_x_mic()")
@ -254,17 +259,25 @@ if (require("ggplot2")) {
some_groups <- sample(LETTERS[1:5], 20, replace = TRUE)
if (require("ggplot2")) {
ggplot(data.frame(mic = some_mic_values,
group = some_groups),
aes(group, mic)) +
ggplot(
data.frame(
mic = some_mic_values,
group = some_groups
),
aes(group, mic)
) +
geom_boxplot() +
geom_violin(linetype = 2, colour = "grey", fill = NA) +
scale_y_mic()
}
if (require("ggplot2")) {
ggplot(data.frame(mic = some_mic_values,
group = some_groups),
aes(group, mic)) +
ggplot(
data.frame(
mic = some_mic_values,
group = some_groups
),
aes(group, mic)
) +
geom_boxplot() +
geom_violin(linetype = 2, colour = "grey", fill = NA) +
scale_y_mic(mic_range = c(NA, 0.25))
@ -273,9 +286,13 @@ if (require("ggplot2")) {
# Plotting using scale_x_sir() -----------------------------------------
if (require("ggplot2")) {
ggplot(data.frame(x = c("I", "R", "S"),
y = c(45,323, 573)),
aes(x, y)) +
ggplot(
data.frame(
x = c("I", "R", "S"),
y = c(45, 323, 573)
),
aes(x, y)
) +
geom_col() +
scale_x_sir()
}
@ -283,12 +300,17 @@ if (require("ggplot2")) {
# Plotting using scale_y_mic() and scale_colour_sir() ------------------
if (require("ggplot2")) {
plain <- ggplot(data.frame(mic = some_mic_values,
group = some_groups,
sir = as.sir(some_mic_values,
mo = "E. coli",
ab = "cipro")),
aes(x = group, y = mic, colour = sir)) +
plain <- ggplot(
data.frame(
mic = some_mic_values,
group = some_groups,
sir = as.sir(some_mic_values,
mo = "E. coli",
ab = "cipro"
)
),
aes(x = group, y = mic, colour = sir)
) +
theme_minimal() +
geom_boxplot(fill = NA, colour = "grey") +
geom_jitter(width = 0.25)
@ -304,8 +326,10 @@ if (require("ggplot2")) {
if (require("ggplot2")) {
plain +
scale_y_mic(mic_range = c(0.005, 32), name = "Our MICs!") +
scale_colour_sir(language = "pt",
name = "Support in 20 languages")
scale_colour_sir(
language = "pt",
name = "Support in 20 languages"
)
}
}

9
man/top_n_microorganisms.Rd
View File

@ -29,15 +29,18 @@ This function is useful for preprocessing data before creating \link[=antibiogra
\examples{
# filter to the top 3 species:
top_n_microorganisms(example_isolates,
n = 3)
n = 3
)
# filter to any species in the top 5 genera:
top_n_microorganisms(example_isolates,
n = 5, property = "genus")
n = 5, property = "genus"
)
# filter to the top 3 species in each of the top 5 genera:
top_n_microorganisms(example_isolates,
n = 5, property = "genus", n_for_each = 3)
n = 5, property = "genus", n_for_each = 3
)
}
\seealso{
\code{\link[=mo_property]{mo_property()}}, \code{\link[=as.mo]{as.mo()}}, \code{\link[=antibiogram]{antibiogram()}}

7
tests/testthat.R
View File

@ -33,8 +33,11 @@ library(AMR)
# add functions from the tinytest package (which we use for older R versions)
expect_inherits <- function(x, y, ...) {
expect(inherits(x, y),
failure_message = paste0("object has class ", paste0(class(x), collapse = "/"),
", required is class ", paste0(y, collapse = "/")))
failure_message = paste0(
"object has class ", paste0(class(x), collapse = "/"),
", required is class ", paste0(y, collapse = "/")
)
)
}
expect_stdout <- expect_output

22
tests/testthat/test-ab.R
View File

@ -80,15 +80,19 @@ expect_equal(
# based on Levenshtein distance
expect_identical(ab_name("ceftazidim/avibactam", language = NULL), "Ceftazidime/avibactam")
expect_identical(as.character(as.ab(c("gentamicine High Level",
"gentamicine High",
"gentamicine (High Level)",
"gentamicine (High)",
"gentamicine HL",
"gentamicine H-L",
"gentamicine (HL)",
"gentamicine (H-L)"))),
rep("GEH", 8))
expect_identical(
as.character(as.ab(c(
"gentamicine High Level",
"gentamicine High",
"gentamicine (High Level)",
"gentamicine (High)",
"gentamicine HL",
"gentamicine H-L",
"gentamicine (HL)",
"gentamicine (H-L)"
))),
rep("GEH", 8)
)
# assigning and subsetting
x <- antibiotics$ab

1
tests/testthat/test-ab_property.R
View File

@ -96,4 +96,3 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
set_ab_names(NIT:VAN) %>%
colnames())))
}

15
tests/testthat/test-age.R
View File

@ -35,13 +35,14 @@ expect_equal(
c(39, 34, 29)
)
expect_equal(age(
x = c("2019-01-01", "2019-04-01", "2019-07-01"),
reference = "2019-09-01",
exact = TRUE
),
c(0.6656393, 0.4191781, 0.1698630),
tolerance = 0.001
expect_equal(
age(
x = c("2019-01-01", "2019-04-01", "2019-07-01"),
reference = "2019-09-01",
exact = TRUE
),
c(0.6656393, 0.4191781, 0.1698630),
tolerance = 0.001
)
expect_error(age(

63
tests/testthat/test-antibiogram.R
View File

@ -31,19 +31,22 @@
# Traditional antibiogram ----------------------------------------------
ab1 <- antibiogram(example_isolates,
antibiotics = c(aminoglycosides(), carbapenems()))
antibiotics = c(aminoglycosides(), carbapenems())
)
ab2 <- antibiogram(example_isolates,
antibiotics = aminoglycosides(),
ab_transform = "atc",
mo_transform = "gramstain",
add_total_n = TRUE)
antibiotics = aminoglycosides(),
ab_transform = "atc",
mo_transform = "gramstain",
add_total_n = TRUE
)
ab3 <- antibiogram(example_isolates,
antibiotics = carbapenems(),
ab_transform = "ab",
mo_transform = "name",
formatting_type = 1)
antibiotics = carbapenems(),
ab_transform = "ab",
mo_transform = "name",
formatting_type = 1
)
expect_inherits(ab1, "antibiogram")
expect_inherits(ab2, "antibiogram")
@ -57,15 +60,17 @@ expect_equal(ab3$MEM, c(52, NA, 100, 100, NA))
# combined antibiotics yield higher empiric coverage
ab4 <- antibiogram(example_isolates,
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
mo_transform = "gramstain")
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
mo_transform = "gramstain"
)
ab5 <- antibiogram(example_isolates,
antibiotics = c("TZP", "TZP+TOB"),
mo_transform = "gramstain",
ab_transform = "name",
sep = " & ",
add_total_n = FALSE)
antibiotics = c("TZP", "TZP+TOB"),
mo_transform = "gramstain",
ab_transform = "name",
sep = " & ",
add_total_n = FALSE
)
expect_inherits(ab4, "antibiogram")
expect_inherits(ab5, "antibiogram")
@ -76,20 +81,23 @@ expect_equal(colnames(ab5), c("Pathogen", "Piperacillin/tazobactam", "Piperacill
# the data set could contain a filter for e.g. respiratory specimens
ab6 <- antibiogram(example_isolates,
antibiotics = c(aminoglycosides(), carbapenems()),
syndromic_group = "ward",
ab_transform = NULL)
antibiotics = c(aminoglycosides(), carbapenems()),
syndromic_group = "ward",
ab_transform = NULL
)
# with a custom language, though this will be determined automatically
# (i.e., this table will be in Dutch on Dutch systems)
ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
ab7 <- antibiogram(ex1,
antibiotics = aminoglycosides(),
ab_transform = "name",
syndromic_group = ifelse(ex1$ward == "ICU",
"IC", "Geen IC"),
language = "nl",
add_total_n = TRUE)
antibiotics = aminoglycosides(),
ab_transform = "name",
syndromic_group = ifelse(ex1$ward == "ICU",
"IC", "Geen IC"
),
language = "nl",
add_total_n = TRUE
)
expect_inherits(ab6, "antibiogram")
expect_inherits(ab7, "antibiogram")
@ -100,8 +108,9 @@ expect_equal(colnames(ab7), c("Syndroomgroep", "Pathogeen (N min-max)", "Amikaci
# the data set could contain a filter for e.g. respiratory specimens
ab8 <- suppressWarnings(antibiogram(example_isolates,
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
wisca = TRUE))
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
wisca = TRUE
))
expect_inherits(ab8, "antibiogram")
expect_equal(colnames(ab8), c("Piperacillin/tazobactam", "Piperacillin/tazobactam + Gentamicin", "Piperacillin/tazobactam + Tobramycin"))

2
tests/testthat/test-av_property.R
View File

@ -34,7 +34,7 @@ expect_identical(av_cid("ACI"), as.integer(135398513))
expect_inherits(av_tradenames("ACI"), "character")
expect_inherits(av_tradenames(c("ACI", "ACI")), "list")
expect_identical(av_group("ACI", language = NULL),"Nucleosides and nucleotides excl. reverse transcriptase inhibitors")
expect_identical(av_group("ACI", language = NULL), "Nucleosides and nucleotides excl. reverse transcriptase inhibitors")
expect_identical(av_name(135398513, language = NULL), "Aciclovir")
expect_identical(av_name("J05AB01", language = NULL), "Aciclovir")

8
tests/testthat/test-custom_antimicrobials.R
View File

@ -33,9 +33,11 @@ expect_message(as.ab("testab", info = TRUE))
suppressMessages(
add_custom_antimicrobials(
data.frame(ab = "TESTAB",
name = "Test Antibiotic",
group = "Test Group")
data.frame(
ab = "TESTAB",
name = "Test Antibiotic",
group = "Test Group"
)
)
)

26
tests/testthat/test-custom_microorganisms.R
View File

@ -27,14 +27,18 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
expect_identical(as.mo("Enterobacter asburiae/cloacae"),
as.mo("Enterobacter asburiae"))
expect_identical(
as.mo("Enterobacter asburiae/cloacae"),
as.mo("Enterobacter asburiae")
)
suppressMessages(
add_custom_microorganisms(
data.frame(mo = "ENT_ASB_CLO",
genus = "Enterobacter",
species = "asburiae/cloacae")
data.frame(
mo = "ENT_ASB_CLO",
genus = "Enterobacter",
species = "asburiae/cloacae"
)
)
)
@ -44,8 +48,12 @@ expect_identical(mo_gramstain("ENT_ASB_CLO", language = NULL), "Gram-negative")
if (getRversion() >= "3.3.0") {
# until R 3.2, abbreviate() used a completely different algorithm, making these tests unreproducible
expect_identical(paste("B", AMR:::abbreviate_mo("Klebsiella"), AMR:::abbreviate_mo("pneumoniae", 4), sep = "_"),
as.character(as.mo("Klebsiella pneumoniae")))
expect_identical(paste("B", AMR:::abbreviate_mo("Aerococcus"), AMR:::abbreviate_mo("urinae", 4), sep = "_"),
as.character(as.mo("Aerococcus urinae")))
expect_identical(
paste("B", AMR:::abbreviate_mo("Klebsiella"), AMR:::abbreviate_mo("pneumoniae", 4), sep = "_"),
as.character(as.mo("Klebsiella pneumoniae"))
)
expect_identical(
paste("B", AMR:::abbreviate_mo("Aerococcus"), AMR:::abbreviate_mo("urinae", 4), sep = "_"),
as.character(as.mo("Aerococcus urinae"))
)
}

75
tests/testthat/test-eucast_rules.R
View File

@ -117,15 +117,16 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
}
# azithromycin and clarythromycin must be equal to Erythromycin
a <- suppressWarnings(as.sir(eucast_rules(data.frame(
mo = example_isolates$mo,
ERY = example_isolates$ERY,
AZM = as.sir("R"),
CLR = factor("R"),
stringsAsFactors = FALSE
),
version_expertrules = 3.1,
only_sir_columns = FALSE
a <- suppressWarnings(as.sir(eucast_rules(
data.frame(
mo = example_isolates$mo,
ERY = example_isolates$ERY,
AZM = as.sir("R"),
CLR = factor("R"),
stringsAsFactors = FALSE
),
version_expertrules = 3.1,
only_sir_columns = FALSE
)$CLR))
b <- example_isolates$ERY
expect_identical(
@ -160,34 +161,37 @@ expect_stdout(suppressWarnings(eucast_rules(example_isolates, verbose = TRUE, ru
# AmpC de-repressed cephalo mutants
expect_identical(
eucast_rules(data.frame(
mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.sir(c("S", "S"))
),
ampc_cephalosporin_resistance = TRUE,
info = FALSE
eucast_rules(
data.frame(
mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.sir(c("S", "S"))
),
ampc_cephalosporin_resistance = TRUE,
info = FALSE
)$cefotax,
as.sir(c("S", "R"))
)
expect_identical(
eucast_rules(data.frame(
mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.sir(c("S", "S"))
),
ampc_cephalosporin_resistance = NA,
info = FALSE
eucast_rules(
data.frame(
mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.sir(c("S", "S"))
),
ampc_cephalosporin_resistance = NA,
info = FALSE
)$cefotax,
as.sir(c("S", NA))
)
expect_identical(
eucast_rules(data.frame(
mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.sir(c("S", "S"))
),
ampc_cephalosporin_resistance = NULL,
info = FALSE
eucast_rules(
data.frame(
mo = c("Escherichia coli", "Enterobacter cloacae"),
cefotax = as.sir(c("S", "S"))
),
ampc_cephalosporin_resistance = NULL,
info = FALSE
)$cefotax,
as.sir(c("S", "S"))
)
@ -208,12 +212,13 @@ expect_stdout(print(c(x, x)))
expect_stdout(print(as.list(x, x)))
# this custom rules makes 8 changes
expect_equal(nrow(eucast_rules(example_isolates,
rules = "custom",
custom_rules = x,
info = FALSE,
verbose = TRUE
)),
8,
tolerance = 0.5
expect_equal(
nrow(eucast_rules(example_isolates,
rules = "custom",
custom_rules = x,
info = FALSE,
verbose = TRUE
)),
8,
tolerance = 0.5
)

37
tests/testthat/test-first_isolate.R
View File

@ -46,17 +46,28 @@ expect_equal(
)
# for phenotype determination
expect_equal(AMR:::duplicated_antibiogram("SSSS", points_threshold = 2, ignore_I = TRUE, type = "points"),
FALSE)
expect_equal(AMR:::duplicated_antibiogram(c("RRR", "SSS"),
points_threshold = 2, ignore_I = TRUE, type = "points"),
c(FALSE, FALSE))
expect_equal(AMR:::duplicated_antibiogram(c("RRR", "RRR", "SSS"),
points_threshold = 2, ignore_I = TRUE, type = "points"),
c(FALSE, TRUE, FALSE))
expect_equal(AMR:::duplicated_antibiogram(c("RRR", "RSS", "SSS", "RSS", "RRR", "RRR", "SSS", "RSS", "RSR", "RRR"),
points_threshold = 2, ignore_I = TRUE, type = "points"),
c(FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE))
expect_equal(
AMR:::duplicated_antibiogram("SSSS", points_threshold = 2, ignore_I = TRUE, type = "points"),
FALSE
)
expect_equal(
AMR:::duplicated_antibiogram(c("RRR", "SSS"),
points_threshold = 2, ignore_I = TRUE, type = "points"
),
c(FALSE, FALSE)
)
expect_equal(
AMR:::duplicated_antibiogram(c("RRR", "RRR", "SSS"),
points_threshold = 2, ignore_I = TRUE, type = "points"
),
c(FALSE, TRUE, FALSE)
)
expect_equal(
AMR:::duplicated_antibiogram(c("RRR", "RSS", "SSS", "RSS", "RRR", "RRR", "SSS", "RSS", "RSR", "RRR"),
points_threshold = 2, ignore_I = TRUE, type = "points"
),
c(FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE)
)
# Phenotype-based, using key antimicrobials
expect_equal(
@ -89,7 +100,9 @@ expect_true(
col_icu = example_isolates$ward == "ICU",
info = TRUE,
icu_exclude = TRUE
), na.rm = TRUE) < 950
),
na.rm = TRUE
) < 950
)
# set 1500 random observations to be of specimen type 'Urine'

22
tests/testthat/test-ggplot_sir.R
View File

@ -28,7 +28,7 @@
# ==================================================================== #
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE) &&
AMR:::pkg_is_available("ggplot2", also_load = TRUE)) {
AMR:::pkg_is_available("ggplot2", also_load = TRUE)) {
pdf(NULL) # prevent Rplots.pdf being created
# data should be equal
@ -44,14 +44,18 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE) &&
as.double()
)
expect_inherits(example_isolates %>%
select(AMC, CIP) %>%
ggplot_sir(x = "interpretation", facet = "antibiotic"),
"gg")
expect_inherits(example_isolates %>%
select(AMC, CIP) %>%
ggplot_sir(x = "antibiotic", facet = "interpretation"),
"gg")
expect_inherits(
example_isolates %>%
select(AMC, CIP) %>%
ggplot_sir(x = "interpretation", facet = "antibiotic"),
"gg"
)
expect_inherits(
example_isolates %>%
select(AMC, CIP) %>%
ggplot_sir(x = "antibiotic", facet = "interpretation"),
"gg"
)
expect_equal(
(example_isolates %>%

54
tests/testthat/test-mdro.R
View File

@ -55,36 +55,38 @@ expect_equal(
# test Dutch P. aeruginosa MDRO
expect_equal(
as.character(mdro(data.frame(
mo = as.mo("P. aeruginosa"),
cfta = "S",
cipr = "S",
mero = "S",
imip = "S",
gent = "S",
tobr = "S",
pita = "S"
),
guideline = "BRMO",
col_mo = "mo",
info = FALSE
as.character(mdro(
data.frame(
mo = as.mo("P. aeruginosa"),
cfta = "S",
cipr = "S",
mero = "S",
imip = "S",
gent = "S",
tobr = "S",
pita = "S"
),
guideline = "BRMO",
col_mo = "mo",
info = FALSE
)),
"Negative"
)
expect_equal(
as.character(mdro(data.frame(
mo = as.mo("P. aeruginosa"),
cefta = "R",
cipr = "R",
mero = "R",
imip = "R",
gent = "R",
tobr = "R",
pita = "R"
),
guideline = "BRMO",
col_mo = "mo",
info = FALSE
as.character(mdro(
data.frame(
mo = as.mo("P. aeruginosa"),
cefta = "R",
cipr = "R",
mero = "R",
imip = "R",
gent = "R",
tobr = "R",
pita = "R"
),
guideline = "BRMO",
col_mo = "mo",
info = FALSE
)),
"Positive"
)

1
tests/testthat/test-mic.R
View File

@ -176,4 +176,3 @@ expect_true(as.mic("32") <= as.mic(32))
expect_false(as.mic("32") <= as.mic("<32"))
expect_true(as.mic("32") <= as.mic("<=32"))
expect_false(as.mic("32") < as.mic("<=32"))

30
tests/testthat/test-mo_property.R
View File

@ -78,8 +78,10 @@ current_grampos_classes <- c(
"Thermoleophilia",
"Thermolithobacteria"
)
expect_identical(sort(unique(microorganisms[which(microorganisms$phylum %in% current_grampos_phyla), "class", drop = TRUE])),
current_grampos_classes)
expect_identical(
sort(unique(microorganisms[which(microorganisms$phylum %in% current_grampos_phyla), "class", drop = TRUE])),
current_grampos_classes
)
expect_equal(mo_species("Escherichia coli"), "coli")
expect_equal(mo_subspecies("Escherichia coli"), "")
@ -103,11 +105,15 @@ expect_inherits(mo_info(c("Escherichia coli", "Staphylococcus aureus")), "list")
expect_true(length(mo_group_members("B_HACEK")) > 1)
expect_inherits(mo_group_members(c("Candida albicans", "Escherichia coli")), "list")
expect_identical(mo_oxygen_tolerance(c("Klebsiella pneumoniae", "Clostridioides difficile")),
c("facultative anaerobe", "anaerobe"))
expect_identical(
mo_oxygen_tolerance(c("Klebsiella pneumoniae", "Clostridioides difficile")),
c("facultative anaerobe", "anaerobe")
)
expect_equal(as.character(table(mo_pathogenicity(example_isolates$mo))),
c("1911", "72", "1", "16"))
expect_equal(
as.character(table(mo_pathogenicity(example_isolates$mo))),
c("1911", "72", "1", "16")
)
expect_equal(mo_ref("Escherichia coli"), "Castellani et al., 1919")
expect_equal(mo_authors("Escherichia coli"), "Castellani et al.")
@ -118,8 +124,10 @@ expect_true(mo_url("Candida albicans") %like% "mycobank.org")
expect_true(mo_url("Escherichia coli") %like% "lpsn.dsmz.de")
# test integrity of getting back full names
expect_identical(microorganisms$fullname[microorganisms$fullname %unlike% "(Fungi|{)"],
suppressWarnings(mo_fullname(microorganisms$fullname[microorganisms$fullname %unlike% "(Fungi|{)"], language = "en", keep_synonyms = TRUE)))
expect_identical(
microorganisms$fullname[microorganisms$fullname %unlike% "(Fungi|{)"],
suppressWarnings(mo_fullname(microorganisms$fullname[microorganisms$fullname %unlike% "(Fungi|{)"], language = "en", keep_synonyms = TRUE))
)
# check languages
expect_equal(mo_type("Escherichia coli", language = "de"), "Bakterien")
@ -169,8 +177,10 @@ expect_identical(
expect_true("Escherichia blattae" %in% mo_synonyms("Shimwellia blattae"))
expect_true(is.list(mo_synonyms(rep("Shimwellia blattae", 2))))
expect_identical(mo_current(c("Escherichia blattae", "Escherichia coli")),
c("Shimwellia blattae", "Escherichia coli"))
expect_identical(
mo_current(c("Escherichia blattae", "Escherichia coli")),
c("Shimwellia blattae", "Escherichia coli")
)
expect_identical(mo_ref("Chlamydia psittaci"), "Garcia-Lopez et al., 2019")
expect_identical(mo_ref("Chlamydophila psittaci", keep_synonyms = TRUE), "Everett et al., 1999")

40
tests/testthat/test-pca.R
View File

@ -27,25 +27,27 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
resistance_data <- structure(list(
order = c("Bacillales", "Enterobacterales", "Enterobacterales"),
genus = c("Staphylococcus", "Escherichia", "Klebsiella"),
AMC = c(0.00425, 0.13062, 0.10344),
CXM = c(0.00425, 0.05376, 0.10344),
CTX = c(0.00000, 0.02396, 0.05172),
TOB = c(0.02325, 0.02597, 0.10344),
TMP = c(0.08387, 0.39141, 0.18367)
),
class = c("grouped_df", "tbl_df", "tbl", "data.frame"),
row.names = c(NA, -3L),
groups = structure(list(
order = c("Bacillales", "Enterobacterales"),
.rows = list(1L, 2:3)
),
row.names = c(NA, -2L),
class = c("tbl_df", "tbl", "data.frame"),
.drop = TRUE
)
resistance_data <- structure(
list(
order = c("Bacillales", "Enterobacterales", "Enterobacterales"),
genus = c("Staphylococcus", "Escherichia", "Klebsiella"),
AMC = c(0.00425, 0.13062, 0.10344),
CXM = c(0.00425, 0.05376, 0.10344),
CTX = c(0.00000, 0.02396, 0.05172),
TOB = c(0.02325, 0.02597, 0.10344),
TMP = c(0.08387, 0.39141, 0.18367)
),
class = c("grouped_df", "tbl_df", "tbl", "data.frame"),
row.names = c(NA, -3L),
groups = structure(
list(
order = c("Bacillales", "Enterobacterales"),
.rows = list(1L, 2:3)
),
row.names = c(NA, -2L),
class = c("tbl_df", "tbl", "data.frame"),
.drop = TRUE
)
)
pca_model <- pca(resistance_data)
expect_inherits(pca_model, "pca")

85
tests/testthat/test-plotting.R
View File

@ -38,7 +38,8 @@ if (AMR:::pkg_is_available("ggplot2", also_load = TRUE)) {
scale_obj <- getExportedValue("ggplot2", scale_fn_name)()
for (method in expected_methods) {
expect_true(is.function(scale_obj[[method]]) || method %in% names(scale_obj),
info = paste0("Method '", method, "' is missing in ggplot2::", scale_fn_name))
info = paste0("Method '", method, "' is missing in ggplot2::", scale_fn_name)
)
}
}
@ -50,38 +51,64 @@ if (AMR:::pkg_is_available("ggplot2", also_load = TRUE)) {
scale_obj <- getExportedValue("ggplot2", scale_fn_name)(aesthetics = aest)
for (method in expected_methods) {
expect_true(is.function(scale_obj[[method]]) || method %in% names(scale_obj),
info = paste0("Method '", method, "' is missing in ggplot2::", scale_fn_name))
info = paste0("Method '", method, "' is missing in ggplot2::", scale_fn_name)
)
}
}
for (method in expected_methods) {
expect_true(is.function(ggplot2::scale_x_discrete()[[method]]) || method %in% names(ggplot2::scale_x_discrete()),
info = paste0("Method '", method, "' is missing in ggplot2::", "scale_x_discrete"))
info = paste0("Method '", method, "' is missing in ggplot2::", "scale_x_discrete")
)
}
expect_inherits(ggplot(data.frame(count = c(1,2,3, 4),
sir = c("S", "I", "R", "SDD")),
aes(x = sir, y = count, fill = sir)) +
geom_col() +
scale_x_sir(eucast_I = F, language = "el") +
scale_fill_sir(eucast_I = T, language = "nl"),
"gg")
expect_inherits(ggplot(data.frame(mic = as.mic(c(2,4,8, 16)),
sir = as.sir(c("S", "I", "R", "SDD"))),
aes(x = sir, y = mic)) +
geom_point() +
scale_y_mic(),
"gg")
expect_inherits(ggplot(data.frame(mic = as.mic(c(2,4,8, 16)),
sir = as.sir(c("S", "I", "R", "SDD"))),
aes(x = sir, y = mic)) +
geom_col() +
scale_y_mic(),
"gg")
expect_inherits(ggplot(data.frame(mic = as.mic(c(2,4,8, 16)),
sir = as.sir(c("S", "I", "R", "SDD"))),
aes(x = sir, y = mic)) +
geom_col() +
scale_y_mic(mic_range = c(4,16)) +
scale_x_sir(),
"gg")
expect_inherits(
ggplot(
data.frame(
count = c(1, 2, 3, 4),
sir = c("S", "I", "R", "SDD")
),
aes(x = sir, y = count, fill = sir)
) +
geom_col() +
scale_x_sir(eucast_I = F, language = "el") +
scale_fill_sir(eucast_I = T, language = "nl"),
"gg"
)
expect_inherits(
ggplot(
data.frame(
mic = as.mic(c(2, 4, 8, 16)),
sir = as.sir(c("S", "I", "R", "SDD"))
),
aes(x = sir, y = mic)
) +
geom_point() +
scale_y_mic(),
"gg"
)
expect_inherits(
ggplot(
data.frame(
mic = as.mic(c(2, 4, 8, 16)),
sir = as.sir(c("S", "I", "R", "SDD"))
),
aes(x = sir, y = mic)
) +
geom_col() +
scale_y_mic(),
"gg"
)
expect_inherits(
ggplot(
data.frame(
mic = as.mic(c(2, 4, 8, 16)),
sir = as.sir(c("S", "I", "R", "SDD"))
),
aes(x = sir, y = mic)
) +
geom_col() +
scale_y_mic(mic_range = c(4, 16)) +
scale_x_sir(),
"gg"
)
}

169
tests/testthat/test-sir.R
View File

@ -90,16 +90,16 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
expect_stdout(print(tibble(ab = as.sir("S"))))
expect_true(example_isolates %>%
select(AMC, MEM) %>%
mutate(MEM = as.sir(ifelse(AMC == "S", "S", MEM))) %>%
pull(MEM) %>%
is.sir())
select(AMC, MEM) %>%
mutate(MEM = as.sir(ifelse(AMC == "S", "S", MEM))) %>%
pull(MEM) %>%
is.sir())
expect_true(example_isolates %>%
select(AMC, MEM) %>%
mutate(MEM = if_else(AMC == "S", "S", MEM)) %>%
pull(MEM) %>%
is.sir())
select(AMC, MEM) %>%
mutate(MEM = if_else(AMC == "S", "S", MEM)) %>%
pull(MEM) %>%
is.sir())
}
if (AMR:::pkg_is_available("skimr", min_version = "2.0.0", also_load = TRUE)) {
expect_inherits(
@ -124,29 +124,45 @@ expect_equal(as.sir(c("", "-", NA, "NULL")), c(NA_sir_, NA_sir_, NA_sir_, NA_sir
# Human -------------------------------------------------------------------
mics <- as.mic(2 ^ c(-4:6)) # 0.0625 to 64 in factors of 2
expect_identical(as.character(as.sir(mics, mo = "Enterobacterales", ab = "AMC", guideline = "EUCAST 2022",
uti = FALSE, include_PKPD = FALSE)),
c("S", "S", "S", "S", "S", "S", "S", "S", "R", "R", "R"))
expect_identical(as.character(as.sir(mics, mo = "Enterobacterales", ab = "AMC", guideline = "EUCAST 2022",
uti = TRUE, include_PKPD = FALSE)),
c("S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "R"))
expect_identical(as.character(as.sir(mics, mo = "Escherichia coli", ab = "AMC", guideline = "EUCAST 2022",
uti = FALSE, include_PKPD = FALSE)),
c("S", "S", "S", "S", "S", "S", "S", "S", "R", "R", "R"))
mics <- as.mic(2^c(-4:6)) # 0.0625 to 64 in factors of 2
expect_identical(
as.character(as.sir(mics,
mo = "Enterobacterales", ab = "AMC", guideline = "EUCAST 2022",
uti = FALSE, include_PKPD = FALSE
)),
c("S", "S", "S", "S", "S", "S", "S", "S", "R", "R", "R")
)
expect_identical(
as.character(as.sir(mics,
mo = "Enterobacterales", ab = "AMC", guideline = "EUCAST 2022",
uti = TRUE, include_PKPD = FALSE
)),
c("S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "R")
)
expect_identical(
as.character(as.sir(mics,
mo = "Escherichia coli", ab = "AMC", guideline = "EUCAST 2022",
uti = FALSE, include_PKPD = FALSE
)),
c("S", "S", "S", "S", "S", "S", "S", "S", "R", "R", "R")
)
# test SIR using dplyr's mutate_if(...) and mutate(across(...))
out1 <- as.sir(as.mic(c(0.256, 0.5, 1, 2)), mo = "Escherichia coli", ab = "ertapenem", guideline = "EUCAST 2023")
expect_identical(out1, as.sir(c("S", "S", "R", "R")))
if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
out2 <- data.frame(mo = "Escherichia coli",
ab = "ertapenem",
some_mics = as.mic(c(0.256, 0.5, 1, 2))) %>%
out2 <- data.frame(
mo = "Escherichia coli",
ab = "ertapenem",
some_mics = as.mic(c(0.256, 0.5, 1, 2))
) %>%
mutate(across(where(is.mic), function(x) as.sir(x, mo = "mo", ab = "ab", guideline = "EUCAST 2023"))) %>%
pull(some_mics)
out3 <- data.frame(mo = "Escherichia coli",
ab = "ertapenem",
some_mics = as.mic(c(0.256, 0.5, 1, 2))) %>%
out3 <- data.frame(
mo = "Escherichia coli",
ab = "ertapenem",
some_mics = as.mic(c(0.256, 0.5, 1, 2))
) %>%
mutate_if(is.mic, as.sir, mo = "mo", ab = "ab", guideline = "EUCAST 2023") %>%
pull(some_mics)
@ -155,27 +171,31 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
}
# S. pneumoniae/ampicillin in EUCAST 2020: 0.5-2 ug/ml (R is only > 2)
expect_equal(suppressMessages(
as.character(
as.sir(
x = as.mic(c(0.125, 0.5, 1, 2, 4)),
mo = "B_STRPT_PNMN",
ab = "AMP",
guideline = "EUCAST 2020"
expect_equal(
suppressMessages(
as.character(
as.sir(
x = as.mic(c(0.125, 0.5, 1, 2, 4)),
mo = "B_STRPT_PNMN",
ab = "AMP",
guideline = "EUCAST 2020"
)
)
)),
),
c("S", "S", "I", "I", "R")
)
# S. pneumoniae/amoxicillin in CLSI 2019: 2-8 ug/ml (R is 8 and > 8)
expect_equal(suppressMessages(
as.character(
as.sir(
x = as.mic(c(1, 2, 4, 8, 16)),
mo = "B_STRPT_PNMN",
ab = "AMX",
guideline = "CLSI 2019"
expect_equal(
suppressMessages(
as.character(
as.sir(
x = as.mic(c(1, 2, 4, 8, 16)),
mo = "B_STRPT_PNMN",
ab = "AMX",
guideline = "CLSI 2019"
)
)
)),
),
c("S", "S", "I", "R", "R")
)
@ -247,14 +267,22 @@ if (AMR:::pkg_is_available("dplyr", min_version = "1.0.0", also_load = TRUE)) {
group_by(mo) %>%
attributes() %>%
.$groups
expect_equal(nrow(groups),
90)
expect_equal(class(groups$.rows),
c("vctrs_list_of", "vctrs_vctr", "list"))
expect_equal(groups$.rows[[1]],
c(101, 524, 1368))
expect_equal(example_isolates[c(101, 524, 1368), "mo", drop = TRUE],
rep(groups$mo[1], 3))
expect_equal(
nrow(groups),
90
)
expect_equal(
class(groups$.rows),
c("vctrs_list_of", "vctrs_vctr", "list")
)
expect_equal(
groups$.rows[[1]],
c(101, 524, 1368)
)
expect_equal(
example_isolates[c(101, 524, 1368), "mo", drop = TRUE],
rep(groups$mo[1], 3)
)
}
# frequency tables
if (AMR:::pkg_is_available("cleaner")) {
@ -295,27 +323,35 @@ expect_message(as.sir(data.frame(
)))
# SDD vs I in CLSI 2024
expect_identical(as.sir(as.mic(2 ^ c(-2:4)), mo = "Enterococcus faecium", ab = "Dapto", guideline = "CLSI 2024"),
as.sir(c("SDD", "SDD", "SDD", "SDD", "SDD", "R", "R")))
expect_identical(as.sir(as.mic(2 ^ c(-2:2)), mo = "Enterococcus faecium", ab = "Cipro
expect_identical(
as.sir(as.mic(2^c(-2:4)), mo = "Enterococcus faecium", ab = "Dapto", guideline = "CLSI 2024"),
as.sir(c("SDD", "SDD", "SDD", "SDD", "SDD", "R", "R"))
)
expect_identical(
as.sir(as.mic(2^c(-2:2)), mo = "Enterococcus faecium", ab = "Cipro
", guideline = "CLSI 2024"),
as.sir(c("S", "S", "S", "I", "R")))
as.sir(c("S", "S", "S", "I", "R"))
)
# Veterinary --------------------------------------------------------------
sir_history <- sir_interpretation_history(clean = TRUE)
mics <- as.mic(2 ^ c(-4:6)) # 0.0625 to 64 in factors of 2
vet <- data.frame(animal = c(rep("cat", 3), rep("dogs", 3), "canine", "equine", "horse", "cattle", "bird"),
PRA = mics,
FLR = mics,
mo = mo_name(rep(c("B_ESCHR_COLI", "B_PSTRL_MLTC", "B_MNNHM_HMLY"), 4)[-1]))
mics <- as.mic(2^c(-4:6)) # 0.0625 to 64 in factors of 2
vet <- data.frame(
animal = c(rep("cat", 3), rep("dogs", 3), "canine", "equine", "horse", "cattle", "bird"),
PRA = mics,
FLR = mics,
mo = mo_name(rep(c("B_ESCHR_COLI", "B_PSTRL_MLTC", "B_MNNHM_HMLY"), 4)[-1])
)
out_vet <- as.sir(vet, host = vet$animal, guideline = "CLSI 2023")
# host column name instead of values
expect_identical(out_vet,
as.sir(vet, host = "animal", guideline = "CLSI 2023"))
expect_identical(
out_vet,
as.sir(vet, host = "animal", guideline = "CLSI 2023")
)
# check outcomes
expect_identical(out_vet$PRA, as.sir(c("S", NA, "S", NA, NA, "R", NA, NA, NA, "I", NA)))
@ -326,11 +362,15 @@ expect_identical(out_vet$PRA, rep(NA_sir_, 11))
expect_identical(out_vet$FLR, as.sir(c("S", "S", NA, "S", "S", NA, "I", "R", NA, "R", "R")))
sir_history <- sir_interpretation_history()
expect_identical(sort(sir_history$host),
c("cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats",
"cats", "cats", "cats", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "dogs",
"dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs",
"horse", "horse", "horse", "horse", "horse", "horse", "horse", "horse", "horse", "poultry","poultry","poultry","poultry"))
expect_identical(
sort(sir_history$host),
c(
"cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats", "cats",
"cats", "cats", "cats", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "dogs",
"dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs",
"horse", "horse", "horse", "horse", "horse", "horse", "horse", "horse", "horse", "poultry", "poultry", "poultry", "poultry"
)
)
# ECOFF -------------------------------------------------------------------
@ -340,4 +380,3 @@ expect_equal(
)
# old method
expect_warning(as.sir(as.mic(2), "E. coli", "ampicillin", guideline = "EUCAST 2020", ecoff = TRUE))

18
tests/testthat/test-vctrs.R
View File

@ -29,11 +29,13 @@
# extra tests for {vctrs} pkg support
if (AMR:::pkg_is_available("tibble")) {
test <- tibble::tibble(ab = as.ab("CIP"),
mo = as.mo("Escherichia coli"),
mic = as.mic(2),
disk = as.disk(20),
sir = as.sir("S"))
test <- tibble::tibble(
ab = as.ab("CIP"),
mo = as.mo("Escherichia coli"),
mic = as.mic(2),
disk = as.disk(20),
sir = as.sir("S")
)
check1 <- lapply(test, class)
test[1, "ab"] <- "GEN"
test[1, "mo"] <- "B_KLBSL_PNMN"
@ -46,8 +48,10 @@ if (AMR:::pkg_is_available("tibble")) {
check2 <- lapply(test, class)
expect_identical(check1, check2)
test <- tibble::tibble(cipro = as.sir("S"),
variable = "test")
test <- tibble::tibble(
cipro = as.sir("S"),
variable = "test"
)
expect_equal(nrow(test[quinolones() == "S", ]), 1)
expect_equal(nrow(test[quinolones() == "R", ]), 0)
}

10
tests/testthat/test-zzz.R
View File

@ -146,14 +146,16 @@ for (i in seq_len(length(import_functions))) {
fn <- names(import_functions)[i]
pkg <- unname(import_functions[i])
expect_true(pkg %in% suggests,
info = paste0("package `", pkg, "` is not in Suggests"))
info = paste0("package `", pkg, "` is not in Suggests")
)
# function should exist in foreign pkg namespace
if (AMR:::pkg_is_available(pkg,
also_load = FALSE,
min_version = if (pkg == "dplyr") "1.0.0" else NULL
also_load = FALSE,
min_version = if (pkg == "dplyr") "1.0.0" else NULL
)) {
expect_true(!is.null(AMR:::import_fn(name = fn, pkg = pkg, error_on_fail = FALSE)),
info = paste0("Function does not exist (anymore): function `", pkg, "::", fn, "()`"))
info = paste0("Function does not exist (anymore): function `", pkg, "::", fn, "()`")
)
} else if (pkg != "rstudioapi") {
warning("Package '", pkg, "' not available")
}