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

(v3.0.0.9036) Modernise messaging infrastructure to use cli markup (#265)

Browse Source 
* Modernise messaging infrastructure with cli support

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

* Replace {.fun} with {.help} for all exported functions in messaging

All function names referenced via {.fun …} in cli-style messages are
exported in NAMESPACE, so {.help …} is the appropriate markup — it
renders as a clickable help link rather than plain function styling.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Qualify all {.help} tags with AMR:: and convert backtick ?func references

- Add AMR:: namespace prefix and trailing () to all {.help} cli markup
  so they render as clickable help links (e.g. {.help AMR::as.sir}())
- Convert `?funcname` backtick-quoted help references to {.help AMR::funcname}()
  in aa_helper_functions.R, custom_eucast_rules.R, interpretive_rules.R,
  key_antimicrobials.R, mo.R, plotting.R, resistance_predict.R, and sir.R
- Skipped `?proportion` in sir_calc.R as 'proportion' is not exported

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Require cli >= 3.0.0 for cli_inform/cli_warn/cli_abort availability checks

cli_inform, cli_warn, and cli_abort were introduced in cli 3.0.0.
Add min_version = "3.0.0" (as character) to all four pkg_is_available("cli")
checks so older cli versions fall back to base R messaging.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Implement cli::code_highlight() for R code examples in messages (issue #191)

Add highlight_code() helper that wraps cli::code_highlight() when cli >= 3.0.0
is available, falling back to plain code otherwise. Apply it to all inline
R code examples embedded in message/warning/stop strings across the package.

Also convert remaining backtick-quoted function and argument references in
messaging calls to proper cli markup: {.help AMR::fn}(), {.arg arg},
{.code expr}, and {.pkg pkg} throughout ab.R, ab_from_text.R, av_from_text.R,
amr_selectors.R, count.R, custom_antimicrobials.R, custom_microorganisms.R,
interpretive_rules.R, mo.R, mo_property.R, sir.R, sir_calc.R.

Fixes #191

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Fix {.help} markup to use correct cli link format [{.fun fn}](AMR::fn)

Replace all instances of {.help AMR::fn}() (incorrect format with manual
parentheses outside the link) with {.help [{.fun fn}](AMR::fn)} which is
the correct cli hyperlink syntax: the display text [{.fun fn}] renders the
function name with parentheses automatically, and (AMR::fn) is the link target.

Also update the plain-text fallback handler in aa_helper_functions.R to
extract the display text from the [text](topic) markdown link format,
so that non-cli environments show just the function name (e.g. `fn()`),
not the raw link markup.

Dynamic cases in amr_selectors.R and mo_property.R also updated.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Add {.topic} markup for non-function help page references

Replace {.code ?AMR-options} and backtick-style ?AMR-options / ?AMR-deprecated
references with proper {.topic AMR-options} / {.topic AMR-deprecated} cli markup
in count.R, interpretive_rules.R, proportion.R, and zz_deprecated.R.

Add {.topic} fallback handler to format_message() in aa_helper_functions.R:
plain-text environments render {.topic foo} as ?foo, and the [text](topic)
link form extracts just the display text (same pattern as {.help}).

Also convert remaining backtick function/arg references in proportion.R to
{.help [{.fun ...}](AMR::...)}, {.arg}, and {.code} markup for consistency.

Note: zzz.R intentionally keeps the backtick form since its startup message
goes through packageStartupMessage() which bypasses our cli infrastructure.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Fix {.topic} to use required pkg::topic format with display text

{.topic} in cli requires a package-qualified topic reference to generate
a valid x-r-help:pkg::topic URI. Bare {.topic AMR-options} produced a
malformed x-r-help:AMR-options URI (no package prefix).

Use the [display_text](pkg::topic) form throughout:
  {.topic [AMR-options](AMR::AMR-options)}
  {.topic [AMR-deprecated](AMR::AMR-deprecated)}

The hyphen in the topic name is fine as a URI string even though
AMR::AMR-options is not a valid R symbol expression.

The fallback handler in format_message() already handles the [text](uri)
form by extracting the display text, so plain-text output is unchanged.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Fix regexec() calls: remove perl=TRUE unsupported in older R

regexec() only gained the perl argument in R 4.1.0. The CI matrix
covers oldrel-1 through oldrel-4 (R 3.x/4.0.x), so perl=TRUE caused
an 'unused argument' error on every message_() call in those
environments.

All four affected regexec() calls use POSIX-extended compatible
patterns, so dropping perl=TRUE is safe.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Slim CI matrix for PRs to ubuntu-latest / r-release only

For pull requests, check-recent now runs a single job (ubuntu-latest,
r-release) via a setup job that emits the matrix as JSON. On push and
schedule the full matrix is unchanged (devel + release on all OSes,
oldrel-1 through oldrel-4).

Also removed the pull_request trigger from check-recent-dev-pkgs; the
dev-packages check only needs to run on push/schedule.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Restrict dev-versions and old-tinytest CI to main branch only

Both workflows were triggering on every push to every branch.
Narrowed push trigger to [main] so they only run after merging,
not on every feature/PR branch push.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Update NEWS.md to continuous log + add concise style rules to CLAUDE.md

NEWS.md is now a single continuous log under one heading per dev series,
not a new section per version bump. CLAUDE.md documents: only replace
line 1 (heading), append new entries, keep them extremely concise with
no trailing full stop.

Merged 9035 and 9036 entries into one section; condensed verbose 9036
bullets; added CI workflow change entry.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Replace single-quoted literals in messaging calls with cli markup

Converted bare 'value' strings inside stop_(), warning_(), message_()
to appropriate cli markup:
- {.val}: option values ('drug', 'dose', 'administration', 'SDD', 'logbook')
- {.cls}: class names ('sir', 'mo')
- {.field}: column names ('mo' in mo_source)
- {.code}: object/dataset names ('clinical_breakpoints')

Files changed: ab_from_text.R, av_from_text.R, sir.R, sir_calc.R, mo_source.R

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Apply {.topic}, {.cls}, and {.field} markup in sir.R messaging

- 'clinical_breakpoints' (dataset): {.code} -> {.topic [clinical_breakpoints](AMR::clinical_breakpoints)}
- "is of class" context: extract bad_col/bad_cls/exp_cls vars and use {.cls} + {.field} in glue syntax
- Column references in as.sir() messages: font_bold(col) with surrounding quotes -> {.field {col}}

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Replace glue-style dynamic markup with paste0() construction

{.field {variable}} and {.cls {variable}} patterns rely on glue
evaluation which is not safe in a zero-dependency package. Replace
all four occurrences with paste0("{.field ", var, "}") so the value
is baked into the markup string before reaching message_()/stop_().

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Limit push trigger to main in check-recent workflow

push: branches: '**' caused both the push event (9-worker matrix) and
the pull_request event (1-worker matrix) to fire simultaneously on every
PR commit. Restricting push to [main] means PR pushes only trigger the
pull_request path (1 worker), while direct pushes to main still get the
full 9-worker matrix.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Limit push trigger to main in code-coverage workflow

Same fix as check-recent: push: branches: '**' caused the workflow to
run twice per PR commit (once for push, once for pull_request). Restricting
push to [main] ensures coverage runs only once per PR update.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Replace bare backticks with cli inline markup across all messaging calls

- {.arg} for argument names in stop_/warning_/message_ calls
- {.cls} after "of class" text in format_class() and elsewhere
- {.fun} for function names (replaces `fn()` pattern)
- {.pkg} for tidyverse package names (dplyr, ggplot2)
- {.code} for code literals (TRUE, FALSE, expressions)
- Rewrite print.ab: use cli named-vector with * bullets and code
  highlighting when cli >= 3.0.0; keep plain-text fallback otherwise
- Fix typo in as.sir(): "of must be" -> "or must be"
- switch sir.R verbose notes from message() to message_()

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* Pre-evaluate inline expressions, add format_inline_(), fix print.ab

- All bare {variable}/{expression} in message_()/warning_()/stop_() calls
  are now pre-evaluated via paste0(), so users without cli/glue never see
  raw template syntax (mo_source.R, first_isolate.R, join_microorganisms.R,
  antibiogram.R, atc_online.R)
- Add format_inline_() helper: formats a cli-markup string and returns it
  (not emits it), using cli::format_inline() when available and cli_to_plain()
  otherwise
- Rewrite .onAttach to use format_inline_() for all packageStartupMessage
  calls; also adds {.topic} link and {.code} markup for option names
- print.ab: pre-evaluate function_name via paste0 (no .envir needed),
  apply highlight_code() to each example bullet for R syntax highlighting
- join_microorganisms: pre-evaluate {type} and {nrow(...)} expressions

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* fixes

* Replace all "in \`funcname()\`:" with {.help [{.fun funcname}](AMR::funcname)}

Converts all "in `funcname()`:" prefixes in warning_()/message_()/stop_()
calls to the full {.help} link format for clickable help in supported
terminals. Also fixes adjacent backtick argument names to {.arg}.

Files changed: ab.R, ab_property.R, av.R, av_property.R, antibiogram.R,
key_antimicrobials.R, mdro.R, mic.R, mo.R, plotting.R

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b

* fixes

* definitive

* version fix

---------

Co-authored-by: Claude <noreply@anthropic.com>
This commit is contained in:
Matthijs Berends
2026-03-20 17:01:34 +01:00
committed by GitHub
parent 8439e9c1d2
commit 4171d5b778
50 changed files with 567 additions and 546 deletions
Download Patch File Download Diff File Expand all files Collapse all files

354
R/aa_helper_functions.R
View File

@@ -304,9 +304,9 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
if (!is.null(found)) {
# this column should contain logicals
if (!is.logical(x[, found, drop = TRUE])) {
message_("Column '", font_bold(found), "' found as input for `", ifelse(add_col_prefix, "col_", ""), type,
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.",
add_fn = font_red
message_(
"Column '", font_bold(found), "' found as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type,
"}, but this column does not contain {.code TRUE}/{.code FALSE} values and was ignored."
)
found <- NULL
}
@@ -383,11 +383,32 @@ pkg_is_available <- function(pkg, also_load = FALSE, min_version = NULL) {
isTRUE(out)
}
highlight_code <- function(code) {
if (pkg_is_available("cli", min_version = "3.0.0")) {
cli::code_highlight(code)
} else {
code
}
}
# Format a cli-markup string for output, with a plain-text fallback when cli is
# unavailable. Unlike message_() / warning_() / stop_(), this function returns
# the formatted string rather than emitting it, so it can be passed to any
# output function (e.g. packageStartupMessage()).
format_inline_ <- function(...) {
msg <- paste0(c(...), collapse = "")
if (pkg_is_available("cli", min_version = "3.0.0")) {
cli::format_inline(msg)
} else {
cli_to_plain(msg, envir = parent.frame())
}
}
import_fn <- function(name, pkg, error_on_fail = TRUE) {
if (isTRUE(error_on_fail)) {
stop_ifnot_installed(pkg)
}
if (pkg == "rstudioapi" && !in_rstudio()) {
if (pkg == "rstudioapi" && (!in_rstudio() || !interactive())) {
# only allow rstudioapi to be imported if we're in RStudio
return(NULL)
}
@@ -397,8 +418,8 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
getExportedValue(name = name, ns = asNamespace(pkg)),
error = function(e) {
if (isTRUE(error_on_fail)) {
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!",
stop_("function {.code ", name, "()} is not an exported object from package '", pkg,
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
call = FALSE
)
} else {
@@ -408,30 +429,108 @@ 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)
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) {
# Handle [display text](topic) markdown link format: extract just the display text
m <- regmatches(c, regexec("^\\[(.*)\\]\\([^)]*\\)$", c))[[1L]]
if (length(m) >= 2L) m[2L] else paste0("`", resolve(c), "`")
})
msg <- apply_sub(msg, "\\{\\.topic ([^}]+)\\}", function(c) {
# Handle [display text](topic) markdown link format: extract just the display text
m <- regmatches(c, regexec("^\\[(.*)\\]\\([^)]*\\)$", c))[[1L]]
if (length(m) >= 2L) m[2L] else paste0("?", resolve(c))
})
msg <- apply_sub(msg, "\\{\\.url (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
msg <- apply_sub(msg, "\\{\\.href ([^}]+)\\}", function(c) strsplit(resolve(c), " ", fixed = TRUE)[[1L]][1L])
# bare {variable} or {expression} -> evaluate in caller's environment
while (grepl("\\{[^{}]+\\}", msg)) {
m <- regexec("\\{([^{}]+)\\}", msg)
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:
# - wraps text to never break lines within words
# - ignores formatted text while wrapping
# - adds indentation dependent on the type of message (such as NOTE)
# - can add additional formatting functions like blue or bold text
# - wraps text to never break lines within words (plain-text fallback only)
# - adds indentation for note-style messages (plain-text fallback only)
# When cli is available this just returns the pasted input; cli handles formatting.
word_wrap <- function(...,
add_fn = list(),
as_note = FALSE,
width = 0.95 * getOption("width"),
extra_indent = 0) {
if (pkg_is_available("cli", min_version = "3.0.0")) {
return(paste0(c(...), collapse = ""))
}
msg <- paste0(c(...), collapse = "")
if (isTRUE(as_note)) {
msg <- paste0(AMR_env$info_icon, " ", gsub("^note:? ?", "", msg, ignore.case = TRUE))
}
if (msg %like% "\n") {
# run word_wraps() over every line here, bind them and return again
if (grepl("\n", msg, fixed = TRUE)) {
return(paste0(
vapply(
FUN.VALUE = character(1),
trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"),
word_wrap,
add_fn = add_fn,
as_note = FALSE,
width = width,
extra_indent = extra_indent
@@ -439,146 +538,75 @@ word_wrap <- function(...,
collapse = "\n"
))
}
# correct for operators (will add the space later on)
ops <- "([,./><\\]\\[])"
msg <- gsub(paste0(ops, " ", ops), "\\1\\2", msg, perl = TRUE)
# we need to correct for already applied style, that adds text like "\033[31m\"
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
wrapped <- paste0(strwrap(msg, width = width), collapse = "\n")
if (grepl("\u2139 ", msg, fixed = TRUE)) {
indentation <- 2L + extra_indent
} else if (grepl("^=> ", msg)) {
indentation <- 3L + extra_indent
} else {
indentation <- 0 + extra_indent
indentation <- 0L + extra_indent
}
msg <- gsub("\n", paste0("\n", strrep(" ", indentation)), msg, fixed = TRUE)
# remove trailing empty characters
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)
}
if (indentation > 0L) {
wrapped <- gsub("\n", paste0("\n", strrep(" ", indentation)), wrapped, fixed = TRUE)
}
# 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
gsub("(\n| )+$", "", wrapped)
}
message_ <- function(...,
appendLF = TRUE,
add_fn = list(font_blue),
as_note = TRUE) {
message(
word_wrap(...,
add_fn = add_fn,
as_note = as_note
),
appendLF = appendLF
)
if (pkg_is_available("cli", min_version = "3.0.0")) {
msg <- paste0(c(...), collapse = "")
if (isTRUE(as_note)) {
cli::cli_inform(c("i" = msg), .envir = parent.frame())
} else {
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(...,
add_fn = list(),
immediate = FALSE,
call = FALSE) {
warning(
trimws2(word_wrap(...,
add_fn = add_fn,
as_note = FALSE
)),
immediate. = immediate,
call. = call
)
if (pkg_is_available("cli", min_version = "3.0.0")) {
msg <- paste0(c(...), collapse = "")
cli::cli_warn(msg, .envir = parent.frame())
} else {
plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
warning(trimws2(word_wrap(plain_msg, as_note = FALSE)), immediate. = immediate, call. = call)
}
}
# this alternative to the stop() function:
# - adds the function name where the error was thrown
# - wraps text to never break lines within words
# - adds the function name where the error was thrown (plain-text fallback)
# - wraps text to never break lines within words (plain-text fallback)
stop_ <- function(..., call = TRUE) {
msg <- paste0(c(...), collapse = "")
msg_call <- ""
if (!isFALSE(call)) {
if (pkg_is_available("cli", min_version = "3.0.0")) {
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 {
# 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 <- as.character(sys.call(call)[1])
call_obj <- NULL
}
msg_call <- paste0("in ", call, "():")
}
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)
cli::cli_abort(msg, call = call_obj, .envir = parent.frame())
} 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 +649,7 @@ stop_ifnot <- function(expr, ..., call = TRUE) {
return_after_integrity_check <- function(value, type, 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
@@ -757,7 +785,7 @@ format_class <- function(class, plural = FALSE) {
ifelse(plural, "s", "")
)
# exceptions
class[class == "logical"] <- ifelse(plural, "a vector of `TRUE`/`FALSE`", "`TRUE` or `FALSE`")
class[class == "logical"] <- ifelse(plural, "a vector of {.code TRUE}/{.code FALSE}", "{.code TRUE} or {.code FALSE}")
class[class == "data.frame"] <- "a data set"
if ("list" %in% class) {
class <- "a list"
@@ -766,12 +794,12 @@ format_class <- function(class, plural = FALSE) {
class <- "a matrix"
}
if ("custom_eucast_rules" %in% class) {
class <- "input created with `custom_eucast_rules()`"
class <- "input created with {.fun custom_eucast_rules}"
}
if (any(c("mo", "ab", "sir") %in% class)) {
class <- paste0("of class '", class[1L], "'")
class <- paste0("of class {.cls ", class[1L], "}")
}
class[class == class.bak] <- paste0("of class '", class[class == class.bak], "'")
class[class == class.bak] <- paste0("of class {.cls ", class[class == class.bak], "}")
# output
vector_or(class, quotes = FALSE, sort = FALSE)
}
@@ -806,11 +834,11 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
AMR_env$meet_criteria_error_txt <- NULL
if (is.null(object)) {
stop_if(allow_NULL == FALSE, "argument `", obj_name, "` must not be NULL", call = call_depth)
stop_if(allow_NULL == FALSE, "argument {.arg ", obj_name, "} must not be NULL", call = call_depth)
return(invisible())
}
if (is.null(dim(object)) && length(object) == 1 && suppressWarnings(is.na(object))) { # suppressWarnings for functions
stop_if(allow_NA == FALSE, "argument `", obj_name, "` must not be NA", call = call_depth)
stop_if(allow_NA == FALSE, "argument {.arg ", obj_name, "} must not be NA", call = call_depth)
return(invisible())
}
@@ -820,32 +848,32 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
}
if (!is.null(allow_class) && !(suppressWarnings(all(is.na(object))) && allow_NA == TRUE)) {
stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
"` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
stop_ifnot(inherits(object, allow_class), "argument {.arg ", obj_name,
"} must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)),
call = call_depth
)
# check data.frames for data
if (inherits(object, "data.frame")) {
stop_if(any(dim(object) == 0),
"the data provided in argument `", obj_name,
"` must contain rows and columns (current dimensions: ",
"the data provided in argument {.arg ", obj_name,
"} must contain rows and columns (current dimensions: ",
paste(dim(object), collapse = "x"), ")",
call = call_depth
)
}
}
if (!is.null(has_length)) {
stop_ifnot(length(object) %in% has_length, "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
stop_ifnot(length(object) %in% has_length, "argument {.arg ", obj_name,
"} must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"be of length ", vector_or(has_length, quotes = FALSE),
", not ", length(object),
call = call_depth
)
}
if (!is.null(looks_like)) {
stop_ifnot(object %like% looks_like, "argument `", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
stop_ifnot(object %like% looks_like, "argument {.arg ", obj_name,
"} must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"resemble the regular expression \"", looks_like, "\"",
call = call_depth
)
@@ -863,7 +891,7 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
if ("logical" %in% allow_class) {
or_values <- paste0(or_values, ", or TRUE or FALSE")
}
stop_ifnot(all(object %in% is_in.bak, na.rm = TRUE), "argument `", obj_name, "` ",
stop_ifnot(all(object %in% is_in.bak, na.rm = TRUE), "argument {.arg ", obj_name, "} ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"must be either ",
"must only contain values "
@@ -874,8 +902,8 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
)
}
if (isTRUE(is_positive)) {
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name,
"` must ",
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument {.arg ", obj_name,
"} must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a number higher than zero",
"all be numbers higher than zero"
@@ -884,8 +912,8 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
)
}
if (isTRUE(is_positive_or_zero)) {
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name,
"` must ",
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument {.arg ", obj_name,
"} must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be zero or a positive number",
"all be zero or numbers higher than zero"
@@ -894,8 +922,8 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
)
}
if (isTRUE(is_finite)) {
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name,
"` must ",
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument {.arg ", obj_name,
"} must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a finite number",
"all be finite numbers"
@@ -929,9 +957,9 @@ ascertain_sir_classes <- function(x, obj_name) {
sirs <- vapply(FUN.VALUE = logical(1), x, is.sir)
if (!any(sirs, na.rm = TRUE)) {
warning_(
"the data provided in argument `", obj_name,
"` should contain at least one column of class 'sir'. Eligible SIR column were now guessed. ",
"See `?as.sir`.",
"the data provided in argument {.arg ", obj_name,
"} should contain at least one column of class {.cls sir}. Eligible SIR columns were now guessed. ",
"See {.help [{.fun as.sir}](AMR::as.sir)}.",
immediate = TRUE
)
sirs_eligible <- is_sir_eligible(x)
@@ -1033,13 +1061,13 @@ get_current_data <- function(arg_name, call) {
} else {
examples <- ""
}
stop_("this function must be used inside a `dplyr` verb or `data.frame` call",
stop_("this function must be used inside a {.pkg dplyr} verb or {.cls data.frame} call",
examples,
call = call
)
} else {
# mimic a base R error that the argument is missing
stop_("argument `", arg_name, "` is missing with no default", call = call)
stop_("argument {.arg ", arg_name, "} is missing with no default", call = call)
}
}
@@ -1633,7 +1661,7 @@ if (!is.null(import_fn("where", "tidyselect", error_on_fail = FALSE))) {
where <- function(fn) {
# based on https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
if (!is.function(fn)) {
stop_("`", deparse(substitute(fn)), "()` is not a valid predicate function.")
stop_("{.fun ", deparse(substitute(fn)), "} is not a valid predicate function.")
}
df <- pm_select_env$.data
cols <- pm_select_env$get_colnames()
@@ -1648,7 +1676,7 @@ if (!is.null(import_fn("where", "tidyselect", error_on_fail = FALSE))) {
},
fn
))
if (!is.logical(preds)) stop_("`where()` must be used with functions that return `TRUE` or `FALSE`.")
if (!is.logical(preds)) stop_("{.fun where} must be used with functions that return {.code TRUE} or {.code FALSE}.")
data_cols <- cols
cols <- data_cols[preds]
which(data_cols %in% cols)