P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2026-08-07 23:37:01 +02:00
Code Releases Activity

styled, unit test fix

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2022-08-28 10:31:50 +02:00
parent 4cb1db4554
commit 4d050aef7c
147 changed files with 10897 additions and 8169 deletions
Download Patch File Download Diff File Expand all files Collapse all files

214
R/aa_globals.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -24,34 +24,50 @@
# ==================================================================== #
# add new version numbers here, and add the rules themselves to "data-raw/eucast_rules.tsv" and rsi_translation
# (sourcing "data-raw/pre-commit-hook.R" will process the TSV file)
EUCAST_VERSION_BREAKPOINTS <- list("11.0" = list(version_txt = "v11.0",
year = 2021,
title = "'EUCAST Clinical Breakpoint Tables'",
url = "https://www.eucast.org/clinical_breakpoints/"),
"10.0" = list(version_txt = "v10.0",
year = 2020,
title = "'EUCAST Clinical Breakpoint Tables'",
url = "https://www.eucast.org/ast_of_bacteria/previous_versions_of_documents/"))
EUCAST_VERSION_EXPERT_RULES <- list("3.1" = list(version_txt = "v3.1",
year = 2016,
title = "'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"),
"3.2" = list(version_txt = "v3.2",
year = 2020,
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"),
"3.3" = list(version_txt = "v3.3",
year = 2021,
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"))
# (sourcing "data-raw/_pre_commit_hook.R" will process the TSV file)
EUCAST_VERSION_BREAKPOINTS <- list(
"11.0" = list(
version_txt = "v11.0",
year = 2021,
title = "'EUCAST Clinical Breakpoint Tables'",
url = "https://www.eucast.org/clinical_breakpoints/"
),
"10.0" = list(
version_txt = "v10.0",
year = 2020,
title = "'EUCAST Clinical Breakpoint Tables'",
url = "https://www.eucast.org/ast_of_bacteria/previous_versions_of_documents/"
)
)
EUCAST_VERSION_EXPERT_RULES <- list(
"3.1" = list(
version_txt = "v3.1",
year = 2016,
title = "'EUCAST Expert Rules, Intrinsic Resistance and Exceptional Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
),
"3.2" = list(
version_txt = "v3.2",
year = 2020,
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
),
"3.3" = list(
version_txt = "v3.3",
year = 2021,
title = "'EUCAST Expert Rules' and 'EUCAST Intrinsic Resistance and Unusual Phenotypes'",
url = "https://www.eucast.org/expert_rules_and_expected_phenotypes/"
)
)
SNOMED_VERSION <- list(title = "Public Health Information Network Vocabulary Access and Distribution System (PHIN VADS)",
current_source = "US Edition of SNOMED CT from 1 September 2020",
current_version = 12,
current_oid = "2.16.840.1.114222.4.11.1009",
value_set_name = "Microorganism",
url = "https://phinvads.cdc.gov/vads/ViewValueSet.action?oid=2.16.840.1.114222.4.11.1009")
SNOMED_VERSION <- list(
title = "Public Health Information Network Vocabulary Access and Distribution System (PHIN VADS)",
current_source = "US Edition of SNOMED CT from 1 September 2020",
current_version = 12,
current_oid = "2.16.840.1.114222.4.11.1009",
value_set_name = "Microorganism",
url = "https://phinvads.cdc.gov/vads/ViewValueSet.action?oid=2.16.840.1.114222.4.11.1009"
)
CATALOGUE_OF_LIFE <- list(
year = 2019,
@@ -61,73 +77,75 @@ CATALOGUE_OF_LIFE <- list(
yearmonth_LPSN = "5 October 2021"
)
globalVariables(c(".rowid",
"ab",
"ab_txt",
"affect_ab_name",
"affect_mo_name",
"angle",
"antibiotic",
"antibiotics",
"atc_group1",
"atc_group2",
"base_ab",
"code",
"cols",
"count",
"data",
"disk",
"dosage",
"dose",
"dose_times",
"fullname",
"fullname_lower",
"g_species",
"genus",
"gr",
"group",
"guideline",
"hjust",
"input",
"intrinsic_resistant",
"isolates",
"lang",
"language",
"lookup",
"method",
"mic",
"mic ",
"microorganism",
"microorganisms",
"microorganisms.codes",
"microorganisms.old",
"mo",
"name",
"new",
"observations",
"old",
"old_name",
"pattern",
"R",
"rank_index",
"reference.rule",
"reference.rule_group",
"reference.version",
"rowid",
"rsi",
"rsi_translation",
"rule_group",
"rule_name",
"se_max",
"se_min",
"species",
"species_id",
"total",
"txt",
"type",
"value",
"varname",
"xvar",
"y",
"year",
"yvar"))
globalVariables(c(
".rowid",
"ab",
"ab_txt",
"affect_ab_name",
"affect_mo_name",
"angle",
"antibiotic",
"antibiotics",
"atc_group1",
"atc_group2",
"base_ab",
"code",
"cols",
"count",
"data",
"disk",
"dosage",
"dose",
"dose_times",
"fullname",
"fullname_lower",
"g_species",
"genus",
"gr",
"group",
"guideline",
"hjust",
"input",
"intrinsic_resistant",
"isolates",
"lang",
"language",
"lookup",
"method",
"mic",
"mic ",
"microorganism",
"microorganisms",
"microorganisms.codes",
"microorganisms.old",
"mo",
"name",
"new",
"observations",
"old",
"old_name",
"pattern",
"R",
"rank_index",
"reference.rule",
"reference.rule_group",
"reference.version",
"rowid",
"rsi",
"rsi_translation",
"rule_group",
"rule_name",
"se_max",
"se_min",
"species",
"species_id",
"total",
"txt",
"type",
"value",
"varname",
"xvar",
"y",
"year",
"yvar"
))

642
R/aa_helper_functions.R
View File

File diff suppressed because it is too large Load Diff

79
R/aa_helper_pm_functions.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -34,10 +34,10 @@
#
# All functions are prefixed with 'pm_' to make it obvious that they are dplyr substitutes.
#
# All code below was released under MIT license, that permits 'free of charge, to any person obtaining a
# All code below was released under MIT license, that permits 'free of charge, to any person obtaining a
# copy of the software and associated documentation files (the "Software"), to deal in the Software
# without restriction, including without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software
# distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software
# is furnished to do so', given that a copyright notice is given in the software.
#
# Copyright notice on 19 September 2020, the day this code was downloaded, as found on
@@ -206,7 +206,9 @@ pm_distinct <- function(.data, ...) {
}
pm_distinct.default <- function(.data, ..., .keep_all = FALSE) {
if (ncol(.data) == 0L) return(.data[1, ])
if (ncol(.data) == 0L) {
return(.data[1, ])
}
cols <- pm_deparse_dots(...)
col_names <- names(cols)
col_len <- length(cols)
@@ -336,7 +338,9 @@ pm_print.grouped_data <- function(x, ..., digits = NULL, quote = FALSE, right =
}
pm_group_data <- function(.data) {
if (!pm_has_groups(.data)) return(data.frame(.rows = I(list(seq_len(nrow(.data))))))
if (!pm_has_groups(.data)) {
return(data.frame(.rows = I(list(seq_len(nrow(.data))))))
}
pm_groups <- pm_get_groups(.data)
pm_group_data_worker(.data, pm_groups)
}
@@ -360,7 +364,9 @@ pm_group_rows <- function(.data) {
}
pm_group_indices <- function(.data) {
if (!pm_has_groups(.data)) return(rep(1L, nrow(.data)))
if (!pm_has_groups(.data)) {
return(rep(1L, nrow(.data)))
}
pm_groups <- pm_get_groups(.data)
res <- unique(.data[, pm_groups, drop = FALSE])
res <- res[do.call(order, lapply(pm_groups, function(x) res[, x])), , drop = FALSE]
@@ -417,7 +423,9 @@ pm_group_keys <- function(.data) {
pm_context$setup(.data)
res <- pm_context$.data[, pm_context$get_colnames() %in% pm_groups, drop = FALSE]
res <- res[!duplicated(res), , drop = FALSE]
if (nrow(res) == 0L) return(res)
if (nrow(res) == 0L) {
return(res)
}
class(res) <- "data.frame"
res <- res[do.call(order, lapply(pm_groups, function(x) res[, x])), , drop = FALSE]
rownames(res) <- NULL
@@ -509,7 +517,9 @@ pm_join_message <- function(by) {
pm_lag <- function(x, pm_n = 1L, default = NA) {
if (inherits(x, "ts")) stop("`x` must be a vector, not a `ts` object, do you want `stats::pm_lag()`?")
if (length(pm_n) != 1L || !is.numeric(pm_n) || pm_n < 0L) stop("`pm_n` must be a nonnegative integer scalar")
if (pm_n == 0L) return(x)
if (pm_n == 0L) {
return(x)
}
tryCatch(
storage.mode(default) <- typeof(x),
warning = function(w) {
@@ -525,7 +535,9 @@ pm_lag <- function(x, pm_n = 1L, default = NA) {
pm_lead <- function(x, pm_n = 1L, default = NA) {
if (length(pm_n) != 1L || !is.numeric(pm_n) || pm_n < 0L) stop("pm_n must be a nonnegative integer scalar")
if (pm_n == 0L) return(x)
if (pm_n == 0L) {
return(x)
}
tryCatch(
storage.mode(default) <- typeof(x),
warning = function(w) {
@@ -565,7 +577,9 @@ pm_mutate.grouped_data <- function(.data, ...) {
}
pm_n_distinct <- function(..., na.rm = FALSE) {
res <- c(...)
if (is.list(res)) return(nrow(unique(as.data.frame(res, stringsAsFactors = FALSE))))
if (is.list(res)) {
return(nrow(unique(as.data.frame(res, stringsAsFactors = FALSE))))
}
if (isTRUE(na.rm)) res <- res[!is.na(res)]
length(unique(res))
}
@@ -593,7 +607,7 @@ pm_pull <- function(.data, var = -1) {
} else if (var_deparse %in% col_names) {
var <- var_deparse
}
.data[, var]
.data[, var, drop = TRUE]
}
pm_set_names <- function(object = nm, nm) {
names(object) <- nm
@@ -669,15 +683,16 @@ pm_rename_with <- function(.data, .fn, .cols = pm_everything(), ...) {
.data
}
pm_replace_with <- function(x, i, val, arg_name) {
if (is.null(val)) return(x)
if (is.null(val)) {
return(x)
}
pm_check_length(val, x, arg_name)
pm_check_type(val, x, arg_name)
pm_check_class(val, x, arg_name)
i[is.na(i)] <- FALSE
if (length(val) == 1L) {
x[i] <- val
}
else {
} else {
x[i] <- val[i]
}
x
@@ -686,7 +701,9 @@ pm_replace_with <- function(x, i, val, arg_name) {
pm_check_length <- function(x, y, arg_name) {
length_x <- length(x)
length_y <- length(y)
if (all(length_x %in% c(1L, length_y))) return()
if (all(length_x %in% c(1L, length_y))) {
return()
}
if (length_y == 1) {
stop(arg_name, " must be length 1, not ", paste(length_x, sep = ", "))
} else {
@@ -697,15 +714,21 @@ pm_check_length <- function(x, y, arg_name) {
pm_check_type <- function(x, y, arg_name) {
x_type <- typeof(x)
y_type <- typeof(y)
if (identical(x_type, y_type)) return()
if (identical(x_type, y_type)) {
return()
}
stop(arg_name, " must be `", y_type, "`, not `", x_type, "`")
}
pm_check_class <- function(x, y, arg_name) {
if (!is.object(x)) return()
if (!is.object(x)) {
return()
}
exp_classes <- class(y)
out_classes <- class(x)
if (identical(out_classes, exp_classes)) return()
if (identical(out_classes, exp_classes)) {
return()
}
stop(arg_name, " must have class `", exp_classes, "`, not class `", out_classes, "`")
}
pm_rownames_to_column <- function(.data, var = "rowname") {
@@ -827,8 +850,7 @@ pm_select_positions <- function(.data, ..., .group_pos = FALSE) {
pm_eval_expr <- function(x) {
type <- typeof(x)
switch(
type,
switch(type,
"integer" = x,
"double" = as.integer(x),
"character" = pm_select_char(x),
@@ -864,8 +886,7 @@ pm_select_symbol <- function(expr) {
pm_eval_call <- function(x) {
type <- as.character(x[[1]])
switch(
type,
switch(type,
`:` = pm_select_seq(x),
`!` = pm_select_negate(x),
`-` = pm_select_minus(x),
@@ -1029,7 +1050,7 @@ pm_is_wholenumber <- function(x) {
x %% 1L == 0L
}
pm_seq2 <- function (from, to) {
pm_seq2 <- function(from, to) {
if (length(from) != 1) stop("`from` must be length one")
if (length(to) != 1) stop("`to` must be length one")
if (from > to) integer() else seq.int(from, to)
@@ -1041,19 +1062,25 @@ pm_is_function <- function(x, frame) {
warning = function(w) FALSE,
error = function(e) FALSE
)
if (isTRUE(res)) return(res)
if (isTRUE(res)) {
return(res)
}
res <- tryCatch(
is.function(eval(x)),
warning = function(w) FALSE,
error = function(e) FALSE
)
if (isTRUE(res)) return(res)
if (isTRUE(res)) {
return(res)
}
res <- tryCatch(
is.function(eval(as.symbol(deparse(substitute(x))))),
warning = function(w) FALSE,
error = function(e) FALSE
)
if (isTRUE(res)) return(res)
if (isTRUE(res)) {
return(res)
}
FALSE
}

251
R/ab.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -33,16 +33,16 @@
#' @rdname as.ab
#' @inheritSection WHOCC WHOCC
#' @details All entries in the [antibiotics] data set have three different identifiers: a human readable EARS-Net code (column `ab`, used by ECDC and WHONET), an ATC code (column `atc`, used by WHO), and a CID code (column `cid`, Compound ID, used by PubChem). The data set contains more than 5,000 official brand names from many different countries, as found in PubChem. Not that some drugs contain multiple ATC codes.
#'
#'
#' All these properties will be searched for the user input. The [as.ab()] can correct for different forms of misspelling:
#'
#'
#' * Wrong spelling of drug names (such as "tobramicin" or "gentamycin"), which corrects for most audible similarities such as f/ph, x/ks, c/z/s, t/th, etc.
#' * Too few or too many vowels or consonants
#' * Switching two characters (such as "mreopenem", often the case in clinical data, when doctors typed too fast)
#' * Digitalised paper records, leaving artefacts like 0/o/O (zero and O's), B/8, n/r, etc.
#'
#' Use the [`ab_*`][ab_property()] functions to get properties based on the returned antibiotic ID, see *Examples*.
#'
#'
#' Note: the [as.ab()] and [`ab_*`][ab_property()] functions may use very long regular expression to match brand names of antimicrobial agents. This may fail on some systems.
#' @section Source:
#' World Health Organization (WHO) Collaborating Centre for Drug Statistics Methodology: \url{https://www.whocc.no/atc_ddd_index/}
@@ -50,7 +50,7 @@
#' European Commission Public Health PHARMACEUTICALS - COMMUNITY REGISTER: \url{https://ec.europa.eu/health/documents/community-register/html/reg_hum_atc.htm}
#' @aliases ab
#' @return A [character] [vector] with additional class [`ab`]
#' @seealso
#' @seealso
#' * [antibiotics] for the [data.frame] that is being used to determine ATCs
#' * [ab_from_text()] for a function to retrieve antimicrobial drugs from clinical text (from health care records)
#' @inheritSection AMR Reference Data Publicly Available
@@ -65,52 +65,52 @@
#' as.ab("ERYT")
#' as.ab("ERY")
#' as.ab("eritromicine") # spelled wrong, yet works
#' as.ab("Erythrocin") # trade name
#' as.ab("Romycin") # trade name
#'
#' as.ab("Erythrocin") # trade name
#' as.ab("Romycin") # trade name
#'
#' # spelling from different languages and dyslexia are no problem
#' ab_atc("ceftriaxon")
#' ab_atc("cephtriaxone") # small spelling error
#' ab_atc("cephthriaxone") # or a bit more severe
#' ab_atc("cephtriaxone") # small spelling error
#' ab_atc("cephthriaxone") # or a bit more severe
#' ab_atc("seephthriaaksone") # and even this works
#'
#' # use ab_* functions to get a specific properties (see ?ab_property);
#' # they use as.ab() internally:
#' ab_name("J01FA01") # "Erythromycin"
#' ab_name("eryt") # "Erythromycin"
#' ab_name("J01FA01") # "Erythromycin"
#' ab_name("eryt") # "Erythromycin"
#' \donttest{
#' if (require("dplyr")) {
#'
#'
#' # you can quickly rename <rsi> columns using dplyr >= 1.0.0:
#' example_isolates %>%
#' rename_with(as.ab, where(is.rsi))
#'
#' }
#' }
as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
meet_criteria(x, allow_class = c("character", "numeric", "integer", "factor"), allow_NA = TRUE)
meet_criteria(flag_multiple_results, allow_class = "logical", has_length = 1)
meet_criteria(info, allow_class = "logical", has_length = 1)
check_dataset_integrity()
if (is.ab(x)) {
return(x)
}
if (all(x %in% c(AB_lookup$ab, NA))) {
# all valid AB codes, but not yet right class
return(set_clean_class(x,
new_class = c("ab", "character")))
new_class = c("ab", "character")
))
}
initial_search <- is.null(list(...)$initial_search)
already_regex <- isTRUE(list(...)$already_regex)
fast_mode <- isTRUE(list(...)$fast_mode)
x_bak <- x
x <- toupper(x)
x_nonNA <- x[!is.na(x)]
# remove diacritics
x <- iconv(x, from = "UTF-8", to = "ASCII//TRANSLIT")
x <- gsub('"', "", x, fixed = TRUE)
@@ -121,11 +121,11 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
if (already_regex == FALSE) {
x_bak_clean <- generalise_antibiotic_name(x_bak_clean)
}
x <- unique(x_bak_clean) # this means that every x is in fact generalise_antibiotic_name(x)
x_new <- rep(NA_character_, length(x))
x_unknown <- character(0)
note_if_more_than_one_found <- function(found, index, from_text) {
if (initial_search == TRUE & isTRUE(length(from_text) > 1)) {
abnames <- ab_name(from_text, tolower = TRUE, initial_search = FALSE)
@@ -133,13 +133,15 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
abnames <- abnames[!abnames %in% c("clavulanic acid", "avibactam")]
}
if (length(abnames) > 1) {
message_("More than one result was found for item ", index, ": ",
vector_and(abnames, quotes = FALSE))
message_(
"More than one result was found for item ", index, ": ",
vector_and(abnames, quotes = FALSE)
)
}
}
found[1L]
}
# Fill in names, AB codes, CID codes and ATC codes directly (`x` is already clean and uppercase)
known_names <- x %in% AB_lookup$generalised_name
x_new[known_names] <- AB_lookup$ab[match(x[known_names], AB_lookup$generalised_name)]
@@ -147,77 +149,89 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
known_codes_atc <- vapply(FUN.VALUE = logical(1), x, function(x_) x_ %in% unlist(AB_lookup$atc), USE.NAMES = FALSE)
known_codes_cid <- x %in% AB_lookup$cid
x_new[known_codes_ab] <- AB_lookup$ab[match(x[known_codes_ab], AB_lookup$ab)]
x_new[known_codes_atc] <- AB_lookup$ab[vapply(FUN.VALUE = integer(1),
x[known_codes_atc],
function(x_) which(vapply(FUN.VALUE = logical(1),
AB_lookup$atc,
function(atc) x_ %in% atc))[1L],
USE.NAMES = FALSE)]
x_new[known_codes_atc] <- AB_lookup$ab[vapply(
FUN.VALUE = integer(1),
x[known_codes_atc],
function(x_) {
which(vapply(
FUN.VALUE = logical(1),
AB_lookup$atc,
function(atc) x_ %in% atc
))[1L]
},
USE.NAMES = FALSE
)]
x_new[known_codes_cid] <- AB_lookup$ab[match(x[known_codes_cid], AB_lookup$cid)]
already_known <- known_names | known_codes_ab | known_codes_atc | known_codes_cid
if (initial_search == TRUE & sum(already_known) < length(x)) {
progress <- progress_ticker(n = sum(!already_known), n_min = 25, print = info) # start if n >= 25
on.exit(close(progress))
}
for (i in which(!already_known)) {
if (initial_search == TRUE) {
progress$tick()
}
if (is.na(x[i]) | is.null(x[i])) {
next
}
if (identical(x[i], "") |
# prevent "bacteria" from coercing to TMP, since Bacterial is a brand name of it:
identical(tolower(x[i]), "bacteria")) {
# prevent "bacteria" from coercing to TMP, since Bacterial is a brand name of it:
identical(tolower(x[i]), "bacteria")) {
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
next
}
if (fast_mode == FALSE && flag_multiple_results == TRUE && x[i] %like% "[ ]") {
from_text <- tryCatch(suppressWarnings(ab_from_text(x[i], initial_search = FALSE, translate_ab = FALSE)[[1]]),
error = function(e) character(0))
error = function(e) character(0)
)
} else {
from_text <- character(0)
}
# old code for phenoxymethylpenicillin (Peni V)
if (x[i] == "PNV") {
x_new[i] <- "PHN"
next
}
# exact LOINC code
loinc_found <- unlist(lapply(AB_lookup$generalised_loinc,
function(s) x[i] %in% s))
loinc_found <- unlist(lapply(
AB_lookup$generalised_loinc,
function(s) x[i] %in% s
))
found <- antibiotics$ab[loinc_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# exact synonym
synonym_found <- unlist(lapply(AB_lookup$generalised_synonyms,
function(s) x[i] %in% s))
synonym_found <- unlist(lapply(
AB_lookup$generalised_synonyms,
function(s) x[i] %in% s
))
found <- antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# exact abbreviation
abbr_found <- unlist(lapply(AB_lookup$generalised_abbreviations,
# require at least 2 characters for abbreviations
function(s) x[i] %in% s & nchar(x[i]) >= 2))
abbr_found <- unlist(lapply(
AB_lookup$generalised_abbreviations,
# require at least 2 characters for abbreviations
function(s) x[i] %in% s & nchar(x[i]) >= 2
))
found <- antibiotics$ab[abbr_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# length of input is quite long, and Levenshtein distance is only max 2
if (nchar(x[i]) >= 10) {
levenshtein <- as.double(utils::adist(x[i], AB_lookup$generalised_name))
@@ -227,7 +241,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
next
}
}
# allow characters that resemble others, but only continue when having more than 3 characters
if (nchar(x[i]) <= 3) {
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
@@ -235,7 +249,6 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
}
x_spelling <- x[i]
if (already_regex == FALSE) {
x_spelling <- gsub("[IY]+", "[IY]+", x_spelling, perl = TRUE)
x_spelling <- gsub("(C|K|Q|QU|S|Z|X|KS)+", "(C|K|Q|QU|S|Z|X|KS)+", x_spelling, perl = TRUE)
x_spelling <- gsub("(PH|F|V)+", "(PH|F|V)+", x_spelling, perl = TRUE)
@@ -258,7 +271,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_spelling <- gsub("(O|0)", "(O|0)+", x_spelling, perl = TRUE)
x_spelling <- gsub("++", "+", x_spelling, fixed = TRUE)
}
# try if name starts with it
found <- antibiotics[which(AB_lookup$generalised_name %like% paste0("^", x_spelling)), "ab", drop = TRUE]
if (length(found) > 0) {
@@ -271,21 +284,23 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# and try if any synonym starts with it
synonym_found <- unlist(lapply(AB_lookup$generalised_synonyms,
function(s) any(s %like% paste0("^", x_spelling))))
synonym_found <- unlist(lapply(
AB_lookup$generalised_synonyms,
function(s) any(s %like% paste0("^", x_spelling))
))
found <- antibiotics$ab[synonym_found == TRUE]
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# INITIAL SEARCH - More uncertain results ----
if (initial_search == TRUE && fast_mode == FALSE) {
# only run on first try
# try by removing all spaces
if (x[i] %like% " ") {
found <- suppressWarnings(as.ab(gsub(" +", "", x[i], perl = TRUE), initial_search = FALSE))
@@ -294,7 +309,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
next
}
}
# try by removing all spaces and numbers
if (x[i] %like% " " | x[i] %like% "[0-9]") {
found <- suppressWarnings(as.ab(gsub("[ 0-9]", "", x[i], perl = TRUE), initial_search = FALSE))
@@ -303,45 +318,53 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
next
}
}
# 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])
}
}
generalise_antibiotic_name(y)
})[[1]],
collapse = "/")
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)
}
)[[1]],
collapse = "/"
)
x_translated_guess <- suppressWarnings(as.ab(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) {
x_new[i] <- x_translated_guess
next
}
# 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])
}
generalise_antibiotic_name(y)
})[[1]],
collapse = "/")
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)
}
)[[1]],
collapse = "/"
)
x_translated_guess <- suppressWarnings(as.ab(x_translated, initial_search = FALSE))
if (!is.na(x_translated_guess)) {
x_new[i] <- x_translated_guess
next
}
# try by removing all trailing capitals
if (x[i] %like_case% "[a-z]+[A-Z]+$") {
found <- suppressWarnings(as.ab(gsub("[A-Z]+$", "", x[i], perl = TRUE), initial_search = FALSE))
@@ -350,27 +373,28 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
next
}
}
# keep only letters
found <- suppressWarnings(as.ab(gsub("[^A-Z]", "", x[i], perl = TRUE), initial_search = FALSE))
if (!is.na(found)) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# try from a bigger text, like from a health care record, see ?ab_from_text
# already calculated above if flag_multiple_results = TRUE
if (flag_multiple_results == TRUE) {
found <- from_text[1L]
} else {
found <- tryCatch(suppressWarnings(ab_from_text(x[i], initial_search = FALSE, translate_ab = FALSE)[[1]][1L]),
error = function(e) NA_character_)
error = function(e) NA_character_
)
}
if (!is.na(found)) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# first 5 except for cephalosporins, then first 7 (those cephalosporins all start quite the same!)
found <- suppressWarnings(as.ab(substr(x[i], 1, 5), initial_search = FALSE))
if (!is.na(found) && ab_group(found, initial_search = FALSE) %unlike% "cephalosporins") {
@@ -382,7 +406,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# make all consonants facultative
search_str <- gsub("([BCDFGHJKLMNPQRSTVWXZ])", "\\1*", x[i], perl = TRUE)
found <- suppressWarnings(as.ab(search_str, initial_search = FALSE, already_regex = TRUE))
@@ -394,7 +418,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# make all vowels facultative
search_str <- gsub("([AEIOUY])", "\\1*", x[i], perl = TRUE)
found <- suppressWarnings(as.ab(search_str, initial_search = FALSE, already_regex = TRUE))
@@ -406,7 +430,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# allow misspelling of vowels
x_spelling <- gsub("A+", "[AEIOU]+", x_spelling, fixed = TRUE)
x_spelling <- gsub("E+", "[AEIOU]+", x_spelling, fixed = TRUE)
@@ -418,17 +442,18 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# try with switched character, like "mreopenem"
for (j in seq_len(nchar(x[i]))) {
x_switched <- paste0(
# beginning part:
substr(x[i], 1, j - 1),
# here is the switching of 2 characters:
substr(x[i], j + 1, j + 1),
substr(x[i], j, j),
substr(x[i], j + 1, j + 1),
substr(x[i], j, j),
# ending part:
substr(x[i], j + 2, nchar(x[i])))
substr(x[i], j + 2, nchar(x[i]))
)
found <- suppressWarnings(as.ab(x_switched, initial_search = FALSE))
if (!is.na(found)) {
break
@@ -438,37 +463,41 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_new[i] <- found[1L]
next
}
} # end of initial_search = TRUE
# not found
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
}
if (initial_search == TRUE & sum(already_known) < length(x)) {
close(progress)
}
# take failed ATC codes apart from rest
x_unknown_ATCs <- x_unknown[x_unknown %like% "[A-Z][0-9][0-9][A-Z][A-Z][0-9][0-9]"]
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
if (length(x_unknown_ATCs) > 0 & fast_mode == FALSE) {
warning_("in `as.ab()`: these ATC codes are not (yet) in the antibiotics data set: ",
vector_and(x_unknown_ATCs), ".")
warning_(
"in `as.ab()`: these ATC codes are not (yet) in the antibiotics data set: ",
vector_and(x_unknown_ATCs), "."
)
}
if (length(x_unknown) > 0 & fast_mode == FALSE) {
warning_("in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ",
vector_and(x_unknown), ".")
warning_(
"in `as.ab()`: these values could not be coerced to a valid antimicrobial ID: ",
vector_and(x_unknown), "."
)
}
x_result <- x_new[match(x_bak_clean, x)]
if (length(x_result) == 0) {
x_result <- NA_character_
}
set_clean_class(x_result,
new_class = c("ab", "character"))
new_class = c("ab", "character")
)
}
#' @rdname as.ab

122
R/ab_from_text.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -24,7 +24,7 @@
# ==================================================================== #
#' Retrieve Antimicrobial Drug Names and Doses from Clinical Text
#'
#'
#' Use this function on e.g. clinical texts from health care records. It returns a [list] with all antimicrobial drugs, doses and forms of administration found in the texts.
#' @param text text to analyse
#' @param type type of property to search for, either `"drug"`, `"dose"` or `"administration"`, see *Examples*
@@ -34,56 +34,62 @@
#' @param info a [logical] to indicate whether a progress bar should be printed, defaults to `TRUE` only in interactive mode
#' @param ... arguments passed on to [as.ab()]
#' @details This function is also internally used by [as.ab()], although it then only searches for the first drug name and will throw a note if more drug names could have been returned. Note: the [as.ab()] function may use very long regular expression to match brand names of antimicrobial agents. This may fail on some systems.
#'
#'
#' ## Argument `type`
#' At default, the function will search for antimicrobial drug names. All text elements will be searched for official names, ATC codes and brand names. As it uses [as.ab()] internally, it will correct for misspelling.
#'
#'
#' With `type = "dose"` (or similar, like "dosing", "doses"), all text elements will be searched for [numeric] values that are higher than 100 and do not resemble years. The output will be [numeric]. It supports any unit (g, mg, IE, etc.) and multiple values in one clinical text, see *Examples*.
#'
#'
#' With `type = "administration"` (or abbreviations, like "admin", "adm"), all text elements will be searched for a form of drug administration. It supports the following forms (including common abbreviations): buccal, implant, inhalation, instillation, intravenous, nasal, oral, parenteral, rectal, sublingual, transdermal and vaginal. Abbreviations for oral (such as 'po', 'per os') will become "oral", all values for intravenous (such as 'iv', 'intraven') will become "iv". It supports multiple values in one clinical text, see *Examples*.
#'
#'
#' ## Argument `collapse`
#' Without using `collapse`, this function will return a [list]. This can be convenient to use e.g. inside a `mutate()`):\cr
#' `df %>% mutate(abx = ab_from_text(clinical_text))`
#'
#' `df %>% mutate(abx = ab_from_text(clinical_text))`
#'
#' The returned AB codes can be transformed to official names, groups, etc. with all [`ab_*`][ab_property()] functions such as [ab_name()] and [ab_group()], or by using the `translate_ab` argument.
#'
#'
#' With using `collapse`, this function will return a [character]:\cr
#' `df %>% mutate(abx = ab_from_text(clinical_text, collapse = "|"))`
#' `df %>% mutate(abx = ab_from_text(clinical_text, collapse = "|"))`
#' @export
#' @return A [list], or a [character] if `collapse` is not `NULL`
#' @examples
#' # mind the bad spelling of amoxicillin in this line,
#' @examples
#' # mind the bad spelling of amoxicillin in this line,
#' # straight from a true health care record:
#' ab_from_text("28/03/2020 regular amoxicilliin 500mg po tds")
#'
#'
#' ab_from_text("500 mg amoxi po and 400mg cipro iv")
#' ab_from_text("500 mg amoxi po and 400mg cipro iv", type = "dose")
#' ab_from_text("500 mg amoxi po and 400mg cipro iv", type = "admin")
#'
#'
#' ab_from_text("500 mg amoxi po and 400mg cipro iv", collapse = ", ")
#' \donttest{
#' # if you want to know which antibiotic groups were administered, do e.g.:
#' abx <- ab_from_text("500 mg amoxi po and 400mg cipro iv")
#' ab_group(abx[[1]])
#'
#'
#' if (require("dplyr")) {
#' tibble(clinical_text = c("given 400mg cipro and 500 mg amox",
#' "started on doxy iv today")) %>%
#' mutate(abx_codes = ab_from_text(clinical_text),
#' abx_doses = ab_from_text(clinical_text, type = "doses"),
#' abx_admin = ab_from_text(clinical_text, type = "admin"),
#' abx_coll = ab_from_text(clinical_text, collapse = "|"),
#' abx_coll_names = ab_from_text(clinical_text,
#' collapse = "|",
#' translate_ab = "name"),
#' abx_coll_doses = ab_from_text(clinical_text,
#' type = "doses",
#' collapse = "|"),
#' abx_coll_admin = ab_from_text(clinical_text,
#' type = "admin",
#' collapse = "|"))
#'
#' tibble(clinical_text = c(
#' "given 400mg cipro and 500 mg amox",
#' "started on doxy iv today"
#' )) %>%
#' mutate(
#' abx_codes = ab_from_text(clinical_text),
#' abx_doses = ab_from_text(clinical_text, type = "doses"),
#' abx_admin = ab_from_text(clinical_text, type = "admin"),
#' abx_coll = ab_from_text(clinical_text, collapse = "|"),
#' abx_coll_names = ab_from_text(clinical_text,
#' collapse = "|",
#' translate_ab = "name"
#' ),
#' abx_coll_doses = ab_from_text(clinical_text,
#' type = "doses",
#' collapse = "|"
#' ),
#' abx_coll_admin = ab_from_text(clinical_text,
#' type = "admin",
#' collapse = "|"
#' )
#' )
#' }
#' }
ab_from_text <- function(text,
@@ -96,7 +102,7 @@ ab_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)
@@ -105,18 +111,17 @@ ab_from_text <- function(text,
meet_criteria(info, allow_class = "logical", has_length = 1)
type <- tolower(trimws(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_ab <- get_translate_ab(translate_ab)
if (isTRUE(thorough_search) |
(isTRUE(is.null(thorough_search)) & max(vapply(FUN.VALUE = double(1), text_split_all, length), na.rm = TRUE) <= 3)) {
if (isTRUE(thorough_search) |
(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()
@@ -124,7 +129,6 @@ ab_from_text <- function(text,
out <- as.ab(text_split, ...)
)
})
} else {
# no thorough search
abbr <- unlist(antibiotics$abbreviations)
@@ -136,25 +140,30 @@ ab_from_text <- function(text,
synonyms_part1 <- synonyms[seq_len(0.5 * length(synonyms))]
synonyms_part2 <- synonyms[!synonyms %in% synonyms_part1]
to_regex <- function(x) {
paste0("^(",
paste0(unique(gsub("[^a-z0-9]+", "", sort(tolower(x)))), collapse = "|"),
").*")
paste0(
"^(",
paste0(unique(gsub("[^a-z0-9]+", "", sort(tolower(x)))), collapse = "|"),
").*"
)
}
result <- lapply(text_split_all, function(text_split) {
progress$tick()
suppressWarnings(
out <- as.ab(unique(c(text_split[text_split %like_case% to_regex(abbr)],
text_split[text_split %like_case% to_regex(names_atc)],
text_split[text_split %like_case% to_regex(synonyms_part1)],
text_split[text_split %like_case% to_regex(synonyms_part2)])
),
...)
out <- as.ab(
unique(c(
text_split[text_split %like_case% to_regex(abbr)],
text_split[text_split %like_case% to_regex(names_atc)],
text_split[text_split %like_case% to_regex(synonyms_part1)],
text_split[text_split %like_case% to_regex(synonyms_part2)]
)),
...
)
)
})
}
close(progress)
result <- lapply(result, function(out) {
out <- out[!is.na(out)]
if (length(out) == 0) {
@@ -165,27 +174,24 @@ ab_from_text <- function(text,
}
out
}
})
} else if (type %like% "dos") {
text_split_all <- strsplit(text, " ")
result <- lapply(text_split_all, function(text_split) {
text_split <- text_split[text_split %like% "^[0-9]{2,}(/[0-9]+)?[a-z]*$"]
# only left part of "/", like 500 in "500/125"
text_split <- gsub("/.*", "", text_split)
text_split <- gsub("/.*", "", text_split)
text_split <- gsub(",", ".", text_split, fixed = TRUE) # foreign system using comma as decimal sep
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 {
NA_real_
}
})
} else if (type %like% "adm") {
result <- lapply(text_split_all, function(text_split) {
text_split <- text_split[text_split %like% "(^iv$|intraven|^po$|per os|oral|implant|inhal|instill|nasal|paren|rectal|sublingual|buccal|trans.*dermal|vaginal)"]
@@ -197,11 +203,10 @@ ab_from_text <- function(text,
NA_character_
}
})
} 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) {
@@ -212,7 +217,6 @@ ab_from_text <- function(text,
}
})
}
result
}

259
R/ab_property.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -37,14 +37,14 @@
#' @param snake_case a [logical] to indicate whether the names should be in so-called [snake case](https://en.wikipedia.org/wiki/Snake_case): in lower case and all spaces/slashes replaced with an underscore (`_`)
#' @param only_first a [logical] to indicate whether only the first ATC code must be returned, with giving preference to J0-codes (i.e., the antimicrobial drug group)
#' @details All output [will be translated][translate] where possible.
#'
#'
#' The function [ab_url()] will return the direct URL to the official WHO website. A warning will be returned if the required ATC code is not available.
#'
#'
#' The function [set_ab_names()] is a special column renaming function for [data.frame]s. It renames columns names that resemble antimicrobial drugs. It always makes sure that the new column names are unique. If `property = "atc"` is set, preference is given to ATC codes from the J-group.
#' @inheritSection as.ab Source
#' @rdname ab_property
#' @name ab_property
#' @return
#' @return
#' - An [integer] in case of [ab_cid()]
#' - A named [list] in case of [ab_info()] and multiple [ab_atc()]/[ab_synonyms()]/[ab_tradenames()]
#' - A [double] in case of [ab_ddd()]
@@ -55,43 +55,45 @@
#' @inheritSection AMR Reference Data Publicly Available
#' @examples
#' # all properties:
#' ab_name("AMX") # "Amoxicillin"
#' ab_atc("AMX") # "J01CA04" (ATC code from the WHO)
#' ab_cid("AMX") # 33613 (Compound ID from PubChem)
#' ab_synonyms("AMX") # a list with brand names of amoxicillin
#' ab_name("AMX") # "Amoxicillin"
#' ab_atc("AMX") # "J01CA04" (ATC code from the WHO)
#' ab_cid("AMX") # 33613 (Compound ID from PubChem)
#' ab_synonyms("AMX") # a list with brand names of amoxicillin
#' ab_tradenames("AMX") # same
#' ab_group("AMX") # "Beta-lactams/penicillins"
#' ab_group("AMX") # "Beta-lactams/penicillins"
#' ab_atc_group1("AMX") # "Beta-lactam antibacterials, penicillins"
#' ab_atc_group2("AMX") # "Penicillins with extended spectrum"
#' ab_url("AMX") # link to the official WHO page
#' ab_url("AMX") # link to the official WHO page
#'
#' # smart lowercase tranformation
#' ab_name(x = c("AMC", "PLB")) # "Amoxicillin/clavulanic acid" "Polymyxin B"
#' ab_name(x = c("AMC", "PLB"),
#' tolower = TRUE) # "amoxicillin/clavulanic acid" "polymyxin B"
#' ab_name(x = c("AMC", "PLB")) # "Amoxicillin/clavulanic acid" "Polymyxin B"
#' ab_name(
#' x = c("AMC", "PLB"),
#' tolower = TRUE
#' ) # "amoxicillin/clavulanic acid" "polymyxin B"
#'
#' # defined daily doses (DDD)
#' ab_ddd("AMX", "oral") # 1.5
#' ab_ddd("AMX", "oral") # 1.5
#' ab_ddd_units("AMX", "oral") # "g"
#' ab_ddd("AMX", "iv") # 3
#' ab_ddd_units("AMX", "iv") # "g"
#' ab_ddd("AMX", "iv") # 3
#' ab_ddd_units("AMX", "iv") # "g"
#'
#' ab_info("AMX") # all properties as a list
#' ab_info("AMX") # all properties as a list
#'
#' # all ab_* functions use as.ab() internally, so you can go from 'any' to 'any':
#' ab_atc("AMP") # ATC code of AMP (ampicillin)
#' ab_group("J01CA01") # Drug group of ampicillins ATC code
#' ab_loinc("ampicillin") # LOINC codes of ampicillin
#' ab_name("21066-6") # "Ampicillin" (using LOINC)
#' ab_name(6249) # "Ampicillin" (using CID)
#' ab_name("J01CA01") # "Ampicillin" (using ATC)
#'
#' ab_atc("AMP") # ATC code of AMP (ampicillin)
#' ab_group("J01CA01") # Drug group of ampicillins ATC code
#' ab_loinc("ampicillin") # LOINC codes of ampicillin
#' ab_name("21066-6") # "Ampicillin" (using LOINC)
#' ab_name(6249) # "Ampicillin" (using CID)
#' ab_name("J01CA01") # "Ampicillin" (using ATC)
#'
#' # spelling from different languages and dyslexia are no problem
#' ab_atc("ceftriaxon")
#' ab_atc("cephtriaxone")
#' ab_atc("cephthriaxone")
#' ab_atc("seephthriaaksone")
#'
#'
#' # use set_ab_names() for renaming columns
#' colnames(example_isolates)
#' colnames(set_ab_names(example_isolates))
@@ -101,31 +103,31 @@
#' example_isolates %>%
#' set_ab_names() %>%
#' head()
#'
#'
#' # this does the same:
#' example_isolates %>%
#' rename_with(set_ab_names)%>%
#' rename_with(set_ab_names) %>%
#' head()
#'
#'
#' # set_ab_names() works with any AB property:
#' example_isolates %>%
#' set_ab_names(property = "atc")%>%
#' set_ab_names(property = "atc") %>%
#' head()
#'
#' example_isolates %>%
#' set_ab_names(where(is.rsi)) %>%
#' colnames()
#'
#' example_isolates %>%
#' set_ab_names(NIT:VAN) %>%
#' colnames()
#'
#' example_isolates %>%
#' set_ab_names(where(is.rsi)) %>%
#' colnames()
#'
#' example_isolates %>%
#' set_ab_names(NIT:VAN) %>%
#' colnames()
#' }
#' }
ab_name <- function(x, language = get_AMR_locale(), tolower = FALSE, ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(tolower, allow_class = "logical", has_length = 1)
x <- translate_into_language(ab_validate(x = x, property = "name", ...), language = language, only_affect_ab_names = TRUE)
if (tolower == TRUE) {
# use perl to only transform the first character
@@ -176,27 +178,29 @@ ab_group <- function(x, language = get_AMR_locale(), ...) {
ab_atc <- function(x, only_first = FALSE, ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(only_first, allow_class = "logical", has_length = 1)
atcs <- ab_validate(x = x, property = "atc", ...)
if (only_first == TRUE) {
atcs <- vapply(FUN.VALUE = character(1),
# get only the first ATC code
atcs,
function(x) {
# try to get the J-group
if (any(x %like% "^J")) {
x[x %like% "^J"][1L]
} else {
as.character(x[1L])
}
})
atcs <- vapply(
FUN.VALUE = character(1),
# get only the first ATC code
atcs,
function(x) {
# try to get the J-group
if (any(x %like% "^J")) {
x[x %like% "^J"][1L]
} else {
as.character(x[1L])
}
}
)
} else if (length(atcs) == 1) {
atcs <- unname(unlist(atcs))
} else {
names(atcs) <- x
}
atcs
}
@@ -234,26 +238,30 @@ ab_loinc <- function(x, ...) {
ab_ddd <- function(x, administration = "oral", ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
x <- as.ab(x, ...)
ddd_prop <- administration
# old behaviour
units <- list(...)$units
if (!is.null(units) && isTRUE(units)) {
if (message_not_thrown_before("ab_ddd", entire_session = TRUE)) {
warning_("in `ab_ddd()`: using `ab_ddd(..., units = TRUE)` is deprecated, use `ab_ddd_units()` to retrieve units instead.",
"This warning will be shown once per session.")
warning_(
"in `ab_ddd()`: using `ab_ddd(..., units = TRUE)` is deprecated, use `ab_ddd_units()` to retrieve units instead.",
"This warning will be shown once per session."
)
}
ddd_prop <- paste0(ddd_prop, "_units")
} else {
ddd_prop <- paste0(ddd_prop, "_ddd")
}
out <- ab_validate(x = x, property = ddd_prop)
if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
warning_("in `ab_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
"Please refer to the WHOCC website:\n",
"www.whocc.no/ddd/list_of_ddds_combined_products/")
warning_(
"in `ab_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
"Please refer to the WHOCC website:\n",
"www.whocc.no/ddd/list_of_ddds_combined_products/"
)
}
out
}
@@ -263,14 +271,16 @@ ab_ddd <- function(x, administration = "oral", ...) {
ab_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.ab(x, ...)
if (any(ab_name(x, language = NULL) %like% "/")) {
warning_("in `ab_ddd_units()`: DDDs of combined products are available for different dose combinations and not (yet) part of the AMR package.",
"Please refer to the WHOCC website:\n",
"www.whocc.no/ddd/list_of_ddds_combined_products/")
warning_(
"in `ab_ddd_units()`: DDDs of combined products are available for different dose combinations and not (yet) part of the AMR package.",
"Please refer to the WHOCC website:\n",
"www.whocc.no/ddd/list_of_ddds_combined_products/"
)
}
ddd_prop <- paste0(administration, "_units")
ab_validate(x = x, property = ddd_prop)
}
@@ -280,21 +290,29 @@ ab_ddd_units <- function(x, administration = "oral", ...) {
ab_info <- function(x, language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- as.ab(x, ...)
list(ab = as.character(x),
cid = ab_cid(x),
name = ab_name(x, language = language),
group = ab_group(x, language = language),
atc = ab_atc(x),
atc_group1 = ab_atc_group1(x, language = language),
atc_group2 = ab_atc_group2(x, language = language),
tradenames = ab_tradenames(x),
loinc = ab_loinc(x),
ddd = list(oral = list(amount = ab_ddd(x, administration = "oral"),
units = ab_ddd_units(x, administration = "oral")),
iv = list(amount = ab_ddd(x, administration = "iv"),
units = ab_ddd_units(x, administration = "iv"))))
list(
ab = as.character(x),
cid = ab_cid(x),
name = ab_name(x, language = language),
group = ab_group(x, language = language),
atc = ab_atc(x),
atc_group1 = ab_atc_group1(x, language = language),
atc_group2 = ab_atc_group2(x, language = language),
tradenames = ab_tradenames(x),
loinc = ab_loinc(x),
ddd = list(
oral = list(
amount = ab_ddd(x, administration = "oral"),
units = ab_ddd_units(x, administration = "oral")
),
iv = list(
amount = ab_ddd(x, administration = "iv"),
units = ab_ddd_units(x, administration = "iv")
)
)
)
}
@@ -303,18 +321,18 @@ ab_info <- function(x, language = get_AMR_locale(), ...) {
ab_url <- function(x, open = FALSE, ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(open, allow_class = "logical", has_length = 1)
ab <- as.ab(x = x, ...)
atcs <- ab_atc(ab, only_first = TRUE)
u <- paste0("https://www.whocc.no/atc_ddd_index/?code=", atcs, "&showdescription=no")
u[is.na(atcs)] <- NA_character_
names(u) <- ab_name(ab)
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(atcs)]
if (length(NAs) > 0) {
warning_("in `ab_url()`: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
}
if (open == TRUE) {
if (length(u) > 1 & !is.na(u[1L])) {
warning_("in `ab_url()`: only the first URL will be opened, as `browseURL()` only suports one string.")
@@ -343,17 +361,17 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
meet_criteria(property, is_in = colnames(antibiotics), has_length = 1, ignore.case = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(snake_case, allow_class = "logical", has_length = 1, allow_NULL = TRUE)
x_deparsed <- deparse(substitute(data))
if (length(x_deparsed) > 1 || any(x_deparsed %unlike% "[a-z]+")) {
x_deparsed <- "your_data"
}
property <- tolower(property)
if (is.null(snake_case)) {
snake_case <- property == "name"
}
if (is.data.frame(data)) {
if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) {
df <- pm_select(data, ...)
@@ -370,44 +388,50 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
vars_ab <- as.ab(data, fast_mode = TRUE)
vars <- data[!is.na(vars_ab)]
}
x <- vapply(FUN.VALUE = character(1),
ab_property(vars, property = property, language = language),
function(x) {
if (property == "atc") {
# try to get the J-group
if (any(x %like% "^J")) {
x[x %like% "^J"][1L]
} else {
as.character(x[1L])
}
} else {
as.character(x[1L])
}
},
USE.NAMES = FALSE)
x <- vapply(
FUN.VALUE = character(1),
ab_property(vars, property = property, language = language),
function(x) {
if (property == "atc") {
# try to get the J-group
if (any(x %like% "^J")) {
x[x %like% "^J"][1L]
} else {
as.character(x[1L])
}
} else {
as.character(x[1L])
}
},
USE.NAMES = FALSE
)
if (any(x %in% c("", NA))) {
warning_("in `set_ab_names()`: no ", property, " found for column(s): ",
vector_and(vars[x %in% c("", NA)], sort = FALSE))
warning_(
"in `set_ab_names()`: no ", property, " found for column(s): ",
vector_and(vars[x %in% c("", NA)], sort = FALSE)
)
x[x %in% c("", NA)] <- vars[x %in% c("", NA)]
}
if (snake_case == TRUE) {
x <- tolower(gsub("[^a-zA-Z0-9]+", "_", x))
}
if (any(duplicated(x))) {
# very hacky way of adding the index to each duplicate
# so "Amoxicillin", "Amoxicillin", "Amoxicillin"
# will be "Amoxicillin", "Amoxicillin_2", "Amoxicillin_3"
invisible(lapply(unique(x),
function(u) {
dups <- which(x == u)
if (length(dups) > 1) {
# there are duplicates
dup_add_int <- dups[2:length(dups)]
x[dup_add_int] <<- paste0(x[dup_add_int], "_", c(2:length(dups)))
}
}))
invisible(lapply(
unique(x),
function(u) {
dups <- which(x == u)
if (length(dups) > 1) {
# there are duplicates
dup_add_int <- dups[2:length(dups)]
x[dup_add_int] <<- paste0(x[dup_add_int], "_", c(2:length(dups)))
}
}
))
}
if (is.data.frame(data)) {
colnames(data)[colnames(data) %in% vars] <- x
@@ -419,25 +443,24 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
}
ab_validate <- function(x, property, ...) {
check_dataset_integrity()
if (tryCatch(all(x[!is.na(x)] %in% AB_lookup$ab), error = function(e) FALSE)) {
# special case for ab_* functions where class is already <ab>
x <- AB_lookup[match(x, AB_lookup$ab), property, drop = TRUE]
} else {
# try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% antibiotics[1, property, drop = TRUE],
error = function(e) stop(e$message, call. = FALSE))
error = function(e) stop(e$message, call. = FALSE)
)
if (!all(x %in% AB_lookup[, property, drop = TRUE])) {
x <- as.ab(x, ...)
x <- AB_lookup[match(x, AB_lookup$ab), property, drop = TRUE]
}
}
if (property == "ab") {
return(set_clean_class(x, new_class = c("ab", "character")))
} else if (property == "cid") {

420
R/ab_selectors.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -24,7 +24,7 @@
# ==================================================================== #
#' Antibiotic Selectors
#'
#'
#' These functions allow for filtering rows and selecting columns based on antibiotic test results that are of a specific antibiotic class or group, without the need to define the columns or antibiotic abbreviations. In short, if you have a column name that resembles an antimicrobial agent, it will be picked up by any of these functions that matches its pharmaceutical class: "cefazolin", "CZO" and "J01DB04" will all be picked up by [cephalosporins()].
#' @param ab_class an antimicrobial class or a part of it, such as `"carba"` and `"carbapenems"`. The columns `group`, `atc_group1` and `atc_group2` of the [antibiotics] data set will be searched (case-insensitive) for this value.
#' @param filter an [expression] to be evaluated in the [antibiotics] data set, such as `name %like% "trim"`
@@ -33,12 +33,12 @@
#' @param ... ignored, only in place to allow future extensions
#' @details
#' These functions can be used in data set calls for selecting columns and filtering rows. They are heavily inspired by the [Tidyverse selection helpers][tidyselect::language] such as [`everything()`][tidyselect::everything()], but also work in base \R and not only in `dplyr` verbs. Nonetheless, they are very convenient to use with `dplyr` functions such as [`select()`][dplyr::select()], [`filter()`][dplyr::filter()] and [`summarise()`][dplyr::summarise()], see *Examples*.
#'
#' All columns in the data in which these functions are called will be searched for known antibiotic names, abbreviations, brand names, and codes (ATC, EARS-Net, WHO, etc.) according to the [antibiotics] data set. This means that a selector such as [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
#'
#'
#' All columns in the data in which these functions are called will be searched for known antibiotic names, abbreviations, brand names, and codes (ATC, EARS-Net, WHO, etc.) according to the [antibiotics] data set. This means that a selector such as [aminoglycosides()] will pick up column names like 'gen', 'genta', 'J01GB03', 'tobra', 'Tobracin', etc.
#'
#' The [ab_class()] function can be used to filter/select on a manually defined antibiotic class. It searches for results in the [antibiotics] data set within the columns `group`, `atc_group1` and `atc_group2`.
#' @section Full list of supported (antibiotic) classes:
#'
#'
#' `r paste0(" * ", na.omit(sapply(DEFINED_AB_GROUPS, function(ab) ifelse(tolower(gsub("^AB_", "", ab)) %in% ls(envir = asNamespace("AMR")), paste0("[", tolower(gsub("^AB_", "", ab)), "()] can select: \\cr ", vector_and(paste0(ab_name(eval(parse(text = ab), envir = asNamespace("AMR")), language = NULL, tolower = TRUE), " (", eval(parse(text = ab), envir = asNamespace("AMR")), ")"), quotes = FALSE, sort = TRUE)), character(0)), USE.NAMES = FALSE)), "\n", collapse = "")`
#' @rdname antibiotic_class_selectors
#' @name antibiotic_class_selectors
@@ -46,153 +46,144 @@
#' @export
#' @inheritSection AMR Reference Data Publicly Available
#' @examples
#' @examples
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#' example_isolates
#'
#'
#' # base R ------------------------------------------------------------------
#'
#'
#' # select columns 'IPM' (imipenem) and 'MEM' (meropenem)
#' example_isolates[, carbapenems()]
#'
#'
#' # select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB'
#' example_isolates[, c("mo", aminoglycosides())]
#'
#'
#' # select only antibiotic columns with DDDs for oral treatment
#' example_isolates[, administrable_per_os()]
#'
#'
#' # filter using any() or all()
#' example_isolates[any(carbapenems() == "R"), ]
#' subset(example_isolates, any(carbapenems() == "R"))
#'
#'
#' # filter on any or all results in the carbapenem columns (i.e., IPM, MEM):
#' example_isolates[any(carbapenems()), ]
#' example_isolates[all(carbapenems()), ]
#'
#'
#' # filter with multiple antibiotic selectors using c()
#' example_isolates[all(c(carbapenems(), aminoglycosides()) == "R"), ]
#'
#'
#' # filter + select in one go: get penicillins in carbapenems-resistant strains
#' example_isolates[any(carbapenems() == "R"), penicillins()]
#'
#'
#' # You can combine selectors with '&' to be more specific. For example,
#' # penicillins() would select benzylpenicillin ('peni G') and
#' # administrable_per_os() would select erythromycin. Yet, when combined these
#' # drugs are both omitted since benzylpenicillin is not administrable per os
#' # and erythromycin is not a penicillin:
#' example_isolates[, penicillins() & administrable_per_os()]
#'
#'
#' # ab_selector() applies a filter in the `antibiotics` data set and is thus very
#' # flexible. For instance, to select antibiotic columns with an oral DDD of at
#' # least 1 gram:
#' 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) %>%
#' 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")) %>%
#' group_by(ward) %>%
#' filter(mo_genus() %in% c("Escherichia", "Klebsiella")) %>%
#' group_by(ward) %>%
#' summarise(across(not_intrinsic_resistant(), resistance))
#'
#' }
#' if (require("dplyr")) {
#'
#'
#' # get susceptibility for antibiotics whose name contains "trim":
#' example_isolates %>%
#' filter(first_isolate()) %>%
#' group_by(ward) %>%
#' filter(first_isolate()) %>%
#' group_by(ward) %>%
#' summarise(across(ab_selector(name %like% "trim"), susceptibility))
#'
#' }
#' if (require("dplyr")) {
#'
#'
#' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
#' example_isolates %>%
#' example_isolates %>%
#' select(carbapenems())
#'
#' }
#' if (require("dplyr")) {
#'
#'
#' # this will select columns 'mo', 'AMK', 'GEN', 'KAN' and 'TOB':
#' example_isolates %>%
#' example_isolates %>%
#' select(mo, aminoglycosides())
#'
#' }
#' if (require("dplyr")) {
#'
#' # any() and all() work in dplyr's filter() too:
#' example_isolates %>%
#' filter(any(aminoglycosides() == "R"),
#' all(cephalosporins_2nd() == "R"))
#'
#'
#' # any() and all() work in dplyr's filter() too:
#' example_isolates %>%
#' filter(
#' any(aminoglycosides() == "R"),
#' all(cephalosporins_2nd() == "R")
#' )
#' }
#' if (require("dplyr")) {
#'
#' # also works with c():
#' example_isolates %>%
#'
#' # 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 %>%
#'
#' # 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 %>%
#' 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()) %>%
#' select(mo, glycopeptides()) %>%
#' example_isolates %>%
#' filter(mo_is_gram_positive()) %>%
#' select(mo, glycopeptides()) %>%
#' bug_drug_combinations() %>%
#' format()
#'
#' }
#' if (require("dplyr")) {
#'
#' data.frame(some_column = "some_value",
#' J01CA01 = "S") %>% # ATC code of ampicillin
#' select(penicillins()) # only the 'J01CA01' column will be selected
#'
#' data.frame(
#' some_column = "some_value",
#' J01CA01 = "S"
#' ) %>% # ATC code of ampicillin
#' 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")
#' z <- example_isolates %>% filter(if_all(carbapenems(), ~.x == "R"))
#' z <- example_isolates %>% filter(if_all(carbapenems(), ~ .x == "R"))
#' identical(x, y) && identical(y, z)
#' }
#' }
ab_class <- function(ab_class,
ab_class <- function(ab_class,
only_rsi_columns = FALSE,
only_treatable = TRUE,
...) {
@@ -205,30 +196,36 @@ ab_class <- function(ab_class,
#' @rdname antibiotic_class_selectors
#' @details The [ab_selector()] function can be used to internally filter the [antibiotics] data set on any results, see *Examples*. It allows for filtering on a (part of) a certain name, and/or a group name or even a minimum of DDDs for oral treatment. This function yields the highest flexibility, but is also the least user-friendly, since it requires a hard-coded filter to set.
#' @export
ab_selector <- function(filter,
ab_selector <- function(filter,
only_rsi_columns = FALSE,
only_treatable = TRUE,
...) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
# get_current_data() has to run each time, for cases where e.g., filter() and select() are used in same call
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "ab_selector")
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "ab_selector"
)
call <- substitute(filter)
agents <- tryCatch(AMR::antibiotics[which(eval(call, envir = AMR::antibiotics)), "ab", drop = TRUE],
error = function(e) stop_(e$message, call = -5))
error = function(e) stop_(e$message, call = -5)
)
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(function_name = "ab_selector",
agents = agents,
ab_group = NULL,
examples = "",
call = call)
message_agent_names(
function_name = "ab_selector",
agents = agents,
ab_group = NULL,
examples = "",
call = call
)
structure(unname(agents),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
#' @rdname antibiotic_class_selectors
@@ -419,24 +416,34 @@ administrable_per_os <- function(only_rsi_columns = FALSE, ...) {
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_per_os")
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_per_os"
)
agents_all <- antibiotics[which(!is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$oral_ddd)), "ab", drop = TRUE]
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(function_name = "administrable_per_os",
agents = agents,
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),
")"))
message_agent_names(
function_name = "administrable_per_os",
agents = agents,
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
),
")"
)
)
structure(unname(agents),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
#' @rdname antibiotic_class_selectors
@@ -447,17 +454,22 @@ administrable_iv <- function(only_rsi_columns = FALSE, ...) {
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_iv")
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "administrable_iv"
)
agents_all <- antibiotics[which(!is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
agents <- antibiotics[which(antibiotics$ab %in% ab_in_data & !is.na(antibiotics$iv_ddd)), "ab", drop = TRUE]
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(function_name = "administrable_iv",
agents = agents,
ab_group = "administrable_iv",
examples = "")
message_agent_names(
function_name = "administrable_iv",
agents = agents,
ab_group = "administrable_iv",
examples = ""
)
structure(unname(agents),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
#' @rdname antibiotic_class_selectors
@@ -470,35 +482,47 @@ not_intrinsic_resistant <- function(only_rsi_columns = FALSE, col_mo = NULL, ver
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -2)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = "not_intrinsic_resistant")
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
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),
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))
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
)
}
),
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)])]
if (length(agents) > 0 &&
message_not_thrown_before("not_intrinsic_resistant", sort(agents))) {
message_not_thrown_before("not_intrinsic_resistant", sort(agents))) {
agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
message_("For `not_intrinsic_resistant()` removing ",
ifelse(length(agents) == 1, "column ", "columns "),
vector_and(agents_formatted, quotes = FALSE, sort = FALSE))
message_(
"For `not_intrinsic_resistant()` removing ",
ifelse(length(agents) == 1, "column ", "columns "),
vector_and(agents_formatted, quotes = FALSE, sort = FALSE)
)
}
vars_df_R <- names(vars_df_R)[which(!vars_df_R)]
# find columns that are abx, but also intrinsic R
out <- unname(intersect(ab_in_data, vars_df_R))
structure(out,
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
ab_select_exec <- function(function_name,
@@ -509,61 +533,74 @@ ab_select_exec <- function(function_name,
# but it only takes a couple of milliseconds
vars_df <- get_current_data(arg_name = NA, call = -3)
# to improve speed, get_column_abx() will only run once when e.g. in a select or group call
ab_in_data <- get_column_abx(vars_df, info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = function_name)
ab_in_data <- get_column_abx(vars_df,
info = FALSE, only_rsi_columns = only_rsi_columns,
sort = FALSE, fn = function_name
)
# untreatable drugs
if (only_treatable == TRUE) {
untreatable <- antibiotics[which(antibiotics$name %like% "-high|EDTA|polysorbate|macromethod|screening|/nacubactam"), "ab", drop = TRUE]
if (any(untreatable %in% names(ab_in_data))) {
if (message_not_thrown_before(function_name, "ab_class", "untreatable", entire_session = TRUE)) {
warning_("in `", function_name, "()`: some agents 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), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
"This warning will be shown once per session.")
warning_(
"in `", function_name, "()`: some agents 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
), ". They can be included using `", function_name, "(only_treatable = FALSE)`. ",
"This warning will be shown once per session."
)
}
ab_in_data <- ab_in_data[!names(ab_in_data) %in% untreatable]
}
}
if (length(ab_in_data) == 0) {
message_("No antimicrobial agents found in the data.")
return(NULL)
}
if (is.null(ab_class_args)) {
# their upper case equivalent are vectors with class <ab>, created in data-raw/pre-commit-hook.R
# their upper case equivalent are vectors with class <ab>, created in data-raw/_pre_commit_hook.R
# carbapenems() gets its codes from AMR:::AB_CARBAPENEMS
abx <- get(paste0("AB_", toupper(function_name)), envir = asNamespace("AMR"))
abx <- get(paste0("AB_", toupper(function_name)), envir = asNamespace("AMR"))
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), ")")
tolower = TRUE,
language = NULL
),
quotes = FALSE
), ")")
} else {
# this for the 'manual' ab_class() function
abx <- subset(AB_lookup,
group %like% ab_class_args |
atc_group1 %like% ab_class_args |
atc_group2 %like% ab_class_args)$ab
abx <- subset(
AB_lookup,
group %like% ab_class_args |
atc_group1 %like% ab_class_args |
atc_group2 %like% ab_class_args
)$ab
ab_group <- find_ab_group(ab_class_args)
function_name <- "ab_class"
examples <- paste0(" (such as ", find_ab_names(ab_class_args, 2), ")")
}
# get the columns with a group names in the chosen ab class
agents <- ab_in_data[names(ab_in_data) %in% abx]
message_agent_names(function_name = function_name,
agents = agents,
ab_group = ab_group,
examples = examples,
ab_class_args = ab_class_args)
message_agent_names(
function_name = function_name,
agents = agents,
ab_group = ab_group,
examples = examples,
ab_class_args = ab_class_args
)
structure(unname(agents),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
#' @method c ab_selector
@@ -571,7 +608,8 @@ ab_select_exec <- function(function_name,
#' @noRd
c.ab_selector <- function(...) {
structure(unlist(lapply(list(...), as.character)),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
all_any_ab_selector <- function(type, ..., na.rm = TRUE) {
@@ -583,18 +621,20 @@ all_any_ab_selector <- function(type, ..., na.rm = TRUE) {
}
cols_ab <- cols_ab[!cols_ab %in% result]
df <- get_current_data(arg_name = NA, call = -3)
if (type == "all") {
scope_fn <- all
} else {
scope_fn <- any
}
x_transposed <- as.list(as.data.frame(t(df[, cols_ab, drop = FALSE]), stringsAsFactors = FALSE))
vapply(FUN.VALUE = logical(1),
X = x_transposed,
FUN = function(y) scope_fn(y %in% result, na.rm = na.rm),
USE.NAMES = FALSE)
vapply(
FUN.VALUE = logical(1),
X = x_transposed,
FUN = function(y) scope_fn(y %in% result, na.rm = na.rm),
USE.NAMES = FALSE
)
}
#' @method all ab_selector
@@ -654,12 +694,15 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
} else {
type <- "all"
if (length(e1) > 1) {
message_("Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
". Wrap around `all()` or `any()` to prevent this note.")
message_(
"Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
". Wrap around `all()` or `any()` to prevent this note."
)
}
}
structure(all_any_ab_selector(type = type, e1, e2),
class = c("ab_selector_any_all", "logical"))
class = c("ab_selector_any_all", "logical")
)
}
#' @method != ab_selector
@@ -676,15 +719,18 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
} else {
type <- "all"
if (length(e1) > 1) {
message_("Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
". Wrap around `all()` or `any()` to prevent this note.")
message_(
"Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
". Wrap around `all()` or `any()` to prevent this note."
)
}
}
# this is `!=`, so turn around the values
rsi <- c("R", "S", "I")
e2 <- rsi[rsi != e2]
structure(all_any_ab_selector(type = type, e1, e2),
class = c("ab_selector_any_all", "logical"))
class = c("ab_selector_any_all", "logical")
)
}
#' @method & ab_selector
@@ -694,7 +740,8 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
# this is only required for base R, since tidyselect has already implemented this
# e.g., for: example_isolates[, penicillins() & administrable_per_os()]
structure(intersect(unclass(e1), unclass(e2)),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
#' @method | ab_selector
#' @export
@@ -703,7 +750,8 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
# this is only required for base R, since tidyselect has already implemented this
# e.g., for: example_isolates[, penicillins() | administrable_per_os()]
structure(union(unclass(e1), unclass(e2)),
class = c("ab_selector", "character"))
class = c("ab_selector", "character")
)
}
is_any <- function(el1) {
@@ -720,38 +768,40 @@ is_all <- function(el1) {
find_ab_group <- function(ab_class_args) {
ab_class_args <- gsub("[^a-zA-Z0-9]", ".*", ab_class_args)
AB_lookup %pm>%
subset(group %like% ab_class_args |
atc_group1 %like% ab_class_args |
atc_group2 %like% ab_class_args) %pm>%
subset(group %like% ab_class_args |
atc_group1 %like% ab_class_args |
atc_group2 %like% ab_class_args) %pm>%
pm_pull(group) %pm>%
unique() %pm>%
tolower() %pm>%
sort() %pm>%
sort() %pm>%
paste(collapse = "/")
}
find_ab_names <- function(ab_group, n = 3) {
ab_group <- gsub("[^a-zA-Z|0-9]", ".*", ab_group)
# try popular first, they have DDDs
drugs <- antibiotics[which((!is.na(antibiotics$iv_ddd) | !is.na(antibiotics$oral_ddd)) &
antibiotics$name %unlike% " " &
antibiotics$group %like% ab_group &
antibiotics$ab %unlike% "[0-9]$"), ]$name
antibiotics$name %unlike% " " &
antibiotics$group %like% ab_group &
antibiotics$ab %unlike% "[0-9]$"), ]$name
if (length(drugs) < n) {
# now try it all
drugs <- antibiotics[which((antibiotics$group %like% ab_group |
antibiotics$atc_group1 %like% ab_group |
antibiotics$atc_group2 %like% ab_group) &
antibiotics$ab %unlike% "[0-9]$"), ]$name
antibiotics$atc_group1 %like% ab_group |
antibiotics$atc_group2 %like% ab_group) &
antibiotics$ab %unlike% "[0-9]$"), ]$name
}
if (length(drugs) == 0) {
return("??")
}
vector_or(ab_name(sample(drugs, size = min(n, length(drugs)), replace = FALSE),
tolower = TRUE,
language = NULL),
quotes = FALSE)
tolower = TRUE,
language = NULL
),
quotes = FALSE
)
}
message_agent_names <- function(function_name, agents, ab_group = NULL, examples = "", ab_class_args = NULL, call = NULL) {
@@ -771,15 +821,19 @@ message_agent_names <- function(function_name, agents, ab_group = NULL, examples
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
message_("For `", function_name, "(",
ifelse(function_name == "ab_class",
paste0("\"", ab_class_args, "\""),
ifelse(!is.null(call),
paste0(deparse(call), collapse = " "),
"")),
")` using ",
ifelse(length(agents) == 1, "column ", "columns "),
vector_and(agents_formatted, quotes = FALSE, sort = FALSE))
message_(
"For `", function_name, "(",
ifelse(function_name == "ab_class",
paste0("\"", ab_class_args, "\""),
ifelse(!is.null(call),
paste0(deparse(call), collapse = " "),
""
)
),
")` using ",
ifelse(length(agents) == 1, "column ", "columns "),
vector_and(agents_formatted, quotes = FALSE, sort = FALSE)
)
}
}
}

74
R/age.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -32,7 +32,7 @@
#' @param na.rm a [logical] to indicate whether missing values should be removed
#' @param ... arguments passed on to [as.POSIXlt()], such as `origin`
#' @details Ages below 0 will be returned as `NA` with a warning. Ages above 120 will only give a warning.
#'
#'
#' This function vectorises over both `x` and `reference`, meaning that either can have a length of 1 while the other argument has a larger length.
#' @return An [integer] (no decimals) if `exact = FALSE`, a [double] (with decimals) otherwise
#' @seealso To split ages into groups, use the [age_groups()] function.
@@ -40,13 +40,13 @@
#' @examples
#' # 10 random pre-Y2K birth dates
#' df <- data.frame(birth_date = as.Date("2000-01-01") - runif(10) * 25000)
#'
#'
#' # add ages
#' df$age <- age(df$birth_date)
#'
#'
#' # add exact ages
#' df$age_exact <- age(df$birth_date, exact = TRUE)
#'
#'
#' # add age at millenium switch
#' df$age_at_y2k <- age(df$birth_date, "2000-01-01")
#'
@@ -56,7 +56,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
meet_criteria(reference, allow_class = c("character", "Date", "POSIXt"))
meet_criteria(exact, allow_class = "logical", has_length = 1)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (length(x) != length(reference)) {
if (length(x) == 1) {
x <- rep(x, length(reference))
@@ -68,26 +68,32 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
}
x <- as.POSIXlt(x, ...)
reference <- as.POSIXlt(reference, ...)
# from https://stackoverflow.com/a/25450756/4575331
years_gap <- reference$year - x$year
ages <- ifelse(reference$mon < x$mon | (reference$mon == x$mon & reference$mday < x$mday),
as.integer(years_gap - 1),
as.integer(years_gap))
as.integer(years_gap - 1),
as.integer(years_gap)
)
# 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),
as.Date(x_in_reference_year),
units = "days"))
n_days_x_rest <- as.double(difftime(as.Date(reference),
as.Date(x_in_reference_year),
units = "days"
))
# get numbers of days the years of `reference` has for a reliable denominator
n_days_reference_year <- as.POSIXlt(paste0(format(as.Date(reference), "%Y"), "-12-31"),
format = "%Y-%m-%d")$yday + 1
format = "%Y-%m-%d"
)$yday + 1
# add decimal parts of year
mod <- n_days_x_rest / n_days_reference_year
# negative mods are cases where `x_in_reference_year` > `reference` - so 'add' a year
@@ -95,7 +101,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
# and finally add to ages
ages <- ages + mod
}
if (any(ages < 0, na.rm = TRUE)) {
ages[!is.na(ages) & ages < 0] <- NA
warning_("in `age()`: NAs introduced for ages below 0.")
@@ -103,11 +109,11 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
if (any(ages > 120, na.rm = TRUE)) {
warning_("in `age()`: some ages are above 120.")
}
if (isTRUE(na.rm)) {
ages <- ages[!is.na(ages)]
}
if (exact == TRUE) {
as.double(ages)
} else {
@@ -122,7 +128,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
#' @param split_at values to split `x` at, defaults to age groups 0-11, 12-24, 25-54, 55-74 and 75+. See *Details*.
#' @param na.rm a [logical] to indicate whether missing values should be removed
#' @details To split ages, the input for the `split_at` argument can be:
#'
#'
#' * A [numeric] vector. A value of e.g. `c(10, 20)` will split `x` on 0-9, 10-19 and 20+. A value of only `50` will split `x` on 0-49 and 50+.
#' The default is to split on young children (0-11), youth (12-24), young adults (25-54), middle-aged adults (55-74) and elderly (75+).
#' * A character:
@@ -163,17 +169,19 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
#' filter(mo == as.mo("Escherichia coli")) %>%
#' group_by(age_group = age_groups(age)) %>%
#' select(age_group, CIP) %>%
#' ggplot_rsi(x = "age_group",
#' minimum = 0,
#' x.title = "Age Group",
#' title = "Ciprofloxacin resistance per age group")
#' ggplot_rsi(
#' x = "age_group",
#' minimum = 0,
#' x.title = "Age Group",
#' title = "Ciprofloxacin resistance per age group"
#' )
#' }
#' }
age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
meet_criteria(x, allow_class = c("numeric", "integer"), is_positive_or_zero = TRUE, is_finite = TRUE)
meet_criteria(split_at, allow_class = c("numeric", "integer", "character"), is_positive_or_zero = TRUE, is_finite = TRUE)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (any(x < 0, na.rm = TRUE)) {
x[x < 0] <- NA
warning_("in `age_groups()`: NAs introduced for ages below 0.")
@@ -183,7 +191,7 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
if (split_at %like% "^(child|kid|junior)") {
split_at <- c(0, 1, 2, 4, 6, 13, 18)
} else if (split_at %like% "^(elder|senior)") {
split_at <- c(65, 75, 85)
split_at <- c(65, 75, 85)
} else if (split_at %like% "^five") {
split_at <- 1:20 * 5
} else if (split_at %like% "^ten") {
@@ -197,7 +205,7 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
}
split_at <- split_at[!is.na(split_at)]
stop_if(length(split_at) == 1, "invalid value for `split_at`") # only 0 is available
# turn input values to 'split_at' indices
y <- x
lbls <- split_at
@@ -206,15 +214,15 @@ age_groups <- function(x, split_at = c(12, 25, 55, 75), na.rm = FALSE) {
# create labels
lbls[i - 1] <- paste0(unique(c(split_at[i - 1], split_at[i] - 1)), collapse = "-")
}
# last category
lbls[length(lbls)] <- paste0(split_at[length(split_at)], "+")
agegroups <- factor(lbls[y], levels = lbls, ordered = TRUE)
if (isTRUE(na.rm)) {
agegroups <- agegroups[!is.na(agegroups)]
}
agegroups
}

8
R/amr.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -28,9 +28,9 @@
#' Welcome to the `AMR` package.
#' @details
#' `AMR` is a free, open-source and independent \R package to simplify the analysis and prediction of Antimicrobial Resistance (AMR) and to work with microbial and antimicrobial data and properties, by using evidence-based methods. Our aim is to provide a standard for clean and reproducible antimicrobial resistance data analysis, that can therefore empower epidemiological analyses to continuously enable surveillance and treatment evaluation in any setting.
#'
#'
#' After installing this package, \R knows `r format_included_data_number(microorganisms)` distinct microbial species and all `r format_included_data_number(rbind(antibiotics[, "atc", drop = FALSE], antivirals[, "atc", drop = FALSE]))` antibiotic, antimycotic and antiviral drugs by name and code (including ATC, EARS-NET, LOINC and SNOMED CT), and knows all about valid R/SI and MIC values. It supports any data format, including WHONET/EARS-Net data.
#'
#'
#' This package is fully independent of any other \R package and works on Windows, macOS and Linux with all versions of \R since R-3.0.0 (April 2013). It was designed to work in any setting, including those with very limited resources. It was created for both routine data analysis and academic research at the Faculty of Medical Sciences of the University of Groningen, in collaboration with non-profit organisations Certe Medical Diagnostics and Advice and University Medical Center Groningen. This \R package is actively maintained and free software; you can freely use and distribute it for both personal and commercial (but not patent) purposes under the terms of the GNU General Public License version 2.0 (GPL-2), as published by the Free Software Foundation.
#'
#' This package can be used for:
@@ -50,7 +50,7 @@
#' - Getting LOINC codes of an antibiotic, or getting properties of an antibiotic based on a LOINC code
#' - Machine reading the EUCAST and CLSI guidelines from 2011-2020 to translate MIC values and disk diffusion diameters to R/SI
#' - Principal component analysis for AMR
#'
#'
#' @section Reference Data Publicly Available:
#' All data sets in this `AMR` package (about microorganisms, antibiotics, R/SI interpretation, EUCAST rules, etc.) are publicly and freely available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. We also provide tab-separated plain text files that are machine-readable and suitable for input in any software program, such as laboratory information systems. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @section Contact Us:

57
R/atc_online.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -34,7 +34,7 @@
#' @param ... arguments to pass on to `atc_property`
#' @details
#' Options for argument `administration`:
#'
#'
#' - `"Implant"` = Implant
#' - `"Inhal"` = Inhalation
#' - `"Instill"` = Instillation
@@ -47,7 +47,7 @@
#' - `"V"` = vaginal
#'
#' Abbreviations of return values when using `property = "U"` (unit):
#'
#'
#' - `"g"` = gram
#' - `"mg"` = milligram
#' - `"mcg"` = microgram
@@ -56,18 +56,18 @@
#' - `"MU"` = million units
#' - `"mmol"` = millimole
#' - `"ml"` = millilitre (e.g. eyedrops)
#'
#'
#' **N.B. This function requires an internet connection and only works if the following packages are installed: `curl`, `rvest`, `xml2`.**
#' @export
#' @rdname atc_online
#' @source <https://www.whocc.no/atc_ddd_alterations__cumulative/ddd_alterations/abbrevations/>
#' @examples
#' \donttest{
#' if (requireNamespace("curl") && requireNamespace("rvest") && requireNamespace("xml2")) {
#' if (requireNamespace("curl") && requireNamespace("rvest") && requireNamespace("xml2")) {
#' # oral DDD (Defined Daily Dose) of amoxicillin
#' atc_online_property("J01CA04", "DDD", "O")
#' atc_online_ddd(ab_atc("amox"))
#'
#'
#' # parenteral DDD (Defined Daily Dose) of amoxicillin
#' atc_online_property("J01CA04", "DDD", "P")
#'
@@ -84,7 +84,7 @@ atc_online_property <- function(atc_code,
meet_criteria(administration, allow_class = "character", has_length = 1)
meet_criteria(url, allow_class = "character", has_length = 1, looks_like = "https?://")
meet_criteria(url_vet, allow_class = "character", has_length = 1, looks_like = "https?://")
has_internet <- import_fn("has_internet", "curl")
html_attr <- import_fn("html_attr", "rvest")
html_children <- import_fn("html_children", "rvest")
@@ -93,20 +93,21 @@ atc_online_property <- function(atc_code,
html_table <- import_fn("html_table", "rvest")
html_text <- import_fn("html_text", "rvest")
read_html <- import_fn("read_html", "xml2")
check_dataset_integrity()
if (!all(atc_code %in% unlist(antibiotics$atc))) {
atc_code <- as.character(ab_atc(atc_code, only_first = TRUE))
}
if (!has_internet()) {
message_("There appears to be no internet connection, returning NA.",
add_fn = font_red,
as_note = FALSE)
add_fn = font_red,
as_note = FALSE
)
return(rep(NA, length(atc_code)))
}
property <- tolower(property)
# also allow unit as property
if (property == "unit") {
@@ -119,12 +120,11 @@ atc_online_property <- function(atc_code,
} else {
returnvalue <- rep(NA_character_, length(atc_code))
}
progress <- progress_ticker(n = length(atc_code), 3)
on.exit(close(progress))
for (i in seq_len(length(atc_code))) {
progress$tick()
if (atc_code[i] %like% "^Q") {
@@ -134,19 +134,20 @@ atc_online_property <- function(atc_code,
atc_url <- url
}
atc_url <- sub("%s", atc_code[i], atc_url, fixed = TRUE)
if (property == "groups") {
out <- tryCatch(
read_html(atc_url) %pm>%
html_node("#content") %pm>%
html_children() %pm>%
html_node("a"),
error = function(e) NULL)
html_node("a"),
error = function(e) NULL
)
if (is.null(out)) {
message_("Connection to ", atc_url, " failed.")
return(rep(NA, length(atc_code)))
}
# get URLS of items
hrefs <- out %pm>% html_attr("href")
# get text of items
@@ -156,28 +157,28 @@ atc_online_property <- function(atc_code,
# last one is antibiotics, skip it
texts <- texts[seq_len(length(texts)) - 1]
returnvalue <- c(list(texts), returnvalue)
} else {
out <- tryCatch(
read_html(atc_url) %pm>%
html_nodes("table") %pm>%
html_table(header = TRUE) %pm>%
as.data.frame(stringsAsFactors = FALSE),
error = function(e) NULL)
as.data.frame(stringsAsFactors = FALSE),
error = function(e) NULL
)
if (is.null(out)) {
message_("Connection to ", atc_url, " failed.")
return(rep(NA, length(atc_code)))
}
# case insensitive column names
colnames(out) <- gsub("^atc.*", "atc", tolower(colnames(out)))
if (length(out) == 0) {
warning_("in `atc_online_property()`: ATC not found: ", atc_code[i], ". Please check ", atc_url, ".")
returnvalue[i] <- NA
next
}
if (property %in% c("atc", "name")) {
# ATC and name are only in first row
returnvalue[i] <- out[1, property, drop = TRUE]
@@ -195,11 +196,11 @@ atc_online_property <- function(atc_code,
}
}
}
if (property == "groups" & length(returnvalue) == 1) {
returnvalue <- returnvalue[[1]]
}
returnvalue
}

48
R/availability.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -44,50 +44,52 @@
availability <- function(tbl, width = NULL) {
meet_criteria(tbl, allow_class = "data.frame")
meet_criteria(width, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
tbl <- as.data.frame(tbl, stringsAsFactors = FALSE)
x <- vapply(FUN.VALUE = double(1), tbl, function(x) {
1 - sum(is.na(x)) / length(x)
1 - sum(is.na(x)) / length(x)
})
n <- vapply(FUN.VALUE = double(1), tbl, function(x) length(x[!is.na(x)]))
R <- vapply(FUN.VALUE = double(1), tbl, function(x) ifelse(is.rsi(x), resistance(x, minimum = 0), NA_real_))
R_print <- character(length(R))
R_print[!is.na(R)] <- percentage(R[!is.na(R)])
R_print[is.na(R)] <- ""
if (is.null(width)) {
width <- options()$width -
(max(nchar(colnames(tbl))) +
# count col
8 +
# available % column
10 +
# resistant % column
10 +
# extra margin
5)
# count col
8 +
# available % column
10 +
# resistant % column
10 +
# extra margin
5)
width <- width / 2
}
if (length(R[is.na(R)]) == ncol(tbl)) {
width <- width * 2 + 10
}
x_chars_R <- strrep("#", round(width * R, digits = 2))
x_chars_SI <- strrep("-", width - nchar(x_chars_R))
vis_resistance <- paste0("|", x_chars_R, x_chars_SI, "|")
vis_resistance[is.na(R)] <- ""
x_chars <- strrep("#", round(x, digits = 2) / (1 / width))
x_chars_empty <- strrep("-", width - nchar(x_chars))
df <- data.frame(count = n,
available = percentage(x),
visual_availabilty = paste0("|", x_chars, x_chars_empty, "|"),
resistant = R_print,
visual_resistance = vis_resistance,
stringsAsFactors = FALSE)
df <- data.frame(
count = n,
available = percentage(x),
visual_availabilty = paste0("|", x_chars, x_chars_empty, "|"),
resistant = R_print,
visual_resistance = vis_resistance,
stringsAsFactors = FALSE
)
if (length(R[is.na(R)]) == ncol(tbl)) {
df[, 1:3, drop = FALSE]
} else {

197
R/bug_drug_combinations.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -24,39 +24,44 @@
# ==================================================================== #
#' Determine Bug-Drug Combinations
#'
#'
#' Determine antimicrobial resistance (AMR) of all bug-drug combinations in your data set where at least 30 (default) isolates are available per species. Use [format()] on the result to prettify it to a publishable/printable format, see *Examples*.
#' @inheritParams eucast_rules
#' @param combine_IR a [logical] to indicate whether values R and I should be summed
#' @param add_ab_group a [logical] to indicate where the group of the antimicrobials must be included as a first column
#' @param remove_intrinsic_resistant [logical] to indicate that rows and columns with 100% resistance for all tested antimicrobials must be removed from the table
#' @param FUN the function to call on the `mo` column to transform the microorganism codes, defaults to [mo_shortname()]
#' @param FUN the function to call on the `mo` column to transform the microorganism codes, defaults to [mo_shortname()]
#' @param translate_ab a [character] of length 1 containing column names of the [antibiotics] data set
#' @param ... arguments passed on to `FUN`
#' @inheritParams rsi_df
#' @inheritParams base::formatC
#' @details The function [format()] calculates the resistance per bug-drug combination. Use `combine_IR = FALSE` (default) to test R vs. S+I and `combine_IR = TRUE` to test R+I vs. S.
#' @details The function [format()] calculates the resistance per bug-drug combination. Use `combine_IR = FALSE` (default) to test R vs. S+I and `combine_IR = TRUE` to test R+I vs. S.
#' @export
#' @rdname bug_drug_combinations
#' @return The function [bug_drug_combinations()] returns a [data.frame] with columns "mo", "ab", "S", "I", "R" and "total".
#' @source \strong{M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition}, 2014, *Clinical and Laboratory Standards Institute (CLSI)*. <https://clsi.org/standards/products/microbiology/documents/m39/>.
#' @examples
#' @examples
#' \donttest{
#' x <- bug_drug_combinations(example_isolates)
#' head(x)
#' format(x, translate_ab = "name (atc)")
#'
#'
#' # Use FUN to change to transformation of microorganism codes
#' bug_drug_combinations(example_isolates,
#' FUN = mo_gramstain)
#'
#' bug_drug_combinations(example_isolates,
#' FUN = function(x) ifelse(x == as.mo("Escherichia coli"),
#' "E. coli",
#' "Others"))
#' FUN = mo_gramstain
#' )
#'
#' bug_drug_combinations(example_isolates,
#' FUN = function(x) {
#' ifelse(x == as.mo("Escherichia coli"),
#' "E. coli",
#' "Others"
#' )
#' }
#' )
#' }
bug_drug_combinations <- function(x,
col_mo = NULL,
bug_drug_combinations <- function(x,
col_mo = NULL,
FUN = mo_shortname,
...) {
meet_criteria(x, allow_class = "data.frame", contains_column_class = "rsi")
@@ -71,13 +76,13 @@ bug_drug_combinations <- function(x,
} else {
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found")
}
x.bak <- x
x <- as.data.frame(x, stringsAsFactors = FALSE)
x[, col_mo] <- FUN(x[, col_mo, drop = TRUE], ...)
unique_mo <- sort(unique(x[, col_mo, drop = TRUE]))
# select only groups and antibiotics
if (is_null_or_grouped_tbl(x.bak)) {
data_has_groups <- TRUE
@@ -87,21 +92,23 @@ bug_drug_combinations <- function(x,
data_has_groups <- FALSE
x <- x[, c(col_mo, names(which(vapply(FUN.VALUE = logical(1), x, is.rsi)))), drop = FALSE]
}
run_it <- function(x) {
out <- data.frame(mo = character(0),
ab = character(0),
S = integer(0),
I = integer(0),
R = integer(0),
total = integer(0),
stringsAsFactors = FALSE)
out <- data.frame(
mo = character(0),
ab = character(0),
S = integer(0),
I = integer(0),
R = integer(0),
total = integer(0),
stringsAsFactors = FALSE
)
if (data_has_groups) {
group_values <- unique(x[, which(colnames(x) %in% groups), drop = FALSE])
rownames(group_values) <- NULL
x <- x[, which(!colnames(x) %in% groups), drop = FALSE]
}
for (i in seq_len(length(unique_mo))) {
# filter on MO group and only select R/SI columns
x_mo_filter <- x[which(x[, col_mo, drop = TRUE] == unique_mo[i]), names(which(vapply(FUN.VALUE = logical(1), x, is.rsi))), drop = FALSE]
@@ -111,18 +118,21 @@ bug_drug_combinations <- function(x,
data.frame(S = m["S", ], I = m["I", ], R = m["R", ], stringsAsFactors = FALSE)
})
merged <- do.call(rbind, pivot)
out_group <- data.frame(mo = rep(unique_mo[i], NROW(merged)),
ab = rownames(merged),
S = merged$S,
I = merged$I,
R = merged$R,
total = merged$S + merged$I + merged$R,
stringsAsFactors = FALSE)
out_group <- data.frame(
mo = rep(unique_mo[i], NROW(merged)),
ab = rownames(merged),
S = merged$S,
I = merged$I,
R = merged$R,
total = merged$S + merged$I + merged$R,
stringsAsFactors = FALSE
)
if (data_has_groups) {
if (nrow(group_values) < nrow(out_group)) {
# repeat group_values for the number of rows in out_group
repeated <- rep(seq_len(nrow(group_values)),
each = nrow(out_group) / nrow(group_values))
each = nrow(out_group) / nrow(group_values)
)
group_values <- group_values[repeated, , drop = FALSE]
}
out_group <- cbind(group_values, out_group)
@@ -141,7 +151,7 @@ bug_drug_combinations <- function(x,
}
res
}
if (data_has_groups) {
out <- apply_group(x, "run_it", groups)
} else {
@@ -176,27 +186,31 @@ format.bug_drug_combinations <- function(x,
meet_criteria(remove_intrinsic_resistant, allow_class = "logical", has_length = 1)
meet_criteria(decimal.mark, allow_class = "character", has_length = 1)
meet_criteria(big.mark, allow_class = "character", has_length = 1)
x.bak <- x
if (inherits(x, "grouped")) {
# bug_drug_combinations() has been run on groups, so de-group here
warning_("in `format()`: formatting the output of `bug_drug_combinations()` does not support grouped variables, they were ignored")
x <- as.data.frame(x, stringsAsFactors = FALSE)
idx <- split(seq_len(nrow(x)), paste0(x$mo, "%%", x$ab))
x <- data.frame(mo = gsub("(.*)%%(.*)", "\\1", names(idx)),
ab = gsub("(.*)%%(.*)", "\\2", names(idx)),
S = sapply(idx, function(i) sum(x$S[i], na.rm = TRUE)),
I = sapply(idx, function(i) sum(x$I[i], na.rm = TRUE)),
R = sapply(idx, function(i) sum(x$R[i], na.rm = TRUE)),
total = sapply(idx, function(i) sum(x$S[i], na.rm = TRUE) +
sum(x$I[i], na.rm = TRUE) +
sum(x$R[i], na.rm = TRUE)),
stringsAsFactors = FALSE)
x <- data.frame(
mo = gsub("(.*)%%(.*)", "\\1", names(idx)),
ab = gsub("(.*)%%(.*)", "\\2", names(idx)),
S = sapply(idx, function(i) sum(x$S[i], na.rm = TRUE)),
I = sapply(idx, function(i) sum(x$I[i], na.rm = TRUE)),
R = sapply(idx, function(i) sum(x$R[i], na.rm = TRUE)),
total = sapply(idx, function(i) {
sum(x$S[i], na.rm = TRUE) +
sum(x$I[i], na.rm = TRUE) +
sum(x$R[i], na.rm = TRUE)
}),
stringsAsFactors = FALSE
)
}
x <- as.data.frame(x, stringsAsFactors = FALSE)
x <- subset(x, total >= minimum)
if (remove_intrinsic_resistant == TRUE) {
x <- subset(x, R != total)
}
@@ -205,7 +219,7 @@ format.bug_drug_combinations <- function(x,
} else {
x$isolates <- x$R + x$I
}
give_ab_name <- function(ab, format, language) {
format <- tolower(format)
ab_txt <- rep(format, length(ab))
@@ -221,15 +235,16 @@ format.bug_drug_combinations <- function(x,
}
ab_txt
}
remove_NAs <- function(.data) {
cols <- colnames(.data)
.data <- as.data.frame(lapply(.data, function(x) ifelse(is.na(x), "", x)),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
colnames(.data) <- cols
.data
}
create_var <- function(.data, ...) {
dots <- list(...)
for (i in seq_len(length(dots))) {
@@ -237,66 +252,74 @@ format.bug_drug_combinations <- function(x,
}
.data
}
y <- x %pm>%
create_var(ab = as.ab(x$ab),
ab_txt = give_ab_name(ab = x$ab, format = translate_ab, language = language)) %pm>%
pm_group_by(ab, ab_txt, mo) %pm>%
pm_summarise(isolates = sum(isolates, na.rm = TRUE),
total = sum(total, na.rm = TRUE)) %pm>%
create_var(
ab = as.ab(x$ab),
ab_txt = give_ab_name(ab = x$ab, format = translate_ab, language = language)
) %pm>%
pm_group_by(ab, ab_txt, mo) %pm>%
pm_summarise(
isolates = sum(isolates, na.rm = TRUE),
total = sum(total, na.rm = TRUE)
) %pm>%
pm_ungroup()
y <- y %pm>%
create_var(txt = paste0(percentage(y$isolates / y$total, decimal.mark = decimal.mark, big.mark = big.mark),
" (", trimws(format(y$isolates, big.mark = big.mark)), "/",
trimws(format(y$total, big.mark = big.mark)), ")")) %pm>%
y <- y %pm>%
create_var(txt = paste0(
percentage(y$isolates / y$total, decimal.mark = decimal.mark, big.mark = big.mark),
" (", trimws(format(y$isolates, big.mark = big.mark)), "/",
trimws(format(y$total, big.mark = big.mark)), ")"
)) %pm>%
pm_select(ab, ab_txt, mo, txt) %pm>%
pm_arrange(mo)
# replace tidyr::pivot_wider() from here
for (i in unique(y$mo)) {
mo_group <- y[which(y$mo == i), c("ab", "txt"), drop = FALSE]
colnames(mo_group) <- c("ab", i)
rownames(mo_group) <- NULL
y <- y %pm>%
y <- y %pm>%
pm_left_join(mo_group, by = "ab")
}
y <- y %pm>%
pm_distinct(ab, .keep_all = TRUE) %pm>%
pm_select(-mo, -txt) %pm>%
y <- y %pm>%
pm_distinct(ab, .keep_all = TRUE) %pm>%
pm_select(-mo, -txt) %pm>%
# replace tidyr::pivot_wider() until here
remove_NAs()
select_ab_vars <- function(.data) {
.data[, c("ab_group", "ab_txt", colnames(.data)[!colnames(.data) %in% c("ab_group", "ab_txt", "ab")]), drop = FALSE]
}
y <- y %pm>%
create_var(ab_group = ab_group(y$ab, language = language)) %pm>%
select_ab_vars() %pm>%
y <- y %pm>%
create_var(ab_group = ab_group(y$ab, language = language)) %pm>%
select_ab_vars() %pm>%
pm_arrange(ab_group, ab_txt)
y <- y %pm>%
y <- y %pm>%
create_var(ab_group = ifelse(y$ab_group != pm_lag(y$ab_group) | is.na(pm_lag(y$ab_group)), y$ab_group, ""))
if (add_ab_group == FALSE) {
y <- y %pm>%
y <- y %pm>%
pm_select(-ab_group) %pm>%
pm_rename("Drug" = ab_txt)
colnames(y)[1] <- translate_into_language(colnames(y)[1], language, only_unknown = FALSE)
} else {
y <- y %pm>%
pm_rename("Group" = ab_group,
"Drug" = ab_txt)
y <- y %pm>%
pm_rename(
"Group" = ab_group,
"Drug" = ab_txt
)
}
if (!is.null(language)) {
colnames(y) <- translate_into_language(colnames(y), language, only_unknown = FALSE)
}
if (remove_intrinsic_resistant == TRUE) {
y <- y[, !vapply(FUN.VALUE = logical(1), y, function(col) all(col %like% "100", na.rm = TRUE) & !any(is.na(col))), drop = FALSE]
}
rownames(y) <- NULL
as_original_data_class(y, class(x.bak))
}
@@ -305,10 +328,14 @@ format.bug_drug_combinations <- function(x,
#' @export
print.bug_drug_combinations <- function(x, ...) {
x_class <- class(x)
print(set_clean_class(x,
new_class = x_class[!x_class %in% c("bug_drug_combinations", "grouped")]),
...)
print(
set_clean_class(x,
new_class = x_class[!x_class %in% c("bug_drug_combinations", "grouped")]
),
...
)
message_("Use 'format()' on this result to get a publishable/printable format.",
ifelse(inherits(x, "grouped"), " Note: The grouping variable(s) will be ignored.", ""),
as_note = FALSE)
ifelse(inherits(x, "grouped"), " Note: The grouping variable(s) will be ignored.", ""),
as_note = FALSE
)
}

69
R/catalogue_of_life.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -94,41 +94,52 @@ NULL
#' @inheritSection catalogue_of_life Catalogue of Life
#' @export
catalogue_of_life_version <- function() {
check_dataset_integrity()
# see the `CATALOGUE_OF_LIFE` list in R/globals.R
lst <- list(CoL =
list(version = gsub("{year}", CATALOGUE_OF_LIFE$year, CATALOGUE_OF_LIFE$version, fixed = TRUE),
url = gsub("{year}", CATALOGUE_OF_LIFE$year, CATALOGUE_OF_LIFE$url_CoL, fixed = TRUE),
n = nrow(pm_filter(microorganisms, source == "CoL"))),
LPSN =
list(version = "List of Prokaryotic names with Standing in Nomenclature",
url = CATALOGUE_OF_LIFE$url_LPSN,
yearmonth = CATALOGUE_OF_LIFE$yearmonth_LPSN,
n = nrow(pm_filter(microorganisms, source == "LPSN"))),
total_included =
list(
n_total_species = nrow(microorganisms),
n_total_synonyms = nrow(microorganisms.old)))
lst <- list(
CoL =
list(
version = gsub("{year}", CATALOGUE_OF_LIFE$year, CATALOGUE_OF_LIFE$version, fixed = TRUE),
url = gsub("{year}", CATALOGUE_OF_LIFE$year, CATALOGUE_OF_LIFE$url_CoL, fixed = TRUE),
n = nrow(pm_filter(microorganisms, source == "CoL"))
),
LPSN =
list(
version = "List of Prokaryotic names with Standing in Nomenclature",
url = CATALOGUE_OF_LIFE$url_LPSN,
yearmonth = CATALOGUE_OF_LIFE$yearmonth_LPSN,
n = nrow(pm_filter(microorganisms, source == "LPSN"))
),
total_included =
list(
n_total_species = nrow(microorganisms),
n_total_synonyms = nrow(microorganisms.old)
)
)
set_clean_class(lst,
new_class = c("catalogue_of_life_version", "list"))
new_class = c("catalogue_of_life_version", "list")
)
}
#' @method print catalogue_of_life_version
#' @export
#' @noRd
print.catalogue_of_life_version <- function(x, ...) {
cat(paste0(font_bold("Included in this AMR package (v", utils::packageDescription("AMR")$Version, ") are:\n\n", collapse = ""),
font_underline(x$CoL$version), "\n",
" Available at: ", font_blue(x$CoL$url), "\n",
" Number of included microbial species: ", format(x$CoL$n, big.mark = ","), "\n",
font_underline(paste0(x$LPSN$version, " (",
x$LPSN$yearmonth, ")")), "\n",
" Available at: ", font_blue(x$LPSN$url), "\n",
" Number of included bacterial species: ", format(x$LPSN$n, big.mark = ","), "\n\n",
"=> Total number of species included: ", format(x$total_included$n_total_species, big.mark = ","), "\n",
"=> Total number of synonyms included: ", format(x$total_included$n_total_synonyms, big.mark = ","), "\n\n",
"See for more info ", font_grey_bg("`?microorganisms`"), " and ", font_grey_bg("`?catalogue_of_life`"), ".\n"))
cat(paste0(
font_bold("Included in this AMR package (v", utils::packageDescription("AMR")$Version, ") are:\n\n", collapse = ""),
font_underline(x$CoL$version), "\n",
" Available at: ", font_blue(x$CoL$url), "\n",
" Number of included microbial species: ", format(x$CoL$n, big.mark = ","), "\n",
font_underline(paste0(
x$LPSN$version, " (",
x$LPSN$yearmonth, ")"
)), "\n",
" Available at: ", font_blue(x$LPSN$url), "\n",
" Number of included bacterial species: ", format(x$LPSN$n, big.mark = ","), "\n\n",
"=> Total number of species included: ", format(x$total_included$n_total_species, big.mark = ","), "\n",
"=> Total number of synonyms included: ", format(x$total_included$n_total_synonyms, big.mark = ","), "\n\n",
"See for more info ", font_grey_bg("`?microorganisms`"), " and ", font_grey_bg("`?catalogue_of_life`"), ".\n"
))
}

141
R/count.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -32,7 +32,7 @@
#' @inheritParams proportion
#' @inheritSection as.rsi Interpretation of R and S/I
#' @details These functions are meant to count isolates. Use the [resistance()]/[susceptibility()] functions to calculate microbial resistance/susceptibility.
#'
#'
#' The function [count_resistant()] is equal to the function [count_R()]. The function [count_susceptible()] is equal to the function [count_SI()].
#'
#' The function [n_rsi()] is an alias of [count_all()]. They can be used to count all available isolates, i.e. where all input antibiotics have an available result (S, I or R). Their use is equal to `n_distinct()`. Their function is equal to `count_susceptible(...) + count_resistant(...)`.
@@ -47,11 +47,11 @@
#' @examples
#' # example_isolates is a data set available in the AMR package.
#' # run ?example_isolates for more info.
#'
#'
#' # base R ------------------------------------------------------------
#' count_resistant(example_isolates$AMX) # counts "R"
#' count_resistant(example_isolates$AMX) # counts "R"
#' count_susceptible(example_isolates$AMX) # counts "S" and "I"
#' count_all(example_isolates$AMX) # counts "S", "I" and "R"
#' count_all(example_isolates$AMX) # counts "S", "I" and "R"
#'
#' # be more specific
#' count_S(example_isolates$AMX)
@@ -76,36 +76,38 @@
#' if (require("dplyr")) {
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(R = count_R(CIP),
#' I = count_I(CIP),
#' S = count_S(CIP),
#' n1 = count_all(CIP), # the actual total; sum of all three
#' n2 = n_rsi(CIP), # same - analogous to n_distinct
#' total = n()) # NOT the number of tested isolates!
#'
#' summarise(
#' R = count_R(CIP),
#' I = count_I(CIP),
#' S = count_S(CIP),
#' n1 = count_all(CIP), # the actual total; sum of all three
#' n2 = n_rsi(CIP), # same - analogous to n_distinct
#' total = n()
#' ) # NOT the number of tested isolates!
#'
#' # Number of available isolates for a whole antibiotic class
#' # (i.e., in this data set columns GEN, TOB, AMK, KAN)
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(across(aminoglycosides(), n_rsi))
#'
#'
#' # Count co-resistance between amoxicillin/clav acid and gentamicin,
#' # so we can see that combination therapy does a lot more than mono therapy.
#' # Please mind that `susceptibility()` calculates percentages right away instead.
#' example_isolates %>% count_susceptible(AMC) # 1433
#' example_isolates %>% count_all(AMC) # 1879
#'
#' example_isolates %>% count_all(AMC) # 1879
#'
#' example_isolates %>% count_susceptible(GEN) # 1399
#' example_isolates %>% count_all(GEN) # 1855
#'
#' example_isolates %>% count_all(GEN) # 1855
#'
#' example_isolates %>% count_susceptible(AMC, GEN) # 1764
#' example_isolates %>% count_all(AMC, GEN) # 1936
#'
#' example_isolates %>% count_all(AMC, GEN) # 1936
#'
#' # Get number of S+I vs. R immediately of selected columns
#' example_isolates %>%
#' select(AMX, CIP) %>%
#' count_df(translate = FALSE)
#'
#'
#' # It also supports grouping variables
#' example_isolates %>%
#' select(ward, AMX, CIP) %>%
@@ -116,10 +118,12 @@
count_resistant <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = "R",
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
ab_result = "R",
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -127,10 +131,12 @@ count_resistant <- function(..., only_all_tested = FALSE) {
count_susceptible <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = c("S", "I"),
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
ab_result = c("S", "I"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -138,10 +144,12 @@ count_susceptible <- function(..., only_all_tested = FALSE) {
count_R <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = "R",
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
ab_result = "R",
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -152,10 +160,12 @@ count_IR <- function(..., only_all_tested = FALSE) {
}
tryCatch(
rsi_calc(...,
ab_result = c("I", "R"),
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
ab_result = c("I", "R"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -163,10 +173,12 @@ count_IR <- function(..., only_all_tested = FALSE) {
count_I <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = "I",
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
ab_result = "I",
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -174,10 +186,12 @@ count_I <- function(..., only_all_tested = FALSE) {
count_SI <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = c("S", "I"),
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
ab_result = c("S", "I"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -188,10 +202,12 @@ count_S <- function(..., only_all_tested = FALSE) {
}
tryCatch(
rsi_calc(...,
ab_result = "S",
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
ab_result = "S",
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -199,10 +215,12 @@ count_S <- function(..., only_all_tested = FALSE) {
count_all <- function(..., only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = c("S", "I", "R"),
only_all_tested = only_all_tested,
only_count = TRUE),
error = function(e) stop_(e$message, call = -5))
ab_result = c("S", "I", "R"),
only_all_tested = only_all_tested,
only_count = TRUE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname count
@@ -217,12 +235,15 @@ count_df <- function(data,
combine_SI = TRUE,
combine_IR = FALSE) {
tryCatch(
rsi_calc_df(type = "count",
data = data,
translate_ab = translate_ab,
language = language,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI)),
error = function(e) stop_(e$message, call = -5))
rsi_calc_df(
type = "count",
data = data,
translate_ab = translate_ab,
language = language,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI)
),
error = function(e) stop_(e$message, call = -5)
)
}

129
R/custom_eucast_rules.R
View File

@@ -24,87 +24,96 @@
# ==================================================================== #
#' Define Custom EUCAST Rules
#'
#'
#' Define custom EUCAST rules for your organisation or specific analysis and use the output of this function in [eucast_rules()].
#' @param ... rules in [formula][base::tilde] notation, see *Examples*
#' @details
#' Some organisations have their own adoption of EUCAST rules. This function can be used to define custom EUCAST rules to be used in the [eucast_rules()] function.
#' @section How it works:
#'
#'
#' ### Basics
#'
#'
#' If you are familiar with the [`case_when()`][dplyr::case_when()] function of the `dplyr` package, you will recognise the input method to set your own rules. Rules must be set using what \R considers to be the 'formula notation'. The rule itself is written *before* the tilde (`~`) and the consequence of the rule is written *after* the tilde:
#'
#'
#' ```{r}
#' x <- custom_eucast_rules(TZP == "S" ~ aminopenicillins == "S",
#' TZP == "R" ~ aminopenicillins == "R")
#' ```
#'
#'
#' These are two custom EUCAST rules: if TZP (piperacillin/tazobactam) is "S", all aminopenicillins (ampicillin and amoxicillin) must be made "S", and if TZP is "R", aminopenicillins must be made "R". These rules can also be printed to the console, so it is immediately clear how they work:
#'
#'
#' ```{r}
#' x
#' ```
#'
#'
#' The rules (the part *before* the tilde, in above example `TZP == "S"` and `TZP == "R"`) must be evaluable in your data set: it should be able to run as a filter in your data set without errors. This means for the above example that the column `TZP` must exist. We will create a sample data set and test the rules set:
#'
#'
#' ```{r}
#' df <- data.frame(mo = c("Escherichia coli", "Klebsiella pneumoniae"),
#' TZP = as.rsi("R"),
#' ampi = as.rsi("S"),
#' cipro = as.rsi("S"))
#' df
#'
#'
#' eucast_rules(df, rules = "custom", custom_rules = x, info = FALSE)
#' ```
#'
#'
#' ### Using taxonomic properties in rules
#'
#'
#' There is one exception in variables used for the rules: all column names of the [microorganisms] data set can also be used, but do not have to exist in the data set. These column names are: `r vector_and(colnames(microorganisms), sort = FALSE)`. Thus, this next example will work as well, despite the fact that the `df` data set does not contain a column `genus`:
#'
#'
#' ```{r}
#' y <- custom_eucast_rules(TZP == "S" & genus == "Klebsiella" ~ aminopenicillins == "S",
#' TZP == "R" & genus == "Klebsiella" ~ aminopenicillins == "R")
#'
#' eucast_rules(df, rules = "custom", custom_rules = y, info = FALSE)
#' ```
#'
#'
#' ### Usage of antibiotic group names
#'
#'
#' It is possible to define antibiotic groups instead of single antibiotics for the rule consequence, the part *after* the tilde. In above examples, the antibiotic group `aminopenicillins` is used to include ampicillin and amoxicillin. The following groups are allowed (case-insensitive). Within parentheses are the agents that will be matched when running the rule.
#'
#'
#' `r paste0(" * ", sapply(DEFINED_AB_GROUPS, function(x) paste0("\"", tolower(gsub("^AB_", "", x)), "\"\\cr(", vector_and(ab_name(eval(parse(text = x), envir = asNamespace("AMR")), language = NULL, tolower = TRUE), quotes = FALSE), ")"), USE.NAMES = FALSE), "\n", collapse = "")`
#' @returns A [list] containing the custom rules
#' @export
#' @examples
#' x <- custom_eucast_rules(AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
#' AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I")
#' x <- custom_eucast_rules(
#' AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
#' AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I"
#' )
#' x
#'
#'
#' # run the custom rule set (verbose = TRUE will return a logbook instead of the data set):
#' eucast_rules(example_isolates,
#' rules = "custom",
#' custom_rules = x,
#' info = FALSE,
#' verbose = TRUE)
#'
#' rules = "custom",
#' custom_rules = x,
#' info = FALSE,
#' verbose = TRUE
#' )
#'
#' # combine rule sets
#' x2 <- c(x,
#' custom_eucast_rules(TZP == "R" ~ carbapenems == "R"))
#' x2 <- c(
#' x,
#' custom_eucast_rules(TZP == "R" ~ carbapenems == "R")
#' )
#' x2
custom_eucast_rules <- function(...) {
dots <- tryCatch(list(...),
error = function(e) "error")
stop_if(identical(dots, "error"),
"rules must be a valid formula inputs (e.g., using '~'), see `?custom_eucast_rules`")
error = function(e) "error"
)
stop_if(
identical(dots, "error"),
"rules must be a valid formula inputs (e.g., using '~'), see `?custom_eucast_rules`"
)
n_dots <- length(dots)
stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using `?custom_eucast_rules`.")
out <- vector("list", n_dots)
for (i in seq_len(n_dots)) {
stop_ifnot(inherits(dots[[i]], "formula"),
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?custom_eucast_rules`")
stop_ifnot(
inherits(dots[[i]], "formula"),
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?custom_eucast_rules`"
)
# Query
qry <- dots[[i]][[2]]
if (inherits(qry, "call")) {
@@ -119,11 +128,13 @@ custom_eucast_rules <- function(...) {
qry <- gsub(" ?, ?", ", ", qry)
qry <- gsub("'", "\"", qry, fixed = TRUE)
out[[i]]$query <- as.expression(qry)
# Resulting rule
result <- dots[[i]][[3]]
stop_ifnot(deparse(result) %like% "==",
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see `?custom_eucast_rules`")
stop_ifnot(
deparse(result) %like% "==",
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see `?custom_eucast_rules`"
)
result_group <- as.character(result)[[2]]
if (paste0("AB_", toupper(result_group), "S") %in% DEFINED_AB_GROUPS) {
# support for e.g. 'aminopenicillin' if user meant 'aminopenicillins'
@@ -134,25 +145,31 @@ custom_eucast_rules <- function(...) {
} else {
result_group <- tryCatch(
suppressWarnings(as.ab(result_group,
fast_mode = TRUE,
flag_multiple_results = FALSE)),
error = function(e) NA_character_)
fast_mode = TRUE,
flag_multiple_results = FALSE
)),
error = function(e) NA_character_
)
}
stop_if(any(is.na(result_group)),
"this result of rule ", i, " could not be translated to a single antimicrobial agent/group: \"",
as.character(result)[[2]], "\".\n\nThe input can be a name or code of an antimicrobial agent, or be one of: ",
vector_or(tolower(gsub("AB_", "", DEFINED_AB_GROUPS)), quotes = FALSE), ".")
stop_if(
any(is.na(result_group)),
"this result of rule ", i, " could not be translated to a single antimicrobial agent/group: \"",
as.character(result)[[2]], "\".\n\nThe input can be a name or code of an antimicrobial agent, or be one of: ",
vector_or(tolower(gsub("AB_", "", DEFINED_AB_GROUPS)), quotes = FALSE), "."
)
result_value <- as.character(result)[[3]]
result_value[result_value == "NA"] <- NA
stop_ifnot(result_value %in% c("R", "S", "I", NA),
"the resulting value of rule ", i, " must be either \"R\", \"S\", \"I\" or NA")
stop_ifnot(
result_value %in% c("R", "S", "I", NA),
"the resulting value of rule ", i, " must be either \"R\", \"S\", \"I\" or NA"
)
result_value <- as.rsi(result_value)
out[[i]]$result_group <- result_group
out[[i]]$result_value <- result_value
}
names(out) <- paste0("rule", seq_len(n_dots))
set_clean_class(out, new_class = c("custom_eucast_rules", "list"))
}
@@ -196,13 +213,19 @@ print.custom_eucast_rules <- function(x, ...) {
} else {
val <- font_rsi_I_bg(font_black(" I "))
}
agents <- paste0(font_blue(ab_name(rule$result_group, language = NULL, tolower = TRUE),
collapse = NULL),
" (", rule$result_group, ")")
agents <- paste0(
font_blue(ab_name(rule$result_group, language = NULL, tolower = TRUE),
collapse = NULL
),
" (", 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))
cat("\n ", rule_if, "\n", rule_then, "\n", sep = "")

56
R/data.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -42,7 +42,7 @@
#' - `iv_ddd`\cr Defined Daily Dose (DDD), parenteral (intravenous) treatment, currently available for `r sum(!is.na(antibiotics$iv_ddd))` drugs
#' - `iv_units`\cr Units of `iv_ddd`
#' - `loinc`\cr All LOINC codes (Logical Observation Identifiers Names and Codes) associated with the name of the antimicrobial agent. Use [ab_loinc()] to retrieve them quickly, see [ab_property()].
#'
#'
#' ## For the [antivirals] data set: a [tibble[tibble::tibble] with `r nrow(antivirals)` observations and `r ncol(antivirals)` variables:
#' - `atc`\cr ATC codes (Anatomical Therapeutic Chemical) as defined by the WHOCC
#' - `cid`\cr Compound ID as found in PubChem
@@ -56,7 +56,7 @@
#' @details Properties that are based on an ATC code are only available when an ATC is available. These properties are: `atc_group1`, `atc_group2`, `oral_ddd`, `oral_units`, `iv_ddd` and `iv_units`.
#'
#' Synonyms (i.e. trade names) were derived from the Compound ID (`cid`) and consequently only available where a CID is available.
#'
#'
#' ## 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 World Health Organization (WHO) Collaborating Centre for Drug Statistics Methodology (WHOCC): <https://www.whocc.no/atc_ddd_index/>
@@ -86,14 +86,14 @@
#' - `source`\cr Either `r vector_or(microorganisms$source)` (see *Source*)
#' - `prevalence`\cr Prevalence of the microorganism, see [as.mo()]
#' - `snomed`\cr Systematized Nomenclature of Medicine (SNOMED) code of the microorganism, according to the `r SNOMED_VERSION$current_source` (see *Source*). Use [mo_snomed()] to retrieve it quickly, see [mo_property()].
#' @details
#' @details
#' Please note that entries are only based on the Catalogue of Life and the LPSN (see below). Since these sources incorporate entries based on (recent) publications in the International Journal of Systematic and Evolutionary Microbiology (IJSEM), it can happen that the year of publication is sometimes later than one might expect.
#'
#'
#' For example, *Staphylococcus pettenkoferi* was described for the first time in Diagnostic Microbiology and Infectious Disease in 2002 (\doi{10.1016/s0732-8893(02)00399-1}), but it was not before 2007 that a publication in IJSEM followed (\doi{10.1099/ijs.0.64381-0}). Consequently, the `AMR` package returns 2007 for `mo_year("S. pettenkoferi")`.
#'
#'
#' ## Manual additions
#' For convenience, some entries were added manually:
#'
#'
#' - 11 entries of *Streptococcus* (beta-haemolytic: groups A, B, C, D, F, G, H, K and unspecified; other: viridans, milleri)
#' - 2 entries of *Staphylococcus* (coagulase-negative (CoNS) and coagulase-positive (CoPS))
#' - 3 entries of *Trichomonas* (*T. vaginalis*, and its family and genus)
@@ -103,27 +103,27 @@
#' - 1 entry of *Moraxella* (*M. catarrhalis*), which was formally named *Branhamella catarrhalis* (Catlin, 1970) though this change was never accepted within the field of clinical microbiology
#' - 5 other 'undefined' entries (unknown, unknown Gram negatives, unknown Gram positives, unknown yeast and unknown fungus)
#' - 6 families under the Enterobacterales order, according to Adeolu *et al.* (2016, PMID 27620848), that are not (yet) in the Catalogue of Life
#'
#'
#' ## Direct download
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @section About the Records from LPSN (see *Source*):
#' The List of Prokaryotic names with Standing in Nomenclature (LPSN) provides comprehensive information on the nomenclature of prokaryotes. LPSN is a free to use service founded by Jean P. Euzeby in 1997 and later on maintained by Aidan C. Parte.
#'
#'
#' As of February 2020, the regularly augmented LPSN database at DSMZ is the basis of the new LPSN service. The new database was implemented for the Type-Strain Genome Server and augmented in 2018 to store all kinds of nomenclatural information. Data from the previous version of LPSN and from the Prokaryotic Nomenclature Up-to-date (PNU) service were imported into the new system. PNU had been established in 1993 as a service of the Leibniz Institute DSMZ, and was curated by Norbert Weiss, Manfred Kracht and Dorothea Gleim.
#' @source
#' @source
#' `r gsub("{year}", CATALOGUE_OF_LIFE$year, CATALOGUE_OF_LIFE$version, fixed = TRUE)` as currently implemented in this `AMR` package:
#'
#'
#' * Annual Checklist (public online taxonomic database), <http://www.catalogueoflife.org>
#'
#'
#' List of Prokaryotic names with Standing in Nomenclature (`r CATALOGUE_OF_LIFE$yearmonth_LPSN`) as currently implemented in this `AMR` package:
#'
#'
#' * Parte, A.C., Sarda Carbasse, J., Meier-Kolthoff, J.P., Reimer, L.C. and Goker, M. (2020). List of Prokaryotic names with Standing in Nomenclature (LPSN) moves to the DSMZ. International Journal of Systematic and Evolutionary Microbiology, 70, 5607-5612; \doi{10.1099/ijsem.0.004332}
#' * Parte, A.C. (2018). LPSN - List of Prokaryotic names with Standing in Nomenclature (bacterio.net), 20 years on. International Journal of Systematic and Evolutionary Microbiology, 68, 1825-1829; \doi{10.1099/ijsem.0.002786}
#' * Parte, A.C. (2014). LPSN - List of Prokaryotic names with Standing in Nomenclature. Nucleic Acids Research, 42, Issue D1, D613-D616; \doi{10.1093/nar/gkt1111}
#' * Euzeby, J.P. (1997). List of Bacterial Names with Standing in Nomenclature: a Folder Available on the Internet. International Journal of Systematic Bacteriology, 47, 590-592; \doi{10.1099/00207713-47-2-590}
#'
#'
#' `r SNOMED_VERSION$current_source` as currently implemented in this `AMR` package:
#'
#'
#' * Retrieved from the `r SNOMED_VERSION$title`, OID `r SNOMED_VERSION$current_oid`, version `r SNOMED_VERSION$current_version`; url: <`r SNOMED_VERSION$url`>
#' @seealso [as.mo()], [mo_property()], [microorganisms.codes], [intrinsic_resistant]
#' @examples
@@ -139,10 +139,10 @@
#' - `fullname_new`\cr New full taxonomic name of the microorganism
#' - `ref`\cr Author(s) and year of concerning scientific publication
#' - `prevalence`\cr Prevalence of the microorganism, see [as.mo()]
#' @details
#' @details
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [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 Catalogue of Life: Annual Checklist (public online taxonomic database), <http://www.catalogueoflife.org> (check included annual version with [catalogue_of_life_version()]).
#'
#'
#' Parte, A.C. (2018). LPSN - List of Prokaryotic names with Standing in Nomenclature (bacterio.net), 20 years on. International Journal of Systematic and Evolutionary Microbiology, 68, 1825-1829; \doi{10.1099/ijsem.0.002786}
#' @seealso [as.mo()] [mo_property()] [microorganisms]
#' @examples
@@ -155,7 +155,7 @@
#' @format A [tibble[tibble::tibble] with `r format(nrow(microorganisms.codes), big.mark = ",")` observations and `r ncol(microorganisms.codes)` variables:
#' - `code`\cr Commonly used code of a microorganism
#' - `mo`\cr ID of the microorganism in the [microorganisms] data set
#' @details
#' @details
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @inheritSection catalogue_of_life Catalogue of Life
#' @seealso [as.mo()] [microorganisms]
@@ -174,7 +174,7 @@
#' - `ward`\cr Ward type where the patient was admitted, either `r vector_or(example_isolates$ward)`
#' - `mo`\cr ID of microorganism created with [as.mo()], see also the [microorganisms] data set
#' - `PEN:RIF`\cr `r sum(vapply(FUN.VALUE = logical(1), example_isolates, is.rsi))` different antibiotics with class [`rsi`] (see [as.rsi()]); these column names occur in the [antibiotics] data set and can be translated with [set_ab_names()] or [ab_name()]
#' @details
#' @details
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @examples
#' example_isolates
@@ -189,7 +189,7 @@
#' - `hospital`\cr ID of the hospital, from A to C
#' - `bacteria`\cr info about microorganism that can be transformed with [as.mo()], see also [microorganisms]
#' - `AMX:GEN`\cr 4 different antibiotics that have to be transformed with [as.rsi()]
#' @details
#' @details
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @examples
#' example_isolates_unclean
@@ -225,7 +225,7 @@
#' - `Comment`\cr Other comments
#' - `Date of data entry`\cr [Date] this data was entered in WHONET
#' - `AMP_ND10:CIP_EE`\cr `r sum(vapply(FUN.VALUE = logical(1), WHONET, is.rsi))` different antibiotics. You can lookup the abbreviations in the [antibiotics] data set, or use e.g. [`ab_name("AMP")`][ab_name()] to get the official name immediately. Before analysis, you should transform this to a valid antibiotic class, using [as.rsi()].
#' @details
#' @details
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @examples
#' WHONET
@@ -246,9 +246,9 @@
#' - `breakpoint_S`\cr Lowest MIC value or highest number of millimetres that leads to "S"
#' - `breakpoint_R`\cr Highest MIC value or lowest number of millimetres that leads to "R"
#' - `uti`\cr A [logical] value (`TRUE`/`FALSE`) to indicate whether the rule applies to a urinary tract infection (UTI)
#' @details
#' @details
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [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).
#'
#'
#' They **allow for machine reading EUCAST and CLSI guidelines**, which is almost impossible with the MS Excel and PDF files distributed by EUCAST and CLSI.
#' @seealso [intrinsic_resistant]
#' @examples
@@ -261,12 +261,12 @@
#' @format A [tibble[tibble::tibble] with `r format(nrow(intrinsic_resistant), big.mark = ",")` observations and `r ncol(intrinsic_resistant)` variables:
#' - `mo`\cr Microorganism ID
#' - `ab`\cr Antibiotic ID
#' @details
#' @details
#' This data set is based on `r format_eucast_version_nr(3.3)`.
#'
#'
#' ## Direct download
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#'
#'
#' They **allow for machine reading EUCAST and CLSI guidelines**, which is almost impossible with the MS Excel and PDF files distributed by EUCAST and CLSI.
#' @examples
#' intrinsic_resistant
@@ -285,9 +285,9 @@
#' - `notes`\cr Additional dosage notes
#' - `original_txt`\cr Original text in the PDF file of EUCAST
#' - `eucast_version`\cr Version number of the EUCAST Clinical Breakpoints guideline to which these dosages apply
#' @details
#' @details
#' This data set is based on `r format_eucast_version_nr(11.0)`.
#'
#'
#' ## Direct download
#' Like all data sets in this package, this data set is publicly available for download in the following formats: R, MS Excel, Apache Feather, Apache Parquet, SPSS, SAS, and Stata. Please visit [our website for the download links](https://msberends.github.io/AMR/articles/datasets.html). The actual files are of course available on [our GitHub repository](https://github.com/msberends/AMR/tree/main/data-raw).
#' @examples

2
R/deprecated.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #

86
R/disk.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -36,33 +36,37 @@
#' @seealso [as.rsi()]
#' @examples
#' # transform existing disk zones to the `disk` class (using base R)
#' df <- data.frame(microorganism = "Escherichia coli",
#' AMP = 20,
#' CIP = 14,
#' GEN = 18,
#' TOB = 16)
#' df <- data.frame(
#' microorganism = "Escherichia coli",
#' AMP = 20,
#' CIP = 14,
#' GEN = 18,
#' TOB = 16
#' )
#' df[, 2:5] <- lapply(df[, 2:5], as.disk)
#' str(df)
#'
#'
#' \donttest{
#' # transforming is easier with dplyr:
#' if (require("dplyr")) {
#' df %>% mutate(across(AMP:TOB, as.disk))
#' }
#' }
#'
#'
#' # interpret disk values, see ?as.rsi
#' as.rsi(x = as.disk(18),
#' mo = "Strep pneu", # `mo` will be coerced with as.mo()
#' ab = "ampicillin", # and `ab` with as.ab()
#' guideline = "EUCAST")
#' as.rsi(
#' x = as.disk(18),
#' mo = "Strep pneu", # `mo` will be coerced with as.mo()
#' ab = "ampicillin", # and `ab` with as.ab()
#' guideline = "EUCAST"
#' )
#'
#' # interpret whole data set, pretend to be all from urinary tract infections:
#' as.rsi(df, uti = TRUE)
as.disk <- function(x, na.rm = FALSE) {
meet_criteria(x, allow_class = c("disk", "character", "numeric", "integer"), allow_NA = TRUE)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (!is.disk(x)) {
x <- unlist(x)
if (na.rm == TRUE) {
@@ -70,9 +74,9 @@ as.disk <- function(x, na.rm = FALSE) {
}
x[trimws(x) == ""] <- NA
x.bak <- x
na_before <- length(x[is.na(x)])
# heavily based on cleaner::clean_double():
clean_double2 <- function(x, remove = "[^0-9.,-]", fixed = FALSE) {
x <- gsub(",", ".", x)
@@ -80,38 +84,44 @@ as.disk <- function(x, na.rm = FALSE) {
x <- gsub("[,.]$", "", x)
# only keep last dot/comma
reverse <- function(x) vapply(FUN.VALUE = character(1), lapply(strsplit(x, NULL), rev), paste, collapse = "")
x <- sub("{{dot}}", ".",
gsub(".", "",
reverse(sub(".", "}}tod{{",
reverse(x),
fixed = TRUE)),
fixed = TRUE),
fixed = TRUE)
x <- sub("{{dot}}", ".",
gsub(".", "",
reverse(sub(".", "}}tod{{",
reverse(x),
fixed = TRUE
)),
fixed = TRUE
),
fixed = TRUE
)
x_clean <- gsub(remove, "", x, ignore.case = TRUE, fixed = fixed)
# remove everything that is not a number or dot
as.double(gsub("[^0-9.]+", "", x_clean))
}
# round up and make it an integer
x <- as.integer(ceiling(clean_double2(x)))
# disks can never be less than 6 mm (size of smallest disk) or more than 50 mm
x[x < 6 | x > 50] <- NA_integer_
na_after <- length(x[is.na(x)])
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak)] %pm>%
unique() %pm>%
sort() %pm>%
vector_and(quotes = TRUE)
warning_("in `as.disk()`: ", na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid disk zones: ",
list_missing)
warning_(
"in `as.disk()`: ", na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid disk zones: ",
list_missing
)
}
}
set_clean_class(as.integer(x),
new_class = c("disk", "integer"))
new_class = c("disk", "integer")
)
}
all_valid_disks <- function(x) {
@@ -119,7 +129,8 @@ all_valid_disks <- function(x) {
return(FALSE)
}
x_disk <- tryCatch(suppressWarnings(as.disk(x[!is.na(x)])),
error = function(e) NA)
error = function(e) NA
)
!any(is.na(x_disk)) && !all(is.na(x))
}
@@ -127,7 +138,8 @@ all_valid_disks <- function(x) {
#' @details `NA_disk_` is a missing value of the new `<disk>` class.
#' @export
NA_disk_ <- set_clean_class(as.integer(NA_real_),
new_class = c("disk", "integer"))
new_class = c("disk", "integer")
)
#' @rdname as.disk
#' @export
@@ -218,10 +230,10 @@ rep.disk <- function(x, ...) {
get_skimmers.disk <- function(column) {
skimr::sfl(
skim_type = "disk",
min = ~min(as.double(.), na.rm = TRUE),
max = ~max(as.double(.), na.rm = TRUE),
median = ~stats::median(as.double(.), na.rm = TRUE),
n_unique = ~length(unique(stats::na.omit(.))),
hist = ~skimr::inline_hist(stats::na.omit(as.double(.)))
min = ~ min(as.double(.), na.rm = TRUE),
max = ~ max(as.double(.), na.rm = TRUE),
median = ~ stats::median(as.double(.), na.rm = TRUE),
n_unique = ~ length(unique(stats::na.omit(.))),
hist = ~ skimr::inline_hist(stats::na.omit(as.double(.)))
)
}

108
R/episode.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -24,18 +24,18 @@
# ==================================================================== #
#' Determine (New) Episodes for Patients
#'
#'
#' These functions determine which items in a vector can be considered (the start of) a new episode, based on the argument `episode_days`. This can be used to determine clinical episodes for any epidemiological analysis. The [get_episode()] function returns the index number of the episode per group, while the [is_new_episode()] function returns values `TRUE`/`FALSE` to indicate whether an item in a vector is the start of a new episode.
#' @param x vector of dates (class `Date` or `POSIXt`), will be sorted internally to determine episodes
#' @param episode_days required episode length in days, can also be less than a day or `Inf`, see *Details*
#' @param ... ignored, only in place to allow future extensions
#' @details
#' @details
#' Dates are first sorted from old to new. The oldest date will mark the start of the first episode. After this date, the next date will be marked that is at least `episode_days` days later than the start of the first episode. From that second marked date on, the next date will be marked that is at least `episode_days` days later than the start of the second episode which will be the start of the third episode, and so on. Before the vector is being returned, the original order will be restored.
#'
#'
#' The [first_isolate()] function is a wrapper around the [is_new_episode()] function, but is more efficient for data sets containing microorganism codes or names and allows for different isolate selection methods.
#'
#'
#' The `dplyr` package is not required for these functions to work, but these functions do support [variable grouping][dplyr::group_by()] and work conveniently inside `dplyr` verbs such as [`filter()`][dplyr::filter()], [`mutate()`][dplyr::mutate()] and [`summarise()`][dplyr::summarise()].
#' @return
#' @return
#' * [get_episode()]: a [double] vector
#' * [is_new_episode()]: a [logical] vector
#' @seealso [first_isolate()]
@@ -45,69 +45,73 @@
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates
#' df <- example_isolates[sample(seq_len(2000), size = 200), ]
#'
#' get_episode(df$date, episode_days = 60) # indices
#'
#' get_episode(df$date, episode_days = 60) # indices
#' is_new_episode(df$date, episode_days = 60) # TRUE/FALSE
#'
#'
#' # filter on results from the third 60-day episode only, using base R
#' df[which(get_episode(df$date, 60) == 3), ]
#'
#'
#' # the functions also work for less than a day, e.g. to include one per hour:
#' get_episode(c(Sys.time(),
#' Sys.time() + 60 * 60),
#' episode_days = 1/24)
#'
#' get_episode(c(
#' Sys.time(),
#' Sys.time() + 60 * 60
#' ),
#' episode_days = 1 / 24
#' )
#'
#' \donttest{
#' if (require("dplyr")) {
#' # is_new_episode() can also be used in dplyr verbs to determine patient
#' # episodes based on any (combination of) grouping variables:
#' df %>%
#' mutate(condition = sample(x = c("A", "B", "C"),
#' size = 200,
#' replace = TRUE)) %>%
#' mutate(condition = sample(
#' x = c("A", "B", "C"),
#' size = 200,
#' replace = TRUE
#' )) %>%
#' group_by(condition) %>%
#' mutate(new_episode = is_new_episode(date, 365)) %>%
#' select(patient, date, condition, new_episode)
#'
#' }
#' if (require("dplyr")) {
#'
#' df %>%
#' group_by(ward, patient) %>%
#' transmute(date,
#' patient,
#' new_index = get_episode(date, 60),
#' new_logical = is_new_episode(date, 60))
#'
#' transmute(date,
#' patient,
#' new_index = get_episode(date, 60),
#' new_logical = is_new_episode(date, 60)
#' )
#' }
#' if (require("dplyr")) {
#'
#' df %>%
#' group_by(ward) %>%
#' summarise(n_patients = n_distinct(patient),
#' n_episodes_365 = sum(is_new_episode(date, episode_days = 365)),
#' n_episodes_60 = sum(is_new_episode(date, episode_days = 60)),
#' n_episodes_30 = sum(is_new_episode(date, episode_days = 30)))
#'
#' group_by(ward) %>%
#' summarise(
#' n_patients = n_distinct(patient),
#' n_episodes_365 = sum(is_new_episode(date, episode_days = 365)),
#' n_episodes_60 = sum(is_new_episode(date, episode_days = 60)),
#' n_episodes_30 = sum(is_new_episode(date, episode_days = 30))
#' )
#' }
#' if (require("dplyr")) {
#'
#'
#' # grouping on patients and microorganisms leads to the same
#' # results as first_isolate() when using 'episode-based':
#' x <- df %>%
#' filter_first_isolate(include_unknown = TRUE,
#' method = "episode-based")
#'
#' filter_first_isolate(
#' include_unknown = TRUE,
#' method = "episode-based"
#' )
#'
#' y <- df %>%
#' group_by(patient, mo) %>%
#' filter(is_new_episode(date, 365)) %>%
#' ungroup()
#'
#' identical(x, y)
#'
#' }
#' if (require("dplyr")) {
#'
#'
#' # but is_new_episode() has a lot more flexibility than first_isolate(),
#' # since you can now group on anything that seems relevant:
#' df %>%
@@ -119,11 +123,13 @@
get_episode <- function(x, episode_days, ...) {
meet_criteria(x, allow_class = c("Date", "POSIXt"), allow_NA = TRUE)
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = FALSE)
exec_episode(x = x,
type = "sequential",
episode_days = episode_days,
... = ...)
exec_episode(
x = x,
type = "sequential",
episode_days = episode_days,
... = ...
)
}
#' @rdname get_episode
@@ -131,18 +137,20 @@ get_episode <- function(x, episode_days, ...) {
is_new_episode <- function(x, episode_days, ...) {
meet_criteria(x, allow_class = c("Date", "POSIXt"), allow_NA = TRUE)
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = FALSE)
exec_episode(x = x,
type = "logical",
episode_days = episode_days,
... = ...)
exec_episode(
x = x,
type = "logical",
episode_days = episode_days,
... = ...
)
}
exec_episode <- function(x, type, episode_days, ...) {
x <- as.double(as.POSIXct(x)) # as.POSIXct() required for Date classes
# since x is now in seconds, get seconds from episode_days as well
episode_seconds <- episode_days * 60 * 60 * 24
if (length(x) == 1) { # this will also match 1 NA, which is fine
if (type == "logical") {
return(TRUE)
@@ -164,7 +172,7 @@ exec_episode <- function(x, type, episode_days, ...) {
}
}
}
# I asked on StackOverflow:
# https://stackoverflow.com/questions/42122245/filter-one-row-every-year
run_episodes <- function(x, episode_seconds) {
@@ -192,7 +200,7 @@ exec_episode <- function(x, type, episode_days, ...) {
indices
}
}
ord <- order(x)
out <- run_episodes(x[ord], episode_seconds)[order(ord)]
out[is.na(x) & ord != 1] <- NA # every NA but the first must remain NA

847
R/eucast_rules.R
View File

File diff suppressed because it is too large Load Diff

402
R/first_isolate.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -34,7 +34,7 @@
#' @param col_specimen column name of the specimen type or group
#' @param col_icu column name of the logicals (`TRUE`/`FALSE`) whether a ward or department is an Intensive Care Unit (ICU). This can also be a [logical] vector with the same length as rows in `x`.
#' @param col_keyantimicrobials (only useful when `method = "phenotype-based"`) column name of the key antimicrobials to determine first isolates, see [key_antimicrobials()]. Defaults to the first column that starts with 'key' followed by 'ab' or 'antibiotics' or 'antimicrobials' (case insensitive). Use `col_keyantimicrobials = FALSE` to prevent this. Can also be the output of [key_antimicrobials()].
#' @param episode_days episode in days after which a genus/species combination will be determined as 'first isolate' again. The default of 365 days is based on the guideline by CLSI, see *Source*.
#' @param episode_days episode in days after which a genus/species combination will be determined as 'first isolate' again. The default of 365 days is based on the guideline by CLSI, see *Source*.
#' @param testcodes_exclude a [character] vector with test codes that should be excluded (case-insensitive)
#' @param icu_exclude a [logical] to indicate whether ICU isolates should be excluded (rows with value `TRUE` in the column set with `col_icu`)
#' @param specimen_group value in the column set with `col_specimen` to filter on
@@ -46,22 +46,22 @@
#' @param include_unknown a [logical] to indicate whether 'unknown' microorganisms should be included too, i.e. microbial code `"UNKNOWN"`, which defaults to `FALSE`. For WHONET users, this means that all records with organism code `"con"` (*contamination*) will be excluded at default. Isolates with a microbial ID of `NA` will always be excluded as first isolate.
#' @param include_untested_rsi a [logical] to indicate whether also rows without antibiotic results are still eligible for becoming a first isolate. Use `include_untested_rsi = FALSE` to always return `FALSE` for such rows. This checks the data set for columns of class `<rsi>` and consequently requires transforming columns with antibiotic results using [as.rsi()] first.
#' @param ... arguments passed on to [first_isolate()] when using [filter_first_isolate()], otherwise arguments passed on to [key_antimicrobials()] (such as `universal`, `gram_negative`, `gram_positive`)
#' @details
#' @details
#' To conduct epidemiological analyses on antimicrobial resistance data, only so-called first isolates should be included to prevent overestimation and underestimation of antimicrobial resistance. Different methods can be used to do so, see below.
#'
#'
#' These functions are context-aware. This means that the `x` argument can be left blank if used inside a [data.frame] call, see *Examples*.
#'
#'
#' The [first_isolate()] function is a wrapper around the [is_new_episode()] function, but more efficient for data sets containing microorganism codes or names.
#'
#'
#' All isolates with a microbial ID of `NA` will be excluded as first isolate.
#'
#'
#' ## Different methods
#'
#' According to Hindler *et al.* (2007, \doi{10.1086/511864}), there are different methods (algorithms) to select first isolates with increasing reliability: isolate-based, patient-based, episode-based and phenotype-based. All methods select on a combination of the taxonomic genus and species (not subspecies).
#'
#'
#' According to Hindler *et al.* (2007, \doi{10.1086/511864}), there are different methods (algorithms) to select first isolates with increasing reliability: isolate-based, patient-based, episode-based and phenotype-based. All methods select on a combination of the taxonomic genus and species (not subspecies).
#'
#' All mentioned methods are covered in the [first_isolate()] function:
#'
#'
#'
#'
#' | **Method** | **Function to apply** |
#' |--------------------------------------------------|-------------------------------------------------------|
#' | **Isolate-based** | `first_isolate(x, method = "isolate-based")` |
@@ -82,53 +82,53 @@
#' | *(= first isolate per phenotype)* | |
#' | - Major difference in any antimicrobial result | - `first_isolate(x, type = "points")` |
#' | - Any difference in key antimicrobial results | - `first_isolate(x, type = "keyantimicrobials")` |
#'
#'
#' ### Isolate-based
#'
#'
#' This method does not require any selection, as all isolates should be included. It does, however, respect all arguments set in the [first_isolate()] function. For example, the default setting for `include_unknown` (`FALSE`) will omit selection of rows without a microbial ID.
#'
#'
#' ### Patient-based
#'
#'
#' To include every genus-species combination per patient once, set the `episode_days` to `Inf`. Although often inappropriate, this method makes sure that no duplicate isolates are selected from the same patient. In a large longitudinal data set, this could mean that isolates are *excluded* that were found years after the initial isolate.
#'
#'
#' ### Episode-based
#'
#'
#' To include every genus-species combination per patient episode once, set the `episode_days` to a sensible number of days. Depending on the type of analysis, this could be 14, 30, 60 or 365. Short episodes are common for analysing specific hospital or ward data, long episodes are common for analysing regional and national data.
#'
#'
#' This is the most common method to correct for duplicate isolates. Patients are categorised into episodes based on their ID and dates (e.g., the date of specimen receipt or laboratory result). While this is a common method, it does not take into account antimicrobial test results. This means that e.g. a methicillin-resistant *Staphylococcus aureus* (MRSA) isolate cannot be differentiated from a wildtype *Staphylococcus aureus* isolate.
#'
#'
#' ### Phenotype-based
#'
#'
#' This is a more reliable method, since it also *weighs* the antibiogram (antimicrobial test results) yielding so-called 'first weighted isolates'. There are two different methods to weigh the antibiogram:
#'
#'
#' 1. Using `type = "points"` and argument `points_threshold` (default)
#'
#'
#' This method weighs *all* antimicrobial agents available in the data set. Any difference from I to S or R (or vice versa) counts as `0.5` points, a difference from S to R (or vice versa) counts as `1` point. When the sum of points exceeds `points_threshold`, which defaults to `2`, an isolate will be selected as a first weighted isolate.
#'
#'
#' All antimicrobials are internally selected using the [all_antimicrobials()] function. The output of this function does not need to be passed to the [first_isolate()] function.
#'
#'
#'
#'
#' 2. Using `type = "keyantimicrobials"` and argument `ignore_I`
#'
#' This method only weighs specific antimicrobial agents, called *key antimicrobials*. Any difference from S to R (or vice versa) in these key antimicrobials will select an isolate as a first weighted isolate. With `ignore_I = FALSE`, also differences from I to S or R (or vice versa) will lead to this.
#'
#'
#' This method only weighs specific antimicrobial agents, called *key antimicrobials*. Any difference from S to R (or vice versa) in these key antimicrobials will select an isolate as a first weighted isolate. With `ignore_I = FALSE`, also differences from I to S or R (or vice versa) will lead to this.
#'
#' Key antimicrobials are internally selected using the [key_antimicrobials()] function, but can also be added manually as a variable to the data and set in the `col_keyantimicrobials` argument. Another option is to pass the output of the [key_antimicrobials()] function directly to the `col_keyantimicrobials` argument.
#'
#'
#'
#'
#' The default method is phenotype-based (using `type = "points"`) and episode-based (using `episode_days = 365`). This makes sure that every genus-species combination is selected per patient once per year, while taking into account all antimicrobial test results. If no antimicrobial test results are available in the data set, only the episode-based method is applied at default.
#' @rdname first_isolate
#' @seealso [key_antimicrobials()]
#' @export
#' @return A [logical] vector
#' @source Methodology of this function is strictly based on:
#'
#'
#' - **M39 Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data, 4th Edition**, 2014, *Clinical and Laboratory Standards Institute (CLSI)*. <https://clsi.org/standards/products/microbiology/documents/m39/>.
#'
#'
#' - Hindler JF and Stelling J (2007). **Analysis and Presentation of Cumulative Antibiograms: A New Consensus Guideline from the Clinical and Laboratory Standards Institute.** Clinical Infectious Diseases, 44(6), 867-873. \doi{10.1086/511864}
#' @examples
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#'
#' example_isolates[first_isolate(), ]
#' \donttest{
#' # get all first Gram-negatives
@@ -138,22 +138,20 @@
#' # filter on first isolates using dplyr:
#' example_isolates %>%
#' 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) %>%
#' mutate(first = first_isolate()) %>%
#' select(ward, date, patient, mo, first)
#'
#' # flag the first isolates per group:
#' example_isolates %>%
#' group_by(ward) %>%
#' mutate(first = first_isolate()) %>%
#' select(ward, date, patient, mo, first)
#' }
#' }
first_isolate <- function(x = NULL,
@@ -176,7 +174,6 @@ first_isolate <- function(x = NULL,
include_unknown = FALSE,
include_untested_rsi = TRUE,
...) {
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old arguments
@@ -188,7 +185,7 @@ first_isolate <- function(x = NULL,
col_keyantimicrobials <- dots[which(dots.names == "col_keyantibiotics")]
}
}
if (is_null_or_grouped_tbl(x)) {
# when `x` is left blank, auto determine it (get_current_data() also contains dplyr::cur_data_all())
# is also fix for using a grouped df as input (a dot as first argument)
@@ -240,36 +237,43 @@ first_isolate <- function(x = NULL,
meet_criteria(info, allow_class = "logical", has_length = 1)
meet_criteria(include_unknown, allow_class = "logical", has_length = 1)
meet_criteria(include_untested_rsi, allow_class = "logical", has_length = 1)
# remove data.table, grouping from tibbles, etc.
x <- as.data.frame(x, stringsAsFactors = FALSE)
any_col_contains_rsi <- any(vapply(FUN.VALUE = logical(1),
X = x,
# check only first 10,000 rows
FUN = function(x) any(as.character(x[1:10000]) %in% c("R", "S", "I"), na.rm = TRUE),
USE.NAMES = FALSE))
any_col_contains_rsi <- any(vapply(
FUN.VALUE = logical(1),
X = x,
# check only first 10,000 rows
FUN = function(x) any(as.character(x[1:10000]) %in% c("R", "S", "I"), na.rm = TRUE),
USE.NAMES = FALSE
))
if (method == "phenotype-based" & !any_col_contains_rsi) {
method <- "episode-based"
}
if (info == TRUE & 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
)
}
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = info)
stop_if(is.null(col_mo), "`col_mo` must be set")
}
# methods ----
if (method == "isolate-based") {
episode_days <- Inf
@@ -300,13 +304,13 @@ first_isolate <- function(x = NULL,
}
}
}
# -- date
if (is.null(col_date)) {
col_date <- search_type_in_df(x = x, type = "date", info = info)
stop_if(is.null(col_date), "`col_date` must be set")
}
# -- patient id
if (is.null(col_patient_id)) {
if (all(c("First name", "Last name", "Sex") %in% colnames(x))) {
@@ -324,78 +328,86 @@ first_isolate <- function(x = NULL,
if (is.null(col_specimen) & !is.null(specimen_group)) {
col_specimen <- search_type_in_df(x = x, type = "specimen", info = info)
}
# check if columns exist
check_columns_existance <- function(column, tblname = x) {
if (!is.null(column)) {
stop_ifnot(column %in% colnames(tblname),
"Column '", column, "' not found.", call = FALSE)
"Column '", column, "' not found.",
call = FALSE
)
}
}
check_columns_existance(col_date)
check_columns_existance(col_patient_id)
check_columns_existance(col_mo)
check_columns_existance(col_testcode)
check_columns_existance(col_keyantimicrobials)
# convert dates to Date
dates <- as.Date(x[, col_date, drop = TRUE])
dates[is.na(dates)] <- as.Date("1970-01-01")
x[, col_date] <- dates
# create original row index
x$newvar_row_index <- seq_len(nrow(x))
x$newvar_mo <- as.mo(x[, col_mo, drop = TRUE])
x$newvar_genus_species <- paste(mo_genus(x$newvar_mo), mo_species(x$newvar_mo))
x$newvar_date <- x[, col_date, drop = TRUE]
x$newvar_patient_id <- x[, col_patient_id, drop = TRUE]
if (is.null(col_testcode)) {
testcodes_exclude <- NULL
}
# remove testcodes
if (!is.null(testcodes_exclude) & info == TRUE & message_not_thrown_before("first_isolate", "excludingtestcodes")) {
message_("Excluding test codes: ", vector_and(testcodes_exclude, quotes = TRUE),
add_fn = font_black,
as_note = FALSE)
add_fn = font_black,
as_note = FALSE
)
}
if (is.null(col_specimen)) {
specimen_group <- NULL
}
# filter on specimen group and keyantibiotics when they are filled in
if (!is.null(specimen_group)) {
check_columns_existance(col_specimen, x)
if (info == TRUE & message_not_thrown_before("first_isolate", "excludingspecimen")) {
message_("Excluding other than specimen group '", specimen_group, "'",
add_fn = font_black,
as_note = FALSE)
add_fn = font_black,
as_note = FALSE
)
}
}
if (!is.null(col_keyantimicrobials)) {
x$newvar_key_ab <- x[, col_keyantimicrobials, drop = TRUE]
}
if (is.null(testcodes_exclude)) {
testcodes_exclude <- ""
}
# arrange data to the right sorting
if (is.null(specimen_group)) {
x <- x[order(x$newvar_patient_id,
x$newvar_genus_species,
x$newvar_date), ]
x <- x[order(
x$newvar_patient_id,
x$newvar_genus_species,
x$newvar_date
), ]
rownames(x) <- NULL
row.start <- 1
row.end <- nrow(x)
} else {
# filtering on specimen and only analyse these rows to save time
x <- x[order(pm_pull(x, col_specimen),
x$newvar_patient_id,
x$newvar_genus_species,
x$newvar_date), ]
x <- x[order(
pm_pull(x, col_specimen),
x$newvar_patient_id,
x$newvar_genus_species,
x$newvar_date
), ]
rownames(x) <- NULL
suppressWarnings(
row.start <- which(x %pm>% pm_pull(col_specimen) == specimen_group) %pm>% min(na.rm = TRUE)
@@ -404,95 +416,111 @@ first_isolate <- function(x = NULL,
row.end <- which(x %pm>% pm_pull(col_specimen) == specimen_group) %pm>% max(na.rm = TRUE)
)
}
# speed up - return immediately if obvious
if (abs(row.start) == Inf | abs(row.end) == Inf) {
if (info == TRUE) {
message_("=> Found ", font_bold("no isolates"),
add_fn = font_black,
as_note = FALSE)
add_fn = font_black,
as_note = FALSE
)
}
return(rep(FALSE, nrow(x)))
}
if (row.start == row.end) {
if (info == TRUE) {
message_("=> Found ", font_bold("1 first isolate"), ", as the data only contained 1 row",
add_fn = font_black,
as_note = FALSE)
message_("=> Found ", font_bold("1 first isolate"), ", as the data only contained 1 row",
add_fn = font_black,
as_note = FALSE
)
}
return(TRUE)
}
if (length(c(row.start:row.end)) == pm_n_distinct(x[c(row.start:row.end), col_mo, drop = TRUE])) {
if (info == TRUE) {
message_("=> Found ", font_bold(paste(length(c(row.start:row.end)), "first isolates")),
", as all isolates were different microbial species",
add_fn = font_black,
as_note = FALSE)
", as all isolates were different microbial species",
add_fn = font_black,
as_note = FALSE
)
}
return(rep(TRUE, length(c(row.start:row.end))))
}
# did find some isolates - add new index numbers of rows
x$newvar_row_index_sorted <- seq_len(nrow(x))
scope.size <- nrow(x[which(x$newvar_row_index_sorted %in% c(row.start + 1:row.end) &
!is.na(x$newvar_mo)), , drop = FALSE])
!is.na(x$newvar_mo)), , drop = FALSE])
# Analysis of first isolate ----
if (!is.null(col_keyantimicrobials)) {
if (info == TRUE & message_not_thrown_before("first_isolate", "type")) {
if (type == "keyantimicrobials") {
message_("Basing inclusion on key antimicrobials, ",
ifelse(ignore_I == FALSE, "not ", ""),
"ignoring I",
add_fn = font_black,
as_note = FALSE)
ifelse(ignore_I == FALSE, "not ", ""),
"ignoring I",
add_fn = font_black,
as_note = FALSE
)
}
if (type == "points") {
message_("Basing inclusion on all antimicrobial results, using a points threshold of ",
points_threshold,
add_fn = font_black,
as_note = FALSE)
points_threshold,
add_fn = font_black,
as_note = FALSE
)
}
}
}
x$other_pat_or_mo <- ifelse(x$newvar_patient_id == pm_lag(x$newvar_patient_id) &
x$newvar_genus_species == pm_lag(x$newvar_genus_species),
FALSE,
TRUE)
x$newvar_genus_species == pm_lag(x$newvar_genus_species),
FALSE,
TRUE
)
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)) {
# with key antibiotics
x$other_key_ab <- !antimicrobials_equal(y = x$newvar_key_ab,
z = pm_lag(x$newvar_key_ab),
type = type,
ignore_I = ignore_I,
points_threshold = points_threshold)
x$newvar_first_isolate <- pm_if_else(x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab),
TRUE,
FALSE)
x$other_key_ab <- !antimicrobials_equal(
y = x$newvar_key_ab,
z = pm_lag(x$newvar_key_ab),
type = type,
ignore_I = ignore_I,
points_threshold = points_threshold
)
x$newvar_first_isolate <- pm_if_else(
x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago | x$other_key_ab),
TRUE,
FALSE
)
} else {
# no key antibiotics
x$newvar_first_isolate <- pm_if_else(x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago),
TRUE,
FALSE)
x$newvar_first_isolate <- pm_if_else(
x$newvar_row_index_sorted >= row.start &
x$newvar_row_index_sorted <= row.end &
x$newvar_genus_species != "" &
(x$other_pat_or_mo | x$more_than_episode_ago),
TRUE,
FALSE
)
}
# first one as TRUE
x[row.start, "newvar_first_isolate"] <- TRUE
# no tests that should be included, or ICU
@@ -502,19 +530,21 @@ first_isolate <- function(x = NULL,
if (!is.null(col_icu)) {
if (icu_exclude == TRUE) {
message_("Excluding ", format(sum(!col_icu, na.rm = TRUE), big.mark = ","), " isolates from ICU.",
add_fn = font_black,
as_note = FALSE)
add_fn = font_black,
as_note = FALSE
)
x[which(col_icu), "newvar_first_isolate"] <- FALSE
} else {
message_("Including isolates from ICU.",
add_fn = font_black,
as_note = FALSE)
add_fn = font_black,
as_note = FALSE
)
}
}
decimal.mark <- getOption("OutDec")
big.mark <- ifelse(decimal.mark != ",", ",", ".")
if (info == TRUE) {
# print group name if used in dplyr::group_by()
cur_group <- import_fn("cur_group", "dplyr", error_on_fail = FALSE)
@@ -532,41 +562,50 @@ first_isolate <- function(x = NULL,
}
})
message_("\nGroup: ", paste0(names(group), " = ", group, collapse = ", "), "\n",
as_note = FALSE,
add_fn = font_red)
as_note = FALSE,
add_fn = font_red
)
}
}
}
# handle empty microorganisms
if (any(x$newvar_mo == "UNKNOWN", na.rm = TRUE) & info == TRUE) {
message_(ifelse(include_unknown == TRUE, "Included ", "Excluded "),
format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark),
" isolates with a microbial ID 'UNKNOWN' (in column '", font_bold(col_mo), "')")
message_(
ifelse(include_unknown == TRUE, "Included ", "Excluded "),
format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark
),
" isolates with a microbial ID 'UNKNOWN' (in column '", font_bold(col_mo), "')"
)
}
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
# exclude all NAs
if (any(is.na(x$newvar_mo)) & info == TRUE) {
message_("Excluded ", format(sum(is.na(x$newvar_mo), na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark),
" isolates with a microbial ID 'NA' (in column '", font_bold(col_mo), "')")
message_(
"Excluded ", format(sum(is.na(x$newvar_mo), na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark
),
" isolates with a microbial ID 'NA' (in column '", font_bold(col_mo), "')"
)
}
x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE
# handle isolates without antibiogram
if (include_untested_rsi == FALSE && any(is.rsi(x))) {
rsi_all_NA <- which(unname(vapply(FUN.VALUE = logical(1),
as.data.frame(t(x[, is.rsi(x), drop = FALSE])),
function(rsi_values) all(is.na(rsi_values)))))
rsi_all_NA <- which(unname(vapply(
FUN.VALUE = logical(1),
as.data.frame(t(x[, is.rsi(x), drop = FALSE])),
function(rsi_values) all(is.na(rsi_values))
)))
x[rsi_all_NA, "newvar_first_isolate"] <- FALSE
}
# arrange back according to original sorting again
x <- x[order(x$newvar_row_index), , drop = FALSE]
rownames(x) <- NULL
if (info == TRUE) {
n_found <- sum(x$newvar_first_isolate, na.rm = TRUE)
p_found_total <- percentage(n_found / nrow(x[which(!is.na(x$newvar_mo)), , drop = FALSE]), digits = 1)
@@ -579,20 +618,25 @@ 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 "),
""),
p_found_total, " of total where a microbial ID was available)"),
add_fn = font_black, as_note = FALSE)
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)"
),
add_fn = font_black, as_note = FALSE
)
}
x$newvar_first_isolate
}
#' @rdname first_isolate
@@ -616,14 +660,16 @@ filter_first_isolate <- function(x = NULL,
meet_criteria(episode_days, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = FALSE)
method <- coerce_method(method)
meet_criteria(method, allow_class = "character", has_length = 1, is_in = c("phenotype-based", "episode-based", "patient-based", "isolate-based"))
subset(x, first_isolate(x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
episode_days = episode_days,
method = method,
...))
subset(x, first_isolate(
x = x,
col_date = col_date,
col_patient_id = col_patient_id,
col_mo = col_mo,
episode_days = episode_days,
method = method,
...
))
}
coerce_method <- function(method) {

98
R/g.test.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -36,7 +36,7 @@
#' In the contingency table case simulation is done by random sampling from the set of all contingency tables with given marginals, and works only if the marginals are strictly positive. Note that this is not the usual sampling situation assumed for a chi-squared test (such as the *G*-test) but rather that for Fisher's exact test.
#'
#' In the goodness-of-fit case simulation is done by random sampling from the discrete distribution specified by `p`, each sample being of size `n = sum(x)`. This simulation is done in \R and may be slow.
#'
#'
#' ## *G*-test Of Goodness-of-Fit (Likelihood Ratio Test)
#' Use the *G*-test of goodness-of-fit when you have one nominal variable with two or more values (such as male and female, or red, pink and white flowers). You compare the observed counts of numbers of observations in each category with the expected counts, which you calculate using some kind of theoretical expectation (such as a 1:1 sex ratio or a 1:2:1 ratio in a genetic cross).
#'
@@ -57,9 +57,9 @@
#' Unlike the exact test of goodness-of-fit ([fisher.test()]), the *G*-test does not directly calculate the probability of obtaining the observed results or something more extreme. Instead, like almost all statistical tests, the *G*-test has an intermediate step; it uses the data to calculate a test statistic that measures how far the observed data are from the null expectation. You then use a mathematical relationship, in this case the chi-square distribution, to estimate the probability of obtaining that value of the test statistic.
#'
#' The *G*-test uses the log of the ratio of two likelihoods as the test statistic, which is why it is also called a likelihood ratio test or log-likelihood ratio test. The formula to calculate a *G*-statistic is:
#'
#'
#' \eqn{G = 2 * sum(x * log(x / E))}
#'
#'
#' where `E` are the expected values. Since this is chi-square distributed, the p value can be calculated in \R with:
#' ```
#' p <- stats::pchisq(G, df, lower.tail = FALSE)
@@ -111,92 +111,112 @@ g.test <- function(x,
p = rep(1 / length(x), length(x)),
rescale.p = FALSE) {
DNAME <- deparse(substitute(x))
if (is.data.frame(x))
if (is.data.frame(x)) {
x <- as.matrix(x)
}
if (is.matrix(x)) {
if (min(dim(x)) == 1L)
if (min(dim(x)) == 1L) {
x <- as.vector(x)
}
}
if (!is.matrix(x) && !is.null(y)) {
if (length(x) != length(y))
if (length(x) != length(y)) {
stop("'x' and 'y' must have the same length")
}
DNAME2 <- deparse(substitute(y))
xname <- if (length(DNAME) > 1L || nchar(DNAME, "w") >
30)
30) {
""
else DNAME
} else {
DNAME
}
yname <- if (length(DNAME2) > 1L || nchar(DNAME2, "w") >
30)
30) {
""
else DNAME2
} else {
DNAME2
}
OK <- complete.cases(x, y)
x <- factor(x[OK])
y <- factor(y[OK])
if ((nlevels(x) < 2L) || (nlevels(y) < 2L))
if ((nlevels(x) < 2L) || (nlevels(y) < 2L)) {
stop("'x' and 'y' must have at least 2 levels")
}
x <- table(x, y)
names(dimnames(x)) <- c(xname, yname)
DNAME <- paste(paste(DNAME, collapse = "\n"), "and",
paste(DNAME2, collapse = "\n"))
DNAME <- paste(
paste(DNAME, collapse = "\n"), "and",
paste(DNAME2, collapse = "\n")
)
}
if (any(x < 0) || any(is.na((x)))) # this last one was anyNA, but only introduced in R 3.1.0
if (any(x < 0) || any(is.na((x)))) { # this last one was anyNA, but only introduced in R 3.1.0
stop("all entries of 'x' must be nonnegative and finite")
if ((n <- sum(x)) == 0)
}
if ((n <- sum(x)) == 0) {
stop("at least one entry of 'x' must be positive")
}
if (is.matrix(x)) {
METHOD <- "G-test of independence"
nr <- as.integer(nrow(x))
nc <- as.integer(ncol(x))
if (is.na(nr) || is.na(nc) || is.na(nr * nc))
if (is.na(nr) || is.na(nc) || is.na(nr * nc)) {
stop("invalid nrow(x) or ncol(x)", domain = NA)
}
# add fisher.test suggestion
if (nr == 2 && nc == 2)
if (nr == 2 && nc == 2) {
warning("`fisher.test()` is always more reliable for 2x2 tables and although much slower, often only takes seconds.")
}
sr <- rowSums(x)
sc <- colSums(x)
E <- outer(sr, sc, "*") / n
v <- function(r, c, n) c * r * (n - r) * (n - c) / n ^ 3
v <- function(r, c, n) c * r * (n - r) * (n - c) / n^3
V <- outer(sr, sc, v, n)
dimnames(E) <- dimnames(x)
STATISTIC <- 2 * sum(x * log(x / E)) # sum((abs(x - E) - YATES)^2/E) for chisq.test
PARAMETER <- (nr - 1L) * (nc - 1L)
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
}
else {
if (length(dim(x)) > 2L)
} else {
if (length(dim(x)) > 2L) {
stop("invalid 'x'")
if (length(x) == 1L)
}
if (length(x) == 1L) {
stop("'x' must at least have 2 elements")
if (length(x) != length(p))
}
if (length(x) != length(p)) {
stop("'x' and 'p' must have the same number of elements")
if (any(p < 0))
}
if (any(p < 0)) {
stop("probabilities must be non-negative.")
}
if (abs(sum(p) - 1) > sqrt(.Machine$double.eps)) {
if (rescale.p)
if (rescale.p) {
p <- p / sum(p)
else stop("probabilities must sum to 1.")
} else {
stop("probabilities must sum to 1.")
}
}
METHOD <- "G-test of goodness-of-fit (likelihood ratio test)"
E <- n * p
V <- n * p * (1 - p)
STATISTIC <- 2 * sum(x * log(x / E)) # sum((x - E)^2/E) for chisq.test
names(E) <- names(x)
PARAMETER <- length(x) - 1
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
}
names(STATISTIC) <- "X-squared"
names(PARAMETER) <- "df"
if (any(E < 5) && is.finite(PARAMETER))
if (any(E < 5) && is.finite(PARAMETER)) {
warning("G-statistic approximation may be incorrect due to E < 5")
structure(list(statistic = STATISTIC, argument = PARAMETER,
p.value = PVAL, method = METHOD, data.name = DNAME,
observed = x, expected = E, residuals = (x - E) / sqrt(E),
stdres = (x - E) / sqrt(V)), class = "htest")
}
structure(list(
statistic = STATISTIC, argument = PARAMETER,
p.value = PVAL, method = METHOD, data.name = DNAME,
observed = x, expected = E, residuals = (x - E) / sqrt(E),
stdres = (x - E) / sqrt(V)
), class = "htest")
}

302
R/ggplot_pca.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -48,8 +48,8 @@
#' @param base_textsize the text size for all plot elements except the labels and arrows
#' @param ... arguments passed on to functions
#' @source The [ggplot_pca()] function is based on the `ggbiplot()` function from the `ggbiplot` package by Vince Vu, as found on GitHub: <https://github.com/vqv/ggbiplot> (retrieved: 2 March 2020, their latest commit: [`7325e88`](https://github.com/vqv/ggbiplot/commit/7325e880485bea4c07465a0304c470608fffb5d9); 12 February 2015).
#'
#' As per their GPL-2 licence that demands documentation of code changes, the changes made based on the source code were:
#'
#' As per their GPL-2 licence that demands documentation of code changes, the changes made based on the source code were:
#' 1. Rewritten code to remove the dependency on packages `plyr`, `scales` and `grid`
#' 2. Parametrised more options, like arrow and ellipse settings
#' 3. Hardened all input possibilities by defining the exact type of user input for every argument
@@ -59,30 +59,32 @@
#' @details The colours for labels and points can be changed by adding another scale layer for colour, such as `scale_colour_viridis_d()` and `scale_colour_brewer()`.
#' @rdname ggplot_pca
#' @export
#' @examples
#' @examples
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#' \donttest{
#' if (require("dplyr")) {
#' # calculate the resistance per group first
#' resistance_data <- example_isolates %>%
#' group_by(order = mo_order(mo), # group on anything, like order
#' genus = mo_genus(mo)) %>% # and genus as we do here;
#' filter(n() >= 30) %>% # filter on only 30 results per group
#' summarise_if(is.rsi, resistance) # then get resistance of all drugs
#'
#' # calculate the resistance per group first
#' resistance_data <- example_isolates %>%
#' group_by(
#' order = mo_order(mo), # group on anything, like order
#' genus = mo_genus(mo)
#' ) %>% # and genus as we do here;
#' filter(n() >= 30) %>% # filter on only 30 results per group
#' summarise_if(is.rsi, resistance) # then get resistance of all drugs
#'
#' # now conduct PCA for certain antimicrobial agents
#' pca_result <- resistance_data %>%
#' pca(AMC, CXM, CTX, CAZ, GEN, TOB, TMP, SXT)
#'
#' pca_result <- resistance_data %>%
#' pca(AMC, CXM, CTX, CAZ, GEN, TOB, TMP, SXT)
#'
#' summary(pca_result)
#'
#'
#' # old base R plotting method:
#' biplot(pca_result)
#' # new ggplot2 plotting method using this package:
#' ggplot_pca(pca_result)
#'
#'
#' if (require("ggplot2")) {
#' ggplot_pca(pca_result) +
#' scale_colour_viridis_d() +
@@ -112,7 +114,6 @@ ggplot_pca <- function(x,
arrows_alpha = 0.75,
base_textsize = 10,
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(x, allow_class = c("prcomp", "princomp", "PCA", "lda"))
meet_criteria(choices, allow_class = c("numeric", "integer"), has_length = 2, is_positive = TRUE, is_finite = TRUE)
@@ -135,17 +136,19 @@ ggplot_pca <- function(x,
meet_criteria(arrows_textangled, allow_class = "logical", has_length = 1)
meet_criteria(arrows_alpha, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(base_textsize, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
calculations <- pca_calculations(pca_model = x,
groups = groups,
groups_missing = missing(groups),
labels = labels,
labels_missing = missing(labels),
choices = choices,
scale = scale,
pc.biplot = pc.biplot,
ellipse_prob = ellipse_prob,
labels_text_placement = labels_text_placement)
calculations <- pca_calculations(
pca_model = x,
groups = groups,
groups_missing = missing(groups),
labels = labels,
labels_missing = missing(labels),
choices = choices,
scale = scale,
pc.biplot = pc.biplot,
ellipse_prob = ellipse_prob,
labels_text_placement = labels_text_placement
)
choices <- calculations$choices
df.u <- calculations$df.u
df.v <- calculations$df.v
@@ -153,111 +156,141 @@ ggplot_pca <- function(x,
groups <- calculations$groups
group_name <- calculations$group_name
labels <- calculations$labels
# Append the proportion of explained variance to the axis labels
if ((1 - as.integer(scale)) == 0) {
u.axis.labs <- paste0("Standardised PC", choices)
} else {
u.axis.labs <- paste0("PC", choices)
}
u.axis.labs <- paste0(u.axis.labs,
paste0("\n(explained var: ",
percentage(x$sdev[choices] ^ 2 / sum(x$sdev ^ 2)),
")"))
u.axis.labs <- paste0(
u.axis.labs,
paste0(
"\n(explained var: ",
percentage(x$sdev[choices]^2 / sum(x$sdev^2)),
")"
)
)
# Score Labels
if (!is.null(labels)) {
df.u$labels <- labels
}
# Grouping variable
if (!is.null(groups)) {
df.u$groups <- groups
}
# Base plot
g <- ggplot2::ggplot(data = df.u,
ggplot2::aes(x = xvar, y = yvar)) +
ggplot2::xlab(u.axis.labs[1]) +
ggplot2::ylab(u.axis.labs[2]) +
ggplot2::expand_limits(x = c(-1.15, 1.15),
y = c(-1.15, 1.15))
g <- ggplot2::ggplot(
data = df.u,
ggplot2::aes(x = xvar, y = yvar)
) +
ggplot2::xlab(u.axis.labs[1]) +
ggplot2::ylab(u.axis.labs[2]) +
ggplot2::expand_limits(
x = c(-1.15, 1.15),
y = c(-1.15, 1.15)
)
# Draw either labels or points
if (!is.null(df.u$labels)) {
if (!is.null(df.u$groups)) {
g <- g + ggplot2::geom_point(ggplot2::aes(colour = groups),
alpha = points_alpha,
size = points_size) +
alpha = points_alpha,
size = points_size
) +
ggplot2::geom_text(ggplot2::aes(label = labels, colour = groups),
nudge_y = -0.05,
size = labels_textsize) +
nudge_y = -0.05,
size = labels_textsize
) +
ggplot2::labs(colour = group_name)
} else {
g <- g + ggplot2::geom_point(alpha = points_alpha,
size = points_size) +
g <- g + ggplot2::geom_point(
alpha = points_alpha,
size = points_size
) +
ggplot2::geom_text(ggplot2::aes(label = labels),
nudge_y = -0.05,
size = labels_textsize)
nudge_y = -0.05,
size = labels_textsize
)
}
} else {
if (!is.null(df.u$groups)) {
g <- g + ggplot2::geom_point(ggplot2::aes(colour = groups),
alpha = points_alpha,
size = points_size) +
alpha = points_alpha,
size = points_size
) +
ggplot2::labs(colour = group_name)
} else {
g <- g + ggplot2::geom_point(alpha = points_alpha,
size = points_size)
g <- g + ggplot2::geom_point(
alpha = points_alpha,
size = points_size
)
}
}
# Overlay a concentration ellipse if there are groups
if (!is.null(df.u$groups) & !is.null(ell) & isTRUE(ellipse)) {
g <- g + ggplot2::geom_path(data = ell,
ggplot2::aes(colour = groups, group = groups),
size = ellipse_size,
alpha = points_alpha)
g <- g + ggplot2::geom_path(
data = ell,
ggplot2::aes(colour = groups, group = groups),
size = ellipse_size,
alpha = points_alpha
)
}
# Label the variable axes
if (arrows == TRUE) {
g <- g + ggplot2::geom_segment(data = df.v,
ggplot2::aes(x = 0, y = 0, xend = xvar, yend = yvar),
arrow = ggplot2::arrow(length = ggplot2::unit(0.5, "picas"),
angle = 20,
ends = "last",
type = "open"),
colour = arrows_colour,
size = arrows_size,
alpha = arrows_alpha)
g <- g + ggplot2::geom_segment(
data = df.v,
ggplot2::aes(x = 0, y = 0, xend = xvar, yend = yvar),
arrow = ggplot2::arrow(
length = ggplot2::unit(0.5, "picas"),
angle = 20,
ends = "last",
type = "open"
),
colour = arrows_colour,
size = arrows_size,
alpha = arrows_alpha
)
if (arrows_textangled == TRUE) {
g <- g + ggplot2::geom_text(data = df.v,
ggplot2::aes(label = varname, x = xvar, y = yvar, angle = angle, hjust = hjust),
colour = arrows_colour,
size = arrows_textsize,
alpha = arrows_alpha)
g <- g + ggplot2::geom_text(
data = df.v,
ggplot2::aes(label = varname, x = xvar, y = yvar, angle = angle, hjust = hjust),
colour = arrows_colour,
size = arrows_textsize,
alpha = arrows_alpha
)
} else {
g <- g + ggplot2::geom_text(data = df.v,
ggplot2::aes(label = varname, x = xvar, y = yvar, hjust = hjust),
colour = arrows_colour,
size = arrows_textsize,
alpha = arrows_alpha)
g <- g + ggplot2::geom_text(
data = df.v,
ggplot2::aes(label = varname, x = xvar, y = yvar, hjust = hjust),
colour = arrows_colour,
size = arrows_textsize,
alpha = arrows_alpha
)
}
}
# Add caption label about total explained variance
g <- g + ggplot2::labs(caption = paste0("Total explained variance: ",
percentage(sum(x$sdev[choices] ^ 2 / sum(x$sdev ^ 2)))))
g <- g + ggplot2::labs(caption = paste0(
"Total explained variance: ",
percentage(sum(x$sdev[choices]^2 / sum(x$sdev^2)))
))
# mark-up nicely
g <- g + ggplot2::theme_minimal(base_size = base_textsize) +
ggplot2::theme(panel.grid.major = ggplot2::element_line(colour = "grey85"),
panel.grid.minor = ggplot2::element_blank(),
# centre title and subtitle
plot.title = ggplot2::element_text(hjust = 0.5),
plot.subtitle = ggplot2::element_text(hjust = 0.5))
ggplot2::theme(
panel.grid.major = ggplot2::element_line(colour = "grey85"),
panel.grid.minor = ggplot2::element_blank(),
# centre title and subtitle
plot.title = ggplot2::element_text(hjust = 0.5),
plot.subtitle = ggplot2::element_text(hjust = 0.5)
)
g
}
@@ -272,17 +305,19 @@ pca_calculations <- function(pca_model,
pc.biplot = TRUE,
ellipse_prob = 0.68,
labels_text_placement = 1.5) {
non_numeric_cols <- attributes(pca_model)$non_numeric_cols
if (groups_missing) {
groups <- tryCatch(non_numeric_cols[[1]],
error = function(e) NULL)
error = function(e) NULL
)
group_name <- tryCatch(colnames(non_numeric_cols[1]),
error = function(e) NULL)
error = function(e) NULL
)
}
if (labels_missing) {
labels <- tryCatch(non_numeric_cols[[2]],
error = function(e) NULL)
error = function(e) NULL
)
}
if (!is.null(groups) & is.null(labels)) {
# turn them around
@@ -290,7 +325,7 @@ pca_calculations <- function(pca_model,
groups <- NULL
group_name <- NULL
}
# Recover the SVD
if (inherits(pca_model, "prcomp")) {
nobs.factor <- sqrt(nrow(pca_model$x) - 1)
@@ -315,66 +350,72 @@ pca_calculations <- function(pca_model,
} else {
stop("Expected an object of class prcomp, princomp, PCA, or lda")
}
# Scores
choices <- pmin(choices, ncol(u))
obs.scale <- 1 - as.integer(scale)
df.u <- as.data.frame(sweep(u[, choices], 2, d[choices] ^ obs.scale, FUN = "*"),
stringsAsFactors = FALSE)
df.u <- as.data.frame(sweep(u[, choices], 2, d[choices]^obs.scale, FUN = "*"),
stringsAsFactors = FALSE
)
# Directions
v <- sweep(v, 2, d ^ as.integer(scale), FUN = "*")
v <- sweep(v, 2, d^as.integer(scale), FUN = "*")
df.v <- as.data.frame(v[, choices],
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
names(df.u) <- c("xvar", "yvar")
names(df.v) <- names(df.u)
if (isTRUE(pc.biplot)) {
df.u <- df.u * nobs.factor
}
# Scale the radius of the correlation circle so that it corresponds to
# Scale the radius of the correlation circle so that it corresponds to
# a data ellipse for the standardized PC scores
circle_prob <- 0.69
r <- sqrt(qchisq(circle_prob, df = 2)) * prod(colMeans(df.u ^ 2)) ^ (0.25)
r <- sqrt(qchisq(circle_prob, df = 2)) * prod(colMeans(df.u^2))^(0.25)
# Scale directions
v.scale <- rowSums(v ^ 2)
v.scale <- rowSums(v^2)
df.v <- r * df.v / sqrt(max(v.scale))
# Grouping variable
if (!is.null(groups)) {
df.u$groups <- groups
}
df.v$varname <- rownames(v)
# Variables for text label placement
df.v$angle <- with(df.v, (180 / pi) * atan(yvar / xvar))
df.v$hjust <- with(df.v, (1 - labels_text_placement * sign(xvar)) / 2)
if (!is.null(df.u$groups)) {
theta <- c(seq(-pi, pi, length = 50), seq(pi, -pi, length = 50))
circle <- cbind(cos(theta), sin(theta))
df.groups <- lapply(unique(df.u$groups), function(g, df = df.u) {
x <- df[which(df$groups == g), , drop = FALSE]
if (nrow(x) <= 2) {
return(data.frame(X1 = numeric(0),
X2 = numeric(0),
groups = character(0),
stringsAsFactors = FALSE))
return(data.frame(
X1 = numeric(0),
X2 = numeric(0),
groups = character(0),
stringsAsFactors = FALSE
))
}
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)
MARGIN = 2,
STATS = mu,
FUN = "+"
),
groups = x$groups[1],
stringsAsFactors = FALSE
)
})
ell <- do.call(rbind, df.groups)
if (NROW(ell) == 0) {
@@ -385,13 +426,14 @@ pca_calculations <- function(pca_model,
} else {
ell <- NULL
}
list(choices = choices,
df.u = df.u,
df.v = df.v,
ell = ell,
groups = groups,
group_name = group_name,
labels = labels
list(
choices = choices,
df.u = df.u,
df.v = df.v,
ell = ell,
groups = groups,
group_name = group_name,
labels = labels
)
}

302
R/ggplot_rsi.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -67,14 +67,13 @@
#' @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_rsi()
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#'
#' # prettify the plot using some additional functions:
#' df <- example_isolates %>% select(AMX, NIT, FOS, TMP, CIP)
#' ggplot(df) +
@@ -83,35 +82,33 @@
#' scale_rsi_colours() +
#' labels_rsi_count() +
#' theme_rsi()
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#'
#' # or better yet, simplify this using the wrapper function - a single command:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi()
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#'
#' # get only proportions and no counts:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi(datalabels = FALSE)
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#'
#' # add other ggplot2 arguments as you like:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi(width = 0.5,
#' colour = "black",
#' size = 1,
#' linetype = 2,
#' alpha = 0.25)
#'
#' ggplot_rsi(
#' width = 0.5,
#' colour = "black",
#' size = 1,
#' linetype = 2,
#' alpha = 0.25
#' )
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
@@ -119,55 +116,57 @@
#' example_isolates %>%
#' select(AMX) %>%
#' ggplot_rsi(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(x = c("Value1", "Value2", "Value3"),
#' y = c(1, 2, 3),
#' z = c("Value4", "Value5", "Value6")) %>%
#' data.frame(
#' x = c("Value1", "Value2", "Value3"),
#' y = c(1, 2, 3),
#' z = c("Value4", "Value5", "Value6")
#' ) %>%
#' ggplot() +
#' geom_col(aes(x = x, y = y, fill = z)) +
#' scale_rsi_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()) %>%
#' filter(first_isolate == TRUE,
#' mo == as.mo("Escherichia coli")) %>%
#' filter(
#' first_isolate == TRUE,
#' mo == as.mo("Escherichia coli")
#' ) %>%
#' # age_groups() is also a function in this AMR package:
#' group_by(age_group = age_groups(age)) %>%
#' select(age_group, CIP) %>%
#' ggplot_rsi(x = "age_group")
#'
#' }
#' if (require("ggplot2") && require("dplyr")) {
#'
#'
#' # a shorter version which also adjusts data label colours:
#' example_isolates %>%
#' select(AMX, NIT, FOS, TMP, CIP) %>%
#' ggplot_rsi(colours = FALSE)
#'
#' }
#' 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") %>%
#' filter(mo_is_gram_negative(), ward != "Outpatient") %>%
#' # select only UTI-specific drugs
#' select(ward, AMX, NIT, FOS, TMP, CIP) %>%
#' group_by(ward) %>%
#' ggplot_rsi(x = "ward",
#' facet = "antibiotic",
#' nrow = 1,
#' title = "AMR of Anti-UTI Drugs Per Ward",
#' x.title = "Ward",
#' datalabels = FALSE)
#' ggplot_rsi(
#' x = "ward",
#' facet = "antibiotic",
#' nrow = 1,
#' title = "AMR of Anti-UTI Drugs Per Ward",
#' x.title = "Ward",
#' datalabels = FALSE
#' )
#' }
#' }
ggplot_rsi <- function(data,
@@ -184,11 +183,13 @@ ggplot_rsi <- function(data,
minimum = 30,
language = get_AMR_locale(),
nrow = NULL,
colours = c(S = "#3CAEA3",
SI = "#3CAEA3",
I = "#F6D55C",
IR = "#ED553B",
R = "#ED553B"),
colours = c(
S = "#3CAEA3",
SI = "#3CAEA3",
I = "#F6D55C",
IR = "#ED553B",
R = "#ED553B"
),
datalabels = TRUE,
datalabels.size = 2.5,
datalabels.colour = "grey15",
@@ -198,7 +199,6 @@ ggplot_rsi <- function(data,
x.title = "Antimicrobial",
y.title = "Proportion",
...) {
stop_ifnot_installed("ggplot2")
meet_criteria(data, allow_class = "data.frame", contains_column_class = "rsi")
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
@@ -241,48 +241,54 @@ ggplot_rsi <- function(data,
if (facet %in% c("NULL", "")) {
facet <- NULL
}
if (is.null(position)) {
position <- "fill"
}
p <- ggplot2::ggplot(data = data) +
geom_rsi(position = position, x = x, fill = fill, translate_ab = translate_ab,
minimum = minimum, language = language,
combine_SI = combine_SI, combine_IR = combine_IR, ...) +
geom_rsi(
position = position, x = x, fill = fill, translate_ab = translate_ab,
minimum = minimum, language = language,
combine_SI = combine_SI, combine_IR = combine_IR, ...
) +
theme_rsi()
if (fill == "interpretation") {
p <- p + scale_rsi_colours(colours = colours)
}
if (identical(position, "fill")) {
# proportions, so use y scale with percentage
p <- p + scale_y_percent(breaks = breaks, limits = limits)
}
if (datalabels == TRUE) {
p <- p + labels_rsi_count(position = position,
x = x,
translate_ab = translate_ab,
minimum = minimum,
language = language,
combine_SI = combine_SI,
combine_IR = combine_IR,
datalabels.size = datalabels.size,
datalabels.colour = datalabels.colour)
p <- p + labels_rsi_count(
position = position,
x = x,
translate_ab = translate_ab,
minimum = minimum,
language = language,
combine_SI = combine_SI,
combine_IR = combine_IR,
datalabels.size = datalabels.size,
datalabels.colour = datalabels.colour
)
}
if (!is.null(facet)) {
p <- p + facet_rsi(facet = facet, nrow = nrow)
}
p <- p + ggplot2::labs(title = title,
subtitle = subtitle,
caption = caption,
x = x.title,
y = y.title)
p <- p + ggplot2::labs(
title = title,
subtitle = subtitle,
caption = caption,
x = x.title,
y = y.title
)
p
}
@@ -296,7 +302,7 @@ geom_rsi <- function(position = NULL,
language = get_AMR_locale(),
combine_SI = TRUE,
combine_IR = FALSE,
...) {
...) {
x <- x[1]
stop_ifnot_installed("ggplot2")
stop_if(is.data.frame(position), "`position` is invalid. Did you accidentally use '%>%' instead of '+'?")
@@ -308,16 +314,16 @@ geom_rsi <- function(position = NULL,
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1)
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
y <- "value"
if (missing(position) | is.null(position)) {
position <- "fill"
}
if (identical(position, "fill")) {
position <- ggplot2::position_fill(vjust = 0.5, reverse = TRUE)
}
# we work with aes_string later on
x_deparse <- deparse(substitute(x))
if (x_deparse != "x") {
@@ -326,21 +332,23 @@ geom_rsi <- function(position = NULL,
if (x %like% '".*"') {
x <- substr(x, 2, nchar(x) - 1)
}
if (tolower(x) %in% tolower(c("ab", "abx", "antibiotics"))) {
x <- "antibiotic"
} else if (tolower(x) %in% tolower(c("SIR", "RSI", "interpretations", "result"))) {
x <- "interpretation"
}
ggplot2::geom_col(
data = function(x) {
rsi_df(data = x,
translate_ab = translate_ab,
language = language,
minimum = minimum,
combine_SI = combine_SI,
combine_IR = combine_IR)
rsi_df(
data = x,
translate_ab = translate_ab,
language = language,
minimum = minimum,
combine_SI = combine_SI,
combine_IR = combine_IR
)
},
mapping = ggplot2::aes_string(x = x, y = y, fill = fill),
position = position,
@@ -355,7 +363,7 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
stop_ifnot_installed("ggplot2")
meet_criteria(facet, allow_class = "character", has_length = 1)
meet_criteria(nrow, allow_class = c("numeric", "integer"), has_length = 1, allow_NULL = TRUE, is_positive = TRUE, is_finite = TRUE)
# we work with aes_string later on
facet_deparse <- deparse(substitute(facet))
if (facet_deparse != "facet") {
@@ -364,13 +372,13 @@ facet_rsi <- function(facet = c("interpretation", "antibiotic"), nrow = NULL) {
if (facet %like% '".*"') {
facet <- substr(facet, 2, nchar(facet) - 1)
}
if (tolower(facet) %in% tolower(c("SIR", "RSI", "interpretations", "result"))) {
facet <- "interpretation"
} else if (tolower(facet) %in% tolower(c("ab", "abx", "antibiotics"))) {
facet <- "antibiotic"
}
ggplot2::facet_wrap(facets = facet, scales = "free_x", nrow = nrow)
}
@@ -380,13 +388,15 @@ scale_y_percent <- function(breaks = seq(0, 1, 0.1), limits = NULL) {
stop_ifnot_installed("ggplot2")
meet_criteria(breaks, allow_class = c("numeric", "integer"))
meet_criteria(limits, allow_class = c("numeric", "integer"), has_length = 2, allow_NULL = TRUE, allow_NA = TRUE)
if (all(breaks[breaks != 0] > 1)) {
breaks <- breaks / 100
}
ggplot2::scale_y_continuous(breaks = breaks,
labels = percentage(breaks),
limits = limits)
ggplot2::scale_y_continuous(
breaks = breaks,
labels = percentage(breaks),
limits = limits
)
}
#' @rdname ggplot_rsi
@@ -397,11 +407,13 @@ scale_rsi_colours <- function(...,
meet_criteria(aesthetics, allow_class = "character", is_in = c("alpha", "colour", "color", "fill", "linetype", "shape", "size"))
# behaviour until AMR pkg v1.5.0 and also when coming from ggplot_rsi()
if ("colours" %in% names(list(...))) {
original_cols <- c(S = "#3CAEA3",
SI = "#3CAEA3",
I = "#F6D55C",
IR = "#ED553B",
R = "#ED553B")
original_cols <- c(
S = "#3CAEA3",
SI = "#3CAEA3",
I = "#F6D55C",
IR = "#ED553B",
R = "#ED553B"
)
colours <- replace(original_cols, names(list(...)$colours), list(...)$colours)
# limits = force is needed in ggplot2 3.3.4 and 3.3.5, see here;
# https://github.com/tidyverse/ggplot2/issues/4511#issuecomment-866185530
@@ -410,28 +422,42 @@ scale_rsi_colours <- function(...,
if (identical(unlist(list(...)), FALSE)) {
return(invisible())
}
names_susceptible <- c("S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible"),
"replacement", drop = TRUE]))
names_incr_exposure <- c("I", "intermediate", "increased exposure", "incr. exposure",
"Increased exposure", "Incr. exposure", "Susceptible, incr. exp.",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Intermediate"),
"replacement", drop = TRUE]),
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible, incr. exp."),
"replacement", drop = TRUE]))
names_resistant <- c("R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Resistant"),
"replacement", drop = TRUE]))
names_susceptible <- c(
"S", "SI", "IS", "S+I", "I+S", "susceptible", "Susceptible",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible"),
"replacement",
drop = TRUE
])
)
names_incr_exposure <- c(
"I", "intermediate", "increased exposure", "incr. exposure",
"Increased exposure", "Incr. exposure", "Susceptible, incr. exp.",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Intermediate"),
"replacement",
drop = TRUE
]),
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Susceptible, incr. exp."),
"replacement",
drop = TRUE
])
)
names_resistant <- c(
"R", "IR", "RI", "R+I", "I+R", "resistant", "Resistant",
unique(TRANSLATIONS[which(TRANSLATIONS$pattern == "Resistant"),
"replacement",
drop = TRUE
])
)
susceptible <- rep("#3CAEA3", length(names_susceptible))
names(susceptible) <- names_susceptible
incr_exposure <- rep("#F6D55C", length(names_incr_exposure))
names(incr_exposure) <- names_incr_exposure
resistant <- rep("#ED553B", length(names_resistant))
names(resistant) <- names_resistant
original_cols = c(susceptible, incr_exposure, resistant)
original_cols <- c(susceptible, incr_exposure, resistant)
dots <- c(...)
# replace S, I, R as colours: scale_rsi_colours(mydatavalue = "S")
dots[dots == "S"] <- "#3CAEA3"
@@ -448,12 +474,14 @@ scale_rsi_colours <- function(...,
theme_rsi <- function() {
stop_ifnot_installed("ggplot2")
ggplot2::theme_minimal(base_size = 10) +
ggplot2::theme(panel.grid.major.x = ggplot2::element_blank(),
panel.grid.minor = ggplot2::element_blank(),
panel.grid.major.y = ggplot2::element_line(colour = "grey75"),
# center title and subtitle
plot.title = ggplot2::element_text(hjust = 0.5),
plot.subtitle = ggplot2::element_text(hjust = 0.5))
ggplot2::theme(
panel.grid.major.x = ggplot2::element_blank(),
panel.grid.minor = ggplot2::element_blank(),
panel.grid.major.y = ggplot2::element_line(colour = "grey75"),
# center title and subtitle
plot.title = ggplot2::element_text(hjust = 0.5),
plot.subtitle = ggplot2::element_text(hjust = 0.5)
)
}
#' @rdname ggplot_rsi
@@ -477,7 +505,7 @@ labels_rsi_count <- function(position = NULL,
meet_criteria(combine_IR, allow_class = "logical", has_length = 1)
meet_criteria(datalabels.size, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
meet_criteria(datalabels.colour, allow_class = "character", has_length = 1)
if (is.null(position)) {
position <- "fill"
}
@@ -485,26 +513,32 @@ labels_rsi_count <- function(position = NULL,
position <- ggplot2::position_fill(vjust = 0.5, reverse = TRUE)
}
x_name <- x
ggplot2::geom_text(mapping = ggplot2::aes_string(label = "lbl",
x = x,
y = "value"),
position = position,
inherit.aes = FALSE,
size = datalabels.size,
colour = datalabels.colour,
lineheight = 0.75,
data = function(x) {
transformed <- rsi_df(data = x,
translate_ab = translate_ab,
combine_SI = combine_SI,
combine_IR = combine_IR,
minimum = minimum,
language = language)
transformed$gr <- transformed[, x_name, drop = TRUE]
transformed %pm>%
pm_group_by(gr) %pm>%
pm_mutate(lbl = paste0("n=", isolates)) %pm>%
pm_ungroup() %pm>%
pm_select(-gr)
})
ggplot2::geom_text(
mapping = ggplot2::aes_string(
label = "lbl",
x = x,
y = "value"
),
position = position,
inherit.aes = FALSE,
size = datalabels.size,
colour = datalabels.colour,
lineheight = 0.75,
data = function(x) {
transformed <- rsi_df(
data = x,
translate_ab = translate_ab,
combine_SI = combine_SI,
combine_IR = combine_IR,
minimum = minimum,
language = language
)
transformed$gr <- transformed[, x_name, drop = TRUE]
transformed %pm>%
pm_group_by(gr) %pm>%
pm_mutate(lbl = paste0("n=", isolates)) %pm>%
pm_ungroup() %pm>%
pm_select(-gr)
}
)
}

181
R/guess_ab_col.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -34,8 +34,10 @@
#' @return A column name of `x`, or `NULL` when no result is found.
#' @export
#' @examples
#' df <- data.frame(amox = "S",
#' tetr = "R")
#' df <- data.frame(
#' amox = "S",
#' tetr = "R"
#' )
#'
#' guess_ab_col(df, "amoxicillin")
#' # [1] "amox"
@@ -47,8 +49,10 @@
#' # [1] "tetr"
#'
#' # WHONET codes
#' df <- data.frame(AMP_ND10 = "R",
#' AMC_ED20 = "S")
#' df <- data.frame(
#' AMP_ND10 = "R",
#' AMC_ED20 = "S"
#' )
#' guess_ab_col(df, "ampicillin")
#' # [1] "AMP_ND10"
#' guess_ab_col(df, "J01CR02")
@@ -57,8 +61,10 @@
#' # [1] "AMC_ED20"
#'
#' # Longer names take precendence:
#' df <- data.frame(AMP_ED2 = "S",
#' AMP_ED20 = "S")
#' df <- data.frame(
#' AMP_ED2 = "S",
#' AMP_ED20 = "S"
#' )
#' guess_ab_col(df, "ampicillin")
#' # [1] "AMP_ED20"
guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_rsi_columns = FALSE) {
@@ -66,30 +72,35 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_r
meet_criteria(search_string, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(verbose, allow_class = "logical", has_length = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
if (is.null(x) & is.null(search_string)) {
return(as.name("guess_ab_col"))
} else {
meet_criteria(search_string, allow_class = "character", has_length = 1, allow_NULL = FALSE)
}
all_found <- get_column_abx(x, info = verbose, only_rsi_columns = only_rsi_columns,
verbose = verbose, fn = "guess_ab_col")
all_found <- get_column_abx(x,
info = verbose, only_rsi_columns = only_rsi_columns,
verbose = verbose, fn = "guess_ab_col"
)
search_string.ab <- suppressWarnings(as.ab(search_string))
ab_result <- unname(all_found[names(all_found) == search_string.ab])
if (length(ab_result) == 0) {
if (verbose == TRUE) {
message_("No column found as input for ", search_string,
" (", ab_name(search_string, language = NULL, tolower = TRUE), ").",
add_fn = font_black,
as_note = FALSE)
" (", ab_name(search_string, language = NULL, tolower = TRUE), ").",
add_fn = font_black,
as_note = FALSE
)
}
return(NULL)
} else {
if (verbose == TRUE) {
message_("Using column '", font_bold(ab_result), "' as input for ", search_string,
" (", ab_name(search_string, language = NULL, tolower = TRUE), ").")
message_(
"Using column '", font_bold(ab_result), "' as input for ", search_string,
" (", ab_name(search_string, language = NULL, tolower = TRUE), ")."
)
}
return(ab_result)
}
@@ -106,16 +117,20 @@ get_column_abx <- function(x,
reuse_previous_result = TRUE,
fn = NULL) {
# check if retrieved before, then get it from package environment
if (isTRUE(reuse_previous_result) && identical(unique_call_id(entire_session = FALSE,
match_fn = fn),
pkg_env$get_column_abx.call)) {
if (isTRUE(reuse_previous_result) && identical(
unique_call_id(
entire_session = FALSE,
match_fn = fn
),
pkg_env$get_column_abx.call
)) {
# so within the same call, within the same environment, we got here again.
# but we could've come from another function within the same call, so now only check the columns that changed
# first remove the columns that are not existing anymore
previous <- pkg_env$get_column_abx.out
current <- previous[previous %in% colnames(x)]
# then compare columns in current call with columns in original call
new_cols <- colnames(x)[!colnames(x) %in% pkg_env$get_column_abx.checked_cols]
if (length(new_cols) > 0) {
@@ -125,7 +140,7 @@ get_column_abx <- function(x,
# order according to columns in current call
current <- current[match(colnames(x)[colnames(x) %in% current], current)]
}
# update pkg environment to improve speed on next run
pkg_env$get_column_abx.out <- current
pkg_env$get_column_abx.checked_cols <- colnames(x)
@@ -133,7 +148,7 @@ get_column_abx <- function(x,
# and return right values
return(pkg_env$get_column_abx.out)
}
meet_criteria(x, allow_class = "data.frame")
meet_criteria(soft_dependencies, allow_class = "character", allow_NULL = TRUE)
meet_criteria(hard_dependencies, allow_class = "character", allow_NULL = TRUE)
@@ -141,11 +156,11 @@ get_column_abx <- function(x,
meet_criteria(info, allow_class = "logical", has_length = 1)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(sort, allow_class = "logical", has_length = 1)
if (info == TRUE) {
message_("Auto-guessing columns suitable for analysis", appendLF = FALSE, as_note = FALSE)
}
x <- as.data.frame(x, stringsAsFactors = FALSE)
x.bak <- x
if (only_rsi_columns == TRUE) {
@@ -156,8 +171,9 @@ get_column_abx <- function(x,
# only test maximum of 10,000 values per column
if (info == TRUE) {
message_(" (using only ", font_bold("the first 10,000 rows"), ")...",
appendLF = FALSE,
as_note = FALSE)
appendLF = FALSE,
as_note = FALSE
)
}
x <- x[1:10000, , drop = FALSE]
} else if (info == TRUE) {
@@ -165,32 +181,36 @@ get_column_abx <- function(x,
}
# only check columns that are a valid AB code, ATC code, name, abbreviation or synonym,
# or already have the <rsi> class (as.rsi)
# or already have the <rsi> class (as.rsi)
# and that they have no more than 50% invalid values
vectr_antibiotics <- unlist(AB_lookup$generalised_all)
vectr_antibiotics <- vectr_antibiotics[!is.na(vectr_antibiotics) & nchar(vectr_antibiotics) >= 3]
x_columns <- vapply(FUN.VALUE = character(1),
colnames(x),
function(col, df = x) {
if (generalise_antibiotic_name(col) %in% vectr_antibiotics ||
is.rsi(x[, col, drop = TRUE]) ||
is.rsi.eligible(x[, col, drop = TRUE], threshold = 0.5)
) {
return(col)
} else {
return(NA_character_)
}
}, USE.NAMES = FALSE)
x_columns <- vapply(
FUN.VALUE = character(1),
colnames(x),
function(col, df = x) {
if (generalise_antibiotic_name(col) %in% vectr_antibiotics ||
is.rsi(x[, col, drop = TRUE]) ||
is.rsi.eligible(x[, col, drop = TRUE], threshold = 0.5)
) {
return(col)
} else {
return(NA_character_)
}
}, USE.NAMES = FALSE
)
x_columns <- x_columns[!is.na(x_columns)]
x <- x[, x_columns, drop = FALSE] # without drop = FALSE, x will become a vector when x_columns is length 1
df_trans <- data.frame(colnames = colnames(x),
abcode = suppressWarnings(as.ab(colnames(x), info = FALSE)),
stringsAsFactors = FALSE)
df_trans <- data.frame(
colnames = colnames(x),
abcode = suppressWarnings(as.ab(colnames(x), info = FALSE)),
stringsAsFactors = FALSE
)
df_trans <- df_trans[!is.na(df_trans$abcode), , drop = FALSE]
out <- as.character(df_trans$colnames)
names(out) <- df_trans$abcode
# add from self-defined dots (...):
# such as get_column_abx(example_isolates %>% rename(thisone = AMX), amox = "thisone")
all_okay <- TRUE
@@ -204,8 +224,9 @@ get_column_abx <- function(x,
message_(" WARNING", add_fn = list(font_yellow, font_bold), as_note = FALSE)
}
warning_("Invalid antibiotic reference(s): ", vector_and(names(dots)[is.na(newnames)], quotes = FALSE),
call = FALSE,
immediate = TRUE)
call = FALSE,
immediate = TRUE
)
all_okay <- FALSE
}
unexisting_cols <- which(!vapply(FUN.VALUE = logical(1), dots, function(col) all(col %in% x_columns)))
@@ -214,7 +235,8 @@ get_column_abx <- function(x,
message_(" ERROR", add_fn = list(font_red, font_bold), as_note = FALSE)
}
stop_("Column(s) not found: ", vector_and(unlist(dots[[unexisting_cols]]), quotes = FALSE),
call = FALSE)
call = FALSE
)
all_okay <- FALSE
}
# turn all NULLs to NAs
@@ -226,7 +248,7 @@ get_column_abx <- function(x,
# delete NAs, this will make e.g. eucast_rules(... TMP = NULL) work to prevent TMP from being used
out <- out[!is.na(out)]
}
if (length(out) == 0) {
if (info == TRUE & all_okay == TRUE) {
message_("No columns found.")
@@ -236,7 +258,7 @@ get_column_abx <- function(x,
pkg_env$get_column_abx.out <- out
return(out)
}
# sort on name
if (sort == TRUE) {
out <- out[order(names(out), out)]
@@ -246,7 +268,7 @@ get_column_abx <- function(x,
if (length(duplicates) > 0) {
all_okay <- FALSE
}
if (info == TRUE) {
if (all_okay == TRUE) {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE)
@@ -255,27 +277,32 @@ get_column_abx <- function(x,
}
for (i in seq_len(length(out))) {
if (verbose == TRUE & !names(out[i]) %in% names(duplicates)) {
message_("Using column '", font_bold(out[i]), "' as input for ", names(out)[i],
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ").")
message_(
"Using column '", font_bold(out[i]), "' as input for ", names(out)[i],
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")."
)
}
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
)
}
}
}
out <- out[!duplicated(names(out))]
out <- out[!duplicated(unname(out))]
if (sort == TRUE) {
out <- out[order(names(out), out)]
}
if (!is.null(hard_dependencies)) {
hard_dependencies <- unique(hard_dependencies)
if (!all(hard_dependencies %in% names(out))) {
@@ -290,14 +317,19 @@ get_column_abx <- function(x,
if (info == TRUE & !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)
message_("Reliability would be improved if these antimicrobial results would be available too: ",
missing_msg)
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: ",
missing_msg
)
}
}
pkg_env$get_column_abx.call <- unique_call_id(entire_session = FALSE, match_fn = fn)
pkg_env$get_column_abx.checked_cols <- colnames(x.bak)
pkg_env$get_column_abx.out <- out
@@ -306,12 +338,12 @@ get_column_abx <- function(x,
get_ab_from_namespace <- function(x, cols_ab) {
# cols_ab comes from get_column_abx()
x <- trimws(unique(toupper(unlist(strsplit(x, ",")))))
x_new <- character()
for (val in x) {
if (paste0("AB_", val) %in% ls(envir = asNamespace("AMR"))) {
# antibiotic group names, as defined in data-raw/pre-commit-hook.R, such as `AB_CARBAPENEMS`
# antibiotic group names, as defined in data-raw/_pre_commit_hook.R, such as `AB_CARBAPENEMS`
val <- eval(parse(text = paste0("AB_", val)), envir = asNamespace("AMR"))
} else if (val %in% AB_lookup$ab) {
# separate drugs, such as `AMX`
@@ -333,7 +365,10 @@ 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
)
}

127
R/italicise_taxonomy.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -24,21 +24,21 @@
# ==================================================================== #
#' Italicise Taxonomic Families, Genera, Species, Subspecies
#'
#'
#' According to the binomial nomenclature, the lowest four taxonomic levels (family, genus, species, subspecies) should be printed in italics. This function finds taxonomic names within strings and makes them italic.
#' @param string a [character] (vector)
#' @param type type of conversion of the taxonomic names, either "markdown" or "ansi", see *Details*
#' @details
#' @details
#' This function finds the taxonomic names and makes them italic based on the [microorganisms] data set.
#'
#'
#' The taxonomic names can be italicised using markdown (the default) by adding `*` before and after the taxonomic names, or using ANSI colours by adding `\033[3m` before and `\033[23m` after the taxonomic names. If multiple ANSI colours are not available, no conversion will occur.
#'
#'
#' This function also supports abbreviation of the genus if it is followed by a species, such as "E. coli" and "K. pneumoniae ozaenae".
#' @export
#' @examples
#' italicise_taxonomy("An overview of Staphylococcus aureus isolates")
#' italicise_taxonomy("An overview of S. aureus isolates")
#'
#'
#' cat(italicise_taxonomy("An overview of S. aureus isolates", type = "ansi"))
italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
if (missing(type)) {
@@ -46,7 +46,7 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
}
meet_criteria(string, allow_class = "character")
meet_criteria(type, allow_class = "character", has_length = 1, is_in = c("markdown", "ansi"))
if (type == "markdown") {
before <- "*"
after <- "*"
@@ -57,57 +57,70 @@ italicise_taxonomy <- function(string, type = c("markdown", "ansi")) {
before <- "\033[3m"
after <- "\033[23m"
}
vapply(FUN.VALUE = character(1),
string,
function(s) {
s_split <- unlist(strsplit(s, " "))
search_strings <- gsub("[^a-zA-Z-]", "", s_split)
ind_species <- search_strings != "" &
search_strings %in% MO_lookup[which(MO_lookup$rank %in% c("family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp.")),
"species",
drop = TRUE]
ind_fullname <- search_strings != "" &
search_strings %in% c(MO_lookup[which(MO_lookup$rank %in% c("family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp.")),
"fullname",
drop = TRUE],
MO_lookup[which(MO_lookup$rank %in% c("family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp.")),
"subspecies",
drop = TRUE])
# also support E. coli, add "E." to indices
has_previous_genera_abbr <- s_split[which(ind_species) - 1] %like_case% "^[A-Z][.]?$"
ind_species <- c(which(ind_species), which(ind_species)[has_previous_genera_abbr] - 1)
ind <- c(ind_species, which(ind_fullname))
s_split[ind] <- paste0(before, s_split[ind], after)
s_paste <- paste(s_split, collapse = " ")
# clean up a bit
s_paste <- gsub(paste0(after, " ", before), " ", s_paste, fixed = TRUE)
s_paste
},
USE.NAMES = FALSE)
vapply(
FUN.VALUE = character(1),
string,
function(s) {
s_split <- unlist(strsplit(s, " "))
search_strings <- gsub("[^a-zA-Z-]", "", s_split)
ind_species <- search_strings != "" &
search_strings %in% MO_lookup[which(MO_lookup$rank %in% c(
"family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp."
)),
"species",
drop = TRUE
]
ind_fullname <- search_strings != "" &
search_strings %in% c(
MO_lookup[which(MO_lookup$rank %in% c(
"family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp."
)),
"fullname",
drop = TRUE
],
MO_lookup[which(MO_lookup$rank %in% c(
"family",
"genus",
"species",
"subspecies",
"infraspecies",
"subsp."
)),
"subspecies",
drop = TRUE
]
)
# also support E. coli, add "E." to indices
has_previous_genera_abbr <- s_split[which(ind_species) - 1] %like_case% "^[A-Z][.]?$"
ind_species <- c(which(ind_species), which(ind_species)[has_previous_genera_abbr] - 1)
ind <- c(ind_species, which(ind_fullname))
s_split[ind] <- paste0(before, s_split[ind], after)
s_paste <- paste(s_split, collapse = " ")
# clean up a bit
s_paste <- gsub(paste0(after, " ", before), " ", s_paste, fixed = TRUE)
s_paste
},
USE.NAMES = FALSE
)
}
#' @rdname italicise_taxonomy

54
R/join_microorganisms.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -33,8 +33,8 @@
#' @param by a variable to join by - if left empty will search for a column with class [`mo`] (created with [as.mo()]) or will be `"mo"` if that column name exists in `x`, could otherwise be a column name of `x` with values that exist in `microorganisms$mo` (such as `by = "bacteria_id"`), or another column in [microorganisms] (but then it should be named, like `by = c("bacteria_id" = "fullname")`)
#' @param suffix if there are non-joined duplicate variables in `x` and `y`, these suffixes will be added to the output to disambiguate them. Should be a [character] vector of length 2.
#' @param ... ignored, only in place to allow future extensions
#' @details **Note:** As opposed to the `join()` functions of `dplyr`, [character] vectors are supported and at default existing columns will get a suffix `"2"` and the newly joined columns will not get a suffix.
#'
#' @details **Note:** As opposed to the `join()` functions of `dplyr`, [character] vectors are supported and at default existing columns will get a suffix `"2"` and the newly joined columns will not get a suffix.
#'
#' If the `dplyr` package is installed, their join functions will be used. Otherwise, the much slower [merge()] and [interaction()] functions from base \R will be used.
#' @return a [data.frame]
#' @export
@@ -42,21 +42,27 @@
#' left_join_microorganisms(as.mo("K. pneumoniae"))
#' left_join_microorganisms("B_KLBSL_PNMN")
#'
#' df <- data.frame(date = seq(from = as.Date("2018-01-01"),
#' to = as.Date("2018-01-07"),
#' by = 1),
#' bacteria = as.mo(c("S. aureus", "MRSA", "MSSA", "STAAUR",
#' "E. coli", "E. coli", "E. coli")),
#' stringsAsFactors = FALSE)
#' df <- data.frame(
#' date = seq(
#' from = as.Date("2018-01-01"),
#' to = as.Date("2018-01-07"),
#' by = 1
#' ),
#' bacteria = as.mo(c(
#' "S. aureus", "MRSA", "MSSA", "STAAUR",
#' "E. coli", "E. coli", "E. coli"
#' )),
#' stringsAsFactors = FALSE
#' )
#' colnames(df)
#'
#'
#' df_joined <- left_join_microorganisms(df, "bacteria")
#' colnames(df_joined)
#'
#'
#' \donttest{
#' if (require("dplyr")) {
#' example_isolates %>%
#' left_join_microorganisms() %>%
#' left_join_microorganisms() %>%
#' colnames()
#' }
#' }
@@ -64,7 +70,7 @@ inner_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
meet_criteria(x, allow_class = c("data.frame", "character"))
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
meet_criteria(suffix, allow_class = "character", has_length = 2)
join_microorganisms(type = "inner_join", x = x, by = by, suffix = suffix, ...)
}
@@ -74,7 +80,7 @@ left_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
meet_criteria(x, allow_class = c("data.frame", "character"))
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
meet_criteria(suffix, allow_class = "character", has_length = 2)
join_microorganisms(type = "left_join", x = x, by = by, suffix = suffix, ...)
}
@@ -84,7 +90,7 @@ right_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
meet_criteria(x, allow_class = c("data.frame", "character"))
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
meet_criteria(suffix, allow_class = "character", has_length = 2)
join_microorganisms(type = "right_join", x = x, by = by, suffix = suffix, ...)
}
@@ -94,7 +100,7 @@ full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
meet_criteria(x, allow_class = c("data.frame", "character"))
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
meet_criteria(suffix, allow_class = "character", has_length = 2)
join_microorganisms(type = "full_join", x = x, by = by, suffix = suffix, ...)
}
@@ -103,7 +109,7 @@ full_join_microorganisms <- function(x, by = NULL, suffix = c("2", ""), ...) {
semi_join_microorganisms <- function(x, by = NULL, ...) {
meet_criteria(x, allow_class = c("data.frame", "character"))
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
join_microorganisms(type = "semi_join", x = x, by = by, ...)
}
@@ -112,13 +118,13 @@ semi_join_microorganisms <- function(x, by = NULL, ...) {
anti_join_microorganisms <- function(x, by = NULL, ...) {
meet_criteria(x, allow_class = c("data.frame", "character"))
meet_criteria(by, allow_class = "character", allow_NULL = TRUE)
join_microorganisms(type = "anti_join", x = x, by = by, ...)
}
join_microorganisms <- function(type, x, by, suffix, ...) {
check_dataset_integrity()
if (!is.data.frame(x)) {
if (pkg_is_available("tibble", also_load = FALSE)) {
x <- import_fn("tibble", "tibble")(mo = x)
@@ -143,12 +149,12 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
} else {
x[, by] <- as.mo(x[, by, drop = TRUE])
}
if (is.null(names(by))) {
# will always be joined to microorganisms$mo, so add name to that
by <- stats::setNames("mo", by)
}
# use dplyr if available - it's much faster than poorman alternatives
dplyr_join <- import_fn(name = type, pkg = "dplyr", error_on_fail = FALSE)
if (!is.null(dplyr_join)) {
@@ -162,7 +168,7 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
} else {
joined <- join_fn(x = x, y = AMR::microorganisms, by = by, ...)
}
if ("join.mo" %in% colnames(joined)) {
if ("mo" %in% colnames(joined)) {
ind_mo <- which(colnames(joined) %in% c("mo", "join.mo"))
@@ -172,10 +178,10 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
colnames(joined)[colnames(joined) == "join.mo"] <- "mo"
}
}
if (type %like% "full|left|right|inner" && NROW(joined) > NROW(x)) {
warning_("in `", type, "_join()`: the newly joined data set contains ", nrow(joined) - nrow(x), " rows more than the number of rows of `x`.")
}
as_original_data_class(joined, class(x.bak))
}

215
R/key_antimicrobials.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -35,15 +35,15 @@
#' @param antifungal names of antifungal agents for **fungi**, case-insensitive. Set to `NULL` to ignore. See *Details* for the default agents.
#' @param only_rsi_columns a [logical] to indicate whether only columns must be included that were transformed to class `<rsi>` (see [as.rsi()]) on beforehand (defaults to `FALSE`)
#' @param ... ignored, only in place to allow future extensions
#' @details
#' @details
#' The [key_antimicrobials()] and [all_antimicrobials()] functions are context-aware. This means that the `x` argument can be left blank if used inside a [data.frame] call, see *Examples*.
#'
#'
#' The function [key_antimicrobials()] returns a [character] vector with 12 antimicrobial results for every isolate. The function [all_antimicrobials()] returns a [character] vector with all antimicrobial results for every isolate. These vectors can then be compared using [antimicrobials_equal()], to check if two isolates have generally the same antibiogram. Missing and invalid values are replaced with a dot (`"."`) by [key_antimicrobials()] and ignored by [antimicrobials_equal()].
#'
#'
#' Please see the [first_isolate()] function how these important functions enable the 'phenotype-based' method for determination of first isolates.
#'
#' The default antimicrobial agents used for **all rows** (set in `universal`) are:
#'
#'
#' - Ampicillin
#' - Amoxicillin/clavulanic acid
#' - Cefuroxime
@@ -52,7 +52,7 @@
#' - Trimethoprim/sulfamethoxazole
#'
#' The default antimicrobial agents used for **Gram-negative bacteria** (set in `gram_negative`) are:
#'
#'
#' - Cefotaxime
#' - Ceftazidime
#' - Colistin
@@ -61,17 +61,17 @@
#' - Tobramycin
#'
#' The default antimicrobial agents used for **Gram-positive bacteria** (set in `gram_positive`) are:
#'
#'
#' - Erythromycin
#' - Oxacillin
#' - Rifampin
#' - Teicoplanin
#' - Tetracycline
#' - Vancomycin
#'
#'
#'
#'
#' The default antimicrobial agents used for **fungi** (set in `antifungal`) are:
#'
#'
#' - Anidulafungin
#' - Caspofungin
#' - Fluconazole
@@ -84,7 +84,7 @@
#' @examples
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#'
#' # output of the `key_antimicrobials()` function could be like this:
#' strainA <- "SSSRR.S.R..S"
#' strainB <- "SSSIRSSSRSSS"
@@ -107,7 +107,7 @@
#' # and first WEIGHTED isolates
#' first_weighted = first_isolate(col_keyantimicrobials = "keyab")
#' )
#'
#'
#' # Check the difference in this data set, 'weighted' results in more isolates:
#' sum(my_patients$first_regular, na.rm = TRUE)
#' sum(my_patients$first_weighted, na.rm = TRUE)
@@ -115,14 +115,22 @@
#' }
key_antimicrobials <- function(x = NULL,
col_mo = NULL,
universal = c("ampicillin", "amoxicillin/clavulanic acid", "cefuroxime",
"piperacillin/tazobactam", "ciprofloxacin", "trimethoprim/sulfamethoxazole"),
gram_negative = c("gentamicin", "tobramycin", "colistin",
"cefotaxime", "ceftazidime", "meropenem"),
gram_positive = c("vancomycin", "teicoplanin", "tetracycline",
"erythromycin", "oxacillin", "rifampin"),
antifungal = c("anidulafungin", "caspofungin", "fluconazole",
"miconazole", "nystatin", "voriconazole"),
universal = c(
"ampicillin", "amoxicillin/clavulanic acid", "cefuroxime",
"piperacillin/tazobactam", "ciprofloxacin", "trimethoprim/sulfamethoxazole"
),
gram_negative = c(
"gentamicin", "tobramycin", "colistin",
"cefotaxime", "ceftazidime", "meropenem"
),
gram_positive = c(
"vancomycin", "teicoplanin", "tetracycline",
"erythromycin", "oxacillin", "rifampin"
),
antifungal = c(
"anidulafungin", "caspofungin", "fluconazole",
"miconazole", "nystatin", "voriconazole"
),
only_rsi_columns = FALSE,
...) {
if (is_null_or_grouped_tbl(x)) {
@@ -137,11 +145,11 @@ key_antimicrobials <- function(x = NULL,
meet_criteria(gram_positive, allow_class = "character", allow_NULL = TRUE)
meet_criteria(antifungal, allow_class = "character", allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
# force regular data.frame, not a tibble or data.table
x <- as.data.frame(x, stringsAsFactors = FALSE)
cols <- get_column_abx(x, info = FALSE, only_rsi_columns = only_rsi_columns, fn = "key_antimicrobials")
# try to find columns based on type
# -- mo
if (is.null(col_mo)) {
@@ -156,68 +164,79 @@ key_antimicrobials <- function(x = NULL,
gramstain <- mo_gramstain(x.mo, language = NULL)
kingdom <- mo_kingdom(x.mo, language = NULL)
}
AMR_string <- function(x, values, name, filter, cols = cols) {
if (is.null(values)) {
return(rep(NA_character_, length(which(filter))))
}
values_old_length <- length(values)
values <- as.ab(values, flag_multiple_results = FALSE, info = FALSE)
values <- cols[names(cols) %in% values]
values_new_length <- length(values)
if (values_new_length < values_old_length &
any(filter, na.rm = TRUE) &
message_not_thrown_before("key_antimicrobials", name)) {
warning_("in `key_antimicrobials()`: ",
ifelse(values_new_length == 0,
"No columns available ",
paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ")),
"as key antimicrobials for ", name, "s. See ?key_antimicrobials.")
any(filter, na.rm = TRUE) &
message_not_thrown_before("key_antimicrobials", name)) {
warning_(
"in `key_antimicrobials()`: ",
ifelse(values_new_length == 0,
"No columns available ",
paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ")
),
"as key antimicrobials for ", name, "s. See ?key_antimicrobials."
)
}
generate_antimcrobials_string(x[which(filter), c(universal, values), drop = FALSE])
}
if (is.null(universal)) {
universal <- character(0)
} else {
universal <- as.ab(universal, flag_multiple_results = FALSE, info = FALSE)
universal <- cols[names(cols) %in% universal]
}
key_ab <- rep(NA_character_, nrow(x))
key_ab[which(gramstain == "Gram-negative")] <- AMR_string(x = x,
values = gram_negative,
name = "Gram-negative",
filter = gramstain == "Gram-negative",
cols = cols)
key_ab[which(gramstain == "Gram-positive")] <- AMR_string(x = x,
values = gram_positive,
name = "Gram-positive",
filter = gramstain == "Gram-positive",
cols = cols)
key_ab[which(kingdom == "Fungi")] <- AMR_string(x = x,
values = antifungal,
name = "antifungal",
filter = kingdom == "Fungi",
cols = cols)
key_ab[which(gramstain == "Gram-negative")] <- AMR_string(
x = x,
values = gram_negative,
name = "Gram-negative",
filter = gramstain == "Gram-negative",
cols = cols
)
key_ab[which(gramstain == "Gram-positive")] <- AMR_string(
x = x,
values = gram_positive,
name = "Gram-positive",
filter = gramstain == "Gram-positive",
cols = cols
)
key_ab[which(kingdom == "Fungi")] <- AMR_string(
x = x,
values = antifungal,
name = "antifungal",
filter = kingdom == "Fungi",
cols = cols
)
# back-up - only use `universal`
key_ab[which(is.na(key_ab))] <- AMR_string(x = x,
values = character(0),
name = "",
filter = is.na(key_ab),
cols = cols)
key_ab[which(is.na(key_ab))] <- AMR_string(
x = x,
values = character(0),
name = "",
filter = is.na(key_ab),
cols = cols
)
if (length(unique(key_ab)) == 1) {
warning_("in `key_antimicrobials()`: no distinct key antibiotics determined.")
}
key_ab
}
@@ -233,13 +252,15 @@ all_antimicrobials <- function(x = NULL,
}
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
# force regular data.frame, not a tibble or data.table
x <- as.data.frame(x, stringsAsFactors = FALSE)
cols <- get_column_abx(x, only_rsi_columns = only_rsi_columns, info = FALSE,
sort = FALSE, fn = "all_antimicrobials")
generate_antimcrobials_string(x[ , cols, drop = FALSE])
cols <- get_column_abx(x,
only_rsi_columns = only_rsi_columns, info = FALSE,
sort = FALSE, fn = "all_antimicrobials"
)
generate_antimcrobials_string(x[, cols, drop = FALSE])
}
generate_antimcrobials_string <- function(df) {
@@ -249,26 +270,32 @@ generate_antimcrobials_string <- function(df) {
if (NROW(df) == 0) {
return(character(0))
}
tryCatch({
do.call(paste0,
lapply(as.list(df),
function(x) {
x <- toupper(as.character(x))
x[!x %in% c("R", "S", "I")] <- "."
paste(x)
}))
},
error = function(e) rep(strrep(".", NCOL(df)), NROW(df)))
tryCatch(
{
do.call(
paste0,
lapply(
as.list(df),
function(x) {
x <- toupper(as.character(x))
x[!x %in% c("R", "S", "I")] <- "."
paste(x)
}
)
)
},
error = function(e) rep(strrep(".", NCOL(df)), NROW(df))
)
}
#' @rdname key_antimicrobials
#' @export
antimicrobials_equal <- function(y,
z,
type = c("points", "keyantimicrobials"),
ignore_I = TRUE,
points_threshold = 2,
...) {
z,
type = c("points", "keyantimicrobials"),
ignore_I = TRUE,
points_threshold = 2,
...) {
meet_criteria(y, allow_class = "character")
meet_criteria(z, allow_class = "character")
stop_if(missing(type), "argument \"type\" is missing, with no default")
@@ -289,10 +316,10 @@ antimicrobials_equal <- function(y,
uniq <- unique(c(y, z))
uniq_list <- lapply(uniq, key2rsi)
names(uniq_list) <- uniq
y <- uniq_list[match(y, names(uniq_list))]
z <- uniq_list[match(z, names(uniq_list))]
determine_equality <- function(a, b, type, points_threshold, ignore_I) {
if (length(a) != length(b)) {
# incomparable, so not equal
@@ -302,7 +329,7 @@ antimicrobials_equal <- function(y,
NA_ind <- which(is.na(a) | is.na(b))
a[NA_ind] <- NA_real_
b[NA_ind] <- NA_real_
if (type == "points") {
# count points for every single character:
# - no change is 0 points
@@ -320,14 +347,18 @@ antimicrobials_equal <- function(y,
all(a == b, na.rm = TRUE)
}
}
out <- unlist(mapply(FUN = determine_equality,
y,
z,
MoreArgs = list(type = type,
points_threshold = points_threshold,
ignore_I = ignore_I),
SIMPLIFY = FALSE,
USE.NAMES = FALSE))
out <- unlist(mapply(
FUN = determine_equality,
y,
z,
MoreArgs = list(
type = type,
points_threshold = points_threshold,
ignore_I = ignore_I
),
SIMPLIFY = FALSE,
USE.NAMES = FALSE
))
out[is.na(y) | is.na(z)] <- NA
out
}

4
R/kurtosis.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -32,7 +32,7 @@
#' @seealso [skewness()]
#' @rdname kurtosis
#' @export
#' @examples
#' @examples
#' kurtosis(rnorm(10000))
#' kurtosis(rnorm(10000), excess = TRUE)
kurtosis <- function(x, na.rm = FALSE, excess = FALSE) {

40
R/like.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -39,7 +39,7 @@
#' * Support multiple patterns
#' * Check if `pattern` is a valid regular expression and sets `fixed = TRUE` if not, to greatly improve speed (vectorised over `pattern`)
#' * Always use compatibility with Perl unless `fixed = TRUE`, to greatly improve speed
#'
#'
#' Using RStudio? The `%like%`/`%unlike%` functions can also be directly inserted in your code from the Addins menu and can have its own keyboard shortcut like `Shift+Ctrl+L` or `Shift+Cmd+L` (see menu `Tools` > `Modify Keyboard Shortcuts...`). If you keep pressing your shortcut, the inserted text will be iterated over `%like%` -> `%unlike%` -> `%like_case%` -> `%unlike_case%`.
#' @source Idea from the [`like` function from the `data.table` package](https://github.com/Rdatatable/data.table/blob/ec1259af1bf13fc0c96a1d3f9e84d55d8106a9a4/R/like.R), although altered as explained in *Details*.
#' @seealso [grepl()]
@@ -49,20 +49,20 @@
#' b <- "TEST"
#' a %like% b
#' b %like% a
#'
#'
#' # also supports multiple patterns
#' a <- c("Test case", "Something different", "Yet another thing")
#' b <- c( "case", "diff", "yet")
#' b <- c("case", "diff", "yet")
#' a %like% b
#' a %unlike% b
#'
#'
#' a[1] %like% b
#' a %like% b[1]
#'
#'
#' \donttest{
#' # get isolates whose name start with 'Entero' (case-insensitive)
#' example_isolates[which(mo_name() %like% "^entero"), ]
#'
#'
#' if (require("dplyr")) {
#' example_isolates %>%
#' filter(mo_name() %like% "^ent")
@@ -72,7 +72,7 @@ like <- function(x, pattern, ignore.case = TRUE) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(pattern, allow_NA = FALSE)
meet_criteria(ignore.case, allow_class = "logical", has_length = 1)
if (all(is.na(x))) {
return(rep(FALSE, length(x)))
}
@@ -96,18 +96,22 @@ like <- function(x, pattern, ignore.case = TRUE) {
if (length(x) == 1) {
x <- rep(x, length(pattern))
} else if (length(pattern) != length(x)) {
stop_("arguments `x` and `pattern` must be of same length, or either one must be 1 ",
"(`x` has length ", length(x), " and `pattern` has length ", length(pattern), ")")
stop_(
"arguments `x` and `pattern` must be of same length, or either one must be 1 ",
"(`x` has length ", length(x), " and `pattern` has length ", length(pattern), ")"
)
}
unlist(
mapply(FUN = grepl,
x = x,
pattern = pattern,
fixed = fixed,
perl = !fixed,
MoreArgs = list(ignore.case = FALSE),
SIMPLIFY = FALSE,
USE.NAMES = FALSE)
mapply(
FUN = grepl,
x = x,
pattern = pattern,
fixed = fixed,
perl = !fixed,
MoreArgs = list(ignore.case = FALSE),
SIMPLIFY = FALSE,
USE.NAMES = FALSE
)
)
}
}

2093
R/mdro.R
View File

File diff suppressed because it is too large Load Diff

147
R/mic.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -25,20 +25,42 @@
# these are allowed MIC values and will become [factor] levels
ops <- c("<", "<=", "", ">=", ">")
valid_mic_levels <- c(c(t(vapply(FUN.VALUE = character(9), ops,
function(x) paste0(x, "0.00", 1:9)))),
unique(c(t(vapply(FUN.VALUE = character(104), ops,
function(x) paste0(x, sort(as.double(paste0("0.0",
sort(c(1:99, 125, 128, 256, 512, 625)))))))))),
unique(c(t(vapply(FUN.VALUE = character(103), ops,
function(x) paste0(x, sort(as.double(paste0("0.",
c(1:99, 125, 128, 256, 512))))))))),
c(t(vapply(FUN.VALUE = character(10), ops,
function(x) paste0(x, sort(c(1:9, 1.5)))))),
c(t(vapply(FUN.VALUE = character(45), ops,
function(x) paste0(x, c(10:98)[9:98 %% 2 == TRUE])))),
c(t(vapply(FUN.VALUE = character(17), ops,
function(x) paste0(x, sort(c(2 ^ c(7:11), 192, 80 * c(2:12))))))))
valid_mic_levels <- c(
c(t(vapply(
FUN.VALUE = character(9), ops,
function(x) paste0(x, "0.00", 1:9)
))),
unique(c(t(vapply(
FUN.VALUE = character(104), ops,
function(x) {
paste0(x, sort(as.double(paste0(
"0.0",
sort(c(1:99, 125, 128, 256, 512, 625))
))))
}
)))),
unique(c(t(vapply(
FUN.VALUE = character(103), ops,
function(x) {
paste0(x, sort(as.double(paste0(
"0.",
c(1:99, 125, 128, 256, 512)
))))
}
)))),
c(t(vapply(
FUN.VALUE = character(10), ops,
function(x) paste0(x, sort(c(1:9, 1.5)))
))),
c(t(vapply(
FUN.VALUE = character(45), ops,
function(x) paste0(x, c(10:98)[9:98 %% 2 == TRUE])
))),
c(t(vapply(
FUN.VALUE = character(17), ops,
function(x) paste0(x, sort(c(2^c(7:11), 192, 80 * c(2:12))))
)))
)
#' Transform Input to Minimum Inhibitory Concentrations (MIC)
#'
@@ -48,32 +70,32 @@ valid_mic_levels <- c(c(t(vapply(FUN.VALUE = character(9), ops,
#' @param na.rm a [logical] indicating whether missing values should be removed
#' @param ... arguments passed on to methods
#' @details To interpret MIC values as RSI values, use [as.rsi()] on MIC values. It supports guidelines from EUCAST (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))`) and CLSI (`r min(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`-`r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "CLSI")$guideline)))`).
#'
#'
#' This class for MIC values is a quite a special data type: formally it is an ordered [factor] with valid MIC values as [factor] levels (to make sure only valid MIC values are retained), but for any mathematical operation it acts as decimal numbers:
#'
#'
#' ```
#' x <- random_mic(10)
#' x
#' #> Class <mic>
#' #> [1] 16 1 8 8 64 >=128 0.0625 32 32 16
#'
#'
#' is.factor(x)
#' #> [1] TRUE
#'
#'
#' x[1] * 2
#' #> [1] 32
#'
#'
#' median(x)
#' #> [1] 26
#' ```
#'
#'
#' This makes it possible to maintain operators that often come with MIC values, such ">=" and "<=", even when filtering using [numeric] values in data analysis, e.g.:
#'
#'
#' ```
#' x[x > 4]
#' #> Class <mic>
#' #> [1] 16 8 8 64 >=128 32 32 16
#'
#'
#' df <- data.frame(x, hospital = "A")
#' subset(df, x > 4) # or with dplyr: df %>% filter(x > 4)
#' #> x hospital
@@ -84,11 +106,11 @@ valid_mic_levels <- c(c(t(vapply(FUN.VALUE = character(9), ops,
#' #> 9 32 A
#' #> 10 16 A
#' ```
#'
#'
#' The following [generic functions][groupGeneric()] are implemented for the MIC class: `!`, `!=`, `%%`, `%/%`, `&`, `*`, `+`, `-`, `/`, `<`, `<=`, `==`, `>`, `>=`, `^`, `|`, [abs()], [acos()], [acosh()], [all()], [any()], [asin()], [asinh()], [atan()], [atanh()], [ceiling()], [cos()], [cosh()], [cospi()], [cummax()], [cummin()], [cumprod()], [cumsum()], [digamma()], [exp()], [expm1()], [floor()], [gamma()], [lgamma()], [log()], [log1p()], [log2()], [log10()], [max()], [mean()], [min()], [prod()], [range()], [round()], [sign()], [signif()], [sin()], [sinh()], [sinpi()], [sqrt()], [sum()], [tan()], [tanh()], [tanpi()], [trigamma()] and [trunc()]. Some functions of the `stats` package are also implemented: [median()], [quantile()], [mad()], [IQR()], [fivenum()]. Also, [boxplot.stats()] is supported. Since [sd()] and [var()] are non-generic functions, these could not be extended. Use [mad()] as an alternative, or use e.g. `sd(as.numeric(x))` where `x` is your vector of MIC values.
#'
#'
#' Using [as.double()] or [as.numeric()] on MIC values will remove the operators and return a numeric vector. Do **not** use [as.integer()] on MIC values as by the \R convention on [factor]s, it will return the index of the factor levels (which is often useless for regular users).
#'
#'
#' Use [droplevels()] to drop unused levels. At default, it will return a plain factor. Use `droplevels(..., as.mic = TRUE)` to maintain the `<mic>` class.
#' @return Ordered [factor] with additional class [`mic`], that in mathematical operations acts as decimal numbers. Bare in mind that the outcome of any mathematical operation on MICs will return a [numeric] value.
#' @aliases mic
@@ -101,26 +123,30 @@ valid_mic_levels <- c(c(t(vapply(FUN.VALUE = character(9), ops,
#'
#' # this can also coerce combined MIC/RSI values:
#' as.mic("<=0.002; S")
#'
#'
#' # mathematical processing treats MICs as numeric values
#' fivenum(mic_data)
#' quantile(mic_data)
#' all(mic_data < 512)
#'
#' # interpret MIC values
#' as.rsi(x = as.mic(2),
#' mo = as.mo("Streptococcus pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST")
#' as.rsi(x = as.mic(c(0.01, 2, 4, 8)),
#' mo = as.mo("Streptococcus pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST")
#' as.rsi(
#' x = as.mic(2),
#' mo = as.mo("Streptococcus pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST"
#' )
#' as.rsi(
#' x = as.mic(c(0.01, 2, 4, 8)),
#' mo = as.mo("Streptococcus pneumoniae"),
#' ab = "AMX",
#' guideline = "EUCAST"
#' )
#'
#' # plot MIC values, see ?plot
#' plot(mic_data)
#' plot(mic_data, mo = "E. coli", ab = "cipro")
#'
#'
#' if (require("ggplot2")) {
#' autoplot(mic_data, mo = "E. coli", ab = "cipro")
#' }
@@ -133,7 +159,7 @@ valid_mic_levels <- c(c(t(vapply(FUN.VALUE = character(9), ops,
as.mic <- function(x, na.rm = FALSE) {
meet_criteria(x, allow_class = c("mic", "character", "numeric", "integer", "factor"), allow_NA = TRUE)
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
if (is.mic(x)) {
x
} else {
@@ -143,7 +169,7 @@ as.mic <- function(x, na.rm = FALSE) {
}
x[trimws(x) == ""] <- NA
x.bak <- x
# comma to period
x <- gsub(",", ".", x, fixed = TRUE)
# transform Unicode for >= and <=
@@ -177,27 +203,30 @@ as.mic <- function(x, na.rm = FALSE) {
x <- gsub("[.]$", "", x, perl = TRUE)
# trim it
x <- trimws(x)
## previously unempty values now empty - should return a warning later on
x[x.bak != "" & x == ""] <- "invalid"
na_before <- x[is.na(x) | x == ""] %pm>% length()
x[!x %in% valid_mic_levels] <- NA
na_after <- x[is.na(x) | x == ""] %pm>% length()
if (na_before != na_after) {
list_missing <- x.bak[is.na(x) & !is.na(x.bak) & x.bak != ""] %pm>%
unique() %pm>%
sort() %pm>%
vector_and(quotes = TRUE)
warning_("in `as.mic()`: ", na_after - na_before, " results truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ",
list_missing, call = FALSE)
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ",
list_missing,
call = FALSE
)
}
set_clean_class(factor(x, levels = valid_mic_levels, ordered = TRUE),
new_class = c("mic", "ordered", "factor"))
new_class = c("mic", "ordered", "factor")
)
}
}
@@ -206,7 +235,8 @@ all_valid_mics <- function(x) {
return(FALSE)
}
x_mic <- tryCatch(suppressWarnings(as.mic(x[!is.na(x)])),
error = function(e) NA)
error = function(e) NA
)
!any(is.na(x_mic)) && !all(is.na(x))
}
@@ -215,7 +245,8 @@ all_valid_mics <- function(x) {
#' @format NULL
#' @export
NA_mic_ <- set_clean_class(factor(NA, levels = valid_mic_levels, ordered = TRUE),
new_class = c("mic", "ordered", "factor"))
new_class = c("mic", "ordered", "factor")
)
#' @rdname as.mic
#' @export
@@ -271,8 +302,10 @@ type_sum.mic <- function(x, ...) {
#' @noRd
print.mic <- function(x, ...) {
cat("Class <mic>",
ifelse(length(levels(x)) < length(valid_mic_levels), font_red(" with dropped levels"), ""),
"\n", sep = "")
ifelse(length(levels(x)) < length(valid_mic_levels), font_red(" with dropped levels"), ""),
"\n",
sep = ""
)
print(as.character(x), quote = FALSE)
att <- attributes(x)
if ("na.action" %in% names(att)) {
@@ -378,12 +411,12 @@ hist.mic <- function(x, ...) {
get_skimmers.mic <- function(column) {
skimr::sfl(
skim_type = "mic",
p0 = ~stats::quantile(., probs = 0, na.rm = TRUE, names = FALSE),
p25 = ~stats::quantile(., probs = 0.25, na.rm = TRUE, names = FALSE),
p50 = ~stats::quantile(., probs = 0.5, na.rm = TRUE, names = FALSE),
p75 = ~stats::quantile(., probs = 0.75, na.rm = TRUE, names = FALSE),
p100 = ~stats::quantile(., probs = 1, na.rm = TRUE, names = FALSE),
hist = ~skimr::inline_hist(log2(stats::na.omit(.)), 5)
p0 = ~ stats::quantile(., probs = 0, na.rm = TRUE, names = FALSE),
p25 = ~ stats::quantile(., probs = 0.25, na.rm = TRUE, names = FALSE),
p50 = ~ stats::quantile(., probs = 0.5, na.rm = TRUE, names = FALSE),
p75 = ~ stats::quantile(., probs = 0.75, na.rm = TRUE, names = FALSE),
p100 = ~ stats::quantile(., probs = 1, na.rm = TRUE, names = FALSE),
hist = ~ skimr::inline_hist(log2(stats::na.omit(.)), 5)
)
}
@@ -679,7 +712,7 @@ is_lower <- function(el) {
#' @export
#' @noRd
`^.mic` <- function(e1, e2) {
as.double(e1) ^ as.double(e2)
as.double(e1)^as.double(e2)
}
#' @method %% mic

1288
R/mo.R
View File

File diff suppressed because it is too large Load Diff

56
R/mo_matching_score.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -24,57 +24,63 @@
# ==================================================================== #
#' Calculate the Matching Score for Microorganisms
#'
#' This algorithm is used by [as.mo()] and all the [`mo_*`][mo_property()] functions to determine the most probable match of taxonomic records based on user input.
#'
#' This algorithm is used by [as.mo()] and all the [`mo_*`][mo_property()] functions to determine the most probable match of taxonomic records based on user input.
#' @author Dr Matthijs Berends
#' @param x Any user input value(s)
#' @param n A full taxonomic name, that exists in [`microorganisms$fullname`][microorganisms]
#' @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:
#'
#'
#' * \ifelse{html}{\out{<i>x</i> is the user input;}}{\eqn{x} is the user input;}
#' * \ifelse{html}{\out{<i>n</i> is a taxonomic name (genus, species, and subspecies);}}{\eqn{n} is a taxonomic name (genus, species, and subspecies);}
#' * \ifelse{html}{\out{<i>l<sub>n</sub></i> is the length of <i>n</i>;}}{l_n is the length of \eqn{n};}
#' * \ifelse{html}{\out{<i>lev</i> is the <a href="https://en.wikipedia.org/wiki/Levenshtein_distance">Levenshtein distance function</a>, which counts any insertion, deletion and substitution as 1 that is needed to change <i>x</i> into <i>n</i>;}}{lev is the Levenshtein distance function, which counts any insertion, deletion and substitution as 1 that is needed to change \eqn{x} into \eqn{n};}
#' * \ifelse{html}{\out{<i>p<sub>n</sub></i> is the human pathogenic prevalence group of <i>n</i>, as described below;}}{p_n is the human pathogenic prevalence group of \eqn{n}, as described below;}
#' * \ifelse{html}{\out{<i>k<sub>n</sub></i> is the taxonomic kingdom of <i>n</i>, set as Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, others = 5.}}{l_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 experience from several microbiological laboratories in the Netherlands in conjunction with international reports on pathogen prevalence. **Group 1** (most prevalent microorganisms) consists of all microorganisms where the taxonomic class is Gammaproteobacteria or where the taxonomic genus is *Enterococcus*, *Staphylococcus* or *Streptococcus*. This group consequently contains all common Gram-negative bacteria, such as *Pseudomonas* and *Legionella* and all species within the order Enterobacterales. **Group 2** consists of all microorganisms where the taxonomic phylum is Proteobacteria, Firmicutes, Actinobacteria or Sarcomastigophora, or where the taxonomic genus is *Absidia*, *Acremonium*, *Actinotignum*, *Alternaria*, *Anaerosalibacter*, *Apophysomyces*, *Arachnia*, *Aspergillus*, *Aureobacterium*, *Aureobasidium*, *Bacteroides*, *Basidiobolus*, *Beauveria*, *Blastocystis*, *Branhamella*, *Calymmatobacterium*, *Candida*, *Capnocytophaga*, *Catabacter*, *Chaetomium*, *Chryseobacterium*, *Chryseomonas*, *Chrysonilia*, *Cladophialophora*, *Cladosporium*, *Conidiobolus*, *Cryptococcus*, *Curvularia*, *Exophiala*, *Exserohilum*, *Flavobacterium*, *Fonsecaea*, *Fusarium*, *Fusobacterium*, *Hendersonula*, *Hypomyces*, *Koserella*, *Lelliottia*, *Leptosphaeria*, *Leptotrichia*, *Malassezia*, *Malbranchea*, *Mortierella*, *Mucor*, *Mycocentrospora*, *Mycoplasma*, *Nectria*, *Ochroconis*, *Oidiodendron*, *Phoma*, *Piedraia*, *Pithomyces*, *Pityrosporum*, *Prevotella*, *Pseudallescheria*, *Rhizomucor*, *Rhizopus*, *Rhodotorula*, *Scolecobasidium*, *Scopulariopsis*, *Scytalidium*, *Sporobolomyces*, *Stachybotrys*, *Stomatococcus*, *Treponema*, *Trichoderma*, *Trichophyton*, *Trichosporon*, *Tritirachium* or *Ureaplasma*. **Group 3** consists of all other microorganisms.
#'
#'
#' All characters in \eqn{x} and \eqn{n} are ignored that are other than A-Z, a-z, 0-9, spaces and parentheses.
#'
#' All matches are sorted descending on their matching score and for all user input values, the top match will be returned. This will lead to the effect that e.g., `"E. coli"` will return the microbial ID of *Escherichia coli* (\eqn{m = `r round(mo_matching_score("E. coli", "Escherichia coli"), 3)`}, a highly prevalent microorganism found in humans) and not *Entamoeba coli* (\eqn{m = `r round(mo_matching_score("E. coli", "Entamoeba coli"), 3)`}, a less prevalent microorganism in humans), although the latter would alphabetically come first.
#'
#'
#' All matches are sorted descending on their matching score and for all user input values, the top match will be returned. This will lead to the effect that e.g., `"E. coli"` will return the microbial ID of *Escherichia coli* (\eqn{m = `r round(mo_matching_score("E. coli", "Escherichia coli"), 3)`}, a highly prevalent microorganism found in humans) and not *Entamoeba coli* (\eqn{m = `r round(mo_matching_score("E. coli", "Entamoeba coli"), 3)`}, a less prevalent microorganism in humans), although the latter would alphabetically come first.
#'
#' Since `AMR` version 1.8.1, common microorganism abbreviations are ignored in determining the matching score. These abbreviations are currently: `r vector_and(pkg_env$mo_field_abbreviations, quotes = FALSE)`.
#' @export
#' @inheritSection AMR Reference Data Publicly Available
#' @examples
#' @examples
#' as.mo("E. coli")
#' mo_uncertainties()
#'
#' mo_matching_score(x = "E. coli",
#' n = c("Escherichia coli", "Entamoeba coli"))
#'
#' mo_matching_score(
#' x = "E. coli",
#' n = c("Escherichia coli", "Entamoeba coli")
#' )
mo_matching_score <- function(x, n) {
meet_criteria(x, allow_class = c("character", "data.frame", "list"))
meet_criteria(n, allow_class = "character")
x <- parse_and_convert(x)
# no dots and other non-whitespace characters
x <- gsub("[^a-zA-Z0-9 \\(\\)]+", "", x)
# remove abbreviations known to the field
x <- gsub(paste0("(^|[^a-z0-9]+)(",
paste0(pkg_env$mo_field_abbreviations, collapse = "|"),
")([^a-z0-9]+|$)"),
"", x, perl = TRUE, ignore.case = TRUE)
x <- gsub(paste0(
"(^|[^a-z0-9]+)(",
paste0(pkg_env$mo_field_abbreviations, collapse = "|"),
")([^a-z0-9]+|$)"
),
"", x,
perl = TRUE, ignore.case = TRUE
)
# only keep one space
x <- gsub(" +", " ", x)
# n is always a taxonomically valid full name
if (length(n) == 1) {
n <- rep(n, length(x))
@@ -82,7 +88,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))
@@ -97,7 +103,7 @@ mo_matching_score <- function(x, n) {
p_n <- MO_lookup[match(n, MO_lookup$fullname), "prevalence", drop = TRUE]
# kingdom index (Bacteria = 1, Fungi = 2, Protozoa = 3, Archaea = 4, others = 5)
k_n <- MO_lookup[match(n, MO_lookup$fullname), "kingdom_index", drop = TRUE]
# matching score:
(l_n - 0.5 * l_n.lev) / (l_n * p_n * k_n)
}

228
R/mo_property.R
View File

@@ -42,15 +42,15 @@
#' Since the top-level of the taxonomy is sometimes referred to as 'kingdom' and sometimes as 'domain', the functions [mo_kingdom()] and [mo_domain()] return the exact same results.
#'
#' The Gram stain - [mo_gramstain()] - will be determined based on the taxonomic kingdom and phylum. According to Cavalier-Smith (2002, [PMID 11837318](https://pubmed.ncbi.nlm.nih.gov/11837318)), who defined subkingdoms Negibacteria and Posibacteria, only these phyla are Posibacteria: Actinobacteria, Chloroflexi, Firmicutes and Tenericutes. These bacteria are considered Gram-positive, except for members of the class Negativicutes which are Gram-negative. Members of other bacterial phyla are all considered Gram-negative. Species outside the kingdom of Bacteria will return a value `NA`. Functions [mo_is_gram_negative()] and [mo_is_gram_positive()] always return `TRUE` or `FALSE` (except when the input is `NA` or the MO code is `UNKNOWN`), thus always return `FALSE` for species outside the taxonomic kingdom of Bacteria.
#'
#'
#' Determination of yeasts - [mo_is_yeast()] - will be based on the taxonomic kingdom and class. *Budding yeasts* are fungi of the phylum Ascomycetes, class Saccharomycetes (also called Hemiascomycetes). *True yeasts* are aggregated into the underlying order Saccharomycetales. Thus, for all microorganisms that are fungi and member of the taxonomic class Saccharomycetes, the function will return `TRUE`. It returns `FALSE` otherwise (except when the input is `NA` or the MO code is `UNKNOWN`).
#'
#'
#' Intrinsic resistance - [mo_is_intrinsic_resistant()] - will be determined based on the [intrinsic_resistant] data set, which is based on `r format_eucast_version_nr(3.3)`. The [mo_is_intrinsic_resistant()] functions can be vectorised over arguments `x` (input for microorganisms) and over `ab` (input for antibiotics).
#'
#' All output [will be translated][translate] where possible.
#'
#' The function [mo_url()] will return the direct URL to the online database entry, which also shows the scientific reference of the concerned species.
#'
#'
#' SNOMED codes - [mo_snomed()] - are from the `r SNOMED_VERSION$current_source`. See *Source* and the [microorganisms] data set for more info.
#' @inheritSection mo_matching_score Matching Score for Microorganisms
#' @inheritSection catalogue_of_life Catalogue of Life
@@ -139,30 +139,32 @@
#' mo_type("Klebsiella pneumoniae")
#'
#' mo_fullname("S. pyogenes",
#' Lancefield = TRUE,
#' language = "de")
#' Lancefield = TRUE,
#' language = "de"
#' )
#' mo_fullname("S. pyogenes",
#' Lancefield = TRUE,
#' language = "nl")
#' Lancefield = TRUE,
#' language = "nl"
#' )
#'
#'
#' # other --------------------------------------------------------------------
#'
#'
#' mo_is_yeast(c("Candida", "Trichophyton", "Klebsiella"))
#'
#'
#' # gram stains and intrinsic resistance can be used as a filter in dplyr verbs
#' if (require("dplyr")) {
#' example_isolates %>%
#' filter(mo_is_gram_positive())
#'
#'
#' example_isolates %>%
#' filter(mo_is_intrinsic_resistant(ab = "vanco"))
#' }
#'
#'
#'
#'
#' # get a list with the complete taxonomy (from kingdom to subspecies)
#' mo_taxonomy("Klebsiella pneumoniae")
#'
#'
#' # get a list with the taxonomy, the authors, Gram-stain,
#' # SNOMED codes, and URL to the online database
#' mo_info("Klebsiella pneumoniae")
@@ -174,11 +176,12 @@ mo_name <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(mo_validate(x = x, property = "fullname", language = language, ...),
language = language,
only_unknown = FALSE,
only_affect_mo_names = TRUE)
language = language,
only_unknown = FALSE,
only_affect_mo_names = TRUE
)
}
#' @rdname mo_property
@@ -194,20 +197,20 @@ mo_shortname <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
replace_empty <- function(x) {
x[x == ""] <- "spp."
x
}
# get first char of genus and complete species in English
genera <- mo_genus(x.mo, language = NULL)
shortnames <- paste0(substr(genera, 1, 1), ". ", replace_empty(mo_species(x.mo, language = NULL)))
# exceptions for where no species is known
shortnames[shortnames %like% ".[.] spp[.]"] <- genera[shortnames %like% ".[.] spp[.]"]
# exceptions for staphylococci
@@ -217,7 +220,7 @@ mo_shortname <- function(x, language = get_AMR_locale(), ...) {
shortnames[shortnames %like% "S. group [ABCDFGHK]"] <- paste0("G", gsub("S. group ([ABCDFGHK])", "\\1", shortnames[shortnames %like% "S. group [ABCDFGHK]"], perl = TRUE), "S")
# unknown species etc.
shortnames[shortnames %like% "unknown"] <- paste0("(", trimws(gsub("[^a-zA-Z -]", "", shortnames[shortnames %like% "unknown"], perl = TRUE)), ")")
shortnames[is.na(x.mo)] <- NA_character_
load_mo_failures_uncertainties_renamed(metadata)
translate_into_language(shortnames, language = language, only_unknown = FALSE, only_affect_mo_names = TRUE)
@@ -234,7 +237,7 @@ mo_subspecies <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(mo_validate(x = x, property = "subspecies", language = language, ...), language = language, only_unknown = TRUE)
}
@@ -247,7 +250,7 @@ mo_species <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(mo_validate(x = x, property = "species", language = language, ...), language = language, only_unknown = TRUE)
}
@@ -260,7 +263,7 @@ mo_genus <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(mo_validate(x = x, property = "genus", language = language, ...), language = language, only_unknown = TRUE)
}
@@ -273,7 +276,7 @@ mo_family <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(mo_validate(x = x, property = "family", language = language, ...), language = language, only_unknown = TRUE)
}
@@ -286,7 +289,7 @@ mo_order <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(mo_validate(x = x, property = "order", language = language, ...), language = language, only_unknown = TRUE)
}
@@ -299,7 +302,7 @@ mo_class <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(mo_validate(x = x, property = "class", language = language, ...), language = language, only_unknown = TRUE)
}
@@ -312,7 +315,7 @@ mo_phylum <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(mo_validate(x = x, property = "phylum", language = language, ...), language = language, only_unknown = TRUE)
}
@@ -325,7 +328,7 @@ mo_kingdom <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(mo_validate(x = x, property = "kingdom", language = language, ...), language = language, only_unknown = TRUE)
}
@@ -342,7 +345,7 @@ mo_type <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x.mo <- as.mo(x, language = language, ...)
out <- mo_kingdom(x.mo, language = NULL)
out[which(mo_is_yeast(x.mo))] <- "Yeasts"
@@ -358,24 +361,26 @@ mo_gramstain <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
x <- rep(NA_character_, length(x))
# make all bacteria Gram negative
x[mo_kingdom(x.mo) == "Bacteria"] <- "Gram-negative"
# overwrite these 4 phyla with Gram-positives
# Source: https://itis.gov/servlet/SingleRpt/SingleRpt?search_topic=TSN&search_value=956097 (Cavalier-Smith, 2002)
x[(mo_phylum(x.mo) %in% c("Actinobacteria",
"Chloroflexi",
"Firmicutes",
"Tenericutes") &
# but class Negativicutes (of phylum Firmicutes) are Gram-negative!
mo_class(x.mo) != "Negativicutes")
# and of course our own ID for Gram-positives
| x.mo == "B_GRAMP"] <- "Gram-positive"
x[(mo_phylum(x.mo) %in% c(
"Actinobacteria",
"Chloroflexi",
"Firmicutes",
"Tenericutes"
) &
# but class Negativicutes (of phylum Firmicutes) are Gram-negative!
mo_class(x.mo) != "Negativicutes")
# and of course our own ID for Gram-positives
| x.mo == "B_GRAMP"] <- "Gram-positive"
load_mo_failures_uncertainties_renamed(metadata)
translate_into_language(x, language = language, only_unknown = FALSE)
}
@@ -389,7 +394,7 @@ mo_is_gram_negative <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
grams <- mo_gramstain(x.mo, language = NULL)
@@ -408,7 +413,7 @@ mo_is_gram_positive <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
grams <- mo_gramstain(x.mo, language = NULL)
@@ -427,15 +432,15 @@ mo_is_yeast <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
x.kingdom <- mo_kingdom(x.mo, language = NULL)
x.class <- mo_class(x.mo, language = NULL)
load_mo_failures_uncertainties_renamed(metadata)
out <- rep(FALSE, length(x))
out[x.kingdom == "Fungi" & x.class == "Saccharomycetes"] <- TRUE
out[x.mo %in% c(NA_character_, "UNKNOWN")] <- NA
@@ -452,10 +457,10 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(ab, allow_NA = FALSE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- as.mo(x, language = language, ...)
ab <- as.ab(ab, language = NULL, flag_multiple_results = FALSE, info = FALSE)
if (length(x) == 1 & length(ab) > 1) {
x <- rep(x, length(ab))
} else if (length(ab) == 1 & length(x) > 1) {
@@ -464,14 +469,16 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_AMR_locale(), ...) {
if (length(x) != length(ab)) {
stop_("length of `x` and `ab` must be equal, or one of them must be of length 1.")
}
# show used version number once per session (pkg_env will reload every session)
if (message_not_thrown_before("mo_is_intrinsic_resistant", "version.mo", entire_session = TRUE)) {
message_("Determining intrinsic resistance based on ",
format_eucast_version_nr(3.3, markdown = FALSE), ". ",
font_red("This note will be shown once per session."))
message_(
"Determining intrinsic resistance based on ",
format_eucast_version_nr(3.3, markdown = FALSE), ". ",
font_red("This note will be shown once per session.")
)
}
# runs against internal vector: INTRINSIC_R (see zzz.R)
paste(x, ab) %in% INTRINSIC_R
}
@@ -485,7 +492,7 @@ mo_snomed <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
mo_validate(x = x, property = "snomed", language = language, ...)
}
@@ -498,7 +505,7 @@ mo_ref <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
mo_validate(x = x, property = "ref", language = language, ...)
}
@@ -511,7 +518,7 @@ mo_authors <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- mo_validate(x = x, property = "ref", language = language, ...)
# remove last 4 digits and presumably the comma and space that preceed them
x[!is.na(x)] <- gsub(",? ?[0-9]{4}", "", x[!is.na(x)], perl = TRUE)
@@ -527,7 +534,7 @@ mo_year <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- mo_validate(x = x, property = "ref", language = language, ...)
# get last 4 digits
x[!is.na(x)] <- gsub(".*([0-9]{4})$", "\\1", x[!is.na(x)], perl = TRUE)
@@ -543,7 +550,7 @@ mo_lpsn <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
mo_validate(x = x, property = "species_id", language = language, ...)
}
@@ -556,32 +563,34 @@ mo_rank <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
mo_validate(x = x, property = "rank", language = language, ...)
}
#' @rdname mo_property
#' @export
mo_taxonomy <- function(x, language = get_AMR_locale(), ...) {
mo_taxonomy <- function(x, language = get_AMR_locale(), ...) {
if (missing(x)) {
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_taxonomy")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
out <- list(kingdom = mo_kingdom(x, language = language),
phylum = mo_phylum(x, language = language),
class = mo_class(x, language = language),
order = mo_order(x, language = language),
family = mo_family(x, language = language),
genus = mo_genus(x, language = language),
species = mo_species(x, language = language),
subspecies = mo_subspecies(x, language = language))
out <- list(
kingdom = mo_kingdom(x, language = language),
phylum = mo_phylum(x, language = language),
class = mo_class(x, language = language),
order = mo_order(x, language = language),
family = mo_family(x, language = language),
genus = mo_genus(x, language = language),
species = mo_species(x, language = language),
subspecies = mo_subspecies(x, language = language)
)
load_mo_failures_uncertainties_renamed(metadata)
out
}
@@ -595,10 +604,10 @@ mo_synonyms <- function(x, language = get_AMR_locale(), ...) {
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
IDs <- mo_name(x = x, language = NULL)
syns <- lapply(IDs, function(newname) {
res <- sort(microorganisms.old[which(microorganisms.old$fullname_new == newname), "fullname", drop = TRUE])
@@ -614,38 +623,43 @@ mo_synonyms <- function(x, language = get_AMR_locale(), ...) {
} else {
result <- unlist(syns)
}
load_mo_failures_uncertainties_renamed(metadata)
result
}
#' @rdname mo_property
#' @export
mo_info <- function(x, language = get_AMR_locale(), ...) {
mo_info <- function(x, language = get_AMR_locale(), ...) {
if (missing(x)) {
# this tries to find the data and an <mo> column
x <- find_mo_col(fn = "mo_info")
}
meet_criteria(x, allow_NA = TRUE)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
info <- lapply(x, function(y)
c(mo_taxonomy(y, language = language),
list(synonyms = mo_synonyms(y),
gramstain = mo_gramstain(y, language = language),
url = unname(mo_url(y, open = FALSE)),
ref = mo_ref(y),
snomed = unlist(mo_snomed(y)))))
info <- lapply(x, function(y) {
c(
mo_taxonomy(y, language = language),
list(
synonyms = mo_synonyms(y),
gramstain = mo_gramstain(y, language = language),
url = unname(mo_url(y, open = FALSE)),
ref = mo_ref(y),
snomed = unlist(mo_snomed(y))
)
)
})
if (length(info) > 1) {
names(info) <- mo_name(x)
result <- info
} else {
result <- info[[1L]]
}
load_mo_failures_uncertainties_renamed(metadata)
result
}
@@ -660,30 +674,31 @@ mo_url <- function(x, open = FALSE, language = get_AMR_locale(), ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(open, allow_class = "logical", has_length = 1)
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
x.mo <- as.mo(x = x, language = language, ... = ...)
metadata <- get_mo_failures_uncertainties_renamed()
df <- microorganisms[match(x.mo, microorganisms$mo), c("mo", "fullname", "source", "kingdom", "rank"), drop = FALSE]
df$url <- ifelse(df$source == "LPSN",
paste0(CATALOGUE_OF_LIFE$url_LPSN, "/species/", gsub(" ", "-", tolower(df$fullname), fixed = TRUE)),
paste0(CATALOGUE_OF_LIFE$url_CoL, "/data/search?type=EXACT&q=", gsub(" ", "%20", df$fullname, fixed = TRUE)))
paste0(CATALOGUE_OF_LIFE$url_LPSN, "/species/", gsub(" ", "-", tolower(df$fullname), fixed = TRUE)),
paste0(CATALOGUE_OF_LIFE$url_CoL, "/data/search?type=EXACT&q=", gsub(" ", "%20", df$fullname, fixed = TRUE))
)
genera <- which(df$kingdom == "Bacteria" & df$rank == "genus")
df$url[genera] <- gsub("/species/", "/genus/", df$url[genera], fixed = TRUE)
subsp <- which(df$kingdom == "Bacteria" & df$rank %in% c("subsp.", "infraspecies"))
df$url[subsp] <- gsub("/species/", "/subspecies/", df$url[subsp], fixed = TRUE)
u <- df$url
names(u) <- df$fullname
if (isTRUE(open)) {
if (length(u) > 1) {
warning_("in `mo_url()`: only the first URL will be opened, as `browseURL()` only suports one string.")
}
utils::browseURL(u[1L])
}
load_mo_failures_uncertainties_renamed(metadata)
u
}
@@ -699,7 +714,7 @@ mo_property <- function(x, property = "fullname", language = get_AMR_locale(), .
meet_criteria(x, allow_NA = TRUE)
meet_criteria(property, allow_class = "character", has_length = 1, is_in = colnames(microorganisms))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
translate_into_language(mo_validate(x = x, property = property, language = language, ...), language = language, only_unknown = TRUE)
}
@@ -715,22 +730,22 @@ mo_validate <- function(x, property, language, ...) {
Lancefield <- FALSE
}
has_Becker_or_Lancefield <- Becker %in% c(TRUE, "all") | Lancefield %in% c(TRUE, "all")
if (tryCatch(all(x[!is.na(x)] %in% MO_lookup$mo) & !has_Becker_or_Lancefield, error = function(e) FALSE)) {
# special case for mo_* functions where class is already <mo>
x <- MO_lookup[match(x, MO_lookup$mo), property, drop = TRUE]
} else {
# try to catch an error when inputting an invalid argument
# so the 'call.' can be set to FALSE
tryCatch(x[1L] %in% MO_lookup[1, property, drop = TRUE],
error = function(e) stop(e$message, call. = FALSE))
error = function(e) stop(e$message, call. = FALSE)
)
if (!all(x[!is.na(x)] %in% MO_lookup[, property, drop = TRUE]) | has_Becker_or_Lancefield) {
x <- exec_as.mo(x, property = property, language = language, ...)
}
}
if (property == "mo") {
return(set_clean_class(x, new_class = c("mo", "character")))
} else if (property == "species_id") {
@@ -747,9 +762,12 @@ find_mo_col <- function(fn) {
# which is useful when functions are used within dplyr verbs
df <- get_current_data(arg_name = "x", call = -3) # will return an error if not found
mo <- NULL
try({
mo <- suppressMessages(search_type_in_df(df, "mo"))
}, silent = TRUE)
try(
{
mo <- suppressMessages(search_type_in_df(df, "mo"))
},
silent = TRUE
)
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
if (message_not_thrown_before(fn = fn)) {
message_("Using column '", font_bold(mo), "' as input for `", fn, "()`")

105
R/mo_source.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -36,17 +36,17 @@
#' @details The reference file can be a text file separated with commas (CSV) or tabs or pipes, an Excel file (either 'xls' or 'xlsx' format) or an \R object file (extension '.rds'). To use an Excel file, you will need to have the `readxl` package installed.
#'
#' [set_mo_source()] will check the file for validity: it must be a [data.frame], must have a column named `"mo"` which contains values from [`microorganisms$mo`][microorganisms] or [`microorganisms$fullname`][microorganisms] and must have a reference column with your own defined values. If all tests pass, [set_mo_source()] will read the file into \R and will ask to export it to `"~/mo_source.rds"`. The CRAN policy disallows packages to write to the file system, although '*exceptions may be allowed in interactive sessions if the package obtains confirmation from the user*'. For this reason, this function only works in interactive sessions so that the user can **specifically confirm and allow** that this file will be created. The destination of this file can be set with the `destination` argument and defaults to the user's home directory. It can also be set as an \R option, using `options(AMR_mo_source = "my/location/file.rds")`.
#'
#' The created compressed data file `"mo_source.rds"` will be used at default for MO determination (function [as.mo()] and consequently all `mo_*` functions like [mo_genus()] and [mo_gramstain()]). The location and timestamp of the original file will be saved as an [attribute][base::attributes()] to the compressed data file.
#'
#'
#' The created compressed data file `"mo_source.rds"` will be used at default for MO determination (function [as.mo()] and consequently all `mo_*` functions like [mo_genus()] and [mo_gramstain()]). The location and timestamp of the original file will be saved as an [attribute][base::attributes()] to the compressed data file.
#'
#' The function [get_mo_source()] will return the data set by reading `"mo_source.rds"` with [readRDS()]. If the original file has changed (by checking the location and timestamp of the original file), it will call [set_mo_source()] to update the data file automatically if used in an interactive session.
#'
#' Reading an Excel file (`.xlsx`) with only one row has a size of 8-9 kB. The compressed file created with [set_mo_source()] will then have a size of 0.1 kB and can be read by [get_mo_source()] in only a couple of microseconds (millionths of a second).
#'
#'
#' @section How to Setup:
#'
#'
#' Imagine this data on a sheet of an Excel file. The first column contains the organisation specific codes, the second column contains valid taxonomic names:
#'
#'
#' ```
#' | A | B |
#' --|--------------------|-----------------------|
@@ -57,18 +57,18 @@
#' ```
#'
#' We save it as `"home/me/ourcodes.xlsx"`. Now we have to set it as a source:
#'
#'
#' ```
#' set_mo_source("home/me/ourcodes.xlsx")
#' #> NOTE: Created mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
#' #> '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
#' #> '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
#' #> "Organisation XYZ" and "mo"
#' ```
#'
#' It has now created a file `"~/mo_source.rds"` with the contents of our Excel file. Only the first column with foreign values and the 'mo' column will be kept when creating the RDS file.
#'
#' And now we can use it in our functions:
#'
#'
#' ```
#' as.mo("lab_mo_ecoli")
#' #> Class <mo>
@@ -86,7 +86,7 @@
#' ```
#'
#' If we edit the Excel file by, let's say, adding row 4 like this:
#'
#'
#' ```
#' | A | B |
#' --|--------------------|-----------------------|
@@ -98,10 +98,10 @@
#' ```
#'
#' ...any new usage of an MO function in this package will update your data file:
#'
#'
#' ```
#' as.mo("lab_mo_ecoli")
#' #> NOTE: Updated mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
#' #> NOTE: Updated mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
#' #> '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
#' #> "Organisation XYZ" and "mo"
#' #> Class <mo>
@@ -112,21 +112,21 @@
#' ```
#'
#' To delete the reference data file, just use `""`, `NULL` or `FALSE` as input for [set_mo_source()]:
#'
#'
#' ```
#' set_mo_source(NULL)
#' #> Removed mo_source file '/Users/me/mo_source.rds'
#' ```
#'
#'
#' If the original file (in the previous case an Excel file) is moved or deleted, the `mo_source.rds` file will be removed upon the next use of [as.mo()] or any [`mo_*`][mo_property()] function.
#' @export
set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_source.rds")) {
meet_criteria(path, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(destination, allow_class = "character", has_length = 1)
stop_ifnot(destination %like% "[.]rds$", "the `destination` must be a file location with file extension .rds.")
mo_source_destination <- path.expand(destination)
stop_ifnot(interactive(), "this function can only be used in interactive mode, since it must ask for the user's permission to write a file to their home folder.")
if (is.null(path) || path %in% c(FALSE, "")) {
@@ -134,77 +134,81 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
if (file.exists(mo_source_destination)) {
unlink(mo_source_destination)
message_("Removed mo_source file '", font_bold(mo_source_destination), "'",
add_fn = font_red,
as_note = FALSE)
add_fn = font_red,
as_note = FALSE
)
}
return(invisible())
}
stop_ifnot(file.exists(path), "file not found: ", path)
df <- NULL
if (path %like% "[.]rds$") {
df <- readRDS(path)
} else if (path %like% "[.]xlsx?$") {
# is Excel file (old or new)
stop_ifnot_installed("readxl")
df <- readxl::read_excel(path)
} else if (path %like% "[.]tsv$") {
df <- utils::read.table(file = path, header = TRUE, sep = "\t", stringsAsFactors = FALSE)
} else if (path %like% "[.]csv$") {
df <- utils::read.table(file = path, header = TRUE, sep = ",", stringsAsFactors = FALSE)
} else {
# try comma first
try(
df <- utils::read.table(file = path, header = TRUE, sep = ",", stringsAsFactors = FALSE),
silent = TRUE)
silent = TRUE
)
if (!check_validity_mo_source(df, stop_on_error = FALSE)) {
# try tab
try(
df <- utils::read.table(file = path, header = TRUE, sep = "\t", stringsAsFactors = FALSE),
silent = TRUE)
silent = TRUE
)
}
if (!check_validity_mo_source(df, stop_on_error = FALSE)) {
# try pipe
try(
df <- utils::read.table(file = path, header = TRUE, sep = "|", stringsAsFactors = FALSE),
silent = TRUE)
silent = TRUE
)
}
}
# check integrity
if (is.null(df)) {
stop_("the path '", path, "' could not be imported as a dataset.")
}
check_validity_mo_source(df)
df <- subset(df, !is.na(mo))
# keep only first two columns, second must be mo
if (colnames(df)[1] == "mo") {
df <- df[, c(colnames(df)[2], "mo")]
} else {
df <- df[, c(colnames(df)[1], "mo")]
}
df <- as.data.frame(df, stringAsFactors = FALSE)
df[, "mo"] <- as.mo(df[, "mo", drop = TRUE])
# success
if (file.exists(mo_source_destination)) {
action <- "Updated"
} else {
action <- "Created"
# only ask when file is created, not when it is updated
txt <- paste0(word_wrap(paste0("This will write create the new file '",
mo_source_destination,
"', for which your permission is needed.")),
"\n\n",
word_wrap("Do you agree that this file will be created?"))
txt <- paste0(
word_wrap(paste0(
"This will write create the new file '",
mo_source_destination,
"', for which your permission is needed."
)),
"\n\n",
word_wrap("Do you agree that this file will be created?")
)
showQuestion <- import_fn("showQuestion", "rstudioapi", error_on_fail = FALSE)
if (!is.null(showQuestion)) {
q_continue <- showQuestion("Create new file in home directory", txt)
@@ -220,11 +224,13 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
attr(df, "mo_source_timestamp") <- file.mtime(path)
saveRDS(df, mo_source_destination)
pkg_env$mo_source <- df
message_(action, " mo_source file '", font_bold(mo_source_destination),
"' (", formatted_filesize(mo_source_destination),
") from '", font_bold(path),
"' (", formatted_filesize(path),
'), columns "', colnames(df)[1], '" and "', colnames(df)[2], '"')
message_(
action, " mo_source file '", font_bold(mo_source_destination),
"' (", formatted_filesize(mo_source_destination),
") from '", font_bold(path),
"' (", formatted_filesize(path),
'), columns "', colnames(df)[1], '" and "', colnames(df)[2], '"'
)
}
#' @rdname mo_source
@@ -240,7 +246,7 @@ get_mo_source <- function(destination = getOption("AMR_mo_source", "~/mo_source.
if (is.null(pkg_env$mo_source)) {
pkg_env$mo_source <- readRDS(path.expand(destination))
}
old_time <- attributes(pkg_env$mo_source)$mo_source_timestamp
new_time <- file.mtime(attributes(pkg_env$mo_source)$mo_source_location)
if (interactive() && !identical(old_time, new_time)) {
@@ -252,7 +258,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) {
check_dataset_integrity()
if (paste(deparse(substitute(x)), collapse = "") == "get_mo_source()") {
return(TRUE)
}
@@ -288,10 +294,11 @@ check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_o
} else {
plural <- ""
}
stop_("Value", plural, " ", vector_and(invalid[, 1, drop = TRUE], quotes = TRUE),
" found in ", tolower(refer_to_name),
", but with invalid microorganism code", plural, " ", vector_and(invalid$mo, quotes = TRUE),
call = FALSE)
stop_("Value", plural, " ", vector_and(invalid[, 1, drop = TRUE], quotes = TRUE),
" found in ", tolower(refer_to_name),
", but with invalid microorganism code", plural, " ", vector_and(invalid$mo, quotes = TRUE),
call = FALSE
)
} else {
return(FALSE)
}

68
R/pca.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -24,42 +24,44 @@
# ==================================================================== #
#' Principal Component Analysis (for AMR)
#'
#'
#' Performs a principal component analysis (PCA) based on a data set with automatic determination for afterwards plotting the groups and labels, and automatic filtering on only suitable (i.e. non-empty and numeric) variables.
#' @param x a [data.frame] containing [numeric] columns
#' @param ... columns of `x` to be selected for PCA, can be unquoted since it supports quasiquotation.
#' @inheritParams stats::prcomp
#' @details The [pca()] function takes a [data.frame] as input and performs the actual PCA with the \R function [prcomp()].
#'
#'
#' The result of the [pca()] function is a [prcomp] object, with an additional attribute `non_numeric_cols` which is a vector with the column names of all columns that do not contain [numeric] values. These are probably the groups and labels, and will be used by [ggplot_pca()].
#' @return An object of classes [pca] and [prcomp]
#' @importFrom stats prcomp
#' @export
#' @examples
#' @examples
#' # `example_isolates` is a data set available in the AMR package.
#' # See ?example_isolates.
#'
#' \donttest{
#' if (require("dplyr")) {
#' # calculate the resistance per group first
#' resistance_data <- example_isolates %>%
#' group_by(order = mo_order(mo), # group on anything, like order
#' genus = mo_genus(mo)) %>% # and genus as we do here;
#' filter(n() >= 30) %>% # filter on only 30 results per group
#' summarise_if(is.rsi, resistance) # then get resistance of all drugs
#'
#' # calculate the resistance per group first
#' resistance_data <- example_isolates %>%
#' group_by(
#' order = mo_order(mo), # group on anything, like order
#' genus = mo_genus(mo)
#' ) %>% # and genus as we do here;
#' filter(n() >= 30) %>% # filter on only 30 results per group
#' summarise_if(is.rsi, resistance) # then get resistance of all drugs
#'
#' # now conduct PCA for certain antimicrobial agents
#' pca_result <- resistance_data %>%
#' pca(AMC, CXM, CTX, CAZ, GEN, TOB, TMP, SXT)
#'
#' pca_result <- resistance_data %>%
#' pca(AMC, CXM, CTX, CAZ, GEN, TOB, TMP, SXT)
#'
#' pca_result
#' summary(pca_result)
#'
#'
#' # old base R plotting method:
#' biplot(pca_result)
#' # new ggplot2 plotting method using this package:
#' ggplot_pca(pca_result)
#'
#'
#' if (require("ggplot2")) {
#' ggplot_pca(pca_result) +
#' scale_colour_viridis_d() +
@@ -70,7 +72,7 @@
pca <- function(x,
...,
retx = TRUE,
center = TRUE,
center = TRUE,
scale. = TRUE,
tol = NULL,
rank. = NULL) {
@@ -80,19 +82,20 @@ pca <- function(x,
meet_criteria(scale., allow_class = "logical", has_length = 1)
meet_criteria(tol, allow_class = "numeric", has_length = 1, allow_NULL = TRUE)
meet_criteria(rank., allow_class = "numeric", has_length = 1, allow_NULL = TRUE)
# unset data.table, tibble, etc.
# also removes groups made by dplyr::group_by
x <- as.data.frame(x, stringsAsFactors = FALSE)
x.bak <- x
# defuse R expressions, this replaces rlang::enquos()
dots <- substitute(list(...))
if (length(dots) > 1) {
new_list <- list(0)
for (i in seq_len(length(dots) - 1)) {
new_list[[i]] <- tryCatch(eval(dots[[i + 1]], envir = x),
error = function(e) stop(e$message, call. = FALSE))
error = function(e) stop(e$message, call. = FALSE)
)
if (length(new_list[[i]]) == 1) {
if (is.character(new_list[[i]]) & new_list[[i]] %in% colnames(x)) {
# this is to support quoted variables: df %pm>% pca("mycol1", "mycol2")
@@ -103,30 +106,33 @@ pca <- function(x,
}
}
}
x <- as.data.frame(new_list, stringsAsFactors = FALSE)
if (any(vapply(FUN.VALUE = logical(1), x, function(y) !is.numeric(y)))) {
warning_("in `pca()`: be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. See Examples in ?pca.", call = FALSE)
}
# set column names
tryCatch(colnames(x) <- as.character(dots)[2:length(dots)],
error = function(e) warning("column names could not be set"))
error = function(e) warning("column names could not be set")
)
# keep only numeric columns
x <- x[, vapply(FUN.VALUE = logical(1), x, function(y) is.numeric(y)), drop = FALSE]
# bind the data set with the non-numeric columns
x <- cbind(x.bak[, vapply(FUN.VALUE = logical(1), x.bak, function(y) !is.numeric(y) & !all(is.na(y))), drop = FALSE], x)
}
x <- pm_ungroup(x) # would otherwise select the grouping vars
x <- pm_ungroup(x) # would otherwise select the grouping vars
x <- x[rowSums(is.na(x)) == 0, ] # remove columns containing NAs
pca_data <- x[, which(vapply(FUN.VALUE = logical(1), x, function(x) is.numeric(x))), drop = FALSE]
message_("Columns selected for PCA: ", vector_and(font_bold(colnames(pca_data), collapse = NULL), quotes = TRUE),
". Total observations available: ", nrow(pca_data), ".")
message_(
"Columns selected for PCA: ", vector_and(font_bold(colnames(pca_data), collapse = NULL), quotes = TRUE),
". Total observations available: ", nrow(pca_data), "."
)
if (getRversion() < "3.4.0") {
# stats::prcomp prior to 3.4.0 does not have the 'rank.' argument
pca_model <- prcomp(pca_data, retx = retx, center = center, scale. = scale., tol = tol)

420
R/plot.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -24,7 +24,7 @@
# ==================================================================== #
#' Plotting for Classes `rsi`, `mic` and `disk`
#'
#'
#' Functions to plot classes `rsi`, `mic` and `disk`, with support for base \R and `ggplot2`.
#' @param x,object values created with [as.mic()], [as.disk()] or [as.rsi()] (or their `random_*` variants, such as [random_mic()])
@@ -38,30 +38,30 @@
#' @param expand a [logical] to indicate whether the range on the x axis should be expanded between the lowest and highest value. For MIC values, intermediate values will be factors of 2 starting from the highest MIC value. For disk diameters, the whole diameter range will be filled.
#' @details
#' The interpretation of "I" will be named "Increased exposure" for all EUCAST guidelines since 2019, and will be named "Intermediate" in all other cases.
#'
#'
#' For interpreting MIC values as well as disk diffusion diameters, supported guidelines to be used as input for the `guideline` argument are: `r vector_and(AMR::rsi_translation$guideline, quotes = TRUE, reverse = TRUE)`.
#'
#'
#' Simply using `"CLSI"` or `"EUCAST"` as input will automatically select the latest version of that guideline.
#' @name plot
#' @rdname plot
#' @return The `autoplot()` functions return a [`ggplot`][ggplot2::ggplot()] model that is extendible with any `ggplot2` function.
#'
#'
#' The `fortify()` functions return a [data.frame] as an extension for usage in the [ggplot2::ggplot()] function.
#' @param ... arguments passed on to methods
#' @examples
#' @examples
#' some_mic_values <- random_mic(size = 100)
#' some_disk_values <- random_disk(size = 100, mo = "Escherichia coli", ab = "cipro")
#' some_rsi_values <- random_rsi(50, prob_RSI = c(0.30, 0.55, 0.05))
#'
#'
#' plot(some_mic_values)
#' plot(some_disk_values)
#' plot(some_rsi_values)
#'
#'
#' # when providing the microorganism and antibiotic, colours will show interpretations:
#' plot(some_mic_values, mo = "S. aureus", ab = "ampicillin")
#' plot(some_disk_values, mo = "Escherichia coli", ab = "cipro")
#' plot(some_disk_values, mo = "Escherichia coli", ab = "cipro", language = "uk")
#'
#'
#' \donttest{
#' if (require("ggplot2")) {
#' autoplot(some_mic_values)
@@ -95,7 +95,7 @@ plot.mic <- function(x,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@@ -103,34 +103,37 @@ plot.mic <- function(x,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
x <- plot_prepare_table(x, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
language = language,
...)
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
language = language,
...
)
barplot(x,
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_RSI %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE)
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_RSI %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE
)
axis(2, seq(0, max(x)))
if (!is.null(cols_sub$sub)) {
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
}
if (any(colours_RSI %in% cols_sub$cols)) {
legend_txt <- character(0)
legend_col <- character(0)
@@ -146,16 +149,17 @@ plot.mic <- function(x,
legend_txt <- c(legend_txt, "Resistant")
legend_col <- c(legend_col, colours_RSI[1])
}
legend("top",
x.intersp = 0.5,
legend = translate_into_language(legend_txt, language = language),
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55")
x.intersp = 0.5,
legend = translate_into_language(legend_txt, language = language),
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55"
)
}
}
@@ -182,7 +186,7 @@ barplot.mic <- function(height,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@@ -190,18 +194,20 @@ barplot.mic <- function(height,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
plot(x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...)
plot(
x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...
)
}
#' @method autoplot mic
@@ -228,7 +234,7 @@ autoplot.mic <- function(object,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@@ -236,23 +242,25 @@ autoplot.mic <- function(object,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if ("main" %in% names(list(...))) {
title <- list(...)$main
}
if (!is.null(title)) {
title <- gsub(" +", " ", paste0(title, collapse = " "))
}
x <- plot_prepare_table(object, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
language = language,
...)
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.mic,
language = language,
...
)
df <- as.data.frame(x, stringsAsFactors = TRUE)
colnames(df) <- c("mic", "count")
df$cols <- cols_sub$cols
@@ -260,28 +268,34 @@ autoplot.mic <- function(object,
df$cols[df$cols == colours_RSI[2]] <- "Susceptible"
df$cols[df$cols == colours_RSI[3]] <- plot_name_of_I(cols_sub$guideline)
df$cols <- factor(translate_into_language(df$cols, language = language),
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
language = language),
ordered = TRUE)
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
language = language
),
ordered = TRUE
)
p <- ggplot2::ggplot(df)
if (any(colours_RSI %in% cols_sub$cols)) {
vals <- c("Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3])
vals <- c(
"Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3]
)
names(vals) <- translate_into_language(names(vals), language = language)
p <- p +
ggplot2::geom_col(ggplot2::aes(x = mic, y = count, fill = cols)) +
ggplot2::geom_col(ggplot2::aes(x = mic, y = count, fill = cols)) +
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
ggplot2::scale_fill_manual(values = vals,
name = NULL,
limits = force)
ggplot2::scale_fill_manual(
values = vals,
name = NULL,
limits = force
)
} else {
p <- p +
ggplot2::geom_col(ggplot2::aes(x = mic, y = count))
}
p +
ggplot2::labs(title = title, x = xlab, y = ylab, subtitle = cols_sub$sub)
}
@@ -290,8 +304,10 @@ autoplot.mic <- function(object,
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
fortify.mic <- function(object, ...) {
stats::setNames(as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y"))
stats::setNames(
as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y")
)
}
#' @method plot disk
@@ -318,7 +334,7 @@ plot.disk <- function(x,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@@ -326,35 +342,38 @@ plot.disk <- function(x,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
x <- plot_prepare_table(x, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
language = language,
...)
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
language = language,
...
)
barplot(x,
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_RSI %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE)
col = cols_sub$cols,
main = main,
ylim = c(0, max(x) * ifelse(any(colours_RSI %in% cols_sub$cols), 1.1, 1)),
ylab = ylab,
xlab = xlab,
axes = FALSE
)
axis(2, seq(0, max(x)))
if (!is.null(cols_sub$sub)) {
mtext(side = 3, line = 0.5, adj = 0.5, cex = 0.75, cols_sub$sub)
}
if (any(colours_RSI %in% cols_sub$cols)) {
legend_txt <- character(0)
legend_col <- character(0)
@@ -370,15 +389,16 @@ plot.disk <- function(x,
legend_txt <- c(legend_txt, "Susceptible")
legend_col <- c(legend_col, colours_RSI[2])
}
legend("top",
x.intersp = 0.5,
legend = translate_into_language(legend_txt, language = language),
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55")
legend("top",
x.intersp = 0.5,
legend = translate_into_language(legend_txt, language = language),
fill = legend_col,
horiz = TRUE,
cex = 0.75,
box.lwd = 0,
box.col = "#FFFFFF55",
bg = "#FFFFFF55"
)
}
}
@@ -405,7 +425,7 @@ barplot.disk <- function(height,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@@ -413,18 +433,20 @@ barplot.disk <- function(height,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
plot(x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...)
plot(
x = height,
main = main,
ylab = ylab,
xlab = xlab,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
...
)
}
#' @method autoplot disk
@@ -451,7 +473,7 @@ autoplot.disk <- function(object,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@@ -459,53 +481,61 @@ autoplot.disk <- function(object,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if ("main" %in% names(list(...))) {
title <- list(...)$main
}
if (!is.null(title)) {
title <- gsub(" +", " ", paste0(title, collapse = " "))
}
x <- plot_prepare_table(object, expand = expand)
cols_sub <- plot_colours_subtitle_guideline(x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
language = language,
...)
cols_sub <- plot_colours_subtitle_guideline(
x = x,
mo = mo,
ab = ab,
guideline = guideline,
colours_RSI = colours_RSI,
fn = as.disk,
language = language,
...
)
df <- as.data.frame(x, stringsAsFactors = TRUE)
colnames(df) <- c("disk", "count")
df$cols <- cols_sub$cols
df$cols[df$cols == colours_RSI[1]] <- "Resistant"
df$cols[df$cols == colours_RSI[2]] <- "Susceptible"
df$cols[df$cols == colours_RSI[3]] <- plot_name_of_I(cols_sub$guideline)
df$cols <- factor(translate_into_language(df$cols, language = language),
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
language = language),
ordered = TRUE)
levels = translate_into_language(c("Susceptible", plot_name_of_I(cols_sub$guideline), "Resistant"),
language = language
),
ordered = TRUE
)
p <- ggplot2::ggplot(df)
if (any(colours_RSI %in% cols_sub$cols)) {
vals <- c("Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3])
vals <- c(
"Resistant" = colours_RSI[1],
"Susceptible" = colours_RSI[2],
"Susceptible, incr. exp." = colours_RSI[3],
"Intermediate" = colours_RSI[3]
)
names(vals) <- translate_into_language(names(vals), language = language)
p <- p +
ggplot2::geom_col(ggplot2::aes(x = disk, y = count, fill = cols)) +
ggplot2::geom_col(ggplot2::aes(x = disk, y = count, fill = cols)) +
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
ggplot2::scale_fill_manual(values = vals,
name = NULL,
limits = force)
ggplot2::scale_fill_manual(
values = vals,
name = NULL,
limits = force
)
} else {
p <- p +
ggplot2::geom_col(ggplot2::aes(x = disk, y = count))
}
p +
ggplot2::labs(title = title, x = xlab, y = ylab, subtitle = cols_sub$sub)
}
@@ -514,8 +544,10 @@ autoplot.disk <- function(object,
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
fortify.disk <- function(object, ...) {
stats::setNames(as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y"))
stats::setNames(
as.data.frame(plot_prepare_table(object, expand = FALSE)),
c("x", "y")
)
}
#' @method plot rsi
@@ -531,7 +563,7 @@ plot.rsi <- function(x,
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(main, allow_class = "character", has_length = 1, allow_NULL = TRUE)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@@ -539,44 +571,51 @@ plot.rsi <- function(x,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
data <- as.data.frame(table(x), stringsAsFactors = FALSE)
colnames(data) <- c("x", "n")
data$s <- round((data$n / sum(data$n)) * 100, 1)
if (!"S" %in% data$x) {
data <- rbind(data, data.frame(x = "S", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
}
if (!"I" %in% data$x) {
data <- rbind(data, data.frame(x = "I", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
}
if (!"R" %in% data$x) {
data <- rbind(data, data.frame(x = "R", n = 0, s = 0, stringsAsFactors = FALSE),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
}
data$x <- factor(data$x, levels = c("S", "I", "R"), ordered = TRUE)
ymax <- pm_if_else(max(data$s) > 95, 105, 100)
plot(x = data$x,
y = data$s,
lwd = 2,
ylim = c(0, ymax),
ylab = ylab,
xlab = xlab,
main = main,
axes = FALSE)
plot(
x = data$x,
y = data$s,
lwd = 2,
ylim = c(0, ymax),
ylab = ylab,
xlab = xlab,
main = main,
axes = FALSE
)
# x axis
axis(side = 1, at = 1:pm_n_distinct(data$x), labels = levels(data$x), lwd = 0)
# y axis, 0-100%
axis(side = 2, at = seq(0, 100, 5))
text(x = data$x,
y = data$s + 4,
labels = paste0(data$s, "% (n = ", data$n, ")"))
text(
x = data$x,
y = data$s + 4,
labels = paste0(data$s, "% (n = ", data$n, ")")
)
}
@@ -598,7 +637,7 @@ barplot.rsi <- function(height,
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
meet_criteria(language, has_length = 1, is_in = c(LANGUAGES_SUPPORTED, ""), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(expand, allow_class = "logical", has_length = 1)
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@@ -606,22 +645,23 @@ barplot.rsi <- function(height,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
} else {
colours_RSI <- c(colours_RSI[2], colours_RSI[3], colours_RSI[1])
}
main <- gsub(" +", " ", paste0(main, collapse = " "))
x <- table(height)
x <- x[c(1, 2, 3)]
barplot(x,
col = colours_RSI,
xlab = xlab,
main = main,
ylab = ylab,
axes = FALSE)
col = colours_RSI,
xlab = xlab,
main = main,
ylab = ylab,
axes = FALSE
)
axis(2, seq(0, max(x)))
}
@@ -640,7 +680,7 @@ autoplot.rsi <- function(object,
meet_criteria(ylab, allow_class = "character", has_length = 1)
meet_criteria(xlab, allow_class = "character", has_length = 1)
meet_criteria(colours_RSI, allow_class = "character", has_length = c(1, 3))
# translate if not specifically set
if (missing(ylab)) {
ylab <- translate_into_language(ylab, language = language)
@@ -648,27 +688,31 @@ autoplot.rsi <- function(object,
if (missing(xlab)) {
xlab <- translate_into_language(xlab, language = language)
}
if ("main" %in% names(list(...))) {
title <- list(...)$main
}
if (!is.null(title)) {
title <- gsub(" +", " ", paste0(title, collapse = " "))
}
if (length(colours_RSI) == 1) {
colours_RSI <- rep(colours_RSI, 3)
}
df <- as.data.frame(table(object), stringsAsFactors = TRUE)
colnames(df) <- c("rsi", "count")
ggplot2::ggplot(df) +
ggplot2::geom_col(ggplot2::aes(x = rsi, y = count, fill = rsi)) +
ggplot2::geom_col(ggplot2::aes(x = rsi, y = count, fill = rsi)) +
# limits = force is needed because of a ggplot2 >= 3.3.4 bug (#4511)
ggplot2::scale_fill_manual(values = c("R" = colours_RSI[1],
"S" = colours_RSI[2],
"I" = colours_RSI[3]),
limits = force) +
ggplot2::scale_fill_manual(
values = c(
"R" = colours_RSI[1],
"S" = colours_RSI[2],
"I" = colours_RSI[3]
),
limits = force
) +
ggplot2::labs(title = title, x = xlab, y = ylab) +
ggplot2::theme(legend.position = "none")
}
@@ -677,8 +721,10 @@ autoplot.rsi <- function(object,
#' @rdname plot
# will be exported using s3_register() in R/zzz.R
fortify.rsi <- function(object, ...) {
stats::setNames(as.data.frame(table(object)),
c("x", "y"))
stats::setNames(
as.data.frame(table(object)),
c("x", "y")
)
}
plot_prepare_table <- function(x, expand) {
@@ -743,8 +789,10 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_RSI, f
moname <- mo_name(mo, language = language)
abname <- ab_name(ab, language = language)
if (all(cols == "#BEBEBE")) {
message_("No ", guideline, " interpretations found for ",
ab_name(ab, language = NULL, tolower = TRUE), " in ", moname)
message_(
"No ", guideline, " interpretations found for ",
ab_name(ab, language = NULL, tolower = TRUE), " in ", moname
)
guideline_txt <- ""
} else {
guideline_txt <- guideline
@@ -753,7 +801,7 @@ plot_colours_subtitle_guideline <- function(x, mo, ab, guideline, colours_RSI, f
}
guideline_txt <- paste0("(", guideline_txt, ")")
}
sub <- bquote(.(abname)~"-"~italic(.(moname))~.(guideline_txt))
sub <- bquote(.(abname) ~ "-" ~ italic(.(moname)) ~ .(guideline_txt))
} else {
cols <- "#BEBEBE"
sub <- NULL

209
R/proportion.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -40,7 +40,7 @@
#' @inheritSection as.rsi Interpretation of R and S/I
#' @details
#' The function [resistance()] is equal to the function [proportion_R()]. The function [susceptibility()] is equal to the function [proportion_SI()].
#'
#'
#' **Remember that you should filter your data to let it contain only first isolates!** This is needed to exclude duplicates and to reduce selection bias. Use [first_isolate()] to determine them in your data set.
#'
#' These functions are not meant to count isolates, but to calculate the proportion of resistance/susceptibility. Use the [`count()`][AMR::count()] functions to count isolates. The function [susceptibility()] is essentially equal to `count_susceptible() / count_all()`. *Low counts can influence the outcome - the `proportion` functions may camouflage this, since they only return the proportion (albeit being dependent on the `minimum` argument).*
@@ -90,9 +90,9 @@
#' @examples
#' # example_isolates is a data set available in the AMR package.
#' # run ?example_isolates for more info.
#'
#'
#' # base R ------------------------------------------------------------
#' resistance(example_isolates$AMX) # determines %R
#' resistance(example_isolates$AMX) # determines %R
#' susceptibility(example_isolates$AMX) # determines %S+I
#'
#' # be more specific
@@ -107,55 +107,65 @@
#' if (require("dplyr")) {
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(r = resistance(CIP),
#' n = n_rsi(CIP)) # n_rsi works like n_distinct in dplyr, see ?n_rsi
#'
#' summarise(
#' r = resistance(CIP),
#' n = n_rsi(CIP)
#' ) # n_rsi works like n_distinct in dplyr, see ?n_rsi
#'
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(R = resistance(CIP, as_percent = TRUE),
#' SI = susceptibility(CIP, as_percent = TRUE),
#' n1 = count_all(CIP), # the actual total; sum of all three
#' n2 = n_rsi(CIP), # same - analogous to n_distinct
#' total = n()) # NOT the number of tested isolates!
#'
#' summarise(
#' R = resistance(CIP, as_percent = TRUE),
#' SI = susceptibility(CIP, as_percent = TRUE),
#' n1 = count_all(CIP), # the actual total; sum of all three
#' n2 = n_rsi(CIP), # same - analogous to n_distinct
#' total = n()
#' ) # NOT the number of tested isolates!
#'
#' # Calculate co-resistance between amoxicillin/clav acid and gentamicin,
#' # so we can see that combination therapy does a lot more than mono therapy:
#' example_isolates %>% susceptibility(AMC) # %SI = 76.3%
#' example_isolates %>% count_all(AMC) # n = 1879
#'
#' example_isolates %>% susceptibility(GEN) # %SI = 75.4%
#' example_isolates %>% count_all(GEN) # n = 1855
#'
#' example_isolates %>% susceptibility(AMC) # %SI = 76.3%
#' example_isolates %>% count_all(AMC) # n = 1879
#'
#' example_isolates %>% susceptibility(GEN) # %SI = 75.4%
#' example_isolates %>% count_all(GEN) # n = 1855
#'
#' example_isolates %>% susceptibility(AMC, GEN) # %SI = 94.1%
#' example_isolates %>% count_all(AMC, GEN) # n = 1939
#'
#'
#' example_isolates %>% count_all(AMC, GEN) # n = 1939
#'
#'
#' # See Details on how `only_all_tested` works. Example:
#' example_isolates %>%
#' summarise(numerator = count_susceptible(AMC, GEN),
#' denominator = count_all(AMC, GEN),
#' proportion = susceptibility(AMC, GEN))
#'
#' summarise(
#' numerator = count_susceptible(AMC, GEN),
#' denominator = count_all(AMC, GEN),
#' proportion = susceptibility(AMC, GEN)
#' )
#'
#' example_isolates %>%
#' summarise(numerator = count_susceptible(AMC, GEN, only_all_tested = TRUE),
#' denominator = count_all(AMC, GEN, only_all_tested = TRUE),
#' proportion = susceptibility(AMC, GEN, only_all_tested = TRUE))
#'
#'
#' summarise(
#' numerator = count_susceptible(AMC, GEN, only_all_tested = TRUE),
#' denominator = count_all(AMC, GEN, only_all_tested = TRUE),
#' proportion = susceptibility(AMC, GEN, only_all_tested = TRUE)
#' )
#'
#'
#' example_isolates %>%
#' group_by(ward) %>%
#' summarise(cipro_p = susceptibility(CIP, as_percent = TRUE),
#' cipro_n = count_all(CIP),
#' genta_p = susceptibility(GEN, as_percent = TRUE),
#' genta_n = count_all(GEN),
#' combination_p = susceptibility(CIP, GEN, as_percent = TRUE),
#' combination_n = count_all(CIP, GEN))
#'
#' summarise(
#' cipro_p = susceptibility(CIP, as_percent = TRUE),
#' cipro_n = count_all(CIP),
#' genta_p = susceptibility(GEN, as_percent = TRUE),
#' genta_n = count_all(GEN),
#' combination_p = susceptibility(CIP, GEN, as_percent = TRUE),
#' combination_n = count_all(CIP, GEN)
#' )
#'
#' # Get proportions S/I/R immediately of all rsi columns
#' example_isolates %>%
#' select(AMX, CIP) %>%
#' proportion_df(translate = FALSE)
#'
#'
#' # It also supports grouping variables
#' # (use rsi_df to also include the count)
#' example_isolates %>%
@@ -170,12 +180,14 @@ resistance <- function(...,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = "R",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
ab_result = "R",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -186,12 +198,14 @@ susceptibility <- function(...,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = c("S", "I"),
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
ab_result = c("S", "I"),
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -202,12 +216,14 @@ proportion_R <- function(...,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = "R",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
ab_result = "R",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -218,12 +234,14 @@ proportion_IR <- function(...,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = c("I", "R"),
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
ab_result = c("I", "R"),
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -234,12 +252,14 @@ proportion_I <- function(...,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = "I",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
ab_result = "I",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -250,12 +270,14 @@ proportion_SI <- function(...,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = c("S", "I"),
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
ab_result = c("S", "I"),
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -266,12 +288,14 @@ proportion_S <- function(...,
only_all_tested = FALSE) {
tryCatch(
rsi_calc(...,
ab_result = "S",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE),
error = function(e) stop_(e$message, call = -5))
ab_result = "S",
minimum = minimum,
as_percent = as_percent,
only_all_tested = only_all_tested,
only_count = FALSE
),
error = function(e) stop_(e$message, call = -5)
)
}
#' @rdname proportion
@@ -284,14 +308,17 @@ proportion_df <- function(data,
combine_SI = TRUE,
combine_IR = FALSE) {
tryCatch(
rsi_calc_df(type = "proportion",
data = data,
translate_ab = translate_ab,
language = language,
minimum = minimum,
as_percent = as_percent,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI)),
error = function(e) stop_(e$message, call = -5))
rsi_calc_df(
type = "proportion",
data = data,
translate_ab = translate_ab,
language = language,
minimum = minimum,
as_percent = as_percent,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI)
),
error = function(e) stop_(e$message, call = -5)
)
}

56
R/random.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -25,14 +25,14 @@
#' Random MIC Values/Disk Zones/RSI Generation
#'
#' These functions can be used for generating random MIC values and disk diffusion diameters, for AMR data analysis practice. By providing a microorganism and antimicrobial agent, the generated results will reflect reality as much as possible.
#' These functions can be used for generating random MIC values and disk diffusion diameters, for AMR data analysis practice. By providing a microorganism and antimicrobial agent, the generated results will reflect reality as much as possible.
#' @param size desired size of the returned vector. If used in a [data.frame] call or `dplyr` verb, will get the current (group) size if left blank.
#' @param mo any [character] that can be coerced to a valid microorganism code with [as.mo()]
#' @param ab any [character] that can be coerced to a valid antimicrobial agent code with [as.ab()]
#' @param prob_RSI a vector of length 3: the probabilities for "R" (1st value), "S" (2nd value) and "I" (3rd value)
#' @param ... ignored, only in place to allow future extensions
#' @details The base \R function [sample()] is used for generating values.
#'
#'
#' Generated values are based on the EUCAST `r max(as.integer(gsub("[^0-9]", "", subset(rsi_translation, guideline %like% "EUCAST")$guideline)))` guideline as implemented in the [rsi_translation] data set. To create specific generated values per bug or drug, set the `mo` and/or `ab` argument.
#' @return class `<mic>` for [random_mic()] (see [as.mic()]) and class `<disk>` for [random_disk()] (see [as.disk()])
#' @name random
@@ -42,15 +42,15 @@
#' random_mic(25)
#' random_disk(25)
#' random_rsi(25)
#'
#'
#' \donttest{
#' # make the random generation more realistic by setting a bug and/or drug:
#' random_mic(25, "Klebsiella pneumoniae") # range 0.0625-64
#' random_mic(25, "Klebsiella pneumoniae", "meropenem") # range 0.0625-16
#' random_mic(25, "Klebsiella pneumoniae") # range 0.0625-64
#' random_mic(25, "Klebsiella pneumoniae", "meropenem") # range 0.0625-16
#' random_mic(25, "Streptococcus pneumoniae", "meropenem") # range 0.0625-4
#'
#' random_disk(25, "Klebsiella pneumoniae") # range 8-50
#' random_disk(25, "Klebsiella pneumoniae", "ampicillin") # range 11-17
#'
#' random_disk(25, "Klebsiella pneumoniae") # range 8-50
#' random_disk(25, "Klebsiella pneumoniae", "ampicillin") # range 11-17
#' random_disk(25, "Streptococcus pneumoniae", "ampicillin") # range 12-27
#' }
random_mic <- function(size = NULL, mo = NULL, ab = NULL, ...) {
@@ -92,14 +92,16 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
pm_filter(guideline %like% "EUCAST") %pm>%
pm_arrange(pm_desc(guideline)) %pm>%
subset(guideline == max(guideline) &
method == type)
method == type)
if (!is.null(mo)) {
mo_coerced <- as.mo(mo)
mo_include <- c(mo_coerced,
as.mo(mo_genus(mo_coerced)),
as.mo(mo_family(mo_coerced)),
as.mo(mo_order(mo_coerced)))
mo_include <- c(
mo_coerced,
as.mo(mo_genus(mo_coerced)),
as.mo(mo_family(mo_coerced)),
as.mo(mo_order(mo_coerced))
)
df_new <- df %pm>%
subset(mo %in% mo_include)
if (nrow(df_new) > 0) {
@@ -108,7 +110,7 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
warning_("in `random_", tolower(type), "()`: no rows found that match mo '", mo, "', ignoring argument `mo`")
}
}
if (!is.null(ab)) {
ab_coerced <- as.ab(ab)
df_new <- df %pm>%
@@ -119,16 +121,20 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
warning_("in `random_", tolower(type), "()`: no rows found that match ab '", ab, "', ignoring argument `ab`")
}
}
if (type == "MIC") {
# set range
mic_range <- c(0.001, 0.002, 0.005, 0.010, 0.025, 0.0625, 0.125, 0.250, 0.5, 1, 2, 4, 8, 16, 32, 64, 128, 256)
# get highest/lowest +/- random 1 to 3 higher factors of two
max_range <- mic_range[min(length(mic_range),
which(mic_range == max(df$breakpoint_R)) + sample(c(1:3), 1))]
min_range <- mic_range[max(1,
which(mic_range == min(df$breakpoint_S)) - sample(c(1:3), 1))]
max_range <- mic_range[min(
length(mic_range),
which(mic_range == max(df$breakpoint_R)) + sample(c(1:3), 1)
)]
min_range <- mic_range[max(
1,
which(mic_range == min(df$breakpoint_S)) - sample(c(1:3), 1)
)]
mic_range_new <- mic_range[mic_range <= max_range & mic_range >= min_range]
if (length(mic_range_new) == 0) {
@@ -144,9 +150,11 @@ random_exec <- function(type, size, mo = NULL, ab = NULL) {
}
return(out)
} else if (type == "DISK") {
set_range <- seq(from = as.integer(min(df$breakpoint_R) / 1.25),
to = as.integer(max(df$breakpoint_S) * 1.25),
by = 1)
set_range <- seq(
from = as.integer(min(df$breakpoint_R) / 1.25),
to = as.integer(max(df$breakpoint_S) * 1.25),
by = 1
)
out <- sample(set_range, size = size, replace = TRUE)
out[out < 6] <- sample(c(6:10), length(out[out < 6]), replace = TRUE)
out[out > 50] <- sample(c(40:50), length(out[out > 50]), replace = TRUE)

219
R/resistance_predict.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -34,7 +34,7 @@
#' @param year_every unit of sequence between lowest year found in the data and `year_max`
#' @param minimum minimal amount of available isolates per year to include. Years containing less observations will be estimated by the model.
#' @param model the statistical model of choice. This could be a generalised linear regression model with binomial distribution (i.e. using `glm(..., family = binomial)`, assuming that a period of zero resistance was followed by a period of increasing resistance leading slowly to more and more resistance. See *Details* for all valid options.
#' @param I_as_S a [logical] to indicate whether values `"I"` should be treated as `"S"` (will otherwise be treated as `"R"`). The default, `TRUE`, follows the redefinition by EUCAST about the interpretation of I (increased exposure) in 2019, see section *Interpretation of S, I and R* below.
#' @param I_as_S a [logical] to indicate whether values `"I"` should be treated as `"S"` (will otherwise be treated as `"R"`). The default, `TRUE`, follows the redefinition by EUCAST about the interpretation of I (increased exposure) in 2019, see section *Interpretation of S, I and R* below.
#' @param preserve_measurements a [logical] to indicate whether predictions of years that are actually available in the data should be overwritten by the original data. The standard errors of those years will be `NA`.
#' @param info a [logical] to indicate whether textual analysis should be printed with the name and [summary()] of the statistical model.
#' @param main title of the plot
@@ -55,19 +55,20 @@
#' - `observations`, the total number of available observations in that year, i.e. \eqn{S + I + R}
#' - `observed`, the original observed resistant percentages
#' - `estimated`, the estimated resistant percentages, calculated by the model
#'
#'
#' Furthermore, the model itself is available as an attribute: `attributes(x)$model`, see *Examples*.
#' @seealso The [proportion()] functions to calculate resistance
#'
#'
#' Models: [lm()] [glm()]
#' @rdname resistance_predict
#' @export
#' @importFrom stats predict glm lm
#' @examples
#' x <- resistance_predict(example_isolates,
#' col_ab = "AMX",
#' year_min = 2010,
#' model = "binomial")
#' x <- resistance_predict(example_isolates,
#' col_ab = "AMX",
#' year_min = 2010,
#' model = "binomial"
#' )
#' plot(x)
#' \donttest{
#' if (require("ggplot2")) {
@@ -89,14 +90,15 @@
#'
#' # create nice plots with ggplot2 yourself
#' if (require("dplyr") && require("ggplot2")) {
#'
#' data <- example_isolates %>%
#' filter(mo == as.mo("E. coli")) %>%
#' resistance_predict(col_ab = "AMX",
#' col_date = "date",
#' model = "binomial",
#' info = FALSE,
#' minimum = 15)
#' resistance_predict(
#' col_ab = "AMX",
#' col_date = "date",
#' model = "binomial",
#' info = FALSE,
#' minimum = 15
#' )
#' head(data)
#' autoplot(data)
#' }
@@ -124,12 +126,12 @@ resistance_predict <- function(x,
meet_criteria(I_as_S, allow_class = "logical", has_length = 1)
meet_criteria(preserve_measurements, allow_class = "logical", has_length = 1)
meet_criteria(info, allow_class = "logical", has_length = 1)
stop_if(is.null(model), 'choose a regression model with the `model` argument, e.g. resistance_predict(..., model = "binomial")')
x.bak <- x
x <- as.data.frame(x, stringsAsFactors = FALSE)
dots <- unlist(list(...))
if (length(dots) != 0) {
# backwards compatibility with old arguments
@@ -141,15 +143,17 @@ resistance_predict <- function(x,
warning_("in `resistance_predict()`: I_as_R is deprecated - use I_as_S instead.")
}
}
# -- date
if (is.null(col_date)) {
col_date <- search_type_in_df(x = x, type = "date")
stop_if(is.null(col_date), "`col_date` must be set")
}
stop_ifnot(col_date %in% colnames(x),
"column '", col_date, "' not found")
stop_ifnot(
col_date %in% colnames(x),
"column '", col_date, "' not found"
)
year <- function(x) {
# don't depend on lubridate or so, would be overkill for only this function
if (all(grepl("^[0-9]{4}$", x))) {
@@ -158,7 +162,7 @@ resistance_predict <- function(x,
as.integer(format(as.Date(x), "%Y"))
}
}
df <- x
df[, col_ab] <- droplevels(as.rsi(df[, col_ab, drop = TRUE]))
if (I_as_S == TRUE) {
@@ -169,22 +173,23 @@ resistance_predict <- function(x,
df[, col_ab] <- gsub("I", "R", df[, col_ab, drop = TRUE])
}
df[, col_ab] <- ifelse(is.na(df[, col_ab, drop = TRUE]), 0, df[, col_ab, drop = TRUE])
# remove rows with NAs
df <- subset(df, !is.na(df[, col_ab, drop = TRUE]))
df$year <- year(df[, col_date, drop = TRUE])
df <- as.data.frame(rbind(table(df[, c("year", col_ab), drop = FALSE])),
stringsAsFactors = FALSE)
stringsAsFactors = FALSE
)
df$year <- as.integer(rownames(df))
rownames(df) <- NULL
df <- subset(df, sum(df$R + df$S, na.rm = TRUE) >= minimum)
# nolint start
df_matrix <- as.matrix(df[, c("R", "S"), drop = FALSE])
# nolint end
stop_if(NROW(df) == 0, "there are no observations")
year_lowest <- min(df$year)
if (is.null(year_min)) {
year_min <- year_lowest
@@ -194,9 +199,9 @@ resistance_predict <- function(x,
if (is.null(year_max)) {
year_max <- year(Sys.Date()) + 10
}
years <- list(year = seq(from = year_min, to = year_max, by = year_every))
if (model %in% c("binomial", "binom", "logit")) {
model <- "binomial"
model_lm <- with(df, glm(df_matrix ~ year, family = binomial))
@@ -205,11 +210,10 @@ resistance_predict <- function(x,
cat("\n------------------------------------------------------------\n")
print(summary(model_lm))
}
predictmodel <- predict(model_lm, newdata = years, type = "response", se.fit = TRUE)
prediction <- predictmodel$fit
se <- predictmodel$se.fit
} else if (model %in% c("loglin", "poisson")) {
model <- "poisson"
model_lm <- with(df, glm(R ~ year, family = poisson))
@@ -218,11 +222,10 @@ resistance_predict <- function(x,
cat("\n--------------------------------------------------------------\n")
print(summary(model_lm))
}
predictmodel <- predict(model_lm, newdata = years, type = "response", se.fit = TRUE)
prediction <- predictmodel$fit
se <- predictmodel$se.fit
} else if (model %in% c("lin", "linear")) {
model <- "linear"
model_lm <- with(df, lm((R / (R + S)) ~ year))
@@ -231,59 +234,61 @@ resistance_predict <- function(x,
cat("\n-----------------------\n")
print(summary(model_lm))
}
predictmodel <- predict(model_lm, newdata = years, se.fit = TRUE)
prediction <- predictmodel$fit
se <- predictmodel$se.fit
} else {
stop("no valid model selected. See ?resistance_predict.")
}
# prepare the output dataframe
df_prediction <- data.frame(year = unlist(years),
value = prediction,
se_min = prediction - se,
se_max = prediction + se,
stringsAsFactors = FALSE)
df_prediction <- data.frame(
year = unlist(years),
value = prediction,
se_min = prediction - se,
se_max = prediction + se,
stringsAsFactors = FALSE
)
if (model == "poisson") {
df_prediction$value <- as.integer(format(df_prediction$value, scientific = FALSE))
df_prediction$se_min <- as.integer(df_prediction$se_min)
df_prediction$se_max <- as.integer(df_prediction$se_max)
} else {
# se_max not above 1
df_prediction$se_max <- ifelse(df_prediction$se_max > 1, 1, df_prediction$se_max)
}
# se_min not below 0
df_prediction$se_min <- ifelse(df_prediction$se_min < 0, 0, df_prediction$se_min)
df_observations <- data.frame(year = df$year,
observations = df$R + df$S,
observed = df$R / (df$R + df$S),
stringsAsFactors = FALSE)
df_observations <- data.frame(
year = df$year,
observations = df$R + df$S,
observed = df$R / (df$R + df$S),
stringsAsFactors = FALSE
)
df_prediction <- df_prediction %pm>%
pm_left_join(df_observations, by = "year")
df_prediction$estimated <- df_prediction$value
if (preserve_measurements == TRUE) {
# replace estimated data by observed data
df_prediction$value <- ifelse(!is.na(df_prediction$observed), df_prediction$observed, df_prediction$value)
df_prediction$se_min <- ifelse(!is.na(df_prediction$observed), NA, df_prediction$se_min)
df_prediction$se_max <- ifelse(!is.na(df_prediction$observed), NA, df_prediction$se_max)
}
df_prediction$value <- ifelse(df_prediction$value > 1, 1, ifelse(df_prediction$value < 0, 0, df_prediction$value))
df_prediction <- df_prediction[order(df_prediction$year), , drop = FALSE]
out <- as_original_data_class(df_prediction, class(x.bak))
structure(out,
class = c("resistance_predict", class(out)),
I_as_S = I_as_S,
model_title = model,
model = model_lm,
ab = col_ab
class = c("resistance_predict", class(out)),
I_as_S = I_as_S,
model_title = model,
model = model_lm,
ab = col_ab
)
}
@@ -298,40 +303,48 @@ rsi_predict <- resistance_predict
plot.resistance_predict <- function(x, main = paste("Resistance Prediction of", x_name), ...) {
x_name <- paste0(ab_name(attributes(x)$ab), " (", attributes(x)$ab, ")")
meet_criteria(main, allow_class = "character", has_length = 1)
if (attributes(x)$I_as_S == TRUE) {
ylab <- "%R"
} else {
ylab <- "%IR"
}
plot(x = x$year,
y = x$value,
ylim = c(0, 1),
yaxt = "n", # no y labels
pch = 19, # closed dots
ylab = paste0("Percentage (", ylab, ")"),
xlab = "Year",
main = main,
sub = paste0("(n = ", sum(x$observations, na.rm = TRUE),
", model: ", attributes(x)$model_title, ")"),
cex.sub = 0.75)
plot(
x = x$year,
y = x$value,
ylim = c(0, 1),
yaxt = "n", # no y labels
pch = 19, # closed dots
ylab = paste0("Percentage (", ylab, ")"),
xlab = "Year",
main = main,
sub = paste0(
"(n = ", sum(x$observations, na.rm = TRUE),
", model: ", attributes(x)$model_title, ")"
),
cex.sub = 0.75
)
axis(side = 2, at = seq(0, 1, 0.1), labels = paste0(0:10 * 10, "%"))
# hack for error bars: https://stackoverflow.com/a/22037078/4575331
arrows(x0 = x$year,
y0 = x$se_min,
x1 = x$year,
y1 = x$se_max,
length = 0.05, angle = 90, code = 3, lwd = 1.5)
arrows(
x0 = x$year,
y0 = x$se_min,
x1 = x$year,
y1 = x$se_max,
length = 0.05, angle = 90, code = 3, lwd = 1.5
)
# overlay grey points for prediction
points(x = subset(x, is.na(observations))$year,
y = subset(x, is.na(observations))$value,
pch = 19,
col = "grey40")
points(
x = subset(x, is.na(observations))$year,
y = subset(x, is.na(observations))$value,
pch = 19,
col = "grey40"
)
}
#' @rdname resistance_predict
@@ -343,27 +356,35 @@ ggplot_rsi_predict <- function(x,
x_name <- paste0(ab_name(attributes(x)$ab), " (", attributes(x)$ab, ")")
meet_criteria(main, allow_class = "character", has_length = 1)
meet_criteria(ribbon, allow_class = "logical", has_length = 1)
stop_ifnot_installed("ggplot2")
stop_ifnot(inherits(x, "resistance_predict"), "`x` must be a resistance prediction model created with resistance_predict()")
if (attributes(x)$I_as_S == TRUE) {
ylab <- "%R"
} else {
ylab <- "%IR"
}
p <- ggplot2::ggplot(as.data.frame(x, stringsAsFactors = FALSE),
ggplot2::aes(x = year, y = value)) +
ggplot2::geom_point(data = subset(x, !is.na(observations)),
size = 2) +
p <- ggplot2::ggplot(
as.data.frame(x, stringsAsFactors = FALSE),
ggplot2::aes(x = year, y = value)
) +
ggplot2::geom_point(
data = subset(x, !is.na(observations)),
size = 2
) +
scale_y_percent(limits = c(0, 1)) +
ggplot2::labs(title = main,
y = paste0("Percentage (", ylab, ")"),
x = "Year",
caption = paste0("(n = ", sum(x$observations, na.rm = TRUE),
", model: ", attributes(x)$model_title, ")"))
ggplot2::labs(
title = main,
y = paste0("Percentage (", ylab, ")"),
x = "Year",
caption = paste0(
"(n = ", sum(x$observations, na.rm = TRUE),
", model: ", attributes(x)$model_title, ")"
)
)
if (ribbon == TRUE) {
p <- p + ggplot2::geom_ribbon(ggplot2::aes(ymin = se_min, ymax = se_max), alpha = 0.25)
} else {
@@ -371,9 +392,11 @@ ggplot_rsi_predict <- function(x,
}
p <- p +
# overlay grey points for prediction
ggplot2::geom_point(data = subset(x, is.na(observations)),
size = 2,
colour = "grey40")
ggplot2::geom_point(
data = subset(x, is.na(observations)),
size = 2,
colour = "grey40"
)
p
}

687
R/rsi.R
View File

File diff suppressed because it is too large Load Diff

144
R/rsi_calc.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -24,7 +24,7 @@
# ==================================================================== #
dots2vars <- function(...) {
# this function is to give more informative output about
# this function is to give more informative output about
# variable names in count_* and proportion_* functions
dots <- substitute(list(...))
as.character(dots)[2:length(dots)]
@@ -41,26 +41,30 @@ rsi_calc <- function(...,
meet_criteria(as_percent, allow_class = "logical", has_length = 1, .call_depth = 1)
meet_criteria(only_all_tested, allow_class = "logical", has_length = 1, .call_depth = 1)
meet_criteria(only_count, allow_class = "logical", has_length = 1, .call_depth = 1)
data_vars <- dots2vars(...)
dots_df <- switch(1, ...)
dots_df <- switch(1,
...
)
if (is.data.frame(dots_df)) {
# make sure to remove all other classes like tibbles, data.tables, etc
dots_df <- as.data.frame(dots_df, stringsAsFactors = FALSE)
}
dots <- eval(substitute(alist(...)))
stop_if(length(dots) == 0, "no variables selected", call = -2)
stop_if("also_single_tested" %in% names(dots),
"`also_single_tested` was replaced by `only_all_tested`.\n",
"Please read Details in the help page (`?proportion`) as this may have a considerable impact on your analysis.", call = -2)
"`also_single_tested` was replaced by `only_all_tested`.\n",
"Please read Details in the help page (`?proportion`) as this may have a considerable impact on your analysis.",
call = -2
)
ndots <- length(dots)
if (is.data.frame(dots_df)) {
# data.frame passed with other columns, like: example_isolates %pm>% proportion_S(AMC, GEN)
dots <- as.character(dots)
# remove first element, it's the data.frame
if (length(dots) == 1) {
@@ -69,14 +73,16 @@ rsi_calc <- function(...,
dots <- dots[2:length(dots)]
}
if (length(dots) == 0 | all(dots == "df")) {
# for complete data.frames, like example_isolates %pm>% select(AMC, GEN) %pm>% proportion_S()
# for complete data.frames, like example_isolates %pm>% select(AMC, GEN) %pm>% proportion_S()
# and the old rsi function, which has "df" as name of the first argument
x <- dots_df
} else {
# get dots that are in column names already, and the ones that will be once evaluated using dots_df or global env
# this is to support susceptibility(example_isolates, AMC, any_of(some_vector_with_AB_names))
dots <- c(dots[dots %in% colnames(dots_df)],
eval(parse(text = dots[!dots %in% colnames(dots_df)]), envir = dots_df, enclos = globalenv()))
dots <- c(
dots[dots %in% colnames(dots_df)],
eval(parse(text = dots[!dots %in% colnames(dots_df)]), envir = dots_df, enclos = globalenv())
)
dots_not_exist <- dots[!dots %in% colnames(dots_df)]
stop_if(length(dots_not_exist) > 0, "column(s) not found: ", vector_and(dots_not_exist, quotes = TRUE), call = -2)
x <- dots_df[, dots, drop = FALSE]
@@ -93,7 +99,7 @@ rsi_calc <- function(...,
x <- as.data.frame(list(...), stringsAsFactors = FALSE)
}
}
if (is.null(x)) {
warning_("argument is NULL (check if columns exist): returning NA")
if (as_percent == TRUE) {
@@ -102,11 +108,11 @@ rsi_calc <- function(...,
return(NA_real_)
}
}
print_warning <- FALSE
ab_result <- as.rsi(ab_result)
if (is.data.frame(x)) {
rsi_integrity_check <- character(0)
for (i in seq_len(ncol(x))) {
@@ -121,13 +127,15 @@ rsi_calc <- function(...,
# this will give a warning for invalid results, of all input columns (so only 1 warning)
rsi_integrity_check <- as.rsi(rsi_integrity_check)
}
x_transposed <- as.list(as.data.frame(t(x), stringsAsFactors = FALSE))
if (only_all_tested == TRUE) {
# no NAs in any column
y <- apply(X = as.data.frame(lapply(x, as.integer), stringsAsFactors = FALSE),
MARGIN = 1,
FUN = min)
y <- apply(
X = as.data.frame(lapply(x, as.integer), stringsAsFactors = FALSE),
MARGIN = 1,
FUN = min
)
numerator <- sum(as.integer(y) %in% as.integer(ab_result), na.rm = TRUE)
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(any(is.na(y)))))
} else {
@@ -145,20 +153,21 @@ rsi_calc <- function(...,
numerator <- sum(x %in% ab_result, na.rm = TRUE)
denominator <- sum(x %in% levels(ab_result), na.rm = TRUE)
}
if (print_warning == TRUE) {
if (message_not_thrown_before("rsi_calc")) {
warning_("Increase speed by transforming to class <rsi> on beforehand:\n",
" your_data %>% mutate_if(is.rsi.eligible, as.rsi)\n",
" your_data %>% mutate(across(where(is.rsi.eligible), as.rsi))",
call = FALSE)
" your_data %>% mutate_if(is.rsi.eligible, as.rsi)\n",
" your_data %>% mutate(across(where(is.rsi.eligible), as.rsi))",
call = FALSE
)
}
}
if (only_count == TRUE) {
return(numerator)
}
if (denominator < minimum) {
if (data_vars != "") {
data_vars <- paste(" for", data_vars)
@@ -182,16 +191,18 @@ rsi_calc <- function(...,
}
}
warning_("Introducing NA: ",
ifelse(denominator == 0, "no", paste("only", denominator)),
" results available",
data_vars,
" (`minimum` = ", minimum, ").", call = FALSE)
ifelse(denominator == 0, "no", paste("only", denominator)),
" results available",
data_vars,
" (`minimum` = ", minimum, ").",
call = FALSE
)
fraction <- NA_real_
} else {
fraction <- numerator / denominator
fraction[is.nan(fraction)] <- NA_real_
}
if (as_percent == TRUE) {
percentage(fraction, digits = 1)
} else {
@@ -216,16 +227,16 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
meet_criteria(as_percent, allow_class = "logical", has_length = 1, .call_depth = 1)
meet_criteria(combine_SI, allow_class = "logical", has_length = 1, .call_depth = 1)
meet_criteria(combine_SI_missing, allow_class = "logical", has_length = 1, .call_depth = 1)
check_dataset_integrity()
if (isTRUE(combine_IR) & isTRUE(combine_SI_missing)) {
combine_SI <- FALSE
}
stop_if(isTRUE(combine_SI) & isTRUE(combine_IR), "either `combine_SI` or `combine_IR` can be TRUE, not both", call = -2)
translate_ab <- get_translate_ab(translate_ab)
data.bak <- data
# select only groups and antibiotics
if (is_null_or_grouped_tbl(data)) {
@@ -236,7 +247,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
data_has_groups <- FALSE
data <- data[, colnames(data)[vapply(FUN.VALUE = logical(1), data, is.rsi)], drop = FALSE]
}
data <- as.data.frame(data, stringsAsFactors = FALSE)
if (isTRUE(combine_SI) | isTRUE(combine_IR)) {
for (i in seq_len(ncol(data))) {
@@ -250,13 +261,15 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
}
}
}
sum_it <- function(.data) {
out <- data.frame(antibiotic = character(0),
interpretation = character(0),
value = double(0),
isolates = integer(0),
stringsAsFactors = FALSE)
out <- data.frame(
antibiotic = character(0),
interpretation = character(0),
value = double(0),
isolates = integer(0),
stringsAsFactors = FALSE
)
if (data_has_groups) {
group_values <- unique(.data[, which(colnames(.data) %in% groups), drop = FALSE])
rownames(group_values) <- NULL
@@ -280,18 +293,22 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
} else {
col_results$value <- rep(NA_real_, NROW(col_results))
}
out_new <- data.frame(antibiotic = ifelse(isFALSE(translate_ab),
colnames(.data)[i],
ab_property(colnames(.data)[i], property = translate_ab, language = language)),
interpretation = col_results$interpretation,
value = col_results$value,
isolates = col_results$isolates,
stringsAsFactors = FALSE)
out_new <- data.frame(
antibiotic = ifelse(isFALSE(translate_ab),
colnames(.data)[i],
ab_property(colnames(.data)[i], property = translate_ab, language = language)
),
interpretation = col_results$interpretation,
value = col_results$value,
isolates = col_results$isolates,
stringsAsFactors = FALSE
)
if (data_has_groups) {
if (nrow(group_values) < nrow(out_new)) {
# repeat group_values for the number of rows in out_new
repeated <- rep(seq_len(nrow(group_values)),
each = nrow(out_new) / nrow(group_values))
each = nrow(out_new) / nrow(group_values)
)
group_values <- group_values[repeated, , drop = FALSE]
}
out_new <- cbind(group_values, out_new)
@@ -301,7 +318,7 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
}
out
}
# based on pm_apply_grouped_function
apply_group <- function(.data, fn, groups, drop = FALSE, ...) {
grouped <- pm_split_into_groups(.data, groups, drop)
@@ -312,13 +329,13 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
}
res
}
if (data_has_groups) {
out <- apply_group(data, "sum_it", groups)
} else {
out <- sum_it(data)
}
# apply factors for right sorting in interpretation
if (isTRUE(combine_SI)) {
out$interpretation <- factor(out$interpretation, levels = c("SI", "R"), ordered = TRUE)
@@ -329,21 +346,21 @@ rsi_calc_df <- function(type, # "proportion", "count" or "both"
# the same data structure as output, regardless of input
out$interpretation <- factor(out$interpretation, levels = c("S", "I", "R"), ordered = TRUE)
}
if (data_has_groups) {
# ordering by the groups and two more: "antibiotic" and "interpretation"
out <- pm_ungroup(out[do.call("order", out[, seq_len(length(groups) + 2), drop = FALSE]), , drop = FALSE])
out <- pm_ungroup(out[do.call("order", out[, seq_len(length(groups) + 2), drop = FALSE]), , drop = FALSE])
} else {
out <- out[order(out$antibiotic, out$interpretation), , drop = FALSE]
}
if (type == "proportion") {
out <- subset(out, select = -c(isolates))
} else if (type == "count") {
out$value <- out$isolates
out <- subset(out, select = -c(isolates))
}
}
rownames(out) <- NULL
out <- as_original_data_class(out, class(data.bak))
structure(out, class = c("rsi_df", class(out)))
@@ -358,9 +375,10 @@ 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
}
}

25
R/rsi_df.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -23,7 +23,7 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' @rdname proportion
#' @rdname proportion
#' @export
rsi_df <- function(data,
translate_ab = "name",
@@ -32,14 +32,15 @@ rsi_df <- function(data,
as_percent = FALSE,
combine_SI = TRUE,
combine_IR = FALSE) {
rsi_calc_df(type = "both",
data = data,
translate_ab = translate_ab,
language = language,
minimum = minimum,
as_percent = as_percent,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI))
rsi_calc_df(
type = "both",
data = data,
translate_ab = translate_ab,
language = language,
minimum = minimum,
as_percent = as_percent,
combine_SI = combine_SI,
combine_IR = combine_IR,
combine_SI_missing = missing(combine_SI)
)
}

6
R/skewness.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -33,7 +33,7 @@
#' @seealso [kurtosis()]
#' @rdname skewness
#' @export
#' @examples
#' @examples
#' skewness(runif(1000))
skewness <- function(x, na.rm = FALSE) {
meet_criteria(na.rm, allow_class = "logical", has_length = 1)
@@ -50,7 +50,7 @@ skewness.default <- function(x, na.rm = FALSE) {
x <- x[!is.na(x)]
}
n <- length(x)
(sum((x - mean(x))^3) / n) / (sum((x - mean(x)) ^ 2) / n) ^ (3 / 2)
(sum((x - mean(x))^3) / n) / (sum((x - mean(x))^2) / n)^(3 / 2)
}
#' @method skewness matrix

97
R/translate.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -34,12 +34,12 @@
#'
#' ## Changing the Default Language
#' The system language will be used at default (as returned by `Sys.getenv("LANG")` or, if `LANG` is not set, [`Sys.getlocale("LC_COLLATE")`][Sys.getlocale()]), if that language is supported. But the language to be used can be overwritten in two ways and will be checked in this order:
#'
#'
#' 1. Setting the R option `AMR_locale`, either by using `set_AMR_locale()` or by running e.g. `options(AMR_locale = "de")`.
#'
#'
#' Note that setting an \R option only works in the same session. Save the command `options(AMR_locale = "(your language)")` to your `.Rprofile` file to apply it for every session.
#' 2. Setting the system variable `LANGUAGE` or `LANG`, e.g. by adding `LANGUAGE="de_DE.utf8"` to your `.Renviron` file in your home directory.
#'
#'
#' Thus, if the R option `AMR_locale` is set, the system variables `LANGUAGE` and `LANG` will be ignored.
#' @rdname translate
#' @name translate
@@ -53,11 +53,11 @@
#' set_AMR_locale("Greek")
#' ab_name("Ciprofloxacin")
#' mo_name("Coagulase-negative Staphylococcus")
#'
#'
#' set_AMR_locale("Spanish")
#' ab_name("Ciprofloxacin")
#' mo_name("Coagulase-negative Staphylococcus")
#'
#'
#' # set_AMR_locale() understands endonyms, English exonyms, and ISO-639-1:
#' set_AMR_locale("Deutsch")
#' set_AMR_locale("German")
@@ -69,7 +69,7 @@ get_AMR_locale <- function() {
if (!is.null(getOption("AMR_locale", default = NULL))) {
return(validate_language(getOption("AMR_locale"), extra_txt = "set with `options(AMR_locale = ...)`"))
}
lang <- ""
# now check the LANGUAGE system variable - return it if set
if (!identical("", Sys.getenv("LANGUAGE"))) {
@@ -81,12 +81,14 @@ get_AMR_locale <- function() {
if (lang == "") {
lang <- Sys.getlocale("LC_COLLATE")
}
lang <- find_language(lang)
if (lang != "en" && interactive() && message_not_thrown_before("get_AMR_locale", entire_session = TRUE)) {
message_("Assuming the ", LANGUAGES_SUPPORTED_NAMES[[lang]]$exonym, " language (",
LANGUAGES_SUPPORTED_NAMES[[lang]]$endonym, ") for the AMR package. Change this with `set_AMR_locale()`. ",
"This note will be shown once per session.")
message_(
"Assuming the ", LANGUAGES_SUPPORTED_NAMES[[lang]]$exonym, " language (",
LANGUAGES_SUPPORTED_NAMES[[lang]]$endonym, ") for the AMR package. Change this with `set_AMR_locale()`. ",
"This note will be shown once per session."
)
}
lang
}
@@ -96,7 +98,7 @@ get_AMR_locale <- function() {
set_AMR_locale <- function(language) {
language <- validate_language(language)
options(AMR_locale = language)
message_("Using the ", LANGUAGES_SUPPORTED_NAMES[[language]]$exonym, " language (", LANGUAGES_SUPPORTED_NAMES[[language]]$endonym, ") for the AMR package for this session.")
message_("Using the ", LANGUAGES_SUPPORTED_NAMES[[language]]$exonym, " language (", LANGUAGES_SUPPORTED_NAMES[[language]]$endonym, ") for the AMR package for this session.")
}
#' @rdname translate
@@ -118,25 +120,32 @@ validate_language <- function(language, extra_txt = character(0)) {
}
lang <- find_language(language, fallback = FALSE)
stop_ifnot(length(lang) > 0 && lang %in% LANGUAGES_SUPPORTED,
"unsupported language for AMR package", extra_txt, ": \"", language, "\". Use one of these language names or ISO-639-1 codes: ",
paste0('"', vapply(FUN.VALUE = character(1), LANGUAGES_SUPPORTED_NAMES, function(x) x[[1]]),
'" ("' , LANGUAGES_SUPPORTED, '")', collapse = ", "),
call = FALSE)
"unsupported language for AMR package", extra_txt, ": \"", language, "\". Use one of these language names or ISO-639-1 codes: ",
paste0('"', vapply(FUN.VALUE = character(1), LANGUAGES_SUPPORTED_NAMES, function(x) x[[1]]),
'" ("', LANGUAGES_SUPPORTED, '")',
collapse = ", "
),
call = FALSE
)
lang
}
find_language <- function(language, fallback = TRUE) {
language <- Map(function(l, n, check = language) {
grepl(paste0("^(", l[1], "|", l[2], "|",
n, "(_|$)|", toupper(n), "(_|$))"),
check,
ignore.case = FALSE,
perl = TRUE,
useBytes = FALSE)
grepl(paste0(
"^(", l[1], "|", l[2], "|",
n, "(_|$)|", toupper(n), "(_|$))"
),
check,
ignore.case = FALSE,
perl = TRUE,
useBytes = FALSE
)
},
LANGUAGES_SUPPORTED_NAMES,
LANGUAGES_SUPPORTED,
USE.NAMES = TRUE)
USE.NAMES = TRUE
)
language <- names(which(language == TRUE))
if (isTRUE(fallback) && length(language) == 0) {
# other language -> set to English
@@ -147,23 +156,22 @@ find_language <- function(language, fallback = TRUE) {
# translate strings based on inst/translations.tsv
translate_into_language <- function(from,
language = get_AMR_locale(),
language = get_AMR_locale(),
only_unknown = FALSE,
only_affect_ab_names = FALSE,
only_affect_mo_names = FALSE) {
if (is.null(language)) {
return(from)
}
if (language %in% c("en", "", NA)) {
return(from)
}
df_trans <- TRANSLATIONS # internal data file
from.bak <- from
from_unique <- unique(from)
from_unique_translated <- from_unique
# get ISO-639-1 of language
lang <- validate_language(language)
# only keep lines where translation is available for this language
@@ -182,35 +190,42 @@ translate_into_language <- function(from,
if (NROW(df_trans) == 0) {
return(from)
}
# default: case sensitive if value if 'case_sensitive' is missing:
df_trans$case_sensitive[is.na(df_trans$case_sensitive)] <- TRUE
# default: not using regular expressions if 'regular_expr' is missing:
df_trans$regular_expr[is.na(df_trans$regular_expr)] <- FALSE
# check if text to look for is in one of the patterns
any_form_in_patterns <- tryCatch(
any(from_unique %like% paste0("(", paste(gsub(" +\\(.*", "", df_trans$pattern), collapse = "|"), ")")),
error = function(e) {
warning_("Translation not possible. Please open an issue on GitHub (https://github.com/msberends/AMR/issues).")
return(FALSE)
})
}
)
if (NROW(df_trans) == 0 | !any_form_in_patterns) {
return(from)
}
lapply(seq_len(nrow(df_trans)),
function(i) from_unique_translated <<- gsub(pattern = df_trans$pattern[i],
replacement = df_trans[i, lang, drop = TRUE],
x = from_unique_translated,
ignore.case = !df_trans$case_sensitive[i] & df_trans$regular_expr[i],
fixed = !df_trans$regular_expr[i],
perl = df_trans$regular_expr[i]))
lapply(
seq_len(nrow(df_trans)),
function(i) {
from_unique_translated <<- gsub(
pattern = df_trans$pattern[i],
replacement = df_trans[i, lang, drop = TRUE],
x = from_unique_translated,
ignore.case = !df_trans$case_sensitive[i] & df_trans$regular_expr[i],
fixed = !df_trans$regular_expr[i],
perl = df_trans$regular_expr[i]
)
}
)
# force UTF-8 for diacritics
from_unique_translated <- enc2utf8(from_unique_translated)
# a kind of left join to get all results back
from_unique_translated[match(from.bak, from_unique)]
}

4
R/vctrs.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -23,7 +23,7 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
# These are all S3 implementations for the vctrs package,
# These are all S3 implementations for the vctrs package,
# that is used internally by tidyverse packages such as dplyr.
# They are to convert AMR-specific classes to bare characters and integers.
# All of them will be exported using s3_register() in R/zzz.R when loading the package.

6
R/whocc.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -28,12 +28,12 @@
#' All antimicrobial drugs and their official names, ATC codes, ATC groups and defined daily dose (DDD) are included in this package, using the WHO Collaborating Centre for Drug Statistics Methodology.
#' @section WHOCC:
#' \if{html}{\figure{logo_who.png}{options: height="60" style=margin-bottom:"5"} \cr}
#' This package contains **all ~550 antibiotic, antimycotic and antiviral drugs** and their Anatomical Therapeutic Chemical (ATC) codes, ATC groups and Defined Daily Dose (DDD) from the World Health Organization Collaborating Centre for Drug Statistics Methodology (WHOCC, <https://www.whocc.no>) and the Pharmaceuticals Community Register of the European Commission (<https://ec.europa.eu/health/documents/community-register/html/reg_hum_atc.htm>).
#' This package contains **all ~550 antibiotic, antimycotic and antiviral drugs** and their Anatomical Therapeutic Chemical (ATC) codes, ATC groups and Defined Daily Dose (DDD) from the World Health Organization Collaborating Centre for Drug Statistics Methodology (WHOCC, <https://www.whocc.no>) and the Pharmaceuticals Community Register of the European Commission (<https://ec.europa.eu/health/documents/community-register/html/reg_hum_atc.htm>).
#'
#' These have become the gold standard for international drug utilisation monitoring and research.
#'
#' The WHOCC is located in Oslo at the Norwegian Institute of Public Health and funded by the Norwegian government. The European Commission is the executive of the European Union and promotes its general interest.
#'
#'
#' **NOTE: The WHOCC copyright does not allow use for commercial purposes, unlike any other info from this package.** See <https://www.whocc.no/copyright_disclaimer/.>
#' @name WHOCC

54
R/zzz.R
View File

@@ -9,7 +9,7 @@
# (c) 2018-2022 Berends MS, Luz CF et al. #
# Developed at the University of Groningen, the Netherlands, in #
# collaboration with non-profit organisations Certe Medical #
# Diagnostics & Advice, and University Medical Center Groningen. #
# Diagnostics & Advice, and University Medical Center Groningen. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
@@ -26,16 +26,19 @@
# set up package environment, used by numerous AMR functions
pkg_env <- new.env(hash = FALSE)
pkg_env$mo_failed <- character(0)
pkg_env$mo_field_abbreviations <- c("AIEC", "ATEC", "BORSA", "CRSM", "DAEC", "EAEC",
"EHEC", "EIEC", "EPEC", "ETEC", "GISA", "MRPA",
"MRSA", "MRSE", "MSSA", "MSSE", "NMEC", "PISP",
"PRSP", "STEC", "UPEC", "VISA", "VISP", "VRE",
"VRSA", "VRSP")
pkg_env$mo_field_abbreviations <- c(
"AIEC", "ATEC", "BORSA", "CRSM", "DAEC", "EAEC",
"EHEC", "EIEC", "EPEC", "ETEC", "GISA", "MRPA",
"MRSA", "MRSE", "MSSA", "MSSE", "NMEC", "PISP",
"PRSP", "STEC", "UPEC", "VISA", "VISP", "VRE",
"VRSA", "VRSP"
)
# determine info icon for messages
utf8_supported <- isTRUE(base::l10n_info()$`UTF-8`)
is_latex <- tryCatch(import_fn("is_latex_output", "knitr", error_on_fail = FALSE)(),
error = function(e) FALSE)
error = function(e) FALSE
)
if (utf8_supported && !is_latex) {
# \u2139 is a symbol officially named 'information source'
pkg_env$info_icon <- "\u2139"
@@ -45,8 +48,8 @@ if (utf8_supported && !is_latex) {
.onLoad <- function(...) {
# Support for tibble headers (type_sum) and tibble columns content (pillar_shaft)
# without the need to depend on other packages. This was suggested by the
# developers of the vctrs package:
# without the need to depend on other packages. This was suggested by the
# developers of the vctrs package:
# https://github.com/r-lib/vctrs/blob/05968ce8e669f73213e3e894b5f4424af4f46316/R/register-s3.R
s3_register("pillar::pillar_shaft", "ab")
s3_register("pillar::pillar_shaft", "mo")
@@ -93,19 +96,22 @@ if (utf8_supported && !is_latex) {
s3_register("vctrs::vec_ptype2", "disk.integer")
s3_register("vctrs::vec_ptype2", "integer.disk")
s3_register("vctrs::vec_cast", "integer.disk")
# if mo source exists, fire it up (see mo_source())
try({
if (file.exists(getOption("AMR_mo_source", "~/mo_source.rds"))) {
invisible(get_mo_source())
}
}, silent = TRUE)
try(
{
if (file.exists(getOption("AMR_mo_source", "~/mo_source.rds"))) {
invisible(get_mo_source())
}
},
silent = TRUE
)
# be sure to print tibbles as tibbles
if (pkg_is_available("tibble", also_load = FALSE)) {
loadNamespace("tibble")
}
# reference data - they have additional columns compared to `antibiotics` and `microorganisms` to improve speed
# they cannot be part of R/sysdata.rda since CRAN thinks it would make the package too large (+3 MB)
assign(x = "AB_lookup", value = create_AB_lookup(), envir = asNamespace("AMR"))
@@ -123,7 +129,7 @@ create_AB_lookup <- function() {
create_MO_lookup <- function() {
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
@@ -131,18 +137,18 @@ create_MO_lookup <- 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
# use this paste instead of `fullname` to work with Viridans Group Streptococci, etc.
if (length(MO_FULLNAME_LOWER) == nrow(MO_lookup)) {
MO_lookup$fullname_lower <- MO_FULLNAME_LOWER
} else {
MO_lookup$fullname_lower <- ""
warning("MO table updated - Run: source(\"data-raw/pre-commit-hook.R\")", call. = FALSE)
warning("MO table updated - Run: source(\"data-raw/_pre_commit_hook.R\")", call. = FALSE)
}
# add a column with only "e coli" like combinations
MO_lookup$g_species <- gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", MO_lookup$fullname_lower, perl = TRUE)
# so arrange data on prevalence first, then kingdom, then full name
MO_lookup[order(MO_lookup$prevalence, MO_lookup$kingdom_index, MO_lookup$fullname_lower), , drop = FALSE]
}
@@ -150,10 +156,10 @@ create_MO_lookup <- function() {
create_MO.old_lookup <- function() {
MO.old_lookup <- AMR::microorganisms.old
MO.old_lookup$fullname_lower <- trimws(gsub("[^.a-z0-9/ \\-]+", "", tolower(trimws(MO.old_lookup$fullname))))
# add a column with only "e coli"-like combinations
MO.old_lookup$g_species <- trimws(gsub("^([a-z])[a-z]+ ([a-z]+) ?.*", "\\1 \\2", MO.old_lookup$fullname_lower))
# so arrange data on prevalence first, then full name
MO.old_lookup[order(MO.old_lookup$prevalence, MO.old_lookup$fullname_lower), , drop = FALSE]
}