P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2024-12-25 07:26:12 +01:00
Code Releases Activity

revert back to pre-antibiogram

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends 2023-02-09 13:07:39 +01:00
parent aa48c6bf53
commit 1a0dc4bf46
53 changed files with 984 additions and 1996 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 1.8.2.9111 Version: 1.8.2.9112
Date: 2023-02-08 Date: 2023-02-09
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by data analysis and to work with microbial and antimicrobial properties by

4
NAMESPACE
View File

@ -73,7 +73,6 @@ S3method(asin,mic)
S3method(asinh,mic) S3method(asinh,mic)
S3method(atan,mic) S3method(atan,mic)
S3method(atanh,mic) S3method(atanh,mic)
S3method(barplot,antibiogram)
S3method(barplot,disk) S3method(barplot,disk)
S3method(barplot,mic) S3method(barplot,mic)
S3method(barplot,rsi) S3method(barplot,rsi)
@ -124,14 +123,12 @@ S3method(mean_amr_distance,mic)
S3method(mean_amr_distance,sir) S3method(mean_amr_distance,sir)
S3method(median,mic) S3method(median,mic)
S3method(min,mic) S3method(min,mic)
S3method(plot,antibiogram)
S3method(plot,disk) S3method(plot,disk)
S3method(plot,mic) S3method(plot,mic)
S3method(plot,resistance_predict) S3method(plot,resistance_predict)
S3method(plot,rsi) S3method(plot,rsi)
S3method(plot,sir) S3method(plot,sir)
S3method(print,ab) S3method(print,ab)
S3method(print,antibiogram)
S3method(print,av) S3method(print,av)
S3method(print,bug_drug_combinations) S3method(print,bug_drug_combinations)
S3method(print,custom_eucast_rules) S3method(print,custom_eucast_rules)
@ -219,7 +216,6 @@ export(aminoglycosides)
export(aminopenicillins) export(aminopenicillins)
export(amr_distance_from_row) export(amr_distance_from_row)
export(anti_join_microorganisms) export(anti_join_microorganisms)
export(antibiogram)
export(antifungals) export(antifungals)
export(antimicrobials_equal) export(antimicrobials_equal)
export(antimycobacterials) export(antimycobacterials)

4
NEWS.md
View File

