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

use dplyr where available, new antibiogram() for WISCA, fixed Salmonella Typhi/Paratyphi

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2023-02-06 11:57:22 +01:00
parent 4b133d4c96
commit 9e99e66f01
69 changed files with 1670 additions and 650 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
R/aa_helper_pm_functions.R
View File

@ -519,7 +519,7 @@ pm_join_message <- function(by) {
}
}
pm_lag <- function(x, pm_n = 1L, default = NA) {
if (inherits(x, "ts")) stop("`x` must be a vector, not a `ts` object, do you want `stats::pm_lag()`?")
if (inherits(x, "ts")) stop("`x` must be a vector, not a `ts` object, do you want `stats::lag()`?")
if (length(pm_n) != 1L || !is.numeric(pm_n) || pm_n < 0L) stop("`pm_n` must be a nonnegative integer scalar")
if (pm_n == 0L) {
return(x)

289
R/aa_helper_functions.R → R/aaa_helper_functions.R
View File

@ -63,99 +63,6 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
merged
}
# support where() like tidyverse:
# adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
where <- function(fn) {
if (!is.function(fn)) {
stop(pm_deparse_var(fn), " is not a valid predicate function.")
}
preds <- unlist(lapply(
pm_select_env$.data,
function(x, fn) {
do.call("fn", list(x))
},
fn
))
if (!is.logical(preds)) stop("`where()` must be used with functions that return `TRUE` or `FALSE`.")
data_cols <- pm_select_env$get_colnames()
cols <- data_cols[preds]
which(data_cols %in% cols)
}
# copied and slightly rewritten from poorman under same license (2021-10-15)
quick_case_when <- function(...) {
fs <- list(...)
lapply(fs, function(x) {
if (!inherits(x, "formula")) {
stop("`case_when()` requires formula inputs.")
}
})
n <- length(fs)
if (n == 0L) {
stop("No cases provided.")
}
validate_case_when_length <- function(query, value, fs) {
lhs_lengths <- lengths(query)
rhs_lengths <- lengths(value)
all_lengths <- unique(c(lhs_lengths, rhs_lengths))
if (length(all_lengths) <= 1L) {
return(all_lengths[[1L]])
}
non_atomic_lengths <- all_lengths[all_lengths != 1L]
len <- non_atomic_lengths[[1L]]
if (length(non_atomic_lengths) == 1L) {
return(len)
}
inconsistent_lengths <- non_atomic_lengths[-1L]
lhs_problems <- lhs_lengths %in% inconsistent_lengths
rhs_problems <- rhs_lengths %in% inconsistent_lengths
problems <- lhs_problems | rhs_problems
if (any(problems)) {
stop("The following formulas must be length ", len, " or 1, not ",
paste(inconsistent_lengths, collapse = ", "), ".\n ",
paste(fs[problems], collapse = "\n "),
call. = FALSE
)
}
}
replace_with <- function(x, i, val, arg_name) {
if (is.null(val)) {
return(x)
}
i[is.na(i)] <- FALSE
if (length(val) == 1L) {
x[i] <- val
} else {
x[i] <- val[i]
}
x
}
query <- vector("list", n)
value <- vector("list", n)
default_env <- parent.frame()
for (i in seq_len(n)) {
query[[i]] <- eval(fs[[i]][[2]], envir = default_env)
value[[i]] <- eval(fs[[i]][[3]], envir = default_env)
if (!is.logical(query[[i]])) {
stop(fs[[i]][[2]], " does not return a `logical` vector.")
}
}
m <- validate_case_when_length(query, value, fs)
out <- value[[1]][rep(NA_integer_, m)]
replaced <- rep(FALSE, m)
for (i in seq_len(n)) {
out <- replace_with(
out, query[[i]] & !replaced, value[[i]],
NULL
)
replaced <- replaced | (query[[i]] & !is.na(query[[i]]))
}
out
}
# No export, no Rd
addin_insert_in <- function() {
import_fn("insertText", "rstudioapi")(" %in% ")
@ -386,7 +293,7 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
getExportedValue(name = name, ns = asNamespace(pkg)),
error = function(e) {
if (isTRUE(error_on_fail)) {
stop_("function ", name, "() is not an exported object from package '", pkg,
stop_("function `", name, "()` is not an exported object from package '", pkg,
"'. Please create an issue at ", font_url("https://github.com/msberends/AMR/issues"), ". Many thanks!",
call = FALSE
)
@ -1272,7 +1179,7 @@ create_pillar_column <- function(x, ...) {
new_pillar_shaft_simple(x, ...)
}
as_original_data_class <- function(df, old_class = NULL) {
as_original_data_class <- function(df, old_class = NULL, extra_class = NULL) {
if ("tbl_df" %in% old_class && pkg_is_available("tibble", also_load = FALSE)) {
# this will then also remove groups
fn <- import_fn("as_tibble", "tibble")
@ -1285,7 +1192,11 @@ as_original_data_class <- function(df, old_class = NULL) {
} else {
fn <- function(x) base::as.data.frame(df, stringsAsFactors = FALSE)
}
fn(df)
out <- fn(df)
if (!is.null(extra_class)) {
class(out) <- c(extra_class, class(out))
}
out
}
# works exactly like round(), but rounds `round2(44.55, 1)` to 44.6 instead of 44.5
@ -1425,7 +1336,7 @@ add_MO_lookup_to_AMR_env <- function() {
}
trimws2 <- function(..., whitespace = "[\u0009\u000A\u000B\u000C\u000D\u0020\u0085\u00A0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u200C\u200D\u2028\u2029\u202F\u205F\u2060\u3000\uFEFF]") {
# this is even faster than trimws() itself which sets " \t\n\r".
# this is even faster than trimws() itself which sets "[ \t\r\n]".
trimws(..., whitespace = whitespace)
}
@ -1436,12 +1347,192 @@ readRDS2 <- function(file, refhook = NULL) {
readRDS(con, refhook = refhook)
}
# dplyr implementations ----
# copied from https://github.com/nathaneastwood/poorman under same license (2021-10-15)
case_when <- function(...) {
fs <- list(...)
lapply(fs, function(x) {
if (!inherits(x, "formula")) {
stop("`case_when()` requires formula inputs.")
}
})
n <- length(fs)
if (n == 0L) {
stop("No cases provided.")
}
validate_case_when_length <- function(query, value, fs) {
lhs_lengths <- lengths(query)
rhs_lengths <- lengths(value)
all_lengths <- unique(c(lhs_lengths, rhs_lengths))
if (length(all_lengths) <= 1L) {
return(all_lengths[[1L]])
}
non_atomic_lengths <- all_lengths[all_lengths != 1L]
len <- non_atomic_lengths[[1L]]
if (length(non_atomic_lengths) == 1L) {
return(len)
}
inconsistent_lengths <- non_atomic_lengths[-1L]
lhs_problems <- lhs_lengths %in% inconsistent_lengths
rhs_problems <- rhs_lengths %in% inconsistent_lengths
problems <- lhs_problems | rhs_problems
if (any(problems)) {
stop("The following formulas must be length ", len, " or 1, not ",
paste(inconsistent_lengths, collapse = ", "), ".\n ",
paste(fs[problems], collapse = "\n "),
call. = FALSE
)
}
}
replace_with <- function(x, i, val, arg_name) {
if (is.null(val)) {
return(x)
}
i[is.na(i)] <- FALSE
if (length(val) == 1L) {
x[i] <- val
} else {
x[i] <- val[i]
}
x
}
query <- vector("list", n)
value <- vector("list", n)
default_env <- parent.frame()
for (i in seq_len(n)) {
query[[i]] <- eval(fs[[i]][[2]], envir = default_env)
value[[i]] <- eval(fs[[i]][[3]], envir = default_env)
if (!is.logical(query[[i]])) {
stop(fs[[i]][[2]], " does not return a `logical` vector.")
}
}
m <- validate_case_when_length(query, value, fs)
out <- value[[1]][rep(NA_integer_, m)]
replaced <- rep(FALSE, m)
for (i in seq_len(n)) {
out <- replace_with(
out, query[[i]] & !replaced, value[[i]],
NULL
)
replaced <- replaced | (query[[i]] & !is.na(query[[i]]))
}
out
}
# adapted from https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
where <- function(fn) {
if (!is.function(fn)) {
stop_("`", deparse(substitute(fn)), "()` is not a valid predicate function.")
}
df <- pm_select_env$.data
cols <- pm_select_env$get_colnames()
if (is.null(df)) {
df <- get_current_data("where", call = FALSE)
cols <- colnames(df)
}
preds <- unlist(lapply(
df,
function(x, fn) {
do.call("fn", list(x))
},
fn
))
if (!is.logical(preds)) stop_("`where()` must be used with functions that return `TRUE` or `FALSE`.")
data_cols <- cols
cols <- data_cols[preds]
which(data_cols %in% cols)
}
# dplyr implementations ----
# take {dplyr} functions if available, and the slower {poorman} functions otherwise
if (pkg_is_available("dplyr", also_load = FALSE)) {
`%>%` <- import_fn("%>%", "dplyr", error_on_fail = FALSE)
anti_join <- import_fn("anti_join", "dplyr", error_on_fail = FALSE)
arrange <- import_fn("arrange", "dplyr", error_on_fail = FALSE)
count <- import_fn("count", "dplyr", error_on_fail = FALSE)
desc <- import_fn("desc", "dplyr", error_on_fail = FALSE)
distinct <- import_fn("distinct", "dplyr", error_on_fail = FALSE)
everything <- import_fn("everything", "dplyr", error_on_fail = FALSE)
filter <- import_fn("filter", "dplyr", error_on_fail = FALSE)
full_join <- import_fn("full_join", "dplyr", error_on_fail = FALSE)
group_by <- import_fn("group_by", "dplyr", error_on_fail = FALSE)
group_vars <- import_fn("group_vars", "dplyr", error_on_fail = FALSE)
inner_join <- import_fn("inner_join", "dplyr", error_on_fail = FALSE)
lag <- import_fn("lag", "dplyr", error_on_fail = FALSE)
left_join <- import_fn("left_join", "dplyr", error_on_fail = FALSE)
n_distinct <- import_fn("n_distinct", "dplyr", error_on_fail = FALSE)
pull <- import_fn("pull", "dplyr", error_on_fail = FALSE)
rename <- import_fn("rename", "dplyr", error_on_fail = FALSE)
right_join <- import_fn("right_join", "dplyr", error_on_fail = FALSE)
row_number <- import_fn("row_number", "dplyr", error_on_fail = FALSE)
select <- import_fn("select", "dplyr", error_on_fail = FALSE)
semi_join <- import_fn("semi_join", "dplyr", error_on_fail = FALSE)
summarise <- import_fn("summarise", "dplyr", error_on_fail = FALSE)
ungroup <- import_fn("ungroup", "dplyr", error_on_fail = FALSE)
mutate <- import_fn("mutate", "dplyr", error_on_fail = FALSE)
bind_rows <- import_fn("bind_rows", "dplyr", error_on_fail = FALSE)
} else {
`%>%` <- `%pm>%`
anti_join <- pm_anti_join
arrange <- pm_arrange
count <- pm_count
desc <- pm_desc
distinct <- pm_distinct
everything <- pm_everything
filter <- pm_filter
full_join <- pm_full_join
group_by <- pm_group_by
group_vars <- pm_group_vars
inner_join <- pm_inner_join
lag <- pm_lag
left_join <- pm_left_join
n_distinct <- pm_n_distinct
pull <- pm_pull
rename <- pm_rename
right_join <- pm_right_join
row_number <- pm_row_number
select <- pm_select
semi_join <- pm_semi_join
summarise <- pm_summarise
ungroup <- pm_ungroup
mutate <- function(.data, ...) {
# pm_mutate is buggy, use this simple alternative
dots <- list(...)
for (i in seq_len(length(dots))) {
.data[, names(dots)[i]] <- dots[[i]]
}
.data
}
bind_rows <- function(..., fill = NA) {
# this AMAZING code is from ChatGPT when I asked for a base R dplyr::bind_rows alternative
dfs <- list(...)
all_cols <- unique(unlist(lapply(dfs, colnames)))
mat_list <- lapply(dfs, function(x) {
mat <- matrix(NA, nrow = nrow(x), ncol = length(all_cols))
colnames(mat) <- all_cols
mat[, colnames(x)] <- as.matrix(x)
mat
})
mat <- do.call(rbind, mat_list)
as.data.frame(mat, stringsAsFactors = FALSE)
}
}
# Faster data.table implementations ----
match <- function(x, table, ...) {
chmatch <- import_fn("chmatch", "data.table", error_on_fail = FALSE)
if (!is.null(chmatch) && is.character(x) && is.character(table)) {
# data.table::chmatch() is 35% faster than base::match() for character
# data.table::chmatch() is much faster than base::match() for character
chmatch(x, table, ...)
} else {
base::match(x, table, ...)
@ -1450,7 +1541,7 @@ match <- function(x, table, ...) {
`%in%` <- function(x, table) {
chin <- import_fn("%chin%", "data.table", error_on_fail = FALSE)
if (!is.null(chin) && is.character(x) && is.character(table)) {
# data.table::`%chin%`() is 20-50% faster than base::`%in%`() for character
# data.table::`%chin%`() is much faster than base::`%in%`() for character
chin(x, table)
} else {
base::`%in%`(x, table)

6
R/ab_property.R
View File

@ -338,7 +338,7 @@ ab_url <- function(x, open = FALSE, ...) {
ab_property <- function(x, property = "name", language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, is_in = colnames(AMR::antibiotics), has_length = 1)
meet_criteria(language, is_in = c(LANGUAGES_SUPPORTED, ""), has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(ab_validate(x = x, property = property, ...), language = language)
}
@ -367,7 +367,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
if (!is.null(out)) {
df <- data[, out, drop = FALSE]
} else {
df <- pm_select(data, ...)
df <- select(data, ...)
}
} else {
df <- data
@ -438,7 +438,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
ab_validate <- function(x, property, ...) {
if (tryCatch(all(x[!is.na(x)] %in% AMR_env$AB_lookup$ab), error = function(e) FALSE)) {
# special case for ab_* functions where class is already 'ab'
# # special case for ab_* functions where class is already 'ab'
x <- AMR_env$AB_lookup[match(x, AMR_env$AB_lookup$ab), property, drop = TRUE]
} else {
# try to catch an error when inputting an invalid argument

14
R/ab_selectors.R
View File

@ -785,14 +785,14 @@ is_all <- function(el1) {
find_ab_group <- function(ab_class_args) {
ab_class_args <- gsub("[^a-zA-Z0-9]", ".*", ab_class_args)
AMR_env$AB_lookup %pm>%
subset(group %like% ab_class_args |
AMR_env$AB_lookup %>%
filter(group %like% ab_class_args |
atc_group1 %like% ab_class_args |
atc_group2 %like% ab_class_args) %pm>%
pm_pull(group) %pm>%
unique() %pm>%
tolower() %pm>%
sort() %pm>%
atc_group2 %like% ab_class_args) %>%
pull(group) %>%
unique() %>%
tolower() %>%
sort() %>%
paste(collapse = "/")
}

512
R/antibiogram.R Executable file
View File

@ -0,0 +1,512 @@
# ==================================================================== #
# TITLE #
# AMR: An R Package for Working with Antimicrobial Resistance Data #
# #
# SOURCE #
# https://github.com/msberends/AMR #
# #
# CITE AS #
# Berends MS, Luz CF, Friedrich AW, Sinha BNM, Albers CJ, Glasner C #
# (2022). AMR: An R Package for Working with Antimicrobial Resistance #
# Data. Journal of Statistical Software, 104(3), 1-31. #
# doi:10.18637/jss.v104.i03 #
# #
# Developed at the University of Groningen and the University Medical #
# Center Groningen in The Netherlands, in collaboration with many #
# colleagues from around the world, see our website. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# We created this package for both routine data analysis and academic #
# research and it was publicly released in the hope that it will be #
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
# #
# Visit our website for the full manual and a complete tutorial about #
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Generate Antibiogram: Traditional, Combined, Syndromic, or Weighted-Incidence Syndromic Combination (WISCA)
#'
#' Generate an antibiogram, and communicate the results in plots or tables. These functions follow the logic of Klinker *et al.* (2021, \doi{10.1177/20499361211011373}) and Barbieri *et al.* (2021, \doi{10.1186/s13756-021-00939-2}), and allow reporting in e.g. R Markdown and Quarto as well.
#' @param x a [data.frame] containing at least a column with microorganisms and columns with antibiotic results (class 'sir', see [as.sir()])
#' @param antibiotics vector of column names, or (any combinations of) [antibiotic selectors][antibiotic_class_selectors] such as [aminoglycosides()] or [carbapenems()]. For combination antibiograms, this can also be column names separated with `"+"`, such as "TZP+TOB" given that the data set contains columns "TZP" and "TOB". See *Examples*.
#' @param mo_transform a character to transform microorganism input - must be "name", "shortname", "gramstain", or one of the column names of the [microorganisms] data set: `r vector_or(colnames(microorganisms), sort = FALSE, quotes = TRUE)`. Can also be `NULL` to not transform the input.
#' @param ab_transform a character to transform antibiotic input - must be one of the column names of the [antibiotics] data set: `r vector_or(colnames(antibiotics), sort = FALSE, quotes = TRUE)`. Can also be `NULL` to not transform the input.
#' @param syndromic_group a column name of `x`, or values calculated to split rows of `x`, e.g. by using [ifelse()] or [`case_when()`][dplyr::case_when()]. See *Examples*.
#' @param add_total_n a [logical] to indicate whether total available numbers per pathogen should be added to the table (defaults to `TRUE`). This will add the lowest and highest number of available isolate per antibiotic (e.g, if for *E. coli* 200 isolates are available for ciprofloxacin and 150 for amoxicillin, the returned number will be "150-200").
#' @param only_all_tested (for combination antibiograms): a [logical] to indicate that isolates must be tested for all antibiotics, see *Details*
#' @param digits number of digits to use for rounding
#' @param col_mo column name of the names or codes of the microorganisms (see [as.mo()]), defaults to the first column of class [`mo`]. Values will be coerced using [as.mo()].
#' @param language language to translate text, which defaults to the system language (see [get_AMR_locale()])
#' @param minimum the minimum allowed number of available (tested) isolates. Any isolate count lower than `minimum` will return `NA` with a warning. The default number of `30` isolates is advised by the Clinical and Laboratory Standards Institute (CLSI) as best practice, see *Source*.
#' @param combine_SI a [logical] to indicate whether all susceptibility should be determined by results of either S or I, instead of only S (defaults to `TRUE`)
#' @param sep a separating character for antibiotic columns in combination antibiograms
#' @details This function returns a table with values between 0 and 100 for *susceptibility*, not resistance.
#'
#' **Remember that you should filter your data to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them in your data set with one of the four available algorithms.
#'
#' There are four antibiogram types, as proposed by Klinker *et al.* (2021, \doi{10.1177/20499361211011373}), and they are all supported by [antibiogram()]:
#'
#' 1. **Traditional Antibiogram**
#'
#' Case example: Susceptibility of *Pseudomonas aeruginosa* to piperacillin/tazobactam (TZP)
#'
#' Code example:
#'
#' ```r
#' antibiogram(your_data,
#' antibiotics = "TZP")
#' ```
#'
#' 2. **Combination Antibiogram**
#'
#' Case example: Additional susceptibility of *Pseudomonas aeruginosa* to TZP + tobramycin versus TZP alone
#'
#' Code example:
#'
#' ```r
#' antibiogram(your_data,
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
#' ```
#'
#' 3. **Syndromic Antibiogram**
#'
#' Case example: Susceptibility of *Pseudomonas aeruginosa* to TZP among respiratory specimens (obtained among ICU patients only)
#'
#' Code example:
#'
#' ```r
#' antibiogram(your_data,
#' antibiotics = penicillins(),
#' syndromic_group = "ward")
#' ```
#'
#' 4. **Weighted-Incidence Syndromic Combination Antibiogram (WISCA)**
#'
#' Case example: Susceptibility of *Pseudomonas aeruginosa* to TZP among respiratory specimens (obtained among ICU patients only) for male patients age >=65 years with heart failure
#'
#' Code example:
#'
#' ```r
#' antibiogram(your_data,
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
#' syndromic_group = ifelse(your_data$age >= 65 & your_data$gender == "Male",
#' "Group 1", "Group 2"))
#' ```
#'
#' All types of antibiograms can be generated with the functions as described on this page, and can be plotted (using [ggplot2::autoplot()] or base \R [plot()]/[barplot()]) or printed into R Markdown / Quarto formats for reports. Use functions from specific 'table reporting' packages to transform the output of [antibiogram()] to your needs, e.g. `flextable::as_flextable()` or `gt::gt()`.
#'
#' Note that for combination antibiograms, it is important to realise that susceptibility can be calculated in two ways, which can be set with the `only_all_tested` argument (defaults to `FALSE`). See this example for two antibiotics, Drug A and Drug B, about how [antibiogram()] works to calculate the %SI:
#'
#' ```
#' --------------------------------------------------------------------
#' only_all_tested = FALSE only_all_tested = TRUE
#' ----------------------- -----------------------
#' Drug A Drug B include as include as include as include as
#' numerator denominator numerator denominator
#' -------- -------- ---------- ----------- ---------- -----------
#' S or I S or I X X X X
#' R S or I X X X X
#' <NA> S or I X X - -
#' S or I R X X X X
#' R R - X - X
#' <NA> R - - - -
#' S or I <NA> X X - -
#' R <NA> - - - -
#' <NA> <NA> - - - -
#' --------------------------------------------------------------------
#' ```
#' @source
#' * Klinker KP *et al.* (2021). **Antimicrobial stewardship and antibiograms: importance of moving beyond traditional antibiograms**. *Therapeutic Advances in Infectious Disease*, May 5;8:20499361211011373; \doi{10.1177/20499361211011373}
#' * Barbieri E *et al.* (2021). **Development of a Weighted-Incidence Syndromic Combination Antibiogram (WISCA) to guide the choice of the empiric antibiotic treatment for urinary tract infection in paediatric patients: a Bayesian approach** *Antimicrobial Resistance & Infection Control* May 1;10(1):74; \doi{10.1186/s13756-021-00939-2}
#' * **M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 5th Edition**, 2022, *Clinical and Laboratory Standards Institute (CLSI)*. <https://clsi.org/standards/products/microbiology/documents/m39/>.
#' @rdname antibiogram
#' @name antibiogram
#' @export
#' @examples
#' # example_isolates is a data set available in the AMR package.
#' # run ?example_isolates for more info.
#' example_isolates
#'
#'
#' # Traditional antibiogram ----------------------------------------------
#'
#' antibiogram(example_isolates,
#' antibiotics = c(aminoglycosides(), carbapenems()))
#'
#' antibiogram(example_isolates,
#' antibiotics = aminoglycosides(),
#' ab_transform = "atc",
#' mo_transform = "gramstain")
#'
#' antibiogram(example_isolates,
#' antibiotics = carbapenems(),
#' ab_transform = "name",
#' mo_transform = "name")
#'
#'
#' # Combined antibiogram -------------------------------------------------
#'
#' # combined antibiotics yield higher empiric coverage
#' antibiogram(example_isolates,
#' antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
#' mo_transform = "gramstain")
#'
#' antibiogram(example_isolates,
#' antibiotics = c("TZP", "TZP+TOB"),
#' mo_transform = "gramstain",
#' ab_transform = "name",
#' sep = " & ")
#'
#'
#' # Syndromic antibiogram ------------------------------------------------
#'
#' # the data set could contain a filter for e.g. respiratory specimens
#' antibiogram(example_isolates,
#' antibiotics = c(aminoglycosides(), carbapenems()),
#' syndromic_group = "ward")
#'
#' # with a custom language, though this will be determined automatically
#' # (i.e., this table will be in Spanish on Spanish systems)
#' ex1 <- example_isolates[which(mo_genus() == "Escherichia"), ]
#' antibiogram(ex1,
#' antibiotics = aminoglycosides(),
#' ab_transform = "name",
#' syndromic_group = ifelse(ex1$ward == "ICU",
#' "UCI", "No UCI"),
#' language = "es")
#'
#'
#' # Weighted-incidence syndromic combination antibiogram (WISCA) ---------
#'
#' # the data set could contain a filter for e.g. respiratory specimens
#' antibiogram(example_isolates,
#' antibiotics = c("AMC", "AMC+CIP", "TZP", "TZP+TOB"),
#' mo_transform = "gramstain",
#' minimum = 10, # this should be >= 30, but now just as example
#' syndromic_group = ifelse(example_isolates$age >= 65 &
#' example_isolates$gender == "M",
#' "WISCA Group 1", "WISCA Group 2"))
#'
#'
#' # Generate plots with ggplot2 or base R --------------------------------
#'
#' ab1 <- antibiogram(example_isolates,
#' antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
#' mo_transform = "gramstain")
#' ab2 <- antibiogram(example_isolates,
#' antibiotics = c("AMC", "CIP", "TZP", "TZP+TOB"),
#' mo_transform = "gramstain",
#' syndromic_group = "ward")
#'
#' plot(ab1)
#'
#' if (requireNamespace("ggplot2")) {
#' ggplot2::autoplot(ab1)
#' }
#'
#' plot(ab2)
#'
#' if (requireNamespace("ggplot2")) {
#' ggplot2::autoplot(ab2)
#' }
antibiogram <- function(x,
antibiotics = where(is.sir),
mo_transform = "shortname",
ab_transform = NULL,
syndromic_group = NULL,
add_total_n = TRUE,
only_all_tested = FALSE,
digits = 0,
col_mo = NULL,
language = get_AMR_locale(),
minimum = 30,
combine_SI = TRUE,
sep = " + ") {
meet_criteria(x, allow_class = "data.frame", contains_column_class = "sir")
meet_criteria(mo_transform, allow_class = "character", has_length = 1, is_in = c("name", "shortname", "gramstain", colnames(AMR::microorganisms)), allow_NULL = TRUE)
meet_criteria(ab_transform, allow_class = "character", has_length = 1, is_in = colnames(AMR::antibiotics), allow_NULL = TRUE)
meet_criteria(syndromic_group, allow_class = "character", allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(add_total_n, allow_class = "logical", has_length = 1)
meet_criteria(only_all_tested, allow_class = "logical", has_length = 1)
meet_criteria(digits, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
language <- validate_language(language)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(sep, allow_class = "character", has_length = 1)
# try to find columns based on type
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = interactive())
stop_if(is.null(col_mo), "`col_mo` must be set")
}
# transform MOs
x$`.mo` <- x[, col_mo, drop = TRUE]
if (is.null(mo_transform)) {
# leave as is
} else if (mo_transform == "gramstain") {
x$`.mo` <- mo_gramstain(x$`.mo`, language = language)
} else if (mo_transform == "shortname") {
x$`.mo` <- mo_shortname(x$`.mo`, language = language)
} else if (mo_transform == "name") {
x$`.mo` <- mo_name(x$`.mo`, language = language)
} else {
x$`.mo` <- mo_property(x$`.mo`, language = language)
}
x$`.mo`[is.na(x$`.mo`)] <- "(??)"
# get syndromic groups
if (!is.null(syndromic_group)) {
if (length(syndromic_group) == 1 && syndromic_group %in% colnames(x)) {
x$`.syndromic_group` <- x[, syndromic_group, drop = TRUE]
} else if (!is.null(syndromic_group)) {
x$`.syndromic_group` <- syndromic_group
}
x$`.syndromic_group`[is.na(x$`.syndromic_group`) | x$`.syndromic_group` == ""] <- paste0("(", translate_AMR("unknown", language = language), ")")
has_syndromic_group <- TRUE
} else {
has_syndromic_group <- FALSE
}
# get antibiotics
if (tryCatch(is.character(antibiotics), error = function(e) FALSE)) {
antibiotics <- strsplit(gsub(" ", "", antibiotics), "+", fixed = TRUE)
non_existing <- unlist(antibiotics)[!unlist(antibiotics) %in% colnames(x)]
if (length(non_existing) > 0) {
warning_("The following antibiotics were not available and ignored: ", vector_and(non_existing, sort = FALSE))
antibiotics <- lapply(antibiotics, function(ab) ab[!ab %in% non_existing])
}
# make list unique
antibiotics <- unique(antibiotics)
# go through list to set AMR in combinations
for (i in seq_len(length(antibiotics))) {
abx <- antibiotics[[i]]
for (ab in abx) {
# make sure they are SIR columns
x[, ab] <- as.sir(x[, ab, drop = TRUE])
}
new_colname <- paste0(trimws(abx), collapse = sep)
if (length(abx) == 1) {
next
} else {
# determine whether this new column should contain S, I, R, or NA
if (isTRUE(combine_SI)) {
S_values <- c("S", "I")
}else {
S_values <- "S"
}
other_values <- setdiff(c("S", "I", "R"), S_values)
x_transposed <- as.list(as.data.frame(t(x[, abx, drop = FALSE]), stringsAsFactors = FALSE))
if (isTRUE(only_all_tested)) {
x[new_colname] <- as.sir(vapply(FUN.VALUE = character(1), x_transposed, function(x) ifelse(anyNA(x), NA_character_, ifelse(any(x %in% S_values), "S", "R")), USE.NAMES = FALSE))
} else {
x[new_colname] <- as.sir(vapply(FUN.VALUE = character(1), x_transposed, function(x) ifelse(any(x %in% S_values, na.rm = TRUE), "S", ifelse(anyNA(x), NA_character_, "R")),
USE.NAMES = FALSE))
}
}
antibiotics[[i]] <- new_colname
}
antibiotics <- unlist(antibiotics)
} else {
if (identical(select, import_fn("select", "dplyr", error_on_fail = FALSE))) {
antibiotics <- suppressWarnings(x %>% select({{ antibiotics }}) %>% colnames())
} else {
antibiotics <- x %>% select(antibiotics) %>% colnames()
}
}
if (isTRUE(has_syndromic_group)) {
out <- x %>%
select(.syndromic_group, .mo, antibiotics) %>%
group_by(.syndromic_group)
} else {
out <- x %>%
select(.mo, antibiotics)
}
# get numbers of S, I, R (per group)
out <- out %>%
bug_drug_combinations(col_mo = ".mo",
FUN = function(x) x)
counts <- out
# regroup for summarising
if (isTRUE(has_syndromic_group)) {
colnames(out)[1] <- "syndromic_group"
out <- out %>%
group_by(syndromic_group, mo, ab)
} else {
out <- out %>%
group_by(mo, ab)
}
if (any(out$total < minimum, na.rm = TRUE)) {
message_("NOTE: ", sum(out$total < minimum, na.rm = TRUE), " combinations had less than `minimum = ", minimum, "` results and were ignored", add_fn = font_red)
}
out <- out %>%
mutate(numerator = ifelse(isTRUE(combine_SI), S + I, S)) %>%
summarise(SI = ifelse(total >= minimum, numerator / total, NA_real_)) %>%
filter(!is.na(SI))
# transform names of antibiotics
ab_naming_function <- function(x, t, l, s) {
x <- strsplit(x, s, fixed = TRUE)
out <- character(length = length(x))
for (i in seq_len(length(x))) {
a <- x[[i]]
if (is.null(t)) {
# leave as is
} else if (t == "atc") {
a <- ab_atc(a, only_first = TRUE, language = l)
} else {
a <- ab_property(a, property = t, language = l)
}
if (length(a) > 1) {
a <- paste0(trimws(a), collapse = sep)
}
out[i] <- a
}
out
}
out$ab <- ab_naming_function(out$ab, t = ab_transform, l = language, s = sep)
# transform long to wide
long_to_wide <- function(object, digs) {
object <- object %>%
mutate(SI = round(SI * 100, digits = digs)) %>%
# an unclassed data.frame is required for stats::reshape()
as.data.frame(stringsAsFactors = FALSE) %>%
stats::reshape(direction = "wide", idvar = "mo", timevar = "ab", v.names = "SI")
colnames(object) <- gsub("^SI?[.]", "", colnames(object))
return(object)
}
long <- ungroup(out)
if (isTRUE(has_syndromic_group)) {
grps <- unique(out$syndromic_group)
for (i in seq_len(length(grps))) {
grp <- grps[i]
if (i == 1) {
new_df <- long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits)
} else {
new_df <- bind_rows(new_df,
long_to_wide(out[which(out$syndromic_group == grp), , drop = FALSE], digs = digits))
}
}
# sort rows
new_df <- new_df %>% arrange(mo, syndromic_group)
# sort columns
new_df <- new_df[, c("syndromic_group", "mo", sort(colnames(new_df)[!colnames(new_df) %in% c("syndromic_group", "mo")])), drop = FALSE]
colnames(new_df)[1:2] <- translate_AMR(c("Syndromic Group", "Pathogen"), language = language)
} else {
new_df <- long_to_wide(out, digs = digits)
# sort rows
new_df <- new_df %>% arrange(mo)
# sort columns
new_df <- new_df[, c("mo", sort(colnames(new_df)[colnames(new_df) != "mo"])), drop = FALSE]
colnames(new_df)[1] <- translate_AMR("Pathogen", language = language)
}
# add total N if indicated
if (isTRUE(add_total_n)) {
if (isTRUE(has_syndromic_group)) {
n_per_mo <- counts %>%
group_by(mo, .syndromic_group) %>%
summarise(paste0(min(total, na.rm = TRUE), "-", max(total, na.rm = TRUE)))
colnames(n_per_mo) <- c("mo", "syn", "count")
count_group <- n_per_mo$count[match(paste(new_df[[2]], new_df[[1]]), paste(n_per_mo$mo, n_per_mo$syn))]
edit_col <- 2
} else {
n_per_mo <- counts %>%
group_by(mo) %>%
summarise(paste0(min(total, na.rm = TRUE), "-", max(total, na.rm = TRUE)))
colnames(n_per_mo) <- c("mo", "count")
count_group <- n_per_mo$count[match(new_df[[1]], n_per_mo$mo)]
edit_col <- 1
}
new_df[[edit_col]] <- paste0(new_df[[edit_col]], " (", count_group, ")")
colnames(new_df)[edit_col] <- paste(colnames(new_df)[edit_col], "(N min-max)")
}
structure(as_original_data_class(new_df, class(x), extra_class = "antibiogram"),
long = long,
combine_SI = combine_SI)
}
#' @export
#' @rdname antibiogram
plot.antibiogram <- function(x, ...) {
df <- attributes(x)$long
if ("syndromic_group" %in% colnames(df)) {
# barplot in base R does not support facets - paste columns together
df$mo <- paste(df$mo, "-", df$syndromic_group)
df$syndromic_group <- NULL
df <- df[order(df$mo), , drop = FALSE]
}
mo_levels = unique(df$mo)
mfrow_old <- par()$mfrow
sqrt_levels <- sqrt(length(mo_levels))
par(mfrow = c(ceiling(sqrt_levels), floor(sqrt_levels)))
for (i in seq_along(mo_levels)) {
mo <- mo_levels[i]
df_sub <- df[df$mo == mo, , drop = FALSE]
barplot(height = df_sub$SI * 100,
xlab = NULL,
ylab = ifelse(isTRUE(attributes(x)$combine_SI), "%SI", "%S"),
names.arg = df_sub$ab,
col = "#aaaaaa",
beside = TRUE,
main = mo,
legend = NULL)
}
par(mfrow = mfrow_old)
}
#' @export
#' @noRd
barplot.antibiogram <- plot.antibiogram
#' @method autoplot antibiogram
#' @rdname antibiogram
# will be exported using s3_register() in R/zzz.R
autoplot.antibiogram <- function(object, ...) {
df <- attributes(object)$long
ggplot2::ggplot(df) +
ggplot2::geom_col(ggplot2::aes(x = ab,
y = SI * 100,
fill = if ("syndromic_group" %in% colnames(df)) {
syndromic_group
} else {
NULL
}),
position = "dodge") +
ggplot2::facet_wrap("mo") +
ggplot2::labs(y = ifelse(isTRUE(attributes(object)$combine_SI), "%SI", "%S"),
x = NULL,
fill = if ("syndromic_group" %in% colnames(df)) {
colnames(object)[1]
} else {
NULL
})
}
#' @export
#' @param as_kable a [logical] to indicate whether the printing should be done using [knitr::kable()] (which is the default in non-interactive sessions)
#' @details Printing the antibiogram in non-interactive sessions will be done by [knitr::kable()], with support for [all their implemented formats][knitr::kable()], such as "markdown". The knitr format will be automatically determined if printed inside a knitr document (LaTeX, HTML, etc.).
#' @rdname antibiogram
print.antibiogram <- function(x, as_kable = !interactive(), ...) {
meet_criteria(as_kable, allow_class = "logical", has_length = 1)
if (isTRUE(as_kable)) {
stop_ifnot_installed("knitr")
kable <- import_fn("kable", "knitr", error_on_fail = TRUE)
kable(x, ...)
} else {
# remove 'antibiogram' class and print as indicated
class(x) <- class(x)[class(x) != "antibiogram"]
print(x, ...)
}
}

16
R/atc_online.R
View File

@ -139,9 +139,9 @@ atc_online_property <- function(atc_code,
if (property == "groups") {
out <- tryCatch(
read_html(atc_url) %pm>%
html_node("#content") %pm>%
html_children() %pm>%
read_html(atc_url) %>%
html_node("#content") %>%
html_children() %>%
html_node("a"),
error = function(e) NULL
)
@ -151,9 +151,9 @@ atc_online_property <- function(atc_code,
}
# get URLS of items
hrefs <- out %pm>% html_attr("href")
hrefs <- out %>% html_attr("href")
# get text of items
texts <- out %pm>% html_text()
texts <- out %>% html_text()
# select only text items where URL like "code="
texts <- texts[grepl("?code=", tolower(hrefs), fixed = TRUE)]
# last one is antibiotics, skip it
@ -161,9 +161,9 @@ atc_online_property <- function(atc_code,
returnvalue <- c(list(texts), returnvalue)
} else {
out <- tryCatch(
read_html(atc_url) %pm>%
html_nodes("table") %pm>%
html_table(header = TRUE) %pm>%
read_html(atc_url) %>%
html_nodes("table") %>%
html_table(header = TRUE) %>%
as.data.frame(stringsAsFactors = FALSE),
error = function(e) NULL
)

2
R/av_property.R
View File

@ -252,7 +252,7 @@ av_url <- function(x, open = FALSE, ...) {
av_property <- function(x, property = "name", language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, is_in = colnames(AMR::antivirals), has_length = 1)
meet_criteria(language, is_in = c(LANGUAGES_SUPPORTED, ""), has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
language <- validate_language(language)
translate_into_language(av_validate(x = x, property = property, ...), language = language)
}

98
R/bug_drug_combinations.R
View File

@ -45,6 +45,10 @@
#' @return The function [bug_drug_combinations()] returns a [data.frame] with columns "mo", "ab", "S", "I", "R" and "total".
#' @examples
#' \donttest{
#' #' # example_isolates is a data set available in the AMR package.
#' # run ?example_isolates for more info.
#' example_isolates
#'
#' x <- bug_drug_combinations(example_isolates)
#' head(x)
#' format(x, translate_ab = "name (atc)")
@ -79,7 +83,30 @@ bug_drug_combinations <- function(x,
} else {
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found")
}
# use dplyr and tidyr if they are available, they are much faster!
if (pkg_is_available("dplyr", min_version = "1.0.0", also_load = FALSE) &&
pkg_is_available("tidyr", min_version = "1.0.0", also_load = FALSE)) {
across <- import_fn("across", "dplyr")
pivot_longer <- import_fn("pivot_longer", "tidyr")
out <- x %>%
ungroup() %>%
mutate(mo = FUN(ungroup(x)[, col_mo, drop = TRUE], ...)) %>%
pivot_longer(where(is.sir), names_to = "ab") %>%
group_by(across(c(group_vars(x), mo, ab))) %>%
summarise(S = sum(value == "S", na.rm = TRUE),
I = sum(value == "I", na.rm = TRUE),
R = sum(value == "R", na.rm = TRUE),
.groups = "drop") %>%
mutate(total = S + I + R)
out <- out %>% arrange(mo, ab)
return(structure(out,
class = c("bug_drug_combinations",
ifelse(is_null_or_grouped_tbl(x), "grouped", character(0)),
class(out))))
}
# no dplyr or tidyr available, so use base R
x.bak <- x
x <- as.data.frame(x, stringsAsFactors = FALSE)
x[, col_mo] <- FUN(x[, col_mo, drop = TRUE], ...)
@ -161,6 +188,7 @@ bug_drug_combinations <- function(x,
out <- run_it(x)
}
rownames(out) <- NULL
out <- out %>% arrange(mo, ab)
out <- as_original_data_class(out, class(x.bak)) # will remove tibble groups
structure(out, class = c("bug_drug_combinations", ifelse(data_has_groups, "grouped", character(0)), class(out)))
}
@ -176,12 +204,12 @@ format.bug_drug_combinations <- function(x,
add_ab_group = TRUE,
remove_intrinsic_resistant = FALSE,
decimal.mark = getOption("OutDec"),
big.mark = ifelse(decimal.mark == ",", ".", ","),
big.mark = ifelse(decimal.mark == ",", " ", ","),
...) {
meet_criteria(x, allow_class = "data.frame")
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(add_ab_group, allow_class = "logical", has_length = 1)
meet_criteria(remove_intrinsic_resistant, allow_class = "logical", has_length = 1)
@ -246,46 +274,38 @@ format.bug_drug_combinations <- function(x,
.data
}
create_var <- function(.data, ...) {
dots <- list(...)
for (i in seq_len(length(dots))) {
.data[, names(dots)[i]] <- dots[[i]]
}
.data
}
y <- x %pm>%
create_var(
y <- x %>%
mutate(
ab = as.ab(x$ab),
ab_txt = give_ab_name(ab = x$ab, format = translate_ab, language = language)
) %pm>%
pm_group_by(ab, ab_txt, mo) %pm>%
pm_summarise(
) %>%
group_by(ab, ab_txt, mo) %>%
summarise(
isolates = sum(isolates, na.rm = TRUE),
total = sum(total, na.rm = TRUE)
) %pm>%
pm_ungroup()
) %>%
ungroup()
y <- y %pm>%
create_var(txt = paste0(
y <- y %>%
mutate(txt = paste0(
percentage(y$isolates / y$total, decimal.mark = decimal.mark, big.mark = big.mark),
" (", trimws(format(y$isolates, big.mark = big.mark)), "/",
trimws(format(y$total, big.mark = big.mark)), ")"
)) %pm>%
pm_select(ab, ab_txt, mo, txt) %pm>%
pm_arrange(mo)
)) %>%
select(ab, ab_txt, mo, txt) %>%
arrange(mo)
# replace tidyr::pivot_wider() from here
for (i in unique(y$mo)) {
mo_group <- y[which(y$mo == i), c("ab", "txt"), drop = FALSE]
colnames(mo_group) <- c("ab", i)
rownames(mo_group) <- NULL
y <- y %pm>%
pm_left_join(mo_group, by = "ab")
y <- y %>%
left_join(mo_group, by = "ab")
}
y <- y %pm>%
pm_distinct(ab, .keep_all = TRUE) %pm>%
pm_select(-mo, -txt) %pm>%
y <- y %>%
distinct(ab, .keep_all = TRUE) %>%
select(-mo, -txt) %>%
# replace tidyr::pivot_wider() until here
remove_NAs()
@ -293,21 +313,21 @@ format.bug_drug_combinations <- function(x,
.data[, c("ab_group", "ab_txt", colnames(.data)[!colnames(.data) %in% c("ab_group", "ab_txt", "ab")]), drop = FALSE]
}
y <- y %pm>%
create_var(ab_group = ab_group(y$ab, language = language)) %pm>%
select_ab_vars() %pm>%
pm_arrange(ab_group, ab_txt)
y <- y %pm>%
create_var(ab_group = ifelse(y$ab_group != pm_lag(y$ab_group) | is.na(pm_lag(y$ab_group)), y$ab_group, ""))
y <- y %>%
mutate(ab_group = ab_group(y$ab, language = language)) %>%
select_ab_vars() %>%
arrange(ab_group, ab_txt)
y <- y %>%
mutate(ab_group = ifelse(y$ab_group != lag(y$ab_group) | is.na(lag(y$ab_group)), y$ab_group, ""))
if (add_ab_group == FALSE) {
y <- y %pm>%
pm_select(-ab_group) %pm>%
pm_rename("Drug" = ab_txt)
y <- y %>%
select(-ab_group) %>%
rename("Drug" = ab_txt)
colnames(y)[1] <- translate_into_language(colnames(y)[1], language, only_unknown = FALSE)
} else {
y <- y %pm>%
pm_rename(
y <- y %>%
rename(
"Group" = ab_group,
"Drug" = ab_txt
)

30
R/data.R
View File

@ -27,7 +27,7 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Data Sets with `r format(nrow(antibiotics) + nrow(antivirals), big.mark = ",")` Antimicrobial Drugs
#' Data Sets with `r format(nrow(antibiotics) + nrow(antivirals), big.mark = " ")` Antimicrobial Drugs
#'
#' Two data sets containing all antibiotics/antimycotics and antivirals. Use [as.ab()] or one of the [`ab_*`][ab_property()] functions to retrieve values from the [antibiotics] data set. Three identifiers are included in this data set: an antibiotic ID (`ab`, primarily used in this package) as defined by WHONET/EARS-Net, an ATC code (`atc`) as defined by the WHO, and a Compound ID (`cid`) as found in PubChem. Other properties in this data set are derived from one or more of these codes. Note that some drugs have multiple ATC codes.
#' @format
@ -82,10 +82,10 @@
#' @rdname antibiotics
"antivirals"
#' Data Set with `r format(nrow(microorganisms), big.mark = ",")` Microorganisms
#' Data Set with `r format(nrow(microorganisms), big.mark = " ")` Microorganisms
#'
#' A data set containing the full microbial taxonomy (**last updated: `r documentation_date(max(TAXONOMY_VERSION$GBIF$accessed_date, TAXONOMY_VERSION$LPSN$accessed_date))`**) of `r nr2char(length(unique(microorganisms$kingdom[!microorganisms$kingdom %like% "unknown"])))` kingdoms from the List of Prokaryotic names with Standing in Nomenclature (LPSN) and the Global Biodiversity Information Facility (GBIF). This data set is the backbone of this `AMR` package. MO codes can be looked up using [as.mo()].
#' @format A [tibble][tibble::tibble] with `r format(nrow(microorganisms), big.mark = ",")` observations and `r ncol(microorganisms)` variables:
#' @format A [tibble][tibble::tibble] with `r format(nrow(microorganisms), big.mark = " ")` observations and `r ncol(microorganisms)` variables:
#' - `mo`\cr ID of microorganism as used by this package
#' - `fullname`\cr Full name, like `"Escherichia coli"`. For the taxonomic ranks genus, species and subspecies, this is the 'pasted' text of genus, species, and subspecies. For all taxonomic ranks higher than genus, this is the name of the taxon.
#' - `status` \cr Status of the taxon, either `r vector_or(microorganisms$status)`
@ -150,10 +150,10 @@
#' microorganisms
"microorganisms"
#' Data Set with `r format(nrow(microorganisms.codes), big.mark = ",")` Common Microorganism Codes
#' Data Set with `r format(nrow(microorganisms.codes), big.mark = " ")` Common Microorganism Codes
#'
#' A data set containing commonly used codes for microorganisms, from laboratory systems and WHONET. Define your own with [set_mo_source()]. They will all be searched when using [as.mo()] and consequently all the [`mo_*`][mo_property()] functions.
#' @format A [tibble][tibble::tibble] with `r format(nrow(microorganisms.codes), big.mark = ",")` observations and `r ncol(microorganisms.codes)` variables:
#' @format A [tibble][tibble::tibble] with `r format(nrow(microorganisms.codes), big.mark = " ")` observations and `r ncol(microorganisms.codes)` variables:
#' - `code`\cr Commonly used code of a microorganism
#' - `mo`\cr ID of the microorganism in the [microorganisms] data set
#' @details
@ -163,10 +163,10 @@
#' microorganisms.codes
"microorganisms.codes"
#' Data Set with `r format(nrow(example_isolates), big.mark = ",")` Example Isolates
#' Data Set with `r format(nrow(example_isolates), big.mark = " ")` Example Isolates
#'
#' A data set containing `r format(nrow(example_isolates), big.mark = ",")` microbial isolates with their full antibiograms. This data set contains randomised fictitious data, but reflects reality and can be used to practise AMR data analysis. For examples, please read [the tutorial on our website](https://msberends.github.io/AMR/articles/AMR.html).
#' @format A [tibble][tibble::tibble] with `r format(nrow(example_isolates), big.mark = ",")` observations and `r ncol(example_isolates)` variables:
#' A data set containing `r format(nrow(example_isolates), big.mark = " ")` microbial isolates with their full antibiograms. This data set contains randomised fictitious data, but reflects reality and can be used to practise AMR data analysis. For examples, please read [the tutorial on our website](https://msberends.github.io/AMR/articles/AMR.html).
#' @format A [tibble][tibble::tibble] with `r format(nrow(example_isolates), big.mark = " ")` observations and `r ncol(example_isolates)` variables:
#' - `date`\cr Date of receipt at the laboratory
#' - `patient`\cr ID of the patient
#' - `age`\cr Age of the patient
@ -182,8 +182,8 @@
#' Data Set with Unclean Data
#'
#' A data set containing `r format(nrow(example_isolates_unclean), big.mark = ",")` microbial isolates that are not cleaned up and consequently not ready for AMR data analysis. This data set can be used for practice.
#' @format A [tibble][tibble::tibble] with `r format(nrow(example_isolates_unclean), big.mark = ",")` observations and `r ncol(example_isolates_unclean)` variables:
#' A data set containing `r format(nrow(example_isolates_unclean), big.mark = " ")` microbial isolates that are not cleaned up and consequently not ready for AMR data analysis. This data set can be used for practice.
#' @format A [tibble][tibble::tibble] with `r format(nrow(example_isolates_unclean), big.mark = " ")` observations and `r ncol(example_isolates_unclean)` variables:
#' - `patient_id`\cr ID of the patient
#' - `date`\cr date of receipt at the laboratory
#' - `hospital`\cr ID of the hospital, from A to C
@ -195,10 +195,10 @@
#' example_isolates_unclean
"example_isolates_unclean"
#' Data Set with `r format(nrow(WHONET), big.mark = ",")` Isolates - WHONET Example
#' Data Set with `r format(nrow(WHONET), big.mark = " ")` Isolates - WHONET Example
#'
#' This example data set has the exact same structure as an export file from WHONET. Such files can be used with this package, as this example data set shows. The antibiotic results are from our [example_isolates] data set. All patient names are created using online surname generators and are only in place for practice purposes.
#' @format A [tibble][tibble::tibble] with `r format(nrow(WHONET), big.mark = ",")` observations and `r ncol(WHONET)` variables:
#' @format A [tibble][tibble::tibble] with `r format(nrow(WHONET), big.mark = " ")` observations and `r ncol(WHONET)` variables:
#' - `Identification number`\cr ID of the sample
#' - `Specimen number`\cr ID of the specimen
#' - `Organism`\cr Name of the microorganism. Before analysis, you should transform this to a valid microbial class, using [as.mo()].
@ -234,7 +234,7 @@
#' Data Set with Clinical Breakpoints for SIR Interpretation
#'
#' Data set containing clinical breakpoints to interpret MIC and disk diffusion to SIR values, according to international guidelines. Currently implemented guidelines are EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`). Use [as.sir()] to transform MICs or disks measurements to SIR values.
#' @format A [tibble][tibble::tibble] with `r format(nrow(clinical_breakpoints), big.mark = ",")` observations and `r ncol(clinical_breakpoints)` variables:
#' @format A [tibble][tibble::tibble] with `r format(nrow(clinical_breakpoints), big.mark = " ")` observations and `r ncol(clinical_breakpoints)` variables:
#' - `guideline`\cr Name of the guideline
#' - `method`\cr Either `r vector_or(clinical_breakpoints$method)`
#' - `site`\cr Body site, e.g. "Oral" or "Respiratory"
@ -258,7 +258,7 @@
#' Data Set with Bacterial Intrinsic Resistance
#'
#' Data set containing defined intrinsic resistance by EUCAST of all bug-drug combinations.
#' @format A [tibble][tibble::tibble] with `r format(nrow(intrinsic_resistant), big.mark = ",")` observations and `r ncol(intrinsic_resistant)` variables:
#' @format A [tibble][tibble::tibble] with `r format(nrow(intrinsic_resistant), big.mark = " ")` observations and `r ncol(intrinsic_resistant)` variables:
#' - `mo`\cr Microorganism ID
#' - `ab`\cr Antibiotic ID
#' @details
@ -275,7 +275,7 @@
#' Data Set with Treatment Dosages as Defined by EUCAST
#'
#' EUCAST breakpoints used in this package are based on the dosages in this data set. They can be retrieved with [eucast_dosage()].
#' @format A [tibble][tibble::tibble] with `r format(nrow(dosage), big.mark = ",")` observations and `r ncol(dosage)` variables:
#' @format A [tibble][tibble::tibble] with `r format(nrow(dosage), big.mark = " ")` observations and `r ncol(dosage)` variables:
#' - `ab`\cr Antibiotic ID as used in this package (such as `AMC`), using the official EARS-Net (European Antimicrobial Resistance Surveillance Network) codes where available
#' - `name`\cr Official name of the antimicrobial drug as used by WHONET/EARS-Net or the WHO
#' - `type`\cr Type of the dosage, either `r vector_or(dosage$type)`

6
R/disk.R
View File

@ -114,9 +114,9 @@ as.disk <- function(x, na.rm = FALSE) {
na_after <- length(x[is.na(x)])
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %pm>%
unique() %pm>%
sort() %pm>%
list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %>%
unique() %>%
sort() %>%
vector_and(quotes = TRUE)
cur_col <- get_current_column()
warning_("in `as.disk()`: ", na_after - na_before, " result",

92
R/eucast_rules.R
View File

@ -236,7 +236,7 @@ eucast_rules <- function(x,
}
decimal.mark <- getOption("OutDec")
big.mark <- ifelse(decimal.mark != ",", ",", ".")
big.mark <- ifelse(decimal.mark != ",", ",", " ")
formatnr <- function(x, big = big.mark, dec = decimal.mark) {
trimws(format(x, big.mark = big, decimal.mark = dec))
}
@ -331,12 +331,12 @@ eucast_rules <- function(x,
# Some helper functions ---------------------------------------------------
get_antibiotic_names <- function(x) {
x <- x %pm>%
strsplit(",") %pm>%
unlist() %pm>%
trimws2() %pm>%
vapply(FUN.VALUE = character(1), function(x) if (x %in% AMR::antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE, fast_mode = TRUE) else x) %pm>%
sort() %pm>%
x <- x %>%
strsplit(",") %>%
unlist() %>%
trimws2() %>%
vapply(FUN.VALUE = character(1), function(x) if (x %in% AMR::antibiotics$ab) ab_name(x, language = NULL, tolower = TRUE, fast_mode = TRUE) else x) %>%
sort() %>%
paste(collapse = ", ")
x <- gsub("_", " ", x, fixed = TRUE)
x <- gsub("except CAZ", paste("except", ab_name("CAZ", language = NULL, tolower = TRUE)), x, fixed = TRUE)
@ -419,10 +419,10 @@ eucast_rules <- function(x,
# save original table, with the new .rowid column
x.bak <- x
# keep only unique rows for MO and ABx
x <- x %pm>%
pm_arrange(`.rowid`) %pm>%
x <- x %>%
arrange(`.rowid`) %>%
# big speed gain! only analyse unique rows:
pm_distinct(`.rowid`, .keep_all = TRUE) %pm>%
distinct(`.rowid`, .keep_all = TRUE) %>%
as.data.frame(stringsAsFactors = FALSE)
x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]), info = info)
# rename col_mo to prevent interference with joined columns
@ -925,16 +925,16 @@ eucast_rules <- function(x,
# Print overview ----------------------------------------------------------
if (isTRUE(info) || isTRUE(verbose)) {
verbose_info <- x.bak %pm>%
pm_mutate(row = pm_row_number()) %pm>%
pm_select(`.rowid`, row) %pm>%
pm_right_join(verbose_info,
verbose_info <- x.bak %>%
mutate(row = row_number()) %>%
select(`.rowid`, row) %>%
right_join(verbose_info,
by = c(".rowid" = "rowid")
) %pm>%
pm_select(-`.rowid`) %pm>%
pm_select(row, pm_everything()) %pm>%
pm_filter(!is.na(new) | is.na(new) & !is.na(old)) %pm>%
pm_arrange(row, rule_group, rule_name, col)
) %>%
select(-`.rowid`) %>%
select(row, everything()) %>%
filter(!is.na(new) | is.na(new) & !is.na(old)) %>%
arrange(row, rule_group, rule_name, col)
rownames(verbose_info) <- NULL
}
@ -949,7 +949,7 @@ eucast_rules <- function(x,
cat(word_wrap(paste0(
"The rules ", paste0(wouldve, "affected "),
font_bold(
formatnr(pm_n_distinct(verbose_info$row)),
formatnr(n_distinct(verbose_info$row)),
"out of", formatnr(nrow(x.bak)),
"rows"
),
@ -957,8 +957,8 @@ eucast_rules <- function(x,
font_bold(formatnr(nrow(verbose_info)), "edits\n")
)))
total_n_added <- verbose_info %pm>% pm_filter(is.na(old)) %pm>% nrow()
total_n_changed <- verbose_info %pm>% pm_filter(!is.na(old)) %pm>% nrow()
total_n_added <- verbose_info %>% filter(is.na(old)) %>% nrow()
total_n_changed <- verbose_info %>% filter(!is.na(old)) %>% nrow()
# print added values
if (total_n_added == 0) {
@ -968,15 +968,15 @@ eucast_rules <- function(x,
}
cat(colour(paste0(
"=> ", wouldve, "added ",
font_bold(formatnr(verbose_info %pm>%
pm_filter(is.na(old)) %pm>%
font_bold(formatnr(verbose_info %>%
filter(is.na(old)) %>%
nrow()), "test results"),
"\n"
)))
if (total_n_added > 0) {
added_summary <- verbose_info %pm>%
pm_filter(is.na(old)) %pm>%
pm_count(new, name = "n")
added_summary <- verbose_info %>%
filter(is.na(old)) %>%
count(new, name = "n")
cat(paste(" -",
paste0(
formatnr(added_summary$n), " test result", ifelse(added_summary$n > 1, "s", ""),
@ -997,16 +997,16 @@ eucast_rules <- function(x,
}
cat(colour(paste0(
"=> ", wouldve, "changed ",
font_bold(formatnr(verbose_info %pm>%
pm_filter(!is.na(old)) %pm>%
font_bold(formatnr(verbose_info %>%
filter(!is.na(old)) %>%
nrow()), "test results"),
"\n"
)))
if (total_n_changed > 0) {
changed_summary <- verbose_info %pm>%
pm_filter(!is.na(old)) %pm>%
pm_mutate(new = ifelse(is.na(new), "NA", new)) %pm>%
pm_count(old, new, name = "n")
changed_summary <- verbose_info %>%
filter(!is.na(old)) %>%
mutate(new = ifelse(is.na(new), "NA", new)) %>%
count(old, new, name = "n")
cat(paste(" -",
paste0(
formatnr(changed_summary$n), " test result", ifelse(changed_summary$n > 1, "s", ""), " changed from ",
@ -1049,8 +1049,8 @@ eucast_rules <- function(x,
# x was analysed with only unique rows, so join everything together again
x <- x[, c(cols_ab, ".rowid"), drop = FALSE]
x.bak <- x.bak[, setdiff(colnames(x.bak), cols_ab), drop = FALSE]
x.bak <- x.bak %pm>%
pm_left_join(x, by = ".rowid")
x.bak <- x.bak %>%
left_join(x, by = ".rowid")
x.bak <- x.bak[, old_cols, drop = FALSE]
# reset original attributes
attributes(x.bak) <- old_attributes
@ -1103,8 +1103,8 @@ edit_sir <- function(x,
if (w$message %like% "invalid factor level") {
xyz <- vapply(FUN.VALUE = logical(1), cols, function(col) {
new_edits[, col] <<- factor(
x = as.character(pm_pull(new_edits, col)),
levels = unique(c(to, levels(pm_pull(new_edits, col))))
x = as.character(pull(new_edits, col)),
levels = unique(c(to, levels(pull(new_edits, col))))
)
TRUE
})
@ -1159,22 +1159,22 @@ edit_sir <- function(x,
"rowid", "col", "mo_fullname", "old", "new",
"rule", "rule_group", "rule_name", "rule_source"
)
verbose_new <- verbose_new %pm>% pm_filter(old != new | is.na(old) | is.na(new) & !is.na(old))
verbose_new <- verbose_new %>% filter(old != new | is.na(old) | is.na(new) & !is.na(old))
# save changes to data set 'verbose_info'
track_changes$verbose_info <- rbind(track_changes$verbose_info,
verbose_new,
stringsAsFactors = FALSE
)
# count adds and changes
track_changes$added <- track_changes$added + verbose_new %pm>%
pm_filter(is.na(old)) %pm>%
pm_pull(rowid) %pm>%
get_original_rows() %pm>%
track_changes$added <- track_changes$added + verbose_new %>%
filter(is.na(old)) %>%
pull(rowid) %>%
get_original_rows() %>%
length()
track_changes$changed <- track_changes$changed + verbose_new %pm>%
pm_filter(!is.na(old)) %pm>%
pm_pull(rowid) %pm>%
get_original_rows() %pm>%
track_changes$changed <- track_changes$changed + verbose_new %>%
filter(!is.na(old)) %>%
pull(rowid) %>%
get_original_rows() %>%
length()
}
}

61
R/first_isolate.R
View File

@ -33,7 +33,7 @@
#' @param x a [data.frame] containing isolates. Can be left blank for automatic determination, see *Examples*.
#' @param col_date column name of the result date (or date that is was received on the lab), defaults to the first column with a date class
#' @param col_patient_id column name of the unique IDs of the patients, defaults to the first column that starts with 'patient' or 'patid' (case insensitive)
#' @param col_mo column name of the IDs of the microorganisms (see [as.mo()]), defaults to the first column of class [`mo`]. Values will be coerced using [as.mo()].
#' @param col_mo column name of the names or codes of the microorganisms (see [as.mo()]), defaults to the first column of class [`mo`]. Values will be coerced using [as.mo()].
#' @param col_testcode column name of the test codes. Use `col_testcode = NULL` to **not** exclude certain test codes (such as test codes for screening). In that case `testcodes_exclude` will be ignored.
#' @param col_specimen column name of the specimen type or group
#' @param col_icu column name of the logicals (`TRUE`/`FALSE`) whether a ward or department is an Intensive Care Unit (ICU). This can also be a [logical] vector with the same length as rows in `x`.
@ -71,17 +71,14 @@
#' | **Isolate-based** | `first_isolate(x, method = "isolate-based")` |
#' | *(= all isolates)* | |
#' | | |
#' | | |
#' | **Patient-based** | `first_isolate(x, method = "patient-based")` |
#' | *(= first isolate per patient)* | |
#' | | |
#' | | |
#' | **Episode-based** | `first_isolate(x, method = "episode-based")`, or: |
#' | *(= first isolate per episode)* | |
#' | - 7-Day interval from initial isolate | - `first_isolate(x, method = "e", episode_days = 7)` |
#' | - 30-Day interval from initial isolate | - `first_isolate(x, method = "e", episode_days = 30)` |
#' | | |
#' | | |
#' | **Phenotype-based** | `first_isolate(x, method = "phenotype-based")`, or: |
#' | *(= first isolate per phenotype)* | |
#' | - Major difference in any antimicrobial result | - `first_isolate(x, type = "points")` |
@ -133,7 +130,7 @@
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#' example_isolates[first_isolate(), ]
#' example_isolates[first_isolate(info = TRUE), ]
#' \donttest{
#' # get all first Gram-negatives
#' example_isolates[which(first_isolate(info = FALSE) & mo_is_gram_negative()), ]
@ -141,7 +138,7 @@
#' if (require("dplyr")) {
#' # filter on first isolates using dplyr:
#' example_isolates %>%
#' filter(first_isolate())
#' filter(first_isolate(info = TRUE))
#' }
#' if (require("dplyr")) {
#' # short-hand version:
@ -152,7 +149,7 @@
#' # flag the first isolates per group:
#' example_isolates %>%
#' group_by(ward) %>%
#' mutate(first = first_isolate()) %>%
#' mutate(first = first_isolate(info = FALSE)) %>%
#' select(ward, date, patient, mo, first)
#' }
#' }
@ -394,17 +391,17 @@ first_isolate <- function(x = NULL,
} else {
# filtering on specimen and only analyse these rows to save time
x <- x[order(
pm_pull(x, col_specimen),
pull(x, col_specimen),
x$newvar_patient_id,
x$newvar_genus_species,
x$newvar_date
), ]
rownames(x) <- NULL
suppressWarnings(
row.start <- which(x %pm>% pm_pull(col_specimen) == specimen_group) %pm>% min(na.rm = TRUE)
row.start <- which(x %>% pull(col_specimen) == specimen_group) %>% min(na.rm = TRUE)
)
suppressWarnings(
row.end <- which(x %pm>% pm_pull(col_specimen) == specimen_group) %pm>% max(na.rm = TRUE)
row.end <- which(x %>% pull(col_specimen) == specimen_group) %>% max(na.rm = TRUE)
)
}
@ -427,7 +424,7 @@ first_isolate <- function(x = NULL,
}
return(TRUE)
}
if (length(c(row.start:row.end)) == pm_n_distinct(x[c(row.start:row.end), col_mo, drop = TRUE])) {
if (length(c(row.start:row.end)) == n_distinct(x[c(row.start:row.end), col_mo, drop = TRUE])) {
if (isTRUE(info)) {
message_("=> Found ", font_bold(paste(length(c(row.start:row.end)), "first isolates")),
", as all isolates were different microbial species",
@ -465,7 +462,7 @@ first_isolate <- function(x = NULL,
}
}
x$other_pat_or_mo <- !(x$newvar_patient_id == pm_lag(x$newvar_patient_id) & x$newvar_genus_species == pm_lag(x$newvar_genus_species))
x$other_pat_or_mo <- !(x$newvar_patient_id == lag(x$newvar_patient_id) & x$newvar_genus_species == lag(x$newvar_genus_species))
x$episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species)
x$more_than_episode_ago <- unlist(
@ -485,29 +482,21 @@ first_isolate <- function(x = NULL,
# with key antibiotics
x$other_key_ab <- !antimicrobials_equal(
y = x$newvar_key_ab,
z = pm_lag(x$newvar_key_ab),
z = lag(x$newvar_key_ab),
type = type,
ignore_I = ignore_I,
points_threshold = points_threshold
)
x$newvar_first_isolate <- pm_if_else(
x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab),
TRUE,
FALSE
)
x$newvar_first_isolate <- x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab)
} else {
# no key antibiotics
x$newvar_first_isolate <- pm_if_else(
x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago),
TRUE,
FALSE
)
x$newvar_first_isolate <- x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago)
}
# first one as TRUE
@ -518,12 +507,14 @@ first_isolate <- function(x = NULL,
}
if (!is.null(col_icu)) {
if (icu_exclude == TRUE) {
message_("Excluding ", format(sum(col_icu, na.rm = TRUE), big.mark = ","), " isolates from ICU.",
add_fn = font_black,
as_note = FALSE
)
if (isTRUE(info)) {
message_("Excluding ", format(sum(col_icu, na.rm = TRUE), big.mark = ","), " isolates from ICU.",
add_fn = font_black,
as_note = FALSE
)
}
x[which(col_icu), "newvar_first_isolate"] <- FALSE
} else {
} else if (isTRUE(info)) {
message_("Including isolates from ICU.",
add_fn = font_black,
as_note = FALSE
@ -532,7 +523,7 @@ first_isolate <- function(x = NULL,
}
decimal.mark <- getOption("OutDec")
big.mark <- ifelse(decimal.mark != ",", ",", ".")
big.mark <- ifelse(decimal.mark != ",", ",", " ")
if (isTRUE(info)) {
# print group name if used in dplyr::group_by()

86
R/episode.R → R/get_episode.R
View File

@ -29,7 +29,7 @@
#' Determine (New) Episodes for Patients
#'
#' These functions determine which items in a vector can be considered (the start of) a new episode, based on the argument `episode_days`. This can be used to determine clinical episodes for any epidemiological analysis. The [get_episode()] function returns the index number of the episode per group, while the [is_new_episode()] function returns values `TRUE`/`FALSE` to indicate whether an item in a vector is the start of a new episode.
#' These functions determine which items in a vector can be considered (the start of) a new episode, based on the argument `episode_days`. This can be used to determine clinical episodes for any epidemiological analysis. The [get_episode()] function returns the index number of the episode per group, while the [is_new_episode()] function returns values `TRUE`/`FALSE` for where [get_episode()] returns 1, and is thus equal to `get_episode(...) == 1`.
#' @param x vector of dates (class `Date` or `POSIXt`), will be sorted internally to determine episodes
#' @param episode_days required episode length in days, can also be less than a day or `Inf`, see *Details*
#' @param ... ignored, only in place to allow future extensions
@ -38,7 +38,7 @@
#'
#' The [first_isolate()] function is a wrapper around the [is_new_episode()] function, but is more efficient for data sets containing microorganism codes or names and allows for different isolate selection methods.
#'
#' The `dplyr` package is not required for these functions to work, but these functions do support [variable grouping][dplyr::group_by()] and work conveniently inside `dplyr` verbs such as [`filter()`][dplyr::filter()], [`mutate()`][dplyr::mutate()] and [`summarise()`][dplyr::summarise()].
#' The `dplyr` package is not required for these functions to work, but these episode functions do support [variable grouping][dplyr::group_by()] and work conveniently inside `dplyr` verbs such as [`filter()`][dplyr::filter()], [`mutate()`][dplyr::mutate()] and [`summarise()`][dplyr::summarise()].
#' @return
#' * [get_episode()]: a [double] vector
#' * [is_new_episode()]: a [logical] vector
@ -48,7 +48,7 @@
#' @examples
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates
#' df <- example_isolates[sample(seq_len(2000), size = 200), ]
#' df <- example_isolates[sample(seq_len(2000), size = 100), ]
#'
#' get_episode(df$date, episode_days = 60) # indices
#' is_new_episode(df$date, episode_days = 60) # TRUE/FALSE
@ -57,13 +57,9 @@
#' df[which(get_episode(df$date, 60) == 3), ]
#'
#' # the functions also work for less than a day, e.g. to include one per hour:
#' get_episode(
#' c(
#' Sys.time(),
#' Sys.time() + 60 * 60
#' ),
#' episode_days = 1 / 24
#' )
#' get_episode(c(Sys.time(),
#' Sys.time() + 60 * 60),
#' episode_days = 1 / 24)
#'
#' \donttest{
#' if (require("dplyr")) {
@ -79,6 +75,7 @@
#' mutate(new_episode = is_new_episode(date, 365)) %>%
#' select(patient, date, condition, new_episode)
#' }
#'
#' if (require("dplyr")) {
#' df %>%
#' group_by(ward, patient) %>%
@ -88,6 +85,7 @@
#' new_logical = is_new_episode(date, 60)
#' )
#' }
#'
#' if (require("dplyr")) {
#' df %>%
#' group_by(ward) %>%
@ -98,25 +96,10 @@
#' n_episodes_30 = sum(is_new_episode(date, episode_days = 30))
#' )
#' }
#'
#' if (require("dplyr")) {
#' # grouping on patients and microorganisms leads to the same
#' # results as first_isolate() when using 'episode-based':
#' x <- df %>%
#' filter_first_isolate(
#' include_unknown = TRUE,
#' method = "episode-based"
#' )
#'
#' y <- df %>%
#' group_by(patient, mo) %>%
#' filter(is_new_episode(date, 365)) %>%
#' ungroup()
#'
#' identical(x, y)
#' }
#' if (require("dplyr")) {
#' # but is_new_episode() has a lot more flexibility than first_isolate(),
#' # since you can now group on anything that seems relevant:
#' # is_new_episode() has a lot more flexibility than first_isolate(),
#' # since you can group on anything that seems relevant:
#' df %>%
#' group_by(patient, mo, ward) %>%
#' mutate(flag_episode = is_new_episode(date, 365)) %>%
@ -129,7 +112,6 @@ get_episode <- function(x, episode_days, ...) {
exec_episode(
x = x,
type = "sequential",
episode_days = episode_days,
... = ...
)
@ -140,43 +122,26 @@ get_episode <- function(x, episode_days, ...) {
is_new_episode <- function(x, episode_days, ...) {
meet_criteria(x, allow_class = c("Date", "POSIXt"), allow_NA = TRUE)
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = FALSE)
exec_episode(
x = x,
type = "logical",
episode_days = episode_days,
... = ...
)
get_episode(x, episode_days, ...) == 1
}
exec_episode <- function(x, type, episode_days, ...) {
x <- as.double(as.POSIXct(x)) # as.POSIXct() required for Date classes
# since x is now in seconds, get seconds from episode_days as well
episode_seconds <- episode_days * 60 * 60 * 24
if (length(x) == 1) { # this will also match 1 NA, which is fine
if (type == "logical") {
return(TRUE)
} else if (type == "sequential") {
return(1)
}
return(1)
} else if (length(x) == 2 && !all(is.na(x))) {
if (max(x) - min(x) >= episode_seconds) {
if (type == "logical") {
return(c(TRUE, TRUE))
} else if (type == "sequential") {
return(c(1, 2))
}
return(c(1, 2))
} else {
if (type == "logical") {
return(c(TRUE, FALSE))
} else if (type == "sequential") {
return(c(1, 1))
}
return(c(1, 1))
}
}
# I asked on StackOverflow:
# we asked on StackOverflow:
# https://stackoverflow.com/questions/42122245/filter-one-row-every-year
run_episodes <- function(x, episode_seconds) {
indices <- integer()
@ -186,26 +151,15 @@ exec_episode <- function(x, type, episode_days, ...) {
for (i in 2:length(x)) {
if (isTRUE((x[i] - start) >= episode_seconds)) {
ind <- ind + 1
if (type == "logical") {
indices[ind] <- i
}
start <- x[i]
}
if (type == "sequential") {
indices[i] <- ind
}
}
if (type == "logical") {
result <- rep(FALSE, length(x))
result[indices] <- TRUE
result
} else if (type == "sequential") {
indices
indices[i] <- ind
}
indices
}
ord <- order(x)
out <- run_episodes(x[ord], episode_seconds)[order(ord)]
out[is.na(x) & ord != 1] <- NA # every NA but the first must remain NA
out[is.na(x) & ord != 1] <- NA # every NA expect for the first must remain NA
out
}

16
R/ggplot_sir.R
View File

@ -202,7 +202,7 @@ ggplot_sir <- function(data,
meet_criteria(limits, allow_class = c("numeric", "integer"), has_length = 2, allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
language <- validate_language(language)
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
meet_criteria(colours, allow_class = c("character", "logical"))
@ -300,7 +300,7 @@ geom_sir <- function(position = NULL,
meet_criteria(x, allow_class = "character", has_length = 1)
meet_criteria(fill, allow_class = "character", has_length = 1)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
language <- validate_language(language)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
@ -486,7 +486,7 @@ labels_sir_count <- function(position = NULL,
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
meet_criteria(x, allow_class = "character", has_length = 1)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
language <- validate_language(language)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
@ -519,11 +519,11 @@ labels_sir_count <- function(position = NULL,
language = language
)
transformed$gr <- transformed[, x_name, drop = TRUE]
transformed %pm>%
pm_group_by(gr) %pm>%
pm_mutate(lbl = paste0("n=", isolates)) %pm>%
pm_ungroup() %pm>%
pm_select(-gr)
transformed %>%
group_by(gr) %>%
mutate(lbl = paste0("n=", isolates)) %>%
ungroup() %>%
select(-gr)
}
)
}

11
R/join_microorganisms.R
View File

@ -159,14 +159,9 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
by <- stats::setNames("mo", by)
}
# use dplyr if available - it's much faster than poorman alternatives
dplyr_join <- import_fn(name = type, pkg = "dplyr", error_on_fail = FALSE)
if (!is.null(dplyr_join)) {
join_fn <- dplyr_join
} else {
# otherwise use poorman, see R/aa_helper_pm_functions.R
join_fn <- get(paste0("pm_", type), envir = asNamespace("AMR"))
}
# this will use dplyr if available, and the slower poorman otherwise, see R/aaa_helper_pm_functions.R
join_fn <- get(type, envir = asNamespace("AMR"))
MO_df <- AMR_env$MO_lookup[, colnames(AMR::microorganisms), drop = FALSE]
if (type %like% "full|left|right|inner") {
joined <- join_fn(x = x, y = MO_df, by = by, suffix = suffix, ...)

2
R/mean_amr_distance.R
View File

@ -137,7 +137,7 @@ mean_amr_distance.data.frame <- function(x, ..., combine_SI = TRUE) {
if (!is.null(out)) {
df <- df[, out, drop = FALSE]
} else {
df <- pm_select(df, ...)
df <- select(df, ...)
}
}
df_classes <- colnames(df)[vapply(FUN.VALUE = logical(1), df, function(x) is.disk(x) | is.mic(x) | is.disk(x), USE.NAMES = FALSE)]

10
R/mic.R
View File

@ -219,14 +219,14 @@ as.mic <- function(x, na.rm = FALSE) {
## previously unempty values now empty - should return a warning later on
x[x.bak != "" & x == ""] <- "invalid"
na_before <- x[is.na(x) | x == ""] %pm>% length()
na_before <- x[is.na(x) | x == ""] %>% length()
x[!x %in% valid_mic_levels] <- NA
na_after <- x[is.na(x) | x == ""] %pm>% length()
na_after <- x[is.na(x) | x == ""] %>% length()
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %pm>%
unique() %pm>%
sort() %pm>%
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %>%
unique() %>%
sort() %>%
vector_and(quotes = TRUE)
cur_col <- get_current_column()
warning_("in `as.mic()`: ", na_after - na_before, " result",

22
R/mo.R
View File

@ -561,10 +561,10 @@ pillar_shaft.mo <- function(x, ...) {
# markup NA and UNKNOWN
out[is.na(x)] <- font_na(" NA")
out[x == "UNKNOWN"] <- font_na(" UNKNOWN")
# markup manual codes
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
)
@ -579,7 +579,7 @@ pillar_shaft.mo <- function(x, ...) {
(!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],
font_na(font_stripstyle(out[!x %in% all_mos]),
collapse = NULL
),
collapse = NULL
@ -627,7 +627,7 @@ freq.mo <- function(x, ...) {
.add_header = list(
`Gram-negative` = paste0(
format(sum(grams == "Gram-negative", na.rm = TRUE),
big.mark = ",",
big.mark = " ",
decimal.mark = "."
),
" (", percentage(sum(grams == "Gram-negative", na.rm = TRUE) / length(grams),
@ -637,7 +637,7 @@ freq.mo <- function(x, ...) {
),
`Gram-positive` = paste0(
format(sum(grams == "Gram-positive", na.rm = TRUE),
big.mark = ",",
big.mark = " ",
decimal.mark = "."
),
" (", percentage(sum(grams == "Gram-positive", na.rm = TRUE) / length(grams),
@ -645,8 +645,8 @@ freq.mo <- function(x, ...) {
),
")"
),
`Nr. of genera` = pm_n_distinct(mo_genus(x_noNA, language = NULL)),
`Nr. of species` = pm_n_distinct(paste(
`Nr. of genera` = n_distinct(mo_genus(x_noNA, language = NULL)),
`Nr. of species` = n_distinct(paste(
mo_genus(x_noNA, language = NULL),
mo_species(x_noNA, language = NULL)
))
@ -1155,14 +1155,14 @@ repair_reference_df <- function(reference_df) {
return(NULL)
}
# has valid own reference_df
reference_df <- reference_df %pm>%
pm_filter(!is.na(mo))
reference_df <- reference_df %>%
filter(!is.na(mo))
# keep only first two columns, second must be mo
if (colnames(reference_df)[1] == "mo") {
reference_df <- reference_df %pm>% pm_select(2, "mo")
reference_df <- reference_df %>% select(2, "mo")
} else {
reference_df <- reference_df %pm>% pm_select(1, "mo")
reference_df <- reference_df %>% select(1, "mo")
}
# remove factors, just keep characters

12
R/mo_property.R
View File

@ -31,7 +31,7 @@
#'
#' Use these functions to return a specific property of a microorganism based on the latest accepted taxonomy. All input values will be evaluated internally with [as.mo()], which makes it possible to use microbial abbreviations, codes and names as input. See *Examples*.
#' @param x any [character] (vector) that can be coerced to a valid microorganism code with [as.mo()]. Can be left blank for auto-guessing the column containing microorganism codes if used in a data set, see *Examples*.
#' @param property one of the column names of the [microorganisms] data set: `r vector_or(colnames(microorganisms), sort = FALSE, quotes = TRUE)`, or must be `"shortname"`
#' @param property one of the column names of the [microorganisms] data set: `r vector_or(colnames(microorganisms), sort = FALSE, quotes = TRUE)`
#' @inheritParams as.mo
#' @param ... other arguments passed on to [as.mo()], such as 'minimum_matching_score', 'ignore_pattern', and 'remove_from_input'
#' @param ab any (vector of) text that can be coerced to a valid antibiotic drug code with [as.ab()]
@ -900,12 +900,16 @@ mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ..
}
# get property reeaaally fast using match()
x <- AMR_env$MO_lookup[[property]][match(x, AMR_env$MO_lookup$mo)]
if (property == "snomed") {
x <- lapply(x, function(y) unlist(AMR_env$MO_lookup$snomed[match(y, AMR_env$MO_lookup$mo)]))
} else {
x <- AMR_env$MO_lookup[[property]][match(x, AMR_env$MO_lookup$mo)]
}
if (property == "mo") {
return(set_clean_class(x, new_class = c("mo", "character")))
} else if (property == "snomed") {
return(sort(as.character(eval(parse(text = x)))))
return(x)
} else if (property == "prevalence") {
return(as.double(x))
} else {

2
R/pca.R
View File

@ -127,7 +127,7 @@ pca <- function(x,
x <- cbind(x.bak[, vapply(FUN.VALUE = logical(1), x.bak, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE], x)
}
x <- pm_ungroup(x) # would otherwise select the grouping vars
x <- ungroup(x) # would otherwise select the grouping vars
x <- x[rowSums(is.na(x)) == 0, ] # remove columns containing NAs
pca_data <- x[, which(vapply(FUN.VALUE = logical(1), x, function(x) is.numeric(x))), drop = FALSE]

4
R/plot.R
View File

@ -602,7 +602,7 @@ plot.sir <- function(x,
data$x <- factor(data$x, levels = c("S", "I", "R"), ordered = TRUE)
ymax <- pm_if_else(max(data$s) > 95, 105, 100)
ymax <- ifelse(max(data$s) > 95, 105, 100)
plot(
x = data$x,
@ -615,7 +615,7 @@ plot.sir <- function(x,
axes = FALSE
)
# x axis
axis(side = 1, at = 1:pm_n_distinct(data$x), labels = levels(data$x), lwd = 0)
axis(side = 1, at = 1:n_distinct(data$x), labels = levels(data$x), lwd = 0)
# y axis, 0-100%
axis(side = 2, at = seq(0, 100, 5))

10
R/proportion.R
View File

@ -27,7 +27,7 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Calculate Microbial Resistance
#' Calculate Antimicrobial Resistance
#'
#' @description These functions can be used to calculate the (co-)resistance or susceptibility of microbial isolates (i.e. percentage of S, SI, I, IR or R). All functions support quasiquotation with pipes, can be used in `summarise()` from the `dplyr` package and also support grouped variables, see *Examples*.
#'
@ -49,7 +49,7 @@
#'
#' Use [sir_confidence_interval()] to calculate the confidence interval, which relies on [binom.test()], i.e., the Clopper-Pearson method. This function returns a vector of length 2 at default for antimicrobial *resistance*. Change the `side` argument to "left"/"min" or "right"/"max" to return a single value, and change the `ab_result` argument to e.g. `c("S", "I")` to test for antimicrobial *susceptibility*, see Examples.
#'
#' **Remember that you should filter your data to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them in your data set.
#' **Remember that you should filter your data to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them in your data set with one of the four available algorithms.
#'
#' These functions are not meant to count isolates, but to calculate the proportion of resistance/susceptibility. Use the [`count()`][AMR::count()] functions to count isolates. The function [susceptibility()] is essentially equal to `count_susceptible() / count_all()`. *Low counts can influence the outcome - the `proportion` functions may camouflage this, since they only return the proportion (albeit being dependent on the `minimum` argument).*
#'
@ -77,11 +77,14 @@
#' ```
#'
#' Please note that, in combination therapies, for `only_all_tested = TRUE` applies that:
#'
#' ```
#' count_S() + count_I() + count_R() = count_all()
#' proportion_S() + proportion_I() + proportion_R() = 1
#' ```
#'
#' and that, in combination therapies, for `only_all_tested = FALSE` applies that:
#'
#' ```
#' count_S() + count_I() + count_R() >= count_all()
#' proportion_S() + proportion_I() + proportion_R() >= 1
@ -98,7 +101,8 @@
#' @examples
#' # example_isolates is a data set available in the AMR package.
#' # run ?example_isolates for more info.
#'
#' example_isolates
#'
#' # base R ------------------------------------------------------------
#' # determines %R
#' resistance(example_isolates$AMX)

12
R/random.R
View File

@ -91,10 +91,10 @@ random_sir <- function(size = NULL, prob_SIR = c(0.33, 0.33, 0.33), ...) {
}
random_exec <- function(type, size, mo = NULL, ab = NULL) {
df <- clinical_breakpoints %pm>%
pm_filter(guideline %like% "EUCAST") %pm>%
pm_arrange(pm_desc(guideline)) %pm>%
subset(guideline == max(guideline) &
df <- clinical_breakpoints %>%
filter(guideline %like% "EUCAST") %>%
arrange(pm_desc(guideline)) %>%
filter(guideline == max(guideline) &
method == type)
if (!is.null(mo)) {
@ -105,7 +105,7 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
as.mo(mo_family(mo_coerced)),
as.mo(mo_order(mo_coerced))
)
df_new <- df %pm>%
df_new <- df %>%
subset(mo %in% mo_include)
if (nrow(df_new) > 0) {
df <- df_new
@ -116,7 +116,7 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
if (!is.null(ab)) {
ab_coerced <- as.ab(ab)
df_new <- df %pm>%
df_new <- df %>%
subset(ab %in% ab_coerced)
if (nrow(df_new) > 0) {
df <- df_new

6
R/resistance_predict.R
View File

@ -125,7 +125,7 @@ resistance_predict <- function(x,
meet_criteria(year_min, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
meet_criteria(year_max, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
meet_criteria(year_every, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
meet_criteria(model, allow_class = c("character", "function"), has_length = 1, allow_NULL = TRUE)
meet_criteria(I_as_S, allow_class = "logical", has_length = 1)
meet_criteria(preserve_measurements, allow_class = "logical", has_length = 1)
@ -260,8 +260,8 @@ resistance_predict <- function(x,
observed = df$R / (df$R + df$S),
stringsAsFactors = FALSE
)
df_prediction <- df_prediction %pm>%
pm_left_join(df_observations, by = "year")
df_prediction <- df_prediction %>%
left_join(df_observations, by = "year")
df_prediction$estimated <- df_prediction$value
if (preserve_measurements == TRUE) {

54
R/sir.R
View File

@ -89,7 +89,7 @@
#'
#' ### Machine-Readable Interpretation Guidelines
#'
#' The repository of this package [contains a machine-readable version](https://github.com/msberends/AMR/blob/main/data-raw/clinical_breakpoints.txt) of all guidelines. This is a CSV file consisting of `r format(nrow(AMR::clinical_breakpoints), big.mark = ",")` rows and `r ncol(AMR::clinical_breakpoints)` columns. This file is machine-readable, since it contains one row for every unique combination of the test method (MIC or disk diffusion), the antimicrobial drug and the microorganism. **This allows for easy implementation of these rules in laboratory information systems (LIS)**. Note that it only contains interpretation guidelines for humans - interpretation guidelines from CLSI for animals were removed.
#' The repository of this package [contains a machine-readable version](https://github.com/msberends/AMR/blob/main/data-raw/clinical_breakpoints.txt) of all guidelines. This is a CSV file consisting of `r format(nrow(AMR::clinical_breakpoints), big.mark = " ")` rows and `r ncol(AMR::clinical_breakpoints)` columns. This file is machine-readable, since it contains one row for every unique combination of the test method (MIC or disk diffusion), the antimicrobial drug and the microorganism. **This allows for easy implementation of these rules in laboratory information systems (LIS)**. Note that it only contains interpretation guidelines for humans - interpretation guidelines from CLSI for animals were removed.
#'
#' ### Other
#'
@ -373,9 +373,9 @@ as.sir.default <- function(x, ...) {
if (!isFALSE(list(...)$warn)) { # so as.sir(..., warn = FALSE) will never throw a warning
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %pm>%
unique() %pm>%
sort() %pm>%
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %>%
unique() %>%
sort() %>%
vector_and(quotes = TRUE)
cur_col <- get_current_column()
warning_("in `as.sir()`: ", na_after - na_before, " result",
@ -543,7 +543,7 @@ as.sir.data.frame <- function(x,
i <- 0
if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) {
sel <- colnames(pm_select(x, ...))
sel <- colnames(select(x, ...))
} else {
sel <- colnames(x)
}
@ -597,10 +597,10 @@ as.sir.data.frame <- function(x,
for (i in seq_len(length(ab_cols))) {
if (types[i] == "mic") {
x[, ab_cols[i]] <- x %pm>%
pm_pull(ab_cols[i]) %pm>%
as.character() %pm>%
as.mic() %pm>%
x[, ab_cols[i]] <- x %>%
pull(ab_cols[i]) %>%
as.character() %>%
as.mic() %>%
as.sir(
mo = x_mo,
mo.bak = x[, col_mo, drop = TRUE],
@ -614,10 +614,10 @@ as.sir.data.frame <- function(x,
is_data.frame = TRUE
)
} else if (types[i] == "disk") {
x[, ab_cols[i]] <- x %pm>%
pm_pull(ab_cols[i]) %pm>%
as.character() %pm>%
as.disk() %pm>%
x[, ab_cols[i]] <- x %>%
pull(ab_cols[i]) %>%
as.character() %>%
as.disk() %>%
as.sir(
mo = x_mo,
mo.bak = x[, col_mo, drop = TRUE],
@ -848,21 +848,21 @@ as_sir_method <- function(method_short,
mo_coerced <- mo
if (identical(reference_data, AMR::clinical_breakpoints)) {
breakpoints <- reference_data %pm>%
breakpoints <- reference_data %>%
subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
if (ab_coerced == "AMX" && nrow(breakpoints) == 0) {
ab_coerced <- "AMP"
breakpoints <- reference_data %pm>%
breakpoints <- reference_data %>%
subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
}
} else {
breakpoints <- reference_data %pm>%
breakpoints <- reference_data %>%
subset(method == method_coerced & ab == ab_coerced)
}
if (isFALSE(include_PKPD)) {
# remove PKPD rules from the breakpoints table
breakpoints <- breakpoints %pm>%
breakpoints <- breakpoints %>%
subset(mo != "UNKNOWN" & ref_tbl %unlike% "PK.*PD")
}
@ -918,7 +918,7 @@ as_sir_method <- function(method_short,
# gather all available breakpoints for current MO and sort on taxonomic rank
# (this will prefer species breakpoints over order breakpoints)
breakpoints_current <- breakpoints %pm>%
breakpoints_current <- breakpoints %>%
subset(mo %in% c(
mo_current_genus, mo_current_family,
mo_current_order, mo_current_class,
@ -927,14 +927,14 @@ as_sir_method <- function(method_short,
))
if (any(uti, na.rm = TRUE)) {
breakpoints_current <- breakpoints_current %pm>%
breakpoints_current <- breakpoints_current %>%
# be as specific as possible (i.e. prefer species over genus):
# the below `pm_desc(uti)` will put `TRUE` on top and FALSE on bottom
pm_arrange(rank_index, pm_desc(uti)) # 'uti' is a column in data set 'clinical_breakpoints'
# the below `desc(uti)` will put `TRUE` on top and FALSE on bottom
arrange(rank_index, desc(uti)) # 'uti' is a column in data set 'clinical_breakpoints'
} else {
breakpoints_current <- breakpoints_current %pm>%
breakpoints_current <- breakpoints_current %>%
# sort UTI = FALSE first, then UTI = TRUE
pm_arrange(rank_index, uti)
arrange(rank_index, uti)
}
# throw notes for different body sites
@ -945,8 +945,8 @@ as_sir_method <- function(method_short,
} else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && any(is.na(uti)) && all(c(TRUE, FALSE) %in% breakpoints_current$uti, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteUTI", mo_unique, ab_coerced)) {
# both UTI and Non-UTI breakpoints available
msgs <- c(msgs, paste0("Breakpoints for UTI ", font_underline("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming non-UTI. Use argument `uti` to set which isolates are from urine. See `?as.sir`."))
breakpoints_current <- breakpoints_current %pm>%
pm_filter(uti == FALSE)
breakpoints_current <- breakpoints_current %>%
filter(uti == FALSE)
} else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && all(breakpoints_current$uti == FALSE, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteOther", mo_unique, ab_coerced)) {
# breakpoints for multiple body sites available
site <- breakpoints_current[1L, "site", drop = FALSE] # this is the one we'll take
@ -974,7 +974,7 @@ as_sir_method <- function(method_short,
}
if (method == "mic") {
new_sir <- quick_case_when(
new_sir <- case_when(
is.na(values) ~ NA_sir_,
values <= breakpoints_current$breakpoint_S ~ as.sir("S"),
guideline_coerced %like% "EUCAST" & values > breakpoints_current$breakpoint_R ~ as.sir("R"),
@ -985,7 +985,7 @@ as_sir_method <- function(method_short,
TRUE ~ NA_sir_
)
} else if (method == "disk") {
new_sir <- quick_case_when(
new_sir <- case_when(
is.na(values) ~ NA_sir_,
as.double(values) >= as.double(breakpoints_current$breakpoint_S) ~ as.sir("S"),
guideline_coerced %like% "EUCAST" & as.double(values) < as.double(breakpoints_current$breakpoint_R) ~ as.sir("R"),

22
R/sir_calc.R
View File

@ -31,7 +31,8 @@ dots2vars <- function(...) {
# this function is to give more informative output about
# variable names in count_* and proportion_* functions
dots <- substitute(list(...))
as.character(dots)[2:length(dots)]
dots <- as.character(dots)[2:length(dots)]
paste0(dots[dots != "."], collapse = "+")
}
sir_calc <- function(...,
@ -41,7 +42,7 @@ sir_calc <- function(...,
only_all_tested = FALSE,
only_count = FALSE) {
meet_criteria(ab_result, allow_class = c("character", "numeric", "integer"), has_length = c(1, 2, 3))
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
meet_criteria(as_percent, allow_class = "logical", has_length = 1)
meet_criteria(only_all_tested, allow_class = "logical", has_length = 1)
meet_criteria(only_count, allow_class = "logical", has_length = 1)
@ -67,7 +68,7 @@ sir_calc <- function(...,
ndots <- length(dots)
if (is.data.frame(dots_df)) {
# data.frame passed with other columns, like: example_isolates %pm>% proportion_S(AMC, GEN)
# data.frame passed with other columns, like: example_isolates %>% proportion_S(AMC, GEN)
dots <- as.character(dots)
# remove first element, it's the data.frame
@ -77,7 +78,7 @@ sir_calc <- function(...,
dots <- dots[2:length(dots)]
}
if (length(dots) == 0 || all(dots == "df")) {
# for complete data.frames, like example_isolates %pm>% select(AMC, GEN) %pm>% proportion_S()
# for complete data.frames, like example_isolates %>% select(AMC, GEN) %>% proportion_S()
# and the old sir function, which has "df" as name of the first argument
x <- dots_df
} else {
@ -92,14 +93,14 @@ sir_calc <- function(...,
x <- dots_df[, dots, drop = FALSE]
}
} else if (ndots == 1) {
# only 1 variable passed (can also be data.frame), like: proportion_S(example_isolates$AMC) and example_isolates$AMC %pm>% proportion_S()
# only 1 variable passed (can also be data.frame), like: proportion_S(example_isolates$AMC) and example_isolates$AMC %>% proportion_S()
x <- dots_df
} else {
# multiple variables passed without pipe, like: proportion_S(example_isolates$AMC, example_isolates$GEN)
x <- NULL
try(x <- as.data.frame(dots, stringsAsFactors = FALSE), silent = TRUE)
if (is.null(x)) {
# support for example_isolates %pm>% group_by(ward) %pm>% summarise(amox = susceptibility(GEN, AMX))
# support for example_isolates %>% group_by(ward) %>% summarise(amox = susceptibility(GEN, AMX))
x <- as.data.frame(list(...), stringsAsFactors = FALSE)
}
}
@ -133,7 +134,7 @@ sir_calc <- function(...,
}
x_transposed <- as.list(as.data.frame(t(x), stringsAsFactors = FALSE))
if (only_all_tested == TRUE) {
if (isTRUE(only_all_tested)) {
# no NAs in any column
y <- apply(
X = as.data.frame(lapply(x, as.integer), stringsAsFactors = FALSE),
@ -170,7 +171,7 @@ sir_calc <- function(...,
if (only_count == TRUE) {
return(numerator)
}
if (denominator < minimum) {
if (data_vars != "") {
data_vars <- paste(" for", data_vars)
@ -224,8 +225,8 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
meet_criteria(type, is_in = c("proportion", "count", "both"), has_length = 1)
meet_criteria(data, allow_class = "data.frame", contains_column_class = "sir")
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
language <- validate_language(language)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE)
meet_criteria(as_percent, allow_class = "logical", has_length = 1)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(confidence_level, allow_class = "numeric", has_length = 1)
@ -355,6 +356,7 @@ sir_calc_df <- function(type, # "proportion", "count" or "both"
if (data_has_groups) {
# ordering by the groups and two more: "antibiotic" and "interpretation"
# (pm_ungroup here, as we do not use dplyr for summarising)
out <- pm_ungroup(out[do.call("order", out[, seq_len(length(groups) + 2), drop = FALSE]), , drop = FALSE])
} else {
out <- out[order(out$antibiotic, out$interpretation), , drop = FALSE]

BIN
R/sysdata.rda
View File

Binary file not shown.

5
R/translate.R
View File

@ -244,9 +244,10 @@ translate_into_language <- function(from,
if (NROW(df_trans) == 0 | !any_form_in_patterns) {
return(from)
}
lapply(
seq_len(nrow(df_trans)),
# starting from last row, since more general translation are on top, such as 'Group'
rev(seq_len(nrow(df_trans))),
function(i) {
from_unique_translated <<- gsub(
pattern = df_trans$pattern[i],

3
R/zzz.R
View File

@ -123,6 +123,7 @@ if (utf8_supported && !is_latex) {
s3_register("ggplot2::autoplot", "mic")
s3_register("ggplot2::autoplot", "disk")
s3_register("ggplot2::autoplot", "resistance_predict")
s3_register("ggplot2::autoplot", "antibiogram")
# Support for fortify from the ggplot2 package
s3_register("ggplot2::fortify", "sir")
s3_register("ggplot2::fortify", "mic")
@ -180,7 +181,7 @@ if (utf8_supported && !is_latex) {
if (pkg_is_available("tibble", also_load = FALSE)) {
try(loadNamespace("tibble"), silent = TRUE)
}
# reference data - they have additional to improve algorithm speed
# they cannot be part of R/sysdata.rda since CRAN thinks it would make the package too large (+3 MB)
AMR_env$AB_lookup <- cbind(AMR::antibiotics, AB_LOOKUP)