mirror of
https://github.com/msberends/AMR.git
synced 2026-03-30 09:36:07 +02:00
Compare commits
2 Commits
51f689b069
...
9f73571832
| Author | SHA1 | Date | |
|---|---|---|---|
|
9f73571832 | ||
| d28671c34d |
@@ -1,5 +1,5 @@
|
||||
Package: AMR
|
||||
Version: 3.0.1.9038
|
||||
Version: 3.0.1.9039
|
||||
Date: 2026-03-19
|
||||
Title: Antimicrobial Resistance Data Analysis
|
||||
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
|
||||
|
||||
5
NEWS.md
5
NEWS.md
@@ -1,4 +1,4 @@
|
||||
# AMR 3.0.1.9038
|
||||
# AMR 3.0.1.9039
|
||||
|
||||
### New
|
||||
* Integration with the **tidymodels** framework to allow seamless use of SIR, MIC and disk data in modelling pipelines via `recipes`
|
||||
@@ -32,7 +32,8 @@
|
||||
### Updates
|
||||
* Replaced all bare backtick-quoted text in `message_()`, `warning_()`, and `stop_()` calls with proper cli inline markup (`{.arg}`, `{.cls}`, `{.fun}`, `{.pkg}`, `{.code}`); rewrote `print.ab` to use a cli named-vector with `*` bullets and code highlighting when cli is available
|
||||
* Added `format_inline_()` helper that formats a cli-markup string and returns it (rather than emitting it), using `cli::format_inline()` when available and `cli_to_plain()` otherwise; used this in `.onAttach` to replace the duplicated cli/non-cli startup message pattern
|
||||
* All inline `{variable}` / `{expression}` in messaging calls are now pre-evaluated via `paste0()`, so users without cli or glue never see raw template syntax
|
||||
* All inline `{variable}` / `{expression}` in messaging calls are now pre-evaluated via `paste0()`, so users without cli or glue never see raw template syntax
|
||||
* All `"in `funcname()`:"` patterns in `warning_()`/`message_()`/`stop_()` replaced with `{.help [{.fun funcname}](AMR::funcname)}` for clickable help links
|
||||
* `mdro()` now infers resistance for a _missing_ base drug column from an _available_ corresponding drug+inhibitor combination showing resistance (e.g., piperacillin is absent but required, while piperacillin/tazobactam available and resistant). Can be set with the new argument `infer_from_combinations`, which defaults to `TRUE` (#209). Note that this can yield a higher MDRO detection (which is a good thing as it has become more reliable).
|
||||
* `susceptibility()` and `resistance()` gained the argument `guideline`, which defaults to EUCAST, for interpreting the 'I' category correctly.
|
||||
* Added to the `antimicrobials` data set: cefepime/taniborbactam (`FTA`), ceftibuten/avibactam (`CTA`), clorobiocin (`CLB`), kasugamycin (`KAS`), ostreogrycin (`OST`), taniborbactam (`TAN`), thiostrepton (`THS`), xeruborbactam (`XER`), and zorbamycin (`ZOR`)
|
||||
|
||||
@@ -304,7 +304,8 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
|
||||
if (!is.null(found)) {
|
||||
# this column should contain logicals
|
||||
if (!is.logical(x[, found, drop = TRUE])) {
|
||||
message_("Column '", font_bold(found), "' found as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type,
|
||||
message_(
|
||||
"Column '", font_bold(found), "' found as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type,
|
||||
"}, but this column does not contain {.code TRUE}/{.code FALSE} values and was ignored."
|
||||
)
|
||||
found <- NULL
|
||||
@@ -407,7 +408,7 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
|
||||
if (isTRUE(error_on_fail)) {
|
||||
stop_ifnot_installed(pkg)
|
||||
}
|
||||
if (pkg == "rstudioapi" && !in_rstudio()) {
|
||||
if (pkg == "rstudioapi" && (!in_rstudio() || !interactive())) {
|
||||
# only allow rstudioapi to be imported if we're in RStudio
|
||||
return(NULL)
|
||||
}
|
||||
@@ -464,15 +465,15 @@ cli_to_plain <- function(msg, envir = parent.frame()) {
|
||||
}
|
||||
|
||||
# cli inline markup -> plain-text equivalents (one level of glue nesting allowed)
|
||||
msg <- apply_sub(msg, "\\{\\.fun (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "()`"))
|
||||
msg <- apply_sub(msg, "\\{\\.arg (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "`"))
|
||||
msg <- apply_sub(msg, "\\{\\.code (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "`"))
|
||||
msg <- apply_sub(msg, "\\{\\.val (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0('"', resolve(c), '"'))
|
||||
msg <- apply_sub(msg, "\\{\\.field (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0('"', resolve(c), '"'))
|
||||
msg <- apply_sub(msg, "\\{\\.cls (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("<", resolve(c), ">"))
|
||||
msg <- apply_sub(msg, "\\{\\.pkg (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
|
||||
msg <- apply_sub(msg, "\\{\\.fun (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "()`"))
|
||||
msg <- apply_sub(msg, "\\{\\.arg (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "`"))
|
||||
msg <- apply_sub(msg, "\\{\\.code (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "`"))
|
||||
msg <- apply_sub(msg, "\\{\\.val (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0('"', resolve(c), '"'))
|
||||
msg <- apply_sub(msg, "\\{\\.field (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0('"', resolve(c), '"'))
|
||||
msg <- apply_sub(msg, "\\{\\.cls (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("<", resolve(c), ">"))
|
||||
msg <- apply_sub(msg, "\\{\\.pkg (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
|
||||
msg <- apply_sub(msg, "\\{\\.strong (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
|
||||
msg <- apply_sub(msg, "\\{\\.emph (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
|
||||
msg <- apply_sub(msg, "\\{\\.emph (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
|
||||
msg <- apply_sub(msg, "\\{\\.help ([^}]+)\\}", function(c) {
|
||||
# Handle [display text](topic) markdown link format: extract just the display text
|
||||
m <- regmatches(c, regexec("^\\[(.*)\\]\\([^)]*\\)$", c))[[1L]]
|
||||
@@ -483,8 +484,8 @@ cli_to_plain <- function(msg, envir = parent.frame()) {
|
||||
m <- regmatches(c, regexec("^\\[(.*)\\]\\([^)]*\\)$", c))[[1L]]
|
||||
if (length(m) >= 2L) m[2L] else paste0("?", resolve(c))
|
||||
})
|
||||
msg <- apply_sub(msg, "\\{\\.url (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
|
||||
msg <- apply_sub(msg, "\\{\\.href ([^}]+)\\}", function(c) strsplit(resolve(c), " ", fixed = TRUE)[[1L]][1L])
|
||||
msg <- apply_sub(msg, "\\{\\.url (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
|
||||
msg <- apply_sub(msg, "\\{\\.href ([^}]+)\\}", function(c) strsplit(resolve(c), " ", fixed = TRUE)[[1L]][1L])
|
||||
|
||||
# bare {variable} or {expression} -> evaluate in caller's environment
|
||||
while (grepl("\\{[^{}]+\\}", msg)) {
|
||||
|
||||
15
R/ab.R
15
R/ab.R
@@ -191,12 +191,13 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
||||
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 <- x %in% AMR_env$ab_previously_coerced$x & !x %in% AMR_env$AB_lookup$ab & !x %in% AMR_env$AB_lookup$generalised_name
|
||||
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
|
||||
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
|
||||
message_(
|
||||
"Returning previously coerced ",
|
||||
ifelse(length(unique(which(x[which(previously_coerced)] %in% x_bak_clean))) > 1, "value for an antimicrobial", "values for various antimicrobials"),
|
||||
". Run `ab_reset_session()` to reset this. This note will be shown once per session."
|
||||
"Returning ", ifelse(only_one, "a ", ""), "previously coerced ",
|
||||
ifelse(only_one, "value for an antimicrobial", "values for various antimicrobials"),
|
||||
". Run {.help [{.fun ab_reset_session}](AMR::ab_reset_session)} to reset this. This note will be shown once per session."
|
||||
)
|
||||
}
|
||||
|
||||
@@ -444,7 +445,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
||||
# take failed ATC codes apart from rest
|
||||
if (length(x_unknown_ATCs) > 0 && fast_mode == FALSE) {
|
||||
warning_(
|
||||
"in `as.ab()`: these ATC codes are not (yet) in the antimicrobials data set: ",
|
||||
"in {.help [{.fun as.ab}](AMR::as.ab)}: these ATC codes are not (yet) in the antimicrobials data set: ",
|
||||
vector_and(x_unknown_ATCs), "."
|
||||
)
|
||||
}
|
||||
@@ -458,12 +459,14 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
||||
x_unknown <- x_unknown[!x_unknown %in% c("", NA)]
|
||||
if (length(x_unknown) > 0 && fast_mode == FALSE) {
|
||||
warning_(
|
||||
"in `as.ab()`: ", ifelse(length(unique(x_unknown)) == 1, "this value", "these values"), " could not be coerced to a valid antimicrobial ID: ",
|
||||
"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: ",
|
||||
vector_and(x_unknown), "."
|
||||
)
|
||||
}
|
||||
|
||||
# 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)) {
|
||||
|
||||
@@ -265,7 +265,7 @@ ab_ddd <- function(x, administration = "oral", ...) {
|
||||
|
||||
if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
|
||||
warning_(
|
||||
"in `ab_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"in {.help [{.fun ab_ddd}](AMR::ab_ddd)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"Please refer to the WHOCC website:\n",
|
||||
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
||||
)
|
||||
@@ -285,7 +285,7 @@ ab_ddd_units <- function(x, administration = "oral", ...) {
|
||||
|
||||
if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
|
||||
warning_(
|
||||
"in `ab_ddd_units()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"in {.help [{.fun ab_ddd_units}](AMR::ab_ddd_units)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"Please refer to the WHOCC website:\n",
|
||||
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
||||
)
|
||||
@@ -424,7 +424,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
|
||||
)
|
||||
if (any(x %in% c("", NA))) {
|
||||
warning_(
|
||||
"in `set_ab_names()`: no ", property, " found for column(s): ",
|
||||
"in {.help [{.fun set_ab_names}](AMR::set_ab_names)}: no ", property, " found for column(s): ",
|
||||
vector_and(vars[x %in% c("", NA)], sort = FALSE)
|
||||
)
|
||||
x[x %in% c("", NA)] <- vars[x %in% c("", NA)]
|
||||
|
||||
@@ -583,9 +583,9 @@ antibiogram.default <- function(x,
|
||||
if (length(existing_ab_combined_cols) > 0 && !is.null(ab_transform)) {
|
||||
ab_transform <- NULL
|
||||
warning_(
|
||||
"Detected column name(s) containing the '+' character, which conflicts with the expected syntax in `antibiogram()`: the '+' is used to combine separate antimicrobial drug columns (e.g., \"AMP+GEN\").\n\n",
|
||||
"To avoid incorrectly guessing which antimicrobials this represents, `ab_transform` was automatically set to `NULL`.\n\n",
|
||||
"If this is unintended, please rename the column(s) to avoid using '+' in the name, or set `ab_transform = NULL` explicitly to suppress this message."
|
||||
"Detected column name(s) containing the '+' character, which conflicts with the expected syntax in {.help [{.fun antibiogram}](AMR::antibiogram)}: the '+' is used to combine separate antimicrobial drug columns (e.g., \"AMP+GEN\").\n\n",
|
||||
"To avoid incorrectly guessing which antimicrobials this represents, {.arg ab_transform} was automatically set to {.code NULL}.\n\n",
|
||||
"If this is unintended, please rename the column(s) to avoid using '+' in the name, or set {.code ab_transform = NULL} explicitly to suppress this message."
|
||||
)
|
||||
}
|
||||
antimicrobials <- ab_trycatch
|
||||
|
||||
4
R/av.R
4
R/av.R
@@ -475,7 +475,7 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
# take failed ATC codes apart from rest
|
||||
if (length(x_unknown_ATCs) > 0 && fast_mode == FALSE) {
|
||||
warning_(
|
||||
"in `as.av()`: these ATC codes are not (yet) in the antivirals data set: ",
|
||||
"in {.help [{.fun as.av}](AMR::as.av)}: these ATC codes are not (yet) in the antivirals data set: ",
|
||||
vector_and(x_unknown_ATCs), "."
|
||||
)
|
||||
}
|
||||
@@ -486,7 +486,7 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
||||
)
|
||||
if (length(x_unknown) > 0 && fast_mode == FALSE) {
|
||||
warning_(
|
||||
"in `as.av()`: these values could not be coerced to a valid antiviral drug ID: ",
|
||||
"in {.help [{.fun as.av}](AMR::as.av)}: these values could not be coerced to a valid antiviral drug ID: ",
|
||||
vector_and(x_unknown), "."
|
||||
)
|
||||
}
|
||||
|
||||
@@ -162,7 +162,7 @@ av_ddd <- function(x, administration = "oral", ...) {
|
||||
|
||||
if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
|
||||
warning_(
|
||||
"in `av_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"in {.help [{.fun av_ddd}](AMR::av_ddd)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"Please refer to the WHOCC website:\n",
|
||||
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
||||
)
|
||||
@@ -182,7 +182,7 @@ av_ddd_units <- function(x, administration = "oral", ...) {
|
||||
|
||||
if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
|
||||
warning_(
|
||||
"in `av_ddd_units()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"in {.help [{.fun av_ddd_units}](AMR::av_ddd_units)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||
"Please refer to the WHOCC website:\n",
|
||||
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
||||
)
|
||||
|
||||
@@ -448,13 +448,15 @@ first_isolate <- function(x = NULL,
|
||||
if (!is.null(col_keyantimicrobials)) {
|
||||
if (isTRUE(info) && message_not_thrown_before("first_isolate", "type")) {
|
||||
if (type == "keyantimicrobials") {
|
||||
message_("Basing inclusion on key antimicrobials, ",
|
||||
message_(
|
||||
"Basing inclusion on key antimicrobials, ",
|
||||
ifelse(ignore_I == FALSE, "not ", ""),
|
||||
"ignoring I"
|
||||
)
|
||||
}
|
||||
if (type == "points") {
|
||||
message_("Basing inclusion on all antimicrobial results, using a points threshold of ",
|
||||
message_(
|
||||
"Basing inclusion on all antimicrobial results, using a points threshold of ",
|
||||
points_threshold
|
||||
)
|
||||
}
|
||||
|
||||
@@ -661,7 +661,8 @@ interpretive_rules <- function(x,
|
||||
ab <- gsub("-S$", "", ab_s)
|
||||
if (ab %in% names(cols_ab) && !ab_s %in% names(cols_ab)) {
|
||||
if (isTRUE(info)) {
|
||||
message_("Using column '", cols_ab[names(cols_ab) == ab],
|
||||
message_(
|
||||
"Using column '", cols_ab[names(cols_ab) == ab],
|
||||
"' as ", ab_name(ab_s, language = NULL, tolower = TRUE),
|
||||
" since a column '", ab_s, "' is missing but required for the chosen rules"
|
||||
)
|
||||
|
||||
@@ -182,7 +182,7 @@ key_antimicrobials <- function(x = NULL,
|
||||
any(filter, na.rm = TRUE) &&
|
||||
message_not_thrown_before("key_antimicrobials", name)) {
|
||||
warning_(
|
||||
"in `key_antimicrobials()`: ",
|
||||
"in {.help [{.fun key_antimicrobials}](AMR::key_antimicrobials)}: ",
|
||||
ifelse(values_new_length == 0,
|
||||
"No columns available ",
|
||||
paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ")
|
||||
|
||||
4
R/mdro.R
4
R/mdro.R
@@ -1888,8 +1888,8 @@ mdro <- function(x = NULL,
|
||||
if (any(x$MDRO == -1, na.rm = TRUE)) {
|
||||
if (message_not_thrown_before("mdro", "availability")) {
|
||||
warning_(
|
||||
"in `mdro()`: NA introduced for isolates where the available percentage of antimicrobial classes was below ",
|
||||
percentage(pct_required_classes), " (set with `pct_required_classes`)"
|
||||
"in {.help [{.fun mdro}](AMR::mdro)}: NA introduced for isolates where the available percentage of antimicrobial classes was below ",
|
||||
percentage(pct_required_classes), " (set with {.arg pct_required_classes})"
|
||||
)
|
||||
}
|
||||
# set these -1s to NA
|
||||
|
||||
2
R/mic.R
2
R/mic.R
@@ -331,7 +331,7 @@ rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE, r
|
||||
}
|
||||
stop_ifnot(
|
||||
all(mic_range %in% c(VALID_MIC_LEVELS, NA)),
|
||||
"Values in `mic_range` must be valid MIC values. ",
|
||||
"Values in {.arg mic_range} must be valid MIC values. ",
|
||||
"The allowed range is ", format(as.double(as.mic(VALID_MIC_LEVELS)[1]), scientific = FALSE), " to ", format(as.double(as.mic(VALID_MIC_LEVELS)[length(VALID_MIC_LEVELS)]), scientific = FALSE), ". ",
|
||||
"Unvalid: ", vector_and(mic_range[!mic_range %in% c(VALID_MIC_LEVELS, NA)], quotes = FALSE), "."
|
||||
)
|
||||
|
||||
139
R/mo.R
139
R/mo.R
@@ -267,7 +267,7 @@ as.mo <- function(x,
|
||||
if (isTRUE(info) && message_not_thrown_before("as.mo", old, new, entire_session = TRUE) && any(is.na(old) & !is.na(new), na.rm = 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 `mo_reset_session()` to reset this. This note will be shown once per session for this input."
|
||||
" 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."
|
||||
)
|
||||
}
|
||||
|
||||
@@ -407,7 +407,9 @@ as.mo <- function(x,
|
||||
paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"),
|
||||
minimum_matching_score
|
||||
),
|
||||
". Try setting this value lower or even to 0.", call = FALSE)
|
||||
". Try setting this value lower or even to 0.",
|
||||
call = FALSE
|
||||
)
|
||||
result_mo <- NA_character_
|
||||
} else {
|
||||
result_mo <- MO_lookup_current$mo[match(top_hits[1], MO_lookup_current$fullname)]
|
||||
@@ -453,8 +455,8 @@ as.mo <- function(x,
|
||||
if (length(AMR_env$mo_uncertainties$original_input) <= 3) {
|
||||
examples <- vector_and(
|
||||
paste0(
|
||||
'"', AMR_env$mo_uncertainties$original_input,
|
||||
'" (assumed ', italicise(AMR_env$mo_uncertainties$fullname), ")"
|
||||
"{.val ", AMR_env$mo_uncertainties$original_input,
|
||||
"} (assumed ", italicise(AMR_env$mo_uncertainties$fullname), ")"
|
||||
),
|
||||
quotes = FALSE
|
||||
)
|
||||
@@ -463,7 +465,7 @@ as.mo <- function(x,
|
||||
}
|
||||
msg <- c(msg, paste0(
|
||||
"Microorganism translation was uncertain for ", examples,
|
||||
". Run `mo_uncertainties()` to review ", plural[2], ", or use `add_custom_microorganisms()` to add custom entries."
|
||||
". Run {.help [{.fun mo_uncertainties}](AMR::mo_uncertainties)} to review ", plural[2], ", or use {.help [{.fun add_custom_microorganisms}](AMR::add_custom_microorganisms)} to add custom entries."
|
||||
))
|
||||
|
||||
for (m in msg) {
|
||||
@@ -479,11 +481,11 @@ as.mo <- function(x,
|
||||
if (isFALSE(keep_synonyms)) {
|
||||
out[!is.na(out_current)] <- out_current[!is.na(out_current)]
|
||||
if (isTRUE(info) && length(AMR_env$mo_renamed$old) > 0) {
|
||||
print(mo_renamed(), extra_txt = " (use `keep_synonyms = TRUE` to leave uncorrected)")
|
||||
print(mo_renamed(), extra_txt = " (use {.arg keep_synonyms = TRUE} to leave uncorrected)")
|
||||
}
|
||||
} else if (is.null(getOption("AMR_keep_synonyms")) && length(AMR_env$mo_renamed$old) > 0 && message_not_thrown_before("as.mo", "keep_synonyms_warning", entire_session = TRUE)) {
|
||||
# keep synonyms is TRUE, so check if any do have synonyms
|
||||
warning_("{.help [{.fun as.mo}](AMR::as.mo)} returned ", nr2char(length(unique(AMR_env$mo_renamed$old))), " outdated taxonomic name", ifelse(length(unique(AMR_env$mo_renamed$old)) > 1, "s", ""), ". Use ", highlight_code("as.mo(..., keep_synonyms = FALSE)"), " to clean the input to currently accepted taxonomic names, or set the R option {.code AMR_keep_synonyms} to {.code FALSE}. This warning will be shown once per session.", call = FALSE)
|
||||
warning_("{.help [{.fun as.mo}](AMR::as.mo)} returned ", nr2char(length(unique(AMR_env$mo_renamed$old))), " outdated taxonomic name", ifelse(length(unique(AMR_env$mo_renamed$old)) > 1, "s", ""), ". Use {.arg keep_synonyms = FALSE} to clean the input to currently accepted taxonomic names, or set the R option {.code AMR_keep_synonyms} to {.code FALSE}. This warning will be shown once per session.", call = FALSE)
|
||||
}
|
||||
|
||||
# Apply Becker ----
|
||||
@@ -907,14 +909,16 @@ rep.mo <- function(x, ...) {
|
||||
print.mo_uncertainties <- function(x, n = 10, ...) {
|
||||
more_than_50 <- FALSE
|
||||
if (NROW(x) == 0) {
|
||||
cat(font_blue(word_wrap("No uncertainties to show. Only uncertainties of the last call to {.help [{.fun as.mo}](AMR::as.mo)} or any mo_*() function are stored.\n\n")))
|
||||
message_("No uncertainties to show. Only uncertainties of the last call to {.help [{.fun as.mo}](AMR::as.mo)} or any {.help [{.fun mo_*}](AMR::mo_property)} function are stored.")
|
||||
return(invisible(NULL))
|
||||
} else if (NROW(x) > 50) {
|
||||
more_than_50 <- TRUE
|
||||
x <- x[1:50, , drop = FALSE]
|
||||
}
|
||||
|
||||
cat(font_blue(word_wrap("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See {.help [{.fun mo_matching_score}](AMR::mo_matching_score)}.\n\n")))
|
||||
message_("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See {.help [{.fun mo_matching_score}](AMR::mo_matching_score)}.",
|
||||
as_note = FALSE
|
||||
)
|
||||
|
||||
add_MO_lookup_to_AMR_env()
|
||||
|
||||
@@ -924,12 +928,13 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
|
||||
col_green <- function(x) font_green_bg(x, collapse = NULL)
|
||||
|
||||
if (has_colour()) {
|
||||
cat(font_blue(word_wrap("Colour keys: ",
|
||||
cat(word_wrap(
|
||||
"Colour keys: ",
|
||||
col_red(" 0.000-0.549 "),
|
||||
col_orange(" 0.550-0.649 "),
|
||||
col_yellow(" 0.650-0.749 "),
|
||||
col_green(" 0.750-1.000")
|
||||
)), font_green_bg(" "), "\n", sep = "")
|
||||
), font_green_bg(" "), "\n", sep = "")
|
||||
}
|
||||
|
||||
score_set_colour <- function(text, scores) {
|
||||
@@ -960,21 +965,6 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
|
||||
# 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
|
||||
)
|
||||
),
|
||||
extra_indent = nchar("Also matched: "),
|
||||
width = 0.9 * getOption("width", 100)
|
||||
)
|
||||
} else {
|
||||
candidates <- ""
|
||||
}
|
||||
@@ -984,46 +974,54 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
|
||||
n = x[i, ]$fullname
|
||||
)
|
||||
score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3))
|
||||
txt <- paste(txt,
|
||||
|
||||
out <- paste0(
|
||||
paste0(
|
||||
"", strrep(font_grey("-"), times = getOption("width", 100)), "\n",
|
||||
'"', x[i, ]$original_input, '"',
|
||||
" -> ",
|
||||
paste0(
|
||||
"", strrep(font_grey("-"), times = getOption("width", 100)), "\n",
|
||||
'"', x[i, ]$original_input, '"',
|
||||
" -> ",
|
||||
paste0(
|
||||
font_bold(italicise(x[i, ]$fullname)),
|
||||
" (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")"
|
||||
)
|
||||
),
|
||||
collapse = "\n"
|
||||
font_bold(italicise(x[i, ]$fullname)),
|
||||
" (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")"
|
||||
)
|
||||
),
|
||||
ifelse(x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")],
|
||||
paste0(
|
||||
strrep(" ", nchar(x[i, ]$original_input) + 6),
|
||||
ifelse(x[i, ]$keep_synonyms == FALSE,
|
||||
# Add note if result was coerced to accepted taxonomic name
|
||||
font_red(paste0("This outdated taxonomic name was converted to ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL),
|
||||
# Or add note if result is currently another taxonomic name
|
||||
font_red(paste0(font_bold("Note: "), "The current name is ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", AMR_env$MO_lookup$ref[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], ")."), collapse = NULL)
|
||||
)
|
||||
),
|
||||
""
|
||||
),
|
||||
candidates,
|
||||
sep = "\n"
|
||||
collapse = "\n"
|
||||
)
|
||||
txt <- gsub("[\n]+", "\n", txt)
|
||||
# remove first and last break
|
||||
txt <- gsub("(^[\n]|[\n]$)", "", txt)
|
||||
txt <- paste0("\n", txt, "\n")
|
||||
message_(out, as_note = FALSE)
|
||||
|
||||
if (x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")]) {
|
||||
out2 <- paste0(
|
||||
strrep(" ", nchar(x[i, ]$original_input) + 6),
|
||||
ifelse(x[i, ]$keep_synonyms == FALSE,
|
||||
# Add note if result was coerced to accepted taxonomic name
|
||||
font_red(paste0("This outdated taxonomic name was converted to ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL),
|
||||
# Or add note if result is currently another taxonomic name
|
||||
font_red(paste0(font_bold("Note: "), "The current name is ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", AMR_env$MO_lookup$ref[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], ")."), collapse = NULL)
|
||||
)
|
||||
)
|
||||
message_(out2, as_note = FALSE)
|
||||
}
|
||||
|
||||
other_matches <- paste0(
|
||||
"Also matched: ",
|
||||
vector_and(
|
||||
paste0(
|
||||
candidates_formatted,
|
||||
font_blue(paste0(" (", scores_formatted, ")"), collapse = NULL)
|
||||
),
|
||||
quotes = FALSE, sort = FALSE
|
||||
)
|
||||
)
|
||||
message_(other_matches, as_note = FALSE)
|
||||
}
|
||||
|
||||
cat(txt)
|
||||
if (isTRUE(any_maxed_out)) {
|
||||
cat(font_blue(word_wrap("\nOnly the first ", n, " other matches of each record are shown. Run `print(mo_uncertainties(), n = ...)` to view more entries, or save `mo_uncertainties()` to an object.")))
|
||||
cat("\n")
|
||||
message_("Only the first ", n, " other matches of each record are shown. Run {.help [`print(mo_uncertainties(), n = ...)`](AMR::mo_uncertainties)} to view more entries, or save {.help [{.fun mo_uncertainties}](AMR::mo_uncertainties)} to an object.")
|
||||
}
|
||||
if (isTRUE(more_than_50)) {
|
||||
cat(font_blue(word_wrap("\nOnly the first 50 uncertainties are shown. Run `View(mo_uncertainties())` to view all entries, or save `mo_uncertainties()` to an object.")))
|
||||
cat("\n")
|
||||
message_("Only the first 50 uncertainties are shown. Run {.help [`View(mo_uncertainties())`](AMR::mo_uncertainties)} to view all entries, or save {.help [{.fun mo_uncertainties}](AMR::mo_uncertainties)} to an object.")
|
||||
}
|
||||
}
|
||||
|
||||
@@ -1032,7 +1030,7 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
|
||||
#' @noRd
|
||||
print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
|
||||
if (NROW(x) == 0) {
|
||||
cat(font_blue(word_wrap("No renamed taxonomy to show. Only renamed taxonomy of the last call of {.help [{.fun as.mo}](AMR::as.mo)} or any mo_*() function are stored.\n")))
|
||||
message_("No renamed taxonomy to show. Only renamed taxonomy of the last call of {.help [{.fun as.mo}](AMR::as.mo)} or any {.help [{.fun mo_*}](AMR::mo_property)} function are stored.")
|
||||
return(invisible(NULL))
|
||||
}
|
||||
|
||||
@@ -1043,14 +1041,17 @@ print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
|
||||
|
||||
rows <- seq_len(min(NROW(x), n))
|
||||
|
||||
message_(
|
||||
"The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":\n",
|
||||
paste0(" ", AMR_env$bullet_icon, " ", font_italic(x$old[rows], collapse = NULL), x$ref_old[rows],
|
||||
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
|
||||
collapse = "\n"
|
||||
),
|
||||
ifelse(NROW(x) > n, paste0("\n\nOnly the first ", n, " (out of ", NROW(x), ") are shown. Run {.code print(mo_renamed(), n = ...)} to view more entries (might be slow), or save {.fun mo_renamed} to an object."), "")
|
||||
)
|
||||
message_("The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":")
|
||||
old_format <- format(paste0(font_italic(x$old[rows], collapse = NULL), x$ref_old[rows])) # format() will set trailing spaces for textual alignment
|
||||
old_format <- gsub(" ", "\u00a0", old_format, fixed = TRUE)
|
||||
for (old_tax in rows) {
|
||||
message_("\u00a0\u00a0", AMR_env$bullet_icon, " ", old_format[old_tax], " -> ", font_italic(x$new[old_tax]), x$ref_new[old_tax], as_note = FALSE)
|
||||
}
|
||||
if (NROW(x) > n) {
|
||||
message_("\u00a0\u00a0Only the first ", n, " (out of ", NROW(x), ") are shown. Run {.code print(mo_renamed(), n = ...)} to view more entries (might be slow), or save {.fun mo_renamed} to an object.",
|
||||
as_note = FALSE
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
# UNDOCUMENTED HELPER FUNCTIONS -------------------------------------------
|
||||
@@ -1255,14 +1256,14 @@ replace_old_mo_codes <- function(x, property) {
|
||||
}
|
||||
if (property != "mo") {
|
||||
warning_(
|
||||
"in `mo_", property, "()`: the input contained ", n_matched,
|
||||
"in {.help [{.fun mo_", property, "}](AMR::mo_", property, ")}: the input contained ", n_matched,
|
||||
" old MO code", ifelse(n_matched == 1, "", "s"),
|
||||
" (", n_unique, "from a previous AMR package version). ",
|
||||
"Please update your MO codes with `as.mo()` to increase speed."
|
||||
"Please update your MO codes with {.help [{.fun as.mo}](AMR::as.mo)} to increase speed."
|
||||
)
|
||||
} else {
|
||||
warning_(
|
||||
"in `as.mo()`: the input contained ", n_matched,
|
||||
"in {.help [{.fun as.mo}](AMR::as.mo)}: the input contained ", n_matched,
|
||||
" old MO code", ifelse(n_matched == 1, "", "s"),
|
||||
" (", n_unique, "from a previous AMR package version). ",
|
||||
n_solved, " old MO code", ifelse(n_solved == 1, "", "s"),
|
||||
|
||||
@@ -1590,7 +1590,7 @@ expand_SIR_colours <- function(colours_SIR, unname = TRUE) {
|
||||
# named input: match and reorder
|
||||
stop_ifnot(
|
||||
all(names(colours_SIR) %in% sir_order),
|
||||
"Unknown names in `colours_SIR`. Expected any of: ", vector_or(levels(NA_sir_), quotes = FALSE, sort = FALSE), "."
|
||||
"Unknown names in {.arg colours_SIR}. Expected any of: ", vector_or(levels(NA_sir_), quotes = FALSE, sort = FALSE), "."
|
||||
)
|
||||
if (length(colours_SIR) == 4) {
|
||||
# add colours for SI (same as S) and IR (same as R)
|
||||
|
||||
@@ -60,11 +60,6 @@ sir_calc <- function(...,
|
||||
dots <- eval(substitute(alist(...)))
|
||||
stop_if(length(dots) == 0, "no variables selected", call = -2)
|
||||
|
||||
stop_if("also_single_tested" %in% names(dots),
|
||||
"`also_single_tested` was replaced by `only_all_tested`.\n",
|
||||
"Please read Details in the help page (`?proportion`) as this may have a considerable impact on your analysis.",
|
||||
call = -2
|
||||
)
|
||||
ndots <- length(dots)
|
||||
|
||||
if (is.data.frame(dots_df)) {
|
||||
|
||||
@@ -270,7 +270,7 @@ test_that("test-mo.R", {
|
||||
))),
|
||||
c("B_MCRBC_PRXY", "B_STRPT_SUIS", "B_KLBSL_TRRG")
|
||||
)
|
||||
expect_output(print(mo_uncertainties()))
|
||||
|
||||
x <- as.mo("Sta. aur")
|
||||
# many hits
|
||||
expect_output(print(mo_uncertainties()))
|
||||
|
||||
@@ -138,7 +138,6 @@ test_that("test-proportion.R", {
|
||||
expect_error(proportion_I("test", as_percent = "test"))
|
||||
expect_error(proportion_S("test", minimum = "test"))
|
||||
expect_error(proportion_S("test", as_percent = "test"))
|
||||
expect_error(proportion_S("test", also_single_tested = TRUE))
|
||||
|
||||
# check too low amount of isolates
|
||||
expect_identical(
|
||||
|
||||
Reference in New Issue
Block a user