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

(v1.7.1.9023) Removed filter_ functions, new set_ab_names(), ATC code update, ab selector update, fixes #46 and fixed #47

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2021-08-16 21:54:34 +02:00
parent 4e1efd902c
commit a2d249962f
248 changed files with 2377 additions and 12201 deletions
Download Patch File Download Diff File Expand all files Collapse all files

20
R/aa_helper_functions.R
View File

@ -544,7 +544,7 @@ create_eucast_ab_documentation <- function() {
out
}
vector_or <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, last_sep = " or ") {
vector_or <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, initial_captital = FALSE, last_sep = " or ") {
# makes unique and sorts, and this also removed NAs
v <- unique(v)
if (isTRUE(sort)) {
@ -560,6 +560,9 @@ vector_or <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, last_sep =
} else {
quotes <- quotes[1L]
}
if (isTRUE(initial_captital)) {
v[1] <- gsub("^([a-z])", "\\U\\1", v[1], perl = TRUE)
}
if (length(v) == 1) {
return(paste0(quotes, v, quotes))
}
@ -572,8 +575,9 @@ vector_or <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, last_sep =
last_sep, paste0(quotes, v[length(v)], quotes))
}
vector_and <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE) {
vector_or(v = v, quotes = quotes, reverse = reverse, sort = sort, last_sep = " and ")
vector_and <- function(v, quotes = TRUE, reverse = FALSE, sort = TRUE, initial_captital = FALSE) {
vector_or(v = v, quotes = quotes, reverse = reverse, sort = sort,
initial_captital = initial_captital, last_sep = " and ")
}
format_class <- function(class, plural = FALSE) {
@ -840,17 +844,17 @@ unique_call_id <- function(entire_session = FALSE) {
}
message_not_thrown_before <- function(fn, entire_session = FALSE) {
# this is to prevent that messages/notes will be printed for every dplyr group
# this is to prevent that messages/notes will be printed for every dplyr group or more than once per session
# e.g. this would show a msg 4 times: example_isolates %>% group_by(hospital_id) %>% filter(mo_is_gram_negative())
test_out <- is.null(pkg_env[[paste0("thrown_msg.", fn)]]) || !identical(pkg_env[[paste0("thrown_msg.", fn)]],
unique_call_id(entire_session = entire_session))
if (isTRUE(test_out)) {
not_thrown_before <- is.null(pkg_env[[paste0("thrown_msg.", fn)]]) || !identical(pkg_env[[paste0("thrown_msg.", fn)]],
unique_call_id(entire_session = entire_session))
if (isTRUE(not_thrown_before)) {
# message was not thrown before - remember this so on the next run it will return FALSE:
assign(x = paste0("thrown_msg.", fn),
value = unique_call_id(entire_session = entire_session),
envir = pkg_env)
}
test_out
not_thrown_before
}
has_colour <- function() {

88
R/ab.R
View File

@ -33,7 +33,7 @@
#' @param ... arguments passed on to internal functions
#' @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.
#' @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:
#'
@ -101,6 +101,11 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
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")))
}
initial_search <- is.null(list(...)$initial_search)
already_regex <- isTRUE(list(...)$already_regex)
@ -110,24 +115,6 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x <- toupper(x)
x_nonNA <- x[!is.na(x)]
if (all(x_nonNA %in% antibiotics$ab, na.rm = TRUE)) {
# all valid AB codes, but not yet right class
return(set_clean_class(x,
new_class = c("ab", "character")))
}
if (all(x_nonNA %in% toupper(antibiotics$name), na.rm = TRUE)) {
# all valid AB names
out <- antibiotics$ab[match(x, toupper(antibiotics$name))]
out[is.na(x)] <- NA_character_
return(out)
}
if (all(x_nonNA %in% antibiotics$atc, na.rm = TRUE)) {
# all valid ATC codes
out <- antibiotics$ab[match(x, antibiotics$atc)]
out[is.na(x)] <- NA_character_
return(out)
}
# remove diacritics
x <- iconv(x, from = "UTF-8", to = "ASCII//TRANSLIT")
x <- gsub('"', "", x, fixed = TRUE)
@ -155,13 +142,29 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
found[1L]
}
if (initial_search == TRUE) {
progress <- progress_ticker(n = length(x), n_min = 25, print = info) # start if n >= 25
# 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)]
known_codes_ab <- x %in% AB_lookup$ab
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)),
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 seq_len(length(x))) {
for (i in which(!already_known)) {
if (initial_search == TRUE) {
progress$tick()
}
@ -189,34 +192,6 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
next
}
# exact name
found <- antibiotics[which(AB_lookup$generalised_name == x[i]), ]$ab
if (length(found) > 0) {
x_new[i] <- found[1L]
next
}
# exact AB code
found <- antibiotics[which(antibiotics$ab == x[i]), ]$ab
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# exact ATC code
found <- antibiotics[which(antibiotics$atc == x[i]), ]$ab
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# exact CID code
found <- antibiotics[which(antibiotics$cid == x[i]), ]$ab
if (length(found) > 0) {
x_new[i] <- note_if_more_than_one_found(found, i, from_text)
next
}
# exact LOINC code
loinc_found <- unlist(lapply(AB_lookup$generalised_loinc,
function(s) x[i] %in% s))
@ -296,7 +271,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
}
# INITIAL SEARCH - More uncertain results ----
if (initial_search == TRUE && fast_mode == FALSE) {
@ -461,7 +436,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
x_unknown <- c(x_unknown, x_bak[x[i] == x_bak_clean][1])
}
if (initial_search == TRUE) {
if (initial_search == TRUE & sum(already_known) < length(x)) {
close(progress)
}
@ -479,11 +454,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
vector_and(x_unknown), ".",
call = FALSE)
}
x_result <- data.frame(x = x_bak_clean, stringsAsFactors = FALSE) %pm>%
pm_left_join(data.frame(x = x, x_new = x_new, stringsAsFactors = FALSE), by = "x") %pm>%
pm_pull(x_new)
x_result <- x_new[match(x_bak_clean, x)]
if (length(x_result) == 0) {
x_result <- NA_character_
}

301
R/ab_class_selectors.R
View File