@ -1,4 +1,4 @@
# AMR 1.8.2.9111 # AMR 1.8.2.9112
*(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)* *(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)*
@ -28,8 +28,6 @@ The 'RSI functions' will be removed in a future version, but not before late 202
### New antibiogram function ### New antibiogram function
Klinker *et al.* (2021, DOI [10.1177/20499361211011373](https://doi.org/10.1177/20499361211011373)) and Barbieri *et al.* (2021, DOI [10.1186/s13756-021-00939-2](https://doi.org/10.1186/s13756-021-00939-2)).
With the new `antibiogram()` function, users can now generate traditional, combined, syndromic, and even weighted-incidence syndromic combination antibiograms (WISCA). With this, we follow the logic in the previously described work of Klinker *et al.* (2021, DOI [10.1177/20499361211011373](https://doi.org/10.1177/20499361211011373)) and Barbieri *et al.* (2021, DOI [10.1186/s13756-021-00939-2](https://doi.org/10.1186/s13756-021-00939-2)). With the new `antibiogram()` function, users can now generate traditional, combined, syndromic, and even weighted-incidence syndromic combination antibiograms (WISCA). With this, we follow the logic in the previously described work of Klinker *et al.* (2021, DOI [10.1177/20499361211011373](https://doi.org/10.1177/20499361211011373)) and Barbieri *et al.* (2021, DOI [10.1186/s13756-021-00939-2](https://doi.org/10.1186/s13756-021-00939-2)).
The help page for `antibiogram()` extensively elaborates on use cases, and `antibiogram()` also supports printing in R Markdown and Quarto, with support for 16 languages. The help page for `antibiogram()` extensively elaborates on use cases, and `antibiogram()` also supports printing in R Markdown and Quarto, with support for 16 languages.

14
R/aa_globals.R
View File

@ -94,9 +94,7 @@ TAXONOMY_VERSION <- list(
) )
globalVariables(c( globalVariables(c(
".mo",
".rowid", ".rowid",
".syndromic_group",
"ab", "ab",
"ab_txt", "ab_txt",
"affect_ab_name", "affect_ab_name",
@ -107,9 +105,8 @@ globalVariables(c(
"atc_group1", "atc_group1",
"atc_group2", "atc_group2",
"base_ab", "base_ab",
"ci_max",
"ci_min", "ci_min",
"clinical_breakpoints", "ci_max",
"code", "code",
"cols", "cols",
"count", "count",
@ -133,15 +130,14 @@ globalVariables(c(
"language", "language",
"lookup", "lookup",
"method", "method",
"mic ",
"mic", "mic",
"mic ",
"microorganism", "microorganism",
"microorganisms", "microorganisms",
"microorganisms.codes", "microorganisms.codes",
"mo", "mo",
"name", "name",
"new", "new",
"numerator",
"observations", "observations",
"old", "old",
"old_name", "old_name",
@ -153,15 +149,13 @@ globalVariables(c(
"reference.rule_group", "reference.rule_group",
"reference.version", "reference.version",
"rowid", "rowid",
"sir",
"clinical_breakpoints",
"rule_group", "rule_group",
"rule_name", "rule_name",
"S",
"se_max", "se_max",
"se_min", "se_min",
"SI",
"sir",
"species", "species",
"syndromic_group",
"total", "total",
"txt", "txt",
"type", "type",

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

@ -63,6 +63,99 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
merged 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 # No export, no Rd
addin_insert_in <- function() { addin_insert_in <- function() {
import_fn("insertText", "rstudioapi")(" %in% ") import_fn("insertText", "rstudioapi")(" %in% ")
@ -259,7 +352,7 @@ is_valid_regex <- function(x) {
} }
stop_ifnot_installed <- function(package) { stop_ifnot_installed <- function(package) {
installed <- vapply(FUN.VALUE = logical(1), package, requireNamespace, lib.loc = base::.libPaths(), quietly = TRUE) installed <- vapply(FUN.VALUE = logical(1), package, requireNamespace, quietly = TRUE)
if (any(!installed) && any(package == "rstudioapi")) { if (any(!installed) && any(package == "rstudioapi")) {
stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE) stop("This function only works in RStudio when using R >= 3.2.", call. = FALSE)
} else if (any(!installed)) { } else if (any(!installed)) {
@ -276,7 +369,7 @@ pkg_is_available <- function(pkg, also_load = TRUE, min_version = NULL) {
if (also_load == TRUE) { if (also_load == TRUE) {
out <- suppressWarnings(require(pkg, character.only = TRUE, warn.conflicts = FALSE)) out <- suppressWarnings(require(pkg, character.only = TRUE, warn.conflicts = FALSE))
} else { } else {
out <- requireNamespace(pkg, lib.loc = base::.libPaths(), quietly = TRUE) out <- requireNamespace(pkg, quietly = TRUE)
} }
if (!is.null(min_version)) { if (!is.null(min_version)) {
out <- out && utils::packageVersion(pkg) >= min_version out <- out && utils::packageVersion(pkg) >= min_version
@ -293,7 +386,7 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
getExportedValue(name = name, ns = asNamespace(pkg)), getExportedValue(name = name, ns = asNamespace(pkg)),
error = function(e) { error = function(e) {
if (isTRUE(error_on_fail)) { 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!", "'. Please create an issue at ", font_url("https://github.com/msberends/AMR/issues"), ". Many thanks!",
call = FALSE call = FALSE
) )
@ -1179,7 +1272,7 @@ create_pillar_column <- function(x, ...) {
new_pillar_shaft_simple(x, ...) new_pillar_shaft_simple(x, ...)
} }
as_original_data_class <- function(df, old_class = NULL, extra_class = NULL) { as_original_data_class <- function(df, old_class = NULL) {
if ("tbl_df" %in% old_class && pkg_is_available("tibble", also_load = FALSE)) { if ("tbl_df" %in% old_class && pkg_is_available("tibble", also_load = FALSE)) {
# this will then also remove groups # this will then also remove groups
fn <- import_fn("as_tibble", "tibble") fn <- import_fn("as_tibble", "tibble")
@ -1192,11 +1285,7 @@ as_original_data_class <- function(df, old_class = NULL, extra_class = NULL) {
} else { } else {
fn <- function(x) base::as.data.frame(df, stringsAsFactors = FALSE) fn <- function(x) base::as.data.frame(df, stringsAsFactors = FALSE)
} }
out <- fn(df) 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 # works exactly like round(), but rounds `round2(44.55, 1)` to 44.6 instead of 44.5
@ -1336,7 +1425,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]") { 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\r\n]". # this is even faster than trimws() itself which sets " \t\n\r".
trimws(..., whitespace = whitespace) trimws(..., whitespace = whitespace)
} }
@ -1347,154 +1436,12 @@ readRDS2 <- function(file, refhook = NULL) {
readRDS(con, refhook = refhook) 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
}
# dplyr/tidyr implementations ----
# take {dplyr} and {tidyr} functions if available, and the slower {poorman} functions otherwise
if (pkg_is_available("dplyr", min_version = "1.0.0", also_load = FALSE)) {
`%>%` <- import_fn("%>%", "dplyr", error_on_fail = FALSE)
across <- import_fn("across", "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)
bind_rows <- import_fn("bind_rows", "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)
mutate <- import_fn("mutate", "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)
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)
where <- import_fn("where", "dplyr", error_on_fail = FALSE)
} else {
`%>%` <- `%pm>%`
across <- pm_across
anti_join <- pm_anti_join
arrange <- pm_arrange
bind_rows <- pm_bind_rows
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
mutate <- pm_mutate
n_distinct <- pm_n_distinct
pull <- pm_pull
rename <- pm_rename
right_join <- pm_right_join
select <- pm_select
semi_join <- pm_semi_join
summarise <- pm_summarise
ungroup <- pm_ungroup
where <- pm_where
}
if (pkg_is_available("tidyr", min_version = "1.0.0", also_load = FALSE)) {
pivot_longer <- import_fn("pivot_longer", "tidyr", error_on_fail = FALSE)
} else {
pivot_longer <- pm_pivot_longer
}
# Faster data.table implementations ---- # Faster data.table implementations ----
match <- function(x, table, ...) { match <- function(x, table, ...) {
chmatch <- import_fn("chmatch", "data.table", error_on_fail = FALSE) chmatch <- import_fn("chmatch", "data.table", error_on_fail = FALSE)
if (!is.null(chmatch) && is.character(x) && is.character(table)) { if (!is.null(chmatch) && is.character(x) && is.character(table)) {
# data.table::chmatch() is much faster than base::match() for character # data.table::chmatch() is 35% faster than base::match() for character
chmatch(x, table, ...) chmatch(x, table, ...)
} else { } else {
base::match(x, table, ...) base::match(x, table, ...)
@ -1503,7 +1450,7 @@ match <- function(x, table, ...) {
`%in%` <- function(x, table) { `%in%` <- function(x, table) {
chin <- import_fn("%chin%", "data.table", error_on_fail = FALSE) chin <- import_fn("%chin%", "data.table", error_on_fail = FALSE)
if (!is.null(chin) && is.character(x) && is.character(table)) { if (!is.null(chin) && is.character(x) && is.character(table)) {
# data.table::`%chin%`() is much faster than base::`%in%`() for character # data.table::`%chin%`() is 20-50% faster than base::`%in%`() for character
chin(x, table) chin(x, table)
} else { } else {
base::`%in%`(x, table) base::`%in%`(x, table)

1707
R/aa_helper_pm_functions.R Normal file → Executable file
View File

File diff suppressed because it is too large Load Diff

9
R/ab_property.R
View File

@ -113,7 +113,8 @@
#' set_ab_names(property = "atc") #' set_ab_names(property = "atc")
#' #'
#' example_isolates %>% #' example_isolates %>%
#' set_ab_names(where(is.sir)) #' set_ab_names(where(is.sir)) %>%
#' colnames()
#' #'
#' example_isolates %>% #' example_isolates %>%
#' set_ab_names(NIT:VAN) %>% #' set_ab_names(NIT:VAN) %>%
@ -334,7 +335,7 @@ ab_url <- function(x, open = FALSE, ...) {
ab_property <- function(x, property = "name", language = get_AMR_locale(), ...) { ab_property <- function(x, property = "name", language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, is_in = colnames(AMR::antibiotics), has_length = 1) meet_criteria(property, is_in = colnames(AMR::antibiotics), has_length = 1)
language <- validate_language(language) meet_criteria(language, is_in = c(LANGUAGES_SUPPORTED, ""), has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(ab_validate(x = x, property = property, ...), language = language) translate_into_language(ab_validate(x = x, property = property, ...), language = language)
} }
@ -359,7 +360,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
if (is.data.frame(data)) { if (is.data.frame(data)) {
if (tryCatch(length(c(...)) > 1, error = function(e) TRUE)) { if (tryCatch(length(c(...)) > 1, error = function(e) TRUE)) {
df <- tryCatch(suppressWarnings(select(data, ...)), df <- tryCatch(suppressWarnings(pm_select(data, ...)),
error = function(e) { error = function(e) {
data[, c(...), drop = FALSE] data[, c(...), drop = FALSE]
}) })
@ -434,7 +435,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
ab_validate <- function(x, property, ...) { ab_validate <- function(x, property, ...) {
if (tryCatch(all(x[!is.na(x)] %in% AMR_env$AB_lookup$ab), error = function(e) FALSE)) { 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] x <- AMR_env$AB_lookup[match(x, AMR_env$AB_lookup$ab), property, drop = TRUE]
} else { } else {
# try to catch an error when inputting an invalid argument # try to catch an error when inputting an invalid argument

14
R/ab_selectors.R
View File

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

0
R/antibiogram.R → R/antibiogram.R.bak
View File

16
R/atc_online.R
View File

@ -139,9 +139,9 @@ atc_online_property <- function(atc_code,
if (property == "groups") { if (property == "groups") {
out <- tryCatch( out <- tryCatch(
read_html(atc_url) %>% read_html(atc_url) %pm>%
html_node("#content") %>% html_node("#content") %pm>%
html_children() %>% html_children() %pm>%
html_node("a"), html_node("a"),
error = function(e) NULL error = function(e) NULL
) )
@ -151,9 +151,9 @@ atc_online_property <- function(atc_code,
} }
# get URLS of items # get URLS of items
hrefs <- out %>% html_attr("href") hrefs <- out %pm>% html_attr("href")
# get text of items # get text of items
texts <- out %>% html_text() texts <- out %pm>% html_text()
# select only text items where URL like "code=" # select only text items where URL like "code="
texts <- texts[grepl("?code=", tolower(hrefs), fixed = TRUE)] texts <- texts[grepl("?code=", tolower(hrefs), fixed = TRUE)]
# last one is antibiotics, skip it # last one is antibiotics, skip it
@ -161,9 +161,9 @@ atc_online_property <- function(atc_code,
returnvalue <- c(list(texts), returnvalue) returnvalue <- c(list(texts), returnvalue)
} else { } else {
out <- tryCatch( out <- tryCatch(
read_html(atc_url) %>% read_html(atc_url) %pm>%
html_nodes("table") %>% html_nodes("table") %pm>%
html_table(header = TRUE) %>% html_table(header = TRUE) %pm>%
as.data.frame(stringsAsFactors = FALSE), as.data.frame(stringsAsFactors = FALSE),
error = function(e) NULL 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(), ...) { av_property <- function(x, property = "name", language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE) meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, is_in = colnames(AMR::antivirals), has_length = 1) meet_criteria(property, is_in = colnames(AMR::antivirals), has_length = 1)
language <- validate_language(language) meet_criteria(language, is_in = c(LANGUAGES_SUPPORTED, ""), has_length = 1, allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(av_validate(x = x, property = property, ...), language = language) translate_into_language(av_validate(x = x, property = property, ...), language = language)
} }

98
R/bug_drug_combinations.R
View File

@ -45,11 +45,8 @@
#' @return The function [bug_drug_combinations()] returns a [data.frame] with columns "mo", "ab", "S", "I", "R" and "total". #' @return The function [bug_drug_combinations()] returns a [data.frame] with columns "mo", "ab", "S", "I", "R" and "total".
#' @examples #' @examples
#' \donttest{ #' \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) #' x <- bug_drug_combinations(example_isolates)
#' head(x)
#' format(x, translate_ab = "name (atc)") #' format(x, translate_ab = "name (atc)")
#' #'
#' # Use FUN to change to transformation of microorganism codes #' # Use FUN to change to transformation of microorganism codes
@ -82,27 +79,7 @@ bug_drug_combinations <- function(x,
} else { } else {
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found") 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 (identical(pivot_longer, import_fn("pivot_longer", "tidyr", error_on_fail = FALSE))) {
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.bak <- x
x <- as.data.frame(x, stringsAsFactors = FALSE) x <- as.data.frame(x, stringsAsFactors = FALSE)
x[, col_mo] <- FUN(x[, col_mo, drop = TRUE], ...) x[, col_mo] <- FUN(x[, col_mo, drop = TRUE], ...)
@ -173,7 +150,7 @@ bug_drug_combinations <- function(x,
res <- do.call(rbind, unname(lapply(grouped, fn, ...))) res <- do.call(rbind, unname(lapply(grouped, fn, ...)))
if (any(groups %in% colnames(res))) { if (any(groups %in% colnames(res))) {
class(res) <- c("grouped_data", class(res)) class(res) <- c("grouped_data", class(res))
res <- pm_groups_set(res, groups[groups %in% colnames(res)]) res <- pm_set_groups(res, groups[groups %in% colnames(res)])
} }
res res
} }
@ -184,7 +161,6 @@ bug_drug_combinations <- function(x,
out <- run_it(x) out <- run_it(x)
} }
rownames(out) <- NULL rownames(out) <- NULL
out <- out %>% arrange(mo, ab)
out <- as_original_data_class(out, class(x.bak)) # will remove tibble groups 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))) structure(out, class = c("bug_drug_combinations", ifelse(data_has_groups, "grouped", character(0)), class(out)))
} }
@ -200,12 +176,12 @@ format.bug_drug_combinations <- function(x,
add_ab_group = TRUE, add_ab_group = TRUE,
remove_intrinsic_resistant = FALSE, remove_intrinsic_resistant = FALSE,
decimal.mark = getOption("OutDec"), decimal.mark = getOption("OutDec"),
big.mark = ifelse(decimal.mark == ",", " ", ","), big.mark = ifelse(decimal.mark == ",", ".", ","),
...) { ...) {
meet_criteria(x, allow_class = "data.frame") meet_criteria(x, allow_class = "data.frame")
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE) meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE)
language <- validate_language(language) 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(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1) meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(add_ab_group, 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) meet_criteria(remove_intrinsic_resistant, allow_class = "logical", has_length = 1)
@ -270,38 +246,46 @@ format.bug_drug_combinations <- function(x,
.data .data
} }
y <- x %>% create_var <- function(.data, ...) {
mutate( dots <- list(...)
for (i in seq_len(length(dots))) {
.data[, names(dots)[i]] <- dots[[i]]
}
.data
}
y <- x %pm>%
create_var(
ab = as.ab(x$ab), ab = as.ab(x$ab),
ab_txt = give_ab_name(ab = x$ab, format = translate_ab, language = language) ab_txt = give_ab_name(ab = x$ab, format = translate_ab, language = language)
) %>% ) %pm>%
group_by(ab, ab_txt, mo) %>% pm_group_by(ab, ab_txt, mo) %pm>%
summarise( pm_summarise(
isolates = sum(isolates, na.rm = TRUE), isolates = sum(isolates, na.rm = TRUE),
total = sum(total, na.rm = TRUE) total = sum(total, na.rm = TRUE)
) %>% ) %pm>%
ungroup() pm_ungroup()
y <- y %>% y <- y %pm>%
mutate(txt = paste0( create_var(txt = paste0(
percentage(y$isolates / y$total, decimal.mark = decimal.mark, big.mark = big.mark), percentage(y$isolates / y$total, decimal.mark = decimal.mark, big.mark = big.mark),
" (", trimws(format(y$isolates, big.mark = big.mark)), "/", " (", trimws(format(y$isolates, big.mark = big.mark)), "/",
trimws(format(y$total, big.mark = big.mark)), ")" trimws(format(y$total, big.mark = big.mark)), ")"
)) %>% )) %pm>%
select(ab, ab_txt, mo, txt) %>% pm_select(ab, ab_txt, mo, txt) %pm>%
arrange(mo) pm_arrange(mo)
# replace tidyr::pivot_wider() from here # replace tidyr::pivot_wider() from here
for (i in unique(y$mo)) { for (i in unique(y$mo)) {
mo_group <- y[which(y$mo == i), c("ab", "txt"), drop = FALSE] mo_group <- y[which(y$mo == i), c("ab", "txt"), drop = FALSE]
colnames(mo_group) <- c("ab", i) colnames(mo_group) <- c("ab", i)
rownames(mo_group) <- NULL rownames(mo_group) <- NULL
y <- y %>% y <- y %pm>%
left_join(mo_group, by = "ab") pm_left_join(mo_group, by = "ab")
} }
y <- y %>% y <- y %pm>%
distinct(ab, .keep_all = TRUE) %>% pm_distinct(ab, .keep_all = TRUE) %pm>%
select(-mo, -txt) %>% pm_select(-mo, -txt) %pm>%
# replace tidyr::pivot_wider() until here # replace tidyr::pivot_wider() until here
remove_NAs() remove_NAs()
@ -309,21 +293,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] .data[, c("ab_group", "ab_txt", colnames(.data)[!colnames(.data) %in% c("ab_group", "ab_txt", "ab")]), drop = FALSE]
} }
y <- y %>% y <- y %pm>%
mutate(ab_group = ab_group(y$ab, language = language)) %>% create_var(ab_group = ab_group(y$ab, language = language)) %pm>%
select_ab_vars() %>% select_ab_vars() %pm>%
arrange(ab_group, ab_txt) pm_arrange(ab_group, ab_txt)
y <- y %>% y <- y %pm>%
mutate(ab_group = ifelse(y$ab_group != lag(y$ab_group) | is.na(lag(y$ab_group)), y$ab_group, "")) create_var(ab_group = ifelse(y$ab_group != pm_lag(y$ab_group) | is.na(pm_lag(y$ab_group)), y$ab_group, ""))
if (add_ab_group == FALSE) { if (add_ab_group == FALSE) {
y <- y %>% y <- y %pm>%
select(-ab_group) %>% pm_select(-ab_group) %pm>%
rename("Drug" = ab_txt) pm_rename("Drug" = ab_txt)
colnames(y)[1] <- translate_into_language(colnames(y)[1], language, only_unknown = FALSE) colnames(y)[1] <- translate_into_language(colnames(y)[1], language, only_unknown = FALSE)
} else { } else {
y <- y %>% y <- y %pm>%
rename( pm_rename(
"Group" = ab_group, "Group" = ab_group,
"Drug" = ab_txt "Drug" = ab_txt
) )

30
R/data.R
View File

@ -27,7 +27,7 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ # # 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. #' 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 #' @format
@ -82,10 +82,10 @@
#' @rdname antibiotics #' @rdname antibiotics
"antivirals" "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()]. #' 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 #' - `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. #' - `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)` #' - `status` \cr Status of the taxon, either `r vector_or(microorganisms$status)`
@ -150,10 +150,10 @@
#' microorganisms #' microorganisms
"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. #' 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 #' - `code`\cr Commonly used code of a microorganism
#' - `mo`\cr ID of the microorganism in the [microorganisms] data set #' - `mo`\cr ID of the microorganism in the [microorganisms] data set
#' @details #' @details
@ -163,10 +163,10 @@
#' microorganisms.codes #' microorganisms.codes
"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). #' 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: #' @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 #' - `date`\cr Date of receipt at the laboratory
#' - `patient`\cr ID of the patient #' - `patient`\cr ID of the patient
#' - `age`\cr Age of the patient #' - `age`\cr Age of the patient
@ -182,8 +182,8 @@
#' Data Set with Unclean Data #' 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. #' 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: #' @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 #' - `patient_id`\cr ID of the patient
#' - `date`\cr date of receipt at the laboratory #' - `date`\cr date of receipt at the laboratory
#' - `hospital`\cr ID of the hospital, from A to C #' - `hospital`\cr ID of the hospital, from A to C
@ -195,10 +195,10 @@
#' example_isolates_unclean #' example_isolates_unclean
"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. #' 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 #' - `Identification number`\cr ID of the sample
#' - `Specimen number`\cr ID of the specimen #' - `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()]. #' - `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 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. #' 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 #' - `guideline`\cr Name of the guideline
#' - `method`\cr Either `r vector_or(clinical_breakpoints$method)` #' - `method`\cr Either `r vector_or(clinical_breakpoints$method)`
#' - `site`\cr Body site, e.g. "Oral" or "Respiratory" #' - `site`\cr Body site, e.g. "Oral" or "Respiratory"
@ -258,7 +258,7 @@
#' Data Set with Bacterial Intrinsic Resistance #' Data Set with Bacterial Intrinsic Resistance
#' #'
#' Data set containing defined intrinsic resistance by EUCAST of all bug-drug combinations. #' 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 #' - `mo`\cr Microorganism ID
#' - `ab`\cr Antibiotic ID #' - `ab`\cr Antibiotic ID
#' @details #' @details
@ -275,7 +275,7 @@
#' Data Set with Treatment Dosages as Defined by EUCAST #' 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()]. #' 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 #' - `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 #' - `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)` #' - `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)]) na_after <- length(x[is.na(x)])
if (na_before != na_after) { if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %>% list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %pm>%
unique() %>% unique() %pm>%
sort() %>% sort() %pm>%
vector_and(quotes = TRUE) vector_and(quotes = TRUE)
cur_col <- get_current_column() cur_col <- get_current_column()
warning_("in `as.disk()`: ", na_after - na_before, " result", warning_("in `as.disk()`: ", na_after - na_before, " result",

90
R/eucast_rules.R
View File

@ -331,12 +331,12 @@ eucast_rules <- function(x,
# Some helper functions --------------------------------------------------- # Some helper functions ---------------------------------------------------
get_antibiotic_names <- function(x) { get_antibiotic_names <- function(x) {
x <- x %>% x <- x %pm>%
strsplit(",") %>% strsplit(",") %pm>%
unlist() %>% unlist() %pm>%
trimws2() %>% 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) %>% 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() %>% sort() %pm>%
paste(collapse = ", ") paste(collapse = ", ")
x <- gsub("_", " ", x, fixed = TRUE) x <- gsub("_", " ", x, fixed = TRUE)
x <- gsub("except CAZ", paste("except", ab_name("CAZ", language = NULL, tolower = TRUE)), 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 # save original table, with the new .rowid column
x.bak <- x x.bak <- x
# keep only unique rows for MO and ABx # keep only unique rows for MO and ABx
x <- x %>% x <- x %pm>%
arrange(`.rowid`) %>% pm_arrange(`.rowid`) %pm>%
# big speed gain! only analyse unique rows: # big speed gain! only analyse unique rows:
distinct(`.rowid`, .keep_all = TRUE) %>% pm_distinct(`.rowid`, .keep_all = TRUE) %pm>%
as.data.frame(stringsAsFactors = FALSE) as.data.frame(stringsAsFactors = FALSE)
x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]), info = info) x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]), info = info)
# rename col_mo to prevent interference with joined columns # rename col_mo to prevent interference with joined columns
@ -925,16 +925,16 @@ eucast_rules <- function(x,
# Print overview ---------------------------------------------------------- # Print overview ----------------------------------------------------------
if (isTRUE(info) || isTRUE(verbose)) { if (isTRUE(info) || isTRUE(verbose)) {
verbose_info <- x.bak %>% verbose_info <- x.bak %pm>%
mutate(row = seq_len(NROW(x.bak))) %>% pm_mutate(row = pm_row_number()) %pm>%
select(`.rowid`, row) %>% pm_select(`.rowid`, row) %pm>%
right_join(verbose_info, pm_right_join(verbose_info,
by = c(".rowid" = "rowid") by = c(".rowid" = "rowid")
) %>% ) %pm>%
select(-`.rowid`) %>% pm_select(-`.rowid`) %pm>%
select(row, everything()) %>% pm_select(row, pm_everything()) %pm>%
filter(!is.na(new) | is.na(new) & !is.na(old)) %>% pm_filter(!is.na(new) | is.na(new) & !is.na(old)) %pm>%
arrange(row, rule_group, rule_name, col) pm_arrange(row, rule_group, rule_name, col)
rownames(verbose_info) <- NULL rownames(verbose_info) <- NULL
} }
@ -949,7 +949,7 @@ eucast_rules <- function(x,
cat(word_wrap(paste0( cat(word_wrap(paste0(
"The rules ", paste0(wouldve, "affected "), "The rules ", paste0(wouldve, "affected "),
font_bold( font_bold(
formatnr(n_distinct(verbose_info$row)), formatnr(pm_n_distinct(verbose_info$row)),
"out of", formatnr(nrow(x.bak)), "out of", formatnr(nrow(x.bak)),
"rows" "rows"
), ),
@ -957,8 +957,8 @@ eucast_rules <- function(x,
font_bold(formatnr(nrow(verbose_info)), "edits\n") font_bold(formatnr(nrow(verbose_info)), "edits\n")
))) )))
total_n_added <- verbose_info %>% filter(is.na(old)) %>% nrow() total_n_added <- verbose_info %pm>% pm_filter(is.na(old)) %pm>% nrow()
total_n_changed <- verbose_info %>% filter(!is.na(old)) %>% nrow() total_n_changed <- verbose_info %pm>% pm_filter(!is.na(old)) %pm>% nrow()
# print added values # print added values
if (total_n_added == 0) { if (total_n_added == 0) {
@ -968,15 +968,15 @@ eucast_rules <- function(x,
} }
cat(colour(paste0( cat(colour(paste0(
"=> ", wouldve, "added ", "=> ", wouldve, "added ",
font_bold(formatnr(verbose_info %>% font_bold(formatnr(verbose_info %pm>%
filter(is.na(old)) %>% pm_filter(is.na(old)) %pm>%
nrow()), "test results"), nrow()), "test results"),
"\n" "\n"
))) )))
if (total_n_added > 0) { if (total_n_added > 0) {
added_summary <- verbose_info %>% added_summary <- verbose_info %pm>%
filter(is.na(old)) %>% pm_filter(is.na(old)) %pm>%
count(new, name = "n") pm_count(new, name = "n")
cat(paste(" -", cat(paste(" -",
paste0( paste0(
formatnr(added_summary$n), " test result", ifelse(added_summary$n > 1, "s", ""), formatnr(added_summary$n), " test result", ifelse(added_summary$n > 1, "s", ""),
@ -997,16 +997,16 @@ eucast_rules <- function(x,
} }
cat(colour(paste0( cat(colour(paste0(
"=> ", wouldve, "changed ", "=> ", wouldve, "changed ",
font_bold(formatnr(verbose_info %>% font_bold(formatnr(verbose_info %pm>%
filter(!is.na(old)) %>% pm_filter(!is.na(old)) %pm>%
nrow()), "test results"), nrow()), "test results"),
"\n" "\n"
))) )))
if (total_n_changed > 0) { if (total_n_changed > 0) {
changed_summary <- verbose_info %>% changed_summary <- verbose_info %pm>%
filter(!is.na(old)) %>% pm_filter(!is.na(old)) %pm>%
mutate(new = ifelse(is.na(new), "NA", new)) %>% pm_mutate(new = ifelse(is.na(new), "NA", new)) %pm>%
count(old, new, name = "n") pm_count(old, new, name = "n")
cat(paste(" -", cat(paste(" -",
paste0( paste0(
formatnr(changed_summary$n), " test result", ifelse(changed_summary$n > 1, "s", ""), " changed from ", 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 was analysed with only unique rows, so join everything together again
x <- x[, c(cols_ab, ".rowid"), drop = FALSE] x <- x[, c(cols_ab, ".rowid"), drop = FALSE]
x.bak <- x.bak[, setdiff(colnames(x.bak), cols_ab), drop = FALSE] x.bak <- x.bak[, setdiff(colnames(x.bak), cols_ab), drop = FALSE]
x.bak <- x.bak %>% x.bak <- x.bak %pm>%
left_join(x, by = ".rowid") pm_left_join(x, by = ".rowid")
x.bak <- x.bak[, old_cols, drop = FALSE] x.bak <- x.bak[, old_cols, drop = FALSE]
# reset original attributes # reset original attributes
attributes(x.bak) <- old_attributes attributes(x.bak) <- old_attributes
@ -1103,8 +1103,8 @@ edit_sir <- function(x,
if (w$message %like% "invalid factor level") { if (w$message %like% "invalid factor level") {
xyz <- vapply(FUN.VALUE = logical(1), cols, function(col) { xyz <- vapply(FUN.VALUE = logical(1), cols, function(col) {
new_edits[, col] <<- factor( new_edits[, col] <<- factor(
x = as.character(pull(new_edits, col)), x = as.character(pm_pull(new_edits, col)),
levels = unique(c(to, levels(pull(new_edits, col)))) levels = unique(c(to, levels(pm_pull(new_edits, col))))
) )
TRUE TRUE
}) })
@ -1159,22 +1159,22 @@ edit_sir <- function(x,
"rowid", "col", "mo_fullname", "old", "new", "rowid", "col", "mo_fullname", "old", "new",
"rule", "rule_group", "rule_name", "rule_source" "rule", "rule_group", "rule_name", "rule_source"
) )
verbose_new <- verbose_new %>% filter(old != new | is.na(old) | is.na(new) & !is.na(old)) verbose_new <- verbose_new %pm>% pm_filter(old != new | is.na(old) | is.na(new) & !is.na(old))
# save changes to data set 'verbose_info' # save changes to data set 'verbose_info'
track_changes$verbose_info <- rbind(track_changes$verbose_info, track_changes$verbose_info <- rbind(track_changes$verbose_info,
verbose_new, verbose_new,
stringsAsFactors = FALSE stringsAsFactors = FALSE
) )
# count adds and changes # count adds and changes
track_changes$added <- track_changes$added + verbose_new %>% track_changes$added <- track_changes$added + verbose_new %pm>%
filter(is.na(old)) %>% pm_filter(is.na(old)) %pm>%
pull(rowid) %>% pm_pull(rowid) %pm>%
get_original_rows() %>% get_original_rows() %pm>%
length() length()
track_changes$changed <- track_changes$changed + verbose_new %>% track_changes$changed <- track_changes$changed + verbose_new %pm>%
filter(!is.na(old)) %>% pm_filter(!is.na(old)) %pm>%
pull(rowid) %>% pm_pull(rowid) %pm>%
get_original_rows() %>% get_original_rows() %pm>%
length() 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 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_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_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 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_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_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_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_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`. #' @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,14 +71,17 @@
#' | **Isolate-based** | `first_isolate(x, method = "isolate-based")` | #' | **Isolate-based** | `first_isolate(x, method = "isolate-based")` |
#' | *(= all isolates)* | | #' | *(= all isolates)* | |
#' | | | #' | | |
#' | | |
#' | **Patient-based** | `first_isolate(x, method = "patient-based")` | #' | **Patient-based** | `first_isolate(x, method = "patient-based")` |
#' | *(= first isolate per patient)* | | #' | *(= first isolate per patient)* | |
#' | | | #' | | |
#' | | |
#' | **Episode-based** | `first_isolate(x, method = "episode-based")`, or: | #' | **Episode-based** | `first_isolate(x, method = "episode-based")`, or: |
#' | *(= first isolate per episode)* | | #' | *(= first isolate per episode)* | |
#' | - 7-Day interval from initial isolate | - `first_isolate(x, method = "e", episode_days = 7)` | #' | - 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)` | #' | - 30-Day interval from initial isolate | - `first_isolate(x, method = "e", episode_days = 30)` |
#' | | | #' | | |
#' | | |
#' | **Phenotype-based** | `first_isolate(x, method = "phenotype-based")`, or: | #' | **Phenotype-based** | `first_isolate(x, method = "phenotype-based")`, or: |
#' | *(= first isolate per phenotype)* | | #' | *(= first isolate per phenotype)* | |
#' | - Major difference in any antimicrobial result | - `first_isolate(x, type = "points")` | #' | - Major difference in any antimicrobial result | - `first_isolate(x, type = "points")` |
@ -130,7 +133,7 @@
#' # `example_isolates` is a data set available in the AMR package. #' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates. #' # See ?example_isolates.
#' #'
#' example_isolates[first_isolate(info = TRUE), ] #' example_isolates[first_isolate(), ]
#' \donttest{ #' \donttest{
#' # get all first Gram-negatives #' # get all first Gram-negatives
#' example_isolates[which(first_isolate(info = FALSE) & mo_is_gram_negative()), ] #' example_isolates[which(first_isolate(info = FALSE) & mo_is_gram_negative()), ]
@ -138,7 +141,7 @@
#' if (require("dplyr")) { #' if (require("dplyr")) {
#' # filter on first isolates using dplyr: #' # filter on first isolates using dplyr:
#' example_isolates %>% #' example_isolates %>%
#' filter(first_isolate(info = TRUE)) #' filter(first_isolate())
#' } #' }
#' if (require("dplyr")) { #' if (require("dplyr")) {
#' # short-hand version: #' # short-hand version:
@ -149,7 +152,7 @@
#' # flag the first isolates per group: #' # flag the first isolates per group:
#' example_isolates %>% #' example_isolates %>%
#' group_by(ward) %>% #' group_by(ward) %>%
#' mutate(first = first_isolate(info = FALSE)) %>% #' mutate(first = first_isolate()) %>%
#' select(ward, date, patient, mo, first) #' select(ward, date, patient, mo, first)
#' } #' }
#' } #' }
@ -391,17 +394,17 @@ first_isolate <- function(x = NULL,
} else { } else {
# filtering on specimen and only analyse these rows to save time # filtering on specimen and only analyse these rows to save time
x <- x[order( x <- x[order(
pull(x, col_specimen), pm_pull(x, col_specimen),
x$newvar_patient_id, x$newvar_patient_id,
x$newvar_genus_species, x$newvar_genus_species,
x$newvar_date x$newvar_date
), ] ), ]
rownames(x) <- NULL rownames(x) <- NULL
suppressWarnings( suppressWarnings(
row.start <- which(x %>% pull(col_specimen) == specimen_group) %>% min(na.rm = TRUE) row.start <- which(x %pm>% pm_pull(col_specimen) == specimen_group) %pm>% min(na.rm = TRUE)
) )
suppressWarnings( suppressWarnings(
row.end <- which(x %>% pull(col_specimen) == specimen_group) %>% max(na.rm = TRUE) row.end <- which(x %pm>% pm_pull(col_specimen) == specimen_group) %pm>% max(na.rm = TRUE)
) )
} }
@ -424,7 +427,7 @@ first_isolate <- function(x = NULL,
} }
return(TRUE) return(TRUE)
} }
if (length(c(row.start:row.end)) == n_distinct(x[c(row.start:row.end), col_mo, drop = TRUE])) { if (length(c(row.start:row.end)) == pm_n_distinct(x[c(row.start:row.end), col_mo, drop = TRUE])) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_("=> Found ", font_bold(paste(length(c(row.start:row.end)), "first isolates")), message_("=> Found ", font_bold(paste(length(c(row.start:row.end)), "first isolates")),
", as all isolates were different microbial species", ", as all isolates were different microbial species",
@ -462,7 +465,7 @@ first_isolate <- function(x = NULL,
} }
} }
x$other_pat_or_mo <- !(x$newvar_patient_id == lag(x$newvar_patient_id) & x$newvar_genus_species == lag(x$newvar_genus_species)) 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$episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species) x$episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species)
x$more_than_episode_ago <- unlist( x$more_than_episode_ago <- unlist(
@ -482,21 +485,29 @@ first_isolate <- function(x = NULL,
# with key antibiotics # with key antibiotics
x$other_key_ab <- !antimicrobials_equal( x$other_key_ab <- !antimicrobials_equal(
y = x$newvar_key_ab, y = x$newvar_key_ab,
z = lag(x$newvar_key_ab), z = pm_lag(x$newvar_key_ab),
type = type, type = type,
ignore_I = ignore_I, ignore_I = ignore_I,
points_threshold = points_threshold points_threshold = points_threshold
) )
x$newvar_first_isolate <- x$newvar_row_index_sorted >= row.start & x$newvar_first_isolate <- pm_if_else(
x$newvar_row_index_sorted <= row.end & x$newvar_row_index_sorted >= row.start &
x$newvar_genus_species != "" & x$newvar_row_index_sorted <= row.end &
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab) x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab),
TRUE,
FALSE
)
} else { } else {
# no key antibiotics # no key antibiotics
x$newvar_first_isolate <- x$newvar_row_index_sorted >= row.start & x$newvar_first_isolate <- pm_if_else(
x$newvar_row_index_sorted <= row.end & x$newvar_row_index_sorted >= row.start &
x$newvar_genus_species != "" & x$newvar_row_index_sorted <= row.end &
(x$other_pat_or_mo | x$more_than_episode_ago) x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago),
TRUE,
FALSE
)
} }
# first one as TRUE # first one as TRUE
@ -507,14 +518,12 @@ first_isolate <- function(x = NULL,
} }
if (!is.null(col_icu)) { if (!is.null(col_icu)) {
if (icu_exclude == TRUE) { if (icu_exclude == TRUE) {
if (isTRUE(info)) { message_("Excluding ", format(sum(col_icu, na.rm = TRUE), big.mark = ","), " isolates from ICU.",
message_("Excluding ", format(sum(col_icu, na.rm = TRUE), big.mark = ","), " isolates from ICU.", add_fn = font_black,
add_fn = font_black, as_note = FALSE
as_note = FALSE )
)
}
x[which(col_icu), "newvar_first_isolate"] <- FALSE x[which(col_icu), "newvar_first_isolate"] <- FALSE
} else if (isTRUE(info)) { } else {
message_("Including isolates from ICU.", message_("Including isolates from ICU.",
add_fn = font_black, add_fn = font_black,
as_note = FALSE as_note = FALSE
@ -523,7 +532,7 @@ first_isolate <- function(x = NULL,
} }
decimal.mark <- getOption("OutDec") decimal.mark <- getOption("OutDec")
big.mark <- ifelse(decimal.mark != ",", ",", " ") big.mark <- ifelse(decimal.mark != ",", ",", ".")
if (isTRUE(info)) { if (isTRUE(info)) {
# print group name if used in dplyr::group_by() # print group name if used in dplyr::group_by()

10
R/get_episode.R
View File

@ -109,7 +109,7 @@
get_episode <- function(x, episode_days, ...) { get_episode <- function(x, episode_days, ...) {
meet_criteria(x, allow_class = c("Date", "POSIXt"), allow_NA = TRUE) 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) meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = FALSE)
exec_episode( exec_episode(
x = x, x = x,
episode_days = episode_days, episode_days = episode_days,
@ -127,10 +127,10 @@ is_new_episode <- function(x, episode_days, ...) {
exec_episode <- function(x, type, episode_days, ...) { exec_episode <- function(x, type, episode_days, ...) {
x <- as.double(as.POSIXct(x)) # as.POSIXct() required for Date classes 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 # since x is now in seconds, get seconds from episode_days as well
episode_seconds <- episode_days * 60 * 60 * 24 episode_seconds <- episode_days * 60 * 60 * 24
if (length(x) == 1) { # this will also match 1 NA, which is fine if (length(x) == 1) { # this will also match 1 NA, which is fine
return(1) return(1)
} else if (length(x) == 2 && !all(is.na(x))) { } else if (length(x) == 2 && !all(is.na(x))) {
@ -140,7 +140,7 @@ exec_episode <- function(x, type, episode_days, ...) {
return(c(1, 1)) return(c(1, 1))
} }
} }
# we asked on StackOverflow: # we asked on StackOverflow:
# https://stackoverflow.com/questions/42122245/filter-one-row-every-year # https://stackoverflow.com/questions/42122245/filter-one-row-every-year
run_episodes <- function(x, episode_seconds) { run_episodes <- function(x, episode_seconds) {
@ -157,7 +157,7 @@ exec_episode <- function(x, type, episode_days, ...) {
} }
indices indices
} }
ord <- order(x) ord <- order(x)
out <- run_episodes(x[ord], episode_seconds)[order(ord)] out <- run_episodes(x[ord], episode_seconds)[order(ord)]
out[is.na(x) & ord != 1] <- NA # every NA expect for the first must remain NA out[is.na(x) & ord != 1] <- NA # every NA expect for the first must remain NA

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(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(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(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_positive_or_zero = TRUE, is_finite = TRUE) meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
language <- validate_language(language) 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(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")) 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(x, allow_class = "character", has_length = 1)
meet_criteria(fill, 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(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_positive_or_zero = TRUE, is_finite = TRUE) meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1) 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(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(x, allow_class = "character", has_length = 1)
meet_criteria(translate_ab, allow_class = c("character", "logical"), has_length = 1, allow_NA = TRUE) 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_positive_or_zero = TRUE, is_finite = TRUE) meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
language <- validate_language(language) language <- validate_language(language)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1) 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) 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 language = language
) )
transformed$gr <- transformed[, x_name, drop = TRUE] transformed$gr <- transformed[, x_name, drop = TRUE]
transformed %>% transformed %pm>%
group_by(gr) %>% pm_group_by(gr) %pm>%
mutate(lbl = paste0("n=", isolates)) %>% pm_mutate(lbl = paste0("n=", isolates)) %pm>%
ungroup() %>% pm_ungroup() %pm>%
select(-gr) pm_select(-gr)
} }
) )
} }

11
R/join_microorganisms.R
View File

@ -159,9 +159,14 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
by <- stats::setNames("mo", by) by <- stats::setNames("mo", by)
} }
# this will use dplyr if available, and the slower poorman otherwise, see R/aaa_helper_pm_functions.R # use dplyr if available - it's much faster than poorman alternatives
join_fn <- get(type, envir = asNamespace("AMR")) 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"))
}
MO_df <- AMR_env$MO_lookup[, colnames(AMR::microorganisms), drop = FALSE] MO_df <- AMR_env$MO_lookup[, colnames(AMR::microorganisms), drop = FALSE]
if (type %like% "full|left|right|inner") { if (type %like% "full|left|right|inner") {
joined <- join_fn(x = x, y = MO_df, by = by, suffix = suffix, ...) 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)) { if (!is.null(out)) {
df <- df[, out, drop = FALSE] df <- df[, out, drop = FALSE]
} else { } else {
df <- select(df, ...) df <- pm_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)] 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 ## previously unempty values now empty - should return a warning later on
x[x.bak != "" & x == ""] <- "invalid" x[x.bak != "" & x == ""] <- "invalid"
na_before <- x[is.na(x) | x == ""] %>% length() na_before <- x[is.na(x) | x == ""] %pm>% length()
x[!x %in% valid_mic_levels] <- NA x[!x %in% valid_mic_levels] <- NA
na_after <- x[is.na(x) | x == ""] %>% length() na_after <- x[is.na(x) | x == ""] %pm>% length()
if (na_before != na_after) { if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %>% list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %pm>%
unique() %>% unique() %pm>%
sort() %>% sort() %pm>%
vector_and(quotes = TRUE) vector_and(quotes = TRUE)
cur_col <- get_current_column() cur_col <- get_current_column()
warning_("in `as.mic()`: ", na_after - na_before, " result", 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 # markup NA and UNKNOWN
out[is.na(x)] <- font_na(" NA") out[is.na(x)] <- font_na(" NA")
out[x == "UNKNOWN"] <- font_na(" UNKNOWN") out[x == "UNKNOWN"] <- font_na(" UNKNOWN")
# markup manual codes # 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) 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), df <- tryCatch(get_current_data(arg_name = "x", call = 0),
error = function(e) NULL 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))) { (!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) {
# markup old mo codes # markup old mo codes
out[!x %in% all_mos] <- font_italic( out[!x %in% all_mos] <- font_italic(
font_na(font_stripstyle(out[!x %in% all_mos]), font_na(x[!x %in% all_mos],
collapse = NULL collapse = NULL
), ),
collapse = NULL collapse = NULL
@ -627,7 +627,7 @@ freq.mo <- function(x, ...) {
.add_header = list( .add_header = list(
`Gram-negative` = paste0( `Gram-negative` = paste0(
format(sum(grams == "Gram-negative", na.rm = TRUE), format(sum(grams == "Gram-negative", na.rm = TRUE),
big.mark = " ", big.mark = ",",
decimal.mark = "." decimal.mark = "."
), ),
" (", percentage(sum(grams == "Gram-negative", na.rm = TRUE) / length(grams), " (", percentage(sum(grams == "Gram-negative", na.rm = TRUE) / length(grams),
@ -637,7 +637,7 @@ freq.mo <- function(x, ...) {
), ),
`Gram-positive` = paste0( `Gram-positive` = paste0(
format(sum(grams == "Gram-positive", na.rm = TRUE), format(sum(grams == "Gram-positive", na.rm = TRUE),
big.mark = " ", big.mark = ",",
decimal.mark = "." decimal.mark = "."
), ),
" (", percentage(sum(grams == "Gram-positive", na.rm = TRUE) / length(grams), " (", percentage(sum(grams == "Gram-positive", na.rm = TRUE) / length(grams),
@ -645,8 +645,8 @@ freq.mo <- function(x, ...) {
), ),
")" ")"
), ),
`Nr. of genera` = n_distinct(mo_genus(x_noNA, language = NULL)), `Nr. of genera` = pm_n_distinct(mo_genus(x_noNA, language = NULL)),
`Nr. of species` = n_distinct(paste( `Nr. of species` = pm_n_distinct(paste(
mo_genus(x_noNA, language = NULL), mo_genus(x_noNA, language = NULL),
mo_species(x_noNA, language = NULL) mo_species(x_noNA, language = NULL)
)) ))
@ -1155,14 +1155,14 @@ repair_reference_df <- function(reference_df) {
return(NULL) return(NULL)
} }
# has valid own reference_df # has valid own reference_df
reference_df <- reference_df %>% reference_df <- reference_df %pm>%
filter(!is.na(mo)) pm_filter(!is.na(mo))
# keep only first two columns, second must be mo # keep only first two columns, second must be mo
if (colnames(reference_df)[1] == "mo") { if (colnames(reference_df)[1] == "mo") {
reference_df <- reference_df %>% select(2, "mo") reference_df <- reference_df %pm>% pm_select(2, "mo")
} else { } else {
reference_df <- reference_df %>% select(1, "mo") reference_df <- reference_df %pm>% pm_select(1, "mo")
} }
# remove factors, just keep characters # 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*. #' 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 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)` #' @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"`
#' @inheritParams as.mo #' @inheritParams as.mo
#' @param ... other arguments passed on to [as.mo()], such as 'minimum_matching_score', 'ignore_pattern', and 'remove_from_input' #' @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()] #' @param ab any (vector of) text that can be coerced to a valid antibiotic drug code with [as.ab()]
@ -900,16 +900,12 @@ mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ..
} }
# get property reeaaally fast using match() # get property reeaaally fast using match()
if (property == "snomed") { x <- AMR_env$MO_lookup[[property]][match(x, AMR_env$MO_lookup$mo)]
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") { if (property == "mo") {
return(set_clean_class(x, new_class = c("mo", "character"))) return(set_clean_class(x, new_class = c("mo", "character")))
} else if (property == "snomed") { } else if (property == "snomed") {
return(x) return(sort(as.character(eval(parse(text = x)))))
} else if (property == "prevalence") { } else if (property == "prevalence") {
return(as.double(x)) return(as.double(x))
} else { } 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 <- cbind(x.bak[, vapply(FUN.VALUE = logical(1), x.bak, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE], x)
} }
x <- ungroup(x) # would otherwise select the grouping vars x <- pm_ungroup(x) # would otherwise select the grouping vars
x <- x[rowSums(is.na(x)) == 0, ] # remove columns containing NAs 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] 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) data$x <- factor(data$x, levels = c("S", "I", "R"), ordered = TRUE)
ymax <- ifelse(max(data$s) > 95, 105, 100) ymax <- pm_if_else(max(data$s) > 95, 105, 100)
plot( plot(
x = data$x, x = data$x,
@ -615,7 +615,7 @@ plot.sir <- function(x,
axes = FALSE axes = FALSE
) )
# x axis # x axis
axis(side = 1, at = 1:n_distinct(data$x), labels = levels(data$x), lwd = 0) axis(side = 1, at = 1:pm_n_distinct(data$x), labels = levels(data$x), lwd = 0)
# y axis, 0-100% # y axis, 0-100%
axis(side = 2, at = seq(0, 100, 5)) 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/ # # how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== # # ==================================================================== #
#' Calculate Antimicrobial Resistance #' Calculate Microbial 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*. #' @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. #' 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 with one of the four available algorithms. #' **Remember that you should filter your data to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them in your data set.
#' #'
#' These functions are not meant to count isolates, but to calculate the proportion of resistance/susceptibility. Use the [`count()`][AMR::count()] functions to count isolates. The function [susceptibility()] is essentially equal to `count_susceptible() / count_all()`. *Low counts can influence the outcome - the `proportion` functions may camouflage this, since they only return the proportion (albeit being dependent on the `minimum` argument).* #' 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,14 +77,11 @@
#' ``` #' ```
#' #'
#' Please note that, in combination therapies, for `only_all_tested = TRUE` applies that: #' Please note that, in combination therapies, for `only_all_tested = TRUE` applies that:
#'
#' ``` #' ```
#' count_S() + count_I() + count_R() = count_all() #' count_S() + count_I() + count_R() = count_all()
#' proportion_S() + proportion_I() + proportion_R() = 1 #' proportion_S() + proportion_I() + proportion_R() = 1
#' ``` #' ```
#'
#' and that, in combination therapies, for `only_all_tested = FALSE` applies that: #' and that, in combination therapies, for `only_all_tested = FALSE` applies that:
#'
#' ``` #' ```
#' count_S() + count_I() + count_R() >= count_all() #' count_S() + count_I() + count_R() >= count_all()
#' proportion_S() + proportion_I() + proportion_R() >= 1 #' proportion_S() + proportion_I() + proportion_R() >= 1
@ -101,8 +98,7 @@
#' @examples #' @examples
#' # example_isolates is a data set available in the AMR package. #' # example_isolates is a data set available in the AMR package.
#' # run ?example_isolates for more info. #' # run ?example_isolates for more info.
#' example_isolates #'
#'
#' # base R ------------------------------------------------------------ #' # base R ------------------------------------------------------------
#' # determines %R #' # determines %R
#' resistance(example_isolates$AMX) #' 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) { random_exec <- function(type, size, mo = NULL, ab = NULL) {
df <- clinical_breakpoints %>% df <- clinical_breakpoints %pm>%
filter(guideline %like% "EUCAST") %>% pm_filter(guideline %like% "EUCAST") %pm>%
arrange(pm_desc(guideline)) %>% pm_arrange(pm_desc(guideline)) %pm>%
filter(guideline == max(guideline) & subset(guideline == max(guideline) &
method == type) method == type)
if (!is.null(mo)) { 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_family(mo_coerced)),
as.mo(mo_order(mo_coerced)) as.mo(mo_order(mo_coerced))
) )
df_new <- df %>% df_new <- df %pm>%
subset(mo %in% mo_include) subset(mo %in% mo_include)
if (nrow(df_new) > 0) { if (nrow(df_new) > 0) {
df <- df_new df <- df_new
@ -116,7 +116,7 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
if (!is.null(ab)) { if (!is.null(ab)) {
ab_coerced <- as.ab(ab) ab_coerced <- as.ab(ab)
df_new <- df %>% df_new <- df %pm>%
subset(ab %in% ab_coerced) subset(ab %in% ab_coerced)
if (nrow(df_new) > 0) { if (nrow(df_new) > 0) {
df <- df_new 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_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_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(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_positive_or_zero = TRUE, is_finite = TRUE) meet_criteria(minimum, allow_class = c("numeric", "integer"), has_length = 1, is_finite = TRUE)
meet_criteria(model, allow_class = c("character", "function"), has_length = 1, allow_NULL = 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(I_as_S, allow_class = "logical", has_length = 1)
meet_criteria(preserve_measurements, 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), observed = df$R / (df$R + df$S),
stringsAsFactors = FALSE stringsAsFactors = FALSE
) )
df_prediction <- df_prediction %>% df_prediction <- df_prediction %pm>%
left_join(df_observations, by = "year") pm_left_join(df_observations, by = "year")
df_prediction$estimated <- df_prediction$value df_prediction$estimated <- df_prediction$value
if (preserve_measurements == TRUE) { if (preserve_measurements == TRUE) {

54
R/sir.R
View File

@ -89,7 +89,7 @@
#' #'
#' ### Machine-Readable Interpretation Guidelines #' ### 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 #' ### 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 (!isFALSE(list(...)$warn)) { # so as.sir(..., warn = FALSE) will never throw a warning
if (na_before != na_after) { if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %>% list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %pm>%
unique() %>% unique() %pm>%
sort() %>% sort() %pm>%
vector_and(quotes = TRUE) vector_and(quotes = TRUE)
cur_col <- get_current_column() cur_col <- get_current_column()
warning_("in `as.sir()`: ", na_after - na_before, " result", warning_("in `as.sir()`: ", na_after - na_before, " result",
@ -543,7 +543,7 @@ as.sir.data.frame <- function(x,
i <- 0 i <- 0
if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) { if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) {
sel <- colnames(select(x, ...)) sel <- colnames(pm_select(x, ...))
} else { } else {
sel <- colnames(x) sel <- colnames(x)
} }
@ -597,10 +597,10 @@ as.sir.data.frame <- function(x,
for (i in seq_len(length(ab_cols))) { for (i in seq_len(length(ab_cols))) {
if (types[i] == "mic") { if (types[i] == "mic") {
x[, ab_cols[i]] <- x %>% x[, ab_cols[i]] <- x %pm>%
pull(ab_cols[i]) %>% pm_pull(ab_cols[i]) %pm>%
as.character() %>% as.character() %pm>%
as.mic() %>% as.mic() %pm>%
as.sir( as.sir(
mo = x_mo, mo = x_mo,
mo.bak = x[, col_mo, drop = TRUE], mo.bak = x[, col_mo, drop = TRUE],
@ -614,10 +614,10 @@ as.sir.data.frame <- function(x,
is_data.frame = TRUE is_data.frame = TRUE
) )
} else if (types[i] == "disk") { } else if (types[i] == "disk") {
x[, ab_cols[i]] <- x %>% x[, ab_cols[i]] <- x %pm>%
pull(ab_cols[i]) %>% pm_pull(ab_cols[i]) %pm>%
as.character() %>% as.character() %pm>%
as.disk() %>% as.disk() %pm>%
as.sir( as.sir(
mo = x_mo, mo = x_mo,
mo.bak = x[, col_mo, drop = TRUE], mo.bak = x[, col_mo, drop = TRUE],
@ -848,21 +848,21 @@ as_sir_method <- function(method_short,
mo_coerced <- mo mo_coerced <- mo
if (identical(reference_data, AMR::clinical_breakpoints)) { if (identical(reference_data, AMR::clinical_breakpoints)) {
breakpoints <- reference_data %>% breakpoints <- reference_data %pm>%
subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced) subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
if (ab_coerced == "AMX" && nrow(breakpoints) == 0) { if (ab_coerced == "AMX" && nrow(breakpoints) == 0) {
ab_coerced <- "AMP" ab_coerced <- "AMP"
breakpoints <- reference_data %>% breakpoints <- reference_data %pm>%
subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced) subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
} }
} else { } else {
breakpoints <- reference_data %>% breakpoints <- reference_data %pm>%
subset(method == method_coerced & ab == ab_coerced) subset(method == method_coerced & ab == ab_coerced)
} }
if (isFALSE(include_PKPD)) { if (isFALSE(include_PKPD)) {
# remove PKPD rules from the breakpoints table # remove PKPD rules from the breakpoints table
breakpoints <- breakpoints %>% breakpoints <- breakpoints %pm>%
subset(mo != "UNKNOWN" & ref_tbl %unlike% "PK.*PD") 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 # gather all available breakpoints for current MO and sort on taxonomic rank
# (this will prefer species breakpoints over order breakpoints) # (this will prefer species breakpoints over order breakpoints)
breakpoints_current <- breakpoints %>% breakpoints_current <- breakpoints %pm>%
subset(mo %in% c( subset(mo %in% c(
mo_current_genus, mo_current_family, mo_current_genus, mo_current_family,
mo_current_order, mo_current_class, mo_current_order, mo_current_class,
@ -927,14 +927,14 @@ as_sir_method <- function(method_short,
)) ))
if (any(uti, na.rm = TRUE)) { if (any(uti, na.rm = TRUE)) {
breakpoints_current <- breakpoints_current %>% breakpoints_current <- breakpoints_current %pm>%
# be as specific as possible (i.e. prefer species over genus): # be as specific as possible (i.e. prefer species over genus):
# the below `desc(uti)` will put `TRUE` on top and FALSE on bottom # the below `pm_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' pm_arrange(rank_index, pm_desc(uti)) # 'uti' is a column in data set 'clinical_breakpoints'
} else { } else {
breakpoints_current <- breakpoints_current %>% breakpoints_current <- breakpoints_current %pm>%
# sort UTI = FALSE first, then UTI = TRUE # sort UTI = FALSE first, then UTI = TRUE
arrange(rank_index, uti) pm_arrange(rank_index, uti)
} }
# throw notes for different body sites # 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)) { } 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 # 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`.")) 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 %>% breakpoints_current <- breakpoints_current %pm>%
filter(uti == FALSE) pm_filter(uti == FALSE)
} else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && all(breakpoints_current$uti == FALSE, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteOther", mo_unique, ab_coerced)) { } else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && all(breakpoints_current$uti == FALSE, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteOther", mo_unique, ab_coerced)) {
# breakpoints for multiple body sites available # breakpoints for multiple body sites available
site <- breakpoints_current[1L, "site", drop = FALSE] # this is the one we'll take 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") { if (method == "mic") {
new_sir <- case_when( new_sir <- quick_case_when(
is.na(values) ~ NA_sir_, is.na(values) ~ NA_sir_,
values <= breakpoints_current$breakpoint_S ~ as.sir("S"), values <= breakpoints_current$breakpoint_S ~ as.sir("S"),
guideline_coerced %like% "EUCAST" & values > breakpoints_current$breakpoint_R ~ as.sir("R"), 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_ TRUE ~ NA_sir_
) )
} else if (method == "disk") { } else if (method == "disk") {
new_sir <- case_when( new_sir <- quick_case_when(
is.na(values) ~ NA_sir_, is.na(values) ~ NA_sir_,
as.double(values) >= as.double(breakpoints_current$breakpoint_S) ~ as.sir("S"), as.double(values) >= as.double(breakpoints_current$breakpoint_S) ~ as.sir("S"),
guideline_coerced %like% "EUCAST" & as.double(values) < as.double(breakpoints_current$breakpoint_R) ~ as.sir("R"), guideline_coerced %like% "EUCAST" & as.double(values) < as.double(breakpoints_current$breakpoint_R) ~ as.sir("R"),

24
R/sir_calc.R
View File

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

5
R/translate.R
View File

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

3
R/zzz.R
View File

@ -123,7 +123,6 @@ if (utf8_supported && !is_latex) {
s3_register("ggplot2::autoplot", "mic") s3_register("ggplot2::autoplot", "mic")
s3_register("ggplot2::autoplot", "disk") s3_register("ggplot2::autoplot", "disk")
s3_register("ggplot2::autoplot", "resistance_predict") s3_register("ggplot2::autoplot", "resistance_predict")
s3_register("ggplot2::autoplot", "antibiogram")
# Support for fortify from the ggplot2 package # Support for fortify from the ggplot2 package
s3_register("ggplot2::fortify", "sir") s3_register("ggplot2::fortify", "sir")
s3_register("ggplot2::fortify", "mic") s3_register("ggplot2::fortify", "mic")
@ -181,7 +180,7 @@ if (utf8_supported && !is_latex) {
if (pkg_is_available("tibble", also_load = FALSE)) { if (pkg_is_available("tibble", also_load = FALSE)) {
try(loadNamespace("tibble"), silent = TRUE) try(loadNamespace("tibble"), silent = TRUE)
} }
# reference data - they have additional to improve algorithm speed # 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) # 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) AMR_env$AB_lookup <- cbind(AMR::antibiotics, AB_LOOKUP)

132
inst/tinytest/test-antibiogram.R
View File

@ -1,132 +0,0 @@
# ==================================================================== #
# TITLE #
# AMR: An R Package for Working with Antimicrobial Resistance Data #
# #
# SOURCE #
# https://github.com/msberends/AMR #
# #
# CITE AS #
# Berends MS, Luz CF, Friedrich AW, Sinha BNM, Albers CJ, Glasner C #
# (2022). AMR: An R Package for Working with Antimicrobial Resistance #
# Data. Journal of Statistical Software, 104(3), 1-31. #
# doi:10.18637/jss.v104.i03 #
# #
# Developed at the University of Groningen and the University Medical #
# Center Groningen in The Netherlands, in collaboration with many #
# colleagues from around the world, see our website. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# We created this package for both routine data analysis and academic #
# research and it was publicly released in the hope that it will be #
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
# #
# Visit our website for the full manual and a complete tutorial about #
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
# Traditional antibiogram ----------------------------------------------
ab1 <- antibiogram(example_isolates,
antibiotics = c(aminoglycosides(), carbapenems()))
ab2 <- antibiogram(example_isolates,
antibiotics = aminoglycosides(),
ab_transform = "atc",
mo_transform = "gramstain")
ab3 <- antibiogram(example_isolates,
antibiotics = carbapenems(),
ab_transform = "name",
mo_transform = "name")
expect_inherits(ab1, "antibiogram")
expect_inherits(ab2, "antibiogram")
expect_inherits(ab3, "antibiogram")
expect_equal(colnames(ab1), c("Pathogen (N min-max)", "AMK", "GEN", "IPM", "KAN", "MEM", "TOB"))
expect_equal(colnames(ab2), c("Pathogen (N min-max)", "J01GB01", "J01GB03", "J01GB04", "J01GB06"))
expect_equal(colnames(ab3), c("Pathogen (N min-max)", "Imipenem", "Meropenem"))
expect_equal(ab3$Meropenem, c(52, NA, 100, 100, NA))
# Combined antibiogram -------------------------------------------------
# combined antibiotics yield higher empiric coverage
ab4 <- antibiogram(example_isolates,
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"),
mo_transform = "gramstain")
ab5 <- antibiogram(example_isolates,
antibiotics = c("TZP", "TZP+TOB"),
mo_transform = "gramstain",
ab_transform = "name",
sep = " & ",
add_total_n = FALSE)
expect_inherits(ab4, "antibiogram")
expect_inherits(ab5, "antibiogram")
expect_equal(colnames(ab4), c("Pathogen (N min-max)", "TZP", "TZP + GEN", "TZP + TOB"))
expect_equal(colnames(ab5), c("Pathogen", "Piperacillin/tazobactam", "Piperacillin/tazobactam & Tobramycin"))
# Syndromic antibiogram ------------------------------------------------
# the data set could contain a filter for e.g. respiratory specimens
ab6 <- 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"), ]
ab7 <- antibiogram(ex1,
antibiotics = aminoglycosides(),
ab_transform = "name",
syndromic_group = ifelse(ex1$ward == "ICU",
"UCI", "No UCI"),
language = "es")
expect_inherits(ab6, "antibiogram")
expect_inherits(ab7, "antibiogram")
expect_equal(colnames(ab6), c("Syndromic Group", "Pathogen (N min-max)", "AMK", "GEN", "IPM", "KAN", "MEM", "TOB"))
expect_equal(colnames(ab7), c("Grupo sindrómico", "Patógeno (N min-max)", "Amikacina", "Gentamicina", "Tobramicina"))
# Weighted-incidence syndromic combination antibiogram (WISCA) ---------
# the data set could contain a filter for e.g. respiratory specimens
ab8 <- 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"))
expect_inherits(ab8, "antibiogram")
expect_equal(colnames(ab8), c("Syndromic Group", "Pathogen (N min-max)", "AMC", "AMC + CIP", "TZP", "TZP + TOB"))
# Generate plots with ggplot2 or base R --------------------------------
pdf(NULL) # prevent Rplots.pdf being created
expect_silent(plot(ab1))
expect_silent(plot(ab2))
expect_silent(plot(ab3))
expect_silent(plot(ab4))
expect_silent(plot(ab5))
expect_silent(plot(ab6))
expect_silent(plot(ab7))
expect_silent(plot(ab8))
if (AMR:::pkg_is_available("ggplot2")) {
expect_inherits(autoplot(ab1), "gg")
expect_inherits(autoplot(ab2), "gg")
expect_inherits(autoplot(ab3), "gg")
expect_inherits(autoplot(ab4), "gg")
expect_inherits(autoplot(ab5), "gg")
expect_inherits(autoplot(ab6), "gg")
expect_inherits(autoplot(ab7), "gg")
expect_inherits(autoplot(ab8), "gg")
}

2
inst/tinytest/test-first_isolate.R
View File

@ -228,7 +228,7 @@ expect_identical(
# notice that all mo's are distinct, so all are TRUE # notice that all mo's are distinct, so all are TRUE
expect_true(all(first_isolate(AMR:::distinct(example_isolates, mo, .keep_all = TRUE), info = TRUE) == TRUE)) expect_true(all(first_isolate(AMR:::pm_distinct(example_isolates, mo, .keep_all = TRUE), info = TRUE) == TRUE))
# only one isolate, so return fast # only one isolate, so return fast
expect_true(first_isolate(data.frame(mo = "Escherichia coli", date = Sys.Date(), patient = "patient"), info = TRUE)) expect_true(first_isolate(data.frame(mo = "Escherichia coli", date = Sys.Date(), patient = "patient"), info = TRUE))

26
inst/tinytest/test-zzz.R
View File

@ -32,21 +32,11 @@
# functions used by import_fn() # functions used by import_fn()
import_functions <- c( import_functions <- c(
"%>%" = "dplyr",
"%chin%" = "data.table", "%chin%" = "data.table",
"across" = "dplyr",
"anti_join" = "dplyr", "anti_join" = "dplyr",
"arrange" = "dplyr",
"bind_rows" = "dplyr",
"chmatch" = "data.table", "chmatch" = "data.table",
"count" = "dplyr",
"cur_column" = "dplyr", "cur_column" = "dplyr",
"desc" = "dplyr",
"distinct" = "dplyr",
"everything" = "dplyr",
"full_join" = "dplyr", "full_join" = "dplyr",
"group_by" = "dplyr",
"group_vars" = "dplyr",
"has_internet" = "curl", "has_internet" = "curl",
"html_attr" = "rvest", "html_attr" = "rvest",
"html_children" = "rvest", "html_children" = "rvest",
@ -56,24 +46,13 @@ import_functions <- c(
"html_text" = "rvest", "html_text" = "rvest",
"inner_join" = "dplyr", "inner_join" = "dplyr",
"insertText" = "rstudioapi", "insertText" = "rstudioapi",
"kable" = "knitr",
"lag" = "dplyr",
"left_join" = "dplyr", "left_join" = "dplyr",
"mutate" = "dplyr",
"n_distinct" = "dplyr",
"new_pillar_shaft_simple" = "pillar", "new_pillar_shaft_simple" = "pillar",
"pivot_longer" = "tidyr",
"progress_bar" = "progress", "progress_bar" = "progress",
"pull" = "dplyr",
"read_html" = "xml2", "read_html" = "xml2",
"rename" = "dplyr",
"right_join" = "dplyr", "right_join" = "dplyr",
"select" = "dplyr",
"semi_join" = "dplyr", "semi_join" = "dplyr",
"showQuestion" = "rstudioapi", "showQuestion" = "rstudioapi"
"summarise" = "dplyr",
"ungroup" = "dplyr",
"where" = "dplyr"
) )
# functions that are called directly with :: # functions that are called directly with ::
@ -92,7 +71,6 @@ call_functions <- c(
"element_text" = "ggplot2", "element_text" = "ggplot2",
"expand_limits" = "ggplot2", "expand_limits" = "ggplot2",
"facet_wrap" = "ggplot2", "facet_wrap" = "ggplot2",
"geom_col" = "ggplot2",
"geom_errorbar" = "ggplot2", "geom_errorbar" = "ggplot2",
"geom_path" = "ggplot2", "geom_path" = "ggplot2",
"geom_point" = "ggplot2", "geom_point" = "ggplot2",
@ -137,7 +115,7 @@ for (i in seq_len(length(import_functions))) {
# function should exist in foreign pkg namespace # function should exist in foreign pkg namespace
if (AMR:::pkg_is_available(pkg, if (AMR:::pkg_is_available(pkg,
also_load = FALSE, also_load = FALSE,
min_version = if (pkg %in% c("dplyr", "tidyr")) "1.0.0" else NULL min_version = if (pkg == "dplyr") "1.0.0" else NULL
)) { )) {
tst <- !is.null(AMR:::import_fn(name = fn, pkg = pkg, error_on_fail = FALSE)) tst <- !is.null(AMR:::import_fn(name = fn, pkg = pkg, error_on_fail = FALSE))
expect_true(tst, expect_true(tst,

3
man/ab_property.Rd
View File

@ -163,7 +163,8 @@ if (require("dplyr")) {
set_ab_names(property = "atc") set_ab_names(property = "atc")
example_isolates \%>\% example_isolates \%>\%
set_ab_names(where(is.sir)) set_ab_names(where(is.sir)) \%>\%
colnames()
example_isolates \%>\% example_isolates \%>\%
set_ab_names(NIT:VAN) \%>\% set_ab_names(NIT:VAN) \%>\%

234
man/antibiogram.Rd
View File

@ -1,234 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/antibiogram.R
\name{antibiogram}
\alias{antibiogram}
\alias{plot.antibiogram}
\alias{autoplot.antibiogram}
\alias{print.antibiogram}
\title{Generate Antibiogram: Traditional, Combined, Syndromic, or Weighted-Incidence Syndromic Combination (WISCA)}
\source{
\itemize{
\item Klinker KP \emph{et al.} (2021). \strong{Antimicrobial stewardship and antibiograms: importance of moving beyond traditional antibiograms}. \emph{Therapeutic Advances in Infectious Disease}, May 5;8:20499361211011373; \doi{10.1177/20499361211011373}
\item Barbieri E \emph{et al.} (2021). \strong{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} \emph{Antimicrobial Resistance & Infection Control} May 1;10(1):74; \doi{10.1186/s13756-021-00939-2}
\item \strong{M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 5th Edition}, 2022, \emph{Clinical and Laboratory Standards Institute (CLSI)}. \url{https://clsi.org/standards/products/microbiology/documents/m39/}.
}
}
\usage{
antibiogram(
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 = " + "
)
\method{plot}{antibiogram}(x, ...)
\method{autoplot}{antibiogram}(object, ...)
\method{print}{antibiogram}(x, as_kable = !interactive(), ...)
}
\arguments{
\item{x}{a \link{data.frame} containing at least a column with microorganisms and columns with antibiotic results (class 'sir', see \code{\link[=as.sir]{as.sir()}})}
\item{antibiotics}{vector of column names, or (any combinations of) \link[=antibiotic_class_selectors]{antibiotic selectors} such as \code{\link[=aminoglycosides]{aminoglycosides()}} or \code{\link[=carbapenems]{carbapenems()}}. For combination antibiograms, this can also be column names separated with \code{"+"}, such as "TZP+TOB" given that the data set contains columns "TZP" and "TOB". See \emph{Examples}.}
\item{mo_transform}{a character to transform microorganism input - must be "name", "shortname", "gramstain", or one of the column names of the \link{microorganisms} data set: "mo", "fullname", "status", "kingdom", "phylum", "class", "order", "family", "genus", "species", "subspecies", "rank", "ref", "source", "lpsn", "lpsn_parent", "lpsn_renamed_to", "gbif", "gbif_parent", "gbif_renamed_to", "prevalence" or "snomed". Can also be \code{NULL} to not transform the input.}
\item{ab_transform}{a character to transform antibiotic input - must be one of the column names of the \link{antibiotics} data set: "ab", "cid", "name", "group", "atc", "atc_group1", "atc_group2", "abbreviations", "synonyms", "oral_ddd", "oral_units", "iv_ddd", "iv_units" or "loinc". Can also be \code{NULL} to not transform the input.}
\item{syndromic_group}{a column name of \code{x}, or values calculated to split rows of \code{x}, e.g. by using \code{\link[=ifelse]{ifelse()}} or \code{\link[dplyr:case_when]{case_when()}}. See \emph{Examples}.}
\item{add_total_n}{a \link{logical} to indicate whether total available numbers per pathogen should be added to the table (defaults to \code{TRUE}). This will add the lowest and highest number of available isolate per antibiotic (e.g, if for \emph{E. coli} 200 isolates are available for ciprofloxacin and 150 for amoxicillin, the returned number will be "150-200").}
\item{only_all_tested}{(for combination antibiograms): a \link{logical} to indicate that isolates must be tested for all antibiotics, see \emph{Details}}
\item{digits}{number of digits to use for rounding}
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
\item{language}{language to translate text, which defaults to the system language (see \code{\link[=get_AMR_locale]{get_AMR_locale()}})}
\item{minimum}{the minimum allowed number of available (tested) isolates. Any isolate count lower than \code{minimum} will return \code{NA} with a warning. The default number of \code{30} isolates is advised by the Clinical and Laboratory Standards Institute (CLSI) as best practice, see \emph{Source}.}
\item{combine_SI}{a \link{logical} to indicate whether all susceptibility should be determined by results of either S or I, instead of only S (defaults to \code{TRUE})}
\item{sep}{a separating character for antibiotic columns in combination antibiograms}
\item{...}{method extensions}
\item{object}{an \code{\link[=antibiogram]{antibiogram()}} object}
\item{as_kable}{a \link{logical} to indicate whether the printing should be done using \code{\link[knitr:kable]{knitr::kable()}} (which is the default in non-interactive sessions)}
}
\description{
Generate an antibiogram, and communicate the results in plots or tables. These functions follow the logic of Klinker \emph{et al.} (2021, \doi{10.1177/20499361211011373}) and Barbieri \emph{et al.} (2021, \doi{10.1186/s13756-021-00939-2}), and allow reporting in e.g. R Markdown and Quarto as well.
}
\details{
This function returns a table with values between 0 and 100 for \emph{susceptibility}, not resistance.
\strong{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 \code{\link[=first_isolate]{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 \emph{et al.} (2021, \doi{10.1177/20499361211011373}), and they are all supported by \code{\link[=antibiogram]{antibiogram()}}:
\enumerate{
\item \strong{Traditional Antibiogram}
Case example: Susceptibility of \emph{Pseudomonas aeruginosa} to piperacillin/tazobactam (TZP)
Code example:
\if{html}{\out{<div class="sourceCode r">}}\preformatted{antibiogram(your_data,
antibiotics = "TZP")
}\if{html}{\out{</div>}}
\item \strong{Combination Antibiogram}
Case example: Additional susceptibility of \emph{Pseudomonas aeruginosa} to TZP + tobramycin versus TZP alone
Code example:
\if{html}{\out{<div class="sourceCode r">}}\preformatted{antibiogram(your_data,
antibiotics = c("TZP", "TZP+TOB", "TZP+GEN"))
}\if{html}{\out{</div>}}
\item \strong{Syndromic Antibiogram}
Case example: Susceptibility of \emph{Pseudomonas aeruginosa} to TZP among respiratory specimens (obtained among ICU patients only)
Code example:
\if{html}{\out{<div class="sourceCode r">}}\preformatted{antibiogram(your_data,
antibiotics = penicillins(),
syndromic_group = "ward")
}\if{html}{\out{</div>}}
\item \strong{Weighted-Incidence Syndromic Combination Antibiogram (WISCA)}
Case example: Susceptibility of \emph{Pseudomonas aeruginosa} to TZP among respiratory specimens (obtained among ICU patients only) for male patients age >=65 years with heart failure
Code example:
\if{html}{\out{<div class="sourceCode r">}}\preformatted{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"))
}\if{html}{\out{</div>}}
}
All types of antibiograms can be generated with the functions as described on this page, and can be plotted (using \code{\link[ggplot2:autoplot]{ggplot2::autoplot()}} or base \R \code{\link[=plot]{plot()}}/\code{\link[=barplot]{barplot()}}) or printed into R Markdown / Quarto formats for reports. Use functions from specific 'table reporting' packages to transform the output of \code{\link[=antibiogram]{antibiogram()}} to your needs, e.g. \code{flextable::as_flextable()} or \code{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 \code{only_all_tested} argument (defaults to \code{FALSE}). See this example for two antibiotics, Drug A and Drug B, about how \code{\link[=antibiogram]{antibiogram()}} works to calculate the \%SI:
\if{html}{\out{<div class="sourceCode">}}\preformatted{--------------------------------------------------------------------
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> - - - -
--------------------------------------------------------------------
}\if{html}{\out{</div>}}
Printing the antibiogram in non-interactive sessions will be done by \code{\link[knitr:kable]{knitr::kable()}}, with support for \link[knitr:kable]{all their implemented formats}, such as "markdown". The knitr format will be automatically determined if printed inside a knitr document (LaTeX, HTML, etc.).
}
\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)
}
}

2
man/antibiotic_class_selectors.Rd
View File

@ -110,7 +110,7 @@ not_intrinsic_resistant(
\item{filter}{an \link{expression} to be evaluated in the \link{antibiotics} data set, such as \code{name \%like\% "trim"}} \item{filter}{an \link{expression} to be evaluated in the \link{antibiotics} data set, such as \code{name \%like\% "trim"}}
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.} \item{col_mo}{column name of the IDs of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
\item{version_expertrules}{the version number to use for the EUCAST Expert Rules and Intrinsic Resistance guideline. Can be either "3.3", "3.2" or "3.1".} \item{version_expertrules}{the version number to use for the EUCAST Expert Rules and Intrinsic Resistance guideline. Can be either "3.3", "3.2" or "3.1".}
} }

4
man/as.sir.Rd
View File

@ -94,7 +94,7 @@ sir_interpretation_history(clean = FALSE)
\item{include_PKPD}{a \link{logical} to indicate that PK/PD clinical breakpoints must be applied as a last resort, defaults to \code{TRUE}. Can also be set with the option \code{\link[=AMR-options]{AMR_include_PKPD}}.} \item{include_PKPD}{a \link{logical} to indicate that PK/PD clinical breakpoints must be applied as a last resort, defaults to \code{TRUE}. Can also be set with the option \code{\link[=AMR-options]{AMR_include_PKPD}}.}
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.} \item{col_mo}{column name of the IDs of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
\item{clean}{a \link{logical} to indicate whether previously stored results should be forgotten after returning the 'logbook' with results} \item{clean}{a \link{logical} to indicate whether previously stored results should be forgotten after returning the 'logbook' with results}
} }
@ -156,7 +156,7 @@ After using \code{\link[=as.sir]{as.sir()}}, you can use the \code{\link[=eucast
\subsection{Machine-Readable Interpretation Guidelines}{ \subsection{Machine-Readable Interpretation Guidelines}{
The repository of this package \href{https://github.com/msberends/AMR/blob/main/data-raw/clinical_breakpoints.txt}{contains a machine-readable version} of all guidelines. This is a CSV file consisting of 18 308 rows and 11 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. \strong{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 \href{https://github.com/msberends/AMR/blob/main/data-raw/clinical_breakpoints.txt}{contains a machine-readable version} of all guidelines. This is a CSV file consisting of 18,308 rows and 11 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. \strong{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.
} }
\subsection{Other}{ \subsection{Other}{

9
man/bug_drug_combinations.Rd
View File

@ -16,14 +16,14 @@ bug_drug_combinations(x, col_mo = NULL, FUN = mo_shortname, ...)
add_ab_group = TRUE, add_ab_group = TRUE,
remove_intrinsic_resistant = FALSE, remove_intrinsic_resistant = FALSE,
decimal.mark = getOption("OutDec"), decimal.mark = getOption("OutDec"),
big.mark = ifelse(decimal.mark == ",", " ", ","), big.mark = ifelse(decimal.mark == ",", ".", ","),
... ...
) )
} }
\arguments{ \arguments{
\item{x}{a data set with antibiotic columns, such as \code{amox}, \code{AMX} and \code{AMC}} \item{x}{a data set with antibiotic columns, such as \code{amox}, \code{AMX} and \code{AMC}}
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.} \item{col_mo}{column name of the IDs of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
\item{FUN}{the function to call on the \code{mo} column to transform the microorganism codes, defaults to \code{\link[=mo_shortname]{mo_shortname()}}} \item{FUN}{the function to call on the \code{mo} column to transform the microorganism codes, defaults to \code{\link[=mo_shortname]{mo_shortname()}}}
@ -59,11 +59,8 @@ The function \code{\link[=format]{format()}} calculates the resistance per bug-d
} }
\examples{ \examples{
\donttest{ \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) x <- bug_drug_combinations(example_isolates)
head(x)
format(x, translate_ab = "name (atc)") format(x, translate_ab = "name (atc)")
# Use FUN to change to transformation of microorganism codes # Use FUN to change to transformation of microorganism codes

2
man/clinical_breakpoints.Rd
View File

@ -5,7 +5,7 @@
\alias{clinical_breakpoints} \alias{clinical_breakpoints}
\title{Data Set with Clinical Breakpoints for SIR Interpretation} \title{Data Set with Clinical Breakpoints for SIR Interpretation}
\format{ \format{
A \link[tibble:tibble]{tibble} with 18 308 observations and 11 variables: A \link[tibble:tibble]{tibble} with 18,308 observations and 11 variables:
\itemize{ \itemize{
\item \code{guideline}\cr Name of the guideline \item \code{guideline}\cr Name of the guideline
\item \code{method}\cr Either "DISK" or "MIC" \item \code{method}\cr Either "DISK" or "MIC"

2
man/eucast_rules.Rd
View File

@ -38,7 +38,7 @@ eucast_dosage(ab, administration = "iv", version_breakpoints = 12)
\arguments{ \arguments{
\item{x}{a data set with antibiotic columns, such as \code{amox}, \code{AMX} and \code{AMC}} \item{x}{a data set with antibiotic columns, such as \code{amox}, \code{AMX} and \code{AMC}}
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.} \item{col_mo}{column name of the IDs of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
\item{info}{a \link{logical} to indicate whether progress should be printed to the console, defaults to only print while in interactive sessions} \item{info}{a \link{logical} to indicate whether progress should be printed to the console, defaults to only print while in interactive sessions}

6
man/example_isolates.Rd
View File

@ -3,9 +3,9 @@
\docType{data} \docType{data}
\name{example_isolates} \name{example_isolates}
\alias{example_isolates} \alias{example_isolates}
\title{Data Set with 2 000 Example Isolates} \title{Data Set with 2,000 Example Isolates}
\format{ \format{
A \link[tibble:tibble]{tibble} with 2 000 observations and 46 variables: A \link[tibble:tibble]{tibble} with 2,000 observations and 46 variables:
\itemize{ \itemize{
\item \code{date}\cr Date of receipt at the laboratory \item \code{date}\cr Date of receipt at the laboratory
\item \code{patient}\cr ID of the patient \item \code{patient}\cr ID of the patient
@ -20,7 +20,7 @@ A \link[tibble:tibble]{tibble} with 2 000 observations and 46 variables:
example_isolates example_isolates
} }
\description{ \description{
A data set containing 2 000 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 \href{https://msberends.github.io/AMR/articles/AMR.html}{the tutorial on our website}. A data set containing 2,000 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 \href{https://msberends.github.io/AMR/articles/AMR.html}{the tutorial on our website}.
} }
\details{ \details{
Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit \href{https://msberends.github.io/AMR/articles/datasets.html}{our website for the download links}. The actual files are of course available on \href{https://github.com/msberends/AMR/tree/main/data-raw}{our GitHub repository}. Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit \href{https://msberends.github.io/AMR/articles/datasets.html}{our website for the download links}. The actual files are of course available on \href{https://github.com/msberends/AMR/tree/main/data-raw}{our GitHub repository}.

4
man/example_isolates_unclean.Rd
View File

@ -5,7 +5,7 @@
\alias{example_isolates_unclean} \alias{example_isolates_unclean}
\title{Data Set with Unclean Data} \title{Data Set with Unclean Data}
\format{ \format{
A \link[tibble:tibble]{tibble} with 3 000 observations and 8 variables: A \link[tibble:tibble]{tibble} with 3,000 observations and 8 variables:
\itemize{ \itemize{
\item \code{patient_id}\cr ID of the patient \item \code{patient_id}\cr ID of the patient
\item \code{date}\cr date of receipt at the laboratory \item \code{date}\cr date of receipt at the laboratory
@ -18,7 +18,7 @@ A \link[tibble:tibble]{tibble} with 3 000 observations and 8 variables:
example_isolates_unclean example_isolates_unclean
} }
\description{ \description{
A data set containing 3 000 microbial isolates that are not cleaned up and consequently not ready for AMR data analysis. This data set can be used for practice. A data set containing 3,000 microbial isolates that are not cleaned up and consequently not ready for AMR data analysis. This data set can be used for practice.
} }
\details{ \details{
Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit \href{https://msberends.github.io/AMR/articles/datasets.html}{our website for the download links}. The actual files are of course available on \href{https://github.com/msberends/AMR/tree/main/data-raw}{our GitHub repository}. Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit \href{https://msberends.github.io/AMR/articles/datasets.html}{our website for the download links}. The actual files are of course available on \href{https://github.com/msberends/AMR/tree/main/data-raw}{our GitHub repository}.

11
man/first_isolate.Rd
View File

@ -52,7 +52,7 @@ filter_first_isolate(
\item{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)} \item{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)}
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.} \item{col_mo}{column name of the IDs of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
\item{col_testcode}{column name of the test codes. Use \code{col_testcode = NULL} to \strong{not} exclude certain test codes (such as test codes for screening). In that case \code{testcodes_exclude} will be ignored.} \item{col_testcode}{column name of the test codes. Use \code{col_testcode = NULL} to \strong{not} exclude certain test codes (such as test codes for screening). In that case \code{testcodes_exclude} will be ignored.}
@ -109,14 +109,17 @@ All mentioned methods are covered in the \code{\link[=first_isolate]{first_isola
\strong{Isolate-based} \tab \code{first_isolate(x, method = "isolate-based")} \cr \strong{Isolate-based} \tab \code{first_isolate(x, method = "isolate-based")} \cr
\emph{(= all isolates)} \tab \cr \emph{(= all isolates)} \tab \cr
\tab \cr \tab \cr
\tab \cr
\strong{Patient-based} \tab \code{first_isolate(x, method = "patient-based")} \cr \strong{Patient-based} \tab \code{first_isolate(x, method = "patient-based")} \cr
\emph{(= first isolate per patient)} \tab \cr \emph{(= first isolate per patient)} \tab \cr
\tab \cr \tab \cr
\tab \cr
\strong{Episode-based} \tab \code{first_isolate(x, method = "episode-based")}, or: \cr \strong{Episode-based} \tab \code{first_isolate(x, method = "episode-based")}, or: \cr
\emph{(= first isolate per episode)} \tab \cr \emph{(= first isolate per episode)} \tab \cr
- 7-Day interval from initial isolate \tab - \code{first_isolate(x, method = "e", episode_days = 7)} \cr - 7-Day interval from initial isolate \tab - \code{first_isolate(x, method = "e", episode_days = 7)} \cr
- 30-Day interval from initial isolate \tab - \code{first_isolate(x, method = "e", episode_days = 30)} \cr - 30-Day interval from initial isolate \tab - \code{first_isolate(x, method = "e", episode_days = 30)} \cr
\tab \cr \tab \cr
\tab \cr
\strong{Phenotype-based} \tab \code{first_isolate(x, method = "phenotype-based")}, or: \cr \strong{Phenotype-based} \tab \code{first_isolate(x, method = "phenotype-based")}, or: \cr
\emph{(= first isolate per phenotype)} \tab \cr \emph{(= first isolate per phenotype)} \tab \cr
- Major difference in any antimicrobial result \tab - \code{first_isolate(x, type = "points")} \cr - Major difference in any antimicrobial result \tab - \code{first_isolate(x, type = "points")} \cr
@ -165,7 +168,7 @@ The default method is phenotype-based (using \code{type = "points"}) and episode
# `example_isolates` is a data set available in the AMR package. # `example_isolates` is a data set available in the AMR package.
# See ?example_isolates. # See ?example_isolates.
example_isolates[first_isolate(info = TRUE), ] example_isolates[first_isolate(), ]
\donttest{ \donttest{
# get all first Gram-negatives # get all first Gram-negatives
example_isolates[which(first_isolate(info = FALSE) & mo_is_gram_negative()), ] example_isolates[which(first_isolate(info = FALSE) & mo_is_gram_negative()), ]
@ -173,7 +176,7 @@ example_isolates[which(first_isolate(info = FALSE) & mo_is_gram_negative()), ]
if (require("dplyr")) { if (require("dplyr")) {
# filter on first isolates using dplyr: # filter on first isolates using dplyr:
example_isolates \%>\% example_isolates \%>\%
filter(first_isolate(info = TRUE)) filter(first_isolate())
} }
if (require("dplyr")) { if (require("dplyr")) {
# short-hand version: # short-hand version:
@ -184,7 +187,7 @@ if (require("dplyr")) {
# flag the first isolates per group: # flag the first isolates per group:
example_isolates \%>\% example_isolates \%>\%
group_by(ward) \%>\% group_by(ward) \%>\%
mutate(first = first_isolate(info = FALSE)) \%>\% mutate(first = first_isolate()) \%>\%
select(ward, date, patient, mo, first) select(ward, date, patient, mo, first)
} }
} }

2
man/intrinsic_resistant.Rd
View File

@ -5,7 +5,7 @@
\alias{intrinsic_resistant} \alias{intrinsic_resistant}
\title{Data Set with Bacterial Intrinsic Resistance} \title{Data Set with Bacterial Intrinsic Resistance}
\format{ \format{
A \link[tibble:tibble]{tibble} with 134 634 observations and 2 variables: A \link[tibble:tibble]{tibble} with 134,634 observations and 2 variables:
\itemize{ \itemize{
\item \code{mo}\cr Microorganism ID \item \code{mo}\cr Microorganism ID
\item \code{ab}\cr Antibiotic ID \item \code{ab}\cr Antibiotic ID

2
man/key_antimicrobials.Rd
View File

@ -35,7 +35,7 @@ antimicrobials_equal(
\arguments{ \arguments{
\item{x}{a \link{data.frame} with antibiotics columns, like \code{AMX} or \code{amox}. Can be left blank to determine automatically} \item{x}{a \link{data.frame} with antibiotics columns, like \code{AMX} or \code{amox}. Can be left blank to determine automatically}
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.} \item{col_mo}{column name of the IDs of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
\item{universal}{names of \strong{broad-spectrum} antimicrobial drugs, case-insensitive. Set to \code{NULL} to ignore. See \emph{Details} for the default antimicrobial drugs} \item{universal}{names of \strong{broad-spectrum} antimicrobial drugs, case-insensitive. Set to \code{NULL} to ignore. See \emph{Details} for the default antimicrobial drugs}

2
man/mdro.Rd
View File

@ -48,7 +48,7 @@ eucast_exceptional_phenotypes(x = NULL, only_sir_columns = FALSE, ...)
\item{guideline}{a specific guideline to follow, see sections \emph{Supported international / national guidelines} and \emph{Using Custom Guidelines} below. When left empty, the publication by Magiorakos \emph{et al.} (see below) will be followed.} \item{guideline}{a specific guideline to follow, see sections \emph{Supported international / national guidelines} and \emph{Using Custom Guidelines} below. When left empty, the publication by Magiorakos \emph{et al.} (see below) will be followed.}
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.} \item{col_mo}{column name of the IDs of the microorganisms (see \code{\link[=as.mo]{as.mo()}}), defaults to the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
\item{info}{a \link{logical} to indicate whether progress should be printed to the console, defaults to only print while in interactive sessions} \item{info}{a \link{logical} to indicate whether progress should be printed to the console, defaults to only print while in interactive sessions}

4
man/microorganisms.Rd
View File

@ -3,9 +3,9 @@
\docType{data} \docType{data}
\name{microorganisms} \name{microorganisms}
\alias{microorganisms} \alias{microorganisms}
\title{Data Set with 52 142 Microorganisms} \title{Data Set with 52,142 Microorganisms}
\format{ \format{
A \link[tibble:tibble]{tibble} with 52 142 observations and 22 variables: A \link[tibble:tibble]{tibble} with 52,142 observations and 22 variables:
\itemize{ \itemize{
\item \code{mo}\cr ID of microorganism as used by this package \item \code{mo}\cr ID of microorganism as used by this package
\item \code{fullname}\cr Full name, like \code{"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. \item \code{fullname}\cr Full name, like \code{"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.

4
man/microorganisms.codes.Rd
View File

@ -3,9 +3,9 @@
\docType{data} \docType{data}
\name{microorganisms.codes} \name{microorganisms.codes}
\alias{microorganisms.codes} \alias{microorganisms.codes}
\title{Data Set with 5 910 Common Microorganism Codes} \title{Data Set with 5,910 Common Microorganism Codes}
\format{ \format{
A \link[tibble:tibble]{tibble} with 5 910 observations and 2 variables: A \link[tibble:tibble]{tibble} with 5,910 observations and 2 variables:
\itemize{ \itemize{
\item \code{code}\cr Commonly used code of a microorganism \item \code{code}\cr Commonly used code of a microorganism
\item \code{mo}\cr ID of the microorganism in the \link{microorganisms} data set \item \code{mo}\cr ID of the microorganism in the \link{microorganisms} data set

2
man/mo_property.Rd
View File

@ -278,7 +278,7 @@ mo_property(
\item{open}{browse the URL using \code{\link[utils:browseURL]{browseURL()}}} \item{open}{browse the URL using \code{\link[utils:browseURL]{browseURL()}}}
\item{property}{one of the column names of the \link{microorganisms} data set: "mo", "fullname", "status", "kingdom", "phylum", "class", "order", "family", "genus", "species", "subspecies", "rank", "ref", "source", "lpsn", "lpsn_parent", "lpsn_renamed_to", "gbif", "gbif_parent", "gbif_renamed_to", "prevalence" or "snomed"} \item{property}{one of the column names of the \link{microorganisms} data set: "mo", "fullname", "status", "kingdom", "phylum", "class", "order", "family", "genus", "species", "subspecies", "rank", "ref", "source", "lpsn", "lpsn_parent", "lpsn_renamed_to", "gbif", "gbif_parent", "gbif_renamed_to", "prevalence" or "snomed", or must be \code{"shortname"}}
} }
\value{ \value{
\itemize{ \itemize{

5
man/proportion.Rd
View File

@ -13,7 +13,7 @@
\alias{proportion_S} \alias{proportion_S}
\alias{proportion_df} \alias{proportion_df}
\alias{sir_df} \alias{sir_df}
\title{Calculate Antimicrobial Resistance} \title{Calculate Microbial Resistance}
\source{ \source{
\strong{M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 5th Edition}, 2022, \emph{Clinical and Laboratory Standards Institute (CLSI)}. \url{https://clsi.org/standards/products/microbiology/documents/m39/}. \strong{M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 5th Edition}, 2022, \emph{Clinical and Laboratory Standards Institute (CLSI)}. \url{https://clsi.org/standards/products/microbiology/documents/m39/}.
} }
@ -98,7 +98,7 @@ The function \code{\link[=resistance]{resistance()}} is equal to the function \c
Use \code{\link[=sir_confidence_interval]{sir_confidence_interval()}} to calculate the confidence interval, which relies on \code{\link[=binom.test]{binom.test()}}, i.e., the Clopper-Pearson method. This function returns a vector of length 2 at default for antimicrobial \emph{resistance}. Change the \code{side} argument to "left"/"min" or "right"/"max" to return a single value, and change the \code{ab_result} argument to e.g. \code{c("S", "I")} to test for antimicrobial \emph{susceptibility}, see Examples. Use \code{\link[=sir_confidence_interval]{sir_confidence_interval()}} to calculate the confidence interval, which relies on \code{\link[=binom.test]{binom.test()}}, i.e., the Clopper-Pearson method. This function returns a vector of length 2 at default for antimicrobial \emph{resistance}. Change the \code{side} argument to "left"/"min" or "right"/"max" to return a single value, and change the \code{ab_result} argument to e.g. \code{c("S", "I")} to test for antimicrobial \emph{susceptibility}, see Examples.
\strong{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 \code{\link[=first_isolate]{first_isolate()}} to determine them in your data set with one of the four available algorithms. \strong{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 \code{\link[=first_isolate]{first_isolate()}} to determine them in your data set.
These functions are not meant to count isolates, but to calculate the proportion of resistance/susceptibility. Use the \code{\link[=count]{count()}} functions to count isolates. The function \code{\link[=susceptibility]{susceptibility()}} is essentially equal to \code{count_susceptible() / count_all()}. \emph{Low counts can influence the outcome - the \code{proportion} functions may camouflage this, since they only return the proportion (albeit being dependent on the \code{minimum} argument).} These functions are not meant to count isolates, but to calculate the proportion of resistance/susceptibility. Use the \code{\link[=count]{count()}} functions to count isolates. The function \code{\link[=susceptibility]{susceptibility()}} is essentially equal to \code{count_susceptible() / count_all()}. \emph{Low counts can influence the outcome - the \code{proportion} functions may camouflage this, since they only return the proportion (albeit being dependent on the \code{minimum} argument).}
@ -162,7 +162,6 @@ This AMR package honours this insight. Use \code{\link[=susceptibility]{suscepti
\examples{ \examples{
# example_isolates is a data set available in the AMR package. # example_isolates is a data set available in the AMR package.
# run ?example_isolates for more info. # run ?example_isolates for more info.
example_isolates
# base R ------------------------------------------------------------ # base R ------------------------------------------------------------
# determines \%R # determines \%R

5
tests/tinytest.R
View File

@ -39,11 +39,6 @@ if (tryCatch(isTRUE(AMR:::import_fn("isJob", "rstudioapi")()), error = function(
.libPaths(c(Sys.getenv("R_LIBS_USER_GH_ACTIONS"), .libPaths())) .libPaths(c(Sys.getenv("R_LIBS_USER_GH_ACTIONS"), .libPaths()))
if (AMR:::pkg_is_available("tinytest", also_load = TRUE)) { if (AMR:::pkg_is_available("tinytest", also_load = TRUE)) {
library(AMR) library(AMR)
if (identical(AMR:::import_fn("select", "dplyr"), AMR:::select)) {
message("\n\n------------------------------------\nThis test will rely on {dplyr} verbs\n------------------------------------\n\n")
} else {
message("\n\n---------------------------------------------------------------------\nThis test will rely on {poorman} verbs (installed state dplyr: ", AMR:::pkg_is_available("dplyr", also_load = FALSE), ")\n---------------------------------------------------------------------\n\n")
}
# set language # set language
set_AMR_locale("English") set_AMR_locale("English")
# set some functions if on old R # set some functions if on old R