P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2026-03-19 07:42:25 +01:00
Code Releases Activity

Modernise messaging infrastructure with cli support

Browse Source 
Rewrites message_(), warning_(), stop_() to use cli::cli_inform(),
cli::cli_warn(), and cli::cli_abort() when the cli package is available,
with a fully functional plain-text fallback for environments without cli.

Key changes:
- New cli_to_plain() helper converts cli inline markup ({.fun}, {.arg},
  {.val}, {.field}, {.cls}, {.pkg}, {.href}, {.url}, etc.) to readable
  plain-text equivalents for the non-cli fallback path
- word_wrap() simplified: drops add_fn, ANSI re-index algorithm, RStudio
  link injection, and operator spacing hack; returns pasted input unchanged
  when cli is available
- stop_() no longer references AMR_env$cli_abort; uses pkg_is_available()
  directly; passes sys.call() objects to cli::cli_abort() call= argument
- Removed add_fn parameter from message_(), warning_(), and word_wrap()
- All call sites across R/ updated: add_fn arguments removed, some paste0-
  based string construction converted to cli glue syntax ({.fun as.mo},
  {.arg col_mo}, {n} results, etc.)
- cli already listed in Suggests; no DESCRIPTION dependency changes needed

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b
This commit is contained in:
Claude
2026-03-18 12:10:17 +00:00
parent 8439e9c1d2
commit ad31fba556
16 changed files with 252 additions and 279 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
DESCRIPTION
View File

@@ -1,5 +1,5 @@
Package: AMR Package: AMR
Version: 3.0.1.9035 Version: 3.0.1.9036
Date: 2026-03-18 Date: 2026-03-18
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)

8
NEWS.md
View File

@@ -1,3 +1,11 @@
# AMR 3.0.1.9036
### Updates
* Modernised messaging infrastructure: `message_()`, `warning_()`, and `stop_()` now use `cli` for rich formatting (colours, inline markup, hyperlinks) when the `cli` package is installed, with a fully functional plain-text fallback when `cli` is absent
* Removed `add_fn` parameter from `message_()`, `warning_()`, and `word_wrap()` — styling is now handled by `cli` markup or dropped from the plain-text path
* New internal helper `cli_to_plain()` converts cli inline markup (`{.fun}`, `{.arg}`, `{.val}`, etc.) to plain-text equivalents for the non-cli fallback path
* Call sites across all R source files updated from `paste0()`-based string construction to cli glue syntax (e.g. `{.fun as.mo}`, `{.arg col_mo}`, `{n} results`)
# AMR 3.0.1.9035 # AMR 3.0.1.9035
### New ### New

261
R/aa_helper_functions.R
View File