@ -23,23 +23,31 @@
# how to conduct AMR data analysis: https://msberends.github.io/AMR/ #
# ==================================================================== #
#' Antibiotic Class Selectors
#' Antibiotic Selectors
#'
#' These functions allow for filtering rows and selecting columns based on antibiotic test results that are of a specific antibiotic class, without the need to define the columns or antibiotic abbreviations.
#' 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()].
#' @inheritSection lifecycle Stable Lifecycle
#' @param ab_class an antimicrobial class, such as `"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"`
#' @param only_rsi_columns a [logical] to indicate whether only columns of class `<rsi>` must be selected (defaults to `FALSE`), see [as.rsi()]
#' @param only_treatable a [logical] to indicate whether agents that are only for laboratory tests should be excluded (defaults to `TRUE`), such as gentamicin-high (`GEH`) and imipenem/EDTA (`IPE`)
#' @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. Use the [ab_class()] function to filter/select on a manually defined antibiotic class.
#' 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.
#'
#' @section Full list of supported agents:
#' 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 `name`, `atc_group1` and `atc_group2`.
#'
#' `r paste0("* ", sapply(c("AMINOGLYCOSIDES", "AMINOPENICILLINS", "BETALACTAMS", "CARBAPENEMS", "CEPHALOSPORINS", "CEPHALOSPORINS_1ST", "CEPHALOSPORINS_2ND", "CEPHALOSPORINS_3RD", "CEPHALOSPORINS_4TH", "CEPHALOSPORINS_5TH", "FLUOROQUINOLONES", "GLYCOPEPTIDES", "LINCOSAMIDES", "LIPOGLYCOPEPTIDES", "MACROLIDES", "OXAZOLIDINONES", "PENICILLINS", "POLYMYXINS", "STREPTOGRAMINS", "QUINOLONES", "TETRACYCLINES", "UREIDOPENICILLINS"), function(x) paste0("``", tolower(x), "()`` can select ", vector_and(paste0(ab_name(eval(parse(text = x), envir = asNamespace("AMR")), language = NULL, tolower = TRUE), " (", eval(parse(text = x), envir = asNamespace("AMR")), ")"), quotes = FALSE))), "\n", collapse = "")`
#' 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.
#'
#' The [administrable_per_os()] and [administrable_iv()] functions also rely on the [antibiotics] data set - antibiotic columns will be matched where a DDD (defined daily dose) for resp. oral and IV treatment is available in the [antibiotics] data set.
#'
#' @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
#' @return (internally) a [character] vector of column names, with additional class `"ab_selector"`
#' @export
#' @inheritSection AMR Reference Data Publicly Available
#' @inheritSection AMR Read more on Our Website!
@ -55,6 +63,9 @@
#' # 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"))
@ -69,6 +80,13 @@
#' # 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()]
#'
#'
#' # dplyr -------------------------------------------------------------------
#' \donttest{
@ -78,6 +96,16 @@
#' example_isolates %>%
#' group_by(hospital_id) %>%
#' summarise(across(aminoglycosides(), resistance))
#'
#' # You can combine selectors with '&' to be more specific:
#' example_isolates %>%
#' select(penicillins() & administrable_per_os())
#'
#' # get susceptibility for antibiotics whose name contains "trim":
#' example_isolates %>%
#' filter(first_isolate()) %>%
#' group_by(hospital_id) %>%
#' summarise(across(ab_selector(name %like% "trim"), susceptibility))
#'
#' # this will select columns 'IPM' (imipenem) and 'MEM' (meropenem):
#' example_isolates %>%
@ -129,22 +157,146 @@ ab_class <- function(ab_class,
meet_criteria(ab_class, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
meet_criteria(only_treatable, allow_class = "logical", has_length = 1)
ab_selector(NULL, only_rsi_columns = only_rsi_columns, ab_class = ab_class, only_treatable = only_treatable)
ab_select_exec(NULL, only_rsi_columns = only_rsi_columns, ab_class = ab_class, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
#' @export
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)
call <- substitute(filter)
agents <- tryCatch(AMR::antibiotics[which(eval(call, envir = AMR::antibiotics)), "ab", drop = TRUE],
error = function(e) stop_(e$message, call = -5))
agents <- ab_in_data[ab_in_data %in% agents]
message_agent_names(function_name = "ab_selector",
agents = agents,
ab_group = NULL,
examples = "",
call = call)
structure(unname(agents),
class = c("ab_selector", "character"))
}
#' @rdname antibiotic_class_selectors
#' @export
administrable_per_os <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, 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)
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),
")"))
structure(unname(agents),
class = c("ab_selector", "character"))
}
#' @rdname antibiotic_class_selectors
#' @export
administrable_iv <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, 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)
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 = "")
structure(unname(agents),
class = c("ab_selector", "character"))
}
# nolint start
# #' @rdname antibiotic_class_selectors
# #' @export
# not_intrinsic_resistant <- function(mo, ..., only_rsi_columns = FALSE) {
# meet_criteria(mo, allow_class = c("mo", "data.frame", "list", "character", "numeric", "integer", "factor"), has_length = 1, allow_NA = FALSE)
# meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
#
# x <- as.mo(mo, ...)
# wont_work <- intrinsic_resistant[which(intrinsic_resistant$microorganism == mo_name(x, language = NULL)),
# "antibiotic",
# drop = TRUE]
#
# # 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)
#
# agents <- ab_in_data[!names(ab_in_data) %in% as.character(as.ab(wont_work))]
#
# # show used version number once per session (pkg_env will reload every session)
# if (message_not_thrown_before("intrinsic_resistant_version.ab", entire_session = TRUE)) {
# message_("Determining intrinsic resistance based on ",
# format_eucast_version_nr(3.2, markdown = FALSE), ". ",
# font_red("This note will be shown once per session."))
# }
#
# message_agent_names(function_name = "not_intrinsic_resistant",
# agents = ab_in_data,
# ab_group = NULL,
# examples = "",
# call = mo_name(x, language = NULL))
#
# agents
# }
# nolint end
#' @rdname antibiotic_class_selectors
#' @export
aminoglycosides <- function(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)
ab_selector("aminoglycosides", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
ab_select_exec("aminoglycosides", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
#' @export
aminopenicillins <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("aminopenicillins", only_rsi_columns = only_rsi_columns)
ab_select_exec("aminopenicillins", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
antifungals <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("antifungals", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
#' @export
antimycobacterials <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("antimycobacterials", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
@ -152,7 +304,7 @@ aminopenicillins <- function(only_rsi_columns = FALSE) {
betalactams <- function(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)
ab_selector("betalactams", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
ab_select_exec("betalactams", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
@ -160,98 +312,98 @@ betalactams <- function(only_rsi_columns = FALSE, only_treatable = TRUE) {
carbapenems <- function(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)
ab_selector("carbapenems", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
ab_select_exec("carbapenems", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("cephalosporins", only_rsi_columns = only_rsi_columns)
ab_select_exec("cephalosporins", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_1st <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("cephalosporins_1st", only_rsi_columns = only_rsi_columns)
ab_select_exec("cephalosporins_1st", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_2nd <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("cephalosporins_2nd", only_rsi_columns = only_rsi_columns)
ab_select_exec("cephalosporins_2nd", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_3rd <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("cephalosporins_3rd", only_rsi_columns = only_rsi_columns)
ab_select_exec("cephalosporins_3rd", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_4th <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("cephalosporins_4th", only_rsi_columns = only_rsi_columns)
ab_select_exec("cephalosporins_4th", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
cephalosporins_5th <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("cephalosporins_5th", only_rsi_columns = only_rsi_columns)
ab_select_exec("cephalosporins_5th", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
fluoroquinolones <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("fluoroquinolones", only_rsi_columns = only_rsi_columns)
ab_select_exec("fluoroquinolones", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
glycopeptides <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("glycopeptides", only_rsi_columns = only_rsi_columns)
ab_select_exec("glycopeptides", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
lincosamides <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("lincosamides", only_rsi_columns = only_rsi_columns)
ab_select_exec("lincosamides", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
lipoglycopeptides <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("lipoglycopeptides", only_rsi_columns = only_rsi_columns)
ab_select_exec("lipoglycopeptides", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
macrolides <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("macrolides", only_rsi_columns = only_rsi_columns)
ab_select_exec("macrolides", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
oxazolidinones <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("oxazolidinones", only_rsi_columns = only_rsi_columns)
ab_select_exec("oxazolidinones", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
penicillins <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("penicillins", only_rsi_columns = only_rsi_columns)
ab_select_exec("penicillins", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
@ -259,47 +411,54 @@ penicillins <- function(only_rsi_columns = FALSE) {
polymyxins <- function(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)
ab_selector("polymyxins", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
ab_select_exec("polymyxins", only_rsi_columns = only_rsi_columns, only_treatable = only_treatable)
}
#' @rdname antibiotic_class_selectors
#' @export
streptogramins <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("streptogramins", only_rsi_columns = only_rsi_columns)
ab_select_exec("streptogramins", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
quinolones <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("quinolones", only_rsi_columns = only_rsi_columns)
ab_select_exec("quinolones", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
tetracyclines <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("tetracyclines", only_rsi_columns = only_rsi_columns)
ab_select_exec("tetracyclines", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
trimethoprims <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_select_exec("trimethoprims", only_rsi_columns = only_rsi_columns)
}
#' @rdname antibiotic_class_selectors
#' @export
ureidopenicillins <- function(only_rsi_columns = FALSE) {
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1)
ab_selector("ureidopenicillins", only_rsi_columns = only_rsi_columns)
ab_select_exec("ureidopenicillins", only_rsi_columns = only_rsi_columns)
}
ab_selector <- function(function_name,
only_rsi_columns,
only_treatable = FALSE,
ab_class = NULL) {
ab_select_exec <- function(function_name,
only_rsi_columns = FALSE,
only_treatable = FALSE,
ab_class = NULL) {
# 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 = -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)
# untreatable drugs
untreatable <- antibiotics[which(antibiotics$name %like% "-high|EDTA|polysorbate"), "ab", drop = TRUE]
if (only_treatable == TRUE & any(untreatable %in% names(ab_in_data))) {
@ -323,7 +482,8 @@ ab_selector <- function(function_name,
if (is.null(ab_class)) {
# their upper case equivalent are vectors with class <ab>, created in data-raw/_internals.R
abx <- get(toupper(function_name), envir = asNamespace("AMR"))
# carbapenems() gets its codes from AMR:::AB_CARBAPENEMS
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,
@ -339,27 +499,14 @@ ab_selector <- function(function_name,
function_name <- "ab_class"
examples <- paste0(" (such as ", find_ab_names(ab_class, 2), ")")
}
# get the columns with a group names in the chosen ab class
agents <- ab_in_data[names(ab_in_data) %in% abx]
if (message_not_thrown_before(paste0(function_name, ".", paste(sort(agents), collapse = "|")))) {
if (length(agents) == 0) {
message_("No antimicrobial agents of class '", ab_group, "' found", examples, ".")
} else {
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 `", function_name, "(",
ifelse(function_name == "ab_class",
paste0("\"", ab_class, "\""),
""),
")` using ",
ifelse(length(agents) == 1, "column ", "columns "),
vector_and(agents_formatted, quotes = FALSE, sort = FALSE))
}
}
message_agent_names(function_name = function_name,
agents = agents,
ab_group = ab_group,
examples = examples)
structure(unname(agents),
class = c("ab_selector", "character"))
@ -486,6 +633,25 @@ any.ab_selector_any_all <- function(..., na.rm = FALSE) {
class = c("ab_selector_any_all", "logical"))
}
#' @method & ab_selector
#' @export
#' @noRd
`&.ab_selector` <- function(e1, e2) {
# 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"))
}
#' @method | ab_selector
#' @export
#' @noRd
`|.ab_selector` <- function(e1, e2) {
# 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"))
}
is_any <- function(el1) {
syscall <- paste0(trimws(deparse(sys.calls()[[1]])), collapse = " ")
el1 <- gsub("(.*),.*", "\\1", el1)
@ -497,7 +663,6 @@ is_all <- function(el1) {
syscall %like% paste0("[^_a-zA-Z0-9]all\\(", "(c\\()?", el1)
}
find_ab_group <- function(ab_class) {
ab_class <- gsub("[^a-zA-Z0-9]", ".*", ab_class)
AB_lookup %pm>%
@ -534,3 +699,33 @@ find_ab_names <- function(ab_group, n = 3) {
language = NULL),
quotes = FALSE)
}
message_agent_names <- function(function_name, agents, ab_group = NULL, examples = "", call = NULL) {
if (message_not_thrown_before(paste0(function_name, ".", paste(sort(agents), collapse = "|")))) {
if (length(agents) == 0) {
if (is.null(ab_group)) {
message_("For `", function_name, "()` no antimicrobial agents found", examples, ".")
} else if (ab_group == "administrable_per_os") {
message_("No orally administrable agents found", examples, ".")
} else if (ab_group == "administrable_iv") {
message_("No IV administrable agents found", examples, ".")
} else {
message_("No antimicrobial agents of class '", ab_group, "' found", examples, ".")
}
} else {
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 `", function_name, "(",
ifelse(function_name == "ab_class",
paste0("\"", ab_class, "\""),
ifelse(!is.null(call),
paste0(deparse(call), collapse = " "),
"")),
")` using ",
ifelse(length(agents) == 1, "column ", "columns "),
vector_and(agents_formatted, quotes = FALSE, sort = FALSE))
}
}
}

177
R/ab_property.R
View File

@ -29,23 +29,26 @@
#' @inheritSection lifecycle Stable Lifecycle
#' @param x any (vector of) text that can be coerced to a valid antibiotic code with [as.ab()]
#' @param tolower a [logical] to indicate whether the first [character] of every output should be transformed to a lower case [character]. This will lead to e.g. "polymyxin B" and not "polymyxin b".
#' @param snake_case a [logical] to indicate whether the names should be returned in so-called [snake case](https://en.wikipedia.org/wiki/Snake_case): in lower case and all spaces/slashes replaced with an underscore (`_`). This is useful for column renaming.
#' @param property one of the column names of one of the [antibiotics] data set
#' @param property one of the column names of one of the [antibiotics] data set: `vector_or(colnames(antibiotics), sort = FALSE)`.
#' @param language language of the returned text, defaults to system language (see [get_locale()]) and can also be set with `getOption("AMR_locale")`. Use `language = NULL` or `language = ""` to prevent translation.
#' @param administration way of administration, either `"oral"` or `"iv"`
#' @param units a [logical] to indicate whether the units instead of the DDDs itself must be returned, see *Examples*
#' @param open browse the URL using [utils::browseURL()]
#' @param ... other arguments passed on to [as.ab()]
#' @param data a [data.frame] of which the columns need to be renamed
#' @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 (`_`)
#' @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
#' - An [integer] in case of [ab_cid()]
#' - A named [list] in case of [ab_info()] and multiple [ab_synonyms()]/[ab_tradenames()]
#' - A named [list] in case of [ab_info()] and multiple [ab_atc()]/[ab_synonyms()]/[ab_tradenames()]
#' - A [double] in case of [ab_ddd()]
#' - A [data.frame] in case of [set_ab_names()]
#' - A [character] in all other cases
#' @export
#' @seealso [antibiotics]
@ -69,10 +72,10 @@
#' tolower = TRUE) # "amoxicillin/clavulanic acid" "polymyxin B"
#'
#' # defined daily doses (DDD)
#' ab_ddd("AMX", "oral") # 1
#' ab_ddd("AMX", "oral", units = TRUE) # "g"
#' ab_ddd("AMX", "iv") # 1
#' ab_ddd("AMX", "iv", units = TRUE) # "g"
#' ab_ddd("AMX", "oral") # 1.5
#' ab_ddd_units("AMX", "oral") # "g"
#' ab_ddd("AMX", "iv") # 3
#' ab_ddd_units("AMX", "iv") # "g"
#'
#' ab_info("AMX") # all properties as a list
#'
@ -89,11 +92,23 @@
#' ab_atc("cephtriaxone")
#' ab_atc("cephthriaxone")
#' ab_atc("seephthriaaksone")
ab_name <- function(x, language = get_locale(), tolower = FALSE, snake_case = FALSE, ...) {
#'
#' # use set_ab_names() for renaming columns
#' colnames(example_isolates)
#' colnames(set_ab_names(example_isolates))
#' \donttest{
#' if (require("dplyr")) {
#' example_isolates %>%
#' set_ab_names()
#' # set_ab_names() works with any AB property:
#' example_isolates %>%
#' set_ab_names("atc")
#' }
#' }
ab_name <- function(x, language = get_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)
meet_criteria(snake_case, allow_class = "logical", has_length = 1)
x <- translate_AMR(ab_validate(x = x, property = "name", ...), language = language, only_affect_ab_names = TRUE)
if (tolower == TRUE) {
@ -101,10 +116,69 @@ ab_name <- function(x, language = get_locale(), tolower = FALSE, snake_case = FA
# as we want "polymyxin B", not "polymyxin b"
x <- gsub("^([A-Z])", "\\L\\1", x, perl = TRUE)
}
x
}
#' @rdname ab_property
#' @aliases ATC
#' @export
set_ab_names <- function(data, property = "name", language = get_locale(), snake_case = property == "name") {
meet_criteria(data, allow_class = "data.frame")
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)
x_deparsed <- deparse(substitute(data))
if (length(x_deparsed) > 1 || any(x_deparsed %unlike% "[a-z]+")) {
x_deparsed <- "your_data"
}
property <- tolower(property)
columns <- get_column_abx(data, info = FALSE, only_rsi_columns = FALSE, sort = FALSE)
if (length(columns) == 0) {
message_("No columns with antibiotic results found for `set_ab_names()`, leaving names unchanged.")
return(data)
}
x <- vapply(FUN.VALUE = character(1),
ab_property(columns, 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])
}
})
if (any(x %in% c("", NA))) {
warning_("No ", property, " found for column(s): ", vector_and(columns[x %in% c("", NA)], sort = FALSE), call = FALSE)
x[x %in% c("", NA)] <- columns[x %in% c("", NA)]
}
if (snake_case == TRUE) {
x <- tolower(gsub("[^a-zA-Z0-9]+", "_", x))
}
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)))
}
}))
}
colnames(data)[colnames(data) %in% columns] <- x
data
}
#' @rdname ab_property
@ -112,7 +186,13 @@ ab_name <- function(x, language = get_locale(), tolower = FALSE, snake_case = FA
#' @export
ab_atc <- function(x, ...) {
meet_criteria(x, allow_NA = TRUE)
ab_validate(x = x, property = "atc", ...)
atcs <- ab_validate(x = x, property = "atc", ...)
names(atcs) <- x
if (length(atcs) == 1) {
unname(unlist(atcs))
} else {
atcs
}
}
#' @rdname ab_property
@ -181,18 +261,47 @@ ab_loinc <- function(x, ...) {
#' @rdname ab_property
#' @export
ab_ddd <- function(x, administration = "oral", units = FALSE, ...) {
ab_ddd <- function(x, administration = "oral", ...) {
meet_criteria(x, allow_NA = TRUE)
meet_criteria(administration, is_in = c("oral", "iv"), has_length = 1)
meet_criteria(units, allow_class = "logical", has_length = 1)
x <- as.ab(x, ...)
if (any(ab_name(x, language = NULL) %like% "/")) {
warning_("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/", call = FALSE)
}
ddd_prop <- administration
if (units == TRUE) {
# old behaviour
units <- list(...)$units
if (!is.null(units) && isTRUE(units)) {
if (message_not_thrown_before("ab_ddd", entire_session = TRUE)) {
warning_("Using `ab_ddd(..., units = TRUE)` is deprecated, use `ab_ddd_units()` instead. ",
"This warning will be shown once per session.", call = FALSE)
}
ddd_prop <- paste0(ddd_prop, "_units")
} else {
ddd_prop <- paste0(ddd_prop, "_ddd")
}
ab_validate(x = x, property = ddd_prop, ...)
ab_validate(x = x, property = ddd_prop)
}
#' @rdname ab_property
#' @export
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_("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/", call = FALSE)
}
ddd_prop <- paste0(administration, "_units")
ab_validate(x = x, property = ddd_prop)
}
#' @rdname ab_property
@ -210,10 +319,10 @@ ab_info <- function(x, language = get_locale(), ...) {
atc_group1 = ab_atc_group1(x, language = language),
atc_group2 = ab_atc_group2(x, language = language),
tradenames = ab_tradenames(x),
ddd = list(oral = list(amount = ab_ddd(x, administration = "oral", units = FALSE),
units = ab_ddd(x, administration = "oral", units = TRUE)),
iv = list(amount = ab_ddd(x, administration = "iv", units = FALSE),
units = ab_ddd(x, administration = "iv", units = TRUE))))
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"))))
}
@ -257,16 +366,22 @@ ab_validate <- function(x, property, ...) {
check_dataset_integrity()
# 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],
error = function(e) stop(e$message, call. = FALSE))
x_bak <- x
if (!all(x %in% antibiotics[, property])) {
x <- data.frame(ab = as.ab(x, ...), stringsAsFactors = FALSE) %pm>%
pm_left_join(antibiotics, by = "ab") %pm>%
pm_pull(property)
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],
error = function(e) stop(e$message, call. = FALSE))
if (!all(x %in% AB_lookup[, property])) {
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") {
@ -274,7 +389,7 @@ ab_validate <- function(x, property, ...) {
} else if (property %like% "ddd") {
return(as.double(x))
} else {
x[is.na(x) & !is.na(x_bak)] <- NA
x[is.na(x)] <- NA
return(x)
}
}

12
R/custom_eucast_rules.R
View File

@ -89,9 +89,9 @@
#'
#' ### 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 antibiotic agents that will be matched when running the rule.
#' 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(x), "``\\cr(", paste0(sort(ab_name(eval(parse(text = x), envir = asNamespace("AMR")), language = NULL, tolower = TRUE)), collapse = ", "), ")"), USE.NAMES = FALSE), "\n", collapse = "")`
#' `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
#' @inheritSection AMR Read more on Our Website!
#' @export
@ -140,12 +140,12 @@ custom_eucast_rules <- function(...) {
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(toupper(result_group), "S") %in% DEFINED_AB_GROUPS) {
if (paste0("AB_", toupper(result_group), "S") %in% DEFINED_AB_GROUPS) {
# support for e.g. 'aminopenicillin' if user meant 'aminopenicillins'
result_group <- paste0(result_group, "s")
}
if (toupper(result_group) %in% DEFINED_AB_GROUPS) {
result_group <- eval(parse(text = toupper(result_group)), envir = asNamespace("AMR"))
if (paste0("AB_", toupper(result_group)) %in% DEFINED_AB_GROUPS) {
result_group <- eval(parse(text = paste0("AB_", toupper(result_group))), envir = asNamespace("AMR"))
} else {
result_group <- tryCatch(
suppressWarnings(as.ab(result_group,
@ -157,7 +157,7 @@ custom_eucast_rules <- function(...) {
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(DEFINED_AB_GROUPS), quotes = FALSE), ".")
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),

6
R/data.R
View File

@ -25,14 +25,14 @@
#' Data Sets with `r format(nrow(antibiotics) + nrow(antivirals), big.mark = ",")` Antimicrobials
#'
#' Two data sets containing all antibiotics/antimycotics and antivirals. Use [as.ab()] or one of the [`ab_*`][ab_property()] functions to retrieve values from the [antibiotics] data set. Three identifiers are included in this data set: an antibiotic ID (`ab`, primarily used in this package) as defined by WHONET/EARS-Net, an ATC code (`atc`) as defined by the WHO, and a Compound ID (`cid`) as found in PubChem. Other properties in this data set are derived from one or more of these codes.
#' Two data sets containing all antibiotics/antimycotics and antivirals. Use [as.ab()] or one of the [`ab_*`][ab_property()] functions to retrieve values from the [antibiotics] data set. Three identifiers are included in this data set: an antibiotic ID (`ab`, primarily used in this package) as defined by WHONET/EARS-Net, an ATC code (`atc`) as defined by the WHO, and a Compound ID (`cid`) as found in PubChem. Other properties in this data set are derived from one or more of these codes. Note that some drugs have multiple ATC codes.
#' @format
#' ## For the [antibiotics] data set: a [data.frame] with `r nrow(antibiotics)` observations and `r ncol(antibiotics)` variables:
#' - `ab`\cr Antibiotic ID as used in this package (such as `AMC`), using the official EARS-Net (European Antimicrobial Resistance Surveillance Network) codes where available
#' - `atc`\cr ATC code (Anatomical Therapeutic Chemical) as defined by the WHOCC, like `J01CR02`
#' - `cid`\cr Compound ID as found in PubChem
#' - `name`\cr Official name as used by WHONET/EARS-Net or the WHO
#' - `group`\cr A short and concise group name, based on WHONET and WHOCC definitions
#' - `atc`\cr ATC codes (Anatomical Therapeutic Chemical) as defined by the WHOCC, like `J01CR02`
#' - `atc_group1`\cr Official pharmacological subgroup (3rd level ATC code) as defined by the WHOCC, like `"Macrolides, lincosamides and streptogramins"`
#' - `atc_group2`\cr Official chemical subgroup (4th level ATC code) as defined by the WHOCC, like `"Macrolides"`
#' - `abbr`\cr List of abbreviations as used in many countries, also for antibiotic susceptibility testing (AST)
@ -44,7 +44,7 @@
#' - `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 [data.frame] with `r nrow(antivirals)` observations and `r ncol(antivirals)` variables:
#' - `atc`\cr ATC code (Anatomical Therapeutic Chemical) as defined by the WHOCC
#' - `atc`\cr ATC codes (Anatomical Therapeutic Chemical) as defined by the WHOCC
#' - `cid`\cr Compound ID as found in PubChem
#' - `name`\cr Official name as used by WHONET/EARS-Net or the WHO
#' - `atc_group`\cr Official pharmacological subgroup (3rd level ATC code) as defined by the WHOCC

454
R/deprecated.R
View File

@ -46,457 +46,3 @@ p_symbol <- function(p, emptychar = " ") {
s
}
#' @name AMR-deprecated
#' @export
filter_first_weighted_isolate <- function(x = NULL,
col_date = NULL,
col_patient_id = NULL,
col_mo = NULL,
...) {
.Deprecated(old = "filter_first_weighted_isolate()",
new = "filter_first_isolate()",
package = "AMR")
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)
x <- tryCatch(get_current_data(arg_name = "x", call = -2), error = function(e) x)
}
meet_criteria(x, allow_class = "data.frame") # also checks dimensions to be >0
meet_criteria(col_date, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_patient_id, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
filter_first_isolate(x = x, col_date = col_date, col_patient_id = col_patient_id, col_mo = col_mo, ...)
}
#' @name AMR-deprecated
#' @export
key_antibiotics <- function(x = NULL,
col_mo = NULL,
universal_1 = guess_ab_col(x, "amoxicillin"),
universal_2 = guess_ab_col(x, "amoxicillin/clavulanic acid"),
universal_3 = guess_ab_col(x, "cefuroxime"),
universal_4 = guess_ab_col(x, "piperacillin/tazobactam"),
universal_5 = guess_ab_col(x, "ciprofloxacin"),
universal_6 = guess_ab_col(x, "trimethoprim/sulfamethoxazole"),
GramPos_1 = guess_ab_col(x, "vancomycin"),
GramPos_2 = guess_ab_col(x, "teicoplanin"),
GramPos_3 = guess_ab_col(x, "tetracycline"),
GramPos_4 = guess_ab_col(x, "erythromycin"),
GramPos_5 = guess_ab_col(x, "oxacillin"),
GramPos_6 = guess_ab_col(x, "rifampin"),
GramNeg_1 = guess_ab_col(x, "gentamicin"),
GramNeg_2 = guess_ab_col(x, "tobramycin"),
GramNeg_3 = guess_ab_col(x, "colistin"),
GramNeg_4 = guess_ab_col(x, "cefotaxime"),
GramNeg_5 = guess_ab_col(x, "ceftazidime"),
GramNeg_6 = guess_ab_col(x, "meropenem"),
warnings = TRUE,
...) {
.Deprecated(old = "key_antibiotics()",
new = "key_antimicrobials()",
package = "AMR")
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)
x <- tryCatch(get_current_data(arg_name = "x", call = -2), error = function(e) x)
}
key_antimicrobials(x = x,
col_mo = col_mo,
universal = c(universal_1, universal_2, universal_3, universal_4, universal_5, universal_6),
gram_negative = c(GramNeg_1, GramNeg_2, GramNeg_3, GramNeg_4, GramNeg_5, GramNeg_6),
gram_positive = c(GramPos_1, GramPos_2, GramPos_3, GramPos_4, GramPos_5, GramPos_6),
antifungal = NULL,
only_rsi_columns = FALSE,
...)
}
#' @name AMR-deprecated
#' @export
key_antibiotics_equal <- function(y,
z,
type = "keyantimicrobials",
ignore_I = TRUE,
points_threshold = 2,
info = FALSE,
na.rm = TRUE,
...) {
.Deprecated(old = "key_antibiotics_equal()",
new = "antimicrobials_equal()",
package = "AMR")
antimicrobials_equal(y = y,
z = z,
type = type,
ignore_I = ignore_I,
points_threshold = points_threshold,
info = info)
}
#' @name AMR-deprecated
#' @export
filter_ab_class <- function(x,
ab_class,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
.call_depth <- list(...)$`.call_depth`
if (is.null(.call_depth)) {
.call_depth <- 0
}
.x_name <- list(...)$`.x_name`
if (is.null(.x_name)) {
.x_name <- deparse(substitute(x))
}
.fn <- list(...)$`.fn`
if (is.null(.fn)) {
.fn <- "filter_ab_class"
}
.fn_old <- .fn
# new way: using the ab selectors
.fn <- gsub("filter_", "", .fn, fixed = TRUE)
.fn <- gsub("^([1-5][a-z]+)_cephalosporins", "cephalosporins_\\1", .fn)
if (missing(x) || 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)
x <- get_current_data(arg_name = "x", call = -2 - .call_depth)
.x_name <- "your_data"
}
meet_criteria(x, allow_class = "data.frame", .call_depth = .call_depth)
meet_criteria(ab_class, allow_class = "character", has_length = 1, .call_depth = .call_depth)
if (!is.null(result)) {
# make result = "SI" works too:
result <- toupper(unlist(strsplit(result, "")))
}
meet_criteria(result, allow_class = "character", has_length = c(1, 2, 3), is_in = c("S", "I", "R"), allow_NULL = TRUE, .call_depth = .call_depth)
meet_criteria(scope, allow_class = "character", has_length = 1, is_in = c("all", "any"), .call_depth = .call_depth)
meet_criteria(only_rsi_columns, allow_class = "logical", has_length = 1, .call_depth = .call_depth)
if (is.null(result)) {
result <- c("S", "I", "R")
}
# get e.g. carbapenems() from filter_carbapenems()
fn <- get(.fn, envir = asNamespace("AMR"))
if (scope == "any") {
scope_fn <- any
} else {
scope_fn <- all
}
# be nice here, be VERY extensive about how the AB selectors have taken over this function
deprecated_fn <- paste0(.fn, "(", ifelse(.fn == "ab_class", paste0("\"", ab_class, "\""), ""), ")",
ifelse(length(result) > 1,
paste0(", c(", paste0("\"", result, "\"", collapse = ", "), ")"),
ifelse(is.null(result),
"",
paste0(" == \"", result, "\""))))
if (.x_name == ".") {
.x_name <- "your_data"
}
warning_(paste0("`", .fn_old, "()` is deprecated. Use the antibiotic selector `", .fn, "()` instead.\n",
"In dplyr:\n",
" - ", .x_name, " %>% filter(", scope, "(", deprecated_fn, "))\n",
ifelse(length(result) > 1,
paste0(" - ", .x_name, " %>% filter(", scope, "(",
.fn, "(", ifelse(.fn == "ab_class", paste0("\"", ab_class, "\""), ""), ") == \"R\"))\n"),
""),
"In base R:\n",
" - ", .x_name, "[", scope, "(", deprecated_fn, "), ]\n",
ifelse(length(result) > 1,
paste0(" - ", .x_name, "[", scope, "(",
.fn, "(", ifelse(.fn == "ab_class", paste0("\"", ab_class, "\""), ""), ") == \"R\"), ]\n"),
""),
" - subset(", .x_name, ", ", scope, "(", deprecated_fn, "))",
ifelse(length(result) > 1,
paste0("\n - subset(", .x_name, ", ", scope, "(",
.fn, "(", ifelse(.fn == "ab_class", paste0("\"", ab_class, "\""), ""), ") == \"R\"))"),
"")),
call = FALSE)
if (.fn == "ab_class") {
subset(x, scope_fn(fn(ab_class = ab_class), result))
} else {
subset(x, scope_fn(fn(), result))
}
}
#' @name AMR-deprecated
#' @export
filter_aminoglycosides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "aminoglycoside",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_aminoglycosides",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_betalactams <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "carbapenem|cephalosporin|penicillin",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_betalactams",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_carbapenems <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "carbapenem",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_carbapenems",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporin",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_1st_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (1st gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_1st_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_2nd_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (2nd gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_2nd_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_3rd_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (3rd gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_3rd_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_4th_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (4th gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_4th_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_5th_cephalosporins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "cephalosporins (5th gen.)",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_5th_cephalosporins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_fluoroquinolones <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "fluoroquinolone",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_fluoroquinolones",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_glycopeptides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "glycopeptide",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_glycopeptides",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_macrolides <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "macrolide",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_macrolides",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_oxazolidinones <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "oxazolidinone",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_oxazolidinones",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_penicillins <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "penicillin",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_penicillins",
.x_name = deparse(substitute(x)),
...)
}
#' @name AMR-deprecated
#' @export
filter_tetracyclines <- function(x,
result = NULL,
scope = "any",
only_rsi_columns = FALSE,
...) {
filter_ab_class(x = x,
ab_class = "tetracycline",
result = result,
scope = scope,
only_rsi_columns = only_rsi_columns,
.call_depth = 1,
.fn = "filter_tetracyclines",
.x_name = deparse(substitute(x)),
...)
}

6
R/eucast_rules.R
View File

@ -320,9 +320,9 @@ eucast_rules <- function(x,
x <- trimws(unique(toupper(unlist(strsplit(x, ",")))))
x_new <- character()
for (val in x) {
if (val %in% ls(envir = asNamespace("AMR"))) {
# antibiotic group names, as defined in data-raw/_internals.R, such as `CARBAPENEMS`
val <- eval(parse(text = val), envir = asNamespace("AMR"))
if (paste0("AB_", val) %in% ls(envir = asNamespace("AMR"))) {
# antibiotic group names, as defined in data-raw/_internals.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`
val <- as.ab(val)

5
R/ggplot_rsi.R
View File

@ -123,8 +123,7 @@
#' mo == as.mo("E. coli")) %>%
#' # age_groups() is also a function in this AMR package:
#' group_by(age_group = age_groups(age)) %>%
#' select(age_group,
#' CIP) %>%
#' select(age_group, CIP) %>%
#' ggplot_rsi(x = "age_group")
#'
#' # a shorter version which also adjusts data label colours:
@ -135,6 +134,8 @@
#'
#' # it also supports groups (don't forget to use the group var on `x` or `facet`):
#' example_isolates %>%
#' filter(mo_is_gram_negative()) %>%
#' # select only UTI-specific drugs
#' select(hospital_id, AMX, NIT, FOS, TMP, CIP) %>%
#' group_by(hospital_id) %>%
#' ggplot_rsi(x = "hospital_id",

2
R/mdro.R
View File

@ -248,7 +248,7 @@ mdro <- function(x = NULL,
if (info == TRUE) {
txt <- paste0("Determining MDROs based on custom rules",
ifelse(isTRUE(attributes(guideline)$as_factor),
paste0(", resulting in [factor] levels: ", paste0(attributes(guideline)$values, collapse = " < ")),
paste0(", resulting in factor levels: ", paste0(attributes(guideline)$values, collapse = " < ")),
""),
".")
txt <- word_wrap(txt)

68
R/mo.R
View File

@ -492,7 +492,7 @@ exec_as.mo <- function(x,
x_backup[x %like_case% "^(fungus|fungi)$"] <- "(unknown fungus)" # will otherwise become the kingdom
x_backup[x_backup_untouched == "Fungi"] <- "Fungi" # is literally the kingdom
# Fill in fullnames and MO codes at once
# Fill in fullnames and MO codes directly
known_names <- tolower(x_backup) %in% MO_lookup$fullname_lower
x[known_names] <- MO_lookup[match(tolower(x_backup)[known_names], MO_lookup$fullname_lower), property, drop = TRUE]
known_codes <- toupper(x_backup) %in% MO_lookup$mo
@ -1551,16 +1551,7 @@ exec_as.mo <- function(x,
& !identical(x_input, "")
& !identical(x_input, "xxx")])
# left join the found results to the original input values (x_input)
df_found <- data.frame(input = as.character(x_input_unique_nonempty),
found = as.character(x),
stringsAsFactors = FALSE)
df_input <- data.frame(input = as.character(x_input),
stringsAsFactors = FALSE)
# super fast using match() which is a lot faster than merge()
x <- df_found$found[match(df_input$input, df_found$input)]
x <- x[match(x_input, x_input_unique_nonempty)]
if (property == "mo") {
x <- set_clean_class(x, new_class = c("mo", "character"))
}
@ -1887,36 +1878,30 @@ print.mo_uncertainties <- function(x, ...) {
if (NROW(x) == 0) {
return(NULL)
}
message_("Matching scores are based on human pathogenic prevalence and the resemblance between the input and the full taxonomic name. See `?mo_matching_score`.", as_note = FALSE)
msg <- ""
cat(word_wrap("Matching scores", ifelse(has_colour(), " (in blue)", ""), " are based on human pathogenic prevalence and the resemblance between the input and the full taxonomic name. See `?mo_matching_score`.\n\n", add_fn = font_blue))
txt <- ""
for (i in seq_len(nrow(x))) {
if (x[i, ]$candidates != "") {
candidates <- unlist(strsplit(x[i, ]$candidates, ", ", fixed = TRUE))
scores <- mo_matching_score(x = x[i, ]$input, n = candidates)
# sort on descending scores
candidates <- candidates[order(1 - scores)]
scores_formatted <- trimws(formatC(round(scores, 3), format = "f", digits = 3))
n_candidates <- length(candidates)
candidates <- vector_and(paste0(candidates, " (", scores_formatted[order(1 - scores)], ")"),
quotes = FALSE,
sort = FALSE)
# align with input after arrow
candidates <- paste0("\n",
strwrap(paste0("Also matched",
ifelse(n_candidates >= 25, " (max 25)", ""), ": ",
candidates), # this is already max 25 due to format_uncertainty_as_df()
indent = nchar(x[i, ]$input) + 6,
exdent = nchar(x[i, ]$input) + 6,
width = 0.98 * getOption("width")),
collapse = "")
# after strwrap, make taxonomic names italic
candidates <- gsub("([A-Za-z]+)", font_italic("\\1"), candidates, perl = TRUE)
candidates <- gsub(font_italic("and"), "and", candidates, fixed = TRUE)
candidates <- gsub(paste(font_italic(c("Also", "matched"), collapse = NULL), collapse = " "),
"Also matched",
candidates, fixed = TRUE)
candidates <- gsub(font_italic("max"), "max", candidates, fixed = TRUE)
candidates_formatted <- font_italic(candidates, collapse = NULL)
scores_formatted <- trimws(formatC(round(scores, 3), format = "f", digits = 3))
# sort on descending scores
candidates_formatted <- candidates_formatted[order(1 - scores)]
scores_formatted <- scores_formatted[order(1 - scores)]
candidates <- word_wrap(paste0("Also matched: ",
vector_and(paste0(candidates_formatted,
font_blue(paste0(" (", scores_formatted, ")"), collapse = NULL)),
quotes = FALSE, sort = FALSE),
ifelse(n_candidates > 25,
paste0(" [showing first 25 of ", n_candidates, "]"),
"")),
extra_indent = nchar("Also matched: "))
} else {
candidates <- ""
}
@ -1924,23 +1909,24 @@ print.mo_uncertainties <- function(x, ...) {
n = x[i, ]$fullname),
3),
format = "f", digits = 3))
msg <- paste(msg,
txt <- paste(txt,
paste0(
strwrap(
paste0('"', x[i, ]$input, '" -> ',
paste0(font_red('"', x[i, ]$input, '"', collapse = ""),
" -> ",
paste0(font_bold(font_italic(x[i, ]$fullname)),
ifelse(!is.na(x[i, ]$renamed_to), paste(", renamed to", font_italic(x[i, ]$renamed_to)), ""),
" (", x[i, ]$mo,
", matching score = ", score,
", ", font_blue(score),
") ")),
width = 0.98 * getOption("width"),
exdent = nchar(x[i, ]$input) + 6),
collapse = "\n"),
candidates,
sep = "\n")
msg <- paste0(gsub("\n\n", "\n", msg), "\n\n")
txt <- paste0(gsub("\n\n", "\n", txt), "\n\n")
}
cat(msg)
cat(txt)
}
#' @rdname as.mo

2
R/mo_matching_score.R
View File

@ -46,6 +46,8 @@
#'
#' 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.
#' @export
#' @inheritSection AMR Reference Data Publicly Available

31
R/mo_property.R
View File

@ -42,7 +42,7 @@
#'
#' 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 - all other bacteria are 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.
#' 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`).
#'
@ -364,25 +364,18 @@ mo_gramstain <- function(x, language = get_locale(), ...) {
x.mo <- as.mo(x, language = language, ...)
metadata <- get_mo_failures_uncertainties_renamed()
x.phylum <- mo_phylum(x.mo)
# DETERMINE GRAM STAIN FOR BACTERIA
# Source: https://itis.gov/servlet/SingleRpt/SingleRpt?search_topic=TSN&search_value=956097
# It says this:
# Kingdom Bacteria (Cavalier-Smith, 2002)
# Subkingdom Posibacteria (Cavalier-Smith, 2002)
# Direct Children:
# Phylum Actinobacteria (Cavalier-Smith, 2002)
# Phylum Chloroflexi (Garrity and Holt, 2002)
# Phylum Firmicutes (corrig. Gibbons and Murray, 1978)
# Phylum Tenericutes (Murray, 1984)
x <- NA_character_
x <- rep(NA_character_, length(x))
# make all bacteria Gram negative
x[mo_kingdom(x.mo) == "Bacteria"] <- "Gram-negative"
# overwrite these phyla with Gram positive
x[x.phylum %in% c("Actinobacteria",
"Chloroflexi",
"Firmicutes",
"Tenericutes")
# 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"
load_mo_failures_uncertainties_renamed(metadata)
@ -477,7 +470,7 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_locale(), ...) {
}
# show used version number once per session (pkg_env will reload every session)
if (message_not_thrown_before("intrinsic_resistant_version", entire_session = TRUE)) {
if (message_not_thrown_before("intrinsic_resistant_version.mo", entire_session = TRUE)) {
message_("Determining intrinsic resistance based on ",
format_eucast_version_nr(3.2, markdown = FALSE), ". ",
font_red("This note will be shown once per session."))

2
R/random.R
View File

@ -30,7 +30,7 @@
#' @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 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.
#'

11
R/rsi.R
View File

@ -89,7 +89,7 @@
#' A microorganism is categorised as *Resistant* when there is a high likelihood of therapeutic failure even when there is increased exposure. Exposure is a function of how the mode of administration, dose, dosing interval, infusion time, as well as distribution and excretion of the antimicrobial agent will influence the infecting organism at the site of infection.
#' - **S = Susceptible**\cr
#' A microorganism is categorised as *Susceptible, standard dosing regimen*, when there is a high likelihood of therapeutic success using a standard dosing regimen of the agent.
#' - **I = Increased exposure, but still susceptible**\cr
#' - **I = Susceptible, Increased exposure**\cr
#' A microorganism is categorised as *Susceptible, Increased exposure* when there is a high likelihood of therapeutic success because exposure to the agent is increased by adjusting the dosing regimen or by its concentration at the site of infection.
#'
#' This AMR package honours this (new) insight. Use [susceptibility()] (equal to [proportion_SI()]) to determine antimicrobial susceptibility and [count_susceptible()] (equal to [count_SI()]) to count susceptible isolates.
@ -649,10 +649,9 @@ as.rsi.data.frame <- function(x,
if (is.null(col_mo.bak)) {
col_mo <- search_type_in_df(x = x, type = "mo")
}
x_mo <- as.mo(x[, col_mo, drop = TRUE])
}
x_mo <- as.mo(x %pm>% pm_pull(col_mo))
for (i in seq_len(length(ab_cols))) {
if (types[i] == "mic") {
x[, ab_cols[i]] <- as.rsi(x = x %pm>%
@ -683,11 +682,11 @@ as.rsi.data.frame <- function(x,
show_message <- FALSE
ab <- ab_cols[i]
ab_coerced <- suppressWarnings(as.ab(ab))
if (!all(x[, ab_cols[i], drop = TRUE] %in% c("R", "S", "I"), na.rm = TRUE)) {
if (!all(x[, ab_cols[i], drop = TRUE] %in% c("R", "S", "I", NA), na.rm = TRUE)) {
show_message <- TRUE
# only print message if values are not already clean
message_("=> Cleaning values in column '", font_bold(ab), "' (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ")... ",
appendLF = FALSE,
as_note = FALSE)
@ -695,7 +694,7 @@ as.rsi.data.frame <- function(x,
show_message <- TRUE
# only print message if class not already set
message_("=> Assigning class <rsi> to already clean column '", font_bold(ab), "' (",
ifelse(ab_coerced != ab, paste0(ab_coerced, ", "), ""),
ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE), ")... ",
appendLF = FALSE,
as_note = FALSE)

BIN
R/sysdata.rda
View File

Binary file not shown.

7
R/zzz.R
View File

@ -89,12 +89,17 @@ if (utf8_supported && !is_latex) {
# reference data - they have additional columns compared to `antibiotics` and `microorganisms` to improve speed
# they can't be part of R/sysdata.rda since CRAN thinks it would make the package too large (+3 MB)
# they cannott 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"))
assign(x = "MO_lookup", value = create_MO_lookup(), envir = asNamespace("AMR"))
assign(x = "MO.old_lookup", value = create_MO.old_lookup(), envir = asNamespace("AMR"))
# for mo_is_intrinsic_resistant() - saves a lot of time when executed on this vector
assign(x = "INTRINSIC_R", value = create_intr_resistance(), envir = asNamespace("AMR"))
# for building the website, only print first 5 rows of a data set
# if (Sys.getenv("IN_PKGDOWN") != "" && !interactive()) {
# ...
# }
}
# Helper functions --------------------------------------------------------