mirror of
https://github.com/msberends/AMR.git
synced 2026-11-16 00:10:57 +01:00
- One cache design for as.ab() and as.mo() in R/aa_session_cache.R: lazily built lookup indices (ATC codes, drug synonyms, SNOMED codes) and coercion caches with the same structure (key, input, value), keyed on input plus outcome-relevant settings - Caches are invalidated whenever the lookup tables change (custom antimicrobials or microorganisms, set_mo_source()) - mo_*() functions use a fast path for valid <mo> input and work on unique values only - synonym_mo_to_accepted_mo() is memoised per code - Fix as.mo() cache keys that never matched again, fast_mode results of as.ab() being reused by regular calls, and ab_reset_session() clearing as.mo() uncertainties Co-authored-by: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
Matthijs BerendsandClaude Opus 5.5 authored and 
GitHub committed
1 parent
0ca43df459
commit
891d248fab
14 files changed
+462
-124
No files matched your search
+2
-2
@@ -1,6 +1,6 @@
|
||||
Package: AMR
|
||||
Version: 3.0.1.9103
|
||||
Date: 2026-10-04
|
||||
Version: 3.0.1.9106
|
||||
Date: 2026-10-07
|
||||
Title: Antimicrobial Resistance Data Analysis
|
||||
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
|
||||
data analysis and to work with microbial and antimicrobial properties by
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
# AMR 3.0.1.9103
|
||||
# AMR 3.0.1.9106
|
||||
|
||||
Planned as v3.1.0, mid October 2026.
|
||||
|
||||
@@ -56,6 +56,9 @@ Planned as v3.1.0, mid October 2026.
|
||||
* Assumption of disk zones are now preferred over MIC values when input is only whole numbers (#291)
|
||||
* `as.mic()`: values in scientific notation (e.g. `1e-3`) now handled correctly
|
||||
* `as.ab()`: codes containing "PH" or "TH" (e.g. `ETH`, `PHE`) no longer return `NA` when mixed with unrecognised input (#245)
|
||||
* `as.ab()`: results of `fast_mode` (used internally) were remembered and reused by later regular calls, which could return `NA` for valid input (#313)
|
||||
* `as.mo()`: previously coerced input was often not recognised again, e.g. for an unknown species of a known genus, so it was matched again on every call (#313)
|
||||
* `ab_reset_session()` no longer clears the uncertainties of `as.mo()` (#313)
|
||||
* Combined MIC/SIR input values (e.g. `"<= 0.002; S"` or `"S; 0.002"`) now parsed correctly (#252)
|
||||
* `as.mo()`:
|
||||
* Input of the form `"X complex"` now falls back to `"X"` when the complex is not a distinct taxon in the database, preventing `NA` results for valid clinical descriptions such as `"Proteus vulgaris complex"` (#287)
|
||||
@@ -74,6 +77,10 @@ Planned as v3.1.0, mid October 2026.
|
||||
* Taxonomy: consistent higher taxonomy and parent records, and data sets refer only to current names (except `intrinsic_resistant`)
|
||||
|
||||
### Updated
|
||||
* Faster `as.ab()`, `as.mo()` and all `mo_*()` functions through one consistent session cache design, which is cleared when lookup tables change, e.g. after `add_custom_microorganisms()` (#313)
|
||||
* `mo_*()` functions retrieve properties of valid `<mo>` input directly, and only for unique values
|
||||
* The mapping of outdated taxonomic names to their current names is remembered per code
|
||||
* `mo_uncertainties()` now also lists uncertainties of previously coerced input
|
||||
* `top_n_microorganisms()`: new `property_for_each` argument for sub-grouping within top *n* groups; rank ordering enforced (only lower taxonomic ranks allowed); fixed `property = NULL` not being accepted; inner filter now tracks original row indices to prevent cross-group contamination
|
||||
* Taxonomic update for all microorganisms, now updated to COL 2026-04-18 XR, LPSN and BacDive of October 2026, and MycoBank of January 2026
|
||||
* `mo_kingdom()` now returns the formal taxonomic kingdom; a one-time note per session explains the change when querying bacterial or archaeal records.
|
||||
|
||||
@@ -1697,6 +1697,8 @@ add_MO_lookup_to_AMR_env <- function() {
|
||||
MO_lookup$species_first <- tolower(substr(MO_lookup$species, 1, 1)) # tolower for groups (Streptococcus, Salmonella)
|
||||
MO_lookup$subspecies_first <- tolower(substr(MO_lookup$subspecies, 1, 1)) # tolower for Salmonella serovars
|
||||
AMR_env$MO_lookup <- MO_lookup
|
||||
# a new lookup table, so derived caches must be rebuilt
|
||||
reset_mo_cache()
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@@ -0,0 +1,133 @@
|
||||
# ==================================================================== #
|
||||
# TITLE: #
|
||||
# AMR: An R Package for Working with Antimicrobial Resistance Data #
|
||||
# #
|
||||
# SOURCE CODE: #
|
||||
# https://github.com/msberends/AMR #
|
||||
# #
|
||||
# PLEASE CITE THIS SOFTWARE AS: #
|
||||
# Berends MS, Luz CF, Friedrich AW, et al. (2022). #
|
||||
# AMR: An R Package for Working with Antimicrobial Resistance Data. #
|
||||
# Journal of Statistical Software, 104(3), 1-31. #
|
||||
# https://doi.org/10.18637/jss.v104.i03 #
|
||||
# #
|
||||
# Developed at the University of Groningen and the University Medical #
|
||||
# Center Groningen in the Netherlands, in collaboration with many #
|
||||
# colleagues from around the world, see our website. #
|
||||
# #
|
||||
# This R package is free software; you can freely use and distribute #
|
||||
# it for both personal and commercial purposes under the terms of the #
|
||||
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
|
||||
# the Free Software Foundation. #
|
||||
# We created this package for both routine data analysis and academic #
|
||||
# research and it was publicly released in the hope that it will be #
|
||||
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
|
||||
# #
|
||||
# Visit our website for the full manual and a complete tutorial about #
|
||||
# how to conduct AMR data analysis: https://amr-for-r.org #
|
||||
# ==================================================================== #
|
||||
|
||||
|
||||
# SESSION CACHES ------------------------------------------------------
|
||||
#
|
||||
# as.ab() and as.mo() share one cache design, kept in the package environment `AMR_env`:
|
||||
#
|
||||
# 1. Lookup indices, derived from `AMR_env$AB_lookup` and `AMR_env$MO_lookup` (e.g. all ATC codes or SNOMED
|
||||
# codes as one flat vector). These are built lazily on first use, see get_ab_index() and get_mo_index().
|
||||
# 2. Coercion caches, `AMR_env$ab_previously_coerced` and `AMR_env$mo_previously_coerced`, that remember the
|
||||
# outcome of earlier coercions. Both have the same structure: a `key` (the cleaned input together with the
|
||||
# settings that affect the outcome), the original `input`, and the resulting code as `value`.
|
||||
# 3. For microorganisms, the mapping from (outdated) codes to codes of currently accepted names, which is
|
||||
# memoised per unique code, see synonym_mo_to_accepted_mo().
|
||||
#
|
||||
# All of these are invalidated with reset_ab_cache() or reset_mo_cache(), which must be called whenever the
|
||||
# lookup tables change, e.g. in add_custom_antimicrobials() and add_custom_microorganisms().
|
||||
|
||||
new_coercion_cache <- function() {
|
||||
data.frame(
|
||||
key = character(0),
|
||||
input = character(0),
|
||||
value = character(0),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
}
|
||||
|
||||
coercion_cache_key <- function(x, ...) {
|
||||
# all arguments in `...` are settings that can change the outcome of a coercion, they become part of the key
|
||||
if (length(x) == 0) {
|
||||
return(character(0))
|
||||
}
|
||||
settings <- vapply(FUN.VALUE = character(1), list(...), function(s) paste0(s, collapse = ""))
|
||||
paste(x, paste(settings, collapse = "|"), sep = "|")
|
||||
}
|
||||
|
||||
coercion_cache_has <- function(type, keys) {
|
||||
keys %in% AMR_env[[paste0(type, "_previously_coerced")]]$key
|
||||
}
|
||||
|
||||
coercion_cache_get <- function(type, keys) {
|
||||
cache <- AMR_env[[paste0(type, "_previously_coerced")]]
|
||||
cache$value[match(keys, cache$key)]
|
||||
}
|
||||
|
||||
coercion_cache_add <- function(type, keys, inputs, values) {
|
||||
cache_name <- paste0(type, "_previously_coerced")
|
||||
keep <- !is.na(keys) & !duplicated(keys)
|
||||
if (!any(keep)) {
|
||||
return(invisible(NULL))
|
||||
}
|
||||
keys <- keys[keep]
|
||||
cache <- AMR_env[[cache_name]]
|
||||
AMR_env[[cache_name]] <- rbind_AMR(
|
||||
cache[which(!cache$key %in% keys), , drop = FALSE],
|
||||
data.frame(
|
||||
key = keys,
|
||||
input = as.character(inputs[keep]),
|
||||
value = as.character(values[keep]),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
)
|
||||
invisible(NULL)
|
||||
}
|
||||
|
||||
reset_ab_cache <- function() {
|
||||
AMR_env$AB_index <- NULL
|
||||
AMR_env$ab_previously_coerced <- new_coercion_cache()
|
||||
}
|
||||
|
||||
reset_mo_cache <- function() {
|
||||
AMR_env$MO_index <- NULL
|
||||
AMR_env$mo_accepted <- NULL
|
||||
AMR_env$mo_previously_coerced <- new_coercion_cache()
|
||||
AMR_env$mo_previously_uncertain <- NULL
|
||||
}
|
||||
|
||||
get_ab_index <- function() {
|
||||
if (is.null(AMR_env$AB_index)) {
|
||||
ab <- as.character(AMR_env$AB_lookup$ab)
|
||||
atc <- unlist(AMR_env$AB_lookup$atc, use.names = FALSE)
|
||||
atc_ab <- rep(ab, lengths(AMR_env$AB_lookup$atc))
|
||||
synonyms <- tolower(unlist(AMR_env$AB_lookup$synonyms, use.names = FALSE))
|
||||
synonyms_ab <- rep(ab, lengths(AMR_env$AB_lookup$synonyms))
|
||||
AMR_env$AB_index <- list(
|
||||
atc = atc[!is.na(atc)],
|
||||
atc_ab = atc_ab[!is.na(atc)],
|
||||
synonyms = synonyms[!is.na(synonyms)],
|
||||
synonyms_ab = synonyms_ab[!is.na(synonyms)]
|
||||
)
|
||||
}
|
||||
AMR_env$AB_index
|
||||
}
|
||||
|
||||
get_mo_index <- function() {
|
||||
add_MO_lookup_to_AMR_env()
|
||||
if (is.null(AMR_env$MO_index)) {
|
||||
snomed <- unlist(AMR_env$MO_lookup$snomed, use.names = FALSE)
|
||||
snomed_mo <- rep(as.character(AMR_env$MO_lookup$mo), lengths(AMR_env$MO_lookup$snomed))
|
||||
AMR_env$MO_index <- list(
|
||||
snomed = snomed[!is.na(snomed)],
|
||||
snomed_mo = snomed_mo[!is.na(snomed)]
|
||||
)
|
||||
}
|
||||
AMR_env$MO_index
|
||||
}
|
||||
@@ -48,6 +48,8 @@
|
||||
#'
|
||||
#' Use the [`ab_*`][ab_property()] functions to get properties based on the returned antibiotic ID, see *Examples*.
|
||||
#'
|
||||
#' Results of non-exact input are remembered during the session, so that the same input is not matched again. Use [ab_reset_session()] to forget these results. They are also forgotten after [add_custom_antimicrobials()] or [clear_custom_antimicrobials()].
|
||||
#'
|
||||
#' Note: the [as.ab()] and [`ab_*`][ab_property()] functions may use very long regular expression to match brand names of antimicrobial drugs. This may fail on some systems.
|
||||
#'
|
||||
#' You can add your own manual codes to be considered by [as.ab()] and all [`ab_*`][ab_property()] functions, see [add_custom_antimicrobials()].
|
||||
@@ -160,40 +162,25 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
||||
known_names <- x %in% AMR_env$AB_lookup$generalised_name
|
||||
x_new[known_names] <- AMR_env$AB_lookup$ab[match(x[known_names], AMR_env$AB_lookup$generalised_name)]
|
||||
known_codes_ab <- x %in% AMR_env$AB_lookup$ab
|
||||
known_codes_atc <- vapply(FUN.VALUE = logical(1), gsub(" ", "", x), function(x_) x_ %in% unlist(AMR_env$AB_lookup$atc), USE.NAMES = FALSE)
|
||||
known_codes_synonyms <- vapply(FUN.VALUE = logical(1), gsub(" ", "", tolower(x)), function(x_) x_ %in% tolower(unlist(AMR_env$AB_lookup$synonyms)), USE.NAMES = FALSE)
|
||||
# ATC codes and synonyms are looked up in flat vectors that are built once per session
|
||||
ab_index <- get_ab_index()
|
||||
x_atc <- gsub(" ", "", x, fixed = TRUE)
|
||||
x_synonym <- gsub(" ", "", tolower(x), fixed = TRUE)
|
||||
known_codes_atc <- x_atc %in% ab_index$atc
|
||||
known_codes_synonyms <- x_synonym %in% ab_index$synonyms
|
||||
known_codes_cid <- x %in% AMR_env$AB_lookup$cid
|
||||
x_new[known_codes_ab] <- AMR_env$AB_lookup$ab[match(x[known_codes_ab], AMR_env$AB_lookup$ab)]
|
||||
x_new[known_codes_atc] <- AMR_env$AB_lookup$ab[vapply(
|
||||
FUN.VALUE = integer(1),
|
||||
gsub(" ", "", x[known_codes_atc]),
|
||||
function(x_) {
|
||||
which(vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
AMR_env$AB_lookup$atc,
|
||||
function(atc) x_ %in% atc
|
||||
))[1L]
|
||||
},
|
||||
USE.NAMES = FALSE
|
||||
)]
|
||||
x_new[known_codes_synonyms] <- AMR_env$AB_lookup$ab[vapply(
|
||||
FUN.VALUE = integer(1),
|
||||
gsub(" ", "", tolower(x[known_codes_synonyms])),
|
||||
function(x_) {
|
||||
which(vapply(
|
||||
FUN.VALUE = logical(1),
|
||||
AMR_env$AB_lookup$synonyms,
|
||||
function(syns) x_ %in% tolower(syns)
|
||||
))[1L]
|
||||
},
|
||||
USE.NAMES = FALSE
|
||||
)]
|
||||
x_new[known_codes_atc] <- ab_index$atc_ab[match(x_atc[known_codes_atc], ab_index$atc)]
|
||||
x_new[known_codes_synonyms] <- ab_index$synonyms_ab[match(x_synonym[known_codes_synonyms], ab_index$synonyms)]
|
||||
x_new[known_codes_cid] <- AMR_env$AB_lookup$ab[match(x[known_codes_cid], AMR_env$AB_lookup$cid)]
|
||||
previously_coerced <- x %in% AMR_env$ab_previously_coerced$x
|
||||
x_new[previously_coerced & is.na(x_new)] <- AMR_env$ab_previously_coerced$ab[match(x[is.na(x_new) & x %in% AMR_env$ab_previously_coerced$x], AMR_env$ab_previously_coerced$x)]
|
||||
previously_coerced_mention <- !is.na(x) & x %in% AMR_env$ab_previously_coerced$x & !x %in% AMR_env$AB_lookup$ab & !x %in% AMR_env$AB_lookup$generalised_name
|
||||
# From previous hits in this session ----
|
||||
# the key contains all settings that can change the outcome, so that e.g. a `fast_mode` result is never reused otherwise
|
||||
cache_keys <- coercion_cache_key(x, fast_mode, flag_multiple_results, language)
|
||||
previously_coerced <- !is.na(x) & is.na(x_new) & coercion_cache_has("ab", cache_keys)
|
||||
x_new[previously_coerced] <- coercion_cache_get("ab", cache_keys[previously_coerced])
|
||||
previously_coerced_mention <- previously_coerced & !is.na(x_new)
|
||||
if (any(previously_coerced_mention) && isTRUE(info) && message_not_thrown_before("as.ab", entire_session = TRUE)) {
|
||||
only_one <- length(unique(which(x[which(previously_coerced)] %in% x_bak_clean))) == 1
|
||||
only_one <- sum(previously_coerced_mention) == 1
|
||||
message_(
|
||||
"Returning ", ifelse(only_one, "a ", ""), "previously coerced ",
|
||||
ifelse(only_one, "value for an antimicrobial", "values for various antimicrobials"),
|
||||
@@ -431,16 +418,13 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
||||
}
|
||||
|
||||
# save to package env to save time for next time
|
||||
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$x %in% x), , drop = FALSE]
|
||||
AMR_env$ab_previously_coerced <- unique(rbind_AMR(
|
||||
AMR_env$ab_previously_coerced,
|
||||
data.frame(
|
||||
x = x,
|
||||
ab = x_new,
|
||||
x_bak = x_bak[match(x, x_bak_clean)],
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
))
|
||||
coerced_now <- which(!already_known & !is.na(x))
|
||||
coercion_cache_add(
|
||||
"ab",
|
||||
keys = cache_keys[coerced_now],
|
||||
inputs = x_bak[match(x[coerced_now], x_bak_clean)],
|
||||
values = x_new[coerced_now]
|
||||
)
|
||||
|
||||
# take failed ATC codes apart from rest
|
||||
if (length(x_unknown_ATCs) > 0 && fast_mode == FALSE) {
|
||||
@@ -454,9 +438,9 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
||||
x_unknown <- x_unknown[!x_unknown %in% x_unknown_ATCs]
|
||||
x_unknown <- c(
|
||||
x_unknown,
|
||||
AMR_env$ab_previously_coerced$x_bak[which(AMR_env$ab_previously_coerced$x %in% x & is.na(AMR_env$ab_previously_coerced$ab))]
|
||||
x_bak[match(x[previously_coerced & is.na(x_new)], x_bak_clean)]
|
||||
)
|
||||
x_unknown <- x_unknown[!x_unknown %in% c("", NA)]
|
||||
x_unknown <- unique(x_unknown[!x_unknown %in% c("", NA)])
|
||||
if (length(x_unknown) > 0 && fast_mode == FALSE) {
|
||||
warning_(
|
||||
"in {.help [{.fun as.ab}](AMR::as.ab)}: ", ifelse(length(unique(x_unknown)) == 1, "this value", "these values"), " could not be coerced to a valid antimicrobial ID: ",
|
||||
@@ -466,16 +450,16 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
||||
|
||||
# Throw note about uncertainties
|
||||
x_uncertain <- x_uncertain[!is.na(x_uncertain)]
|
||||
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[!is.na(AMR_env$ab_previously_coerced$x), ]
|
||||
if (isTRUE(info) && length(x_uncertain) > 0 && fast_mode == FALSE) {
|
||||
x_uncertain <- unique(x_uncertain)
|
||||
if (message_not_thrown_before("as.ab", "uncertainties", x_bak)) {
|
||||
if (length(x_uncertain) <= 3) {
|
||||
ab_uncertain <- x_new[match(x_bak_clean[match(x_uncertain, x_bak)], x)]
|
||||
examples <- vector_and(
|
||||
paste0(
|
||||
'"', x_uncertain, '" (assumed ',
|
||||
ab_name(AMR_env$ab_previously_coerced$ab[which(AMR_env$ab_previously_coerced$x_bak %in% x_uncertain)], language = NULL, tolower = TRUE),
|
||||
", ", AMR_env$ab_previously_coerced$ab[which(AMR_env$ab_previously_coerced$x_bak %in% x_uncertain)], ")"
|
||||
ab_name(ab_uncertain, language = NULL, tolower = TRUE),
|
||||
", ", ab_uncertain, ")"
|
||||
),
|
||||
quotes = FALSE
|
||||
)
|
||||
@@ -510,8 +494,7 @@ is.ab <- function(x) {
|
||||
ab_reset_session <- function() {
|
||||
if (NROW(AMR_env$ab_previously_coerced) > 0) {
|
||||
message_("Reset ", nr2char(NROW(AMR_env$ab_previously_coerced)), " previously matched input value", ifelse(NROW(AMR_env$ab_previously_coerced) > 1, "s", ""), ".")
|
||||
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[0, , drop = FALSE]
|
||||
AMR_env$mo_uncertainties <- AMR_env$mo_uncertainties[0, , drop = FALSE]
|
||||
AMR_env$ab_previously_coerced <- new_coercion_cache()
|
||||
} else {
|
||||
message_("No previously matched input values to reset.")
|
||||
}
|
||||
|
||||
@@ -153,8 +153,9 @@ add_custom_antimicrobials <- function(x) {
|
||||
}
|
||||
AMR_env$AB_lookup <- unique(rbind_AMR(AMR_env$AB_lookup, new_df))
|
||||
|
||||
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$ab %in% c(x$ab, x$generalised_name) & !AMR_env$ab_previously_coerced$x %in% c(x$ab, x$generalised_name)), , drop = FALSE]
|
||||
class(AMR_env$AB_lookup$ab) <- c("ab", "character")
|
||||
# the lookup table changed, so earlier coercions and lookup indices are no longer valid
|
||||
reset_ab_cache()
|
||||
message_("Added ", nr2char(nrow(x)), " record", ifelse(nrow(x) > 1, "s", ""), " to the internal {.code antimicrobials} data set.")
|
||||
}
|
||||
|
||||
@@ -165,6 +166,6 @@ clear_custom_antimicrobials <- function() {
|
||||
AMR_env$AB_lookup <- cbind(AMR::antimicrobials, AB_LOOKUP)
|
||||
n2 <- nrow(AMR_env$AB_lookup)
|
||||
AMR_env$custom_ab_codes <- character(0)
|
||||
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(AMR_env$ab_previously_coerced$ab %in% AMR_env$AB_lookup$ab), , drop = FALSE]
|
||||
reset_ab_cache()
|
||||
message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal {.help [antimicrobials](AMR::antimicrobials)} data set.")
|
||||
}
|
||||
@@ -278,11 +278,11 @@ add_custom_microorganisms <- function(x) {
|
||||
new_df[, col] <- x[, col, drop = TRUE]
|
||||
}
|
||||
|
||||
# clear previous coercions
|
||||
suppressMessages(mo_reset_session())
|
||||
|
||||
AMR_env$MO_lookup <- unique(rbind_AMR(AMR_env$MO_lookup, new_df))
|
||||
class(AMR_env$MO_lookup$mo) <- c("mo", "character")
|
||||
# the lookup table changed, so earlier coercions and lookup indices are no longer valid
|
||||
reset_mo_cache()
|
||||
AMR_env$mo_uncertainties <- AMR_env$mo_uncertainties[0, , drop = FALSE]
|
||||
if (nrow(x) <= 3) {
|
||||
message_("Added ", vector_and(italicise(x$fullname), quotes = FALSE), " to the internal {.code microorganisms} data set.")
|
||||
} else {
|
||||
@@ -295,16 +295,12 @@ add_custom_microorganisms <- function(x) {
|
||||
clear_custom_microorganisms <- function() {
|
||||
n <- nrow(AMR_env$MO_lookup)
|
||||
|
||||
# reset
|
||||
# reset, which also invalidates earlier coercions and lookup indices
|
||||
AMR_env$MO_lookup <- NULL
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
# clear previous coercions
|
||||
suppressMessages(mo_reset_session())
|
||||
|
||||
n2 <- nrow(AMR_env$MO_lookup)
|
||||
AMR_env$custom_mo_codes <- character(0)
|
||||
AMR_env$mo_previously_coerced <- AMR_env$mo_previously_coerced[which(AMR_env$mo_previously_coerced$mo %in% AMR_env$MO_lookup$mo), , drop = FALSE]
|
||||
AMR_env$mo_uncertainties <- AMR_env$mo_uncertainties[0, , drop = FALSE]
|
||||
message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal {.code microorganisms} data set.")
|
||||
}
|
||||
|
||||
@@ -86,6 +86,8 @@
|
||||
#' - Use [mo_failures()] to get a [character] [vector] with all values that could not be coerced to a valid value.
|
||||
#' - Use [mo_renamed()] to get a [data.frame] with all values that could be coerced based on outdated, previously accepted taxonomic names.
|
||||
#'
|
||||
#' Results of non-exact input are remembered during the session, so that the same input is not matched again. This only applies to the same settings of `minimum_matching_score`, `only_fungi` and `cleaning_regex`. Use [mo_reset_session()] to forget these results. They are also forgotten when the taxonomy changes, e.g. after [add_custom_microorganisms()].
|
||||
#'
|
||||
#' ### For Mycologists
|
||||
#'
|
||||
#' The [matching score algorithm][mo_matching_score()] gives precedence to bacteria over fungi. If you are only analysing fungi, be sure to use `only_fungi = TRUE`, or better yet, add this to your code and run it once every session:
|
||||
@@ -207,13 +209,15 @@ as.mo <- function(x,
|
||||
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
if (tryCatch(all(x %in% c(AMR_env$MO_lookup$mo, NA)), error = function(e) FALSE) &&
|
||||
isFALSE(Becker) &&
|
||||
isFALSE(Lancefield) &&
|
||||
isTRUE(keep_synonyms)) {
|
||||
# don't look into valid MO codes, just return them
|
||||
if (isFALSE(Becker) && isFALSE(Lancefield) && is.atomic(x) && is.null(dim(x))) {
|
||||
# don't look into valid MO codes, just return them, unless synonyms must be replaced
|
||||
# is.mo() won't work - MO codes might change between package versions
|
||||
return(set_clean_class(x, new_class = c("mo", "character")))
|
||||
x_unique <- unique(as.character(x))
|
||||
x_index <- match(x_unique, AMR_env$MO_lookup$mo)
|
||||
if (all(!is.na(x_index) | is.na(x_unique)) &&
|
||||
(isTRUE(keep_synonyms) || !any(AMR_env$MO_lookup$status[x_index] == "synonym", na.rm = TRUE))) {
|
||||
return(set_clean_class(x, new_class = c("mo", "character")))
|
||||
}
|
||||
}
|
||||
|
||||
# start off with replaced language-specific non-ASCII characters with ASCII characters
|
||||
@@ -253,26 +257,31 @@ as.mo <- function(x,
|
||||
)
|
||||
}
|
||||
# From SNOMED ----
|
||||
# based on this extremely fast gem: https://stackoverflow.com/a/11002456/4575331
|
||||
snomeds <- unlist(AMR_env$MO_lookup$snomed)
|
||||
snomeds <- snomeds[!is.na(snomeds)]
|
||||
out[is.na(out) & x %in% snomeds] <- AMR_env$MO_lookup$mo[rep(seq_along(AMR_env$MO_lookup$snomed), vapply(FUN.VALUE = double(1), AMR_env$MO_lookup$snomed, length))[match(x[is.na(out) & x %in% snomeds], snomeds)]]
|
||||
# SNOMED codes are looked up in a flat vector that is built once per session
|
||||
mo_index <- get_mo_index()
|
||||
ind <- is.na(out) & x %in% mo_index$snomed
|
||||
out[ind] <- mo_index$snomed_mo[match(x[ind], mo_index$snomed)]
|
||||
# From other familiar output ----
|
||||
# such as Salmonella groups, colloquial names, etc.
|
||||
out[is.na(out)] <- convert_colloquial_input(x[is.na(out)])
|
||||
# From previous hits in this session ----
|
||||
old <- out
|
||||
out[is.na(out) & paste(x, minimum_matching_score, only_fungi) %in% AMR_env$mo_previously_coerced$x] <- AMR_env$mo_previously_coerced$mo[match(paste(x, minimum_matching_score, only_fungi)[is.na(out) & paste(x, minimum_matching_score, only_fungi) %in% AMR_env$mo_previously_coerced$x], AMR_env$mo_previously_coerced$x)]
|
||||
new <- out
|
||||
if (isTRUE(info) && message_not_thrown_before("as.mo", old, new, entire_session = TRUE) && any(is.na(old) & !is.na(new), na.rm = TRUE)) {
|
||||
x_left <- unique(x[is.na(out) & !is.na(x)])
|
||||
cache_keys_left <- coercion_cache_key(x_left, minimum_matching_score, only_fungi, cleaning_regex)
|
||||
cache_hit <- coercion_cache_has("mo", cache_keys_left)
|
||||
previously_coerced <- is.na(out) & x %in% x_left[cache_hit]
|
||||
out[previously_coerced] <- coercion_cache_get("mo", cache_keys_left[cache_hit])[match(x[previously_coerced], x_left[cache_hit])]
|
||||
previously_coerced_mention <- previously_coerced & out != "UNKNOWN"
|
||||
if (isTRUE(info) && any(previously_coerced_mention) && message_not_thrown_before("as.mo", x[previously_coerced_mention], entire_session = TRUE)) {
|
||||
message_(
|
||||
"Returning previously coerced value", ifelse(sum(is.na(old) & !is.na(new)) > 1, "s", ""),
|
||||
" for ", vector_and(x[is.na(old) & !is.na(new)]), ". Run {.help [{.fun mo_reset_session}](AMR::mo_reset_session)} to reset this. This note will be shown once per session for this input."
|
||||
"Returning previously coerced value", ifelse(length(unique(x[previously_coerced_mention])) > 1, "s", ""),
|
||||
" for ", vector_and(x[previously_coerced_mention]), ". Run {.help [{.fun mo_reset_session}](AMR::mo_reset_session)} to reset this. This note will be shown once per session for this input."
|
||||
)
|
||||
}
|
||||
|
||||
# For all other input ----
|
||||
if (any(is.na(out) & !is.na(x))) {
|
||||
to_coerce <- is.na(out) & !is.na(x)
|
||||
if (any(to_coerce)) {
|
||||
x_before_cleaning <- x
|
||||
# reset uncertainties
|
||||
AMR_env$mo_uncertainties <- AMR_env$mo_uncertainties[0, ]
|
||||
AMR_env$mo_failures <- NULL
|
||||
@@ -474,15 +483,6 @@ as.mo <- function(x,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
)
|
||||
# save to package env to save time for next time
|
||||
AMR_env$mo_previously_coerced <- unique(rbind_AMR(
|
||||
AMR_env$mo_previously_coerced,
|
||||
data.frame(
|
||||
x = paste(x_search, minimum_matching_score, only_fungi),
|
||||
mo = result_mo,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
))
|
||||
}
|
||||
# the actual result:
|
||||
as.character(result_mo)
|
||||
@@ -493,6 +493,27 @@ as.mo <- function(x,
|
||||
# expand from unique again
|
||||
out[is.na(out)] <- x_coerced[match(x[is.na(out)], x_unique)]
|
||||
|
||||
# save to package env to save time for next time, using the input from before the cleaning steps above
|
||||
coerced_now <- which(to_coerce & !is.na(x))
|
||||
coerced_now <- coerced_now[!duplicated(x_before_cleaning[coerced_now])]
|
||||
cache_keys_now <- coercion_cache_key(x_before_cleaning[coerced_now], minimum_matching_score, only_fungi, cleaning_regex)
|
||||
value_now <- out[coerced_now]
|
||||
value_now[is.na(value_now)] <- "UNKNOWN"
|
||||
coercion_cache_add("mo", keys = cache_keys_now, inputs = x_before_cleaning[coerced_now], values = value_now)
|
||||
# also save the uncertainties, so that mo_uncertainties() remains complete for previously coerced input
|
||||
uncertainty_row <- match(x[coerced_now], AMR_env$mo_uncertainties$original_input)
|
||||
if (any(!is.na(uncertainty_row))) {
|
||||
previously_uncertain <- AMR_env$mo_previously_uncertain
|
||||
AMR_env$mo_previously_uncertain <- rbind_AMR(
|
||||
previously_uncertain[which(!previously_uncertain$key %in% cache_keys_now), , drop = FALSE],
|
||||
cbind(
|
||||
key = cache_keys_now[!is.na(uncertainty_row)],
|
||||
AMR_env$mo_uncertainties[uncertainty_row[!is.na(uncertainty_row)], , drop = FALSE],
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
# Throw note about uncertainties ----
|
||||
if (isTRUE(info) && NROW(AMR_env$mo_uncertainties) > 0) {
|
||||
if (message_not_thrown_before("as.mo", "uncertainties", AMR_env$mo_uncertainties$original_input)) {
|
||||
@@ -523,6 +544,19 @@ as.mo <- function(x,
|
||||
}
|
||||
} # end of loop over all yet unknowns
|
||||
|
||||
# Add uncertainties of previously coerced input ----
|
||||
previously_uncertain <- AMR_env$mo_previously_uncertain
|
||||
previously_uncertain <- previously_uncertain[which(previously_uncertain$key %in% cache_keys_left[cache_hit]), , drop = FALSE]
|
||||
if (NROW(previously_uncertain) > 0) {
|
||||
if (!any(to_coerce)) {
|
||||
# uncertainties were not reset for new input, so do it here
|
||||
AMR_env$mo_uncertainties <- AMR_env$mo_uncertainties[0, , drop = FALSE]
|
||||
}
|
||||
previously_uncertain$key <- NULL
|
||||
previously_uncertain$keep_synonyms <- keep_synonyms
|
||||
AMR_env$mo_uncertainties <- rbind_AMR(AMR_env$mo_uncertainties, previously_uncertain)
|
||||
}
|
||||
|
||||
# Keep or replace synonyms ----
|
||||
out_current <- synonym_mo_to_accepted_mo(out, fill_in_accepted = FALSE)
|
||||
AMR_env$mo_renamed <- list(old = out[!is.na(out_current)])
|
||||
@@ -653,7 +687,8 @@ mo_failures <- function() {
|
||||
mo_reset_session <- function() {
|
||||
if (NROW(AMR_env$mo_previously_coerced) > 0) {
|
||||
message_("Reset ", nr2char(NROW(AMR_env$mo_previously_coerced)), " previously matched input value", ifelse(NROW(AMR_env$mo_previously_coerced) > 1, "s", ""), ".")
|
||||
AMR_env$mo_previously_coerced <- AMR_env$mo_previously_coerced[0, , drop = FALSE]
|
||||
AMR_env$mo_previously_coerced <- new_coercion_cache()
|
||||
AMR_env$mo_previously_uncertain <- NULL
|
||||
AMR_env$mo_uncertainties <- AMR_env$mo_uncertainties[0, , drop = FALSE]
|
||||
} else {
|
||||
message_("No previously matched input values to reset.")
|
||||
@@ -1387,11 +1422,39 @@ load_mo_uncertainties <- function(metadata) {
|
||||
|
||||
synonym_mo_to_accepted_mo <- function(x, fill_in_accepted = FALSE, dataset = AMR_env$MO_lookup) {
|
||||
# `dataset` is an argument so that it can be used in the regeneration of the microorganisms data set
|
||||
if (identical(dataset, AMR_env$MO_lookup)) {
|
||||
add_MO_lookup_to_AMR_env()
|
||||
dataset <- AMR_env$MO_lookup
|
||||
if (!identical(dataset, AMR_env$MO_lookup)) {
|
||||
return(synonym_mo_to_accepted_mo_uncached(x, fill_in_accepted = fill_in_accepted, dataset = dataset))
|
||||
}
|
||||
|
||||
# for the internal lookup table, the outcome is memoised per unique code for the whole session
|
||||
add_MO_lookup_to_AMR_env()
|
||||
x <- as.character(x)
|
||||
accepted <- AMR_env$mo_accepted
|
||||
if (is.null(accepted)) {
|
||||
accepted <- data.frame(mo = character(0), accepted = character(0), stringsAsFactors = FALSE)
|
||||
}
|
||||
x_new <- unique(x[!is.na(x) & !x %in% accepted$mo])
|
||||
if (length(x_new) > 0) {
|
||||
accepted <- rbind_AMR(
|
||||
accepted,
|
||||
data.frame(
|
||||
mo = x_new,
|
||||
accepted = synonym_mo_to_accepted_mo_uncached(x_new, fill_in_accepted = TRUE, dataset = AMR_env$MO_lookup),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
)
|
||||
AMR_env$mo_accepted <- accepted
|
||||
}
|
||||
|
||||
out <- accepted$accepted[match(x, accepted$mo)]
|
||||
if (isFALSE(fill_in_accepted)) {
|
||||
# only return codes that were actually renamed, i.e., of synonyms with a known current name
|
||||
out[!is.na(out) & out == x] <- NA_character_
|
||||
}
|
||||
out
|
||||
}
|
||||
|
||||
synonym_mo_to_accepted_mo_uncached <- function(x, fill_in_accepted = FALSE, dataset) {
|
||||
out <- x
|
||||
is_still_synonym <- dataset$status[match(out, dataset$mo)] == "synonym"
|
||||
limit <- 0
|
||||
|
||||
+43
-24
@@ -1038,34 +1038,53 @@ mo_validate <- function(x, property, language, keep_synonyms = keep_synonyms, ..
|
||||
}
|
||||
has_Becker_or_Lancefield <- Becker %in% c(TRUE, "all") || Lancefield %in% c(TRUE, "all")
|
||||
|
||||
if (isFALSE(has_Becker_or_Lancefield) && isTRUE(keep_synonyms) && all(x %in% c(AMR_env$MO_lookup$mo, NA))) {
|
||||
# fastest way to get properties
|
||||
if (property == "snomed") {
|
||||
x <- lapply(x, function(y) unlist(AMR_env$MO_lookup$snomed[match(y, AMR_env$MO_lookup$mo)]))
|
||||
} else {
|
||||
x <- AMR_env$MO_lookup[[property]][match(x, AMR_env$MO_lookup$mo)]
|
||||
}
|
||||
# properties are retrieved for unique values only, and expanded again at the end
|
||||
x_full <- NULL
|
||||
if (is.atomic(x) && is.null(dim(x)) && anyDuplicated(x) > 0) {
|
||||
x_full <- x
|
||||
x <- unique(x)
|
||||
}
|
||||
if (is.atomic(x) && is.null(dim(x))) {
|
||||
x_index <- match(x, AMR_env$MO_lookup$mo)
|
||||
is_valid_mo <- !is.na(x_index) | is.na(x)
|
||||
} else {
|
||||
# get microorganisms data set, but remove synonyms if keep_synonyms is FALSE
|
||||
mo_data_check <- AMR_env$MO_lookup[which(AMR_env$MO_lookup$status %in% if (isTRUE(keep_synonyms)) c("synonym", "accepted") else "accepted"), , drop = FALSE]
|
||||
is_valid_mo <- FALSE
|
||||
}
|
||||
|
||||
if (all(x %in% c(mo_data_check$mo, NA)) && !has_Becker_or_Lancefield) {
|
||||
# do nothing, just don't run the other if-else's
|
||||
} else if (all(x %in% c(unlist(mo_data_check[[property]]), NA)) && !has_Becker_or_Lancefield) {
|
||||
# no need to do anything, just return it
|
||||
return(x)
|
||||
} else {
|
||||
# we need to get MO codes now
|
||||
x <- replace_old_mo_codes(x, property = property)
|
||||
x <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
|
||||
if (isFALSE(has_Becker_or_Lancefield) && all(is_valid_mo) &&
|
||||
(isTRUE(keep_synonyms) || !any(AMR_env$MO_lookup$status[x_index] == "synonym", na.rm = TRUE))) {
|
||||
# fastest way to get properties: valid MO codes that need no further coercion
|
||||
} else {
|
||||
if (isFALSE(has_Becker_or_Lancefield) && !all(is_valid_mo)) {
|
||||
# input might already contain the property, such as a genus for mo_genus(), in which case just return it
|
||||
# (synonyms only count if keep_synonyms is TRUE)
|
||||
allowed_status <- if (isTRUE(keep_synonyms)) c("synonym", "accepted") else "accepted"
|
||||
property_values <- AMR_env$MO_lookup[[property]][which(AMR_env$MO_lookup$status %in% allowed_status)]
|
||||
if (is.list(property_values)) {
|
||||
property_values <- unlist(property_values)
|
||||
}
|
||||
if (all(x %in% c(property_values, NA))) {
|
||||
if (is.null(x_full)) {
|
||||
return(x)
|
||||
} else {
|
||||
return(x_full)
|
||||
}
|
||||
}
|
||||
}
|
||||
# we need to get MO codes now
|
||||
x <- replace_old_mo_codes(x, property = property)
|
||||
x <- as.mo(x, language = language, keep_synonyms = keep_synonyms, ...)
|
||||
x_index <- match(x, AMR_env$MO_lookup$mo)
|
||||
}
|
||||
|
||||
# get property reeaaally fast using match()
|
||||
if (property == "snomed") {
|
||||
x <- lapply(x, function(y) unlist(AMR_env$MO_lookup$snomed[match(y, AMR_env$MO_lookup$mo)]))
|
||||
} else {
|
||||
x <- AMR_env$MO_lookup[[property]][match(x, AMR_env$MO_lookup$mo)]
|
||||
}
|
||||
# get property reeaaally fast using match()
|
||||
if (property == "snomed") {
|
||||
x <- lapply(x_index, function(i) unlist(AMR_env$MO_lookup$snomed[i]))
|
||||
} else {
|
||||
x <- AMR_env$MO_lookup[[property]][x_index]
|
||||
}
|
||||
if (!is.null(x_full)) {
|
||||
x <- x[match(x_full, unique(x_full))]
|
||||
}
|
||||
|
||||
if (property == "mo") {
|
||||
|
||||
@@ -132,6 +132,9 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
|
||||
stop_ifnot(destination %like% "[.]rds$", "the {.arg destination} must be a file location with file extension .rds.")
|
||||
mo_source_destination <- path.expand(destination)
|
||||
|
||||
# earlier coercions might have been based on another mo_source
|
||||
AMR_env$mo_previously_coerced <- new_coercion_cache()
|
||||
|
||||
if (is.null(path) || path %in% c(FALSE, "")) {
|
||||
AMR_env$mo_source <- NULL
|
||||
if (file.exists(mo_source_destination)) {
|
||||
|
||||
@@ -40,16 +40,9 @@ AMR_env$mo_uncertainties <- data.frame(
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
AMR_env$mo_renamed <- list()
|
||||
AMR_env$mo_previously_coerced <- data.frame(
|
||||
x = character(0),
|
||||
mo = character(0),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
AMR_env$ab_previously_coerced <- data.frame(
|
||||
x = character(0),
|
||||
ab = character(0),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
# session caches of as.ab() and as.mo(), see R/aa_session_cache.R
|
||||
AMR_env$mo_previously_coerced <- new_coercion_cache()
|
||||
AMR_env$ab_previously_coerced <- new_coercion_cache()
|
||||
AMR_env$av_previously_coerced <- data.frame(
|
||||
x = character(0),
|
||||
av = character(0),
|
||||
@@ -111,6 +104,7 @@ AMR_env$cross_icon <- if (isTRUE(base::l10n_info()$`UTF-8`)) "\u00d7" else "x"
|
||||
}
|
||||
|
||||
AMR_env$AB_lookup <- cbind(AMR::antimicrobials, AB_LOOKUP)
|
||||
reset_ab_cache()
|
||||
AMR_env$AV_lookup <- cbind(AMR::antivirals, AV_LOOKUP)
|
||||
}
|
||||
|
||||
|
||||
@@ -52,6 +52,8 @@ All these properties will be searched for the user input. The \code{\link[=as.ab
|
||||
|
||||
Use the \code{\link[=ab_property]{ab_*}} functions to get properties based on the returned antibiotic ID, see \emph{Examples}.
|
||||
|
||||
Results of non-exact input are remembered during the session, so that the same input is not matched again. Use \code{\link[=ab_reset_session]{ab_reset_session()}} to forget these results. They are also forgotten after \code{\link[=add_custom_antimicrobials]{add_custom_antimicrobials()}} or \code{\link[=clear_custom_antimicrobials]{clear_custom_antimicrobials()}}.
|
||||
|
||||
Note: the \code{\link[=as.ab]{as.ab()}} and \code{\link[=ab_property]{ab_*}} functions may use very long regular expression to match brand names of antimicrobial drugs. This may fail on some systems.
|
||||
|
||||
You can add your own manual codes to be considered by \code{\link[=as.ab]{as.ab()}} and all \code{\link[=ab_property]{ab_*}} functions, see \code{\link[=add_custom_antimicrobials]{add_custom_antimicrobials()}}.
|
||||
|
||||
@@ -113,6 +113,8 @@ There are three helper functions that can be run after using the \code{\link[=as
|
||||
\item Use \code{\link[=mo_failures]{mo_failures()}} to get a \link{character} \link{vector} with all values that could not be coerced to a valid value.
|
||||
\item Use \code{\link[=mo_renamed]{mo_renamed()}} to get a \link{data.frame} with all values that could be coerced based on outdated, previously accepted taxonomic names.
|
||||
}
|
||||
|
||||
Results of non-exact input are remembered during the session, so that the same input is not matched again. This only applies to the same settings of \code{minimum_matching_score}, \code{only_fungi} and \code{cleaning_regex}. Use \code{\link[=mo_reset_session]{mo_reset_session()}} to forget these results. They are also forgotten when the taxonomy changes, e.g. after \code{\link[=add_custom_microorganisms]{add_custom_microorganisms()}}.
|
||||
}
|
||||
|
||||
\subsection{For Mycologists}{
|
||||
|
||||
@@ -0,0 +1,133 @@
|
||||
# ==================================================================== #
|
||||
# TITLE: #
|
||||
# AMR: An R Package for Working with Antimicrobial Resistance Data #
|
||||
# #
|
||||
# SOURCE CODE: #
|
||||
# https://github.com/msberends/AMR #
|
||||
# #
|
||||
# PLEASE CITE THIS SOFTWARE AS: #
|
||||
# Berends MS, Luz CF, Friedrich AW, et al. (2022). #
|
||||
# AMR: An R Package for Working with Antimicrobial Resistance Data. #
|
||||
# Journal of Statistical Software, 104(3), 1-31. #
|
||||
# https://doi.org/10.18637/jss.v104.i03 #
|
||||
# #
|
||||
# Developed at the University of Groningen and the University Medical #
|
||||
# Center Groningen in the Netherlands, in collaboration with many #
|
||||
# colleagues from around the world, see our website. #
|
||||
# #
|
||||
# This R package is free software; you can freely use and distribute #
|
||||
# it for both personal and commercial purposes under the terms of the #
|
||||
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
|
||||
# the Free Software Foundation. #
|
||||
# We created this package for both routine data analysis and academic #
|
||||
# research and it was publicly released in the hope that it will be #
|
||||
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
|
||||
# #
|
||||
# Visit our website for the full manual and a complete tutorial about #
|
||||
# how to conduct AMR data analysis: https://amr-for-r.org #
|
||||
# ==================================================================== #
|
||||
|
||||
test_that("test-session_cache.R", {
|
||||
skip_on_cran()
|
||||
|
||||
# as.ab() ----
|
||||
ab_reset_session()
|
||||
# a `fast_mode` result must never be reused by a regular coercion
|
||||
expect_true(is.na(suppressWarnings(as.ab("amxcilin", fast_mode = TRUE, info = FALSE))))
|
||||
expect_identical(as.character(suppressWarnings(as.ab("amxcilin", info = FALSE))), "AMX")
|
||||
expect_true(all(c("amxcilin") %in% AMR:::AMR_env$ab_previously_coerced$input))
|
||||
expect_identical(colnames(AMR:::AMR_env$ab_previously_coerced), c("key", "input", "value"))
|
||||
# second run comes from the cache and gives the same result
|
||||
expect_identical(as.character(as.ab("amxcilin", info = FALSE)), "AMX")
|
||||
# ATC codes and synonyms are looked up in the session index
|
||||
expect_identical(as.character(as.ab(c("J01CA04", "J01MA02", "amoxil", "cipro"), info = FALSE)), c("AMX", "CIP", "AMX", "CIP"))
|
||||
# resetting does not touch microorganism uncertainties
|
||||
suppressWarnings(as.mo("Klebsiela pneumonia", info = FALSE))
|
||||
n_uncertain <- NROW(mo_uncertainties())
|
||||
expect_message(ab_reset_session())
|
||||
expect_identical(NROW(mo_uncertainties()), n_uncertain)
|
||||
expect_identical(NROW(AMR:::AMR_env$ab_previously_coerced), 0L)
|
||||
|
||||
# as.mo() ----
|
||||
mo_reset_session()
|
||||
x <- c("Klebsiela pneumonia", "Stafylococcus aureus")
|
||||
expect_identical(as.character(suppressWarnings(as.mo(x, info = FALSE))), c("B_KLBSL_PNMN", "B_STPHY_AURS"))
|
||||
expect_true(all(x %in% AMR:::AMR_env$mo_previously_coerced$input))
|
||||
expect_identical(NROW(mo_uncertainties()), 2L)
|
||||
# second run comes from the cache, and the uncertainties are still complete
|
||||
expect_identical(as.character(suppressWarnings(as.mo(rev(x), info = FALSE))), c("B_STPHY_AURS", "B_KLBSL_PNMN"))
|
||||
expect_identical(sort(mo_uncertainties()$original_input), sort(x))
|
||||
# another minimum_matching_score is another cache key
|
||||
n_cached <- NROW(AMR:::AMR_env$mo_previously_coerced)
|
||||
suppressWarnings(as.mo(x, minimum_matching_score = 0.1, info = FALSE))
|
||||
expect_identical(NROW(AMR:::AMR_env$mo_previously_coerced), n_cached + 2L)
|
||||
# cached results are keyed on the original input, also when it is cleaned before fuzzy matching
|
||||
mo_reset_session()
|
||||
suppressWarnings(as.mo("Klebsiela pneumonia group", info = FALSE))
|
||||
expect_true("Klebsiela pneumonia group" %in% AMR:::AMR_env$mo_previously_coerced$input)
|
||||
# input that could not be coerced is also remembered
|
||||
expect_identical(as.character(suppressWarnings(as.mo("xq", info = FALSE))), "UNKNOWN")
|
||||
expect_warning(as.mo("xq", info = FALSE))
|
||||
expect_identical(mo_failures(), "xq")
|
||||
|
||||
# valid codes of outdated names are replaced, also on the fast path
|
||||
syn <- AMR:::AMR_env$MO_lookup$mo[AMR:::AMR_env$MO_lookup$status == "synonym"][1:5]
|
||||
expect_false(any(as.mo(syn, keep_synonyms = FALSE, info = FALSE) %in% syn, na.rm = TRUE))
|
||||
expect_identical(as.character(as.mo(syn, keep_synonyms = TRUE, info = FALSE)), as.character(syn))
|
||||
|
||||
# SNOMED codes
|
||||
expect_identical(as.character(as.mo(c(112283007, 3092008), info = FALSE)), c("B_ESCHR_COLI", "B_STPHY_AURS"))
|
||||
|
||||
# synonym_mo_to_accepted_mo() ----
|
||||
all_mo <- as.character(AMR:::AMR_env$MO_lookup$mo)
|
||||
for (fill in c(TRUE, FALSE)) {
|
||||
AMR:::reset_mo_cache()
|
||||
expect_identical(
|
||||
AMR:::synonym_mo_to_accepted_mo(c(all_mo, NA, "invalid"), fill_in_accepted = fill),
|
||||
AMR:::synonym_mo_to_accepted_mo_uncached(c(all_mo, NA, "invalid"), fill_in_accepted = fill, dataset = AMR:::AMR_env$MO_lookup)
|
||||
)
|
||||
# now from the memoised mapping
|
||||
expect_identical(
|
||||
AMR:::synonym_mo_to_accepted_mo(rev(all_mo), fill_in_accepted = fill),
|
||||
AMR:::synonym_mo_to_accepted_mo_uncached(rev(all_mo), fill_in_accepted = fill, dataset = AMR:::AMR_env$MO_lookup)
|
||||
)
|
||||
}
|
||||
|
||||
# mo_*() functions ----
|
||||
x <- as.mo(c("B_ESCHR_COLI", "B_STPHY_AURS", NA, "B_ESCHR_COLI", "UNKNOWN"))
|
||||
expect_identical(mo_name(x, language = NULL), c("Escherichia coli", "Staphylococcus aureus", NA, "Escherichia coli", "(unknown name)"))
|
||||
expect_identical(mo_genus(rep(x, 3), language = NULL), rep(mo_genus(x, language = NULL), 3))
|
||||
expect_identical(mo_snomed(x[c(1, 1, 3)]), list(mo_snomed(x[1])[[1]], mo_snomed(x[1])[[1]], NULL))
|
||||
expect_identical(mo_property(x, "prevalence"), as.double(AMR:::AMR_env$MO_lookup$prevalence[match(x, AMR:::AMR_env$MO_lookup$mo)]))
|
||||
# input that already contains the property is returned as is
|
||||
expect_identical(mo_genus(c("Escherichia", "Escherichia", NA)), c("Escherichia", "Escherichia", NA))
|
||||
# character input with duplicates
|
||||
expect_identical(mo_name(c("E. coli", "S. aureus", "E. coli"), language = NULL), c("Escherichia coli", "Staphylococcus aureus", "Escherichia coli"))
|
||||
# factors
|
||||
expect_identical(mo_gramstain(factor(c("E. coli", "S. aureus", "E. coli")), language = NULL), c("Gram-negative", "Gram-positive", "Gram-negative"))
|
||||
# synonyms are replaced unless keep_synonyms = TRUE
|
||||
expect_false(any(mo_name(syn, keep_synonyms = FALSE, language = NULL) == mo_name(syn, keep_synonyms = TRUE, language = NULL)))
|
||||
|
||||
# invalidation ----
|
||||
mo_reset_session()
|
||||
suppressWarnings(as.mo("Klebsiela pneumonia", info = FALSE))
|
||||
invisible(AMR:::get_mo_index())
|
||||
invisible(AMR:::synonym_mo_to_accepted_mo("B_ESCHR_COLI"))
|
||||
suppressMessages(add_custom_microorganisms(data.frame(genus = "Testbacterium", species = "cachei")))
|
||||
expect_identical(NROW(AMR:::AMR_env$mo_previously_coerced), 0L)
|
||||
expect_null(AMR:::AMR_env$MO_index)
|
||||
expect_null(AMR:::AMR_env$mo_accepted)
|
||||
expect_identical(mo_name("Testbacterium cachei", language = NULL), "Testbacterium cachei")
|
||||
suppressMessages(clear_custom_microorganisms())
|
||||
expect_identical(NROW(AMR:::AMR_env$mo_previously_coerced), 0L)
|
||||
|
||||
ab_reset_session()
|
||||
expect_true(is.na(suppressWarnings(as.ab("Qwxzqwxz", info = FALSE))))
|
||||
invisible(AMR:::get_ab_index())
|
||||
suppressMessages(add_custom_antimicrobials(data.frame(ab = "TESTCD", name = "Qwxzqwxz", group = "Test group")))
|
||||
expect_identical(NROW(AMR:::AMR_env$ab_previously_coerced), 0L)
|
||||
expect_null(AMR:::AMR_env$AB_index)
|
||||
expect_identical(as.character(as.ab("Qwxzqwxz", info = FALSE)), "TESTCD")
|
||||
suppressMessages(clear_custom_antimicrobials())
|
||||
expect_true(is.na(suppressWarnings(as.ab("Qwxzqwxz", info = FALSE))))
|
||||
})
|
||||
Reference in new issue
Block a user