@@ -305,8 +305,7 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
# 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 `", ifelse(add_col_prefix, "col_", ""), type, message_("Column '", font_bold(found), "' found as input for `", ifelse(add_col_prefix, "col_", ""), type,
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.", "`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored."
add_fn = font_red
) )
found <- NULL found <- NULL
} }
@@ -398,7 +397,7 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
error = function(e) { error = function(e) {
if (isTRUE(error_on_fail)) { if (isTRUE(error_on_fail)) {
stop_("function `", name, "()` is not an exported object from package '", pkg, stop_("function `", name, "()` is not an exported object from package '", pkg,
"'. Please create an issue at ", font_url("https://github.com/msberends/AMR/issues"), ". Many thanks!", "'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
call = FALSE call = FALSE
) )
} else { } else {
@@ -408,30 +407,99 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
) )
} }
# Convert cli glue markup to plain text for the non-cli fallback path.
# Called by message_(), warning_(), and stop_() when cli is not available.
cli_to_plain <- function(msg, envir = parent.frame()) {
resolve <- function(x) {
# If x looks like {expr}, evaluate the inner expression
if (grepl("^\\{.+\\}$", x)) {
inner <- substring(x, 2L, nchar(x) - 1L)
tryCatch(
paste0(as.character(eval(parse(text = inner), envir = envir)), collapse = ", "),
error = function(e) x
)
} else {
x
}
}
apply_sub <- function(msg, pattern, formatter) {
while (grepl(pattern, msg, perl = TRUE)) {
m <- regexec(pattern, msg, perl = TRUE)
matches <- regmatches(msg, m)[[1]]
if (length(matches) < 2L) break
full_match <- matches[1L]
content <- matches[2L]
replacement <- formatter(content)
idx <- regexpr(full_match, msg, fixed = TRUE)
if (idx == -1L) break
msg <- paste0(
substr(msg, 1L, idx - 1L),
replacement,
substr(msg, idx + nchar(full_match), nchar(msg))
)
}
msg
}
# 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, "\\{\\.strong (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
msg <- apply_sub(msg, "\\{\\.emph (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
msg <- apply_sub(msg, "\\{\\.help (\\{[^}]+\\}|[^}]+)\\}", function(c) 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])
# bare {variable} or {expression} -> evaluate in caller's environment
while (grepl("\\{[^{}]+\\}", msg)) {
m <- regexec("\\{([^{}]+)\\}", msg, perl = TRUE)
matches <- regmatches(msg, m)[[1]]
if (length(matches) < 2L) break
full_match <- matches[1L]
inner <- matches[2L]
replacement <- tryCatch(
paste0(as.character(eval(parse(text = inner), envir = envir)), collapse = ", "),
error = function(e) full_match
)
idx <- regexpr(full_match, msg, fixed = TRUE)
if (idx == -1L) break
msg <- paste0(
substr(msg, 1L, idx - 1L),
replacement,
substr(msg, idx + nchar(full_match), nchar(msg))
)
}
msg
}
# this alternative wrapper to the message(), warning() and stop() functions: # this alternative wrapper to the message(), warning() and stop() functions:
# - wraps text to never break lines within words # - wraps text to never break lines within words (plain-text fallback only)
# - ignores formatted text while wrapping # - adds indentation for note-style messages (plain-text fallback only)
# - adds indentation dependent on the type of message (such as NOTE) # When cli is available this just returns the pasted input; cli handles formatting.
# - can add additional formatting functions like blue or bold text
word_wrap <- function(..., word_wrap <- function(...,
add_fn = list(),
as_note = FALSE, as_note = FALSE,
width = 0.95 * getOption("width"), width = 0.95 * getOption("width"),
extra_indent = 0) { extra_indent = 0) {
if (pkg_is_available("cli")) {
return(paste0(c(...), collapse = ""))
}
msg <- paste0(c(...), collapse = "") msg <- paste0(c(...), collapse = "")
if (isTRUE(as_note)) { if (isTRUE(as_note)) {
msg <- paste0(AMR_env$info_icon, " ", gsub("^note:? ?", "", msg, ignore.case = TRUE)) msg <- paste0(AMR_env$info_icon, " ", gsub("^note:? ?", "", msg, ignore.case = TRUE))
} }
if (grepl("\n", msg, fixed = TRUE)) {
if (msg %like% "\n") {
# run word_wraps() over every line here, bind them and return again
return(paste0( return(paste0(
vapply( vapply(
FUN.VALUE = character(1), FUN.VALUE = character(1),
trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"), trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"),
word_wrap, word_wrap,
add_fn = add_fn,
as_note = FALSE, as_note = FALSE,
width = width, width = width,
extra_indent = extra_indent extra_indent = extra_indent
@@ -439,146 +507,75 @@ word_wrap <- function(...,
collapse = "\n" collapse = "\n"
)) ))
} }
wrapped <- paste0(strwrap(msg, width = width), collapse = "\n")
# correct for operators (will add the space later on) if (grepl("\u2139 ", msg, fixed = TRUE)) {
ops <- "([,./><\\]\\[])" indentation <- 2L + extra_indent
msg <- gsub(paste0(ops, " ", ops), "\\1\\2", msg, perl = TRUE) } else if (grepl("^=> ", msg)) {
# we need to correct for already applied style, that adds text like "\033[31m\" indentation <- 3L + extra_indent
msg_stripped <- gsub("(.*)?\\033\\]8;;.*\\a(.*?)\\033\\]8;;\\a(.*)", "\\1\\2\\3", msg, perl = TRUE) # for font_url()
msg_stripped <- font_stripstyle(msg_stripped)
# where are the spaces now?
msg_stripped_wrapped <- paste0(
strwrap(msg_stripped,
simplify = TRUE,
width = width
),
collapse = "\n"
)
msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")),
collapse = "\n"
)
msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "", fixed = TRUE)) == " ")
msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "", fixed = TRUE)) != "\n")
# so these are the indices of spaces that need to be replaced
replace_spaces <- which(!msg_stripped_spaces %in% msg_stripped_wrapped_spaces)
# put it together
msg <- unlist(strsplit(msg, " ", fixed = TRUE))
msg[replace_spaces] <- paste0(msg[replace_spaces], "\n")
# add space around operators again
msg <- gsub(paste0(ops, ops), "\\1 \\2", msg, perl = TRUE)
msg <- paste0(msg, collapse = " ")
msg <- gsub("\n ", "\n", msg, fixed = TRUE)
if (msg_stripped %like% "\u2139 ") {
indentation <- 2 + extra_indent
} else if (msg_stripped %like% "^=> ") {
indentation <- 3 + extra_indent
} else { } else {
indentation <- 0 + extra_indent indentation <- 0L + extra_indent
} }
msg <- gsub("\n", paste0("\n", strrep(" ", indentation)), msg, fixed = TRUE) if (indentation > 0L) {
# remove trailing empty characters wrapped <- gsub("\n", paste0("\n", strrep(" ", indentation)), wrapped, fixed = TRUE)
msg <- gsub("(\n| )+$", "", msg)
if (length(add_fn) > 0) {
if (!is.list(add_fn)) {
add_fn <- list(add_fn)
}
for (i in seq_len(length(add_fn))) {
msg <- add_fn[[i]](msg)
}
} }
gsub("(\n| )+$", "", wrapped)
# format backticks
if (pkg_is_available("cli") && in_rstudio() &&
tryCatch(getExportedValue("versionInfo", ns = asNamespace("rstudioapi"))()$version > "2023.6.0.0", error = function(e) {
return(FALSE)
})) {
# we are in a recent version of RStudio, so do something nice: add links to our help pages in the console.
parts <- strsplit(msg, "`", fixed = TRUE)[[1]]
cmds <- parts %in% paste0(ls(envir = asNamespace("AMR")), "()")
# functions with a dot are not allowed: https://github.com/rstudio/rstudio/issues/11273#issuecomment-1156193252
# lead them to the help page of our package
parts[cmds & parts %like% "[.]"] <- font_url(
url = paste0("ide:help:AMR::", gsub("()", "", parts[cmds & parts %like% "[.]"], fixed = TRUE)),
txt = parts[cmds & parts %like% "[.]"]
)
# datasets should give help page as well
parts[parts %in% c("antimicrobials", "microorganisms", "microorganisms.codes", "microorganisms.groups")] <- font_url(
url = paste0("ide:help:AMR::", gsub("()", "", parts[parts %in% c("antimicrobials", "microorganisms", "microorganisms.codes", "microorganisms.groups")], fixed = TRUE)),
txt = parts[parts %in% c("antimicrobials", "microorganisms", "microorganisms.codes", "microorganisms.groups")]
)
# text starting with `?` must also lead to the help page
parts[parts %like% "^[?].+"] <- font_url(
url = paste0("ide:help:AMR::", gsub("?", "", parts[parts %like% "^[?].+"], fixed = TRUE)),
txt = parts[parts %like% "^[?].+"]
)
msg <- paste0(parts, collapse = "`")
}
# msg <- gsub("`(.+?)`", font_grey_bg("`\\1`"), msg)
# clean introduced whitespace in between fullstops
msg <- gsub("[.] +[.]", "..", msg)
# remove extra space that was introduced (e.g. "Smith et al. , 2022")
msg <- gsub(". ,", ".,", msg, fixed = TRUE)
msg <- gsub("[ ,", "[,", msg, fixed = TRUE)
msg <- gsub("/ /", "//", msg, fixed = TRUE)
msg
} }
message_ <- function(..., message_ <- function(...,
appendLF = TRUE, appendLF = TRUE,
add_fn = list(font_blue),
as_note = TRUE) { as_note = TRUE) {
message( if (pkg_is_available("cli")) {
word_wrap(..., msg <- paste0(c(...), collapse = "")
add_fn = add_fn, if (isTRUE(as_note)) {
as_note = as_note cli::cli_inform(c("i" = msg), .envir = parent.frame())
), } else {
appendLF = appendLF cli::cli_inform(msg, .envir = parent.frame())
) }
} else {
plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
message(word_wrap(plain_msg, as_note = as_note), appendLF = appendLF)
}
} }
warning_ <- function(..., warning_ <- function(...,
add_fn = list(),
immediate = FALSE, immediate = FALSE,
call = FALSE) { call = FALSE) {
warning( if (pkg_is_available("cli")) {
trimws2(word_wrap(..., msg <- paste0(c(...), collapse = "")
add_fn = add_fn, cli::cli_warn(msg, .envir = parent.frame())
as_note = FALSE } else {
)), plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
immediate. = immediate, warning(trimws2(word_wrap(plain_msg, as_note = FALSE)), immediate. = immediate, call. = call)
call. = call }
)
} }
# this alternative to the stop() function: # this alternative to the stop() function:
# - adds the function name where the error was thrown # - adds the function name where the error was thrown (plain-text fallback)
# - wraps text to never break lines within words # - wraps text to never break lines within words (plain-text fallback)
stop_ <- function(..., call = TRUE) { stop_ <- function(..., call = TRUE) {
msg <- paste0(c(...), collapse = "") msg <- paste0(c(...), collapse = "")
msg_call <- "" if (pkg_is_available("cli")) {
if (!isFALSE(call)) {
if (isTRUE(call)) { if (isTRUE(call)) {
call <- as.character(sys.call(-1)[1]) call_obj <- sys.call(-1)
} else if (!isFALSE(call)) {
call_obj <- sys.call(call)
} else { } else {
# so you can go back more than 1 call, as used in sir_calc(), that now throws a reference to e.g. n_sir() call_obj <- NULL
call <- as.character(sys.call(call)[1])
} }
msg_call <- paste0("in ", call, "():") cli::cli_abort(msg, call = call_obj, .envir = parent.frame())
}
msg <- trimws2(word_wrap(msg, add_fn = list(), as_note = FALSE))
if (!is.null(AMR_env$cli_abort) && length(unlist(strsplit(msg, "\n", fixed = TRUE))) <= 1) {
if (is.character(call)) {
call <- as.call(str2lang(paste0(call, "()")))
} else {
call <- NULL
}
AMR_env$cli_abort(msg, call = call)
} else { } else {
stop(paste(msg_call, msg), call. = FALSE) msg_call <- ""
if (!isFALSE(call)) {
if (isTRUE(call)) {
call_name <- as.character(sys.call(-1)[1])
} else {
# go back more than 1 call, as used in sir_calc() to reference e.g. n_sir()
call_name <- as.character(sys.call(call)[1])
}
msg_call <- paste0("in ", call_name, "():")
}
plain_msg <- cli_to_plain(trimws2(word_wrap(msg, as_note = FALSE)), envir = parent.frame())
stop(paste(msg_call, plain_msg), call. = FALSE)
} }
} }
@@ -621,7 +618,7 @@ stop_ifnot <- function(expr, ..., call = TRUE) {
return_after_integrity_check <- function(value, type, check_vector) { return_after_integrity_check <- function(value, type, check_vector) {
if (!all(value[!is.na(value)] %in% check_vector)) { if (!all(value[!is.na(value)] %in% check_vector)) {
warning_(paste0("invalid ", type, ", NA generated")) warning_("invalid ", type, ", NA generated")
value[!value %in% check_vector] <- NA value[!value %in% check_vector] <- NA
} }
value value

18
R/antibiogram.R
View File

@@ -445,7 +445,7 @@ antibiogram.default <- function(x,
meet_criteria(wisca, allow_class = "logical", has_length = 1) meet_criteria(wisca, allow_class = "logical", has_length = 1)
if (isTRUE(wisca)) { if (isTRUE(wisca)) {
if (!is.null(mo_transform) && !missing(mo_transform)) { if (!is.null(mo_transform) && !missing(mo_transform)) {
warning_("WISCA must be based on the species level as WISCA parameters are based on this. For that reason, `mo_transform` will be ignored.") warning_("WISCA must be based on the species level as WISCA parameters are based on this. For that reason, {.arg mo_transform} will be ignored.")
} }
mo_transform <- function(x) suppressMessages(suppressWarnings(paste(mo_genus(x, keep_synonyms = TRUE, language = NULL), mo_species(x, keep_synonyms = TRUE, language = NULL)))) mo_transform <- function(x) suppressMessages(suppressWarnings(paste(mo_genus(x, keep_synonyms = TRUE, language = NULL), mo_species(x, keep_synonyms = TRUE, language = NULL))))
} }
@@ -482,7 +482,7 @@ antibiogram.default <- function(x,
# try to find columns based on type # try to find columns based on type
if (is.null(col_mo)) { if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = info) col_mo <- search_type_in_df(x = x, type = "mo", info = info)
stop_if(is.null(col_mo), "`col_mo` must be set") stop_if(is.null(col_mo), "{.arg col_mo} must be set")
} }
# transform MOs # transform MOs
x$`.mo` <- x[, col_mo, drop = TRUE] x$`.mo` <- x[, col_mo, drop = TRUE]
@@ -523,7 +523,7 @@ antibiogram.default <- function(x,
ab_trycatch <- tryCatch(colnames(dplyr::select(x, {{ antimicrobials }})), error = function(e) NULL) ab_trycatch <- tryCatch(colnames(dplyr::select(x, {{ antimicrobials }})), error = function(e) NULL)
} }
if (is.null(ab_trycatch)) { if (is.null(ab_trycatch)) {
stop_ifnot(is.character(suppressMessages(antimicrobials)), "`antimicrobials` must be an antimicrobial selector, or a character vector.") stop_ifnot(is.character(suppressMessages(antimicrobials)), "{.arg antimicrobials} must be an antimicrobial selector, or a character vector.")
antimicrobials.bak <- antimicrobials antimicrobials.bak <- antimicrobials
# split antimicrobials on separator and make it a list # split antimicrobials on separator and make it a list
antimicrobials <- strsplit(gsub(" ", "", antimicrobials), "+", fixed = TRUE) antimicrobials <- strsplit(gsub(" ", "", antimicrobials), "+", fixed = TRUE)
@@ -619,7 +619,7 @@ antibiogram.default <- function(x,
out$n_susceptible <- out$n_susceptible + out$I + out$SDD out$n_susceptible <- out$n_susceptible + out$I + out$SDD
} }
if (all(out$n_tested < minimum, na.rm = TRUE) && wisca == FALSE) { if (all(out$n_tested < minimum, na.rm = TRUE) && wisca == FALSE) {
warning_("All combinations had less than `minimum = ", minimum, "` results, returning an empty antibiogram") warning_("All combinations had less than {.arg minimum} = {minimum} results, returning an empty antibiogram")
return(as_original_data_class(data.frame(), class(x), extra_class = "antibiogram")) return(as_original_data_class(data.frame(), class(x), extra_class = "antibiogram"))
} else if (any(out$n_tested < minimum, na.rm = TRUE)) { } else if (any(out$n_tested < minimum, na.rm = TRUE)) {
mins <- sum(out$n_tested < minimum, na.rm = TRUE) mins <- sum(out$n_tested < minimum, na.rm = TRUE)
@@ -627,7 +627,7 @@ antibiogram.default <- function(x,
out <- out %pm>% out <- out %pm>%
subset(n_tested >= minimum) subset(n_tested >= minimum)
if (isTRUE(info) && mins > 0) { if (isTRUE(info) && mins > 0) {
message_("NOTE: ", mins, " combinations had less than `minimum = ", minimum, "` results and were ignored", add_fn = font_red) message_("NOTE: {mins} combinations had less than {.arg minimum} = {minimum} results and were ignored")
} }
} }
} }
@@ -812,7 +812,7 @@ antibiogram.default <- function(x,
# 21. 5 (4-6,N=15/300) # 21. 5 (4-6,N=15/300)
# 22. 5% (4-6%,N=15/300) # 22. 5% (4-6%,N=15/300)
if (wisca == TRUE && !formatting_type %in% c(1, 2, 13, 14) && info == TRUE && message_not_thrown_before("antibiogram", wisca, formatting_type)) { if (wisca == TRUE && !formatting_type %in% c(1, 2, 13, 14) && info == TRUE && message_not_thrown_before("antibiogram", wisca, formatting_type)) {
message_("Using WISCA with a `formatting_type` that includes the denominator is not useful") message_("Using WISCA with a {.arg formatting_type} that includes the denominator is not useful")
} }
out$digits <- digits # since pm_sumarise() cannot work with an object outside the current frame out$digits <- digits # since pm_sumarise() cannot work with an object outside the current frame
if (formatting_type == 1) out <- out %pm>% pm_summarise(out_value = round(coverage * 100, digits = digits)) if (formatting_type == 1) out <- out %pm>% pm_summarise(out_value = round(coverage * 100, digits = digits))
@@ -998,8 +998,8 @@ antibiogram.grouped_df <- function(x,
interval_side = "two-tailed", interval_side = "two-tailed",
info = interactive(), info = interactive(),
...) { ...) {
stop_ifnot(is.null(mo_transform), "`mo_transform` must not be set if creating an antibiogram using a grouped tibble. The groups will become the variables over which the antimicrobials are calculated, which could include the pathogen information (though not necessary). Nonetheless, this makes `mo_transform` redundant.", call = FALSE) stop_ifnot(is.null(mo_transform), "{.arg mo_transform} must not be set if creating an antibiogram using a grouped tibble. The groups will become the variables over which the antimicrobials are calculated, which could include the pathogen information (though not necessary). Nonetheless, this makes {.arg mo_transform} redundant.", call = FALSE)
stop_ifnot(is.null(syndromic_group), "`syndromic_group` must not be set if creating an antibiogram using a grouped tibble. The groups will become the variables over which the antimicrobials are calculated, making `syndromic_groups` redundant.", call = FALSE) stop_ifnot(is.null(syndromic_group), "{.arg syndromic_group} must not be set if creating an antibiogram using a grouped tibble. The groups will become the variables over which the antimicrobials are calculated, making {.arg syndromic_group} redundant.", call = FALSE)
groups <- attributes(x)$groups groups <- attributes(x)$groups
n_groups <- NROW(groups) n_groups <- NROW(groups)
progress <- progress_ticker( progress <- progress_ticker(
@@ -1198,7 +1198,7 @@ simulate_coverage <- function(params) {
#' @param wisca_model The outcome of [wisca()] or [`antibiogram(..., wisca = TRUE)`][antibiogram()]. #' @param wisca_model The outcome of [wisca()] or [`antibiogram(..., wisca = TRUE)`][antibiogram()].
#' @rdname antibiogram #' @rdname antibiogram
retrieve_wisca_parameters <- function(wisca_model, ...) { retrieve_wisca_parameters <- function(wisca_model, ...) {
stop_ifnot(isTRUE(attributes(wisca_model)$wisca), "This function only applies to WISCA models. Use `wisca()` or `antibiogram(..., wisca = TRUE)` to create a WISCA model.") stop_ifnot(isTRUE(attributes(wisca_model)$wisca), "This function only applies to WISCA models. Use {.fun wisca} or {.fun antibiogram} (with {.code wisca = TRUE}) to create a WISCA model.")
attributes(wisca_model)$wisca_parameters attributes(wisca_model)$wisca_parameters
} }

3
R/atc_online.R
View File

@@ -105,7 +105,6 @@ atc_online_property <- function(atc_code,
if (!has_internet()) { if (!has_internet()) {
message_("There appears to be no internet connection, returning NA.", message_("There appears to be no internet connection, returning NA.",
add_fn = font_red,
as_note = FALSE as_note = FALSE
) )
return(rep(NA, length(atc_code))) return(rep(NA, length(atc_code)))
@@ -181,7 +180,7 @@ atc_online_property <- function(atc_code,
colnames(out) <- gsub("^atc.*", "atc", tolower(colnames(out))) colnames(out) <- gsub("^atc.*", "atc", tolower(colnames(out)))
if (length(out) == 0) { if (length(out) == 0) {
message_("in `atc_online_property()`: no properties found for ATC ", atc_code[i], ". Please check ", font_url(atc_url, "this WHOCC webpage"), ".") message_("in {.fun atc_online_property}: no properties found for ATC ", atc_code[i], ". Please check {.href {atc_url} this WHOCC webpage}.")
returnvalue[i] <- NA returnvalue[i] <- NA
next next
} }

17
R/custom_mdro_guideline.R
View File

@@ -145,15 +145,15 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
) )
stop_if( stop_if(
identical(dots, "error"), identical(dots, "error"),
"rules must be a valid formula inputs (e.g., using '~'), see `?mdro`" "rules must be a valid formula inputs (e.g., using '~'), see {.fun mdro}"
) )
n_dots <- length(dots) n_dots <- length(dots)
stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using `?mdro`.") stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using {.fun mdro}.")
out <- vector("list", n_dots) out <- vector("list", n_dots)
for (i in seq_len(n_dots)) { for (i in seq_len(n_dots)) {
stop_ifnot( stop_ifnot(
inherits(dots[[i]], "formula"), inherits(dots[[i]], "formula"),
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?mdro`" "rule ", i, " must be a valid formula input (e.g., using '~'), see {.fun mdro}"
) )
# Query # Query
@@ -202,7 +202,7 @@ c.custom_mdro_guideline <- function(x, ..., as_factor = NULL) {
} }
for (g in list(...)) { for (g in list(...)) {
stop_ifnot(inherits(g, "custom_mdro_guideline"), stop_ifnot(inherits(g, "custom_mdro_guideline"),
"for combining custom MDRO guidelines, all rules must be created with `custom_mdro_guideline()`", "for combining custom MDRO guidelines, all rules must be created with {.fun custom_mdro_guideline}",
call = FALSE call = FALSE
) )
vals <- attributes(x)$values vals <- attributes(x)$values
@@ -259,16 +259,15 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
} }
) )
if (identical(qry, "error")) { if (identical(qry, "error")) {
warning_("in `custom_mdro_guideline()`: rule ", i, warning_("in {.fun custom_mdro_guideline}: rule ", i,
" (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ", " (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
AMR_env$err_msg, AMR_env$err_msg,
call = FALSE, call = FALSE
add_fn = font_red
) )
next next
} }
stop_ifnot(is.logical(qry), "in custom_mdro_guideline(): rule ", i, " (`", guideline[[i]]$query, stop_ifnot(is.logical(qry), "in {.fun custom_mdro_guideline}: rule ", i, " (`", guideline[[i]]$query,
"`) must return `TRUE` or `FALSE`, not ", "`) must return {.code TRUE} or {.code FALSE}, not ",
format_class(class(qry), plural = FALSE), format_class(class(qry), plural = FALSE),
call = FALSE call = FALSE
) )

50
R/first_isolate.R
View File

@@ -263,8 +263,7 @@ first_isolate <- function(x = NULL,
), ),
"" ""
) )
), )
add_fn = font_red
) )
} }
@@ -272,7 +271,7 @@ first_isolate <- function(x = NULL,
# -- mo # -- mo
if (is.null(col_mo)) { if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = info) col_mo <- search_type_in_df(x = x, type = "mo", info = info)
stop_if(is.null(col_mo), "`col_mo` must be set") stop_if(is.null(col_mo), "{.arg col_mo} must be set")
} }
# methods ---- # methods ----
@@ -309,7 +308,7 @@ first_isolate <- function(x = NULL,
# -- date # -- date
if (is.null(col_date)) { if (is.null(col_date)) {
col_date <- search_type_in_df(x = x, type = "date", info = info) col_date <- search_type_in_df(x = x, type = "date", info = info)
stop_if(is.null(col_date), "`col_date` must be set") stop_if(is.null(col_date), "{.arg col_date} must be set")
} }
# -- patient id # -- patient id
@@ -318,11 +317,11 @@ first_isolate <- function(x = NULL,
# WHONET support # WHONET support
x$patient_id <- paste(x$`First name`, x$`Last name`, x$Sex) x$patient_id <- paste(x$`First name`, x$`Last name`, x$Sex)
col_patient_id <- "patient_id" col_patient_id <- "patient_id"
message_("Using combined columns '", font_bold("First name"), "', '", font_bold("Last name"), "' and '", font_bold("Sex"), "' as input for `col_patient_id`") message_("Using combined columns '", font_bold("First name"), "', '", font_bold("Last name"), "' and '", font_bold("Sex"), "' as input for {.arg col_patient_id}")
} else { } else {
col_patient_id <- search_type_in_df(x = x, type = "patient_id", info = info) col_patient_id <- search_type_in_df(x = x, type = "patient_id", info = info)
} }
stop_if(is.null(col_patient_id), "`col_patient_id` must be set") stop_if(is.null(col_patient_id), "{.arg col_patient_id} must be set")
} }
# -- specimen # -- specimen
@@ -334,7 +333,7 @@ first_isolate <- function(x = NULL,
check_columns_existance <- function(column, tblname = x) { check_columns_existance <- function(column, tblname = x) {
if (!is.null(column)) { if (!is.null(column)) {
stop_ifnot(column %in% colnames(tblname), stop_ifnot(column %in% colnames(tblname),
"Column '", column, "' not found.", "Column '{column}' not found.",
call = FALSE call = FALSE
) )
} }
@@ -363,9 +362,7 @@ first_isolate <- function(x = NULL,
} }
# remove testcodes # remove testcodes
if (!is.null(testcodes_exclude) && isTRUE(info) && message_not_thrown_before("first_isolate", "excludingtestcodes")) { if (!is.null(testcodes_exclude) && isTRUE(info) && message_not_thrown_before("first_isolate", "excludingtestcodes")) {
message_("Excluding test codes: ", vector_and(testcodes_exclude, quotes = TRUE), message_("Excluding test codes: ", vector_and(testcodes_exclude, quotes = TRUE))
add_fn = font_red
)
} }
if (is.null(col_specimen)) { if (is.null(col_specimen)) {
@@ -376,9 +373,7 @@ first_isolate <- function(x = NULL,
if (!is.null(specimen_group)) { if (!is.null(specimen_group)) {
check_columns_existance(col_specimen, x) check_columns_existance(col_specimen, x)
if (isTRUE(info) && message_not_thrown_before("first_isolate", "excludingspecimen")) { if (isTRUE(info) && message_not_thrown_before("first_isolate", "excludingspecimen")) {
message_("Excluding other than specimen group '", specimen_group, "'", message_("Excluding other than specimen group '{specimen_group}'")
add_fn = font_red
)
} }
} }
if (!is.null(col_keyantimicrobials)) { if (!is.null(col_keyantimicrobials)) {
@@ -420,7 +415,6 @@ first_isolate <- function(x = NULL,
if (abs(row.start) == Inf || abs(row.end) == Inf) { if (abs(row.start) == Inf || abs(row.end) == Inf) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_("=> Found ", font_bold("no isolates"), message_("=> Found ", font_bold("no isolates"),
add_fn = font_black,
as_note = FALSE as_note = FALSE
) )
} }
@@ -429,7 +423,6 @@ first_isolate <- function(x = NULL,
if (row.start == row.end) { if (row.start == row.end) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_("=> Found ", font_bold("1 first isolate"), ", as the data only contained 1 row", message_("=> Found ", font_bold("1 first isolate"), ", as the data only contained 1 row",
add_fn = font_black,
as_note = FALSE as_note = FALSE
) )
} }
@@ -437,9 +430,7 @@ first_isolate <- function(x = NULL,
} }
if (length(c(row.start:row.end)) == pm_n_distinct(x[c(row.start:row.end), col_mo, drop = TRUE])) { if (length(c(row.start:row.end)) == pm_n_distinct(x[c(row.start:row.end), col_mo, drop = TRUE])) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_("=> Found ", font_bold(paste(length(c(row.start:row.end)), "first isolates")), message_("=> Found {.strong {length(c(row.start:row.end))} first isolates}, as all isolates were different microbial species",
", as all isolates were different microbial species",
add_fn = font_black,
as_note = FALSE as_note = FALSE
) )
} }
@@ -458,14 +449,12 @@ first_isolate <- function(x = NULL,
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"
add_fn = font_red
) )
} }
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
add_fn = font_red
) )
} }
} }
@@ -524,9 +513,7 @@ first_isolate <- function(x = NULL,
if (any(!is.na(x$newvar_is_icu)) && any(x$newvar_is_icu == TRUE, na.rm = TRUE)) { if (any(!is.na(x$newvar_is_icu)) && any(x$newvar_is_icu == TRUE, na.rm = TRUE)) {
if (icu_exclude == TRUE) { if (icu_exclude == TRUE) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_("Excluding ", format(sum(x$newvar_is_icu, na.rm = TRUE), decimal.mark = decimal.mark, big.mark = big.mark), " isolates from ICU.", message_("Excluding ", format(sum(x$newvar_is_icu, na.rm = TRUE), decimal.mark = decimal.mark, big.mark = big.mark), " isolates from ICU.")
add_fn = font_red
)
} }
x[which(x$newvar_is_icu), "newvar_first_isolate"] <- FALSE x[which(x$newvar_is_icu), "newvar_first_isolate"] <- FALSE
} else if (isTRUE(info)) { } else if (isTRUE(info)) {
@@ -550,9 +537,8 @@ first_isolate <- function(x = NULL,
paste0('"', x, '"') paste0('"', x, '"')
} }
}) })
message_("\nGroup: ", paste0(names(group), " = ", group, collapse = ", "), "\n", message_("\nGroup: {toString(paste0(names(group), ' = ', group))}\n",
as_note = FALSE, as_note = FALSE
add_fn = font_red
) )
} }
} }
@@ -565,8 +551,7 @@ first_isolate <- function(x = NULL,
format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE), format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark decimal.mark = decimal.mark, big.mark = big.mark
), ),
" isolates with a microbial ID 'UNKNOWN' (in column '", font_bold(col_mo), "')", " isolates with a microbial ID 'UNKNOWN' (in column '", font_bold(col_mo), "')"
add_fn = font_red
) )
} }
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
@@ -577,8 +562,7 @@ first_isolate <- function(x = NULL,
"Excluding ", format(sum(is.na(x$newvar_mo), na.rm = TRUE), "Excluding ", format(sum(is.na(x$newvar_mo), na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark decimal.mark = decimal.mark, big.mark = big.mark
), ),
" isolates with a microbial ID `NA` (in column '", font_bold(col_mo), "')", " isolates with a microbial ID `NA` (in column '", font_bold(col_mo), "')"
add_fn = font_red
) )
} }
x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE
@@ -624,7 +608,7 @@ first_isolate <- function(x = NULL,
), ),
p_found_total, " of total where a microbial ID was available)" p_found_total, " of total where a microbial ID was available)"
), ),
add_fn = font_black, as_note = FALSE as_note = FALSE
) )
} }

14
R/guess_ab_col.R
View File

@@ -79,7 +79,6 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_s
if (isTRUE(verbose)) { if (isTRUE(verbose)) {
message_("No column found as input for ", search_string, message_("No column found as input for ", search_string,
" (", ab_name(search_string, language = NULL, tolower = TRUE), ").", " (", ab_name(search_string, language = NULL, tolower = TRUE), ").",
add_fn = font_black,
as_note = FALSE as_note = FALSE
) )
} }
@@ -211,7 +210,7 @@ get_column_abx <- function(x,
newnames <- suppressWarnings(as.ab(names(dots), info = FALSE)) newnames <- suppressWarnings(as.ab(names(dots), info = FALSE))
if (anyNA(newnames)) { if (anyNA(newnames)) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_(paste0(font_yellow(font_bold(" WARNING: ")), "some columns returned `NA` for `as.ab()`"), as_note = FALSE) message_("WARNING: some columns returned NA for {.fun as.ab}", as_note = FALSE)
} }
warning_("Invalid antibiotic reference(s): ", vector_and(names(dots)[is.na(newnames)], quotes = FALSE), warning_("Invalid antibiotic reference(s): ", vector_and(names(dots)[is.na(newnames)], quotes = FALSE),
call = FALSE, call = FALSE,
@@ -222,7 +221,7 @@ get_column_abx <- function(x,
unexisting_cols <- which(!vapply(FUN.VALUE = logical(1), dots, function(col) all(col %in% x_columns))) unexisting_cols <- which(!vapply(FUN.VALUE = logical(1), dots, function(col) all(col %in% x_columns)))
if (length(unexisting_cols) > 0) { if (length(unexisting_cols) > 0) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_(" ERROR", add_fn = list(font_red, font_bold), as_note = FALSE) message_(" ERROR", as_note = FALSE)
} }
stop_("Column(s) not found: ", vector_and(unlist(dots[[unexisting_cols]]), quotes = FALSE), stop_("Column(s) not found: ", vector_and(unlist(dots[[unexisting_cols]]), quotes = FALSE),
call = FALSE call = FALSE
@@ -266,11 +265,11 @@ get_column_abx <- function(x,
if (isTRUE(info)) { if (isTRUE(info)) {
if (all_okay == TRUE) { if (all_okay == TRUE) {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE) message_(" OK.", as_note = FALSE)
} else if (!isFALSE(dups)) { } else if (!isFALSE(dups)) {
message_(paste0(font_yellow(font_bold(" WARNING: ")), "some results from `as.ab()` are duplicated: ", vector_and(dups, quotes = "`")), as_note = FALSE) message_("WARNING: some results from {.fun as.ab} are duplicated: ", vector_and(dups, quotes = "`"), as_note = FALSE)
} else { } else {
message_(" WARNING.", add_fn = list(font_yellow, font_bold), as_note = FALSE) message_(" WARNING.", as_note = FALSE)
} }
for (i in seq_len(length(out))) { for (i in seq_len(length(out))) {
@@ -288,8 +287,7 @@ get_column_abx <- function(x,
"Column '", font_bold(out[i]), "' will not be used for ", "Column '", font_bold(out[i]), "' will not be used for ",
names(out)[i], " (", suppressMessages(ab_name(names(out)[i], tolower = TRUE, language = NULL, fast_mode = TRUE)), ")", names(out)[i], " (", suppressMessages(ab_name(names(out)[i], tolower = TRUE, language = NULL, fast_mode = TRUE)), ")",
", as this antimicrobial has already been set." ", as this antimicrobial has already been set."
), )
add_fn = font_red
) )
} }
} }

41
R/interpretive_rules.R
View File

@@ -192,19 +192,19 @@ interpretive_rules <- function(x,
stop_if( stop_if(
!is.na(ampc_cephalosporin_resistance) && !any(c("expert", "all") %in% rules), !is.na(ampc_cephalosporin_resistance) && !any(c("expert", "all") %in% rules),
"For the `ampc_cephalosporin_resistance` argument to work, the `rules` argument must contain `\"expert\"` or `\"all\"`." "For the {.arg ampc_cephalosporin_resistance} argument to work, the {.arg rules} argument must contain {.code \"expert\"} or {.code \"all\"}."
) )
add_MO_lookup_to_AMR_env() add_MO_lookup_to_AMR_env()
if ("custom" %in% rules && is.null(custom_rules)) { if ("custom" %in% rules && is.null(custom_rules)) {
warning_("in `eucast_rules()`: no custom rules were set with the `custom_rules` argument", warning_("in {.fun eucast_rules}: no custom rules were set with the {.arg custom_rules} argument",
immediate = TRUE immediate = TRUE
) )
rules <- rules[rules != "custom"] rules <- rules[rules != "custom"]
if (length(rules) == 0) { if (length(rules) == 0) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_("No other rules were set, returning original data", add_fn = font_red, as_note = FALSE) message_("No other rules were set, returning original data", as_note = FALSE)
} }
return(x) return(x)
} }
@@ -232,7 +232,7 @@ interpretive_rules <- function(x,
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt) q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
} }
if (q_continue %in% c(FALSE, 2)) { if (q_continue %in% c(FALSE, 2)) {
message_("Cancelled, returning original data", add_fn = font_red, as_note = FALSE) message_("Cancelled, returning original data", as_note = FALSE)
return(x) return(x)
} }
} }
@@ -241,7 +241,7 @@ interpretive_rules <- function(x,
# -- mo # -- mo
if (is.null(col_mo)) { if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = info) col_mo <- search_type_in_df(x = x, type = "mo", info = info)
stop_if(is.null(col_mo), "`col_mo` must be set") stop_if(is.null(col_mo), "{.arg col_mo} must be set")
} }
decimal.mark <- getOption("OutDec") decimal.mark <- getOption("OutDec")
@@ -459,7 +459,7 @@ interpretive_rules <- function(x,
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL, info = FALSE) x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL, info = FALSE)
x$genus_species <- trimws(paste(x$genus, x$species)) x$genus_species <- trimws(paste(x$genus, x$species))
if (isTRUE(info) && NROW(x.bak) > 10000) { if (isTRUE(info) && NROW(x.bak) > 10000) {
message_("OK.", add_fn = list(font_green, font_bold), as_note = FALSE) message_("OK.", as_note = FALSE)
} }
n_added <- 0 n_added <- 0
@@ -595,23 +595,13 @@ interpretive_rules <- function(x,
} else { } else {
if (isTRUE(info)) { if (isTRUE(info)) {
cat("\n") cat("\n")
message_(paste0( message_("Skipping inhibitor-inheritance rules defined by this AMR package: setting S to drug+inhibitor where drug is S, and setting R to drug where drug+inhibitor is R. Add \"other\" or \"all\" to the {.arg rules} argument to apply those rules.")
font_red("Skipping inhibitor-inheritance rules defined by this AMR package: setting "),
font_green_bg(" S "),
font_red(" to drug+inhibitor where drug is "),
font_green_bg(" S "),
font_red(", and setting "),
font_rose_bg(" R "),
font_red(" to drug where drug+inhibitor is "),
font_rose_bg(" R "),
font_red(". Add \"other\" or \"all\" to the `rules` argument to apply those rules.")
))
} }
} }
if (!any(c("all", "custom") %in% rules) && !is.null(custom_rules)) { if (!any(c("all", "custom") %in% rules) && !is.null(custom_rules)) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_("Skipping custom EUCAST rules, since the `rules` argument does not contain \"custom\".") message_("Skipping custom EUCAST rules, since the {.arg rules} argument does not contain {.code \"custom\"}.")
} }
custom_rules <- NULL custom_rules <- NULL
} }
@@ -673,8 +663,7 @@ interpretive_rules <- function(x,
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"
add_fn = font_red
) )
} }
cols_ab <- c(cols_ab, stats::setNames(unname(cols_ab[names(cols_ab) == ab]), ab_s)) cols_ab <- c(cols_ab, stats::setNames(unname(cols_ab[names(cols_ab) == ab]), ab_s))
@@ -898,7 +887,7 @@ interpretive_rules <- function(x,
for (i in seq_len(length(custom_rules))) { for (i in seq_len(length(custom_rules))) {
rule <- custom_rules[[i]] rule <- custom_rules[[i]]
rows <- tryCatch(which(eval(parse(text = rule$query), envir = x)), rows <- tryCatch(which(eval(parse(text = rule$query), envir = x)),
error = function(e) stop_(paste0(conditionMessage(e), font_red(" (check available data and compare with the custom rules set)")), call = FALSE) error = function(e) stop_(conditionMessage(e), " (check available data and compare with the custom rules set)", call = FALSE)
) )
cols <- as.character(rule$result_group) cols <- as.character(rule$result_group)
cols <- c( cols <- c(
@@ -1073,7 +1062,7 @@ interpretive_rules <- function(x,
warn_lacking_sir_class <- warn_lacking_sir_class[order(colnames(x.bak))] warn_lacking_sir_class <- warn_lacking_sir_class[order(colnames(x.bak))]
warn_lacking_sir_class <- warn_lacking_sir_class[!is.na(warn_lacking_sir_class)] warn_lacking_sir_class <- warn_lacking_sir_class[!is.na(warn_lacking_sir_class)]
warning_( warning_(
"in `eucast_rules()`: not all columns with antimicrobial results are of class 'sir'. Transform them on beforehand, with e.g.:\n", "in {.fun eucast_rules}: not all columns with antimicrobial results are of class 'sir'. Transform them on beforehand, with e.g.:\n",
" - ", x_deparsed, " %>% as.sir(", ifelse(length(warn_lacking_sir_class) == 1, " - ", x_deparsed, " %>% as.sir(", ifelse(length(warn_lacking_sir_class) == 1,
warn_lacking_sir_class, warn_lacking_sir_class,
paste0(warn_lacking_sir_class[1], ":", warn_lacking_sir_class[length(warn_lacking_sir_class)]) paste0(warn_lacking_sir_class[1], ":", warn_lacking_sir_class[length(warn_lacking_sir_class)])
@@ -1108,7 +1097,7 @@ eucast_rules <- function(x,
rules = getOption("AMR_interpretive_rules", default = c("breakpoints", "expected_phenotypes")), rules = getOption("AMR_interpretive_rules", default = c("breakpoints", "expected_phenotypes")),
...) { ...) {
if (!is.null(getOption("AMR_eucastrules", default = NULL))) { if (!is.null(getOption("AMR_eucastrules", default = NULL))) {
warning_("The global option `AMR_eucastrules` that you have set is now invalid was ignored - set `AMR_interpretive_rules` instead. See `?AMR-options`.") warning_("The global option {.code AMR_eucastrules} that you have set is now invalid was ignored - set {.code AMR_interpretive_rules} instead. See {.code ?AMR-options}.")
} }
interpretive_rules(x = x, col_mo = col_mo, info = info, rules = rules, guideline = "EUCAST", ...) interpretive_rules(x = x, col_mo = col_mo, info = info, rules = rules, guideline = "EUCAST", ...)
} }
@@ -1165,7 +1154,7 @@ edit_sir <- function(x,
isSIR <- !isNA & (new_edits[rows, cols] == "S" | new_edits[rows, cols] == "I" | new_edits[rows, cols] == "R" | new_edits[rows, cols] == "SDD" | new_edits[rows, cols] == "NI" | new_edits[rows, cols] == "WT" | new_edits[rows, cols] == "NWT" | new_edits[rows, cols] == "NS") isSIR <- !isNA & (new_edits[rows, cols] == "S" | new_edits[rows, cols] == "I" | new_edits[rows, cols] == "R" | new_edits[rows, cols] == "SDD" | new_edits[rows, cols] == "NI" | new_edits[rows, cols] == "WT" | new_edits[rows, cols] == "NWT" | new_edits[rows, cols] == "NS")
non_SIR <- !isSIR non_SIR <- !isSIR
if (isFALSE(overwrite) && any(isSIR) && message_not_thrown_before("edit_sir.warning_overwrite")) { if (isFALSE(overwrite) && any(isSIR) && message_not_thrown_before("edit_sir.warning_overwrite")) {
warning_("Some values had SIR values and were not overwritten, since `overwrite = FALSE`.") warning_("Some values had SIR values and were not overwritten, since {.code overwrite = FALSE}.")
} }
tryCatch( tryCatch(
# insert into original table # insert into original table
@@ -1189,7 +1178,7 @@ edit_sir <- function(x,
suppressWarnings(new_edits[rows, cols][non_SIR] <<- to) suppressWarnings(new_edits[rows, cols][non_SIR] <<- to)
} }
warning_( warning_(
"in `eucast_rules()`: value \"", to, "\" added to the factor levels of column", "in {.fun eucast_rules}: value \"", to, "\" added to the factor levels of column",
ifelse(length(cols) == 1, "", "s"), ifelse(length(cols) == 1, "", "s"),
" ", vector_and(cols, quotes = "`", sort = FALSE), " ", vector_and(cols, quotes = "`", sort = FALSE),
" because this value was not an existing factor level." " because this value was not an existing factor level."
@@ -1197,7 +1186,7 @@ edit_sir <- function(x,
txt_warning() txt_warning()
warned <- FALSE warned <- FALSE
} else { } else {
warning_("in `eucast_rules()`: ", w$message) warning_("in {.fun eucast_rules}: ", w$message)
txt_warning() txt_warning()
} }
}, },

6
R/join_microorganisms.R
View File

@@ -143,9 +143,9 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
if (is.null(by) && NCOL(x) == 1) { if (is.null(by) && NCOL(x) == 1) {
by <- colnames(x)[1L] by <- colnames(x)[1L]
} else { } else {
stop_if(is.null(by), "no column with microorganism names or codes found, set this column with `by`", call = -2) stop_if(is.null(by), "no column with microorganism names or codes found, set this column with {.arg by}", call = -2)
} }
message_('Joining, by = "', by, '"', add_fn = font_black, as_note = FALSE) # message same as dplyr::join functions message_('Joining, by = "{by}"', as_note = FALSE) # message same as dplyr::join functions
} }
if (!all(x[, by, drop = TRUE] %in% AMR_env$MO_lookup$mo, na.rm = TRUE)) { if (!all(x[, by, drop = TRUE] %in% AMR_env$MO_lookup$mo, na.rm = TRUE)) {
x$join.mo <- as.mo(x[, by, drop = TRUE]) x$join.mo <- as.mo(x[, by, drop = TRUE])
@@ -185,7 +185,7 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
} }
if (type %like% "full|left|right|inner" && NROW(joined) > NROW(x)) { if (type %like% "full|left|right|inner" && NROW(joined) > NROW(x)) {
warning_("in `", type, "_microorganisms()`: the newly joined data set contains ", nrow(joined) - nrow(x), " rows more than the number of rows of `x`.") warning_("in `{type}_microorganisms()`: the newly joined data set contains {nrow(joined) - nrow(x)} rows more than the number of rows of {.arg x}.")
} }
as_original_data_class(joined, class(x.bak)) # will remove tibble groups as_original_data_class(joined, class(x.bak)) # will remove tibble groups

26
R/mdro.R
View File

@@ -170,9 +170,9 @@ mdro <- function(x = NULL,
meet_criteria(infer_from_combinations, allow_class = "logical", has_length = 1) meet_criteria(infer_from_combinations, allow_class = "logical", has_length = 1)
if (isTRUE(only_sir_columns) && !any(is.sir(x))) { if (isTRUE(only_sir_columns) && !any(is.sir(x))) {
stop_("There were no SIR columns found in the data set, despite `only_sir_columns` being `TRUE`. Transform columns with `as.sir()` for valid antimicrobial interpretations.") stop_("There were no SIR columns found in the data set, despite {.arg only_sir_columns} being {.code TRUE}. Transform columns with {.fun as.sir} for valid antimicrobial interpretations.")
} else if (!isTRUE(only_sir_columns) && !any(is.sir(x)) && !any(is_sir_eligible(x))) { } else if (!isTRUE(only_sir_columns) && !any(is.sir(x)) && !any(is_sir_eligible(x))) {
stop_("There were no eligible SIR columns found in the data set. Transform columns with `as.sir()` for valid antimicrobial interpretations.") stop_("There were no eligible SIR columns found in the data set. Transform columns with {.fun as.sir} for valid antimicrobial interpretations.")
} }
# get gene values as TRUE/FALSE # get gene values as TRUE/FALSE
@@ -213,7 +213,7 @@ mdro <- function(x = NULL,
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt) q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
} }
if (q_continue %in% c(FALSE, 2)) { if (q_continue %in% c(FALSE, 2)) {
message_("Cancelled, returning original data", add_fn = font_red, as_note = FALSE) message_("Cancelled, returning original data", as_note = FALSE)
return(x) return(x)
} }
} }
@@ -251,7 +251,7 @@ mdro <- function(x = NULL,
guideline.bak <- guideline guideline.bak <- guideline
if (is.list(guideline)) { if (is.list(guideline)) {
# Custom MDRO guideline --------------------------------------------------- # Custom MDRO guideline ---------------------------------------------------
stop_ifnot(inherits(guideline, "custom_mdro_guideline"), "use `custom_mdro_guideline()` to create custom guidelines") stop_ifnot(inherits(guideline, "custom_mdro_guideline"), "use {.fun custom_mdro_guideline} to create custom guidelines")
if (isTRUE(info)) { if (isTRUE(info)) {
txt <- paste0( txt <- paste0(
"Determining MDROs based on custom rules", "Determining MDROs based on custom rules",
@@ -328,13 +328,13 @@ mdro <- function(x = NULL,
} }
if (is.null(col_mo) && guideline$code == "tb") { if (is.null(col_mo) && guideline$code == "tb") {
message_( message_(
"No column found as input for `col_mo`, ", "No column found as input for {.arg col_mo}, ",
font_bold(paste0("assuming all rows contain ", font_italic("Mycobacterium tuberculosis"), ".")) font_bold(paste0("assuming all rows contain ", font_italic("Mycobacterium tuberculosis"), "."))
) )
x$mo <- as.mo("Mycobacterium tuberculosis", keep_synonyms = TRUE) x$mo <- as.mo("Mycobacterium tuberculosis", keep_synonyms = TRUE)
col_mo <- "mo" col_mo <- "mo"
} }
stop_if(is.null(col_mo), "`col_mo` must be set") stop_if(is.null(col_mo), "{.arg col_mo} must be set")
if (guideline$code == "cmi2012") { if (guideline$code == "cmi2012") {
guideline$name <- "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance." guideline$name <- "Multidrug-resistant, extensively drug-resistant and pandrug-resistant bacteria: an international expert proposal for interim standard definitions for acquired resistance."
@@ -476,7 +476,7 @@ mdro <- function(x = NULL,
if (!"AMP" %in% names(cols_ab) && "AMX" %in% names(cols_ab)) { if (!"AMP" %in% names(cols_ab) && "AMX" %in% names(cols_ab)) {
# ampicillin column is missing, but amoxicillin is available # ampicillin column is missing, but amoxicillin is available
if (isTRUE(info)) { if (isTRUE(info)) {
message_("Using column '", cols_ab[names(cols_ab) == "AMX"], "' as input for ampicillin since many MDRO rules depend on it.", add_fn = font_red) message_("Using column '", cols_ab[names(cols_ab) == "AMX"], "' as input for ampicillin since many MDRO rules depend on it.")
} }
cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"]))) cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"])))
} }
@@ -875,7 +875,7 @@ mdro <- function(x = NULL,
} }
if (isTRUE(info)) { if (isTRUE(info)) {
message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE) message_(" OK.", as_note = FALSE)
} }
} }
@@ -1965,7 +1965,7 @@ brmo <- function(x = NULL, only_sir_columns = any(is.sir(x)), ...) {
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
stop_if( stop_if(
"guideline" %in% names(list(...)), "guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function" "argument {.arg guideline} must not be set since this is a guideline-specific function"
) )
mdro(x = x, only_sir_columns = only_sir_columns, guideline = "BRMO", ...) mdro(x = x, only_sir_columns = only_sir_columns, guideline = "BRMO", ...)
} }
@@ -1978,7 +1978,7 @@ mrgn <- function(x = NULL, only_sir_columns = any(is.sir(x)), verbose = FALSE, .
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
stop_if( stop_if(
"guideline" %in% names(list(...)), "guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function" "argument {.arg guideline} must not be set since this is a guideline-specific function"
) )
mdro(x = x, only_sir_columns = only_sir_columns, verbose = verbose, guideline = "MRGN", ...) mdro(x = x, only_sir_columns = only_sir_columns, verbose = verbose, guideline = "MRGN", ...)
} }
@@ -1990,7 +1990,7 @@ mdr_tb <- function(x = NULL, only_sir_columns = any(is.sir(x)), verbose = FALSE,
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
stop_if( stop_if(
"guideline" %in% names(list(...)), "guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function" "argument {.arg guideline} must not be set since this is a guideline-specific function"
) )
mdro(x = x, only_sir_columns = only_sir_columns, verbose = verbose, guideline = "TB", ...) mdro(x = x, only_sir_columns = only_sir_columns, verbose = verbose, guideline = "TB", ...)
} }
@@ -2002,7 +2002,7 @@ mdr_cmi2012 <- function(x = NULL, only_sir_columns = any(is.sir(x)), verbose = F
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
stop_if( stop_if(
"guideline" %in% names(list(...)), "guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function" "argument {.arg guideline} must not be set since this is a guideline-specific function"
) )
mdro(x = x, only_sir_columns = only_sir_columns, verbose = verbose, guideline = "CMI 2012", ...) mdro(x = x, only_sir_columns = only_sir_columns, verbose = verbose, guideline = "CMI 2012", ...)
} }
@@ -2014,7 +2014,7 @@ eucast_exceptional_phenotypes <- function(x = NULL, only_sir_columns = any(is.si
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1) meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
stop_if( stop_if(
"guideline" %in% names(list(...)), "guideline" %in% names(list(...)),
"argument `guideline` must not be set since this is a guideline-specific function" "argument {.arg guideline} must not be set since this is a guideline-specific function"
) )
mdro(x = x, only_sir_columns = only_sir_columns, verbose = verbose, guideline = "EUCAST", ...) mdro(x = x, only_sir_columns = only_sir_columns, verbose = verbose, guideline = "EUCAST", ...)
} }

20
R/mo.R
View File

@@ -402,7 +402,12 @@ as.mo <- function(x,
top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs
if (length(top_hits) == 0) { if (length(top_hits) == 0) {
warning_("No hits found for \"", x_search, "\" with minimum_matching_score = ", ifelse(is.null(minimum_matching_score), 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) warning_("No hits found for \"", x_search, "\" with minimum_matching_score = ",
ifelse(is.null(minimum_matching_score),
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)
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)]
@@ -902,14 +907,14 @@ 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(word_wrap("No uncertainties to show. Only uncertainties of the last call to `as.mo()` or any `mo_*()` function are stored.\n\n", add_fn = font_blue)) cat(font_blue(word_wrap("No uncertainties to show. Only uncertainties of the last call to `as.mo()` or any `mo_*()` function are stored.\n\n")))
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(word_wrap("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See `?mo_matching_score`.\n\n", add_fn = font_blue)) 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 `?mo_matching_score`.\n\n")))
add_MO_lookup_to_AMR_env() add_MO_lookup_to_AMR_env()
@@ -919,13 +924,12 @@ 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(word_wrap("Colour keys: ", cat(font_blue(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")
add_fn = font_blue )), font_green_bg(" "), "\n", sep = "")
), font_green_bg(" "), "\n", sep = "")
} }
score_set_colour <- function(text, scores) { score_set_colour <- function(text, scores) {
@@ -1028,7 +1032,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(word_wrap("No renamed taxonomy to show. Only renamed taxonomy of the last call of `as.mo()` or any `mo_*()` function are stored.\n", add_fn = font_blue)) cat(font_blue(word_wrap("No renamed taxonomy to show. Only renamed taxonomy of the last call of `as.mo()` or any `mo_*()` function are stored.\n")))
return(invisible(NULL)) return(invisible(NULL))
} }

5
R/mo_source.R
View File

@@ -129,7 +129,7 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
meet_criteria(path, allow_class = "character", has_length = 1, allow_NULL = TRUE) meet_criteria(path, allow_class = "character", has_length = 1, allow_NULL = TRUE)
meet_criteria(destination, allow_class = "character", has_length = 1) meet_criteria(destination, allow_class = "character", has_length = 1)
stop_ifnot(destination %like% "[.]rds$", "the `destination` must be a file location with file extension .rds.") stop_ifnot(destination %like% "[.]rds$", "the {.arg destination} must be a file location with file extension .rds.")
mo_source_destination <- path.expand(destination) mo_source_destination <- path.expand(destination)
if (is.null(path) || path %in% c(FALSE, "")) { if (is.null(path) || path %in% c(FALSE, "")) {
@@ -137,7 +137,6 @@ set_mo_source <- function(path, destination = getOption("AMR_mo_source", "~/mo_s
if (file.exists(mo_source_destination)) { if (file.exists(mo_source_destination)) {
unlink(mo_source_destination) unlink(mo_source_destination)
message_("Removed mo_source file '", font_bold(mo_source_destination), "'", message_("Removed mo_source file '", font_bold(mo_source_destination), "'",
add_fn = font_red,
as_note = FALSE as_note = FALSE
) )
} }
@@ -250,7 +249,7 @@ get_mo_source <- function(destination = getOption("AMR_mo_source", "~/mo_source.
current_ext <- regexpr("\\.([[:alnum:]]+)$", destination) current_ext <- regexpr("\\.([[:alnum:]]+)$", destination)
current_ext <- ifelse(current_ext > -1L, substring(destination, current_ext + 1L), "") current_ext <- ifelse(current_ext > -1L, substring(destination, current_ext + 1L), "")
vowel <- ifelse(current_ext %like% "^[AEFHILMNORSX]", "n", "") vowel <- ifelse(current_ext %like% "^[AEFHILMNORSX]", "n", "")
stop_("The AMR mo source must be an RDS file, not a", vowel, " ", toupper(current_ext), " file. If `\"", basename(destination), "\"` was meant as your input file, use `set_mo_source()` on this file. In any case, the option `AMR_mo_source` must be set to another path.") stop_("The AMR mo source must be an RDS file, not a{vowel} {toupper(current_ext)} file. If \"{basename(destination)}\" was meant as your input file, use {.fun set_mo_source} on this file. In any case, the option {.code AMR_mo_source} must be set to another path.")
} }
if (is.null(AMR_env$mo_source)) { if (is.null(AMR_env$mo_source)) {
AMR_env$mo_source <- readRDS_AMR(path.expand(destination)) AMR_env$mo_source <- readRDS_AMR(path.expand(destination))

49
R/sir.R
View File

@@ -441,7 +441,7 @@ is_sir_eligible <- function(x, threshold = 0.05) {
return(unname(vapply(FUN.VALUE = logical(1), x, is_sir_eligible))) return(unname(vapply(FUN.VALUE = logical(1), x, is_sir_eligible)))
} }
stop_if(NCOL(x) > 1, "`x` must be a one-dimensional vector.") stop_if(NCOL(x) > 1, "{.arg x} must be a one-dimensional vector.")
if (any(c( if (any(c(
"numeric", "numeric",
"integer", "integer",
@@ -529,10 +529,10 @@ as.sir.default <- function(x,
if (all(x %unlike% "(S|I|R)", na.rm = TRUE) && !all(x %in% c(1, 2, 3, 4, 5), na.rm = TRUE)) { if (all(x %unlike% "(S|I|R)", na.rm = TRUE) && !all(x %in% c(1, 2, 3, 4, 5), na.rm = TRUE)) {
# check if they are actually MICs or disks # check if they are actually MICs or disks
if (all_valid_mics(x)) { if (all_valid_mics(x)) {
warning_("in `as.sir()`: input values were guessed to be MIC values - preferably transform them with `as.mic()` before running `as.sir()`.") warning_("in {.fun as.sir}: input values were guessed to be MIC values - preferably transform them with {.fun as.mic} before running {.fun as.sir}.")
return(as.sir(as.mic(x), ...)) return(as.sir(as.mic(x), ...))
} else if (all_valid_disks(x)) { } else if (all_valid_disks(x)) {
warning_("in `as.sir()`: input values were guessed to be disk diffusion values - preferably transform them with `as.disk()` before running `as.sir()`.") warning_("in {.fun as.sir}: input values were guessed to be disk diffusion values - preferably transform them with {.fun as.disk} before running {.fun as.sir}.")
return(as.sir(as.disk(x), ...)) return(as.sir(as.disk(x), ...))
} }
} }
@@ -601,7 +601,7 @@ as.sir.default <- function(x,
ifelse(length(out7) > 0, paste0("7 as \"", out7, "\""), NA_character_), ifelse(length(out7) > 0, paste0("7 as \"", out7, "\""), NA_character_),
ifelse(length(out8) > 0, paste0("8 as \"", out8, "\""), NA_character_) ifelse(length(out8) > 0, paste0("8 as \"", out8, "\""), NA_character_)
) )
message_("in `as.sir()`: Interpreting input value ", vector_and(out[!is.na(out)], quotes = FALSE, sort = FALSE)) message_("in {.fun as.sir}: Interpreting input value ", vector_and(out[!is.na(out)], quotes = FALSE, sort = FALSE))
} }
if (na_before != na_after) { if (na_before != na_after) {
@@ -610,7 +610,7 @@ as.sir.default <- function(x,
sort() %pm>% sort() %pm>%
vector_and(quotes = TRUE) vector_and(quotes = TRUE)
cur_col <- get_current_column() cur_col <- get_current_column()
warning_("in `as.sir()`: ", na_after - na_before, " result", warning_("in {.fun as.sir}: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""), ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")), ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (", " truncated (",
@@ -783,10 +783,10 @@ as.sir.data.frame <- function(x,
# -- host # -- host
if (missing(breakpoint_type) && any(host %in% clinical_breakpoints$host[!clinical_breakpoints$host %in% c("human", "ECOFF")], na.rm = TRUE)) { if (missing(breakpoint_type) && any(host %in% clinical_breakpoints$host[!clinical_breakpoints$host %in% c("human", "ECOFF")], na.rm = TRUE)) {
if (isTRUE(info)) message_("Assuming `breakpoint_type = \"animal\"` since `host` contains animal species.") if (isTRUE(info)) message_("Assuming {.code breakpoint_type = \"animal\"} since {.arg host} contains animal species.")
breakpoint_type <- "animal" breakpoint_type <- "animal"
} else if (any(!suppressMessages(convert_host(host, lang = language)) %in% c("human", "ECOFF"), na.rm = TRUE)) { } else if (any(!suppressMessages(convert_host(host, lang = language)) %in% c("human", "ECOFF"), na.rm = TRUE)) {
if (isTRUE(info)) message_("Assuming `breakpoint_type = \"animal\"`.") if (isTRUE(info)) message_("Assuming {.code breakpoint_type = \"animal\"}.")
breakpoint_type <- "animal" breakpoint_type <- "animal"
} }
if (breakpoint_type == "animal") { if (breakpoint_type == "animal") {
@@ -883,7 +883,7 @@ as.sir.data.frame <- function(x,
types[types == "" & !vapply(FUN.VALUE = logical(1), x.bak[, ab_cols, drop = FALSE], is.sir)] <- "sir" types[types == "" & !vapply(FUN.VALUE = logical(1), x.bak[, ab_cols, drop = FALSE], is.sir)] <- "sir"
if (any(types %in% c("mic", "disk"), na.rm = TRUE)) { if (any(types %in% c("mic", "disk"), na.rm = TRUE)) {
# now we need an mo column # now we need an mo column
stop_if(is.null(col_mo), "`col_mo` must be set") stop_if(is.null(col_mo), "{.arg col_mo} must be set")
# if not null, we already found it, now find again so a message will show # if not null, we already found it, now find again so a message will show
if (is.null(col_mo.bak)) { if (is.null(col_mo.bak)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = info) col_mo <- search_type_in_df(x = x, type = "mo", info = info)
@@ -898,7 +898,7 @@ as.sir.data.frame <- function(x,
cl <- tryCatch(parallel::makeCluster(n_cores, type = "PSOCK"), cl <- tryCatch(parallel::makeCluster(n_cores, type = "PSOCK"),
error = function(e) { error = function(e) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_("Could not create parallel cluster, using single-core computation. Error message: ", conditionMessage(e), add_fn = font_red) message_("Could not create parallel cluster, using single-core computation. Error message: ", conditionMessage(e))
} }
return(NULL) return(NULL)
} }
@@ -1029,14 +1029,14 @@ as.sir.data.frame <- function(x,
if (isTRUE(info)) { if (isTRUE(info)) {
message_(font_green_bg(" DONE "), as_note = FALSE) message_(font_green_bg(" DONE "), as_note = FALSE)
message() message()
message_("Run `sir_interpretation_history()` to retrieve a logbook with all details of the breakpoint interpretations.", add_fn = font_green) message_("Run {.fun sir_interpretation_history} to retrieve a logbook with all details of the breakpoint interpretations.")
} }
} else { } else {
# sequential mode (non-parallel) # sequential mode (non-parallel)
if (isTRUE(info) && n_cores > 1 && NROW(x) * NCOL(x) > 10000) { if (isTRUE(info) && n_cores > 1 && NROW(x) * NCOL(x) > 10000) {
# give a note that parallel mode might be better # give a note that parallel mode might be better
message() message()
message_("Running in sequential mode. Consider setting `parallel = TRUE` to speed up processing on multiple cores.\n", add_fn = font_red) message_("Running in sequential mode. Consider setting {.arg parallel} to {.code TRUE} to speed up processing on multiple cores.\n")
} }
# this will contain a progress bar already # this will contain a progress bar already
result_list <- lapply(seq_along(ab_cols), run_as_sir_column) result_list <- lapply(seq_along(ab_cols), run_as_sir_column)
@@ -1168,13 +1168,13 @@ as_sir_method <- function(method_short,
dots <- list(...) dots <- list(...)
dots <- dots[which(!names(dots) %in% c("warn", "mo.bak", "is_data.frame"))] dots <- dots[which(!names(dots) %in% c("warn", "mo.bak", "is_data.frame"))]
if (length(dots) != 0) { if (length(dots) != 0) {
warning_("These arguments in `as.sir()` are no longer used: ", vector_and(names(dots), quotes = "`"), ".", call = FALSE) warning_("These arguments in {.fun as.sir} are no longer used: ", vector_and(names(dots), quotes = "`"), ".", call = FALSE)
} }
current_sir_interpretation_history <- NROW(AMR_env$sir_interpretation_history) current_sir_interpretation_history <- NROW(AMR_env$sir_interpretation_history)
if (isTRUE(info) && message_not_thrown_before("as.sir", "sir_interpretation_history")) { if (isTRUE(info) && message_not_thrown_before("as.sir", "sir_interpretation_history")) {
message_("Run `sir_interpretation_history()` afterwards to retrieve a logbook with all details of the breakpoint interpretations.\n\n", add_fn = font_green) message_("Run {.fun sir_interpretation_history} afterwards to retrieve a logbook with all details of the breakpoint interpretations.\n\n")
} }
current_df <- tryCatch(get_current_data(NA, 0), error = function(e) NULL) current_df <- tryCatch(get_current_data(NA, 0), error = function(e) NULL)
@@ -1190,13 +1190,13 @@ as_sir_method <- function(method_short,
if (is.null(host)) { if (is.null(host)) {
host <- "dogs" host <- "dogs"
if (isTRUE(info) && message_not_thrown_before("as.sir", "host_missing")) { if (isTRUE(info) && message_not_thrown_before("as.sir", "host_missing")) {
message_("Animal hosts not set in `host`, assuming `host = \"dogs\"`, since these have the highest breakpoint availability.\n\n") message_("Animal hosts not set in {.arg host}, assuming {.code host = \"dogs\"}, since these have the highest breakpoint availability.\n\n")
} }
} }
} else { } else {
if (!is.null(host) && !all(toupper(as.character(host)) %in% c("HUMAN", "ECOFF"))) { if (!is.null(host) && !all(toupper(as.character(host)) %in% c("HUMAN", "ECOFF"))) {
if (isTRUE(info) && message_not_thrown_before("as.sir", "assumed_breakpoint_animal")) { if (isTRUE(info) && message_not_thrown_before("as.sir", "assumed_breakpoint_animal")) {
message_("Assuming `breakpoint_type = \"animal\"`, since `host` is set.", ifelse(guideline_coerced %like% "EUCAST", " Do you also need to set `guideline = \"CLSI\"`?", ""), "\n\n") message_("Assuming {.code breakpoint_type = \"animal\"}, since {.arg host} is set.", ifelse(guideline_coerced %like% "EUCAST", " Do you also need to set {.code guideline = \"CLSI\"}?", ""), "\n\n")
} }
breakpoint_type <- "animal" breakpoint_type <- "animal"
} else { } else {
@@ -1276,7 +1276,7 @@ as_sir_method <- function(method_short,
mo_var_found <- "" mo_var_found <- ""
} }
if (is.null(mo)) { if (is.null(mo)) {
stop_("No information was supplied about the microorganisms (missing argument `mo` and no column of class 'mo' found). See ?as.sir.\n\n", stop_("No information was supplied about the microorganisms (missing argument {.arg mo} and no column of class 'mo' found). See {.fun as.sir}.\n\n",
"To transform certain columns with e.g. mutate(), use `data %>% mutate(across(..., as.sir, mo = x))`, where x is your column with microorganisms.\n", "To transform certain columns with e.g. mutate(), use `data %>% mutate(across(..., as.sir, mo = x))`, where x is your column with microorganisms.\n",
"To transform all ", method_long, " in a data set, use `data %>% as.sir()` or `data %>% mutate_if(is.", method_short, ", as.sir)`.", "To transform all ", method_long, " in a data set, use `data %>% as.sir()` or `data %>% mutate_if(is.", method_short, ", as.sir)`.",
call = FALSE call = FALSE
@@ -1312,7 +1312,7 @@ as_sir_method <- function(method_short,
if (length(ab) == 1 && ab %like% paste0("as.", method_short)) { if (length(ab) == 1 && ab %like% paste0("as.", method_short)) {
stop_("No unambiguous name was supplied about the antibiotic (argument `ab`). See ?as.sir.", call = FALSE) stop_("No unambiguous name was supplied about the antibiotic (argument {.arg ab}). See {.fun as.sir}.", call = FALSE)
} }
ab.bak <- trimws2(ab) ab.bak <- trimws2(ab)
@@ -1328,8 +1328,7 @@ as_sir_method <- function(method_short,
if (all(is.na(ab))) { if (all(is.na(ab))) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_("Returning NAs for unknown antibiotic: ", vector_and(ab.bak, sort = FALSE, quotes = TRUE), message_("Returning NAs for unknown antibiotic: ", vector_and(ab.bak, sort = FALSE, quotes = TRUE),
". Rename this column to a valid name or code, and check the output with `as.ab()`.", ". Rename this column to a valid name or code, and check the output with {.fun as.ab}.",
add_fn = font_red,
as_note = FALSE as_note = FALSE
) )
} }
@@ -1353,9 +1352,7 @@ as_sir_method <- function(method_short,
} }
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %unlike% "EUCAST") { if (isTRUE(add_intrinsic_resistance) && guideline_coerced %unlike% "EUCAST") {
if (isTRUE(info) && message_not_thrown_before("as.sir", "intrinsic")) { if (isTRUE(info) && message_not_thrown_before("as.sir", "intrinsic")) {
message_("in `as.sir()`: using 'add_intrinsic_resistance' is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.", message_("in {.fun as.sir}: using {.arg add_intrinsic_resistance} is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
add_fn = font_red
)
} }
} }
@@ -1947,7 +1944,7 @@ as_sir_method <- function(method_short,
# if (isTRUE(verbose) || length(notes) == 1 || NROW(AMR_env$sir_interpretation_history) == 0) { # if (isTRUE(verbose) || length(notes) == 1 || NROW(AMR_env$sir_interpretation_history) == 0) {
if (isTRUE(verbose)) { if (isTRUE(verbose)) {
for (i in seq_along(notes)) { for (i in seq_along(notes)) {
message(word_wrap(" ", AMR_env$bullet_icon, " ", notes[i], add_fn = font_black)) message(word_wrap(" ", AMR_env$bullet_icon, " ", notes[i]))
} }
} else { } else {
# message(word_wrap(" ", AMR_env$bullet_icon, " There were multiple notes. Print or View `sir_interpretation_history()` to examine them, or use `as.sir(..., verbose = TRUE)` next time to directly print them here.", add_fn = font_black)) # message(word_wrap(" ", AMR_env$bullet_icon, " There were multiple notes. Print or View `sir_interpretation_history()` to examine them, or use `as.sir(..., verbose = TRUE)` next time to directly print them here.", add_fn = font_black))
@@ -1991,7 +1988,7 @@ sir_interpretation_history <- function(clean = FALSE) {
#' @noRd #' @noRd
print.sir_log <- function(x, ...) { print.sir_log <- function(x, ...) {
if (NROW(x) == 0) { if (NROW(x) == 0) {
message_("No results to print. First run `as.sir()` on MIC values or disk diffusion zones (or on a `data.frame` containing any of these) to print a 'logbook' data set here.") message_("No results to print. First run {.fun as.sir} on MIC values or disk diffusion zones (or on a {.cls data.frame} containing any of these) to print a 'logbook' data set here.")
return(invisible(NULL)) return(invisible(NULL))
} }
class(x) <- class(x)[class(x) != "sir_log"] class(x) <- class(x)[class(x) != "sir_log"]
@@ -2230,10 +2227,10 @@ check_reference_data <- function(reference_data, .call_depth) {
class_sir <- vapply(FUN.VALUE = character(1), AMR::clinical_breakpoints, function(x) paste0("<", class(x), ">", collapse = " and ")) class_sir <- vapply(FUN.VALUE = character(1), AMR::clinical_breakpoints, function(x) paste0("<", class(x), ">", collapse = " and "))
class_ref <- vapply(FUN.VALUE = character(1), reference_data, function(x) paste0("<", class(x), ">", collapse = " and ")) class_ref <- vapply(FUN.VALUE = character(1), reference_data, function(x) paste0("<", class(x), ">", collapse = " and "))
if (!all(names(class_sir) == names(class_ref))) { if (!all(names(class_sir) == names(class_ref))) {
stop_("`reference_data` must have the same column names as the 'clinical_breakpoints' data set.", call = .call_depth) stop_("{.arg reference_data} must have the same column names as the 'clinical_breakpoints' data set.", call = .call_depth)
} }
if (!all(class_sir == class_ref)) { if (!all(class_sir == class_ref)) {
stop_("`reference_data` must be the same structure as the 'clinical_breakpoints' data set. Column '", names(class_ref[class_sir != class_ref][1]), "' is of class ", class_ref[class_sir != class_ref][1], ", but should be of class ", class_sir[class_sir != class_ref][1], ".", call = .call_depth) stop_("{.arg reference_data} must be the same structure as the 'clinical_breakpoints' data set. Column '", names(class_ref[class_sir != class_ref][1]), "' is of class ", class_ref[class_sir != class_ref][1], ", but should be of class ", class_sir[class_sir != class_ref][1], ".", call = .call_depth)
} }
} }
} }

8
R/translate.R
View File

@@ -249,7 +249,7 @@ translate_into_language <- function(from,
any_form_in_patterns <- tryCatch( any_form_in_patterns <- tryCatch(
any(from_unique %like% paste0("(", paste(gsub(" +\\(.*", "", df_trans$pattern), collapse = "|"), ")")), any(from_unique %like% paste0("(", paste(gsub(" +\\(.*", "", df_trans$pattern), collapse = "|"), ")")),
error = function(e) { error = function(e) {
warning_("Translation not possible. Please create an issue at ", font_url("https://github.com/msberends/AMR/issues"), ". Many thanks!") warning_("Translation not possible. Please create an issue at {.url https://github.com/msberends/AMR/issues}. Many thanks!")
return(FALSE) return(FALSE)
} }
) )
@@ -293,11 +293,11 @@ translate_into_language <- function(from,
out <- from_unique_translated[match(from.bak, from_unique)] out <- from_unique_translated[match(from.bak, from_unique)]
if (!identical(from.bak, out) && get_AMR_locale() == lang && is.null(getOption("AMR_locale", default = NULL)) && message_not_thrown_before("translation", entire_session = TRUE) && interactive()) { if (!identical(from.bak, out) && get_AMR_locale() == lang && is.null(getOption("AMR_locale", default = NULL)) && message_not_thrown_before("translation", entire_session = TRUE) && interactive()) {
message(word_wrap( message(font_blue(word_wrap(
"Assuming the ", LANGUAGES_SUPPORTED_NAMES[[lang]]$exonym, " language (", "Assuming the ", LANGUAGES_SUPPORTED_NAMES[[lang]]$exonym, " language (",
LANGUAGES_SUPPORTED_NAMES[[lang]]$endonym, ") for the AMR package. See `set_AMR_locale()` to change this or to silence this once-per-session note.", LANGUAGES_SUPPORTED_NAMES[[lang]]$endonym, ") for the AMR package. See `set_AMR_locale()` to change this or to silence this once-per-session note.",
add_fn = list(font_blue), as_note = TRUE as_note = TRUE
)) )))
} }
out out

3
R/zzz.R
View File

@@ -118,8 +118,7 @@ AMR_env$cross_icon <- if (isTRUE(base::l10n_info()$`UTF-8`)) "\u00d7" else "x"
if (interactive() && is.null(getOption("AMR_guideline"))) { if (interactive() && is.null(getOption("AMR_guideline"))) {
packageStartupMessage( packageStartupMessage(
word_wrap( word_wrap(
"Assuming ", AMR::clinical_breakpoints$guideline[1], " as the default AMR guideline, see `?AMR-options` to change this.", "Assuming ", AMR::clinical_breakpoints$guideline[1], " as the default AMR guideline, see `?AMR-options` to change this."
add_fn = NULL
) )
) )
} }