P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2026-03-30 08:15:57 +02:00
Code Releases Activity

fixes

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2026-03-20 15:17:34 +01:00
parent 51f689b069
commit d28671c34d
8 changed files with 94 additions and 92 deletions
Download Patch File Download Diff File Expand all files Collapse all files

25
R/aa_helper_functions.R
View File

@@ -304,7 +304,8 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
if (!is.null(found)) { if (!is.null(found)) {
# this column should contain logicals # this column should contain logicals
if (!is.logical(x[, found, drop = TRUE])) { 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." "}, but this column does not contain {.code TRUE}/{.code FALSE} values and was ignored."
) )
found <- NULL found <- NULL
@@ -407,7 +408,7 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
if (isTRUE(error_on_fail)) { if (isTRUE(error_on_fail)) {
stop_ifnot_installed(pkg) 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 # only allow rstudioapi to be imported if we're in RStudio
return(NULL) 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) # 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, "\\{\\.fun (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "()`"))
msg <- apply_sub(msg, "\\{\\.arg (\\{[^}]+\\}|[^}]+)\\}", 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, "\\{\\.code (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "`"))
msg <- apply_sub(msg, "\\{\\.val (\\{[^}]+\\}|[^}]+)\\}", 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, "\\{\\.field (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0('"', resolve(c), '"'))
msg <- apply_sub(msg, "\\{\\.cls (\\{[^}]+\\}|[^}]+)\\}", 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, "\\{\\.pkg (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
msg <- apply_sub(msg, "\\{\\.strong (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", 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) { msg <- apply_sub(msg, "\\{\\.help ([^}]+)\\}", function(c) {
# Handle [display text](topic) markdown link format: extract just the display text # Handle [display text](topic) markdown link format: extract just the display text
m <- regmatches(c, regexec("^\\[(.*)\\]\\([^)]*\\)$", c))[[1L]] m <- regmatches(c, regexec("^\\[(.*)\\]\\([^)]*\\)$", c))[[1L]]
@@ -483,8 +484,8 @@ cli_to_plain <- function(msg, envir = parent.frame()) {
m <- regmatches(c, regexec("^\\[(.*)\\]\\([^)]*\\)$", c))[[1L]] m <- regmatches(c, regexec("^\\[(.*)\\]\\([^)]*\\)$", c))[[1L]]
if (length(m) >= 2L) m[2L] else paste0("?", resolve(c)) if (length(m) >= 2L) m[2L] else paste0("?", resolve(c))
}) })
msg <- apply_sub(msg, "\\{\\.url (\\{[^}]+\\}|[^}]+)\\}", function(c) 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, "\\{\\.href ([^}]+)\\}", function(c) strsplit(resolve(c), " ", fixed = TRUE)[[1L]][1L])
# bare {variable} or {expression} -> evaluate in caller's environment # bare {variable} or {expression} -> evaluate in caller's environment
while (grepl("\\{[^{}]+\\}", msg)) { while (grepl("\\{[^{}]+\\}", msg)) {

11
R/ab.R
View File

@@ -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)] 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 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)] 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)) { 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_( message_(
"Returning previously coerced ", "Returning ", ifelse(only_one, "a ", ""), "previously coerced ",
ifelse(length(unique(which(x[which(previously_coerced)] %in% x_bak_clean))) > 1, "value for an antimicrobial", "values for various antimicrobials"), ifelse(only_one, "value for an antimicrobial", "values for various antimicrobials"),
". Run `ab_reset_session()` to reset this. This note will be shown once per session." ". Run {.help [{.fun ab_reset_session}](AMR::ab_reset_session)} to reset this. This note will be shown once per session."
) )
} }
@@ -464,6 +465,8 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
} }
# Throw note about uncertainties # 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) { if (isTRUE(info) && length(x_uncertain) > 0 && fast_mode == FALSE) {
x_uncertain <- unique(x_uncertain) x_uncertain <- unique(x_uncertain)
if (message_not_thrown_before("as.ab", "uncertainties", x_bak)) { if (message_not_thrown_before("as.ab", "uncertainties", x_bak)) {

6
R/first_isolate.R
View File

@@ -448,13 +448,15 @@ first_isolate <- function(x = NULL,
if (!is.null(col_keyantimicrobials)) { if (!is.null(col_keyantimicrobials)) {
if (isTRUE(info) && message_not_thrown_before("first_isolate", "type")) { if (isTRUE(info) && message_not_thrown_before("first_isolate", "type")) {
if (type == "keyantimicrobials") { if (type == "keyantimicrobials") {
message_("Basing inclusion on key antimicrobials, ", message_(
"Basing inclusion on key antimicrobials, ",
ifelse(ignore_I == FALSE, "not ", ""), ifelse(ignore_I == FALSE, "not ", ""),
"ignoring I" "ignoring I"
) )
} }
if (type == "points") { 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 points_threshold
) )
} }

3
R/interpretive_rules.R
View File

@@ -661,7 +661,8 @@ interpretive_rules <- function(x,
ab <- gsub("-S$", "", ab_s) ab <- gsub("-S$", "", ab_s)
if (ab %in% names(cols_ab) && !ab_s %in% names(cols_ab)) { if (ab %in% names(cols_ab) && !ab_s %in% names(cols_ab)) {
if (isTRUE(info)) { 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), "' as ", ab_name(ab_s, language = NULL, tolower = TRUE),
" since a column '", ab_s, "' is missing but required for the chosen rules" " since a column '", ab_s, "' is missing but required for the chosen rules"
) )

133
R/mo.R
View File

@@ -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)) { 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_( message_(
"Returning previously coerced value", ifelse(sum(is.na(old) & !is.na(new)) > 1, "s", ""), "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), ")"), paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"),
minimum_matching_score 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_ result_mo <- NA_character_
} else { } else {
result_mo <- MO_lookup_current$mo[match(top_hits[1], MO_lookup_current$fullname)] 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) { if (length(AMR_env$mo_uncertainties$original_input) <= 3) {
examples <- vector_and( examples <- vector_and(
paste0( paste0(
'"', AMR_env$mo_uncertainties$original_input, "{.val ", AMR_env$mo_uncertainties$original_input,
'" (assumed ', italicise(AMR_env$mo_uncertainties$fullname), ")" "} (assumed ", italicise(AMR_env$mo_uncertainties$fullname), ")"
), ),
quotes = FALSE quotes = FALSE
) )
@@ -463,7 +465,7 @@ as.mo <- function(x,
} }
msg <- c(msg, paste0( msg <- c(msg, paste0(
"Microorganism translation was uncertain for ", examples, "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) { for (m in msg) {
@@ -479,11 +481,11 @@ as.mo <- function(x,
if (isFALSE(keep_synonyms)) { if (isFALSE(keep_synonyms)) {
out[!is.na(out_current)] <- out_current[!is.na(out_current)] out[!is.na(out_current)] <- out_current[!is.na(out_current)]
if (isTRUE(info) && length(AMR_env$mo_renamed$old) > 0) { 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)) { } 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 # 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 ---- # Apply Becker ----
@@ -907,14 +909,16 @@ rep.mo <- function(x, ...) {
print.mo_uncertainties <- function(x, n = 10, ...) { print.mo_uncertainties <- function(x, n = 10, ...) {
more_than_50 <- FALSE more_than_50 <- FALSE
if (NROW(x) == 0) { 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)) return(invisible(NULL))
} else if (NROW(x) > 50) { } else if (NROW(x) > 50) {
more_than_50 <- TRUE more_than_50 <- TRUE
x <- x[1:50, , drop = FALSE] 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() 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) col_green <- function(x) font_green_bg(x, collapse = NULL)
if (has_colour()) { if (has_colour()) {
cat(font_blue(word_wrap("Colour keys: ", cat(word_wrap(
"Colour keys: ",
col_red(" 0.000-0.549 "), col_red(" 0.000-0.549 "),
col_orange(" 0.550-0.649 "), col_orange(" 0.550-0.649 "),
col_yellow(" 0.650-0.749 "), col_yellow(" 0.650-0.749 "),
col_green(" 0.750-1.000") col_green(" 0.750-1.000")
)), font_green_bg(" "), "\n", sep = "") ), font_green_bg(" "), "\n", sep = "")
} }
score_set_colour <- function(text, scores) { score_set_colour <- function(text, scores) {
@@ -960,21 +965,6 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
# sort on descending scores # sort on descending scores
candidates_formatted <- candidates_formatted[order(1 - scores)] candidates_formatted <- candidates_formatted[order(1 - scores)]
scores_formatted <- scores_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 { } else {
candidates <- "" candidates <- ""
} }
@@ -984,46 +974,54 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
n = x[i, ]$fullname n = x[i, ]$fullname
) )
score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3)) score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3))
txt <- paste(txt,
out <- paste0(
paste0( paste0(
"", strrep(font_grey("-"), times = getOption("width", 100)), "\n",
'"', x[i, ]$original_input, '"',
" -> ",
paste0( paste0(
"", strrep(font_grey("-"), times = getOption("width", 100)), "\n", font_bold(italicise(x[i, ]$fullname)),
'"', x[i, ]$original_input, '"', " (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")"
" -> ", )
paste0(
font_bold(italicise(x[i, ]$fullname)),
" (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")"
)
),
collapse = "\n"
), ),
ifelse(x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")], collapse = "\n"
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"
) )
txt <- gsub("[\n]+", "\n", txt) message_(out, as_note = FALSE)
# remove first and last break
txt <- gsub("(^[\n]|[\n]$)", "", txt) if (x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")]) {
txt <- paste0("\n", txt, "\n") 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)) { 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)) { 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 #' @noRd
print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) { print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
if (NROW(x) == 0) { 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)) return(invisible(NULL))
} }
@@ -1043,14 +1041,17 @@ print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
rows <- seq_len(min(NROW(x), n)) rows <- seq_len(min(NROW(x), n))
message_( message_("The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":")
"The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":\n", old_format <- format(paste0(font_italic(x$old[rows], collapse = NULL), x$ref_old[rows])) # format() will set trailing spaces for textual alignment
paste0(" ", AMR_env$bullet_icon, " ", font_italic(x$old[rows], collapse = NULL), x$ref_old[rows], old_format <- gsub(" ", "\u00a0", old_format, fixed = TRUE)
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows], for (old_tax in rows) {
collapse = "\n" 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)
), }
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."), "") 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 ------------------------------------------- # UNDOCUMENTED HELPER FUNCTIONS -------------------------------------------

5
R/sir_calc.R
View File

@@ -60,11 +60,6 @@ sir_calc <- function(...,
dots <- eval(substitute(alist(...))) dots <- eval(substitute(alist(...)))
stop_if(length(dots) == 0, "no variables selected", call = -2) 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) ndots <- length(dots)
if (is.data.frame(dots_df)) { if (is.data.frame(dots_df)) {

2
tests/testthat/test-mo.R
View File

@@ -270,7 +270,7 @@ test_that("test-mo.R", {
))), ))),
c("B_MCRBC_PRXY", "B_STRPT_SUIS", "B_KLBSL_TRRG") c("B_MCRBC_PRXY", "B_STRPT_SUIS", "B_KLBSL_TRRG")
) )
expect_output(print(mo_uncertainties()))
x <- as.mo("Sta. aur") x <- as.mo("Sta. aur")
# many hits # many hits
expect_output(print(mo_uncertainties())) expect_output(print(mo_uncertainties()))

1
tests/testthat/test-proportion.R
View File

@@ -138,7 +138,6 @@ test_that("test-proportion.R", {
expect_error(proportion_I("test", as_percent = "test")) expect_error(proportion_I("test", as_percent = "test"))
expect_error(proportion_S("test", minimum = "test")) expect_error(proportion_S("test", minimum = "test"))
expect_error(proportion_S("test", as_percent = "test")) expect_error(proportion_S("test", as_percent = "test"))
expect_error(proportion_S("test", also_single_tested = TRUE))
# check too low amount of isolates # check too low amount of isolates
expect_identical( expect_identical(