P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2026-03-19 11:42:23 +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

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)))
}
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(
"numeric",
"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)) {
# check if they are actually MICs or disks
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), ...))
} 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), ...))
}
}
@@ -601,7 +601,7 @@ as.sir.default <- function(x,
ifelse(length(out7) > 0, paste0("7 as \"", out7, "\""), 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) {
@@ -610,7 +610,7 @@ as.sir.default <- function(x,
sort() %pm>%
vector_and(quotes = TRUE)
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(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (",
@@ -783,10 +783,10 @@ as.sir.data.frame <- function(x,
# -- host
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"
} 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"
}
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"
if (any(types %in% c("mic", "disk"), na.rm = TRUE)) {
# 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 (is.null(col_mo.bak)) {
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"),
error = function(e) {
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)
}
@@ -1029,14 +1029,14 @@ as.sir.data.frame <- function(x,
if (isTRUE(info)) {
message_(font_green_bg(" DONE "), as_note = FALSE)
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 {
# sequential mode (non-parallel)
if (isTRUE(info) && n_cores > 1 && NROW(x) * NCOL(x) > 10000) {
# give a note that parallel mode might be better
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
result_list <- lapply(seq_along(ab_cols), run_as_sir_column)
@@ -1168,13 +1168,13 @@ as_sir_method <- function(method_short,
dots <- list(...)
dots <- dots[which(!names(dots) %in% c("warn", "mo.bak", "is_data.frame"))]
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)
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)
@@ -1190,13 +1190,13 @@ as_sir_method <- function(method_short,
if (is.null(host)) {
host <- "dogs"
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 {
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")) {
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"
} else {
@@ -1276,7 +1276,7 @@ as_sir_method <- function(method_short,
mo_var_found <- ""
}
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 all ", method_long, " in a data set, use `data %>% as.sir()` or `data %>% mutate_if(is.", method_short, ", as.sir)`.",
call = FALSE
@@ -1312,7 +1312,7 @@ as_sir_method <- function(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)
@@ -1328,8 +1328,7 @@ as_sir_method <- function(method_short,
if (all(is.na(ab))) {
if (isTRUE(info)) {
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()`.",
add_fn = font_red,
". Rename this column to a valid name or code, and check the output with {.fun as.ab}.",
as_note = FALSE
)
}
@@ -1353,9 +1352,7 @@ as_sir_method <- function(method_short,
}
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %unlike% "EUCAST") {
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.",
add_fn = font_red
)
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.")
}
}
@@ -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)) {
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 {
# 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
print.sir_log <- function(x, ...) {
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))
}
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_ref <- vapply(FUN.VALUE = character(1), reference_data, function(x) paste0("<", class(x), ">", collapse = " and "))
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)) {
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)
}
}
}