P281424
/
AMR
mirror of https://github.com/msberends/AMR.git
1
0
Fork 0
Code Releases Activity

sort sir history

This commit is contained in:
dr. M.S. (Matthijs) Berends 2023-01-23 15:01:21 +01:00
parent af139a3c82
commit 19fd0ef121
57 changed files with 2864 additions and 2739 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
Version: 1.8.2.9096
Date: 2023-01-21
Version: 1.8.2.9098
Date: 2023-01-23
Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by

2
NEWS.md
View File

@ -1,4 +1,4 @@
# AMR 1.8.2.9096
# AMR 1.8.2.9098
*(this beta version will eventually become v2.0! We're happy to reach a new major milestone soon!)*

6
R/aa_amr-package.R
View File

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

179
R/aa_helper_functions.R
View File

@ -49,12 +49,13 @@ pm_left_join <- function(x, y, by = NULL, suffix = c(".x", ".y")) {
merged <- cbind(
x,
y[match(
x[, by[1], drop = TRUE],
y[, by[2], drop = TRUE]
),
colnames(y)[!colnames(y) %in% colnames(x) & !colnames(y) == by[2]],
drop = FALSE
y[
match(
x[, by[1], drop = TRUE],
y[, by[2], drop = TRUE]
),
colnames(y)[!colnames(y) %in% colnames(x) & !colnames(y) == by[2]],
drop = FALSE
]
)
@ -190,12 +191,13 @@ addin_insert_like <- function() {
)
}
replace_pos <- function(old, with) {
modifyRange(document_range(
document_position(current_row, current_col - nchar(old)),
document_position(current_row, current_col)
),
text = with,
id = context$id
modifyRange(
document_range(
document_position(current_row, current_col - nchar(old)),
document_position(current_row, current_col)
),
text = with,
id = context$id
)
}
@ -226,7 +228,7 @@ search_type_in_df <- function(x, type, info = TRUE) {
# -- mo
if (type == "mo") {
add_MO_lookup_to_AMR_env()
if (any(vapply(FUN.VALUE = logical(1), x, is.mo))) {
# take first 'mo' column
found <- colnames(x)[vapply(FUN.VALUE = logical(1), x, is.mo)]
@ -253,11 +255,12 @@ search_type_in_df <- function(x, type, info = TRUE) {
# WHONET support
found <- sort(colnames(x)[colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)"])
if (!inherits(pm_pull(x, found), c("Date", "POSIXct"))) {
stop(font_red(paste0(
"Found column '", font_bold(found), "' to be used as input for `col_", type,
"`, but this column contains no valid dates. Transform its values to valid dates first."
)),
call. = FALSE
stop(
font_red(paste0(
"Found column '", font_bold(found), "' to be used as input for `col_", type,
"`, but this column contains no valid dates. Transform its values to valid dates first."
)),
call. = FALSE
)
}
} else if (any(vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct"))))) {
@ -319,21 +322,23 @@ search_type_in_df <- function(x, type, info = TRUE) {
}
is_valid_regex <- function(x) {
regex_at_all <- tryCatch(vapply(
FUN.VALUE = logical(1),
X = strsplit(x, "", fixed = TRUE),
FUN = function(y) {
any(y %in% c(
"$", "(", ")", "*", "+", "-",
".", "?", "[", "]", "^", "{",
"|", "}", "\\"
),
na.rm = TRUE
)
},
USE.NAMES = FALSE
),
error = function(e) rep(TRUE, length(x))
regex_at_all <- tryCatch(
vapply(
FUN.VALUE = logical(1),
X = strsplit(x, "", fixed = TRUE),
FUN = function(y) {
any(
y %in% c(
"$", "(", ")", "*", "+", "-",
".", "?", "[", "]", "^", "{",
"|", "}", "\\"
),
na.rm = TRUE
)
},
USE.NAMES = FALSE
),
error = function(e) rep(TRUE, length(x))
)
regex_valid <- vapply(
FUN.VALUE = logical(1),
@ -410,16 +415,17 @@ word_wrap <- function(...,
if (msg %like% "\n") {
# run word_wraps() over every line here, bind them and return again
return(paste0(vapply(
FUN.VALUE = character(1),
trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"),
word_wrap,
add_fn = add_fn,
as_note = FALSE,
width = width,
extra_indent = extra_indent
),
collapse = "\n"
return(paste0(
vapply(
FUN.VALUE = character(1),
trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"),
word_wrap,
add_fn = add_fn,
as_note = FALSE,
width = width,
extra_indent = extra_indent
),
collapse = "\n"
))
}
@ -429,11 +435,12 @@ word_wrap <- function(...,
# we need to correct for already applied style, that adds text like "\033[31m\"
msg_stripped <- font_stripstyle(msg)
# where are the spaces now?
msg_stripped_wrapped <- paste0(strwrap(msg_stripped,
simplify = TRUE,
width = width
),
collapse = "\n"
msg_stripped_wrapped <- paste0(
strwrap(msg_stripped,
simplify = TRUE,
width = width
),
collapse = "\n"
)
msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")),
collapse = "\n"
@ -487,11 +494,12 @@ message_ <- function(...,
appendLF = TRUE,
add_fn = list(font_blue),
as_note = TRUE) {
message(word_wrap(...,
add_fn = add_fn,
as_note = as_note
),
appendLF = appendLF
message(
word_wrap(...,
add_fn = add_fn,
as_note = as_note
),
appendLF = appendLF
)
}
@ -499,12 +507,13 @@ warning_ <- function(...,
add_fn = list(),
immediate = FALSE,
call = FALSE) {
warning(word_wrap(...,
add_fn = add_fn,
as_note = FALSE
),
immediate. = immediate,
call. = call
warning(
word_wrap(...,
add_fn = add_fn,
as_note = FALSE
),
immediate. = immediate,
call. = call
)
}
@ -836,17 +845,18 @@ meet_criteria <- function(object,
)
}
if (!is.null(contains_column_class)) {
stop_ifnot(any(vapply(
FUN.VALUE = logical(1),
object,
function(col, columns_class = contains_column_class) {
inherits(col, columns_class)
}
), na.rm = TRUE),
"the data provided in argument `", obj_name,
"` must contain at least one column of class <", contains_column_class, ">. ",
"See ?as.", contains_column_class, ".",
call = call_depth
stop_ifnot(
any(vapply(
FUN.VALUE = logical(1),
object,
function(col, columns_class = contains_column_class) {
inherits(col, columns_class)
}
), na.rm = TRUE),
"the data provided in argument `", obj_name,
"` must contain at least one column of class <", contains_column_class, ">. ",
"See ?as.", contains_column_class, ".",
call = call_depth
)
}
return(invisible())
@ -1314,7 +1324,6 @@ round2 <- function(x, digits = 1, force_zero = TRUE) {
# percentage from our other package: 'cleaner'
percentage <- function(x, digits = NULL, ...) {
# getdecimalplaces() function
getdecimalplaces <- function(x, minimum = 0, maximum = 3) {
if (maximum < minimum) {
@ -1330,12 +1339,13 @@ percentage <- function(x, digits = NULL, ...) {
), ".", fixed = TRUE),
function(y) ifelse(length(y) == 2, nchar(y[2]), 0)
)), na.rm = TRUE)
max(min(max_places,
maximum,
max(
min(max_places,
maximum,
na.rm = TRUE
),
minimum,
na.rm = TRUE
),
minimum,
na.rm = TRUE
)
}
@ -1366,11 +1376,12 @@ percentage <- function(x, digits = NULL, ...) {
# max one digit if undefined
digits <- getdecimalplaces(x, minimum = 0, maximum = 1)
}
format_percentage(structure(
.Data = as.double(x),
class = c("percentage", "numeric")
),
digits = digits, ...
format_percentage(
structure(
.Data = as.double(x),
class = c("percentage", "numeric")
),
digits = digits, ...
)
}
@ -1385,7 +1396,7 @@ add_MO_lookup_to_AMR_env <- function() {
# for all MO functions, saves a lot of time on package load and in package size
if (is.null(AMR_env$MO_lookup)) {
MO_lookup <- AMR::microorganisms
MO_lookup$kingdom_index <- NA_real_
MO_lookup[which(MO_lookup$kingdom == "Bacteria" | MO_lookup$mo == "UNKNOWN"), "kingdom_index"] <- 1
MO_lookup[which(MO_lookup$kingdom == "Fungi"), "kingdom_index"] <- 2
@ -1393,7 +1404,7 @@ add_MO_lookup_to_AMR_env <- function() {
MO_lookup[which(MO_lookup$kingdom == "Archaea"), "kingdom_index"] <- 4
# all the rest
MO_lookup[which(is.na(MO_lookup$kingdom_index)), "kingdom_index"] <- 5
# the fullname lowercase, important for the internal algorithms in as.mo()
MO_lookup$fullname_lower <- tolower(trimws(paste(
MO_lookup$genus,
@ -1405,7 +1416,7 @@ add_MO_lookup_to_AMR_env <- function() {
MO_lookup$fullname_lower <- trimws(gsub("[^.a-z0-9/ \\-]+", "", MO_lookup$fullname_lower, perl = TRUE))
# special for Salmonella - they have cities as subspecies but not the species (enterica) in the fullname:
MO_lookup$fullname_lower[which(MO_lookup$subspecies %like_case% "^[A-Z]")] <- gsub(" enterica ", " ", MO_lookup$fullname_lower[which(MO_lookup$subspecies %like_case% "^[A-Z]")], fixed = TRUE)
MO_lookup$full_first <- substr(MO_lookup$fullname_lower, 1, 1)
MO_lookup$species_first <- tolower(substr(MO_lookup$species, 1, 1)) # tolower for groups (Streptococcus, Salmonella)
MO_lookup$subspecies_first <- tolower(substr(MO_lookup$subspecies, 1, 1)) # tolower for Salmonella serovars

69
R/ab.R
View File

@ -87,7 +87,6 @@
#'
#' \donttest{
#' if (require("dplyr")) {
#'
#' # you can quickly rename 'sir' columns using set_ab_names() with dplyr:
#' example_isolates %>%
#' set_ab_names(where(is.sir), property = "atc")
@ -338,22 +337,23 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# transform back from other languages and try again
x_translated <- paste(lapply(
strsplit(x[i], "[^A-Z0-9]"),
function(y) {
for (i in seq_len(length(y))) {
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
!isFALSE(TRANSLATIONS$fixed)), "pattern"],
y[i]
)
x_translated <- paste(
lapply(
strsplit(x[i], "[^A-Z0-9]"),
function(y) {
for (i in seq_len(length(y))) {
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
!isFALSE(TRANSLATIONS$fixed)), "pattern"],
y[i]
)
}
}
generalise_antibiotic_name(y)
}
generalise_antibiotic_name(y)
}
)[[1]],
collapse = "/"
)[[1]],
collapse = "/"
)
x_translated_guess <- suppressWarnings(as.ab(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) {
@ -362,20 +362,21 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# now also try to coerce brandname combinations like "Amoxy/clavulanic acid"
x_translated <- paste(lapply(
strsplit(x_translated, "[^A-Z0-9 ]"),
function(y) {
for (i in seq_len(length(y))) {
y_name <- suppressWarnings(ab_name(y[i], language = NULL, initial_search = FALSE))
y[i] <- ifelse(!is.na(y_name),
y_name,
y[i]
)
x_translated <- paste(
lapply(
strsplit(x_translated, "[^A-Z0-9 ]"),
function(y) {
for (i in seq_len(length(y))) {
y_name <- suppressWarnings(ab_name(y[i], language = NULL, initial_search = FALSE))
y[i] <- ifelse(!is.na(y_name),
y_name,
y[i]
)
}
generalise_antibiotic_name(y)
}
generalise_antibiotic_name(y)
}
)[[1]],
collapse = "/"
)[[1]],
collapse = "/"
)
x_translated_guess <- suppressWarnings(as.ab(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) {
@ -513,8 +514,10 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
)
}
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
x_unknown <- c(x_unknown,
AMR_env$ab_previously_coerced$x_bak[which(AMR_env$ab_previously_coerced$x %in% x & is.na(AMR_env$ab_previously_coerced$ab))])
x_unknown <- c(
x_unknown,
AMR_env$ab_previously_coerced$x_bak[which(AMR_env$ab_previously_coerced$x %in% x & is.na(AMR_env$ab_previously_coerced$ab))]
)
if (length(x_unknown) > 0 && fast_mode == FALSE) {
warning_(
"in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ",
@ -660,9 +663,9 @@ get_translate_ab <- function(translate_ab) {
} else {
translate_ab <- tolower(translate_ab)
stop_ifnot(translate_ab %in% colnames(AMR::antibiotics),
"invalid value for 'translate_ab', this must be a column name of the antibiotics data set\n",
"or TRUE (equals 'name') or FALSE to not translate at all.",
call = FALSE
"invalid value for 'translate_ab', this must be a column name of the antibiotics data set\n",
"or TRUE (equals 'name') or FALSE to not translate at all.",
call = FALSE
)
translate_ab
}

92
R/ab_selectors.R
View File

@ -95,20 +95,17 @@
#' # dplyr -------------------------------------------------------------------
#' \donttest{
#' if (require("dplyr")) {
#'
#' # get AMR for all aminoglycosides e.g., per ward:
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(across(aminoglycosides(), resistance))
#' }
#' if (require("dplyr")) {
#'
#' # You can combine selectors with '&' to be more specific:
#' example_isolates %>%
#' select(penicillins() & administrable_per_os())
#' }
#' if (require("dplyr")) {
#'
#' # get AMR for only drugs that matter - no intrinsic resistance:
#' example_isolates %>%
#' filter(mo_genus() %in% c("Escherichia", "Klebsiella")) %>%
@ -116,7 +113,6 @@
#' summarise(across(not_intrinsic_resistant(), resistance))
#' }
#' if (require("dplyr")) {
#'
#' # get susceptibility for antibiotics whose name contains "trim":
#' example_isolates %>%
#' filter(first_isolate()) %>%
@ -124,19 +120,16 @@
#' summarise(across(ab_selector(name %like% "trim"), susceptibility))
#' }
#' if (require("dplyr")) {
#'
#' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
#' example_isolates %>%
#' select(carbapenems())
#' }
#' if (require("dplyr")) {
#'
#' # this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
#' example_isolates %>%
#' select(mo, aminoglycosides())
#' }
#' if (require("dplyr")) {
#'
#' # any() and all() work in dplyr's filter() too:
#' example_isolates %>%
#' filter(
@ -145,25 +138,21 @@
#' )
#' }
#' if (require("dplyr")) {
#'
#' # also works with c():
#' example_isolates %>%
#' filter(any(c(carbapenems(), aminoglycosides()) == "R"))
#' }
#' if (require("dplyr")) {
#'
#' # not setting any/all will automatically apply all():
#' example_isolates %>%
#' filter(aminoglycosides() == "R")
#' }
#' if (require("dplyr")) {
#'
#' # this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
#' example_isolates %>%
#' select(mo, ab_class("mycobact"))
#' }
#' if (require("dplyr")) {
#'
#' # get bug/drug combinations for only glycopeptides in Gram-positives:
#' example_isolates %>%
#' filter(mo_is_gram_positive()) %>%
@ -179,7 +168,6 @@
#' select(penicillins()) # only the 'J01CA01' column will be selected
#' }
#' if (require("dplyr")) {
#'
#' # with recent versions of dplyr this is all equal:
#' x <- example_isolates[carbapenems() == "R", ]
#' y <- example_isolates %>% filter(carbapenems() == "R")
@ -433,14 +421,16 @@ administrable_per_os <- function(only_sir_columns = FALSE, ...) {
ab_group = "administrable_per_os",
examples = paste0(
" (such as ",
vector_or(ab_name(sample(agents_all,
size = min(5, length(agents_all)),
replace = FALSE
),
tolower = TRUE,
language = NULL
),
quotes = FALSE
vector_or(
ab_name(
sample(agents_all,
size = min(5, length(agents_all)),
replace = FALSE
),
tolower = TRUE,
language = NULL
),
quotes = FALSE
),
")"
)
@ -491,20 +481,21 @@ not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, ver
sort = FALSE, fn = "not_intrinsic_resistant"
)
# intrinsic vars
vars_df_R <- tryCatch(sapply(
eucast_rules(vars_df,
col_mo = col_mo,
version_expertrules = version_expertrules,
rules = "expert",
info = FALSE
vars_df_R <- tryCatch(
sapply(
eucast_rules(vars_df,
col_mo = col_mo,
version_expertrules = version_expertrules,
rules = "expert",
info = FALSE
),
function(col) {
tryCatch(!any(is.na(col)) && all(col == "R"),
error = function(e) FALSE
)
}
),
function(col) {
tryCatch(!any(is.na(col)) && all(col == "R"),
error = function(e) FALSE
)
}
),
error = function(e) stop_("in not_intrinsic_resistant(): ", e$message, call = FALSE)
error = function(e) stop_("in not_intrinsic_resistant(): ", e$message, call = FALSE)
)
agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]
@ -549,12 +540,13 @@ ab_select_exec <- function(function_name,
if (message_not_thrown_before(function_name, "ab_class", "untreatable", entire_session = TRUE)) {
warning_(
"in `", function_name, "()`: some drugs were ignored since they cannot be used for treating patients: ",
vector_and(ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
language = NULL,
tolower = TRUE
),
quotes = FALSE,
sort = TRUE
vector_and(
ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
language = NULL,
tolower = TRUE
),
quotes = FALSE,
sort = TRUE
), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
"This warning will be shown once per session."
)
@ -593,11 +585,12 @@ ab_select_exec <- function(function_name,
}
ab_group <- function_name
}
examples <- paste0(" (such as ", vector_or(ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE),
tolower = TRUE,
language = NULL
),
quotes = FALSE
examples <- paste0(" (such as ", vector_or(
ab_name(sample(abx, size = min(2, length(abx)), replace = FALSE),
tolower = TRUE,
language = NULL
),
quotes = FALSE
), ")")
} else {
# this for the 'manual' ab_class() function
@ -821,11 +814,12 @@ find_ab_names <- function(ab_group, n = 3) {
if (length(drugs) == 0) {
return("??")
}
vector_or(ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
tolower = TRUE,
language = NULL
),
quotes = FALSE
vector_or(
ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
tolower = TRUE,
language = NULL
),
quotes = FALSE
)
}

11
R/age.R
View File

@ -83,11 +83,12 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
# add decimals
if (exact == TRUE) {
# get dates of `x` when `x` would have the year of `reference`
x_in_reference_year <- as.POSIXlt(paste0(
format(as.Date(reference), "%Y"),
format(as.Date(x), "-%m-%d")
),
format = "%Y-%m-%d"
x_in_reference_year <- as.POSIXlt(
paste0(
format(as.Date(reference), "%Y"),
format(as.Date(x), "-%m-%d")
),
format = "%Y-%m-%d"
)
# get differences in days
n_days_x_rest <- as.double(difftime(as.Date(reference),

68
R/av.R
View File

@ -308,22 +308,23 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# transform back from other languages and try again
x_translated <- paste(lapply(
strsplit(x[i], "[^A-Z0-9]"),
function(y) {
for (i in seq_len(length(y))) {
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
!isFALSE(TRANSLATIONS$fixed)), "pattern"],
y[i]
)
x_translated <- paste(
lapply(
strsplit(x[i], "[^A-Z0-9]"),
function(y) {
for (i in seq_len(length(y))) {
for (lang in LANGUAGES_SUPPORTED[LANGUAGES_SUPPORTED != "en"]) {
y[i] <- ifelse(tolower(y[i]) %in% tolower(TRANSLATIONS[, lang, drop = TRUE]),
TRANSLATIONS[which(tolower(TRANSLATIONS[, lang, drop = TRUE]) == tolower(y[i]) &
!isFALSE(TRANSLATIONS$fixed)), "pattern"],
y[i]
)
}
}
generalise_antibiotic_name(y)
}
generalise_antibiotic_name(y)
}
)[[1]],
collapse = "/"
)[[1]],
collapse = "/"
)
x_translated_guess <- suppressWarnings(as.av(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) {
@ -332,20 +333,21 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
# now also try to coerce brandname combinations like "Amoxy/clavulanic acid"
x_translated <- paste(lapply(
strsplit(x_translated, "[^A-Z0-9 ]"),
function(y) {
for (i in seq_len(length(y))) {
y_name <- suppressWarnings(av_name(y[i], language = NULL, initial_search = FALSE))
y[i] <- ifelse(!is.na(y_name),
y_name,
y[i]
)
x_translated <- paste(
lapply(
strsplit(x_translated, "[^A-Z0-9 ]"),
function(y) {
for (i in seq_len(length(y))) {
y_name <- suppressWarnings(av_name(y[i], language = NULL, initial_search = FALSE))
y[i] <- ifelse(!is.na(y_name),
y_name,
y[i]
)
}
generalise_antibiotic_name(y)
}
generalise_antibiotic_name(y)
}
)[[1]],
collapse = "/"
)[[1]],
collapse = "/"
)
x_translated_guess <- suppressWarnings(as.av(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) {
@ -478,8 +480,10 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
)
}
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
x_unknown <- c(x_unknown,
AMR_env$av_previously_coerced$x_bak[which(AMR_env$av_previously_coerced$x %in% x & is.na(AMR_env$av_previously_coerced$av))])
x_unknown <- c(
x_unknown,
AMR_env$av_previously_coerced$x_bak[which(AMR_env$av_previously_coerced$x %in% x & is.na(AMR_env$av_previously_coerced$av))]
)
if (length(x_unknown) > 0 && fast_mode == FALSE) {
warning_(
"in `as.av()`: these values could not be coerced to a valid antiviral drug ID: ",
@ -604,9 +608,9 @@ get_translate_av <- function(translate_av) {
} else {
translate_av <- tolower(translate_av)
stop_ifnot(translate_av %in% colnames(AMR::antivirals),
"invalid value for 'translate_av', this must be a column name of the antivirals data set\n",
"or TRUE (equals 'name') or FALSE to not translate at all.",
call = FALSE
"invalid value for 'translate_av', this must be a column name of the antivirals data set\n",
"or TRUE (equals 'name') or FALSE to not translate at all.",
call = FALSE
)
translate_av
}

22
R/av_from_text.R
View File

@ -69,26 +69,26 @@ av_from_text <- function(text,
if (missing(type)) {
type <- type[1L]
}
meet_criteria(text)
meet_criteria(type, allow_class = "character", has_length = 1)
meet_criteria(collapse, has_length = 1, allow_NULL = TRUE)
meet_criteria(translate_av, allow_NULL = FALSE) # get_translate_av() will be more informative about what's allowed
meet_criteria(thorough_search, allow_class = "logical", has_length = 1, allow_NULL = TRUE)
meet_criteria(info, allow_class = "logical", has_length = 1)
type <- tolower(trimws2(type))
text <- tolower(as.character(text))
text_split_all <- strsplit(text, "[ ;.,:\\|]")
progress <- progress_ticker(n = length(text_split_all), n_min = 5, print = info)
on.exit(close(progress))
if (type %like% "(drug|ab|anti)") {
translate_av <- get_translate_av(translate_av)
if (isTRUE(thorough_search) ||
(isTRUE(is.null(thorough_search)) && max(vapply(FUN.VALUE = double(1), text_split_all, length), na.rm = TRUE) <= 3)) {
(isTRUE(is.null(thorough_search)) && max(vapply(FUN.VALUE = double(1), text_split_all, length), na.rm = TRUE) <= 3)) {
text_split_all <- text_split_all[nchar(text_split_all) >= 4 & grepl("[a-z]+", text_split_all)]
result <- lapply(text_split_all, function(text_split) {
progress$tick()
@ -125,9 +125,9 @@ av_from_text <- function(text,
)
})
}
close(progress)
result <- lapply(result, function(out) {
out <- out[!is.na(out)]
if (length(out) == 0) {
@ -149,7 +149,7 @@ av_from_text <- function(text,
text_split <- as.double(gsub("[^0-9.]", "", text_split))
# minimal 100 units/mg and no years that unlikely doses
text_split <- text_split[text_split >= 100 & !text_split %in% c(1951:1999, 2001:2049)]
if (length(text_split) > 0) {
text_split
} else {
@ -170,7 +170,7 @@ av_from_text <- function(text,
} else {
stop_("`type` must be either 'drug', 'dose' or 'administration'")
}
# collapse text if needed
if (!is.null(collapse)) {
result <- vapply(FUN.VALUE = character(1), result, function(x) {
@ -181,6 +181,6 @@ av_from_text <- function(text,
}
})
}
result
}

24
R/av_property.R
View File

@ -84,7 +84,7 @@ av_name <- function(x, language = get_AMR_locale(), tolower = FALSE, ...) {
meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(tolower, allow_class = "logical", has_length = 1)
x <- translate_into_language(av_validate(x = x, property = "name", ...), language = language, only_affect_ab_names = TRUE)
if (tolower == TRUE) {
# use perl to only transform the first character
@ -155,11 +155,11 @@ av_loinc <- function(x, ...) {
av_ddd <- function(x, administration = "oral", ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
x <- as.av(x, ...)
ddd_prop <- paste0(administration, "_ddd")
out <- av_validate(x = x, property = ddd_prop)
if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
warning_(
"in `av_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
@ -175,11 +175,11 @@ av_ddd <- function(x, administration = "oral", ...) {
av_ddd_units <- function(x, administration = "oral", ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
x <- as.av(x, ...)
ddd_prop <- paste0(administration, "_units")
out <- av_validate(x = x, property = ddd_prop)
if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
warning_(
"in `av_ddd_units()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
@ -195,7 +195,7 @@ av_ddd_units <- function(x, administration = "oral", ...) {
av_info <- function(x, language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language)
x <- as.av(x, ...)
list(
av = as.character(x),
@ -224,18 +224,18 @@ av_info <- function(x, language = get_AMR_locale(), ...) {
av_url <- function(x, open = FALSE, ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(open, allow_class = "logical", has_length = 1)
av <- as.av(x = x, ...)
atcs <- av_atc(av, only_first = TRUE)
u <- paste0("https://www.whocc.no/atc_ddd_index/?code=", atcs, "&showdescription=no")
u[is.na(atcs)] <- NA_character_
names(u) <- av_name(av)
NAs <- av_name(av, tolower = TRUE, language = NULL)[!is.na(av) & is.na(atcs)]
if (length(NAs) > 0) {
warning_("in `av_url()`: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
}
if (open == TRUE) {
if (length(u) > 1 && !is.na(u[1L])) {
warning_("in `av_url()`: only the first URL will be opened, as `browseURL()` only suports one string.")
@ -264,9 +264,9 @@ av_validate <- function(x, property, ...) {
# try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% AMR_env$AV_lookup[1, property, drop = TRUE],
error = function(e) stop(e$message, call. = FALSE)
error = function(e) stop(e$message, call. = FALSE)
)
if (!all(x %in% AMR_env$AV_lookup[, property, drop = TRUE])) {
x <- as.av(x, ...)
if (all(is.na(x)) && is.list(AMR_env$AV_lookup[, property, drop = TRUE])) {
@ -276,7 +276,7 @@ av_validate <- function(x, property, ...) {
}
}
}
if (property == "av") {
return(set_clean_class(x, new_class = c("av", "character")))
} else if (property == "cid") {

22
R/custom_antimicrobials.R
View File

@ -31,25 +31,25 @@
#'
#' With [add_custom_antimicrobials()] you can add your own custom antimicrobial drug names and codes.
#' @param x a [data.frame] resembling the [antibiotics] data set, at least containing columns "ab" and "name"
#' @details **Important:** Due to how \R works, the [add_custom_antimicrobials()] function has to be run in every \R session - added antimicrobials are not stored between sessions and are thus lost when \R is exited.
#'
#' @details **Important:** Due to how \R works, the [add_custom_antimicrobials()] function has to be run in every \R session - added antimicrobials are not stored between sessions and are thus lost when \R is exited.
#'
#' There are two ways to automate this process:
#'
#'
#' **Method 1:** Save the antimicrobials to a local or remote file (can even be the internet). To use this method:
#'
#'
#' 1. Create a data set in the structure of the [antibiotics] data set (containing at the very least columns "ab" and "name") and save it with [saveRDS()] to a location of choice, e.g. `"~/my_custom_ab.rds"`, or any remote location.
#'
#'
#' 2. Set the file location to the `AMR_custom_ab` \R option: `options(AMR_custom_ab = "~/my_custom_ab.rds")`. This can even be a remote file location, such as an https URL. Since options are not saved between \R sessions, it is best to save this option to the `.Rprofile` file so that it will loaded on start-up of \R. To do this, open the `.Rprofile` file using e.g. `utils::file.edit("~/.Rprofile")`, add this text and save the file:
#'
#' ```r
#' # Add custom antibiotic drug codes:
#' options(AMR_custom_ab = "~/my_custom_ab.rds")
#' ```
#'
#'
#' Upon package load, this file will be loaded and run through the [add_custom_antimicrobials()] function.
#'
#'
#' **Method 2:** Save the antimicrobial additions directly to your `.Rprofile` file. An important downside is that this requires to load the `AMR` package at every start-up. To use this method:
#'
#'
#' 1. Edit the `.Rprofile` file using e.g. `utils::file.edit("~/.Rprofile")`.
#'
#' 2. Add a text like below and save the file:
@ -139,10 +139,10 @@ add_custom_antimicrobials <- function(x) {
x[, col] <- as.list(x[, col, drop = TRUE])
}
}
AMR_env$custom_ab_codes <- c(AMR_env$custom_ab_codes, x$ab)
class(AMR_env$AB_lookup$ab) <- "character"
new_df <- AMR_env$AB_lookup[0, , drop = FALSE][seq_len(NROW(x)), , drop = FALSE]
rownames(new_df) <- NULL
list_cols <- vapply(FUN.VALUE = logical(1), new_df, is.list)
@ -155,7 +155,7 @@ add_custom_antimicrobials <- function(x) {
new_df[, col] <- x[, col, drop = TRUE]
}
AMR_env$AB_lookup <- unique(rbind(AMR_env$AB_lookup, new_df))
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$ab %in% x$ab), , drop = FALSE]
class(AMR_env$AB_lookup$ab) <- c("ab", "character")
message_("Added ", nr2char(nrow(x)), " record", ifelse(nrow(x) > 1, "s", ""), " to the internal `antibiotics` data set.")

11
R/custom_eucast_rules.R
View File

@ -240,11 +240,12 @@ print.custom_eucast_rules <- function(x, ...) {
" (", rule$result_group, ")"
)
agents <- sort(agents)
rule_if <- word_wrap(paste0(
i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then "),
"set to {result}:"
),
extra_indent = 5
rule_if <- word_wrap(
paste0(
i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then "),
"set to {result}:"
),
extra_indent = 5
)
rule_if <- gsub("{result}", val, rule_if, fixed = TRUE)
rule_then <- paste0(" ", word_wrap(paste0(agents, collapse = ", "), extra_indent = 5))

129
R/custom_microorganisms.R
View File

@ -32,26 +32,26 @@
#' With [add_custom_microorganisms()] you can add your own custom microorganisms, such the non-taxonomic outcome of laboratory analysis.
#' @param x a [data.frame] resembling the [microorganisms] data set, at least containing column "genus" (case-insensitive)
#' @details This function will fill in missing taxonomy for you, if specific taxonomic columns are missing, see *Examples*.
#'
#' **Important:** Due to how \R works, the [add_custom_microorganisms()] function has to be run in every \R session - added microorganisms are not stored between sessions and are thus lost when \R is exited.
#'
#'
#' **Important:** Due to how \R works, the [add_custom_microorganisms()] function has to be run in every \R session - added microorganisms are not stored between sessions and are thus lost when \R is exited.
#'
#' There are two ways to automate this process:
#'
#'
#' **Method 1:** Using the option [`AMR_custom_mo`][AMR-options], which is the preferred method. To use this method:
#'
#'
#' 1. Create a data set in the structure of the [microorganisms] data set (containing at the very least column "genus") and save it with [saveRDS()] to a location of choice, e.g. `"~/my_custom_mo.rds"`, or any remote location.
#'
#'
#' 2. Set the file location to the `AMR_custom_mo` \R option: `options(AMR_custom_mo = "~/my_custom_mo.rds")`. This can even be a remote file location, such as an https URL. Since options are not saved between \R sessions, it is best to save this option to the `.Rprofile` file so that it will be loaded on start-up of \R. To do this, open the `.Rprofile` file using e.g. `utils::file.edit("~/.Rprofile")`, add this text and save the file:
#'
#' ```r
#' # Add custom microorganism codes:
#' options(AMR_custom_mo = "~/my_custom_mo.rds")
#' ```
#'
#'
#' Upon package load, this file will be loaded and run through the [add_custom_microorganisms()] function.
#'
#'
#' **Method 2:** Loading the microorganism directly from your `.Rprofile` file. An important downside is that this requires the `AMR` package to be installed or else this method will fail. To use this method:
#'
#'
#' 1. Edit the `.Rprofile` file using e.g. `utils::file.edit("~/.Rprofile")`.
#'
#' 2. Add a text like below and save the file:
@ -77,44 +77,49 @@
#' # now add a custom entry - it will be considered by as.mo() and
#' # all mo_*() functions
#' add_custom_microorganisms(
#' data.frame(genus = "Enterobacter",
#' species = "asburiae/cloacae"
#' data.frame(
#' genus = "Enterobacter",
#' species = "asburiae/cloacae"
#' )
#' )
#'
#' # E. asburiae/cloacae is now a new microorganism:
#' mo_name("Enterobacter asburiae/cloacae")
#'
#'
#' # its code:
#' as.mo("Enterobacter asburiae/cloacae")
#'
#'
#' # all internal algorithms will work as well:
#' mo_name("Ent asburia cloacae")
#'
#'
#' # and even the taxonomy was added based on the genus!
#' mo_family("E. asburiae/cloacae")
#' mo_gramstain("Enterobacter asburiae/cloacae")
#'
#' mo_info("Enterobacter asburiae/cloacae")
#'
#'
#'
#'
#' # the function tries to be forgiving:
#' add_custom_microorganisms(
#' data.frame(GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE",
#' SPECIES = "SPECIES")
#' data.frame(
#' GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE",
#' SPECIES = "SPECIES"
#' )
#' )
#' mo_name("BACTEROIDES / PARABACTEROIDES")
#' mo_rank("BACTEROIDES / PARABACTEROIDES")
#'
#'
#' # taxonomy still works, although a slashline genus was given as input:
#' mo_family("Bacteroides/Parabacteroides")
#'
#'
#'
#'
#' # for groups and complexes, set them as species or subspecies:
#' add_custom_microorganisms(
#' data.frame(genus = "Citrobacter",
#' species = c("freundii", "braakii complex"),
#' subspecies = c("complex", ""))
#' data.frame(
#' genus = "Citrobacter",
#' species = c("freundii", "braakii complex"),
#' subspecies = c("complex", "")
#' )
#' )
#' mo_name(c("C. freundii complex", "C. braakii complex"))
#' mo_species(c("C. freundii complex", "C. braakii complex"))
@ -123,9 +128,9 @@
add_custom_microorganisms <- function(x) {
meet_criteria(x, allow_class = "data.frame")
stop_ifnot("genus" %in% tolower(colnames(x)), paste0("`x` must contain column 'genus'."))
add_MO_lookup_to_AMR_env()
# remove any extra class/type, such as grouped tbl, or data.table:
x <- as.data.frame(x, stringsAsFactors = FALSE)
colnames(x) <- tolower(colnames(x))
@ -135,7 +140,7 @@ add_custom_microorganisms <- function(x) {
}
# keep only columns available in the microorganisms data set
x <- x[, colnames(AMR_env$MO_lookup)[colnames(AMR_env$MO_lookup) %in% colnames(x)], drop = FALSE]
# clean the input ----
for (col in c("genus", "species", "subspecies")) {
if (!col %in% colnames(x)) {
@ -152,7 +157,7 @@ add_custom_microorganisms <- function(x) {
col_ <- gsub(" *([/-]) *", "\\1", col_, perl = TRUE)
# groups are in our taxonomic table with a capital G
col_ <- gsub(" group( |$)", " Group\\1", col_, perl = TRUE)
col_[is.na(col_)] <- ""
if (col == "genus") {
substr(col_, 1, 1) <- toupper(substr(col_, 1, 1))
@ -163,19 +168,27 @@ add_custom_microorganisms <- function(x) {
x[, col] <- col_
}
# if subspecies is a group or complex, add it to the species and empty the subspecies
x$species[which(x$subspecies %in% c("group", "Group", "complex"))] <- paste(x$species[which(x$subspecies %in% c("group", "Group", "complex"))],
x$subspecies[which(x$subspecies %in% c("group", "Group", "complex"))])
x$species[which(x$subspecies %in% c("group", "Group", "complex"))] <- paste(
x$species[which(x$subspecies %in% c("group", "Group", "complex"))],
x$subspecies[which(x$subspecies %in% c("group", "Group", "complex"))]
)
x$subspecies[which(x$subspecies %in% c("group", "Group", "complex"))] <- ""
if ("rank" %in% colnames(x)) {
stop_ifnot(all(x$rank %in% AMR_env$MO_lookup$rank),
"the 'rank' column can only contain these values: ", vector_or(AMR_env$MO_lookup$rank))
stop_ifnot(
all(x$rank %in% AMR_env$MO_lookup$rank),
"the 'rank' column can only contain these values: ", vector_or(AMR_env$MO_lookup$rank)
)
} else {
x$rank <- ifelse(x$subspecies != "", "subspecies",
ifelse(x$species != "", "species",
ifelse(x$genus != "", "genus",
stop("in add_custom_microorganisms(): only microorganisms up to the genus level can be added",
call. = FALSE))))
ifelse(x$species != "", "species",
ifelse(x$genus != "", "genus",
stop("in add_custom_microorganisms(): only microorganisms up to the genus level can be added",
call. = FALSE
)
)
)
)
}
x$source <- "Added by user"
if (!"fullname" %in% colnames(x)) {
@ -191,7 +204,7 @@ add_custom_microorganisms <- function(x) {
x$class[is.na(x$class)] <- ""
x$order[is.na(x$order)] <- ""
x$family[is.na(x$family)] <- ""
for (col in colnames(x)) {
if (is.factor(x[, col, drop = TRUE])) {
x[, col] <- as.character(x[, col, drop = TRUE])
@ -200,7 +213,7 @@ add_custom_microorganisms <- function(x) {
x[, col] <- as.list(x[, col, drop = TRUE])
}
}
# fill in taxonomy based on genus
genus_to_check <- gsub("^(.*)[^a-zA-Z].*", "\\1", x$genus, perl = TRUE)
x$kingdom[which(x$kingdom == "" & genus_to_check != "")] <- AMR_env$MO_lookup$kingdom[match(genus_to_check[which(x$kingdom == "" & genus_to_check != "")], AMR_env$MO_lookup$genus)]
@ -208,7 +221,7 @@ add_custom_microorganisms <- function(x) {
x$class[which(x$class == "" & genus_to_check != "")] <- AMR_env$MO_lookup$class[match(genus_to_check[which(x$class == "" & genus_to_check != "")], AMR_env$MO_lookup$genus)]
x$order[which(x$order == "" & genus_to_check != "")] <- AMR_env$MO_lookup$order[match(genus_to_check[which(x$order == "" & genus_to_check != "")], AMR_env$MO_lookup$genus)]
x$family[which(x$family == "" & genus_to_check != "")] <- AMR_env$MO_lookup$family[match(genus_to_check[which(x$family == "" & genus_to_check != "")], AMR_env$MO_lookup$genus)]
# fill in other columns that are used in internal algorithms
x$prevalence <- NA_real_
x$prevalence[which(genus_to_check != "")] <- AMR_env$MO_lookup$prevalence[match(genus_to_check[which(genus_to_check != "")], AMR_env$MO_lookup$genus)]
@ -222,7 +235,7 @@ add_custom_microorganisms <- function(x) {
x$full_first <- substr(x$fullname_lower, 1, 1)
x$species_first <- tolower(substr(x$species, 1, 1))
x$subspecies_first <- tolower(substr(x$subspecies, 1, 1))
if (!"mo" %in% colnames(x)) {
# create the mo code
x$mo <- NA_character_
@ -230,19 +243,27 @@ add_custom_microorganisms <- function(x) {
x$mo <- trimws2(as.character(x$mo))
x$mo[x$mo == ""] <- NA_character_
current <- sum(AMR_env$MO_lookup$source == "Added by user", na.rm = TRUE)
x$mo[is.na(x$mo)] <- paste0("CUSTOM",
seq.int(from = current + 1, to = current + nrow(x), by = 1),
"_",
toupper(unname(abbreviate(gsub(" +", " _ ",
gsub("[^A-Za-z0-9-]", " ",
trimws2(paste(x$genus, x$species, x$subspecies)))),
minlength = 10))))
x$mo[is.na(x$mo)] <- paste0(
"CUSTOM",
seq.int(from = current + 1, to = current + nrow(x), by = 1),
"_",
toupper(unname(abbreviate(
gsub(
" +", " _ ",
gsub(
"[^A-Za-z0-9-]", " ",
trimws2(paste(x$genus, x$species, x$subspecies))
)
),
minlength = 10
)))
)
stop_if(anyDuplicated(c(as.character(AMR_env$MO_lookup$mo), x$mo)), "MO codes must be unique and not match existing MO codes of the AMR package")
# add to package ----
AMR_env$custom_mo_codes <- c(AMR_env$custom_mo_codes, x$mo)
class(AMR_env$MO_lookup$mo) <- "character"
new_df <- AMR_env$MO_lookup[0, , drop = FALSE][seq_len(NROW(x)), , drop = FALSE]
rownames(new_df) <- NULL
list_cols <- vapply(FUN.VALUE = logical(1), new_df, is.list)
@ -254,10 +275,10 @@ add_custom_microorganisms <- function(x) {
# assign new values
new_df[, col] <- x[, col, drop = TRUE]
}
# clear previous coercions
suppressMessages(mo_reset_session())
AMR_env$MO_lookup <- unique(rbind(AMR_env$MO_lookup, new_df))
class(AMR_env$MO_lookup$mo) <- c("mo", "character")
if (nrow(x) <= 3) {
@ -271,11 +292,11 @@ add_custom_microorganisms <- function(x) {
#' @export
clear_custom_microorganisms <- function() {
n <- nrow(AMR_env$MO_lookup)
# reset
AMR_env$MO_lookup <- NULL
add_MO_lookup_to_AMR_env()
n2 <- nrow(AMR_env$MO_lookup)
AMR_env$custom_mo_codes <- character(0)
AMR_env$mo_previously_coerced <- AMR_env$mo_previously_coerced[which(AMR_env$mo_previously_coerced$mo %in% AMR_env$MO_lookup$mo), , drop = FALSE]

10
R/data.R
View File

@ -65,10 +65,10 @@
#'
#' ### Direct download
#' Like all data sets in this package, these data sets are publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @source
#'
#' @source
#'
#' * World Health Organization (WHO) Collaborating Centre for Drug Statistics Methodology (WHOCC): <https://www.whocc.no/atc_ddd_index/>
#'
#'
#' * `r TAXONOMY_VERSION$LOINC$citation` Accessed from <`r TAXONOMY_VERSION$LOINC$url`> on `r documentation_date(TAXONOMY_VERSION$LOINC$accessed_date)`.
#'
#' * European Commission Public Health PHARMACEUTICALS - COMMUNITY REGISTER: <https://ec.europa.eu/health/documents/community-register/html/reg_hum_atc.htm>
@ -141,9 +141,9 @@
#' * `r TAXONOMY_VERSION$GBIF$citation` Accessed from <`r TAXONOMY_VERSION$GBIF$url`> on `r documentation_date(TAXONOMY_VERSION$GBIF$accessed_date)`.
#'
#' * `r TAXONOMY_VERSION$SNOMED$citation` URL: <`r TAXONOMY_VERSION$SNOMED$url`>
#'
#'
#' * Grimont *et al.* (2007). Antigenic Formulae of the Salmonella Serovars, 9th Edition. WHO Collaborating Centre for Reference and Research on *Salmonella* (WHOCC-SALM).
#'
#'
#' * Bartlett *et al.* (2022). **A comprehensive list of bacterial pathogens infecting humans** *Microbiology* 168:001269; \doi{10.1099/mic.0.001269}
#' @seealso [as.mo()], [mo_property()], [microorganisms.codes], [intrinsic_resistant]
#' @examples

14
R/disk.R
View File

@ -120,13 +120,13 @@ as.disk <- function(x, na.rm = FALSE) {
vector_and(quotes = TRUE)
cur_col <- get_current_column()
warning_("in `as.disk()`: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid disk zones: ",
list_missing,
call = FALSE
ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid disk zones: ",
list_missing,
call = FALSE
)
}
}

13
R/episode.R
View File

@ -57,11 +57,12 @@
#' df[which(get_episode(df$date, 60) == 3), ]
#'
#' # the functions also work for less than a day, e.g. to include one per hour:
#' get_episode(c(
#' Sys.time(),
#' Sys.time() + 60 * 60
#' ),
#' episode_days = 1 / 24
#' get_episode(
#' c(
#' Sys.time(),
#' Sys.time() + 60 * 60
#' ),
#' episode_days = 1 / 24
#' )
#'
#' \donttest{
@ -98,7 +99,6 @@
#' )
#' }
#' if (require("dplyr")) {
#'
#' # grouping on patients and microorganisms leads to the same
#' # results as first_isolate() when using 'episode-based':
#' x <- df %>%
@ -115,7 +115,6 @@
#' identical(x, y)
#' }
#' if (require("dplyr")) {
#'
#' # but is_new_episode() has a lot more flexibility than first_isolate(),
#' # since you can now group on anything that seems relevant:
#' df %>%

88
R/eucast_rules.R
View File

@ -702,11 +702,12 @@ eucast_rules <- function(x,
# Print rule -------------------------------------------------------------
if (rule_current != rule_previous) {
# is new rule within group, print its name
cat(italicise_taxonomy(word_wrap(rule_current,
width = getOption("width") - 30,
extra_indent = 6
),
type = "ansi"
cat(italicise_taxonomy(
word_wrap(rule_current,
width = getOption("width") - 30,
extra_indent = 6
),
type = "ansi"
))
warned <- FALSE
}
@ -721,21 +722,23 @@ eucast_rules <- function(x,
if (mo_value %like% "coagulase" && any(x$genus == "Staphylococcus", na.rm = TRUE)) {
if (mo_value %like% "negative") {
eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(all_staph[which(all_staph$CNS_CPS %like% "negative"),
"fullname",
drop = TRUE
],
collapse = "|"
"^(", paste0(
all_staph[which(all_staph$CNS_CPS %like% "negative"),
"fullname",
drop = TRUE
],
collapse = "|"
),
")$"
)
} else {
eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(all_staph[which(all_staph$CNS_CPS %like% "positive"),
"fullname",
drop = TRUE
],
collapse = "|"
"^(", paste0(
all_staph[which(all_staph$CNS_CPS %like% "positive"),
"fullname",
drop = TRUE
],
collapse = "|"
),
")$"
)
@ -745,11 +748,12 @@ eucast_rules <- function(x,
# be sure to comprise all beta-haemolytic Streptococci (Lancefield groups A, B, C and G) when they are mentioned
if (mo_value %like% "group [ABCG]" && any(x$genus == "Streptococcus", na.rm = TRUE)) {
eucast_rules_df[i, "this_value"] <- paste0(
"^(", paste0(all_strep[which(all_strep$Lancefield %like% "group [ABCG]"),
"fullname",
drop = TRUE
],
collapse = "|"
"^(", paste0(
all_strep[which(all_strep$Lancefield %like% "group [ABCG]"),
"fullname",
drop = TRUE
],
collapse = "|"
),
")$"
)
@ -789,15 +793,17 @@ eucast_rules <- function(x,
if (length(source_antibiotics) == 0) {
rows <- integer(0)
} else if (length(source_antibiotics) == 1) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value &
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
error = function(e) integer(0)
rows <- tryCatch(
which(x[, if_mo_property, drop = TRUE] %like% mo_value &
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L]),
error = function(e) integer(0)
)
} else if (length(source_antibiotics) == 2) {
rows <- tryCatch(which(x[, if_mo_property, drop = TRUE] %like% mo_value &
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L] &
as.sir_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
error = function(e) integer(0)
rows <- tryCatch(
which(x[, if_mo_property, drop = TRUE] %like% mo_value &
as.sir_no_warning(x[, source_antibiotics[1L]]) == source_value[1L] &
as.sir_no_warning(x[, source_antibiotics[2L]]) == source_value[2L]),
error = function(e) integer(0)
)
# nolint start
# } else if (length(source_antibiotics) == 3) {
@ -872,11 +878,12 @@ eucast_rules <- function(x,
)
if (isTRUE(info)) {
# print rule
cat(italicise_taxonomy(word_wrap(format_custom_query_rule(rule$query, colours = FALSE),
width = getOption("width") - 30,
extra_indent = 6
),
type = "ansi"
cat(italicise_taxonomy(
word_wrap(format_custom_query_rule(rule$query, colours = FALSE),
width = getOption("width") - 30,
extra_indent = 6
),
type = "ansi"
))
warned <- FALSE
}
@ -1117,14 +1124,15 @@ edit_sir <- function(x,
},
error = function(e) {
txt_error()
stop(paste0(
"In row(s) ", paste(rows[seq_len(min(length(rows), 10))], collapse = ","),
ifelse(length(rows) > 10, "...", ""),
" while writing value '", to,
"' to column(s) `", paste(cols, collapse = "`, `"),
"`:\n", e$message
),
call. = FALSE
stop(
paste0(
"In row(s) ", paste(rows[seq_len(min(length(rows), 10))], collapse = ","),
ifelse(length(rows) > 10, "...", ""),
" while writing value '", to,
"' to column(s) `", paste(cols, collapse = "`, `"),
"`:\n", e$message
),
call. = FALSE
)
}
)

76
R/first_isolate.R
View File

@ -144,13 +144,11 @@
#' filter(first_isolate())
#' }
#' if (require("dplyr")) {
#'
#' # short-hand version:
#' example_isolates %>%
#' filter_first_isolate(info = FALSE)
#' }
#' if (require("dplyr")) {
#'
#' # flag the first isolates per group:
#' example_isolates %>%
#' group_by(ward) %>%
@ -244,18 +242,19 @@ first_isolate <- function(x = NULL,
method <- "episode-based"
}
if (isTRUE(info) && message_not_thrown_before("first_isolate", "method")) {
message_(paste0(
"Determining first isolates ",
ifelse(method %in% c("episode-based", "phenotype-based"),
ifelse(is.infinite(episode_days),
"without a specified episode length",
paste("using an episode length of", episode_days, "days")
),
""
)
),
as_note = FALSE,
add_fn = font_black
message_(
paste0(
"Determining first isolates ",
ifelse(method %in% c("episode-based", "phenotype-based"),
ifelse(is.infinite(episode_days),
"without a specified episode length",
paste("using an episode length of", episode_days, "days")
),
""
)
),
as_note = FALSE,
add_fn = font_black
)
}
@ -469,15 +468,17 @@ first_isolate <- function(x = NULL,
x$other_pat_or_mo <- !(x$newvar_patient_id == pm_lag(x$newvar_patient_id) & x$newvar_genus_species == pm_lag(x$newvar_genus_species))
x$episode_group <- paste(x$newvar_patient_id, x$newvar_genus_species)
x$more_than_episode_ago <- unlist(lapply(split(
x$newvar_date,
x$episode_group
),
exec_episode, # this will skip meet_criteria() in is_new_episode(), saving time
type = "logical",
episode_days = episode_days
),
use.names = FALSE
x$more_than_episode_ago <- unlist(
lapply(
split(
x$newvar_date,
x$episode_group
),
exec_episode, # this will skip meet_criteria() in is_new_episode(), saving time
type = "logical",
episode_days = episode_days
),
use.names = FALSE
)
if (!is.null(col_keyantimicrobials)) {
@ -606,21 +607,22 @@ first_isolate <- function(x = NULL,
}
# mark up number of found
n_found <- format(n_found, big.mark = big.mark, decimal.mark = decimal.mark)
message_(paste0(
"=> Found ",
font_bold(paste0(
n_found,
ifelse(method == "isolate-based", "", paste0(" '", method, "'")),
" first isolates"
)),
" (",
ifelse(p_found_total != p_found_scope,
paste0(p_found_scope, " within scope and "),
""
message_(
paste0(
"=> Found ",
font_bold(paste0(
n_found,
ifelse(method == "isolate-based", "", paste0(" '", method, "'")),
" first isolates"
)),
" (",
ifelse(p_found_total != p_found_scope,
paste0(p_found_scope, " within scope and "),
""
),
p_found_total, " of total where a microbial ID was available)"
),
p_found_total, " of total where a microbial ID was available)"
),
add_fn = font_black, as_note = FALSE
add_fn = font_black, as_note = FALSE
)
}

15
R/ggplot_pca.R
View File

@ -414,13 +414,14 @@ pca_calculations <- function(pca_model,
sigma <- var(cbind(x$xvar, x$yvar))
mu <- c(mean(x$xvar), mean(x$yvar))
ed <- sqrt(qchisq(ellipse_prob, df = 2))
data.frame(sweep(circle %*% chol(sigma) * ed,
MARGIN = 2,
STATS = mu,
FUN = "+"
),
groups = x$groups[1],
stringsAsFactors = FALSE
data.frame(
sweep(circle %*% chol(sigma) * ed,
MARGIN = 2,
STATS = mu,
FUN = "+"
),
groups = x$groups[1],
stringsAsFactors = FALSE
)
})
ell <- do.call(rbind, df.groups)

10
R/ggplot_sir.R
View File

@ -71,13 +71,11 @@
#' @examples
#' \donttest{
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # get antimicrobial results for drugs against a UTI:
#' ggplot(example_isolates %>% select(AMX, NIT, FOS, TMP, CIP)) +
#' geom_sir()
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # prettify the plot using some additional functions:
#' df <- example_isolates %>% select(AMX, NIT, FOS, TMP, CIP)
#' ggplot(df) +
@ -88,21 +86,18 @@
#' theme_sir()
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # or better yet, simplify this using the wrapper function - a single command:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_sir()
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # get only proportions and no counts:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_sir(datalabels = FALSE)
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # add other ggplot2 arguments as you like:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
@ -115,14 +110,12 @@
#' )
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # you can alter the colours with colour names:
#' example_isolates %>%
#' select(AMX) %>%
#' ggplot_sir(colours = c(SI = "yellow"))
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # but you can also use the built-in colour-blind friendly colours for
#' # your plots, where "S" is green, "I" is yellow and "R" is red:
#' data.frame(
@ -135,7 +128,6 @@
#' scale_sir_colours(Value4 = "S", Value5 = "I", Value6 = "R")
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # resistance of ciprofloxacine per age group
#' example_isolates %>%
#' mutate(first_isolate = first_isolate()) %>%
@ -149,14 +141,12 @@
#' ggplot_sir(x = "age_group")
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # a shorter version which also adjusts data label colours:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_sir(colours = FALSE)
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#' # it also supports groups (don't forget to use the group var on `x` or `facet`):
#' example_isolates %>%
#' filter(mo_is_gram_negative(), ward != "Outpatient") %>%

39
R/guess_ab_col.R
View File

@ -274,14 +274,15 @@ get_column_abx <- function(x,
}
if (names(out[i]) %in% names(duplicates)) {
already_set_as <- out[unname(out) == unname(out[i])][1L]
warning_(paste0(
"Column '", font_bold(out[i]), "' will not be used for ",
names(out)[i], " (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")",
", as it is already set for ",
names(already_set_as), " (", ab_name(names(already_set_as), tolower = TRUE, language = NULL), ")"
),
add_fn = font_red,
immediate = verbose
warning_(
paste0(
"Column '", font_bold(out[i]), "' will not be used for ",
names(out)[i], " (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")",
", as it is already set for ",
names(already_set_as), " (", ab_name(names(already_set_as), tolower = TRUE, language = NULL), ")"
),
add_fn = font_red,
immediate = verbose
)
}
}
@ -307,11 +308,12 @@ get_column_abx <- function(x,
if (isTRUE(info) && !all(soft_dependencies %in% names(out))) {
# missing a soft dependency may lower the reliability
missing <- soft_dependencies[!soft_dependencies %in% names(out)]
missing_msg <- vector_and(paste0(
ab_name(missing, tolower = TRUE, language = NULL),
" (", font_bold(missing, collapse = NULL), ")"
),
quotes = FALSE
missing_msg <- vector_and(
paste0(
ab_name(missing, tolower = TRUE, language = NULL),
" (", font_bold(missing, collapse = NULL), ")"
),
quotes = FALSE
)
message_(
"Reliability would be improved if these antimicrobial results would be available too: ",
@ -355,10 +357,11 @@ generate_warning_abs_missing <- function(missing, any = FALSE) {
} else {
any_txt <- c("", "are")
}
warning_(paste0(
"Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
vector_and(missing, quotes = FALSE)
),
immediate = TRUE
warning_(
paste0(
"Introducing NAs since", any_txt[1], " these antimicrobials ", any_txt[2], " required: ",
vector_and(missing, quotes = FALSE)
),
immediate = TRUE
)
}

59
R/italicise_taxonomy.R
View File

@ -73,41 +73,44 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
search_strings <- gsub("[^a-zA-Z-]", "", s_split)
ind_species <- search_strings != "" &
search_strings %in% AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c(
"family",
"genus",
search_strings %in% AMR_env$MO_lookup[
which(AMR_env$MO_lookup$rank %in% c(
"family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp."
)),
"species",
"subspecies",
"infraspecies",
"subsp."
)),
"species",
drop = TRUE
drop = TRUE
]
ind_fullname <- search_strings != "" &
search_strings %in% c(
AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c(
"family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp."
)),
"fullname",
drop = TRUE
AMR_env$MO_lookup[
which(AMR_env$MO_lookup$rank %in% c(
"family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp."
)),
"fullname",
drop = TRUE
],
AMR_env$MO_lookup[which(AMR_env$MO_lookup$rank %in% c(
"family",
"genus",
"species",
AMR_env$MO_lookup[
which(AMR_env$MO_lookup$rank %in% c(
"family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp."
)),
"subspecies",
"infraspecies",
"subsp."
)),
"subspecies",
drop = TRUE
drop = TRUE
]
)

2
R/join_microorganisms.R
View File

@ -128,7 +128,7 @@ anti_join_microorganisms <- function(x, by = NULL, ...) {
join_microorganisms <- function(type, x, by, suffix, ...) {
add_MO_lookup_to_AMR_env()
if (!is.data.frame(x)) {
if (pkg_is_available("tibble", also_load = FALSE)) {
x <- import_fn("tibble", "tibble")(mo = x)

448
R/mdro.R
View File

@ -193,17 +193,17 @@ mdro <- function(x = NULL,
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
if (!any(is_sir_eligible(x))) {
stop_("There were no possible SIR columns found in the data set. Transform columns with `as.sir()` for valid antimicrobial interpretations.")
}
info.bak <- info
# don't thrown info's more than once per call
if (isTRUE(info)) {
info <- message_not_thrown_before("mdro")
}
if (interactive() && isTRUE(verbose) && isTRUE(info)) {
txt <- paste0(
"WARNING: In Verbose mode, the mdro() function does not return the MDRO results, but instead returns a data set in logbook form with extensive info about which isolates would be MDRO-positive, or why they are not.",
@ -221,7 +221,7 @@ mdro <- function(x = NULL,
return(x)
}
}
group_msg <- ""
if (isTRUE(info.bak)) {
# print group name if used in dplyr::group_by()
@ -243,15 +243,15 @@ mdro <- function(x = NULL,
}
}
}
# force regular [data.frame], not a tibble or data.table
x <- as.data.frame(x, stringsAsFactors = FALSE)
if (pct_required_classes > 1) {
# allow pct_required_classes = 75 -> pct_required_classes = 0.75
pct_required_classes <- pct_required_classes / 100
}
guideline.bak <- guideline
if (is.list(guideline)) {
# Custom MDRO guideline ---------------------------------------------------
@ -260,8 +260,8 @@ mdro <- function(x = NULL,
txt <- paste0(
"Determining MDROs based on custom rules",
ifelse(isTRUE(attributes(guideline)$as_factor),
paste0(", resulting in factor levels: ", paste0(attributes(guideline)$values, collapse = " < ")),
""
paste0(", resulting in factor levels: ", paste0(attributes(guideline)$values, collapse = " < ")),
""
),
"."
)
@ -314,7 +314,7 @@ mdro <- function(x = NULL,
"invalid guideline: ", guideline.bak
)
guideline <- list(code = guideline)
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
@ -329,7 +329,7 @@ mdro <- function(x = NULL,
col_mo <- "mo"
}
stop_if(is.null(col_mo), "`col_mo` must be set")
if (guideline$code == "cmi2012") {
guideline$name <- "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance."
guideline$author <- "Magiorakos AP, Srinivasan A, Carey RB, ..., Vatopoulos A, Weber JT, Monnet DL"
@ -360,7 +360,7 @@ mdro <- function(x = NULL,
guideline$version <- "WHO/HTM/TB/2014.11, 2014"
guideline$source_url <- font_url("https://www.who.int/publications/i/item/9789241548809", "Direct download")
guideline$type <- "MDR-TB's"
# support per country:
} else if (guideline$code == "mrgn") {
guideline$name <- "Cross-border comparison of the Dutch and German guidelines on multidrug-resistant Gram-negative microorganisms"
@ -377,7 +377,7 @@ mdro <- function(x = NULL,
} else {
stop("This guideline is currently unsupported: ", guideline$code, call. = FALSE)
}
if (guideline$code == "cmi2012") {
cols_ab <- get_column_abx(
x = x,
@ -456,7 +456,7 @@ mdro <- function(x = NULL,
}
cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"])))
}
# nolint start
AMC <- cols_ab["AMC"]
AMK <- cols_ab["AMK"]
@ -601,13 +601,13 @@ mdro <- function(x = NULL,
abx_tb <- abx_tb[!is.na(abx_tb)]
stop_if(guideline$code == "tb" & length(abx_tb) == 0, "no antimycobacterials found in data set")
# nolint end
if (isTRUE(combine_SI)) {
search_result <- "R"
} else {
search_result <- c("R", "I")
}
if (isTRUE(info)) {
if (isTRUE(combine_SI)) {
cat(font_red("\nOnly results with 'R' are considered as resistance. Use `combine_SI = FALSE` to also consider 'I' as resistance.\n"))
@ -615,18 +615,18 @@ mdro <- function(x = NULL,
cat(font_red("\nResults with 'R' or 'I' are considered as resistance. Use `combine_SI = TRUE` to only consider 'R' as resistance.\n"))
}
cat("\n", word_wrap("Determining multidrug-resistant organisms (MDRO), according to:"), "\n",
word_wrap(paste0(font_bold("Guideline: "), font_italic(guideline$name)), extra_indent = 11, as_note = FALSE), "\n",
word_wrap(paste0(font_bold("Author(s): "), guideline$author), extra_indent = 11, as_note = FALSE), "\n",
ifelse(!is.na(guideline$version),
paste0(word_wrap(paste0(font_bold("Version: "), guideline$version), extra_indent = 11, as_note = FALSE), "\n"),
""
),
paste0(font_bold("Source: "), guideline$source_url),
"\n\n",
sep = ""
word_wrap(paste0(font_bold("Guideline: "), font_italic(guideline$name)), extra_indent = 11, as_note = FALSE), "\n",
word_wrap(paste0(font_bold("Author(s): "), guideline$author), extra_indent = 11, as_note = FALSE), "\n",
ifelse(!is.na(guideline$version),
paste0(word_wrap(paste0(font_bold("Version: "), guideline$version), extra_indent = 11, as_note = FALSE), "\n"),
""
),
paste0(font_bold("Source: "), guideline$source_url),
"\n\n",
sep = ""
)
}
ab_missing <- function(ab) {
isTRUE(ab %in% c(NULL, NA)) | length(ab) == 0
}
@ -638,7 +638,7 @@ mdro <- function(x = NULL,
out[is.na(out)] <- FALSE
out
}
# antibiotic classes
# nolint start
aminoglycosides <- c(TOB, GEN)
@ -649,17 +649,18 @@ mdro <- function(x = NULL,
carbapenems <- c(DOR, ETP, IPM, MEM, MEV)
fluoroquinolones <- c(CIP, ENX, FLE, GAT, GEM, GRX, LVX, LOM, MFX, NOR, OFX, PAZ, PEF, PRU, RFL, SPX, TMX, TVA)
# nolint end
# helper function for editing the table
trans_tbl <- function(to, rows, cols, any_all) {
cols <- cols[!ab_missing(cols)]
cols <- cols[!is.na(cols)]
if (length(rows) > 0 && length(cols) > 0) {
x[, cols] <- as.data.frame(lapply(
x[, cols, drop = FALSE],
function(col) as.sir(col)
),
stringsAsFactors = FALSE
x[, cols] <- as.data.frame(
lapply(
x[, cols, drop = FALSE],
function(col) as.sir(col)
),
stringsAsFactors = FALSE
)
x[rows, "columns_nonsusceptible"] <<- vapply(
FUN.VALUE = character(1),
@ -670,22 +671,23 @@ mdro <- function(x = NULL,
x[row, group_vct, drop = FALSE],
function(y) y %in% search_result
)
paste(sort(c(
unlist(strsplit(x[row, "columns_nonsusceptible", drop = TRUE], ", ", fixed = TRUE)),
names(cols_nonsus)[cols_nonsus]
)),
collapse = ", "
paste(
sort(c(
unlist(strsplit(x[row, "columns_nonsusceptible", drop = TRUE], ", ", fixed = TRUE)),
names(cols_nonsus)[cols_nonsus]
)),
collapse = ", "
)
}
)
if (any_all == "any") {
search_function <- any
} else if (any_all == "all") {
search_function <- all
}
x_transposed <- as.list(as.data.frame(t(x[, cols, drop = FALSE]),
stringsAsFactors = FALSE
stringsAsFactors = FALSE
))
rows_affected <- vapply(
FUN.VALUE = logical(1),
@ -704,7 +706,7 @@ mdro <- function(x = NULL,
)
}
}
trans_tbl2 <- function(txt, rows, lst) {
if (isTRUE(info)) {
message_(txt, "...", appendLF = FALSE, as_note = FALSE)
@ -714,12 +716,13 @@ mdro <- function(x = NULL,
lst_vector <- unlist(lst)[!is.na(unlist(lst))]
# keep only unique ones:
lst_vector <- lst_vector[!duplicated(paste(lst_vector, names(lst_vector)))]
x[, lst_vector] <- as.data.frame(lapply(
x[, lst_vector, drop = FALSE],
function(col) as.sir(col)
),
stringsAsFactors = FALSE
x[, lst_vector] <- as.data.frame(
lapply(
x[, lst_vector, drop = FALSE],
function(col) as.sir(col)
),
stringsAsFactors = FALSE
)
x[rows, "classes_in_guideline"] <<- length(lst)
x[rows, "classes_available"] <<- vapply(
@ -733,7 +736,7 @@ mdro <- function(x = NULL,
))
}
)
if (isTRUE(verbose)) {
x[rows, "columns_nonsusceptible"] <<- vapply(
FUN.VALUE = character(1),
@ -748,30 +751,31 @@ mdro <- function(x = NULL,
FUN.VALUE = double(1),
rows,
function(row, group_tbl = lst) {
sum(vapply(
FUN.VALUE = logical(1),
group_tbl,
function(group) {
any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% search_result, na.rm = TRUE)
}
),
na.rm = TRUE
sum(
vapply(
FUN.VALUE = logical(1),
group_tbl,
function(group) {
any(unlist(x[row, group[!is.na(group)], drop = TRUE]) %in% search_result, na.rm = TRUE)
}
),
na.rm = TRUE
)
}
)
# for PDR; all drugs are R (or I if combine_SI = FALSE)
x_transposed <- as.list(as.data.frame(t(x[rows, lst_vector, drop = FALSE]),
stringsAsFactors = FALSE
stringsAsFactors = FALSE
))
row_filter <- vapply(FUN.VALUE = logical(1), x_transposed, function(y) all(y %in% search_result, na.rm = TRUE))
x[which(row_filter), "classes_affected"] <<- 999
}
if (isTRUE(info)) {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
}
}
x[, col_mo] <- as.mo(as.character(x[, col_mo, drop = TRUE]))
# rename col_mo to prevent interference with joined columns
colnames(x)[colnames(x) == col_mo] <- ".col_mo"
@ -782,12 +786,12 @@ mdro <- function(x = NULL,
x$row_number <- seq_len(nrow(x))
x$reason <- paste0("not covered by ", toupper(guideline$code), " guideline")
x$columns_nonsusceptible <- ""
if (guideline$code == "cmi2012") {
# CMI, 2012 ---------------------------------------------------------------
# Non-susceptible = R and I
# (see header 'Approaches to Creating Definitions for MDR, XDR and PDR' in paper)
# take amoxicillin if ampicillin is unavailable
if (is.na(AMP) && !is.na(AMX)) {
if (isTRUE(verbose)) {
@ -808,87 +812,87 @@ mdro <- function(x = NULL,
}
CTX <- CRO
}
# intrinsic resistant must not be considered for the determination of MDR,
# so let's just remove them, meticulously following the paper
x[which(x$genus == "Enterococcus" & x$species == "faecium"), ab_NA(IPM)] <- NA
x[which(x$genus == "Enterococcus" & x$species == "faecalis"), ab_NA(QDA)] <- NA
x[which((x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(GEN, TOB, NET))] <- NA
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(GEN, TOB, NET))] <- NA
x[which(x$genus == "Escherichia" & x$species == "hermannii"), ab_NA(c(TCC, TZP))] <- NA
x[which((x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CZO)] <- NA
(x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CZO)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CXM)] <- NA
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(CXM)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TGC)] <- NA
(x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TGC)] <- NA
x[which((x$genus == "Citrobacter" & x$species == "koseri") |
(x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Escherichia" & x$species == "hermannii") |
(x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Klebsiella") |
(x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMP)] <- NA
(x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Escherichia" & x$species == "hermannii") |
(x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Klebsiella") |
(x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMP)] <- NA
x[which((x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMC)] <- NA
(x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(AMC)] <- NA
x[which((x$genus == "Citrobacter" & x$species == "freundii") |
(x$genus == "Citrobacter" & x$species == "koseri") |
(x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(SAM)] <- NA
(x$genus == "Citrobacter" & x$species == "koseri") |
(x$genus == "Enterobacter" & x$species == "aerogenes") |
(x$genus == "Klebsiella" & x$species == "aerogenes") # new name (2017)
| (x$genus == "Enterobacter" & x$species == "cloacae") |
(x$genus == "Hafnia" & x$species == "alvei") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(SAM)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(COL)] <- NA
(x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii") |
(x$genus == "Serratia" & x$species == "marcescens")), ab_NA(COL)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TCY)] <- NA
(x$genus == "Proteus" & x$species == "mirabilis") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(TCY)] <- NA
x[which((x$genus == "Morganella" & x$species == "morganii") |
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(DOX, MNO))] <- NA
(x$genus == "Proteus" & x$species == "penneri") |
(x$genus == "Proteus" & x$species == "vulgaris") |
(x$genus == "Providencia" & x$species == "rettgeri") |
(x$genus == "Providencia" & x$species == "stuartii")), ab_NA(c(DOX, MNO))] <- NA
x$classes_in_guideline <- NA_integer_
x$classes_available <- NA_integer_
x$classes_affected <- NA_integer_
# now add the MDR levels to the data
trans_tbl(
2,
@ -990,7 +994,7 @@ mdro <- function(x = NULL,
c(TCY, DOX, MNO)
)
)
# now set MDROs:
# MDR (=2): >=3 classes affected
x[which(x$classes_affected >= 3), "MDRO"] <- 2
@ -1002,7 +1006,7 @@ mdro <- function(x = NULL,
" out of ", x$classes_available[which(x$classes_affected >= 3)], " available classes"
)
}
# XDR (=3): all but <=2 classes affected
x[which((x$classes_in_guideline - x$classes_affected) <= 2), "MDRO"] <- 3
if (isTRUE(verbose)) {
@ -1011,7 +1015,7 @@ mdro <- function(x = NULL,
" out of ", x$classes_in_guideline[which(x$MDRO == 3)], " classes)"
)
}
# PDR (=4): all drugs are R
x[which(x$classes_affected == 999 & x$classes_in_guideline == x$classes_available), "MDRO"] <- 4
if (isTRUE(verbose)) {
@ -1022,7 +1026,7 @@ mdro <- function(x = NULL,
ifelse(!isTRUE(combine_SI), " or I", "")
)
}
# not enough classes available
x[which(x$MDRO %in% c(1, 3) & x$classes_available < floor(x$classes_in_guideline * pct_required_classes)), "MDRO"] <- -1
if (isTRUE(verbose)) {
@ -1032,18 +1036,18 @@ mdro <- function(x = NULL,
" (~", percentage(pct_required_classes), " of ", x$classes_in_guideline[which(x$MDRO == -1)], ")"
)
}
# add antibiotic names of resistant ones to verbose output
}
if (guideline$code == "eucast3.1") {
# EUCAST 3.1 --------------------------------------------------------------
# Table 5
trans_tbl(
3,
which(x$order == "Enterobacterales" |
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"),
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"),
COL,
"all"
)
@ -1128,17 +1132,17 @@ mdro <- function(x = NULL,
"any"
)
}
if (guideline$code == "eucast3.2") {
# EUCAST 3.2 --------------------------------------------------------------
# Table 6
trans_tbl(
3,
which((x$order == "Enterobacterales" &
!x$family == "Morganellaceae" &
!(x$genus == "Serratia" & x$species == "marcescens")) |
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"),
!x$family == "Morganellaceae" &
!(x$genus == "Serratia" & x$species == "marcescens")) |
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"),
COL,
"all"
)
@ -1229,7 +1233,7 @@ mdro <- function(x = NULL,
"any"
)
}
if (guideline$code == "eucast3.3") {
# EUCAST 3.3 --------------------------------------------------------------
# note: this guideline is equal to EUCAST 3.2 - no MDRO insights changed
@ -1237,10 +1241,10 @@ mdro <- function(x = NULL,
trans_tbl(
3,
which((x$order == "Enterobacterales" &
!x$family == "Morganellaceae" &
!(x$genus == "Serratia" & x$species == "marcescens")) |
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"),
!x$family == "Morganellaceae" &
!(x$genus == "Serratia" & x$species == "marcescens")) |
(x$genus == "Pseudomonas" & x$species == "aeruginosa") |
x$genus == "Acinetobacter"),
COL,
"all"
)
@ -1331,72 +1335,72 @@ mdro <- function(x = NULL,
"any"
)
}
if (guideline$code == "mrgn") {
# Germany -----------------------------------------------------------------
# Table 1
trans_tbl(
2, # 3MRGN
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
try_ab(x[, PIP, drop = TRUE] == "R") &
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
(try_ab(x[, IPM, drop = TRUE] != "R") | try_ab(x[, MEM, drop = TRUE] != "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")),
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
try_ab(x[, PIP, drop = TRUE] == "R") &
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
(try_ab(x[, IPM, drop = TRUE] != "R") | try_ab(x[, MEM, drop = TRUE] != "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")),
c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any"
)
trans_tbl(
3, # 4MRGN, overwrites 3MRGN if applicable
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
try_ab(x[, PIP, drop = TRUE] == "R") &
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")),
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
try_ab(x[, PIP, drop = TRUE] == "R") &
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")),
c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any"
)
trans_tbl(
3, # 4MRGN, overwrites 3MRGN if applicable
which((x$order == "Enterobacterales" | # following in fact the old Enterobacteriaceae classification
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R"))),
(x$genus == "Acinetobacter" & x$species == "baumannii")) &
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R"))),
c(IPM, MEM),
"any"
)
trans_tbl(
2, # 3MRGN, if only 1 group is S
which(x$genus == "Pseudomonas" & x$species == "aeruginosa" &
try_ab(x[, PIP, drop = TRUE] == "S") +
try_ab(x[, CTX, drop = TRUE] == "S") +
try_ab(x[, CAZ, drop = TRUE] == "S") +
try_ab(x[, IPM, drop = TRUE] == "S") +
try_ab(x[, MEM, drop = TRUE] == "S") +
try_ab(x[, CIP, drop = TRUE] == "S") == 1),
try_ab(x[, PIP, drop = TRUE] == "S") +
try_ab(x[, CTX, drop = TRUE] == "S") +
try_ab(x[, CAZ, drop = TRUE] == "S") +
try_ab(x[, IPM, drop = TRUE] == "S") +
try_ab(x[, MEM, drop = TRUE] == "S") +
try_ab(x[, CIP, drop = TRUE] == "S") == 1),
c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any"
)
trans_tbl(
3, # 4MRGN otherwise
which((x$genus == "Pseudomonas" & x$species == "aeruginosa") &
try_ab(x[, PIP, drop = TRUE] == "R") &
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")),
try_ab(x[, PIP, drop = TRUE] == "R") &
(try_ab(x[, CTX, drop = TRUE] == "R") | try_ab(x[, CAZ, drop = TRUE] == "R")) &
(try_ab(x[, IPM, drop = TRUE] == "R") | try_ab(x[, MEM, drop = TRUE] == "R")) &
try_ab(x[, CIP, drop = TRUE] == "R")),
c(PIP, CTX, CAZ, IPM, MEM, CIP),
"any"
)
x[which(x$MDRO == 2), "reason"] <- "3MRGN"
x[which(x$MDRO == 3), "reason"] <- "4MRGN"
}
if (guideline$code == "brmo") {
# Netherlands -------------------------------------------------------------
aminoglycosides <- aminoglycosides[!is.na(aminoglycosides)]
@ -1409,7 +1413,7 @@ mdro <- function(x = NULL,
if (length(ESBLs) != 2) {
ESBLs <- character(0)
}
# Table 1
trans_tbl(
3,
@ -1417,21 +1421,21 @@ mdro <- function(x = NULL,
c(aminoglycosides, fluoroquinolones),
"all"
)
trans_tbl(
2,
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
carbapenems,
"any"
)
trans_tbl(
2,
which(x$order == "Enterobacterales"), # following in fact the old Enterobacteriaceae classification
ESBLs,
"all"
)
# Table 2
trans_tbl(
2,
@ -1445,19 +1449,19 @@ mdro <- function(x = NULL,
c(aminoglycosides, fluoroquinolones),
"all"
)
trans_tbl(
3,
which(x$genus == "Stenotrophomonas" & x$species == "maltophilia"),
SXT,
"all"
)
if (!ab_missing(MEM) && !ab_missing(IPM) &&
!ab_missing(GEN) && !ab_missing(TOB) &&
!ab_missing(CIP) &&
!ab_missing(CAZ) &&
!ab_missing(TZP)) {
!ab_missing(GEN) && !ab_missing(TOB) &&
!ab_missing(CIP) &&
!ab_missing(CAZ) &&
!ab_missing(TZP)) {
x$psae <- 0
x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, MEM, drop = TRUE] == "R" | x[, IPM, drop = TRUE] == "R"), "psae"]
x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"] <- 1 + x[which(x[, GEN, drop = TRUE] == "R" & x[, TOB, drop = TRUE] == "R"), "psae"]
@ -1477,7 +1481,7 @@ mdro <- function(x = NULL,
x$genus == "Pseudomonas" & x$species == "aeruginosa" &
x$psae >= 3
), "reason"] <- paste0("at least 3 classes contain R", ifelse(!isTRUE(combine_SI), " or I", ""))
# Table 3
trans_tbl(
3,
@ -1498,7 +1502,7 @@ mdro <- function(x = NULL,
"all"
)
}
if (guideline$code == "tb") {
# Tuberculosis ------------------------------------------------------------
prepare_drug <- function(ab) {
@ -1535,7 +1539,7 @@ mdro <- function(x = NULL,
ab != "R"
}
}
x$mono_count <- 0
x[drug_is_R(INH), "mono_count"] <- x[drug_is_R(INH), "mono_count", drop = TRUE] + 1
x[drug_is_R(RIF), "mono_count"] <- x[drug_is_R(RIF), "mono_count", drop = TRUE] + 1
@ -1543,7 +1547,7 @@ mdro <- function(x = NULL,
x[drug_is_R(PZA), "mono_count"] <- x[drug_is_R(PZA), "mono_count", drop = TRUE] + 1
x[drug_is_R(RIB), "mono_count"] <- x[drug_is_R(RIB), "mono_count", drop = TRUE] + 1
x[drug_is_R(RFP), "mono_count"] <- x[drug_is_R(RFP), "mono_count", drop = TRUE] + 1
x$mono <- x$mono_count > 0
x$poly <- x$mono_count > 1 & drug_is_not_R(RIF) & drug_is_not_R(INH)
x$mdr <- drug_is_R(RIF) & drug_is_R(INH)
@ -1551,19 +1555,19 @@ mdro <- function(x = NULL,
x$second <- drug_is_R(CAP) | drug_is_R(KAN) | drug_is_R(AMK)
x$xdr <- x$mdr & x$xdr & x$second
x$MDRO <- ifelse(x$xdr, 5,
ifelse(x$mdr, 4,
ifelse(x$poly, 3,
ifelse(x$mono, 2,
1
)
)
)
ifelse(x$mdr, 4,
ifelse(x$poly, 3,
ifelse(x$mono, 2,
1
)
)
)
)
# keep all real TB, make other species NA
x$MDRO <- ifelse(x$fullname == "Mycobacterium tuberculosis", x$MDRO, NA_real_)
x$reason <- "PDR/MDR/XDR criteria were met"
}
# some more info on negative results
if (isTRUE(verbose)) {
if (guideline$code == "cmi2012") {
@ -1579,7 +1583,7 @@ mdro <- function(x = NULL,
x[which(x$MDRO == 1), "reason"] <- "too few antibiotics are R"
}
}
if (isTRUE(info.bak)) {
cat(group_msg)
if (sum(!is.na(x$MDRO)) == 0) {
@ -1591,11 +1595,11 @@ mdro <- function(x = NULL,
)))
}
}
# Fill in blanks ----
# for rows that have no results
x_transposed <- as.list(as.data.frame(t(x[, cols_ab, drop = FALSE]),
stringsAsFactors = FALSE
stringsAsFactors = FALSE
))
rows_empty <- which(vapply(
FUN.VALUE = logical(1),
@ -1609,7 +1613,7 @@ mdro <- function(x = NULL,
} else {
cat("\n")
}
# Results ----
if (guideline$code == "cmi2012") {
if (any(x$MDRO == -1, na.rm = TRUE)) {
@ -1656,7 +1660,7 @@ mdro <- function(x = NULL,
ordered = TRUE
)
}
if (isTRUE(verbose)) {
colnames(x)[colnames(x) == col_mo] <- "microorganism"
x$microorganism <- mo_name(x$microorganism, language = NULL)
@ -1678,9 +1682,9 @@ mdro <- function(x = NULL,
#' @export
custom_mdro_guideline <- function(..., as_factor = TRUE) {
meet_criteria(as_factor, allow_class = "logical", has_length = 1)
dots <- tryCatch(list(...),
error = function(e) "error"
error = function(e) "error"
)
stop_if(
identical(dots, "error"),
@ -1694,7 +1698,7 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
inherits(dots[[i]], "formula"),
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?mdro`"
)
# Query
qry <- dots[[i]][[2]]
if (inherits(qry, "call")) {
@ -1710,14 +1714,14 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
qry <- gsub(" *([&|+-/*^><==]+) *", " \\1 ", qry)
qry <- gsub("'", "\"", qry, fixed = TRUE)
out[[i]]$query <- as.expression(qry)
# Value
val <- tryCatch(eval(dots[[i]][[3]]), error = function(e) NULL)
stop_if(is.null(val), "rule ", i, " must return a valid value, it now returns an error: ", tryCatch(eval(dots[[i]][[3]]), error = function(e) e$message))
stop_if(length(val) > 1, "rule ", i, " must return a value of length 1, not ", length(val))
out[[i]]$value <- as.character(val)
}
names(out) <- paste0("rule", seq_len(n_dots))
out <- set_clean_class(out, new_class = c("custom_mdro_guideline", "list"))
attr(out, "values") <- unname(c("Negative", vapply(FUN.VALUE = character(1), unclass(out), function(x) x$value)))
@ -1739,8 +1743,8 @@ c.custom_mdro_guideline <- function(x, ..., as_factor = NULL) {
}
for (g in list(...)) {
stop_ifnot(inherits(g, "custom_mdro_guideline"),
"for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`",
call = FALSE
"for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`",
call = FALSE
)
vals <- attributes(x)$values
if (!all(attributes(g)$values %in% vals)) {
@ -1790,28 +1794,28 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
reasons <- character(length = NROW(df))
for (i in seq_len(n_dots)) {
qry <- tryCatch(eval(parse(text = guideline[[i]]$query), envir = df, enclos = parent.frame()),
error = function(e) {
AMR_env$err_msg <- e$message
return("error")
}
error = function(e) {
AMR_env$err_msg <- e$message
return("error")
}
)
if (identical(qry, "error")) {
warning_("in `custom_mdro_guideline()`: rule ", i,
" (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
AMR_env$err_msg,
call = FALSE,
add_fn = font_red
" (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
AMR_env$err_msg,
call = FALSE,
add_fn = font_red
)
next
}
stop_ifnot(is.logical(qry), "in custom_mdro_guideline(): rule ", i, " (`", guideline[[i]]$query,
"`) must return `TRUE` or `FALSE`, not ",
format_class(class(qry), plural = FALSE),
call = FALSE
"`) must return `TRUE` or `FALSE`, not ",
format_class(class(qry), plural = FALSE),
call = FALSE
)
new_mdros <- which(qry == TRUE & out == "")
if (isTRUE(info)) {
cat(word_wrap(
"- Custom MDRO rule ", i, ": `", as.character(guideline[[i]]$query),
@ -1827,11 +1831,11 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
}
out[out == ""] <- "Negative"
reasons[out == "Negative"] <- "no rules matched"
if (isTRUE(attributes(guideline)$as_factor)) {
out <- factor(out, levels = attributes(guideline)$values, ordered = TRUE)
}
columns_nonsusceptible <- as.data.frame(t(df[, is.sir(df), drop = FALSE] == "R"))
columns_nonsusceptible <- vapply(
FUN.VALUE = character(1),
@ -1839,7 +1843,7 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
function(x) paste0(rownames(columns_nonsusceptible)[which(x)], collapse = " ")
)
columns_nonsusceptible[is.na(out)] <- NA_character_
data.frame(
row_number = seq_len(NROW(df)),
MDRO = out,

8
R/mean_amr_distance.R
View File

@ -49,13 +49,13 @@
#' sir <- random_sir(10)
#' sir
#' mean_amr_distance(sir)
#'
#'
#' mic <- random_mic(10)
#' mic
#' mean_amr_distance(mic)
#' # equal to the Z-score of their log2:
#' (log2(mic) - mean(log2(mic))) / sd(log2(mic))
#'
#'
#' disk <- random_disk(10)
#' disk
#' mean_amr_distance(disk)
@ -143,7 +143,7 @@ mean_amr_distance.data.frame <- function(x, ..., combine_SI = TRUE) {
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_antibiotics <- unname(get_column_abx(df, info = FALSE))
df <- df[, colnames(df)[colnames(df) %in% union(df_classes, df_antibiotics)], drop = FALSE]
stop_if(ncol(df) < 2,
"data set must contain at least two variables",
call = -2
@ -151,7 +151,7 @@ mean_amr_distance.data.frame <- function(x, ..., combine_SI = TRUE) {
if (message_not_thrown_before("mean_amr_distance", "groups")) {
message_("Calculating mean AMR distance based on columns ", vector_and(colnames(df), sort = FALSE))
}
res <- vapply(
FUN.VALUE = double(nrow(df)),
df,

14
R/mic.R
View File

@ -230,13 +230,13 @@ as.mic <- function(x, na.rm = FALSE) {
vector_and(quotes = TRUE)
cur_col <- get_current_column()
warning_("in `as.mic()`: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ",
list_missing,
call = FALSE
ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ",
list_missing,
call = FALSE
)
}

98
R/mo.R
View File

@ -183,12 +183,12 @@ as.mo <- function(x,
x <- replace_ignore_pattern(x, ignore_pattern)
x_lower <- tolower(x)
complexes <- x[trimws2(x_lower) %like_case% " (complex|group)$"]
if (length(complexes) > 0 && identical(remove_from_input, mo_cleaning_regex()) && !any(AMR_env$MO_lookup$fullname[which(AMR_env$MO_lookup$source == "Added by user")] %like% "(group|complex)", na.rm = TRUE)) {
warning_("in `as.mo()`: 'complex' and 'group' were ignored from the input in ", length(complexes), " case", ifelse(length(complexes) > 1, "s", ""), ", as they are currently not supported.\nYou can add your own microorganism with `add_custom_microorganisms()`.", call = FALSE)
}
# WHONET: xxx = no growth
x[x_lower %in% c("", "xxx", "na", "nan")] <- NA_character_
@ -274,7 +274,7 @@ as.mo <- function(x,
# take out the parts, split by space
x_parts <- strsplit(gsub("-", " ", x_out, fixed = TRUE), " ", fixed = TRUE)[[1]]
# do a pre-match on first character (and if it contains a space, first chars of first two terms)
if (length(x_parts) %in% c(2, 3)) {
# for genus + species + subspecies
@ -313,13 +313,13 @@ as.mo <- function(x,
} else {
minimum_matching_score_current <- minimum_matching_score
}
if (sum(m >= minimum_matching_score_current) > 10) {
# at least 10 are left over, make the ones under `m` NA
m[m < minimum_matching_score_current] <- NA_real_
m[m < minimum_matching_score_current] <- NA_real_
}
top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs
top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs
if (length(top_hits) == 0) {
warning_("No hits found for \"", x_search, "\" with minimum_matching_score = ", ifelse(is.null(minimum_matching_score), paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"), minimum_matching_score), ". Try setting this value lower or even to 0.", call = FALSE)
result_mo <- NA_character_
@ -365,18 +365,19 @@ as.mo <- function(x,
plural <- c("s", "these uncertainties")
}
if (length(AMR_env$mo_uncertainties$original_input) <= 3) {
examples <- vector_and(paste0(
'"', AMR_env$mo_uncertainties$original_input,
'" (assumed ', italicise(AMR_env$mo_uncertainties$fullname), ")"
),
quotes = FALSE
examples <- vector_and(
paste0(
'"', AMR_env$mo_uncertainties$original_input,
'" (assumed ', italicise(AMR_env$mo_uncertainties$fullname), ")"
),
quotes = FALSE
)
} else {
examples <- paste0(nr2char(length(AMR_env$mo_uncertainties$original_input)), " microorganism", plural[1])
}
msg <- c(msg, paste0(
"Microorganism translation was uncertain for ", examples,
". Run `mo_uncertainties()` to review ", plural[2], ", or use `add_custom_microorganisms()` to add own entries."
". Run `mo_uncertainties()` to review ", plural[2], ", or use `add_custom_microorganisms()` to add custom entries."
))
for (m in msg) {
@ -442,7 +443,7 @@ as.mo <- function(x,
# Apply Lancefield ----
if (isTRUE(Lancefield) || Lancefield == "all") {
# (using `%like_case%` to also match subspecies)
# group A - S. pyogenes
out[out %like_case% "^B_STRPT_PYGN(_|$)"] <- "B_STRPT_GRPA"
# group B - S. agalactiae
@ -560,7 +561,7 @@ pillar_shaft.mo <- function(x, ...) {
# markup NA and UNKNOWN
out[is.na(x)] <- font_na(" NA")
out[x == "UNKNOWN"] <- font_na(" UNKNOWN")
# markup manual codes
out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo] <- font_blue(out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo], collapse = NULL)
@ -577,10 +578,11 @@ pillar_shaft.mo <- function(x, ...) {
if (!all(x %in% all_mos) ||
(!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) {
# markup old mo codes
out[!x %in% all_mos] <- font_italic(font_na(x[!x %in% all_mos],
out[!x %in% all_mos] <- font_italic(
font_na(x[!x %in% all_mos],
collapse = NULL
),
collapse = NULL
),
collapse = NULL
)
# throw a warning with the affected column name(s)
if (!is.null(mo_cols)) {
@ -797,7 +799,7 @@ print.mo_uncertainties <- function(x, ...) {
cat(word_wrap("No uncertainties to show. Only uncertainties of the last call of `as.mo()` or any `mo_*()` function are stored.\n\n", add_fn = font_blue))
return(invisible(NULL))
}
add_MO_lookup_to_AMR_env()
cat(word_wrap("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See `?mo_matching_score`.\n\n", add_fn = font_blue))
@ -819,7 +821,7 @@ print.mo_uncertainties <- function(x, ...) {
text[scores < 0.5] <- font_red_bg(text[scores < 0.5], collapse = NULL)
text
}
txt <- ""
for (i in seq_len(nrow(x))) {
if (x[i, ]$candidates != "") {
@ -835,21 +837,23 @@ print.mo_uncertainties <- function(x, ...) {
candidates_formatted <- candidates_formatted[order(1 - scores)]
scores_formatted <- scores_formatted[order(1 - scores)]
candidates <- word_wrap(paste0(
"Also matched: ",
vector_and(paste0(
candidates_formatted,
font_blue(paste0(" (", scores_formatted, ")"), collapse = NULL)
candidates <- word_wrap(
paste0(
"Also matched: ",
vector_and(
paste0(
candidates_formatted,
font_blue(paste0(" (", scores_formatted, ")"), collapse = NULL)
),
quotes = FALSE, sort = FALSE
),
ifelse(n_candidates == 25,
font_grey(" [showing first 25]"),
""
)
),
quotes = FALSE, sort = FALSE
),
ifelse(n_candidates == 25,
font_grey(" [showing first 25]"),
""
)
),
extra_indent = nchar("Also matched: "),
width = 0.9 * getOption("width", 100)
extra_indent = nchar("Also matched: "),
width = 0.9 * getOption("width", 100)
)
} else {
candidates <- ""
@ -954,17 +958,17 @@ convert_colloquial_input <- function(x) {
out[x %like_case% "mil+er+i gr"] <- "B_STRPT_MILL"
out[x %like_case% "((strepto|^s).* viridans|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI"
out[x %like_case% "(viridans.* (strepto|^s).*|^vgs[^a-z]*$)"] <- "B_STRPT_VIRI"
# Salmonella in different languages, like "Salmonella grupo B"
out[x %like_case% "salmonella.* [bcd]$"] <- gsub(".*salmonella.* ([bcd])$",
"B_SLMNL_GRP\\U\\1",
x[x %like_case% "salmonella.* [bcd]$"],
perl = TRUE
"B_SLMNL_GRP\\U\\1",
x[x %like_case% "salmonella.* [bcd]$"],
perl = TRUE
)
out[x %like_case% "group [bcd] salmonella"] <- gsub(".*group ([bcd]) salmonella*",
"B_SLMNL_GRP\\U\\1",
x[x %like_case% "group [bcd] salmonella"],
perl = TRUE
"B_SLMNL_GRP\\U\\1",
x[x %like_case% "group [bcd] salmonella"],
perl = TRUE
)
# CoNS/CoPS in different languages (support for German, Dutch, Spanish, Portuguese)
@ -999,10 +1003,14 @@ convert_colloquial_input <- function(x) {
italicise <- function(x) {
out <- font_italic(x, collapse = NULL)
out[x %like_case% "Salmonella [A-Z]"] <- paste(font_italic("Salmonella"),
gsub("Salmonella ", "", x[x %like_case% "Salmonella [A-Z]"]))
out[x %like_case% "Streptococcus [A-Z]"] <- paste(font_italic("Streptococcus"),
gsub("Streptococcus ", "", x[x %like_case% "Streptococcus [A-Z]"]))
out[x %like_case% "Salmonella [A-Z]"] <- paste(
font_italic("Salmonella"),
gsub("Salmonella ", "", x[x %like_case% "Salmonella [A-Z]"])
)
out[x %like_case% "Streptococcus [A-Z]"] <- paste(
font_italic("Streptococcus"),
gsub("Streptococcus ", "", x[x %like_case% "Streptococcus [A-Z]"])
)
if (has_colour()) {
out <- gsub("(Group|group|Complex|complex)(\033\\[23m)?", "\033[23m\\1", out, perl = TRUE)
}

18
R/mo_matching_score.R
View File

@ -34,13 +34,13 @@
#' @param x Any user input value(s)
#' @param n A full taxonomic name, that exists in [`microorganisms$fullname`][microorganisms]
#' @note This algorithm was originally described in: Berends MS *et al.* (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}.
#'
#'
#' Later, the work of Bartlett A *et al.* about bacterial pathogens infecting humans (2022, \doi{10.1099/mic.0.001269}) was incorporated.
#' @section Matching Score for Microorganisms:
#' With ambiguous user input in [as.mo()] and all the [`mo_*`][mo_property()] functions, the returned results are chosen based on their matching score using [mo_matching_score()]. This matching score \eqn{m}, is calculated as:
#'
#' \ifelse{latex}{\deqn{m_{(x, n)} = \frac{l_{n} - 0.5 \cdot \min \begin{cases}l_{n} \\ \textrm{lev}(x, n)\end{cases}}{l_{n} \cdot p_{n} \cdot k_{n}}}}{
#'
#'
#' \ifelse{html}{\figure{mo_matching_score.png}{options: width="300" alt="mo matching score"}}{m(x, n) = ( l_n * min(l_n, lev(x, n) ) ) / ( l_n * p_n * k_n )}}
#'
#' where:
@ -53,12 +53,12 @@
#' * \eqn{k_n} is the taxonomic kingdom of \eqn{n}, set as Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, others = 5.
#'
#' The grouping into human pathogenic prevalence \eqn{p} is based on recent work from Bartlett *et al.* (2022, \doi{10.1099/mic.0.001269}) who extensively studied medical-scientific literature to categorise all bacterial species into these groups:
#'
#'
#' - **Established**, if a taxonomic species has infected at least three persons in three or more references. These records have `prevalence = 1.0` in the [microorganisms] data set;
#' - **Putative**, if a taxonomic species has fewer than three known cases. These records have `prevalence = 1.25` in the [microorganisms] data set.
#'
#'
#' Furthermore,
#'
#'
#' - Any genus present in the **established** list also has `prevalence = 1.0` in the [microorganisms] data set;
#' - Any other genus present in the **putative** list has `prevalence = 1.25` in the [microorganisms] data set;
#' - Any other species or subspecies of which the genus is present in the two aforementioned groups, has `prevalence = 1.5` in the [microorganisms] data set;
@ -72,7 +72,7 @@
#' @inheritSection AMR Reference Data Publicly Available
#' @examples
#' mo_reset_session()
#'
#'
#' as.mo("E. coli")
#' mo_uncertainties()
#'
@ -95,7 +95,7 @@ mo_matching_score <- function(x, n) {
# force a capital letter, so this conversion will not count as a substitution
substr(x, 1, 1) <- toupper(substr(x, 1, 1))
# n is always a taxonomically valid full name
if (length(n) == 1) {
n <- rep(n, length(x))
@ -103,7 +103,7 @@ mo_matching_score <- function(x, n) {
if (length(x) == 1) {
x <- rep(x, length(n))
}
# length of fullname
l_n <- nchar(n)
lev <- double(length = length(x))
@ -126,7 +126,7 @@ mo_matching_score <- function(x, n) {
p_n <- AMR_env$MO_lookup[match(n, AMR_env$MO_lookup$fullname), "prevalence", drop = TRUE]
# kingdom index (Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, others = 5)
k_n <- AMR_env$MO_lookup[match(n, AMR_env$MO_lookup$fullname), "kingdom_index", drop = TRUE]
# matching score:
(l_n - 0.5 * l_n.lev) / (l_n * p_n * k_n)
}

37
R/mo_property.R
View File

@ -133,7 +133,6 @@
#' mo_fullname("K. pneu rh")
#' mo_shortname("K. pneu rh")
#'
#'
#' \donttest{
#' # Becker classification, see ?as.mo ----------------------------------------
#'
@ -158,7 +157,7 @@
#' mo_gramstain("Klebsiella pneumoniae", language = "es") # Spanish
#' mo_gramstain("Klebsiella pneumoniae", language = "el") # Greek
#' mo_gramstain("Klebsiella pneumoniae", language = "uk") # Ukrainian
#'
#'
#' # mo_type is equal to mo_kingdom, but mo_kingdom will remain untranslated
#' mo_kingdom("Klebsiella pneumoniae")
#' mo_type("Klebsiella pneumoniae")
@ -426,17 +425,23 @@ mo_pathogenicity <- function(x, language = get_AMR_locale(), keep_synonyms = get
kngd <- AMR_env$MO_lookup$kingdom[match(x.mo, AMR_env$MO_lookup$mo)]
rank <- AMR_env$MO_lookup$rank[match(x.mo, AMR_env$MO_lookup$mo)]
out <- factor(ifelse(prev == 1 & kngd == "Bacteria" & rank != "genus",
"Pathogenic",
ifelse(prev < 2 & kngd == "Fungi",
"Potentially pathogenic",
ifelse(prev == 2 & kngd == "Bacteria",
"Non-pathogenic",
ifelse(kngd == "Bacteria",
"Potentially pathogenic",
"Unknown")))),
levels = c("Pathogenic", "Potentially pathogenic", "Non-pathogenic", "Unknown"),
ordered = TRUE)
out <- factor(
ifelse(prev == 1 & kngd == "Bacteria" & rank != "genus",
"Pathogenic",
ifelse(prev < 2 & kngd == "Fungi",
"Potentially pathogenic",
ifelse(prev == 2 & kngd == "Bacteria",
"Non-pathogenic",
ifelse(kngd == "Bacteria",
"Potentially pathogenic",
"Unknown"
)
)
)
),
levels = c("Pathogenic", "Potentially pathogenic", "Non-pathogenic", "Unknown"),
ordered = TRUE
)
load_mo_uncertainties(metadata)
out
@ -727,7 +732,7 @@ mo_synonyms <- function(x, language = get_AMR_locale(), keep_synonyms = getOptio
meet_criteria(x, allow_NA = TRUE)
language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
add_MO_lookup_to_AMR_env()
x.mo <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
@ -815,7 +820,7 @@ mo_url <- function(x, open = FALSE, language = get_AMR_locale(), keep_synonyms =
meet_criteria(open, allow_class = "logical", has_length = 1)
language <- validate_language(language)
meet_criteria(keep_synonyms, allow_class = "logical", has_length = 1)
add_MO_lookup_to_AMR_env()
x.mo <- as.mo(x = x, language = language, keep_synonyms = keep_synonyms, ... = ...)
@ -862,7 +867,7 @@ mo_property <- function(x, property = "fullname", language = get_AMR_locale(), k
mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ...) {
add_MO_lookup_to_AMR_env()
# try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% unlist(AMR_env$MO_lookup[1, property, drop = TRUE]),

2
R/mo_source.R
View File

@ -262,7 +262,7 @@ get_mo_source <- function(destination = getOption("AMR_mo_source", "~/mo_source.
check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_on_error = TRUE) {
add_MO_lookup_to_AMR_env()
if (paste(deparse(substitute(x)), collapse = "") == "get_mo_source()") {
return(TRUE)
}

1
R/proportion.R
View File

@ -140,7 +140,6 @@
#' )
#' }
#' if (require("dplyr")) {
#'
#' # scoped dplyr verbs with antibiotic selectors
#' # (you could also use across() of course)
#' example_isolates %>%

2
R/resistance_predict.R
View File

@ -274,7 +274,7 @@ resistance_predict <- function(x,
df_prediction$value <- ifelse(df_prediction$value > 1, 1, pmax(df_prediction$value, 0))
df_prediction <- df_prediction[order(df_prediction$year), , drop = FALSE]
out <- as_original_data_class(df_prediction, class(x.bak)) # will remove tibble groups
out <- as_original_data_class(df_prediction, class(x.bak)) # will remove tibble groups
structure(out,
class = c("resistance_predict", class(out)),
I_as_S = I_as_S,

98
R/sir.R
View File

@ -64,16 +64,16 @@
#' ```
#' 4. For **interpreting a complete data set**, with automatic determination of MIC values, disk diffusion diameters, microorganism names or codes, and antimicrobial test results. This is done very simply by running `as.sir(your_data)`.
#'
#' For points 2, 3 and 4: Use [sir_interpretation_history()] to retrieve a [data.frame] (or [tibble][tibble::tibble()] if the `tibble` package is installed) with all results of the last [as.sir()] call.
#' **For points 2, 3 and 4: Use [sir_interpretation_history()]** to retrieve a [data.frame] (or [tibble][tibble::tibble()] if the `tibble` package is installed) with all results of the last [as.sir()] call.
#'
#' ### Supported Guidelines
#'
#' For interpreting MIC values as well as disk diffusion diameters, currently implemented guidelines are EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(clinical_breakpoints, guideline %like% "CLSI")$guideline)))`).
#'
#' Thus, the `guideline` argument must be set to e.g., ``r paste0('"', subset(clinical_breakpoints, guideline %like% "EUCAST")$guideline[1], '"')`` or ``r paste0('"', subset(clinical_breakpoints, guideline %like% "CLSI")$guideline[1], '"')``. By simply using `"EUCAST"` (the default) or `"CLSI"` as input, the latest included version of that guideline will automatically be selected. You can set your own data set using the `reference_data` argument. The `guideline` argument will then be ignored.
#'
#'
#' You can set the default guideline with the `AMR_guideline` [option][options()] (e.g. in your `.Rprofile` file), such as:
#'
#'
#' ```
#' options(AMR_guideline = "CLSI")
#' options(AMR_guideline = "CLSI 2018")
@ -104,7 +104,7 @@
#' A microorganism is categorised as "Susceptible, Increased exposure*" when there is a high likelihood of therapeutic success because exposure to the agent is increased by adjusting the dosing regimen or by its concentration at the site of infection.
#' - **R = Resistant**\cr
#' A microorganism is categorised as "Resistant" when there is a high likelihood of therapeutic failure even when there is increased exposure.
#'
#'
#' * *Exposure* is a function of how the mode of administration, dose, dosing interval, infusion time, as well as distribution and excretion of the antimicrobial agent will influence the infecting organism at the site of infection.
#'
#' This AMR package honours this insight. Use [susceptibility()] (equal to [proportion_SI()]) to determine antimicrobial susceptibility and [count_susceptible()] (equal to [count_SI()]) to count susceptible isolates.
@ -297,7 +297,7 @@ as.sir.default <- function(x, ...) {
x.bak <- x
x <- as.character(x) # this is needed to prevent the vctrs pkg from throwing an error
if (inherits(x.bak, c("integer", "numeric", "double")) && all(x %in% c(1:3, NA))) {
# support haven package for importing e.g., from SPSS - it adds the 'labels' attribute
lbls <- attributes(x.bak)$labels
@ -328,7 +328,7 @@ as.sir.default <- function(x, ...) {
x <- trimws2(as.character(unlist(x)))
x[x %in% c(NA, "", "-", "NULL")] <- NA_character_
x.bak <- x
na_before <- length(x[is.na(x)])
# correct for translations
@ -768,13 +768,13 @@ as_sir_method <- function(method_short,
if (length(uti) == 1) {
uti <- rep(uti, length(x))
}
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %unlike% "EUCAST") {
if (message_not_thrown_before("as.sir", "intrinsic")) {
warning_("in `as.sir()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
}
}
agent_formatted <- paste0("'", font_bold(ab.bak), "'")
agent_name <- ab_name(ab, tolower = TRUE, language = NULL)
if (generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)) {
@ -801,27 +801,31 @@ as_sir_method <- function(method_short,
appendLF = FALSE,
as_note = FALSE
)
msg_note <- function(messages) {
for (i in seq_len(length(messages))) {
messages[i] <- word_wrap(extra_indent = 5, messages[i])
}
message(font_green(font_bold(" Note:\n")),
paste0(" ", font_black(AMR_env$bullet_icon)," ", font_black(messages, collapse = NULL) , collapse = "\n"))
message(
font_green(font_bold(" Note:\n")),
paste0(" ", font_black(AMR_env$bullet_icon), " ", font_black(messages, collapse = NULL), collapse = "\n")
)
}
method <- method_short
metadata_mo <- get_mo_uncertainties()
df <- data.frame(values = x,
mo = mo,
result = NA_sir_,
uti = uti,
stringsAsFactors = FALSE)
df <- data.frame(
values = x,
mo = mo,
result = NA_sir_,
uti = uti,
stringsAsFactors = FALSE
)
if (method == "mic") {
# when as.sir.mic is called directly
df$values <- as.mic(df$values)
df$values <- as.mic(df$values)
} else if (method == "disk") {
# when as.sir.disk is called directly
df$values <- as.disk(df$values)
@ -832,7 +836,7 @@ as_sir_method <- function(method_short,
method_coerced <- toupper(method)
ab_coerced <- ab
mo_coerced <- mo
if (identical(reference_data, AMR::clinical_breakpoints)) {
breakpoints <- reference_data %pm>%
subset(guideline == guideline_coerced & method == method_coerced & ab == ab_coerced)
@ -845,30 +849,31 @@ as_sir_method <- function(method_short,
breakpoints <- reference_data %pm>%
subset(method == method_coerced & ab == ab_coerced)
}
msgs <- character(0)
if (nrow(breakpoints) == 0) {
# apparently no breakpoints found
msg_note(paste0("No ", method_coerced, " breakpoints available for ",
suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
" (", ab_coerced, ")"))
msg_note(paste0(
"No ", method_coerced, " breakpoints available for ",
suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
" (", ab_coerced, ")"
))
load_mo_uncertainties(metadata_mo)
return(rep(NA_sir_, nrow(df)))
}
if (guideline_coerced %like% "EUCAST") {
any_is_intrinsic_resistant <- FALSE
add_intrinsic_resistance_to_AMR_env()
}
# run the rules
for (mo_unique in unique(df$mo)) {
rows <- which(df$mo == mo_unique)
values <- df[rows, "values", drop = TRUE]
uti <- df[rows, "uti", drop = TRUE]
new_sir <- rep(NA_sir_, length(rows))
# find different mo properties
mo_current_genus <- as.mo(mo_genus(mo_unique, language = NULL))
mo_current_family <- as.mo(mo_family(mo_unique, language = NULL))
@ -890,17 +895,21 @@ as_sir_method <- function(method_short,
if (!mo_rank(mo_unique) %in% c("kingdom", "phylum", "class", "order")) {
mo_formatted <- font_italic(mo_formatted)
}
ab_formatted <- paste0(suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
" (", ab_coerced, ")")
# gather all available breakpoints for current MO and sort on taxonomic rank
ab_formatted <- paste0(
suppressMessages(suppressWarnings(ab_name(ab_coerced, language = NULL, tolower = TRUE))),
" (", ab_coerced, ")"
)
# gather all available breakpoints for current MO and sort on taxonomic rank
# (this will prefer species breakpoints over order breakpoints)
breakpoints_current <- breakpoints %pm>%
subset(mo %in% c(mo_current_genus, mo_current_family,
mo_current_order, mo_current_class,
mo_current_becker, mo_current_lancefield,
mo_current_other))
subset(mo %in% c(
mo_current_genus, mo_current_family,
mo_current_order, mo_current_class,
mo_current_becker, mo_current_lancefield,
mo_current_other
))
if (any(df[rows, "uti", drop = TRUE], na.rm = TRUE)) {
breakpoints_current <- breakpoints_current %pm>%
# be as specific as possible (i.e. prefer species over genus):
@ -911,7 +920,7 @@ as_sir_method <- function(method_short,
# sort UTI = FALSE first, then UTI = TRUE
pm_arrange(rank_index, uti)
}
# throw notes for different body sites
if (nrow(breakpoints_current) == 1 && all(breakpoints_current$uti == TRUE) && any(uti %in% c(FALSE, NA)) && message_not_thrown_before("as.sir", "uti", ab_coerced)) {
# only UTI breakpoints available
@ -932,16 +941,15 @@ as_sir_method <- function(method_short,
}
msgs <- c(msgs, paste0("Multiple breakpoints available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, "."))
}
# first check if mo is intrinsic resistant
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %like% "EUCAST" && paste(mo_unique, ab_coerced) %in% AMR_env$intrinsic_resistant) {
msgs <- c(msgs, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, ""))
new_sir <- rep(as.sir("R"), length(rows))
} else {
# then run the rules
breakpoints_current <- breakpoints_current[1L, , drop = FALSE]
if (method == "mic") {
new_sir <- quick_case_when(
is.na(values) ~ NA_sir_,
@ -953,7 +961,6 @@ as_sir_method <- function(method_short,
# and NA otherwise
TRUE ~ NA_sir_
)
} else if (method == "disk") {
new_sir <- quick_case_when(
is.na(values) ~ NA_sir_,
@ -988,10 +995,10 @@ as_sir_method <- function(method_short,
)
)
}
df[rows, "result"] <- new_sir
}
if (isTRUE(rise_warning)) {
message(font_yellow(font_bold(" * WARNING *")))
} else if (length(msgs) == 0) {
@ -999,9 +1006,9 @@ as_sir_method <- function(method_short,
} else {
msg_note(sort(msgs))
}
load_mo_uncertainties(metadata_mo)
df$result
}
@ -1027,6 +1034,9 @@ sir_interpretation_history <- function(clean = FALSE) {
AMR_env$sir_interpretation_history <- out.bak
}
# sort descending on time
out <- out[order(out$datetime, decreasing = TRUE), , drop = FALSE]
if (pkg_is_available("tibble", also_load = FALSE)) {
import_fn("as_tibble", "tibble")(out)
} else {

BIN
R/sysdata.rda
View File

Binary file not shown.

33
R/translate.R
View File

@ -141,10 +141,11 @@ reset_AMR_locale <- function() {
#' @export
translate_AMR <- function(x, language = get_AMR_locale()) {
translate_into_language(x,
language = language,
only_unknown = FALSE,
only_affect_ab_names = FALSE,
only_affect_mo_names = FALSE)
language = language,
only_unknown = FALSE,
only_affect_ab_names = FALSE,
only_affect_mo_names = FALSE
)
}
@ -170,14 +171,15 @@ find_language <- function(language, fallback = TRUE) {
language <- Map(LANGUAGES_SUPPORTED_NAMES,
LANGUAGES_SUPPORTED,
f = function(l, n, check = language) {
grepl(paste0(
"^(", l[1], "|", l[2], "|",
n, "(_|$)|", toupper(n), "(_|$))"
),
check,
ignore.case = TRUE,
perl = TRUE,
useBytes = FALSE
grepl(
paste0(
"^(", l[1], "|", l[2], "|",
n, "(_|$)|", toupper(n), "(_|$))"
),
check,
ignore.case = TRUE,
perl = TRUE,
useBytes = FALSE
)
},
USE.NAMES = TRUE
@ -196,7 +198,6 @@ translate_into_language <- function(from,
only_unknown = FALSE,
only_affect_ab_names = FALSE,
only_affect_mo_names = FALSE) {
# get ISO-639-1 of language
lang <- validate_language(language)
if (lang == "en") {
@ -260,10 +261,10 @@ translate_into_language <- function(from,
# force UTF-8 for diacritics
from_unique_translated <- enc2utf8(from_unique_translated)
# a kind of left join to get all results back
out <- from_unique_translated[match(from.bak, from_unique)]
if (!identical(from.bak, out) && get_AMR_locale() == lang && message_not_thrown_before("translation", entire_session = TRUE) && interactive()) {
message(word_wrap(
"Assuming the ", LANGUAGES_SUPPORTED_NAMES[[lang]]$exonym, " language (",
@ -271,6 +272,6 @@ translate_into_language <- function(from,
add_fn = list(font_blue), as_note = TRUE
))
}
out
}

23
R/zz_deprecated.R
View File

@ -35,7 +35,8 @@
#' @rdname AMR-deprecated
#' @export
NA_rsi_ <- set_clean_class(factor(NA_character_, levels = c("S", "I", "R"), ordered = TRUE),
new_class = c("rsi", "ordered", "factor"))
new_class = c("rsi", "ordered", "factor")
)
#' @rdname AMR-deprecated
#' @export
as.rsi <- function(x, ...) {
@ -197,14 +198,18 @@ deprecation_warning <- function(old = NULL, new = NULL, extra_msg = NULL) {
env <- paste0("deprecated_", old)
if (!env %in% names(AMR_env)) {
AMR_env[[paste0("deprecated_", old)]] <- 1
warning_(ifelse(is.null(new),
paste0("The `", old, "()` function is no longer in use"),
paste0("The `", old, "()` function has been replaced with `", new, "()`")),
", see `?AMR-deprecated`.",
ifelse(!is.null(extra_msg),
paste0(" ", extra_msg),
""),
"\nThis warning will be shown once per session.")
warning_(
ifelse(is.null(new),
paste0("The `", old, "()` function is no longer in use"),
paste0("The `", old, "()` function has been replaced with `", new, "()`")
),
", see `?AMR-deprecated`.",
ifelse(!is.null(extra_msg),
paste0(" ", extra_msg),
""
),
"\nThis warning will be shown once per session."
)
}
}
}

22
R/zzz.R
View File

@ -192,18 +192,24 @@ if (utf8_supported && !is_latex) {
if (!is.null(getOption("AMR_custom_ab")) && file.exists(getOption("AMR_custom_ab", default = ""))) {
packageStartupMessage("Adding custom antimicrobials from '", getOption("AMR_custom_ab"), "'...", appendLF = FALSE)
x <- readRDS2(getOption("AMR_custom_ab"))
tryCatch({
suppressWarnings(suppressMessages(add_custom_antimicrobials(x)))
packageStartupMessage("OK.")
}, error = function(e) packageStartupMessage("Failed: ", e$message))
tryCatch(
{
suppressWarnings(suppressMessages(add_custom_antimicrobials(x)))
packageStartupMessage("OK.")
},
error = function(e) packageStartupMessage("Failed: ", e$message)
)
}
# if custom mo option is available, load it
if (!is.null(getOption("AMR_custom_mo")) && file.exists(getOption("AMR_custom_mo", default = ""))) {
packageStartupMessage("Adding custom microorganisms from '", getOption("AMR_custom_mo"), "'...", appendLF = FALSE)
x <- readRDS2(getOption("AMR_custom_mo"))
tryCatch({
suppressWarnings(suppressMessages(add_custom_microorganisms(x)))
packageStartupMessage("OK.")
}, error = function(e) packageStartupMessage("Failed: ", e$message))
tryCatch(
{
suppressWarnings(suppressMessages(add_custom_microorganisms(x)))
packageStartupMessage("OK.")
},
error = function(e) packageStartupMessage("Failed: ", e$message)
)
}
}

97
data-raw/_pre_commit_hook.R
View File

@ -101,46 +101,48 @@ create_species_cons_cops <- function(type = c("CoNS", "CoPS")) {
MO_staph <- AMR::microorganisms
MO_staph <- MO_staph[which(MO_staph$genus == "Staphylococcus"), , drop = FALSE]
if (type == "CoNS") {
MO_staph[which(MO_staph$species %in% c(
"coagulase-negative", "argensis", "arlettae",
"auricularis", "borealis", "caeli", "capitis", "caprae",
"carnosus", "casei", "caseolyticus", "chromogenes", "cohnii", "condimenti",
"croceilyticus",
"debuckii", "devriesei", "edaphicus", "epidermidis",
"equorum", "felis", "fleurettii", "gallinarum",
"haemolyticus", "hominis", "jettensis", "kloosii",
"lentus", "lugdunensis", "massiliensis", "microti",
"muscae", "nepalensis", "pasteuri", "petrasii",
"pettenkoferi", "piscifermentans", "pragensis", "pseudoxylosus",
"pulvereri", "rostri", "saccharolyticus", "saprophyticus",
"sciuri", "simulans", "stepanovicii", "succinus",
"ureilyticus",
"vitulinus", "vitulus", "warneri", "xylosus",
"caledonicus", "canis",
"durrellii", "lloydii",
"ratti", "taiwanensis", "veratri", "urealyticus"
) |
# old, now renamed to S. schleiferi (but still as synonym in our data of course):
(MO_staph$species == "schleiferi" & MO_staph$subspecies %in% c("schleiferi", ""))),
"mo",
drop = TRUE
MO_staph[
which(MO_staph$species %in% c(
"coagulase-negative", "argensis", "arlettae",
"auricularis", "borealis", "caeli", "capitis", "caprae",
"carnosus", "casei", "caseolyticus", "chromogenes", "cohnii", "condimenti",
"croceilyticus",
"debuckii", "devriesei", "edaphicus", "epidermidis",
"equorum", "felis", "fleurettii", "gallinarum",
"haemolyticus", "hominis", "jettensis", "kloosii",
"lentus", "lugdunensis", "massiliensis", "microti",
"muscae", "nepalensis", "pasteuri", "petrasii",
"pettenkoferi", "piscifermentans", "pragensis", "pseudoxylosus",
"pulvereri", "rostri", "saccharolyticus", "saprophyticus",
"sciuri", "simulans", "stepanovicii", "succinus",
"ureilyticus",
"vitulinus", "vitulus", "warneri", "xylosus",
"caledonicus", "canis",
"durrellii", "lloydii",
"ratti", "taiwanensis", "veratri", "urealyticus"
) |
# old, now renamed to S. schleiferi (but still as synonym in our data of course):
(MO_staph$species == "schleiferi" & MO_staph$subspecies %in% c("schleiferi", ""))),
"mo",
drop = TRUE
]
} else if (type == "CoPS") {
MO_staph[which(MO_staph$species %in% c(
"coagulase-positive", "coagulans",
"agnetis", "argenteus",
"cornubiensis",
"delphini", "lutrae",
"hyicus", "intermedius",
"pseudintermedius", "pseudointermedius",
"schweitzeri", "simiae",
"roterodami",
"singaporensis"
) |
# old, now renamed to S. coagulans (but still as synonym in our data of course):
(MO_staph$species == "schleiferi" & MO_staph$subspecies == "coagulans")),
"mo",
drop = TRUE
MO_staph[
which(MO_staph$species %in% c(
"coagulase-positive", "coagulans",
"agnetis", "argenteus",
"cornubiensis",
"delphini", "lutrae",
"hyicus", "intermedius",
"pseudintermedius", "pseudointermedius",
"schweitzeri", "simiae",
"roterodami",
"singaporensis"
) |
# old, now renamed to S. coagulans (but still as synonym in our data of course):
(MO_staph$species == "schleiferi" & MO_staph$subspecies == "coagulans")),
"mo",
drop = TRUE
]
}
}
@ -254,14 +256,15 @@ create_AB_AV_lookup <- function(df) {
}
new_df$generalised_loinc <- lapply(new_df$loinc, generalise_antibiotic_name)
new_df$generalised_all <- unname(lapply(
as.list(as.data.frame(t(new_df[,
c(
colnames(new_df)[colnames(new_df) %in% c("ab", "av", "atc", "cid", "name")],
colnames(new_df)[colnames(new_df) %like% "generalised"]
),
drop = FALSE
]),
stringsAsFactors = FALSE
as.list(as.data.frame(
t(new_df[,
c(
colnames(new_df)[colnames(new_df) %in% c("ab", "av", "atc", "cid", "name")],
colnames(new_df)[colnames(new_df) %like% "generalised"]
),
drop = FALSE
]),
stringsAsFactors = FALSE
)),
function(x) {
x <- generalise_antibiotic_name(unname(unlist(x)))
@ -472,7 +475,7 @@ suppressMessages(devtools::document(quiet = TRUE))
if (!"styler" %in% rownames(utils::installed.packages())) {
message("Package 'styler' not installed!")
} else if (interactive()) {
# # only when sourcing this file ourselves
# only when sourcing this file ourselves
# usethis::ui_info("Styling package")
# styler::style_pkg(
# style = styler::tidyverse_style,

1
data-raw/create_survey_page.R
View File

@ -1,4 +1,3 @@
license_text <- readLines("docs/LICENSE-text.html")
license_text <- paste(license_text, collapse = "|||")
license_text <- gsub("licen(s|c)e", "Survey", license_text, ignore.case = TRUE)

49
data-raw/read_EUCAST.R
View File

@ -66,33 +66,36 @@ read_EUCAST <- function(sheet, file, guideline_name) {
# in the info header in the Excel file, EUCAST mentions which genera are targeted
if (sheet %like% "anaerob.*Gram.*posi") {
sheet <- paste0(c(
"Actinomyces", "Bifidobacterium", "Clostridioides",
"Clostridium", "Cutibacterium", "Eggerthella",
"Eubacterium", "Lactobacillus", "Propionibacterium",
"Staphylococcus saccharolyticus"
),
collapse = "_"
sheet <- paste0(
c(
"Actinomyces", "Bifidobacterium", "Clostridioides",
"Clostridium", "Cutibacterium", "Eggerthella",
"Eubacterium", "Lactobacillus", "Propionibacterium",
"Staphylococcus saccharolyticus"
),
collapse = "_"
)
} else if (sheet %like% "anaerob.*Gram.*nega") {
sheet <- paste0(c(
"Bacteroides",
"Bilophila",
"Fusobacterium",
"Mobiluncus",
"Parabacteroides",
"Porphyromonas",
"Prevotella"
),
collapse = "_"
sheet <- paste0(
c(
"Bacteroides",
"Bilophila",
"Fusobacterium",
"Mobiluncus",
"Parabacteroides",
"Porphyromonas",
"Prevotella"
),
collapse = "_"
)
} else if (sheet == "Streptococcus A,B,C,G") {
sheet <- paste0(microorganisms %>%
filter(genus == "Streptococcus") %>%
mutate(lancefield = mo_name(mo, Lancefield = TRUE)) %>%
filter(lancefield %like% "^Streptococcus group") %>%
pull(fullname),
collapse = "_"
sheet <- paste0(
microorganisms %>%
filter(genus == "Streptococcus") %>%
mutate(lancefield = mo_name(mo, Lancefield = TRUE)) %>%
filter(lancefield %like% "^Streptococcus group") %>%
pull(fullname),
collapse = "_"
)
} else if (sheet %like% "PK.*PD") {
sheet <- "UNKNOWN"

71
data-raw/reproduction_of_antibiotics.R
View File

@ -142,14 +142,15 @@ abx2 <- bind_rows(abx_atc1, abx_atc2)
rm(abx_atc1)
rm(abx_atc2)
abx2$ab[is.na(abx2$ab)] <- toupper(abbreviate(gsub(
"[/0-9-]",
" ",
abx2$name[is.na(abx2$ab)]
),
minlength = 3,
method = "left.kept",
strict = TRUE
abx2$ab[is.na(abx2$ab)] <- toupper(abbreviate(
gsub(
"[/0-9-]",
" ",
abx2$name[is.na(abx2$ab)]
),
minlength = 3,
method = "left.kept",
strict = TRUE
))
n_distinct(abx2$ab)
@ -197,24 +198,26 @@ get_CID <- function(ab) {
p$tick()
CID[i] <- tryCatch(
data.table::fread(paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
URLencode(ab[i], reserved = TRUE),
"/cids/TXT?name_type=complete"
),
showProgress = FALSE
data.table::fread(
paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
URLencode(ab[i], reserved = TRUE),
"/cids/TXT?name_type=complete"
),
showProgress = FALSE
)[[1]][1],
error = function(e) NA_integer_
)
if (is.na(CID[i])) {
# try with removing the text in brackets
CID[i] <- tryCatch(
data.table::fread(paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
URLencode(trimws(gsub("[(].*[)]", "", ab[i])), reserved = TRUE),
"/cids/TXT?name_type=complete"
),
showProgress = FALSE
data.table::fread(
paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
URLencode(trimws(gsub("[(].*[)]", "", ab[i])), reserved = TRUE),
"/cids/TXT?name_type=complete"
),
showProgress = FALSE
)[[1]][1],
error = function(e) NA_integer_
)
@ -223,12 +226,13 @@ get_CID <- function(ab) {
# try match on word and take the lowest CID value (sorted)
ab[i] <- gsub("[^a-z0-9]+", " ", ab[i], ignore.case = TRUE)
CID[i] <- tryCatch(
data.table::fread(paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
URLencode(ab[i], reserved = TRUE),
"/cids/TXT?name_type=word"
),
showProgress = FALSE
data.table::fread(
paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/name/",
URLencode(ab[i], reserved = TRUE),
"/cids/TXT?name_type=word"
),
showProgress = FALSE
)[[1]][1],
error = function(e) NA_integer_
)
@ -260,13 +264,14 @@ get_synonyms <- function(CID, clean = TRUE) {
}
synonyms_txt <- tryCatch(
data.table::fread(paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/fastidentity/cid/",
CID[i],
"/synonyms/TXT"
),
sep = "\n",
showProgress = FALSE
data.table::fread(
paste0(
"https://pubchem.ncbi.nlm.nih.gov/rest/pug/compound/fastidentity/cid/",
CID[i],
"/synonyms/TXT"
),
sep = "\n",
showProgress = FALSE
)[[1]],
error = function(e) NA_character_
)

34
data-raw/reproduction_of_antivirals.R
View File

@ -106,31 +106,32 @@ antivirals <- antivirals %>%
oral_units,
iv_ddd,
iv_units
) %>%
) %>%
AMR:::dataset_UTF8_to_ASCII()
av_codes <- tibble(name = antivirals$name %>%
strsplit("(, | and )") %>%
unlist() %>%
unique() %>%
sort()) %>%
mutate(av_1st = toupper(abbreviate(name, minlength = 3, use.classes = FALSE))) %>%
strsplit("(, | and )") %>%
unlist() %>%
unique() %>%
sort()) %>%
mutate(av_1st = toupper(abbreviate(name, minlength = 3, use.classes = FALSE))) %>%
filter(!name %in% c("acid", "dipivoxil", "disoproxil", "marboxil", "alafenamide"))
replace_with_av_code <- function(name) {
unname(av_codes$av_1st[match(name, av_codes$name)])
}
names_codes <- antivirals %>%
names_codes <- antivirals %>%
separate(name,
into = paste0("name", c(1:7)),
sep = "(, | and )",
remove = FALSE,
fill = "right") %>%
into = paste0("name", c(1:7)),
sep = "(, | and )",
remove = FALSE,
fill = "right"
) %>%
# remove empty columns
select(!where(function(x) all(is.na(x)))) %>%
mutate_at(vars(matches("name[1-9]")), replace_with_av_code) %>%
unite(av, matches("name[1-9]"), sep = "+", na.rm = TRUE) %>%
select(!where(function(x) all(is.na(x)))) %>%
mutate_at(vars(matches("name[1-9]")), replace_with_av_code) %>%
unite(av, matches("name[1-9]"), sep = "+", na.rm = TRUE) %>%
mutate(name = gsub("(, | and )", "/", name))
substr(names_codes$name, 1, 1) <- toupper(substr(names_codes$name, 1, 1))
@ -143,8 +144,9 @@ antivirals <- antivirals %>% AMR:::dataset_UTF8_to_ASCII()
# add loinc, see 'data-raw/loinc.R'
loinc_df <- read.csv("data-raw/Loinc.csv",
row.names = NULL,
stringsAsFactors = FALSE)
row.names = NULL,
stringsAsFactors = FALSE
)
loinc_df <- loinc_df %>% filter(CLASS == "DRUG/TOX")
av_names <- antivirals %>%

2
data-raw/reproduction_of_dosage.R
View File

@ -173,7 +173,7 @@ dosage_new <- bind_rows(
as.data.frame(stringsAsFactors = FALSE)
rownames(dosage_new) <- NULL
dosage <- bind_rows(dosage_new, AMR::dosage) %>%
dosage <- bind_rows(dosage_new, AMR::dosage) %>%
dataset_UTF8_to_ASCII()
usethis::use_data(dosage, internal = FALSE, overwrite = TRUE, version = 2)

387
data-raw/reproduction_of_microorganisms.R
View File

@ -37,10 +37,10 @@
# CSV file (~12,5 MB) as "taxonomy.csv". Their API unfortunately does
# not include the full taxonomy and is currently (2022) pretty worthless.
# 3. For data about human pathogens, we use Bartlett et al. (2022),
# https://doi.org/10.1099/mic.0.001269. Their latest supplementary material
# https://doi.org/10.1099/mic.0.001269. Their latest supplementary material
# can be found here: https://github.com/padpadpadpad/bartlett_et_al_2022_human_pathogens.
#. Download their latest xlsx file in the `data` folder and save it to our
#. `data-raw` folder.
# . Download their latest xlsx file in the `data` folder and save it to our
# . `data-raw` folder.
# 4. Set this folder_location to the path where these two files are:
folder_location <- "~/Downloads/backbone/"
file_gbif <- paste0(folder_location, "Taxon.tsv")
@ -65,7 +65,7 @@ devtools::load_all(".") # load AMR package
get_author_year <- function(ref) {
# Only keep first author, e.g. transform 'Smith, Jones, 2011' to 'Smith et al., 2011'
authors2 <- iconv(ref, from = "UTF-8", to = "ASCII//TRANSLIT")
authors2 <- gsub(" ?\\(Approved Lists [0-9]+\\) ?", " () ", authors2)
authors2 <- gsub(" [)(]+ $", "", authors2)
@ -73,21 +73,21 @@ get_author_year <- function(ref) {
authors2 <- trimws(gsub("^[(](.*)[)]$", "\\1", authors2))
# only take part after brackets if there's a name
authors2 <- ifelse(grepl(".*[)] [a-zA-Z]+.*", authors2),
gsub(".*[)] (.*)", "\\1", authors2),
authors2
gsub(".*[)] (.*)", "\\1", authors2),
authors2
)
# replace parentheses with emend. to get the latest authors
authors2 <- gsub("(", " emend. ", authors2, fixed = TRUE)
authors2 <- gsub(")", "", authors2, fixed = TRUE)
authors2 <- gsub(" +", " ", authors2)
authors2 <- trimws(authors2)
# get year from last 4 digits
lastyear <- as.integer(gsub(".*([0-9]{4})$", "\\1", authors2))
# can never be later than now
lastyear <- ifelse(lastyear > as.integer(format(Sys.Date(), "%Y")),
NA,
lastyear
NA,
lastyear
)
# get authors without last year
authors <- gsub("(.*)[0-9]{4}$", "\\1", authors2)
@ -119,8 +119,8 @@ get_author_year <- function(ref) {
authors[nchar(authors) <= 3] <- ""
# combine author and year if year is available
ref <- ifelse(!is.na(lastyear),
paste0(authors, ", ", lastyear),
authors
paste0(authors, ", ", lastyear),
authors
)
# fix beginning and ending
ref <- gsub(", $", "", ref)
@ -128,7 +128,7 @@ get_author_year <- function(ref) {
ref <- gsub("^(emend|et al.,?)", "", ref)
ref <- trimws(ref)
ref <- gsub("'", "", ref)
# a lot start with a lowercase character - fix that
ref[!grepl("^d[A-Z]", ref)] <- gsub("^([a-z])", "\\U\\1", ref[!grepl("^d[A-Z]", ref)], perl = TRUE)
# specific one for the French that are named dOrbigny
@ -222,9 +222,9 @@ include_fungal_orders <- c(
# get latest taxonomic names of these fungal orders
include_fungal_orders_ids <- taxonomy_gbif.bak %>%
filter(order %in% include_fungal_orders)
include_fungal_orders <- taxonomy_gbif.bak %>%
filter(taxonID %in% c(include_fungal_orders_ids$taxonID, include_fungal_orders_ids$acceptedNameUsageID)) %>%
distinct(order) %>%
include_fungal_orders <- taxonomy_gbif.bak %>%
filter(taxonID %in% c(include_fungal_orders_ids$taxonID, include_fungal_orders_ids$acceptedNameUsageID)) %>%
distinct(order) %>%
pull(order)
# check some columns to validate below filters
@ -361,7 +361,7 @@ for (page in LETTERS) {
names <- names[ranks != "species"]
ranks <- ranks[ranks != "species"]
ranks[ranks == "domain"] <- "kingdom"
df <- names %>%
tibble() %>%
t() %>%
@ -369,7 +369,7 @@ for (page in LETTERS) {
setNames(ranks) %>%
# no candidates please
filter(genus %unlike% "^(Candidatus|\\[)")
taxonomy_lpsn_missing <- taxonomy_lpsn_missing %>%
bind_rows(df)
}
@ -491,14 +491,14 @@ saveRDS(taxonomy_lpsn, "data-raw/taxonomy_lpsn.rds", version = 2)
taxonomy_gbif <- taxonomy_gbif %>%
# clean NAs and add fullname
mutate(across(kingdom:subspecies, function(x) ifelse(is.na(x), "", x)),
fullname = trimws(case_when(
rank == "family" ~ family,
rank == "order" ~ order,
rank == "class" ~ class,
rank == "phylum" ~ phylum,
rank == "kingdom" ~ kingdom,
TRUE ~ paste(genus, species, subspecies)
)), .before = 1
fullname = trimws(case_when(
rank == "family" ~ family,
rank == "order" ~ order,
rank == "class" ~ class,
rank == "phylum" ~ phylum,
rank == "kingdom" ~ kingdom,
TRUE ~ paste(genus, species, subspecies)
)), .before = 1
) %>%
# keep only one GBIF taxon ID per full name
arrange(fullname, gbif) %>%
@ -507,14 +507,14 @@ taxonomy_gbif <- taxonomy_gbif %>%
taxonomy_lpsn <- taxonomy_lpsn %>%
# clean NAs and add fullname
mutate(across(kingdom:subspecies, function(x) ifelse(is.na(x), "", x)),
fullname = trimws(case_when(
rank == "family" ~ family,
rank == "order" ~ order,
rank == "class" ~ class,
rank == "phylum" ~ phylum,
rank == "kingdom" ~ kingdom,
TRUE ~ paste(genus, species, subspecies)
)), .before = 1
fullname = trimws(case_when(
rank == "family" ~ family,
rank == "order" ~ order,
rank == "class" ~ class,
rank == "phylum" ~ phylum,
rank == "kingdom" ~ kingdom,
TRUE ~ paste(genus, species, subspecies)
)), .before = 1
) %>%
# keep only one LPSN record ID per full name
arrange(fullname, lpsn) %>%
@ -536,23 +536,25 @@ taxonomy_lpsn$lpsn_parent[taxonomy_lpsn$rank == "subspecies"] <- taxonomy_lpsn$l
taxonomy <- taxonomy_lpsn %>%
# join GBIF identifiers to them
left_join(taxonomy_gbif %>% select(kingdom, fullname, starts_with("gbif")),
by = c("kingdom", "fullname")
by = c("kingdom", "fullname")
)
# for everything else, add the GBIF data
taxonomy <- taxonomy %>%
bind_rows(taxonomy_gbif %>%
filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname))) %>%
filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname))) %>%
arrange(fullname) %>%
filter(fullname != "")
# get missing entries from existing microorganisms data set
taxonomy <- taxonomy %>%
bind_rows(AMR::microorganisms %>%
select(all_of(colnames(taxonomy))) %>%
filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname),
# these will be added later:
source != "manually added")) %>%
select(all_of(colnames(taxonomy))) %>%
filter(
!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname),
# these will be added later:
source != "manually added"
)) %>%
arrange(fullname) %>%
filter(fullname != "")
@ -602,9 +604,10 @@ taxonomy <- taxonomy %>%
source = "manually added"
) %>%
filter(!paste(kingdom, rank) %in% paste(taxonomy$kingdom, taxonomy$rank)) %>%
left_join(current_gbif %>%
select(kingdom, rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
by = c("kingdom", "rank")
left_join(
current_gbif %>%
select(kingdom, rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
by = c("kingdom", "rank")
) %>%
mutate(source = ifelse(!is.na(gbif), "GBIF", source))
)
@ -625,17 +628,18 @@ for (i in 2:6) {
source = "manually added"
) %>%
filter(!paste(kingdom, .[[ncol(.) - 4]], rank) %in% paste(taxonomy$kingdom, taxonomy[[i + 1]], taxonomy$rank)) %>%
# get GBIF identifier where available
left_join(current_gbif %>%
select(kingdom, all_of(i_name), rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
by = c("kingdom", "rank", i_name)
) %>%
mutate(source = ifelse(!is.na(gbif), "GBIF", source))
# get GBIF identifier where available
left_join(
current_gbif %>%
select(kingdom, all_of(i_name), rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
by = c("kingdom", "rank", i_name)
) %>%
mutate(source = ifelse(!is.na(gbif), "GBIF", source))
message("n = ", nrow(to_add))
if (is.null(taxonomy_all_missing)) {
taxonomy_all_missing <- to_add
} else {
taxonomy_all_missing <- taxonomy_all_missing %>%
taxonomy_all_missing <- taxonomy_all_missing %>%
bind_rows(to_add)
}
}
@ -645,20 +649,24 @@ taxonomy <- taxonomy %>%
bind_rows(taxonomy_all_missing)
# fix for duplicate fullnames within a kingdom (such as Nitrospira which is the name of the genus AND its class)
taxonomy <- taxonomy %>%
mutate(rank_index = case_when(rank == "subspecies" ~ 1,
rank == "species" ~ 2,
rank == "genus" ~ 3,
rank == "family" ~ 4,
rank == "order" ~ 5,
rank == "class" ~ 6,
TRUE ~ 7),
fullname_rank = paste0(fullname, " {", rank, "}")) %>%
arrange(kingdom, fullname, rank_index) %>%
group_by(kingdom, fullname) %>%
mutate(fullname = if_else(row_number() > 1, fullname_rank, fullname)) %>%
ungroup() %>%
select(-fullname_rank, -rank_index) %>%
taxonomy <- taxonomy %>%
mutate(
rank_index = case_when(
rank == "subspecies" ~ 1,
rank == "species" ~ 2,
rank == "genus" ~ 3,
rank == "family" ~ 4,
rank == "order" ~ 5,
rank == "class" ~ 6,
TRUE ~ 7
),
fullname_rank = paste0(fullname, " {", rank, "}")
) %>%
arrange(kingdom, fullname, rank_index) %>%
group_by(kingdom, fullname) %>%
mutate(fullname = if_else(row_number() > 1, fullname_rank, fullname)) %>%
ungroup() %>%
select(-fullname_rank, -rank_index) %>%
arrange(fullname)
# now also add missing species (requires combination with genus)
@ -676,12 +684,13 @@ taxonomy <- taxonomy %>%
) %>%
filter(!paste(kingdom, genus, species, rank) %in% paste(taxonomy$kingdom, taxonomy$genus, taxonomy$species, taxonomy$rank)) %>%
# get GBIF identifier where available
left_join(current_gbif %>%
select(kingdom, genus, species = specificEpithet, rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
by = c("kingdom", "rank", "genus", "species")
left_join(
current_gbif %>%
select(kingdom, genus, species = specificEpithet, rank = taxonRank, ref = scientificNameAuthorship, gbif = taxonID, gbif_parent = parentNameUsageID),
by = c("kingdom", "rank", "genus", "species")
) %>%
mutate(source = ifelse(!is.na(gbif), "GBIF", source))
)
)
# remove NAs from taxonomy again, and keep unique full names
@ -702,7 +711,7 @@ manually_added <- AMR::microorganisms %>%
filter(source == "manually added", !paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname)) %>%
select(fullname:subspecies, ref, source, rank)
manually_added <- manually_added %>%
manually_added <- manually_added %>%
bind_rows(salmonellae)
# get latest taxonomy for those entries
@ -805,76 +814,83 @@ taxonomy <- taxonomy %>%
pathogens <- read_excel(file_bartlett, sheet = "Tab 6 Full List")
# get all established, both old and current taxonomic names
established <- pathogens %>%
filter(status == "established") %>%
established <- pathogens %>%
filter(status == "established") %>%
mutate(fullname = paste(genus, species)) %>%
pull(fullname) %>%
c(unlist(mo_current(.)),
unlist(mo_synonyms(., keep_synonyms = FALSE))) %>%
strsplit(" ", fixed = TRUE) %>%
sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>%
sort() %>%
pull(fullname) %>%
c(
unlist(mo_current(.)),
unlist(mo_synonyms(., keep_synonyms = FALSE))
) %>%
strsplit(" ", fixed = TRUE) %>%
sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>%
sort() %>%
unique()
# get all putative, both old and current taxonomic names
putative <- pathogens %>%
filter(status == "putative") %>%
putative <- pathogens %>%
filter(status == "putative") %>%
mutate(fullname = paste(genus, species)) %>%
pull(fullname) %>%
c(unlist(mo_current(.)),
unlist(mo_synonyms(., keep_synonyms = FALSE))) %>%
strsplit(" ", fixed = TRUE) %>%
sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>%
sort() %>%
pull(fullname) %>%
c(
unlist(mo_current(.)),
unlist(mo_synonyms(., keep_synonyms = FALSE))
) %>%
strsplit(" ", fixed = TRUE) %>%
sapply(function(x) ifelse(length(x) == 1, x, paste(x[1], x[2]))) %>%
sort() %>%
unique()
established <- established[established %unlike% "unknown"]
putative <- putative[putative %unlike% "unknown"]
established_genera <- established %>%
strsplit(" ", fixed = TRUE) %>%
sapply(function(x) x[1]) %>%
sort() %>%
established_genera <- established %>%
strsplit(" ", fixed = TRUE) %>%
sapply(function(x) x[1]) %>%
sort() %>%
unique()
putative_genera <- putative %>%
strsplit(" ", fixed = TRUE) %>%
sapply(function(x) x[1]) %>%
sort() %>%
putative_genera <- putative %>%
strsplit(" ", fixed = TRUE) %>%
sapply(function(x) x[1]) %>%
sort() %>%
unique()
nonbacterial_genera <- AMR:::MO_PREVALENT_GENERA %>%
c(unlist(mo_current(.)),
unlist(mo_synonyms(., keep_synonyms = FALSE))) %>%
strsplit(" ", fixed = TRUE) %>%
sapply(function(x) x[1]) %>%
sort() %>%
nonbacterial_genera <- AMR:::MO_PREVALENT_GENERA %>%
c(
unlist(mo_current(.)),
unlist(mo_synonyms(., keep_synonyms = FALSE))
) %>%
strsplit(" ", fixed = TRUE) %>%
sapply(function(x) x[1]) %>%
sort() %>%
unique()
nonbacterial_genera <- nonbacterial_genera[nonbacterial_genera %unlike% "unknown"]
# update prevalence based on taxonomy (following the recent and thorough work of Bartlett et al., 2022)
# see https://doi.org/10.1099/mic.0.001269
taxonomy <- taxonomy %>%
taxonomy <- taxonomy %>%
mutate(prevalence = case_when(
# 'established' means 'have infected at least three persons in three or more references'
paste(genus, species) %in% established & rank %in% c("species", "subspecies") ~ 1.0,
# other genera in the 'established' group
genus %in% established_genera & rank == "genus" ~ 1.0,
# 'putative' means 'fewer than three known cases'
paste(genus, species) %in% putative & rank %in% c("species", "subspecies") ~ 1.25,
# other genera in the 'putative' group
genus %in% putative_genera & rank == "genus" ~ 1.25,
# species and subspecies in 'established' and 'putative' groups
genus %in% c(established_genera, putative_genera) & rank %in% c("species", "subspecies") ~ 1.5,
# other species from a genus in either group
genus %in% nonbacterial_genera & rank %in% c("genus", "species", "subspecies") ~ 1.5,
# we keep track of prevalent genera too of non-bacterial species
genus %in% AMR:::MO_PREVALENT_GENERA & kingdom != "Bacteria" & rank %in% c("genus", "species", "subspecies") ~ 1.5,
# all others
TRUE ~ 2.0))
TRUE ~ 2.0
))
table(taxonomy$prevalence, useNA = "always")
# (a lot will be removed further below)
@ -909,13 +925,14 @@ mo_kingdom <- taxonomy %>%
mo_phylum <- taxonomy %>%
filter(rank == "phylum") %>%
distinct(kingdom, phylum) %>%
left_join(AMR::microorganisms %>%
filter(rank == "phylum") %>%
transmute(kingdom,
phylum = fullname,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
),
by = c("kingdom", "phylum")
left_join(
AMR::microorganisms %>%
filter(rank == "phylum") %>%
transmute(kingdom,
phylum = fullname,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
),
by = c("kingdom", "phylum")
) %>%
group_by(kingdom) %>%
mutate(
@ -935,13 +952,14 @@ mo_phylum <- mo_phylum %>%
mo_class <- taxonomy %>%
filter(rank == "class") %>%
distinct(kingdom, class) %>%
left_join(AMR::microorganisms %>%
filter(rank == "class") %>%
transmute(kingdom,
class = fullname,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
),
by = c("kingdom", "class")
left_join(
AMR::microorganisms %>%
filter(rank == "class") %>%
transmute(kingdom,
class = fullname,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
),
by = c("kingdom", "class")
) %>%
group_by(kingdom) %>%
mutate(
@ -961,13 +979,14 @@ mo_class <- mo_class %>%
mo_order <- taxonomy %>%
filter(rank == "order") %>%
distinct(kingdom, order) %>%
left_join(AMR::microorganisms %>%
filter(rank == "order") %>%
transmute(kingdom,
order = fullname,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
),
by = c("kingdom", "order")
left_join(
AMR::microorganisms %>%
filter(rank == "order") %>%
transmute(kingdom,
order = fullname,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
),
by = c("kingdom", "order")
) %>%
group_by(kingdom) %>%
mutate(
@ -987,13 +1006,14 @@ mo_order <- mo_order %>%
mo_family <- taxonomy %>%
filter(rank == "family") %>%
distinct(kingdom, family) %>%
left_join(AMR::microorganisms %>%
filter(rank == "family") %>%
transmute(kingdom,
family = fullname,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
),
by = c("kingdom", "family")
left_join(
AMR::microorganisms %>%
filter(rank == "family") %>%
transmute(kingdom,
family = fullname,
mo_old = gsub("[A-Z]{1,2}_", "", as.character(mo))
),
by = c("kingdom", "family")
) %>%
group_by(kingdom) %>%
mutate(
@ -1014,11 +1034,12 @@ mo_genus <- taxonomy %>%
filter(rank == "genus") %>%
distinct(kingdom, genus) %>%
# get available old MO codes
left_join(AMR::microorganisms %>%
filter(rank == "genus") %>%
transmute(mo_genus_old = gsub("^[A-Z]+_", "", as.character(mo)), kingdom, genus) %>%
distinct(kingdom, genus, .keep_all = TRUE),
by = c("kingdom", "genus")
left_join(
AMR::microorganisms %>%
filter(rank == "genus") %>%
transmute(mo_genus_old = gsub("^[A-Z]+_", "", as.character(mo)), kingdom, genus) %>%
distinct(kingdom, genus, .keep_all = TRUE),
by = c("kingdom", "genus")
) %>%
distinct(kingdom, genus, .keep_all = TRUE) %>%
# since kingdom is part of the code, genus abbreviations may be duplicated between kingdoms
@ -1060,12 +1081,13 @@ mo_genus <- mo_genus %>%
mo_species <- taxonomy %>%
filter(rank == "species") %>%
distinct(kingdom, genus, species) %>%
left_join(AMR::microorganisms %>%
filter(rank == "species") %>%
transmute(mo_species_old = gsub("^[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species) %>%
filter(mo_species_old %unlike% "-") %>%
distinct(kingdom, genus, species, .keep_all = TRUE),
by = c("kingdom", "genus", "species")
left_join(
AMR::microorganisms %>%
filter(rank == "species") %>%
transmute(mo_species_old = gsub("^[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species) %>%
filter(mo_species_old %unlike% "-") %>%
distinct(kingdom, genus, species, .keep_all = TRUE),
by = c("kingdom", "genus", "species")
) %>%
distinct(kingdom, genus, species, .keep_all = TRUE) %>%
group_by(kingdom, genus) %>%
@ -1108,12 +1130,13 @@ mo_species <- mo_species %>%
mo_subspecies <- taxonomy %>%
filter(rank == "subspecies") %>%
distinct(kingdom, genus, species, subspecies) %>%
left_join(AMR::microorganisms %>%
filter(rank %in% c("subspecies", "subsp.", "infraspecies")) %>%
transmute(mo_subspecies_old = gsub("^[A-Z]+_[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species, subspecies) %>%
filter(mo_subspecies_old %unlike% "-") %>%
distinct(kingdom, genus, species, subspecies, .keep_all = TRUE),
by = c("kingdom", "genus", "species", "subspecies")
left_join(
AMR::microorganisms %>%
filter(rank %in% c("subspecies", "subsp.", "infraspecies")) %>%
transmute(mo_subspecies_old = gsub("^[A-Z]+_[A-Z]+_[A-Z]+_", "", as.character(mo)), kingdom, genus, species, subspecies) %>%
filter(mo_subspecies_old %unlike% "-") %>%
distinct(kingdom, genus, species, subspecies, .keep_all = TRUE),
by = c("kingdom", "genus", "species", "subspecies")
) %>%
distinct(kingdom, genus, species, subspecies, .keep_all = TRUE) %>%
group_by(kingdom, genus, species) %>%
@ -1187,20 +1210,26 @@ taxonomy <- taxonomy %>%
arrange(fullname)
# now check these - e.g. Nitrospira is the name of a genus AND its class
taxonomy %>% filter(fullname %in% .[duplicated(fullname), "fullname", drop = TRUE]) %>% View()
taxonomy %>%
filter(fullname %in% .[duplicated(fullname), "fullname", drop = TRUE]) %>%
View()
taxonomy <- taxonomy %>%
mutate(rank_index = case_when(kingdom == "Bacteria" ~ 1,
kingdom == "Fungi" ~ 2,
kingdom == "Protozoa" ~ 3,
kingdom == "Archaea" ~ 4,
TRUE ~ 5)) %>%
arrange(fullname, rank_index) %>%
distinct(fullname, .keep_all = TRUE) %>%
select(-rank_index) %>%
mutate(rank_index = case_when(
kingdom == "Bacteria" ~ 1,
kingdom == "Fungi" ~ 2,
kingdom == "Protozoa" ~ 3,
kingdom == "Archaea" ~ 4,
TRUE ~ 5
)) %>%
arrange(fullname, rank_index) %>%
distinct(fullname, .keep_all = TRUE) %>%
select(-rank_index) %>%
filter(mo != "")
# this must not exist:
taxonomy %>% filter(mo %like% "__") %>% View()
taxonomy %>%
filter(mo %like% "__") %>%
View()
taxonomy <- taxonomy %>% filter(mo %unlike% "__")
@ -1214,14 +1243,20 @@ taxonomy <- taxonomy %>% distinct(mo, .keep_all = TRUE)
taxonomy %>% filter(fullname %in% .[duplicated(fullname), "fullname", drop = TRUE])
# are all GBIFs available?
taxonomy %>% filter(!gbif_parent %in% gbif) %>% count(rank)
taxonomy %>%
filter(!gbif_parent %in% gbif) %>%
count(rank)
# try to find the right gbif IDs
taxonomy$gbif_parent[which(!taxonomy$gbif_parent %in% taxonomy$gbif & taxonomy$rank == "species")] <- taxonomy$gbif[match(taxonomy$genus[which(!taxonomy$gbif_parent %in% taxonomy$gbif & taxonomy$rank == "species")], taxonomy$genus)]
taxonomy$gbif_parent[which(!taxonomy$gbif_parent %in% taxonomy$gbif & taxonomy$rank == "class")] <- taxonomy$gbif[match(taxonomy$phylum[which(!taxonomy$gbif_parent %in% taxonomy$gbif & taxonomy$rank == "class")], taxonomy$phylum)]
taxonomy %>% filter(!gbif_parent %in% gbif) %>% count(rank)
taxonomy %>%
filter(!gbif_parent %in% gbif) %>%
count(rank)
# are all LPSNs available?
taxonomy %>% filter(!lpsn_parent %in% lpsn) %>% count(rank)
taxonomy %>%
filter(!lpsn_parent %in% lpsn) %>%
count(rank)
# make GBIF refer to newest renaming according to LPSN
taxonomy$gbif_renamed_to[which(!is.na(taxonomy$gbif_renamed_to) & !is.na(taxonomy$lpsn_renamed_to))] <- taxonomy$gbif[match(taxonomy$lpsn_renamed_to[which(!is.na(taxonomy$gbif_renamed_to) & !is.na(taxonomy$lpsn_renamed_to))], taxonomy$lpsn)]
@ -1251,21 +1286,33 @@ taxonomy <- taxonomy %>%
# no ghost families, orders classes, phyla
taxonomy <- taxonomy %>%
group_by(kingdom, family) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
group_by(kingdom, order) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
group_by(kingdom, class) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
group_by(kingdom, phylum) %>% filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
group_by(kingdom, family) %>%
filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
group_by(kingdom, order) %>%
filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
group_by(kingdom, class) %>%
filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
group_by(kingdom, phylum) %>%
filter(n() > 1 | fullname %like% "unknown" | rank == "kingdom") %>%
ungroup()
message("\nCongratulations! The new taxonomic table will contain ", format(nrow(taxonomy), big.mark = ","), " rows.\n",
"This was ", format(nrow(AMR::microorganisms), big.mark = ","), " rows.\n")
message(
"\nCongratulations! The new taxonomic table will contain ", format(nrow(taxonomy), big.mark = ","), " rows.\n",
"This was ", format(nrow(AMR::microorganisms), big.mark = ","), " rows.\n"
)
# these are the new ones:
taxonomy %>% filter(!paste(kingdom, fullname) %in% paste(AMR::microorganisms$kingdom, AMR::microorganisms$fullname)) %>% View()
taxonomy %>%
filter(!paste(kingdom, fullname) %in% paste(AMR::microorganisms$kingdom, AMR::microorganisms$fullname)) %>%
View()
# these were removed:
AMR::microorganisms %>% filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname)) %>% View()
AMR::microorganisms %>% filter(!fullname %in% taxonomy$fullname) %>% View()
AMR::microorganisms %>%
filter(!paste(kingdom, fullname) %in% paste(taxonomy$kingdom, taxonomy$fullname)) %>%
View()
AMR::microorganisms %>%
filter(!fullname %in% taxonomy$fullname) %>%
View()
# Add SNOMED CT -----------------------------------------------------------

3054
data-raw/salmonellae.R
View File

File diff suppressed because it is too large Load Diff

19
man/add_custom_microorganisms.Rd
View File

@ -58,8 +58,9 @@ mo_name("Enterobacter asburiae/cloacae")
# now add a custom entry - it will be considered by as.mo() and
# all mo_*() functions
add_custom_microorganisms(
data.frame(genus = "Enterobacter",
species = "asburiae/cloacae"
data.frame(
genus = "Enterobacter",
species = "asburiae/cloacae"
)
)
@ -81,8 +82,10 @@ mo_info("Enterobacter asburiae/cloacae")
# the function tries to be forgiving:
add_custom_microorganisms(
data.frame(GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE",
SPECIES = "SPECIES")
data.frame(
GENUS = "BACTEROIDES / PARABACTEROIDES SLASHLINE",
SPECIES = "SPECIES"
)
)
mo_name("BACTEROIDES / PARABACTEROIDES")
mo_rank("BACTEROIDES / PARABACTEROIDES")
@ -93,9 +96,11 @@ mo_family("Bacteroides/Parabacteroides")
# for groups and complexes, set them as species or subspecies:
add_custom_microorganisms(
data.frame(genus = "Citrobacter",
species = c("freundii", "braakii complex"),
subspecies = c("complex", ""))
data.frame(
genus = "Citrobacter",
species = c("freundii", "braakii complex"),
subspecies = c("complex", "")
)
)
mo_name(c("C. freundii complex", "C. braakii complex"))
mo_species(c("C. freundii complex", "C. braakii complex"))

12
man/antibiotic_class_selectors.Rd
View File

@ -214,20 +214,17 @@ example_isolates[, ab_selector(oral_ddd > 1 & oral_units == "g")]
# dplyr -------------------------------------------------------------------
\donttest{
if (require("dplyr")) {
# get AMR for all aminoglycosides e.g., per ward:
example_isolates \%>\%
group_by(ward) \%>\%
summarise(across(aminoglycosides(), resistance))
}
if (require("dplyr")) {
# You can combine selectors with '&' to be more specific:
example_isolates \%>\%
select(penicillins() & administrable_per_os())
}
if (require("dplyr")) {
# get AMR for only drugs that matter - no intrinsic resistance:
example_isolates \%>\%
filter(mo_genus() \%in\% c("Escherichia", "Klebsiella")) \%>\%
@ -235,7 +232,6 @@ if (require("dplyr")) {
summarise(across(not_intrinsic_resistant(), resistance))
}
if (require("dplyr")) {
# get susceptibility for antibiotics whose name contains "trim":
example_isolates \%>\%
filter(first_isolate()) \%>\%
@ -243,19 +239,16 @@ if (require("dplyr")) {
summarise(across(ab_selector(name \%like\% "trim"), susceptibility))
}
if (require("dplyr")) {
# this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
example_isolates \%>\%
select(carbapenems())
}
if (require("dplyr")) {
# this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
example_isolates \%>\%
select(mo, aminoglycosides())
}
if (require("dplyr")) {
# any() and all() work in dplyr's filter() too:
example_isolates \%>\%
filter(
@ -264,25 +257,21 @@ if (require("dplyr")) {
)
}
if (require("dplyr")) {
# also works with c():
example_isolates \%>\%
filter(any(c(carbapenems(), aminoglycosides()) == "R"))
}
if (require("dplyr")) {
# not setting any/all will automatically apply all():
example_isolates \%>\%
filter(aminoglycosides() == "R")
}
if (require("dplyr")) {
# this will select columns 'mo' and all antimycobacterial drugs ('RIF'):
example_isolates \%>\%
select(mo, ab_class("mycobact"))
}
if (require("dplyr")) {
# get bug/drug combinations for only glycopeptides in Gram-positives:
example_isolates \%>\%
filter(mo_is_gram_positive()) \%>\%
@ -298,7 +287,6 @@ if (require("dplyr")) {
select(penicillins()) # only the 'J01CA01' column will be selected
}
if (require("dplyr")) {
# with recent versions of dplyr this is all equal:
x <- example_isolates[carbapenems() == "R", ]
y <- example_isolates \%>\% filter(carbapenems() == "R")

1
man/as.ab.Rd
View File

@ -91,7 +91,6 @@ ab_name("eryt")
\donttest{
if (require("dplyr")) {
# you can quickly rename 'sir' columns using set_ab_names() with dplyr:
example_isolates \%>\%
set_ab_names(where(is.sir), property = "atc")

2
man/as.sir.Rd
View File

@ -125,7 +125,7 @@ your_data \%>\% mutate(across(where(is.disk), as.sir))
\item For \strong{interpreting a complete data set}, with automatic determination of MIC values, disk diffusion diameters, microorganism names or codes, and antimicrobial test results. This is done very simply by running \code{as.sir(your_data)}.
}
For points 2, 3 and 4: Use \code{\link[=sir_interpretation_history]{sir_interpretation_history()}} to retrieve a \link{data.frame} (or \link[tibble:tibble]{tibble} if the \code{tibble} package is installed) with all results of the last \code{\link[=as.sir]{as.sir()}} call.
\strong{For points 2, 3 and 4: Use \code{\link[=sir_interpretation_history]{sir_interpretation_history()}}} to retrieve a \link{data.frame} (or \link[tibble:tibble]{tibble} if the \code{tibble} package is installed) with all results of the last \code{\link[=as.sir]{as.sir()}} call.
}
\subsection{Supported Guidelines}{

2
man/first_isolate.Rd
View File

@ -179,13 +179,11 @@ if (require("dplyr")) {
filter(first_isolate())
}
if (require("dplyr")) {
# short-hand version:
example_isolates \%>\%
filter_first_isolate(info = FALSE)
}
if (require("dplyr")) {
# flag the first isolates per group:
example_isolates \%>\%
group_by(ward) \%>\%

13
man/get_episode.Rd
View File

@ -44,11 +44,12 @@ is_new_episode(df$date, episode_days = 60) # TRUE/FALSE
df[which(get_episode(df$date, 60) == 3), ]
# the functions also work for less than a day, e.g. to include one per hour:
get_episode(c(
Sys.time(),
Sys.time() + 60 * 60
),
episode_days = 1 / 24
get_episode(
c(
Sys.time(),
Sys.time() + 60 * 60
),
episode_days = 1 / 24
)
\donttest{
@ -85,7 +86,6 @@ if (require("dplyr")) {
)
}
if (require("dplyr")) {
# grouping on patients and microorganisms leads to the same
# results as first_isolate() when using 'episode-based':
x <- df \%>\%
@ -102,7 +102,6 @@ if (require("dplyr")) {
identical(x, y)
}
if (require("dplyr")) {
# but is_new_episode() has a lot more flexibility than first_isolate(),
# since you can now group on anything that seems relevant:
df \%>\%

10
man/ggplot_sir.Rd
View File

@ -138,13 +138,11 @@ At default, the names of antibiotics will be shown on the plots using \code{\lin
\examples{
\donttest{
if (require("ggplot2") && require("dplyr")) {
# get antimicrobial results for drugs against a UTI:
ggplot(example_isolates \%>\% select(AMX, NIT, FOS, TMP, CIP)) +
geom_sir()
}
if (require("ggplot2") && require("dplyr")) {
# prettify the plot using some additional functions:
df <- example_isolates \%>\% select(AMX, NIT, FOS, TMP, CIP)
ggplot(df) +
@ -155,21 +153,18 @@ if (require("ggplot2") && require("dplyr")) {
theme_sir()
}
if (require("ggplot2") && require("dplyr")) {
# or better yet, simplify this using the wrapper function - a single command:
example_isolates \%>\%
select(AMX, NIT, FOS, TMP, CIP) \%>\%
ggplot_sir()
}
if (require("ggplot2") && require("dplyr")) {
# get only proportions and no counts:
example_isolates \%>\%
select(AMX, NIT, FOS, TMP, CIP) \%>\%
ggplot_sir(datalabels = FALSE)
}
if (require("ggplot2") && require("dplyr")) {
# add other ggplot2 arguments as you like:
example_isolates \%>\%
select(AMX, NIT, FOS, TMP, CIP) \%>\%
@ -182,14 +177,12 @@ if (require("ggplot2") && require("dplyr")) {
)
}
if (require("ggplot2") && require("dplyr")) {
# you can alter the colours with colour names:
example_isolates \%>\%
select(AMX) \%>\%
ggplot_sir(colours = c(SI = "yellow"))
}
if (require("ggplot2") && require("dplyr")) {
# but you can also use the built-in colour-blind friendly colours for
# your plots, where "S" is green, "I" is yellow and "R" is red:
data.frame(
@ -202,7 +195,6 @@ if (require("ggplot2") && require("dplyr")) {
scale_sir_colours(Value4 = "S", Value5 = "I", Value6 = "R")
}
if (require("ggplot2") && require("dplyr")) {
# resistance of ciprofloxacine per age group
example_isolates \%>\%
mutate(first_isolate = first_isolate()) \%>\%
@ -216,14 +208,12 @@ if (require("ggplot2") && require("dplyr")) {
ggplot_sir(x = "age_group")
}
if (require("ggplot2") && require("dplyr")) {
# a shorter version which also adjusts data label colours:
example_isolates \%>\%
select(AMX, NIT, FOS, TMP, CIP) \%>\%
ggplot_sir(colours = FALSE)
}
if (require("ggplot2") && require("dplyr")) {
# it also supports groups (don't forget to use the group var on `x` or `facet`):
example_isolates \%>\%
filter(mo_is_gram_negative(), ward != "Outpatient") \%>\%

1
man/mo_property.Rd
View File

@ -405,7 +405,6 @@ mo_species("EHEC")
mo_fullname("K. pneu rh")
mo_shortname("K. pneu rh")
\donttest{
# Becker classification, see ?as.mo ----------------------------------------

1
man/proportion.Rd
View File

@ -204,7 +204,6 @@ if (require("dplyr")) {
)
}
if (require("dplyr")) {
# scoped dplyr verbs with antibiotic selectors
# (you could also use across() of course)
example_isolates \%>\%

2
tests/tinytest.R
View File

@ -34,7 +34,7 @@
# test only on GitHub Actions and at using RStudio jobs - not on CRAN as tests are lengthy
if (tryCatch(isTRUE(AMR:::import_fn("isJob", "rstudioapi")()), error = function(e) FALSE) ||
identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
identical(Sys.getenv("R_RUN_TINYTEST"), "true")) {
# env var 'R_LIBS_USER' got overwritten during 'R CMD check' in GitHub Actions, so:
.libPaths(c(Sys.getenv("R_LIBS_USER_GH_ACTIONS"), .libPaths()))
if (AMR:::pkg_is_available("tinytest", also_load = TRUE)) {

63
vignettes/AMR.Rmd
View File

@ -48,15 +48,16 @@ For this tutorial, we will create fake demonstration data to work with.
You can skip to [Cleaning the data](#cleaning-the-data) if you already have your own data ready. If you start your analysis, try to make the structure of your data generally look like this:
```{r example table, echo = FALSE, results = 'asis'}
knitr::kable(data.frame(
date = Sys.Date(),
patient_id = c("abcd", "abcd", "efgh"),
mo = "Escherichia coli",
AMX = c("S", "S", "R"),
CIP = c("S", "R", "S"),
stringsAsFactors = FALSE
),
align = "c"
knitr::kable(
data.frame(
date = Sys.Date(),
patient_id = c("abcd", "abcd", "efgh"),
mo = "Escherichia coli",
AMX = c("S", "S", "R"),
CIP = c("S", "R", "S"),
stringsAsFactors = FALSE
),
align = "c"
)
```
@ -129,14 +130,15 @@ sample_size <- 20000
data <- data.frame(
date = sample(dates, size = sample_size, replace = TRUE),
patient_id = sample(patients, size = sample_size, replace = TRUE),
hospital = sample(c(
"Hospital A",
"Hospital B",
"Hospital C",
"Hospital D"
),
size = sample_size, replace = TRUE,
prob = c(0.30, 0.35, 0.15, 0.20)
hospital = sample(
c(
"Hospital A",
"Hospital B",
"Hospital C",
"Hospital D"
),
size = sample_size, replace = TRUE,
prob = c(0.30, 0.35, 0.15, 0.20)
),
bacteria = sample(bacteria,
size = sample_size, replace = TRUE,
@ -293,10 +295,11 @@ data_1st %>%
```
```{r bug_drg 2b, echo = FALSE, results = 'asis'}
knitr::kable(data_1st %>%
filter(any(aminoglycosides() == "R")) %>%
head(),
align = "c"
knitr::kable(
data_1st %>%
filter(any(aminoglycosides() == "R")) %>%
head(),
align = "c"
)
```
@ -309,10 +312,11 @@ data_1st %>%
```
```{r bug_drg 1b, echo = FALSE, results = 'asis'}
knitr::kable(data_1st %>%
bug_drug_combinations() %>%
head(),
align = "c"
knitr::kable(
data_1st %>%
bug_drug_combinations() %>%
head(),
align = "c"
)
```
@ -325,10 +329,11 @@ data_1st %>%
```{r bug_drg 3b, echo = FALSE, results = 'asis'}
knitr::kable(data_1st %>%
select(bacteria, aminoglycosides()) %>%
bug_drug_combinations(),
align = "c"
knitr::kable(
data_1st %>%
select(bacteria, aminoglycosides()) %>%
bug_drug_combinations(),
align = "c"
)
```

13
vignettes/WHONET.Rmd
View File

@ -88,11 +88,12 @@ data %>%
```{r, echo = FALSE}
# on very old and some new releases of R, this may lead to an error
tryCatch(data %>%
group_by(Country) %>%
select(Country, AMP_ND2, AMC_ED20, CAZ_ED10, CIP_ED5) %>%
ggplot_sir(translate_ab = "ab", facet = "Country", datalabels = FALSE) %>%
print(),
error = function(e) base::invisible()
tryCatch(
data %>%
group_by(Country) %>%
select(Country, AMP_ND2, AMC_ED20, CAZ_ED10, CIP_ED5) %>%
ggplot_sir(translate_ab = "ab", facet = "Country", datalabels = FALSE) %>%
print(),
error = function(e) base::invisible()
)
```