From 4171d5b778901ed6fb25ef217e7e90bcab372d5e Mon Sep 17 00:00:00 2001 From: Matthijs Berends <31037261+msberends@users.noreply.github.com> Date: Fri, 20 Mar 2026 17:01:34 +0100 Subject: [PATCH] (v3.0.0.9036) Modernise messaging infrastructure to use cli markup (#265) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * 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 --- .../check-current-testthat-dev-versions.yaml | 5 +- .github/workflows/check-current-testthat.yaml | 38 +- .github/workflows/check-old-tinytest.yaml | 4 +- .github/workflows/codecovr.yaml | 6 +- CLAUDE.md | 7 +- DESCRIPTION | 7 +- NEWS.md | 3 +- R/aa_helper_functions.R | 354 ++++++++++-------- R/ab.R | 50 ++- R/ab_from_text.R | 2 +- R/ab_property.R | 12 +- R/age.R | 12 +- R/amr_selectors.R | 8 +- R/antibiogram.R | 24 +- R/atc_online.R | 3 +- R/av.R | 4 +- R/av_from_text.R | 2 +- R/av_property.R | 8 +- R/bug_drug_combinations.R | 6 +- R/count.R | 4 +- R/custom_antimicrobials.R | 4 +- R/custom_eucast_rules.R | 8 +- R/custom_mdro_guideline.R | 21 +- R/custom_microorganisms.R | 8 +- R/disk.R | 2 +- R/first_isolate.R | 57 ++- R/get_episode.R | 2 +- R/ggplot_sir.R | 2 +- R/guess_ab_col.R | 14 +- R/interpretive_rules.R | 58 ++- R/join_microorganisms.R | 6 +- R/key_antimicrobials.R | 10 +- R/mdro.R | 30 +- R/mic.R | 10 +- R/mo.R | 149 ++++---- R/mo_property.R | 8 +- R/mo_source.R | 7 +- R/pca.R | 2 +- R/plotting.R | 12 +- R/proportion.R | 4 +- R/resistance_predict.R | 8 +- R/sir.R | 69 ++-- R/sir_calc.R | 15 +- R/top_n_microorganisms.R | 2 +- R/translate.R | 8 +- R/zz_deprecated.R | 2 +- R/zzz.R | 21 +- tests/testthat/test-mo.R | 4 +- tests/testthat/test-proportion.R | 1 - tests/testthat/test-zzz.R | 10 +- 50 files changed, 567 insertions(+), 546 deletions(-) diff --git a/.github/workflows/check-current-testthat-dev-versions.yaml b/.github/workflows/check-current-testthat-dev-versions.yaml index 5d3b4dc55..ea4bc6f04 100644 --- a/.github/workflows/check-current-testthat-dev-versions.yaml +++ b/.github/workflows/check-current-testthat-dev-versions.yaml @@ -28,11 +28,8 @@ # ==================================================================== # on: - pull_request: - # run in each PR in this repo - branches: '**' push: - branches: '**' + branches: [main] schedule: # also run a schedule everyday at 1 AM. # this is to check that all dependencies are still available (see R/zzz.R) diff --git a/.github/workflows/check-current-testthat.yaml b/.github/workflows/check-current-testthat.yaml index d59035888..0a318cc8d 100644 --- a/.github/workflows/check-current-testthat.yaml +++ b/.github/workflows/check-current-testthat.yaml @@ -29,10 +29,11 @@ on: pull_request: - # run in each PR in this repo + # run in each PR in this repo (1 worker, see matrix logic below) branches: '**' push: - branches: '**' + # only on main; pushing to a PR branch is already covered by pull_request above + branches: [main] schedule: # also run a schedule everyday at 1 AM. # this is to check that all dependencies are still available (see R/zzz.R) @@ -41,7 +42,22 @@ on: name: check-recent jobs: + setup: + runs-on: ubuntu-latest + outputs: + matrix: ${{ steps.set-matrix.outputs.matrix }} + steps: + - id: set-matrix + shell: bash + run: | + if [ "${{ github.event_name }}" = "pull_request" ]; then + echo 'matrix={"config":[{"os":"ubuntu-latest","r":"release","allowfail":false}]}' >> "$GITHUB_OUTPUT" + else + echo 'matrix={"config":[{"os":"windows-latest","r":"devel","allowfail":false},{"os":"ubuntu-latest","r":"devel","allowfail":false,"http-user-agent":"release"},{"os":"macOS-latest","r":"release","allowfail":true},{"os":"windows-latest","r":"release","allowfail":false},{"os":"ubuntu-latest","r":"release","allowfail":false},{"os":"ubuntu-latest","r":"oldrel-1","allowfail":false},{"os":"ubuntu-latest","r":"oldrel-2","allowfail":false},{"os":"ubuntu-latest","r":"oldrel-3","allowfail":false},{"os":"ubuntu-latest","r":"oldrel-4","allowfail":false}]}' >> "$GITHUB_OUTPUT" + fi + R-code-check: + needs: setup runs-on: ${{ matrix.config.os }} continue-on-error: ${{ matrix.config.allowfail }} @@ -50,23 +66,7 @@ jobs: strategy: fail-fast: false - matrix: - config: - # current development version, check all major OSes: - # - {os: macOS-latest, r: 'devel', allowfail: true} - - {os: windows-latest, r: 'devel', allowfail: false} - - {os: ubuntu-latest, r: 'devel', allowfail: false, http-user-agent: 'release'} - - # current 'release' version, check all major OSes: - - {os: macOS-latest, r: 'release', allowfail: true} - - {os: windows-latest, r: 'release', allowfail: false} - - {os: ubuntu-latest, r: 'release', allowfail: false} - - # older versions (see also check-old-tinytest.yaml for even older versions): - - {os: ubuntu-latest, r: 'oldrel-1', allowfail: false} - - {os: ubuntu-latest, r: 'oldrel-2', allowfail: false} - - {os: ubuntu-latest, r: 'oldrel-3', allowfail: false} - - {os: ubuntu-latest, r: 'oldrel-4', allowfail: false} + matrix: ${{ fromJSON(needs.setup.outputs.matrix) }} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} diff --git a/.github/workflows/check-old-tinytest.yaml b/.github/workflows/check-old-tinytest.yaml index 4ad26b4b3..f6f97c3a5 100644 --- a/.github/workflows/check-old-tinytest.yaml +++ b/.github/workflows/check-old-tinytest.yaml @@ -29,8 +29,8 @@ on: push: - # only run after a git push on any branch in this repo - branches: '**' + # only run after a git push on the main branch + branches: [main] name: check-old diff --git a/.github/workflows/codecovr.yaml b/.github/workflows/codecovr.yaml index f618bad32..5c9004f67 100644 --- a/.github/workflows/codecovr.yaml +++ b/.github/workflows/codecovr.yaml @@ -28,10 +28,12 @@ # ==================================================================== # on: - push: - branches: '**' pull_request: + # run on every PR update (once per push) branches: '**' + push: + # only on main; PR pushes are already covered by pull_request above + branches: [main] name: code-coverage diff --git a/CLAUDE.md b/CLAUDE.md index 3c8878bf5..4892f3c00 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -166,7 +166,12 @@ echo "$currentversion" The `+ 1` accounts for the fact that this PR's squash commit is not yet on the default branch. Set **both** of these files to the resulting version string (and only once per PR, even across multiple commits): 1. **`DESCRIPTION`** — the `Version:` field -2. **`NEWS.md`** — the top-level heading `# AMR ` +2. **`NEWS.md`** — **only replace line 1** (the `# AMR ` heading) with the new version number; do **not** create a new section. `NEWS.md` is a **continuous log** for the entire current `x.y.z.9nnn` development series: all changes since the last stable release accumulate under that single heading. After updating line 1, append the new change as a bullet under the appropriate sub-heading (`### New`, `### Fixes`, or `### Updates`). + + Style rules for `NEWS.md` entries: + - Be **extremely concise** — one short line per item + - Do **not** end with a full stop (period) + - No verbose explanations; just the essential fact If `git describe` fails (e.g. no tags exist in the environment), fall back to reading the current version from `DESCRIPTION` and adding 1 to the last numeric component — but only if no bump has already been made in this PR. diff --git a/DESCRIPTION b/DESCRIPTION index 2a0c9e10d..327fef431 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: AMR -Version: 3.0.1.9035 -Date: 2026-03-18 +Version: 3.0.1.9036 +Date: 2026-03-19 Title: Antimicrobial Resistance Data Analysis Description: Functions to simplify and standardise antimicrobial resistance (AMR) data analysis and to work with microbial and antimicrobial properties by @@ -63,7 +63,8 @@ Suggests: tidyselect, tinytest, vctrs, - xml2 + xml2, + usethis VignetteBuilder: knitr,rmarkdown URL: https://amr-for-r.org, https://github.com/msberends/AMR BugReports: https://github.com/msberends/AMR/issues diff --git a/NEWS.md b/NEWS.md index ac9a03389..e3faf456c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# AMR 3.0.1.9035 +# AMR 3.0.1.9036 ### New * Integration with the **tidymodels** framework to allow seamless use of SIR, MIC and disk data in modelling pipelines via `recipes` @@ -30,6 +30,7 @@ * Fixed SIR and MIC coercion of combined values, e.g. `as.sir("<= 0.002; S") ` or `as.mic("S; 0.002")` (#252) ### Updates +* Extensive `cli` integration for better message handling and clickable links in messages and warnings (#191, #265) * `mdro()` now infers resistance for a _missing_ base drug column from an _available_ corresponding drug+inhibitor combination showing resistance (e.g., piperacillin is absent but required, while piperacillin/tazobactam available and resistant). Can be set with the new argument `infer_from_combinations`, which defaults to `TRUE` (#209). Note that this can yield a higher MDRO detection (which is a good thing as it has become more reliable). * `susceptibility()` and `resistance()` gained the argument `guideline`, which defaults to EUCAST, for interpreting the 'I' category correctly. * Added to the `antimicrobials` data set: cefepime/taniborbactam (`FTA`), ceftibuten/avibactam (`CTA`), clorobiocin (`CLB`), kasugamycin (`KAS`), ostreogrycin (`OST`), taniborbactam (`TAN`), thiostrepton (`THS`), xeruborbactam (`XER`), and zorbamycin (`ZOR`) diff --git a/R/aa_helper_functions.R b/R/aa_helper_functions.R index a64529ff8..5b8090ab0 100644 --- a/R/aa_helper_functions.R +++ b/R/aa_helper_functions.R @@ -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) diff --git a/R/ab.R b/R/ab.R index cd8a2d43b..a67b53cb4 100755 --- a/R/ab.R +++ b/R/ab.R @@ -191,12 +191,13 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(), x_new[known_codes_cid] <- AMR_env$AB_lookup$ab[match(x[known_codes_cid], AMR_env$AB_lookup$cid)] previously_coerced <- x %in% AMR_env$ab_previously_coerced$x x_new[previously_coerced & is.na(x_new)] <- AMR_env$ab_previously_coerced$ab[match(x[is.na(x_new) & x %in% AMR_env$ab_previously_coerced$x], AMR_env$ab_previously_coerced$x)] - previously_coerced_mention <- x %in% AMR_env$ab_previously_coerced$x & !x %in% AMR_env$AB_lookup$ab & !x %in% AMR_env$AB_lookup$generalised_name + previously_coerced_mention <- !is.na(x) & x %in% AMR_env$ab_previously_coerced$x & !x %in% AMR_env$AB_lookup$ab & !x %in% AMR_env$AB_lookup$generalised_name if (any(previously_coerced_mention) && isTRUE(info) && message_not_thrown_before("as.ab", entire_session = TRUE)) { + only_one <- length(unique(which(x[which(previously_coerced)] %in% x_bak_clean))) == 1 message_( - "Returning previously coerced ", - ifelse(length(unique(which(x[which(previously_coerced)] %in% x_bak_clean))) > 1, "value for an antimicrobial", "values for various antimicrobials"), - ". Run `ab_reset_session()` to reset this. This note will be shown once per session." + "Returning ", ifelse(only_one, "a ", ""), "previously coerced ", + ifelse(only_one, "value for an antimicrobial", "values for various antimicrobials"), + ". Run {.help [{.fun ab_reset_session}](AMR::ab_reset_session)} to reset this. This note will be shown once per session." ) } @@ -210,7 +211,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(), progress <- progress_ticker(n = sum(!already_known), n_min = 25, print = info) # start if n >= 25 on.exit(close(progress)) if (any(x_new[!already_known & !is.na(x_new)] %in% unlist(AMR_env$AV_lookup$generalised_all, use.names = FALSE), na.rm = TRUE)) { - warning_("in `as.ab()`: some input seems to resemble antiviral drugs - use `as.av()` or e.g. `av_name()` for these, not `as.ab()` or e.g. `ab_name()`.") + warning_("in {.help [{.fun as.ab}](AMR::as.ab)}: some input seems to resemble antiviral drugs - use {.help [{.fun as.av}](AMR::as.av)} or e.g. {.help [{.fun av_name}](AMR::av_name)} for these, not {.help [{.fun as.ab}](AMR::as.ab)} or e.g. {.help [{.fun ab_name}](AMR::ab_name)}.") } } @@ -444,7 +445,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(), # take failed ATC codes apart from rest if (length(x_unknown_ATCs) > 0 && fast_mode == FALSE) { warning_( - "in `as.ab()`: these ATC codes are not (yet) in the antimicrobials data set: ", + "in {.help [{.fun as.ab}](AMR::as.ab)}: these ATC codes are not (yet) in the antimicrobials data set: ", vector_and(x_unknown_ATCs), "." ) } @@ -458,12 +459,14 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(), x_unknown <- x_unknown[!x_unknown %in% c("", NA)] if (length(x_unknown) > 0 && fast_mode == FALSE) { warning_( - "in `as.ab()`: ", ifelse(length(unique(x_unknown)) == 1, "this value", "these values"), " could not be coerced to a valid antimicrobial ID: ", + "in {.help [{.fun as.ab}](AMR::as.ab)}: ", ifelse(length(unique(x_unknown)) == 1, "this value", "these values"), " could not be coerced to a valid antimicrobial ID: ", vector_and(x_unknown), "." ) } # Throw note about uncertainties + x_uncertain <- x_uncertain[!is.na(x_uncertain)] + AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[!is.na(AMR_env$ab_previously_coerced$x), ] if (isTRUE(info) && length(x_uncertain) > 0 && fast_mode == FALSE) { x_uncertain <- unique(x_uncertain) if (message_not_thrown_before("as.ab", "uncertainties", x_bak)) { @@ -481,7 +484,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(), } message_( "Antimicrobial translation was uncertain for ", examples, - ". If required, use `add_custom_antimicrobials()` to add custom entries." + ". If required, use {.help [{.fun add_custom_antimicrobials}](AMR::add_custom_antimicrobials)} to add custom entries." ) } } @@ -551,14 +554,25 @@ type_sum.ab <- function(x, ...) { print.ab <- function(x, ...) { if (!is.null(attributes(x)$amr_selector)) { function_name <- attributes(x)$amr_selector - message_( - "This 'ab' vector was retrieved using `", function_name, "()`, which should normally be used inside a `dplyr` verb or `data.frame` call, e.g.:\n", - " ", AMR_env$bullet_icon, " your_data %>% select(", function_name, "())\n", - " ", AMR_env$bullet_icon, " your_data %>% select(column_a, column_b, ", function_name, "())\n", - " ", AMR_env$bullet_icon, " your_data %>% filter(any(", function_name, "() == \"R\"))\n", - " ", AMR_env$bullet_icon, " your_data[, ", function_name, "()]\n", - " ", AMR_env$bullet_icon, " your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]" - ) + if (pkg_is_available("cli", min_version = "3.0.0")) { + cli::cli_inform(c( + "i" = paste0("This {.cls ab} vector was retrieved using {.fun ", function_name, "}, which should normally be used inside a {.pkg dplyr} verb or {.cls data.frame} call, e.g.:"), + paste0("\u00a0\u00a0", AMR_env$bullet_icon, " ", highlight_code(paste0("your_data %>% select(", function_name, "())"))), + paste0("\u00a0\u00a0", AMR_env$bullet_icon, " ", highlight_code(paste0("your_data %>% select(column_a, column_b, ", function_name, "())"))), + paste0("\u00a0\u00a0", AMR_env$bullet_icon, " ", highlight_code(paste0("your_data %>% filter(any(", function_name, "() == \"R\"))"))), + paste0("\u00a0\u00a0", AMR_env$bullet_icon, " ", highlight_code(paste0("your_data[, ", function_name, "()]"))), + paste0("\u00a0\u00a0", AMR_env$bullet_icon, " ", highlight_code(paste0("your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]"))) + )) + } else { + message(word_wrap(paste0( + "This 'ab' vector was retrieved using `", function_name, "()`, which should normally be used inside a dplyr verb or data.frame call, e.g.:\n", + "\u00a0\u00a0", AMR_env$bullet_icon, " your_data %>% select(", function_name, "())\n", + "\u00a0\u00a0", AMR_env$bullet_icon, " your_data %>% select(column_a, column_b, ", function_name, "())\n", + "\u00a0\u00a0", AMR_env$bullet_icon, " your_data %>% filter(any(", function_name, "() == \"R\"))\n", + "\u00a0\u00a0", AMR_env$bullet_icon, " your_data[, ", function_name, "()]\n", + "\u00a0\u00a0", AMR_env$bullet_icon, " your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]" + ), as_note = TRUE)) + } } cat("Class 'ab'\n") print(as.character(x), quote = FALSE) @@ -704,8 +718,8 @@ get_translate_ab <- function(translate_ab) { } else { translate_ab <- tolower(translate_ab) stop_ifnot(translate_ab %in% colnames(AMR::antimicrobials), - "invalid value for 'translate_ab', this must be a column name of the `antimicrobials` data set\n", - "or `TRUE` (equals 'name') or `FALSE` to not translate at all.", + "invalid value for {.arg translate_ab}, this must be a column name of the {.topic [antimicrobials](AMR::antimicrobials)} data set\n", + "or {.code TRUE} (equals {.val name}) or {.code FALSE} to not translate at all.", call = FALSE ) translate_ab diff --git a/R/ab_from_text.R b/R/ab_from_text.R index 1b0e77efa..c9705f1ae 100755 --- a/R/ab_from_text.R +++ b/R/ab_from_text.R @@ -212,7 +212,7 @@ ab_from_text <- function(text, } }) } else { - stop_("`type` must be either 'drug', 'dose' or 'administration'") + stop_("{.arg type} must be either {.val drug}, {.val dose} or {.val administration}") } # collapse text if needed diff --git a/R/ab_property.R b/R/ab_property.R index d31a2ea3e..3f90aa844 100755 --- a/R/ab_property.R +++ b/R/ab_property.R @@ -265,7 +265,7 @@ ab_ddd <- function(x, administration = "oral", ...) { if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) { warning_( - "in `ab_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.", + "in {.help [{.fun ab_ddd}](AMR::ab_ddd)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.", "Please refer to the WHOCC website:\n", "atcddd.fhi.no/ddd/list_of_ddds_combined_products/" ) @@ -285,7 +285,7 @@ ab_ddd_units <- function(x, administration = "oral", ...) { if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) { warning_( - "in `ab_ddd_units()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.", + "in {.help [{.fun ab_ddd_units}](AMR::ab_ddd_units)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.", "Please refer to the WHOCC website:\n", "atcddd.fhi.no/ddd/list_of_ddds_combined_products/" ) @@ -341,12 +341,12 @@ ab_url <- function(x, open = FALSE, ...) { NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(atcs)] if (length(NAs) > 0) { - warning_("in `ab_url()`: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".") + warning_("in {.fun ab_url}: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".") } if (open == TRUE) { if (length(u) > 1 && !is.na(u[1L])) { - warning_("in `ab_url()`: only the first URL will be opened, as `browseURL()` only suports one string.") + warning_("in {.fun ab_url}: only the first URL will be opened, as {.fun browseURL} only suports one string.") } if (!is.na(u[1L])) { utils::browseURL(u[1L]) @@ -397,7 +397,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale } vars <- get_column_abx(df, info = FALSE, only_sir_columns = FALSE, sort = FALSE, fn = "set_ab_names") if (length(vars) == 0) { - message_("No columns with antibiotic results found for `set_ab_names()`, leaving names unchanged.") + message_("No columns with antibiotic results found for {.fun set_ab_names}, leaving names unchanged.") return(data) } } else { @@ -424,7 +424,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale ) if (any(x %in% c("", NA))) { warning_( - "in `set_ab_names()`: no ", property, " found for column(s): ", + "in {.help [{.fun set_ab_names}](AMR::set_ab_names)}: no ", property, " found for column(s): ", vector_and(vars[x %in% c("", NA)], sort = FALSE) ) x[x %in% c("", NA)] <- vars[x %in% c("", NA)] diff --git a/R/age.R b/R/age.R index 9fb436466..1f6a5b6b0 100755 --- a/R/age.R +++ b/R/age.R @@ -67,7 +67,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) { } else if (length(reference) == 1) { reference <- rep(reference, length(x)) } else { - stop_("`x` and `reference` must be of same length, or `reference` must be of length 1.") + stop_("{.arg x} and {.arg reference} must be of same length, or {.arg reference} must be of length 1.") } } x <- as.POSIXlt(x, ...) @@ -109,10 +109,10 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) { if (any(ages < 0, na.rm = TRUE)) { ages[!is.na(ages) & ages < 0] <- NA - warning_("in `age()`: NAs introduced for ages below 0.") + warning_("in {.fun age}: NAs introduced for ages below 0.") } if (any(ages > 120, na.rm = TRUE)) { - warning_("in `age()`: some ages are above 120.") + warning_("in {.fun age}: some ages are above 120.") } if (isTRUE(na.rm)) { @@ -191,7 +191,7 @@ age_groups <- function(x, split_at = c(0, 12, 25, 55, 75), names = NULL, na.rm = if (any(x < 0, na.rm = TRUE)) { x[x < 0] <- NA - warning_("in `age_groups()`: NAs introduced for ages below 0.") + warning_("in {.fun age_groups}: NAs introduced for ages below 0.") } if (is.character(split_at)) { split_at <- split_at[1L] @@ -211,7 +211,7 @@ age_groups <- function(x, split_at = c(0, 12, 25, 55, 75), names = NULL, na.rm = split_at <- c(0, split_at) } split_at <- split_at[!is.na(split_at)] - stop_if(length(split_at) == 1, "invalid value for `split_at`.") # only 0 is available + stop_if(length(split_at) == 1, "invalid value for {.arg split_at}.") # only 0 is available # turn input values to 'split_at' indices y <- x @@ -228,7 +228,7 @@ age_groups <- function(x, split_at = c(0, 12, 25, 55, 75), names = NULL, na.rm = agegroups <- factor(lbls[y], levels = lbls, ordered = TRUE) if (!is.null(names)) { - stop_ifnot(length(names) == length(levels(agegroups)), "`names` must have the same length as the number of age groups (", length(levels(agegroups)), ").") + stop_ifnot(length(names) == length(levels(agegroups)), "{.arg names} must have the same length as the number of age groups (", length(levels(agegroups)), ").") levels(agegroups) <- names } diff --git a/R/amr_selectors.R b/R/amr_selectors.R index 1d3d99b99..c27f0f791 100755 --- a/R/amr_selectors.R +++ b/R/amr_selectors.R @@ -722,7 +722,7 @@ amr_select_exec <- function(function_name, if (any(untreatable %in% names(ab_in_data))) { if (message_not_thrown_before(function_name, "amr_class", "untreatable")) { warning_( - "in `", function_name, "()`: some drugs were ignored since they cannot be used for treatment: ", + "in {.help [{.fun ", function_name, "}](AMR::", function_name, ")}: some drugs were ignored since they cannot be used for treatment: ", vector_and( ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable], language = NULL, @@ -797,7 +797,7 @@ amr_select_exec <- function(function_name, if (only_treatable == TRUE) { if (message_not_thrown_before(function_name, "amr_class", "untreatable")) { message_( - "in `", function_name, "()`: ", + "in {.help [{.fun ", function_name, "}](AMR::", function_name, ")}: ", vector_and( paste0( ab_name(abx[abx %in% untreatable], @@ -837,7 +837,7 @@ amr_select_exec <- function(function_name, #' @export #' @noRd print.amr_selector <- function(x, ...) { - warning_("It should never be needed to print an antimicrobial selector class. Are you using data.table? Then add the argument `with = FALSE`, see our examples at `?amr_selector`.", + warning_("It should never be needed to print an antimicrobial selector class. Are you using {.pkg data.table}? Then add the argument {.code with = FALSE}, see our examples at {.help [{.fun amr_selector}](AMR::amr_selector)}.", immediate = TRUE ) cat("Class 'amr_selector'\n") @@ -1062,7 +1062,7 @@ message_agent_names <- function(function_name, agents, ab_group = NULL, examples if (message_not_thrown_before(function_name, sort(agents))) { if (length(agents) == 0) { if (is.null(ab_group)) { - message_("For `", function_name, "()` no antimicrobial drugs found", examples, ".") + message_("For {.help [{.fun ", function_name, "}](AMR::", function_name, ")} no antimicrobial drugs found", examples, ".") } else if (ab_group == "administrable_per_os") { message_("No orally administrable drugs found", examples, ".") } else if (ab_group == "administrable_iv") { diff --git a/R/antibiogram.R b/R/antibiogram.R index 1fffc1dd0..40bf874b8 100755 --- a/R/antibiogram.R +++ b/R/antibiogram.R @@ -445,7 +445,7 @@ antibiogram.default <- function(x, meet_criteria(wisca, allow_class = "logical", has_length = 1) if (isTRUE(wisca)) { 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)))) } @@ -482,7 +482,7 @@ antibiogram.default <- function(x, # try to find columns based on type if (is.null(col_mo)) { 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 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) } 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 # split antimicrobials on separator and make it a list antimicrobials <- strsplit(gsub(" ", "", antimicrobials), "+", fixed = TRUE) @@ -583,9 +583,9 @@ antibiogram.default <- function(x, if (length(existing_ab_combined_cols) > 0 && !is.null(ab_transform)) { ab_transform <- NULL warning_( - "Detected column name(s) containing the '+' character, which conflicts with the expected syntax in `antibiogram()`: the '+' is used to combine separate antimicrobial drug columns (e.g., \"AMP+GEN\").\n\n", - "To avoid incorrectly guessing which antimicrobials this represents, `ab_transform` was automatically set to `NULL`.\n\n", - "If this is unintended, please rename the column(s) to avoid using '+' in the name, or set `ab_transform = NULL` explicitly to suppress this message." + "Detected column name(s) containing the '+' character, which conflicts with the expected syntax in {.help [{.fun antibiogram}](AMR::antibiogram)}: the '+' is used to combine separate antimicrobial drug columns (e.g., \"AMP+GEN\").\n\n", + "To avoid incorrectly guessing which antimicrobials this represents, {.arg ab_transform} was automatically set to {.code NULL}.\n\n", + "If this is unintended, please rename the column(s) to avoid using '+' in the name, or set {.code ab_transform = NULL} explicitly to suppress this message." ) } antimicrobials <- ab_trycatch @@ -619,7 +619,7 @@ antibiogram.default <- function(x, out$n_susceptible <- out$n_susceptible + out$I + out$SDD } 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")) } else if (any(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>% subset(n_tested >= minimum) 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) # 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)) { - 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 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", 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(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(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), "{.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 n_groups <- NROW(groups) progress <- progress_ticker( @@ -1198,7 +1198,7 @@ simulate_coverage <- function(params) { #' @param wisca_model The outcome of [wisca()] or [`antibiogram(..., wisca = TRUE)`][antibiogram()]. #' @rdname antibiogram 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 {.help [{.fun wisca}](AMR::wisca)} or {.help [{.fun antibiogram}](AMR::antibiogram)} (with {.code wisca = TRUE}) to create a WISCA model.") attributes(wisca_model)$wisca_parameters } diff --git a/R/atc_online.R b/R/atc_online.R index 7a24fa543..833a72144 100755 --- a/R/atc_online.R +++ b/R/atc_online.R @@ -105,7 +105,6 @@ atc_online_property <- function(atc_code, if (!has_internet()) { message_("There appears to be no internet connection, returning NA.", - add_fn = font_red, as_note = FALSE ) return(rep(NA, length(atc_code))) @@ -181,7 +180,7 @@ atc_online_property <- function(atc_code, colnames(out) <- gsub("^atc.*", "atc", tolower(colnames(out))) 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 {.help [{.fun atc_online_property}](AMR::atc_online_property)}: no properties found for ATC ", atc_code[i], ". Please check {.href ", atc_url, " this WHOCC webpage}.") returnvalue[i] <- NA next } diff --git a/R/av.R b/R/av.R index 117730167..a5d3509a5 100755 --- a/R/av.R +++ b/R/av.R @@ -475,7 +475,7 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) { # take failed ATC codes apart from rest if (length(x_unknown_ATCs) > 0 && fast_mode == FALSE) { warning_( - "in `as.av()`: these ATC codes are not (yet) in the antivirals data set: ", + "in {.help [{.fun as.av}](AMR::as.av)}: these ATC codes are not (yet) in the antivirals data set: ", vector_and(x_unknown_ATCs), "." ) } @@ -486,7 +486,7 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) { ) if (length(x_unknown) > 0 && fast_mode == FALSE) { warning_( - "in `as.av()`: these values could not be coerced to a valid antiviral drug ID: ", + "in {.help [{.fun as.av}](AMR::as.av)}: these values could not be coerced to a valid antiviral drug ID: ", vector_and(x_unknown), "." ) } diff --git a/R/av_from_text.R b/R/av_from_text.R index 3d9da809f..d07dc81bb 100755 --- a/R/av_from_text.R +++ b/R/av_from_text.R @@ -168,7 +168,7 @@ av_from_text <- function(text, } }) } else { - stop_("`type` must be either 'drug', 'dose' or 'administration'") + stop_("{.arg type} must be either {.val drug}, {.val dose} or {.val administration}") } # collapse text if needed diff --git a/R/av_property.R b/R/av_property.R index 92bb1d9c1..41f83df7c 100755 --- a/R/av_property.R +++ b/R/av_property.R @@ -162,7 +162,7 @@ av_ddd <- function(x, administration = "oral", ...) { if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) { warning_( - "in `av_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.", + "in {.help [{.fun av_ddd}](AMR::av_ddd)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.", "Please refer to the WHOCC website:\n", "atcddd.fhi.no/ddd/list_of_ddds_combined_products/" ) @@ -182,7 +182,7 @@ av_ddd_units <- function(x, administration = "oral", ...) { if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) { warning_( - "in `av_ddd_units()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.", + "in {.help [{.fun av_ddd_units}](AMR::av_ddd_units)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.", "Please refer to the WHOCC website:\n", "atcddd.fhi.no/ddd/list_of_ddds_combined_products/" ) @@ -233,12 +233,12 @@ av_url <- function(x, open = FALSE, ...) { NAs <- av_name(av, tolower = TRUE, language = NULL)[!is.na(av) & is.na(atcs)] if (length(NAs) > 0) { - warning_("in `av_url()`: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".") + warning_("in {.fun av_url}: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".") } if (open == TRUE) { if (length(u) > 1 && !is.na(u[1L])) { - warning_("in `av_url()`: only the first URL will be opened, as `browseURL()` only suports one string.") + warning_("in {.fun av_url}: only the first URL will be opened, as {.fun browseURL} only suports one string.") } if (!is.na(u[1L])) { utils::browseURL(u[1L]) diff --git a/R/bug_drug_combinations.R b/R/bug_drug_combinations.R index 6eb9a9beb..d98630a5a 100755 --- a/R/bug_drug_combinations.R +++ b/R/bug_drug_combinations.R @@ -82,9 +82,9 @@ bug_drug_combinations <- function(x, # -- mo if (is.null(col_mo)) { col_mo <- search_type_in_df(x = x, type = "mo") - stop_if(is.null(col_mo), "`col_mo` must be set") + stop_if(is.null(col_mo), "{.arg col_mo} must be set") } else { - stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found") + stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' ({.arg col_mo}) not found") } x.bak <- x @@ -226,7 +226,7 @@ format.bug_drug_combinations <- function(x, x.bak <- x if (inherits(x, "grouped")) { # bug_drug_combinations() has been run on groups, so de-group here - warning_("in `format()`: formatting the output of `bug_drug_combinations()` does not support grouped variables, they were ignored") + warning_("in {.fun format}: formatting the output of {.fun bug_drug_combinations} does not support grouped variables, they were ignored") x <- as.data.frame(x, stringsAsFactors = FALSE) idx <- split(seq_len(nrow(x)), paste0(x$mo, "%%", x$ab)) x <- data.frame( diff --git a/R/count.R b/R/count.R index 1c17d3806..19bd6c74d 100755 --- a/R/count.R +++ b/R/count.R @@ -128,7 +128,7 @@ count_resistant <- function(..., # other arguments for meet_criteria are handled by sir_calc() meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1) if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("count_resistant", "eucast_default", entire_session = TRUE)) { - message_("`count_resistant()` assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the `guideline` argument or the `AMR_guideline` option to either \"CLSI\" or \"EUCAST\", see `?AMR-options`.") + message_("{.help [{.fun count_resistant}](AMR::count_resistant)} assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the {.arg guideline} argument or the {.code AMR_guideline} option to either \"CLSI\" or \"EUCAST\", see {.topic [AMR-options](AMR::AMR-options)}.") message_("This message will be shown once per session.") } tryCatch( @@ -152,7 +152,7 @@ count_susceptible <- function(..., # other arguments for meet_criteria are handled by sir_calc() meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1) if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("count_susceptible", "eucast_default", entire_session = TRUE)) { - message_("`count_susceptible()` assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the `guideline` argument or the `AMR_guideline` option to either \"CLSI\" or \"EUCAST\", see `?AMR-options`.") + message_("{.help [{.fun count_susceptible}](AMR::count_susceptible)} assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the {.arg guideline} argument or the {.code AMR_guideline} option to either \"CLSI\" or \"EUCAST\", see {.topic [AMR-options](AMR::AMR-options)}.") message_("This message will be shown once per session.") } tryCatch( diff --git a/R/custom_antimicrobials.R b/R/custom_antimicrobials.R index 48714d420..2f6995ffc 100755 --- a/R/custom_antimicrobials.R +++ b/R/custom_antimicrobials.R @@ -155,7 +155,7 @@ add_custom_antimicrobials <- function(x) { AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$ab %in% c(x$ab, x$generalised_name) & !AMR_env$ab_previously_coerced$x %in% c(x$ab, x$generalised_name)), , drop = FALSE] class(AMR_env$AB_lookup$ab) <- c("ab", "character") - message_("Added ", nr2char(nrow(x)), " record", ifelse(nrow(x) > 1, "s", ""), " to the internal `antimicrobials` data set.") + message_("Added ", nr2char(nrow(x)), " record", ifelse(nrow(x) > 1, "s", ""), " to the internal {.code antimicrobials} data set.") } #' @rdname add_custom_antimicrobials @@ -166,5 +166,5 @@ clear_custom_antimicrobials <- function() { n2 <- nrow(AMR_env$AB_lookup) AMR_env$custom_ab_codes <- character(0) AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(AMR_env$ab_previously_coerced$ab %in% AMR_env$AB_lookup$ab), , drop = FALSE] - message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal `antimicrobials` data set.") + message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal {.topic [antimicrobials](AMR::antimicrobials)} data set.") } diff --git a/R/custom_eucast_rules.R b/R/custom_eucast_rules.R index 8a762fb12..c5846506e 100755 --- a/R/custom_eucast_rules.R +++ b/R/custom_eucast_rules.R @@ -150,15 +150,15 @@ custom_eucast_rules <- function(...) { ) stop_if( identical(dots, "error"), - "rules must be a valid formula inputs (e.g., using '~'), see `?custom_eucast_rules`" + "rules must be a valid formula inputs (e.g., using '~'), see {.help [{.fun custom_eucast_rules}](AMR::custom_eucast_rules)}" ) n_dots <- length(dots) - stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using `?custom_eucast_rules`.") + stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using {.help [{.fun custom_eucast_rules}](AMR::custom_eucast_rules)}.") out <- vector("list", n_dots) for (i in seq_len(n_dots)) { stop_ifnot( inherits(dots[[i]], "formula"), - "rule ", i, " must be a valid formula input (e.g., using '~'), see `?custom_eucast_rules`" + "rule ", i, " must be a valid formula input (e.g., using '~'), see {.help [{.fun custom_eucast_rules}](AMR::custom_eucast_rules)}" ) # Query @@ -180,7 +180,7 @@ custom_eucast_rules <- function(...) { result <- dots[[i]][[3]] stop_ifnot( deparse(result) %like% "==", - "the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see `?custom_eucast_rules`" + "the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see {.help [{.fun custom_eucast_rules}](AMR::custom_eucast_rules)}" ) result_group <- as.character(result)[[2]] result_group <- as.character(str2lang(result_group)) diff --git a/R/custom_mdro_guideline.R b/R/custom_mdro_guideline.R index 14f739236..4db6b6cff 100755 --- a/R/custom_mdro_guideline.R +++ b/R/custom_mdro_guideline.R @@ -145,15 +145,15 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) { ) stop_if( 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 {.help [{.fun mdro}](AMR::mdro)}" ) 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 {.help [{.fun mdro}](AMR::mdro)}.") out <- vector("list", n_dots) for (i in seq_len(n_dots)) { stop_ifnot( 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 {.help [{.fun mdro}](AMR::mdro)}" ) # Query @@ -202,7 +202,7 @@ c.custom_mdro_guideline <- function(x, ..., as_factor = NULL) { } for (g in list(...)) { 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 {.help [{.fun custom_mdro_guideline}](AMR::custom_mdro_guideline)}", call = FALSE ) vals <- attributes(x)$values @@ -235,9 +235,9 @@ print.custom_mdro_guideline <- function(x, ...) { for (i in seq_len(length(x))) { rule <- x[[i]] rule$query <- format_custom_query_rule(rule$query) - cat(" ", i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then: "), font_red(rule$value), "\n", sep = "") + cat("\u00a0\u00a0", i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then: "), font_red(rule$value), "\n", sep = "") } - cat(" ", i + 1, ". ", font_bold("Otherwise: "), font_red(paste0("Negative")), "\n", sep = "") + cat("\u00a0\u00a0", i + 1, ". ", font_bold("Otherwise: "), font_red(paste0("Negative")), "\n", sep = "") cat("\nUnmatched rows will return ", font_red("NA"), ".\n", sep = "") if (isTRUE(attributes(x)$as_factor)) { cat("Results will be of class 'factor', with ordered levels: ", paste0(attributes(x)$values, collapse = " < "), "\n", sep = "") @@ -259,16 +259,15 @@ run_custom_mdro_guideline <- function(df, guideline, info) { } ) if (identical(qry, "error")) { - warning_("in `custom_mdro_guideline()`: rule ", i, + warning_("in {.help [{.fun custom_mdro_guideline}](AMR::custom_mdro_guideline)}: rule ", i, " (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ", AMR_env$err_msg, - call = FALSE, - add_fn = font_red + call = FALSE ) next } - stop_ifnot(is.logical(qry), "in custom_mdro_guideline(): rule ", i, " (`", guideline[[i]]$query, - "`) must return `TRUE` or `FALSE`, not ", + stop_ifnot(is.logical(qry), "in {.help [{.fun custom_mdro_guideline}](AMR::custom_mdro_guideline)}: rule ", i, " ({.code ", guideline[[i]]$query, + "}) must return {.code TRUE} or {.code FALSE}, not ", format_class(class(qry), plural = FALSE), call = FALSE ) diff --git a/R/custom_microorganisms.R b/R/custom_microorganisms.R index be37a348b..ec28f9113 100755 --- a/R/custom_microorganisms.R +++ b/R/custom_microorganisms.R @@ -128,7 +128,7 @@ #' } add_custom_microorganisms <- function(x) { meet_criteria(x, allow_class = "data.frame") - stop_ifnot("genus" %in% tolower(colnames(x)), paste0("`x` must contain column 'genus'.")) + stop_ifnot("genus" %in% tolower(colnames(x)), "{.arg x} must contain column 'genus'.") add_MO_lookup_to_AMR_env() @@ -281,9 +281,9 @@ add_custom_microorganisms <- function(x) { AMR_env$MO_lookup <- unique(rbind_AMR(AMR_env$MO_lookup, new_df)) class(AMR_env$MO_lookup$mo) <- c("mo", "character") if (nrow(x) <= 3) { - message_("Added ", vector_and(italicise(x$fullname), quotes = FALSE), " to the internal `microorganisms` data set.") + message_("Added ", vector_and(italicise(x$fullname), quotes = FALSE), " to the internal {.code microorganisms} data set.") } else { - message_("Added ", nr2char(nrow(x)), " records to the internal `microorganisms` data set.") + message_("Added ", nr2char(nrow(x)), " records to the internal {.code microorganisms} data set.") } } @@ -303,7 +303,7 @@ clear_custom_microorganisms <- function() { AMR_env$custom_mo_codes <- character(0) AMR_env$mo_previously_coerced <- AMR_env$mo_previously_coerced[which(AMR_env$mo_previously_coerced$mo %in% AMR_env$MO_lookup$mo), , drop = FALSE] AMR_env$mo_uncertainties <- AMR_env$mo_uncertainties[0, , drop = FALSE] - message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal `microorganisms` data set.") + message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal {.code microorganisms} data set.") } abbreviate_mo <- function(x, minlength = 5, prefix = "", hyphen_as_space = FALSE, ...) { diff --git a/R/disk.R b/R/disk.R index 284bca47e..62e9d82c4 100755 --- a/R/disk.R +++ b/R/disk.R @@ -119,7 +119,7 @@ as.disk <- function(x, na.rm = FALSE) { sort() %pm>% vector_and(quotes = TRUE) cur_col <- get_current_column() - warning_("in `as.disk()`: ", na_after - na_before, " result", + warning_("in {.fun as.disk}: ", na_after - na_before, " result", ifelse(na_after - na_before > 1, "s", ""), ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")), " truncated (", diff --git a/R/first_isolate.R b/R/first_isolate.R index 091154708..3ce0c127b 100644 --- a/R/first_isolate.R +++ b/R/first_isolate.R @@ -263,8 +263,7 @@ first_isolate <- function(x = NULL, ), "" ) - ), - add_fn = font_red + ) ) } @@ -272,7 +271,7 @@ first_isolate <- function(x = NULL, # -- mo if (is.null(col_mo)) { 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 ---- @@ -309,7 +308,7 @@ first_isolate <- function(x = NULL, # -- date if (is.null(col_date)) { 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 @@ -318,11 +317,11 @@ first_isolate <- function(x = NULL, # WHONET support x$patient_id <- paste(x$`First name`, x$`Last name`, x$Sex) 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 { 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 @@ -334,7 +333,7 @@ first_isolate <- function(x = NULL, check_columns_existance <- function(column, tblname = x) { if (!is.null(column)) { stop_ifnot(column %in% colnames(tblname), - "Column '", column, "' not found.", + "Column '{column}' not found.", call = FALSE ) } @@ -363,9 +362,7 @@ first_isolate <- function(x = NULL, } # remove testcodes if (!is.null(testcodes_exclude) && isTRUE(info) && message_not_thrown_before("first_isolate", "excludingtestcodes")) { - message_("Excluding test codes: ", vector_and(testcodes_exclude, quotes = TRUE), - add_fn = font_red - ) + message_("Excluding test codes: ", vector_and(testcodes_exclude, quotes = TRUE)) } if (is.null(col_specimen)) { @@ -376,9 +373,7 @@ first_isolate <- function(x = NULL, if (!is.null(specimen_group)) { check_columns_existance(col_specimen, x) if (isTRUE(info) && message_not_thrown_before("first_isolate", "excludingspecimen")) { - message_("Excluding other than specimen group '", specimen_group, "'", - add_fn = font_red - ) + message_("Excluding other than specimen group '", specimen_group, "'") } } if (!is.null(col_keyantimicrobials)) { @@ -420,7 +415,6 @@ first_isolate <- function(x = NULL, if (abs(row.start) == Inf || abs(row.end) == Inf) { if (isTRUE(info)) { message_("=> Found ", font_bold("no isolates"), - add_fn = font_black, as_note = FALSE ) } @@ -429,7 +423,6 @@ first_isolate <- function(x = NULL, if (row.start == row.end) { if (isTRUE(info)) { message_("=> Found ", font_bold("1 first isolate"), ", as the data only contained 1 row", - add_fn = font_black, as_note = FALSE ) } @@ -437,9 +430,8 @@ 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 (isTRUE(info)) { - message_("=> Found ", font_bold(paste(length(c(row.start:row.end)), "first isolates")), - ", as all isolates were different microbial species", - add_fn = font_black, + n_rows <- length(c(row.start:row.end)) + message_("=> Found {.strong ", n_rows, " first isolates}, as all isolates were different microbial species", as_note = FALSE ) } @@ -456,16 +448,16 @@ first_isolate <- function(x = NULL, if (!is.null(col_keyantimicrobials)) { if (isTRUE(info) && message_not_thrown_before("first_isolate", "type")) { if (type == "keyantimicrobials") { - message_("Basing inclusion on key antimicrobials, ", + message_( + "Basing inclusion on key antimicrobials, ", ifelse(ignore_I == FALSE, "not ", ""), - "ignoring I", - add_fn = font_red + "ignoring I" ) } if (type == "points") { - message_("Basing inclusion on all antimicrobial results, using a points threshold of ", - points_threshold, - add_fn = font_red + message_( + "Basing inclusion on all antimicrobial results, using a points threshold of ", + points_threshold ) } } @@ -524,9 +516,7 @@ first_isolate <- function(x = NULL, if (any(!is.na(x$newvar_is_icu)) && any(x$newvar_is_icu == TRUE, na.rm = TRUE)) { if (icu_exclude == TRUE) { 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.", - add_fn = font_red - ) + message_("Excluding ", format(sum(x$newvar_is_icu, na.rm = TRUE), decimal.mark = decimal.mark, big.mark = big.mark), " isolates from ICU.") } x[which(x$newvar_is_icu), "newvar_first_isolate"] <- FALSE } else if (isTRUE(info)) { @@ -550,9 +540,8 @@ first_isolate <- function(x = NULL, paste0('"', x, '"') } }) - message_("\nGroup: ", paste0(names(group), " = ", group, collapse = ", "), "\n", - as_note = FALSE, - add_fn = font_red + message_("\nGroup: ", toString(paste0(names(group), " = ", group)), "\n", + as_note = FALSE ) } } @@ -565,8 +554,7 @@ first_isolate <- function(x = NULL, format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE), decimal.mark = decimal.mark, big.mark = big.mark ), - " isolates with a microbial ID 'UNKNOWN' (in column '", font_bold(col_mo), "')", - add_fn = font_red + " isolates with a microbial ID 'UNKNOWN' (in column '", font_bold(col_mo), "')" ) } x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown @@ -577,8 +565,7 @@ first_isolate <- function(x = NULL, "Excluding ", format(sum(is.na(x$newvar_mo), na.rm = TRUE), decimal.mark = decimal.mark, big.mark = big.mark ), - " isolates with a microbial ID `NA` (in column '", font_bold(col_mo), "')", - add_fn = font_red + " isolates with a microbial ID `NA` (in column '", font_bold(col_mo), "')" ) } x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE @@ -624,7 +611,7 @@ first_isolate <- function(x = NULL, ), p_found_total, " of total where a microbial ID was available)" ), - add_fn = font_black, as_note = FALSE + as_note = FALSE ) } diff --git a/R/get_episode.R b/R/get_episode.R index 1fb33f292..bc9dc58eb 100644 --- a/R/get_episode.R +++ b/R/get_episode.R @@ -215,7 +215,7 @@ is_new_episode <- function(x, episode_days = NULL, case_free_days = NULL, ...) { exec_episode <- function(x, episode_days, case_free_days, ...) { stop_ifnot(is.null(episode_days) || is.null(case_free_days), - "either argument `episode_days` or argument `case_free_days` must be set.", + "either argument {.arg episode_days} or argument {.arg case_free_days} must be set.", call = -2 ) diff --git a/R/ggplot_sir.R b/R/ggplot_sir.R index f9c89fc96..b275bb8b3 100755 --- a/R/ggplot_sir.R +++ b/R/ggplot_sir.R @@ -295,7 +295,7 @@ geom_sir <- function(position = NULL, ...) { x <- x[1] stop_ifnot_installed("ggplot2") - stop_if(is.data.frame(position), "`position` is invalid. Did you accidentally use '%>%' instead of '+'?") + stop_if(is.data.frame(position), "{.arg position} is invalid. Did you accidentally use {.code %>%} instead of {.code +}?") meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE) meet_criteria(x, allow_class = "character", has_length = 1) meet_criteria(fill, allow_class = "character", has_length = 1) diff --git a/R/guess_ab_col.R b/R/guess_ab_col.R index f8a6638b3..f63f95ab8 100755 --- a/R/guess_ab_col.R +++ b/R/guess_ab_col.R @@ -79,7 +79,6 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_s if (isTRUE(verbose)) { message_("No column found as input for ", search_string, " (", ab_name(search_string, language = NULL, tolower = TRUE), ").", - add_fn = font_black, as_note = FALSE ) } @@ -211,7 +210,7 @@ get_column_abx <- function(x, newnames <- suppressWarnings(as.ab(names(dots), info = FALSE)) if (anyNA(newnames)) { 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 {.help [{.fun as.ab}](AMR::as.ab)}", as_note = FALSE) } warning_("Invalid antibiotic reference(s): ", vector_and(names(dots)[is.na(newnames)], quotes = 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))) if (length(unexisting_cols) > 0) { 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), call = FALSE @@ -266,11 +265,11 @@ get_column_abx <- function(x, if (isTRUE(info)) { 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)) { - 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 {.help [{.fun as.ab}](AMR::as.ab)} are duplicated: ", vector_and(dups, quotes = FALSE), as_note = FALSE) } 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))) { @@ -288,8 +287,7 @@ get_column_abx <- function(x, "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)), ")", ", as this antimicrobial has already been set." - ), - add_fn = font_red + ) ) } } diff --git a/R/interpretive_rules.R b/R/interpretive_rules.R index ce0555c13..bbcf798ae 100755 --- a/R/interpretive_rules.R +++ b/R/interpretive_rules.R @@ -192,19 +192,19 @@ interpretive_rules <- function(x, stop_if( !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() if ("custom" %in% rules && is.null(custom_rules)) { - warning_("in `eucast_rules()`: no custom rules were set with the `custom_rules` argument", + warning_("in {.help [{.fun eucast_rules}](AMR::eucast_rules)}: no custom rules were set with the {.arg custom_rules} argument", immediate = TRUE ) rules <- rules[rules != "custom"] if (length(rules) == 0) { 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) } @@ -232,7 +232,7 @@ interpretive_rules <- function(x, q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt) } 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) } } @@ -241,7 +241,7 @@ interpretive_rules <- function(x, # -- mo if (is.null(col_mo)) { 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") @@ -459,7 +459,7 @@ interpretive_rules <- function(x, x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL, info = FALSE) x$genus_species <- trimws(paste(x$genus, x$species)) 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 @@ -481,7 +481,7 @@ interpretive_rules <- function(x, "Rules by the ", font_bold(paste0("AMR package v", utils::packageDescription("AMR")$Version)), " (", format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"), - "), see `?eucast_rules`\n" + "), see {.help [{.fun eucast_rules}](AMR::eucast_rules)}\n" ) )) cat("\n\n") @@ -595,23 +595,13 @@ interpretive_rules <- function(x, } else { if (isTRUE(info)) { cat("\n") - message_(paste0( - 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.") - )) + 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.") } } if (!any(c("all", "custom") %in% rules) && !is.null(custom_rules)) { 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 } @@ -671,10 +661,10 @@ interpretive_rules <- function(x, ab <- gsub("-S$", "", ab_s) if (ab %in% names(cols_ab) && !ab_s %in% names(cols_ab)) { if (isTRUE(info)) { - message_("Using column '", cols_ab[names(cols_ab) == ab], + message_( + "Using column '", cols_ab[names(cols_ab) == ab], "' as ", ab_name(ab_s, language = NULL, tolower = TRUE), - " since a column '", ab_s, "' is missing but required for the chosen rules", - add_fn = font_red + " since a column '", ab_s, "' is missing but required for the chosen rules" ) } cols_ab <- c(cols_ab, stats::setNames(unname(cols_ab[names(cols_ab) == ab]), ab_s)) @@ -898,7 +888,7 @@ interpretive_rules <- function(x, for (i in seq_len(length(custom_rules))) { rule <- custom_rules[[i]] 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 <- c( @@ -1061,9 +1051,9 @@ interpretive_rules <- function(x, cat(paste0(font_grey(strrep("-", 0.95 * getOption("width", 100))), "\n")) if (isFALSE(verbose) && total_n_added + total_n_changed > 0) { - cat("\n", word_wrap("Use `eucast_rules(..., verbose = TRUE)` (on your original data) to get a data.frame with all specified edits instead."), "\n\n", sep = "") + cat("\n", word_wrap("Use ", highlight_code("eucast_rules(..., verbose = TRUE)"), " (on your original data) to get a data.frame with all specified edits instead."), "\n\n", sep = "") } else if (isTRUE(verbose)) { - cat("\n", word_wrap("Used 'Verbose mode' (`verbose = TRUE`), which returns a data.frame with all specified edits.\nUse `verbose = FALSE` to apply the rules on your data."), "\n\n", sep = "") + cat("\n", word_wrap("Used 'Verbose mode' ({.code verbose = TRUE}), which returns a data.frame with all specified edits.\nUse {.code verbose = FALSE} to apply the rules on your data."), "\n\n", sep = "") } } @@ -1073,13 +1063,13 @@ interpretive_rules <- function(x, 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)] warning_( - "in `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, + "in {.help [{.fun eucast_rules}](AMR::eucast_rules)}: not all columns with antimicrobial results are of class {.cls sir}. Transform them on beforehand, e.g.:\n", + " - ", highlight_code(paste0(x_deparsed, " %>% as.sir(", ifelse(length(warn_lacking_sir_class) == 1, warn_lacking_sir_class, paste0(warn_lacking_sir_class[1], ":", warn_lacking_sir_class[length(warn_lacking_sir_class)]) - ), ")\n", - " - ", x_deparsed, " %>% mutate_if(is_sir_eligible, as.sir)\n", - " - ", x_deparsed, " %>% mutate(across(where(is_sir_eligible), as.sir))" + ), ")")), "\n", + " - ", highlight_code(paste0(x_deparsed, " %>% mutate_if(is_sir_eligible, as.sir)")), "\n", + " - ", highlight_code(paste0(x_deparsed, " %>% mutate(across(where(is_sir_eligible), as.sir))")) ) } @@ -1108,7 +1098,7 @@ eucast_rules <- function(x, rules = getOption("AMR_interpretive_rules", default = c("breakpoints", "expected_phenotypes")), ...) { 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 {.topic [AMR-options](AMR::AMR-options)}.") } interpretive_rules(x = x, col_mo = col_mo, info = info, rules = rules, guideline = "EUCAST", ...) } @@ -1165,7 +1155,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") non_SIR <- !isSIR 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( # insert into original table @@ -1189,7 +1179,7 @@ edit_sir <- function(x, suppressWarnings(new_edits[rows, cols][non_SIR] <<- to) } warning_( - "in `eucast_rules()`: value \"", to, "\" added to the factor levels of column", + "in {.help [{.fun eucast_rules}](AMR::eucast_rules)}: value \"", to, "\" added to the factor levels of column", ifelse(length(cols) == 1, "", "s"), " ", vector_and(cols, quotes = "`", sort = FALSE), " because this value was not an existing factor level." @@ -1197,7 +1187,7 @@ edit_sir <- function(x, txt_warning() warned <- FALSE } else { - warning_("in `eucast_rules()`: ", w$message) + warning_("in {.help [{.fun eucast_rules}](AMR::eucast_rules)}: ", w$message) txt_warning() } }, diff --git a/R/join_microorganisms.R b/R/join_microorganisms.R index c5d54cc38..e282b9933 100755 --- a/R/join_microorganisms.R +++ b/R/join_microorganisms.R @@ -143,9 +143,9 @@ join_microorganisms <- function(type, x, by, suffix, ...) { if (is.null(by) && NCOL(x) == 1) { by <- colnames(x)[1L] } 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)) { 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)) { - 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 {.fun ", 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 diff --git a/R/key_antimicrobials.R b/R/key_antimicrobials.R index 516b527fc..0fb749b56 100755 --- a/R/key_antimicrobials.R +++ b/R/key_antimicrobials.R @@ -159,7 +159,7 @@ key_antimicrobials <- function(x = NULL, col_mo <- search_type_in_df(x = x, type = "mo", info = FALSE) } if (is.null(col_mo)) { - warning_("in `key_antimicrobials()`: no column found for `col_mo`, ignoring antibiotics set in `gram_negative` and `gram_positive`, and antimycotics set in `antifungal`") + warning_("in {.fun key_antimicrobials}: no column found for {.arg col_mo}, ignoring antibiotics set in {.arg gram_negative} and {.arg gram_positive}, and antimycotics set in {.arg antifungal}") gramstain <- NA_character_ kingdom <- NA_character_ } else { @@ -182,12 +182,12 @@ key_antimicrobials <- function(x = NULL, any(filter, na.rm = TRUE) && message_not_thrown_before("key_antimicrobials", name)) { warning_( - "in `key_antimicrobials()`: ", + "in {.help [{.fun key_antimicrobials}](AMR::key_antimicrobials)}: ", ifelse(values_new_length == 0, "No columns available ", paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ") ), - "as key antimicrobials for ", name, "s. See `?key_antimicrobials`." + "as key antimicrobials for ", name, "s. See {.help [{.fun key_antimicrobials}](AMR::key_antimicrobials)}." ) } @@ -237,7 +237,7 @@ key_antimicrobials <- function(x = NULL, ) if (length(unique(key_ab)) == 1) { - warning_("in `key_antimicrobials()`: no distinct key antibiotics determined.") + warning_("in {.fun key_antimicrobials}: no distinct key antibiotics determined.") } key_ab @@ -310,7 +310,7 @@ antimicrobials_equal <- function(y, meet_criteria(type, allow_class = "character", has_length = 1, is_in = c("points", "keyantimicrobials")) meet_criteria(ignore_I, allow_class = "logical", has_length = 1) meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE) - stop_ifnot(length(y) == length(z), "length of `y` and `z` must be equal") + stop_ifnot(length(y) == length(z), "length of {.arg y} and {.arg z} must be equal") key2sir <- function(val) { val <- strsplit(val, "", fixed = TRUE)[[1L]] diff --git a/R/mdro.R b/R/mdro.R index eef4d4ed3..c1bd4dfae 100755 --- a/R/mdro.R +++ b/R/mdro.R @@ -170,9 +170,9 @@ mdro <- function(x = NULL, meet_criteria(infer_from_combinations, allow_class = "logical", has_length = 1) 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 {.help [{.fun as.sir}](AMR::as.sir)} for valid antimicrobial interpretations.") } 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 {.help [{.fun as.sir}](AMR::as.sir)} for valid antimicrobial interpretations.") } # 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) } 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) } } @@ -251,7 +251,7 @@ mdro <- function(x = NULL, guideline.bak <- guideline if (is.list(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 {.help [{.fun custom_mdro_guideline}](AMR::custom_mdro_guideline)} to create custom guidelines") if (isTRUE(info)) { txt <- paste0( "Determining MDROs based on custom rules", @@ -328,13 +328,13 @@ mdro <- function(x = NULL, } if (is.null(col_mo) && guideline$code == "tb") { 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"), ".")) ) x$mo <- as.mo("Mycobacterium tuberculosis", keep_synonyms = TRUE) 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") { 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)) { # ampicillin column is missing, but amoxicillin is available 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"]))) } @@ -875,7 +875,7 @@ mdro <- function(x = NULL, } if (isTRUE(info)) { - message_(" OK.", add_fn = list(font_green, font_bold), as_note = FALSE) + message_(" OK.", as_note = FALSE) } } @@ -1888,8 +1888,8 @@ mdro <- function(x = NULL, if (any(x$MDRO == -1, na.rm = TRUE)) { if (message_not_thrown_before("mdro", "availability")) { warning_( - "in `mdro()`: NA introduced for isolates where the available percentage of antimicrobial classes was below ", - percentage(pct_required_classes), " (set with `pct_required_classes`)" + "in {.help [{.fun mdro}](AMR::mdro)}: NA introduced for isolates where the available percentage of antimicrobial classes was below ", + percentage(pct_required_classes), " (set with {.arg pct_required_classes})" ) } # set these -1s to NA @@ -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) stop_if( "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", ...) } @@ -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) stop_if( "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", ...) } @@ -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) stop_if( "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", ...) } @@ -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) stop_if( "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", ...) } @@ -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) stop_if( "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", ...) } diff --git a/R/mic.R b/R/mic.R index 6b2eaad0b..74e3d8d25 100644 --- a/R/mic.R +++ b/R/mic.R @@ -269,7 +269,7 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all", round_to_next_log2 sort() %pm>% vector_and(quotes = TRUE) cur_col <- get_current_column() - warning_("in `as.mic()`: ", na_after - na_before, " result", + warning_("in {.fun as.mic}: ", na_after - na_before, " result", ifelse(na_after - na_before > 1, "s", ""), ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")), " truncated (", @@ -331,7 +331,7 @@ rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE, r } stop_ifnot( all(mic_range %in% c(VALID_MIC_LEVELS, NA)), - "Values in `mic_range` must be valid MIC values. ", + "Values in {.arg mic_range} must be valid MIC values. ", "The allowed range is ", format(as.double(as.mic(VALID_MIC_LEVELS)[1]), scientific = FALSE), " to ", format(as.double(as.mic(VALID_MIC_LEVELS)[length(VALID_MIC_LEVELS)]), scientific = FALSE), ". ", "Unvalid: ", vector_and(mic_range[!mic_range %in% c(VALID_MIC_LEVELS, NA)], quotes = FALSE), "." ) @@ -441,7 +441,7 @@ all_valid_mics <- function(x) { #' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, mic) pillar_shaft.mic <- function(x, ...) { if (!identical(levels(x), VALID_MIC_LEVELS) && message_not_thrown_before("pillar_shaft.mic")) { - warning_(AMR_env$sup_1_icon, " These columns contain an outdated or altered structure - convert with `as.mic()` to update", + warning_(AMR_env$sup_1_icon, " These columns contain an outdated or altered structure - convert with {.fun as.mic} to update", call = FALSE ) } @@ -508,7 +508,7 @@ as.vector.mic <- function(x, mode = "numneric", ...) { y <- as.mic(y) calls <- unlist(lapply(sys.calls(), as.character)) if (any(calls %in% c("rbind", "cbind")) && message_not_thrown_before("as.vector.mic")) { - warning_("Functions `rbind()` and `cbind()` cannot preserve the structure of MIC values. Use dplyr's `bind_rows()` or `bind_cols()` instead.", call = FALSE) + warning_("Functions {.fun rbind} and {.fun cbind} cannot preserve the structure of MIC values. Use {.pkg dplyr}'s {.fun bind_rows} or {.fun bind_cols} instead.", call = FALSE) } y } @@ -601,7 +601,7 @@ sort.mic <- function(x, decreasing = FALSE, ...) { #' @export #' @noRd hist.mic <- function(x, ...) { - warning_("in `hist()`: use `plot()` or ggplot2's `autoplot()` for optimal plotting of MIC values") + warning_("in {.fun hist}: use {.fun plot} or {.pkg ggplot2}'s {.fun autoplot} for optimal plotting of MIC values") hist(log2(x)) } diff --git a/R/mo.R b/R/mo.R index 307217054..2dd8cc9c6 100755 --- a/R/mo.R +++ b/R/mo.R @@ -267,7 +267,7 @@ as.mo <- function(x, if (isTRUE(info) && message_not_thrown_before("as.mo", old, new, entire_session = TRUE) && any(is.na(old) & !is.na(new), na.rm = TRUE)) { message_( "Returning previously coerced value", ifelse(sum(is.na(old) & !is.na(new)) > 1, "s", ""), - " for ", vector_and(x[is.na(old) & !is.na(new)]), ". Run `mo_reset_session()` to reset this. This note will be shown once per session for this input." + " for ", vector_and(x[is.na(old) & !is.na(new)]), ". Run {.help [{.fun mo_reset_session}](AMR::mo_reset_session)} to reset this. This note will be shown once per session for this input." ) } @@ -402,7 +402,14 @@ as.mo <- function(x, top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs 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_ } else { result_mo <- MO_lookup_current$mo[match(top_hits[1], MO_lookup_current$fullname)] @@ -448,8 +455,8 @@ as.mo <- function(x, if (length(AMR_env$mo_uncertainties$original_input) <= 3) { examples <- vector_and( paste0( - '"', AMR_env$mo_uncertainties$original_input, - '" (assumed ', italicise(AMR_env$mo_uncertainties$fullname), ")" + "{.val ", AMR_env$mo_uncertainties$original_input, + "} (assumed ", italicise(AMR_env$mo_uncertainties$fullname), ")" ), quotes = FALSE ) @@ -458,7 +465,7 @@ as.mo <- function(x, } msg <- c(msg, paste0( "Microorganism translation was uncertain for ", examples, - ". Run `mo_uncertainties()` to review ", plural[2], ", or use `add_custom_microorganisms()` to add custom entries." + ". Run {.help [{.fun mo_uncertainties}](AMR::mo_uncertainties)} to review ", plural[2], ", or use {.help [{.fun add_custom_microorganisms}](AMR::add_custom_microorganisms)} to add custom entries." )) for (m in msg) { @@ -474,11 +481,11 @@ as.mo <- function(x, if (isFALSE(keep_synonyms)) { out[!is.na(out_current)] <- out_current[!is.na(out_current)] if (isTRUE(info) && length(AMR_env$mo_renamed$old) > 0) { - print(mo_renamed(), extra_txt = " (use `keep_synonyms = TRUE` to leave uncorrected)") + print(mo_renamed(), extra_txt = " (use {.arg keep_synonyms = TRUE} to leave uncorrected)") } } else if (is.null(getOption("AMR_keep_synonyms")) && length(AMR_env$mo_renamed$old) > 0 && message_not_thrown_before("as.mo", "keep_synonyms_warning", entire_session = TRUE)) { # keep synonyms is TRUE, so check if any do have synonyms - warning_("Function `as.mo()` returned ", nr2char(length(unique(AMR_env$mo_renamed$old))), " outdated taxonomic name", ifelse(length(unique(AMR_env$mo_renamed$old)) > 1, "s", ""), ". Use `as.mo(..., keep_synonyms = FALSE)` to clean the input to currently accepted taxonomic names, or set the R option `AMR_keep_synonyms` to `FALSE`. This warning will be shown once per session.", call = FALSE) + warning_("{.help [{.fun as.mo}](AMR::as.mo)} returned ", nr2char(length(unique(AMR_env$mo_renamed$old))), " outdated taxonomic name", ifelse(length(unique(AMR_env$mo_renamed$old)) > 1, "s", ""), ". Use {.arg keep_synonyms = FALSE} to clean the input to currently accepted taxonomic names, or set the R option {.code AMR_keep_synonyms} to {.code FALSE}. This warning will be shown once per session.", call = FALSE) } # Apply Becker ---- @@ -495,7 +502,7 @@ as.mo <- function(x, ) if (any(out %in% AMR_env$MO_lookup$mo[match(post_Becker, AMR_env$MO_lookup$fullname)])) { if (message_not_thrown_before("as.mo", "becker")) { - warning_("in `as.mo()`: Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ", + warning_("in {.fun as.mo}: Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ", vector_and(font_italic(gsub("Staphylococcus", "S.", post_Becker, fixed = TRUE), collapse = NULL), quotes = FALSE), ". Categorisation to CoNS/CoPS was taken from the original scientific publication(s).", immediate = TRUE, call = FALSE @@ -540,7 +547,7 @@ as.mo <- function(x, out[is.na(out) & !is.na(x)] <- "UNKNOWN" AMR_env$mo_failures <- unique(x[out == "UNKNOWN" & !toupper(x) %in% c("UNKNOWN", "CON", "UNK") & !x %like_case% "^[(]unknown [a-z]+[)]$" & !is.na(x)]) if (length(AMR_env$mo_failures) > 0) { - warning_("The following input could not be coerced and was returned as \"UNKNOWN\": ", vector_and(AMR_env$mo_failures, quotes = TRUE), ".\nYou can retrieve this list with `mo_failures()`.", call = FALSE) + warning_("The following input could not be coerced and was returned as \"UNKNOWN\": ", vector_and(AMR_env$mo_failures, quotes = TRUE), ".\nYou can retrieve this list with {.fun mo_failures}.", call = FALSE) } # Return class ---- @@ -902,14 +909,16 @@ rep.mo <- function(x, ...) { print.mo_uncertainties <- function(x, n = 10, ...) { more_than_50 <- FALSE 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)) + message_("No uncertainties to show. Only uncertainties of the last call to {.help [{.fun as.mo}](AMR::as.mo)} or any {.help [{.fun mo_*}](AMR::mo_property)} function are stored.") return(invisible(NULL)) } else if (NROW(x) > 50) { more_than_50 <- TRUE x <- x[1:50, , drop = FALSE] } - cat(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)) + message_("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See {.help [{.fun mo_matching_score}](AMR::mo_matching_score)}.", + as_note = FALSE + ) add_MO_lookup_to_AMR_env() @@ -919,12 +928,12 @@ print.mo_uncertainties <- function(x, n = 10, ...) { col_green <- function(x) font_green_bg(x, collapse = NULL) if (has_colour()) { - cat(word_wrap("Colour keys: ", + cat(word_wrap( + "Colour keys: ", col_red(" 0.000-0.549 "), col_orange(" 0.550-0.649 "), col_yellow(" 0.650-0.749 "), - col_green(" 0.750-1.000"), - add_fn = font_blue + col_green(" 0.750-1.000") ), font_green_bg(" "), "\n", sep = "") } @@ -956,21 +965,6 @@ print.mo_uncertainties <- function(x, n = 10, ...) { # sort on descending scores candidates_formatted <- candidates_formatted[order(1 - scores)] scores_formatted <- scores_formatted[order(1 - scores)] - - candidates <- word_wrap( - paste0( - "Also matched: ", - vector_and( - paste0( - candidates_formatted, - font_blue(paste0(" (", scores_formatted, ")"), collapse = NULL) - ), - quotes = FALSE, sort = FALSE - ) - ), - extra_indent = nchar("Also matched: "), - width = 0.9 * getOption("width", 100) - ) } else { candidates <- "" } @@ -980,46 +974,54 @@ print.mo_uncertainties <- function(x, n = 10, ...) { n = x[i, ]$fullname ) score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3)) - txt <- paste(txt, + + out <- paste0( paste0( + "", strrep(font_grey("-"), times = getOption("width", 100) - 1), "\n", + "{.val ", x[i, ]$original_input, "}", + " -> ", paste0( - "", strrep(font_grey("-"), times = getOption("width", 100)), "\n", - '"', x[i, ]$original_input, '"', - " -> ", - paste0( - font_bold(italicise(x[i, ]$fullname)), - " (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")" - ) - ), - collapse = "\n" + font_bold(italicise(x[i, ]$fullname)), + " (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")" + ) ), - ifelse(x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")], - paste0( - strrep(" ", nchar(x[i, ]$original_input) + 6), - ifelse(x[i, ]$keep_synonyms == FALSE, - # Add note if result was coerced to accepted taxonomic name - font_red(paste0("This outdated taxonomic name was converted to ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL), - # Or add note if result is currently another taxonomic name - font_red(paste0(font_bold("Note: "), "The current name is ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", AMR_env$MO_lookup$ref[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], ")."), collapse = NULL) - ) - ), - "" - ), - candidates, - sep = "\n" + collapse = "\n" ) - txt <- gsub("[\n]+", "\n", txt) - # remove first and last break - txt <- gsub("(^[\n]|[\n]$)", "", txt) - txt <- paste0("\n", txt, "\n") + message_(out, as_note = FALSE) + + if (x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")]) { + out2 <- paste0( + strrep(" ", nchar(x[i, ]$original_input) + 6), + ifelse(x[i, ]$keep_synonyms == FALSE, + # Add note if result was coerced to accepted taxonomic name + font_red(paste0("This outdated taxonomic name was converted to ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL), + # Or add note if result is currently another taxonomic name + font_red(paste0(font_bold("Note: "), "The current name is ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", AMR_env$MO_lookup$ref[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], ")."), collapse = NULL) + ) + ) + message_(out2, as_note = FALSE) + } + + other_matches <- paste0( + "Also matched: ", + vector_and( + paste0( + candidates_formatted, + font_blue(paste0(" (", scores_formatted, ")"), collapse = NULL) + ), + quotes = FALSE, sort = FALSE + ) + ) + message_(other_matches, as_note = FALSE) } - cat(txt) if (isTRUE(any_maxed_out)) { - cat(font_blue(word_wrap("\nOnly the first ", n, " other matches of each record are shown. Run `print(mo_uncertainties(), n = ...)` to view more entries, or save `mo_uncertainties()` to an object."))) + cat("\n") + message_("Only the first ", n, " other matches of each record are shown. Run {.help [`print(mo_uncertainties(), n = ...)`](AMR::mo_uncertainties)} to view more entries, or save {.help [{.fun mo_uncertainties}](AMR::mo_uncertainties)} to an object.") } if (isTRUE(more_than_50)) { - cat(font_blue(word_wrap("\nOnly the first 50 uncertainties are shown. Run `View(mo_uncertainties())` to view all entries, or save `mo_uncertainties()` to an object."))) + cat("\n") + message_("Only the first 50 uncertainties are shown. Run {.help [`View(mo_uncertainties())`](AMR::mo_uncertainties)} to view all entries, or save {.help [{.fun mo_uncertainties}](AMR::mo_uncertainties)} to an object.") } } @@ -1028,7 +1030,7 @@ print.mo_uncertainties <- function(x, n = 10, ...) { #' @noRd print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) { if (NROW(x) == 0) { - cat(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)) + message_("No renamed taxonomy to show. Only renamed taxonomy of the last call of {.help [{.fun as.mo}](AMR::as.mo)} or any {.help [{.fun mo_*}](AMR::mo_property)} function are stored.") return(invisible(NULL)) } @@ -1039,14 +1041,17 @@ print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) { rows <- seq_len(min(NROW(x), n)) - message_( - "The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":\n", - paste0(" ", AMR_env$bullet_icon, " ", font_italic(x$old[rows], collapse = NULL), x$ref_old[rows], - " -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows], - collapse = "\n" - ), - ifelse(NROW(x) > n, paste0("\n\nOnly the first ", n, " (out of ", NROW(x), ") are shown. Run `print(mo_renamed(), n = ...)` to view more entries (might be slow), or save `mo_renamed()` to an object."), "") - ) + message_("The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":") + old_format <- format(paste0(font_italic(x$old[rows], collapse = NULL), x$ref_old[rows])) # format() will set trailing spaces for textual alignment + old_format <- gsub(" ", "\u00a0", old_format, fixed = TRUE) + for (old_tax in rows) { + message_("\u00a0\u00a0", AMR_env$bullet_icon, " ", old_format[old_tax], " -> ", font_italic(x$new[old_tax]), x$ref_new[old_tax], as_note = FALSE) + } + if (NROW(x) > n) { + message_("\u00a0\u00a0Only the first ", n, " (out of ", NROW(x), ") are shown. Run {.code print(mo_renamed(), n = ...)} to view more entries (might be slow), or save {.fun mo_renamed} to an object.", + as_note = FALSE + ) + } } # UNDOCUMENTED HELPER FUNCTIONS ------------------------------------------- @@ -1251,14 +1256,14 @@ replace_old_mo_codes <- function(x, property) { } if (property != "mo") { warning_( - "in `mo_", property, "()`: the input contained ", n_matched, + "in {.help [{.fun mo_", property, "}](AMR::mo_", property, ")}: the input contained ", n_matched, " old MO code", ifelse(n_matched == 1, "", "s"), " (", n_unique, "from a previous AMR package version). ", - "Please update your MO codes with `as.mo()` to increase speed." + "Please update your MO codes with {.help [{.fun as.mo}](AMR::as.mo)} to increase speed." ) } else { warning_( - "in `as.mo()`: the input contained ", n_matched, + "in {.help [{.fun as.mo}](AMR::as.mo)}: the input contained ", n_matched, " old MO code", ifelse(n_matched == 1, "", "s"), " (", n_unique, "from a previous AMR package version). ", n_solved, " old MO code", ifelse(n_solved == 1, "", "s"), diff --git a/R/mo_property.R b/R/mo_property.R index 0e6fb2b3c..54bc9ca3d 100755 --- a/R/mo_property.R +++ b/R/mo_property.R @@ -584,7 +584,7 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_AMR_locale(), keep_s ab <- rep(ab, length(x)) } if (length(x) != length(ab)) { - stop_("length of `x` and `ab` must be equal, or one of them must be of length 1.") + stop_("length of {.arg x} and {.arg ab} must be equal, or one of them must be of length 1.") } # show used version number once per session (AMR_env will reload every session) @@ -943,7 +943,7 @@ mo_url <- function(x, open = FALSE, language = get_AMR_locale(), keep_synonyms = if (isTRUE(open)) { if (length(u) > 1) { - warning_("in `mo_url()`: only the first URL will be opened, as R's built-in function `browseURL()` only suports one string.") + warning_("in {.fun mo_url}: only the first URL will be opened, as R's built-in function {.fun browseURL} only suports one string.") } utils::browseURL(u[1L]) } @@ -1043,10 +1043,10 @@ find_mo_col <- function(fn) { ) if (!is.null(df) && !is.null(mo) && is.data.frame(df)) { if (message_not_thrown_before(fn = fn)) { - message_("Using column '", font_bold(mo), "' as input for `", fn, "()`") + message_("Using column '", font_bold(mo), "' as input for {.help [{.fun ", fn, "}](AMR::", fn, ")}") } return(df[, mo, drop = TRUE]) } else { - stop_("argument `x` is missing and no column with info about microorganisms could be found.", call = -2) + stop_("argument {.arg x} is missing and no column with info about microorganisms could be found.", call = -2) } } diff --git a/R/mo_source.R b/R/mo_source.R index 3a932db05..89bc7a238 100755 --- a/R/mo_source.R +++ b/R/mo_source.R @@ -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(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) 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)) { unlink(mo_source_destination) message_("Removed mo_source file '", font_bold(mo_source_destination), "'", - add_fn = font_red, 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 <- ifelse(current_ext > -1L, substring(destination, current_ext + 1L), "") 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 {.help [{.fun set_mo_source}](AMR::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)) { AMR_env$mo_source <- readRDS_AMR(path.expand(destination)) @@ -290,7 +289,7 @@ check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_o } if (!"mo" %in% colnames(x)) { if (stop_on_error == TRUE) { - stop_(refer_to_name, " must contain a column 'mo'", call = FALSE) + stop_(refer_to_name, " must contain a column {.field mo}", call = FALSE) } else { return(FALSE) } diff --git a/R/pca.R b/R/pca.R index 1c7bcf2a3..24c6a2e87 100755 --- a/R/pca.R +++ b/R/pca.R @@ -114,7 +114,7 @@ pca <- function(x, x <- as.data.frame(new_list, stringsAsFactors = FALSE) if (any(vapply(FUN.VALUE = logical(1), x, function(y) !is.numeric(y)))) { - warning_("in `pca()`: be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. See Examples in `?pca`.", call = FALSE) + warning_("in {.fun pca}: be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. See {.help [{.fun pca}](AMR::pca)}.", call = FALSE) } # set column names diff --git a/R/plotting.R b/R/plotting.R index 479d4cd71..39fb877d9 100755 --- a/R/plotting.R +++ b/R/plotting.R @@ -258,11 +258,11 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) { } else if (any(other_x %in% colnames(df))) { aest_val <- intersect(other_x, colnames(df))[1] } else { - stop_("No support for plotting df with `scale_", aest, "_mic()` with columns ", vector_and(colnames(df), sort = FALSE)) + stop_("No support for plotting df with {.fun scale_", aest, "_mic} with columns ", vector_and(colnames(df), sort = FALSE)) } mics <- rescale_mic(x = as.double(as.mic(df[[aest_val]])), keep_operators = "none", mic_range = NULL, as.mic = TRUE) if (!is.null(self$mic_values_rescaled) && any(mics < min(self$mic_values_rescaled, na.rm = TRUE) | mics > max(self$mic_values_rescaled, na.rm = TRUE), na.rm = TRUE)) { - warning_("The value for `", aest_val, "` is outside the plotted MIC range, consider using/updating the `mic_range` argument in `scale_", aest, "_mic()`.") + warning_("The value for {.field ", aest_val, "} is outside the plotted MIC range, consider using/updating the {.arg mic_range} argument in {.fun scale_", aest, "_mic}.") } out[[aest_val]] <- log2(as.double(mics)) } else { @@ -412,7 +412,7 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) { scale$labels <- function(x) { stop_ifnot(all(x %in% c(levels(NA_sir_), "SI", "IR", NA)), - "Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see `?as.sir`.", + "Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see {.help [{.fun as.sir}](AMR::as.sir)}.", call = FALSE ) x <- as.character(x) @@ -1443,10 +1443,10 @@ scale_sir_colours <- function(..., meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4)) if ("fill" %in% aesthetics && message_not_thrown_before("scale_sir_colours", "fill", entire_session = TRUE)) { - warning_("Using `scale_sir_colours()` for the `fill` aesthetic has been superseded by `scale_fill_sir()`, please use that instead. This warning will be shown once per session.") + warning_("Using {.fun scale_sir_colours} for the {.code fill} aesthetic has been superseded by {.fun scale_fill_sir}, please use that instead. This warning will be shown once per session.") } if (any(c("colour", "color") %in% aesthetics) && message_not_thrown_before("scale_sir_colours", "colour", entire_session = TRUE)) { - warning_("Using `scale_sir_colours()` for the `colour` aesthetic has been superseded by `scale_colour_sir()`, please use that instead. This warning will be shown once per session.") + warning_("Using {.fun scale_sir_colours} for the {.code colour} aesthetic has been superseded by {.fun scale_colour_sir}, please use that instead. This warning will be shown once per session.") } if ("colours" %in% names(list(...))) { @@ -1590,7 +1590,7 @@ expand_SIR_colours <- function(colours_SIR, unname = TRUE) { # named input: match and reorder stop_ifnot( all(names(colours_SIR) %in% sir_order), - "Unknown names in `colours_SIR`. Expected any of: ", vector_or(levels(NA_sir_), quotes = FALSE, sort = FALSE), "." + "Unknown names in {.arg colours_SIR}. Expected any of: ", vector_or(levels(NA_sir_), quotes = FALSE, sort = FALSE), "." ) if (length(colours_SIR) == 4) { # add colours for SI (same as S) and IR (same as R) diff --git a/R/proportion.R b/R/proportion.R index fb151b1b6..573430210 100644 --- a/R/proportion.R +++ b/R/proportion.R @@ -238,7 +238,7 @@ resistance <- function(..., # other arguments for meet_criteria are handled by sir_calc() meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1) if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("resistance", "eucast_default", entire_session = TRUE)) { - message_("`resistance()` assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the `guideline` argument or the `AMR_guideline` option to either \"CLSI\" or \"EUCAST\", see `?AMR-options`.") + message_("{.help [{.fun resistance}](AMR::resistance)} assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the {.arg guideline} argument or the {.code AMR_guideline} option to either \"CLSI\" or \"EUCAST\", see {.topic [AMR-options](AMR::AMR-options)}.") message_("This message will be shown once per session.") } tryCatch( @@ -266,7 +266,7 @@ susceptibility <- function(..., # other arguments for meet_criteria are handled by sir_calc() meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1) if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("susceptibility", "eucast_default", entire_session = TRUE)) { - message_("`susceptibility()` assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the `guideline` argument or the `AMR_guideline` option to either \"CLSI\" or \"EUCAST\", see `?AMR-options`.") + message_("{.help [{.fun susceptibility}](AMR::susceptibility)} assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the {.arg guideline} argument or the {.code AMR_guideline} option to either \"CLSI\" or \"EUCAST\", see {.topic [AMR-options](AMR::AMR-options)}.") message_("This message will be shown once per session.") } tryCatch( diff --git a/R/resistance_predict.R b/R/resistance_predict.R index fb04c7126..b473c575e 100755 --- a/R/resistance_predict.R +++ b/R/resistance_predict.R @@ -138,7 +138,7 @@ resistance_predict <- function(x, extra_msg = paste0("Use the tidymodels framework instead, for which we have written a basic and short introduction on our website: ", font_url("https://amr-for-r.org/articles/AMR_with_tidymodels.html", txt = font_bold("AMR with tidymodels"))) ) - stop_if(is.null(model), 'choose a regression model with the `model` argument, e.g. resistance_predict(..., model = "binomial")') + stop_if(is.null(model), 'choose a regression model with the {.arg model} argument, e.g. {.code resistance_predict(..., model = "binomial")}') x.bak <- x x <- as.data.frame(x, stringsAsFactors = FALSE) @@ -146,7 +146,7 @@ resistance_predict <- function(x, # -- date if (is.null(col_date)) { col_date <- search_type_in_df(x = x, type = "date") - stop_if(is.null(col_date), "`col_date` must be set") + stop_if(is.null(col_date), "{.arg col_date} must be set") } stop_ifnot( col_date %in% colnames(x), @@ -238,7 +238,7 @@ resistance_predict <- function(x, prediction <- predictmodel$fit se <- predictmodel$se.fit } else { - stop("no valid model selected. See `?resistance_predict`.") + stop("no valid model selected. See {.help [{.fun resistance_predict}](AMR::resistance_predict)}.") } # prepare the output dataframe @@ -357,7 +357,7 @@ ggplot_sir_predict <- function(x, meet_criteria(ribbon, allow_class = "logical", has_length = 1) stop_ifnot_installed("ggplot2") - stop_ifnot(inherits(x, "resistance_predict"), "`x` must be a resistance prediction model created with resistance_predict()") + stop_ifnot(inherits(x, "resistance_predict"), "{.arg x} must be a resistance prediction model created with {.fun resistance_predict}") if (attributes(x)$I_as_S == TRUE) { ylab <- "%R" diff --git a/R/sir.R b/R/sir.R index c9f5e7533..e09561dec 100755 --- a/R/sir.R +++ b/R/sir.R @@ -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 {.help [{.fun as.sir}](AMR::as.sir)}: input values were guessed to be MIC values - preferably transform them with {.help [{.fun as.mic}](AMR::as.mic)} before running {.help [{.fun as.sir}](AMR::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 {.help [{.fun as.sir}](AMR::as.sir)}: input values were guessed to be disk diffusion values - preferably transform them with {.help [{.fun as.disk}](AMR::as.disk)} before running {.help [{.fun as.sir}](AMR::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 {.help [{.fun as.sir}](AMR::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 {.help [{.fun as.sir}](AMR::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") { @@ -816,7 +816,7 @@ as.sir.data.frame <- function(x, # column found, transform to logical stop_if( length(col_uti) != 1 | !col_uti %in% colnames(x), - "argument `uti` must be a [logical] vector, of must be a single column name of `x`" + "argument {.arg uti} must be a [logical] vector, or must be a single column name of {.arg x}" ) uti <- as.logical(x[, col_uti, drop = TRUE]) } @@ -835,8 +835,7 @@ as.sir.data.frame <- function(x, message_( "Assuming value", plural[1], " ", vector_and(col_values, quotes = TRUE), - " in column '", font_bold(col_specimen), - "' reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1], + " in column ", paste0("{.field ", col_specimen, "}"), " reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1], ".\n Use `as.sir(uti = FALSE)` to prevent this." ) } @@ -883,7 +882,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 +897,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) } @@ -975,7 +974,7 @@ as.sir.data.frame <- function(x, if (!all(x[, ab, drop = TRUE] %in% c("S", "SDD", "I", "R", "NI", NA), na.rm = TRUE)) { show_message <- TRUE if (isTRUE(info)) { - message_("Cleaning values in column '", font_bold(ab), "' (", + message_("Cleaning values in column ", paste0("{.field ", ab, "}"), " (", ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""), ab_name(ab_coerced, tolower = TRUE, info = info), ")... ", appendLF = FALSE, @@ -985,7 +984,7 @@ as.sir.data.frame <- function(x, } else if (!is.sir(x.bak[, ab, drop = TRUE])) { show_message <- TRUE if (isTRUE(info)) { - message_("Assigning class 'sir' to already clean column '", font_bold(ab), "' (", + message_("Assigning class {.cls sir} to already clean column ", paste0("{.field ", ab, "}"), " (", ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""), ab_name(ab_coerced, tolower = TRUE, language = NULL, info = info), ")... ", appendLF = FALSE, @@ -1029,14 +1028,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 {.help [{.fun sir_interpretation_history}](AMR::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 +1167,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 {.help [{.fun as.sir}](AMR::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 {.help [{.fun sir_interpretation_history}](AMR::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 +1189,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,9 +1275,9 @@ 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", - "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)`.", + stop_("No information was supplied about the microorganisms (missing argument {.arg mo} and no column of class {.cls mo} found). See {.help [{.fun as.sir}](AMR::as.sir)}.\n\n", + "To transform certain columns with e.g. mutate(), use ", highlight_code("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 ", highlight_code("data %>% as.sir()"), " or ", highlight_code(paste0("data %>% mutate_if(is.", method_short, ", as.sir)")), ".", call = FALSE ) } @@ -1312,7 +1311,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 {.help [{.fun as.sir}](AMR::as.sir)}.", call = FALSE) } ab.bak <- trimws2(ab) @@ -1328,8 +1327,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 {.help [{.fun as.ab}](AMR::as.ab)}.", as_note = FALSE ) } @@ -1353,9 +1351,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 {.help [{.fun as.sir}](AMR::as.sir)}: using {.arg add_intrinsic_resistance} is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.") } } @@ -1724,7 +1720,7 @@ as_sir_method <- function(method_short, pm_filter(uti == FALSE) notes_current <- paste0( notes_current, "\n", - paste0("Breakpoints for UTI ", font_bold("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, ". Use argument `uti` to set which isolates are from urine. See `?as.sir`.") + paste0("Breakpoints for UTI ", font_bold("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, ". Use argument {.arg uti} to set which isolates are from urine. See {.help [{.fun as.sir}](AMR::as.sir)}.") ) } else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && all(breakpoints_current$uti == FALSE, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteOther", mo_current, ab_current)) { # breakpoints for multiple body sites available @@ -1947,10 +1943,10 @@ 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_(notes[i], as_note = FALSE) } } 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("\u00a0\u00a0", 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)) } } else { message(font_green_bg(" OK ")) @@ -1991,7 +1987,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 {.help [{.fun as.sir}](AMR::as.sir)} on MIC values or disk diffusion zones (or on a {.cls data.frame} containing any of these) to print a {.val logbook} data set here.") return(invisible(NULL)) } class(x) <- class(x)[class(x) != "sir_log"] @@ -2230,10 +2226,13 @@ 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 {.topic [clinical_breakpoints](AMR::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) + bad_col <- names(class_ref[class_sir != class_ref][1]) + bad_cls <- gsub("<|>", "", class_ref[class_sir != class_ref][1]) + exp_cls <- gsub("<|>", "", class_sir[class_sir != class_ref][1]) + stop_("{.arg reference_data} must be the same structure as the {.topic [clinical_breakpoints](AMR::clinical_breakpoints)} data set. Column ", paste0("{.field ", bad_col, "}"), " is of class ", paste0("{.cls ", bad_cls, "}"), ", but should be of class ", paste0("{.cls ", exp_cls, "}"), call = .call_depth) } } } diff --git a/R/sir_calc.R b/R/sir_calc.R index b7a338001..5c6129e88 100755 --- a/R/sir_calc.R +++ b/R/sir_calc.R @@ -60,11 +60,6 @@ sir_calc <- function(..., dots <- eval(substitute(alist(...))) stop_if(length(dots) == 0, "no variables selected", call = -2) - stop_if("also_single_tested" %in% names(dots), - "`also_single_tested` was replaced by `only_all_tested`.\n", - "Please read Details in the help page (`?proportion`) as this may have a considerable impact on your analysis.", - call = -2 - ) ndots <- length(dots) if (is.data.frame(dots_df)) { @@ -144,7 +139,7 @@ sir_calc <- function(..., FUN = min ) if ("SDD" %in% ab_result && "SDD" %in% y && message_not_thrown_before("sir_calc", only_count, ab_result, entire_session = TRUE)) { - message_("Note that `", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "()` will also include dose-dependent susceptibility, 'SDD'. This note will be shown once for this session.", as_note = FALSE) + message_("Note that {.fun ", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "} will also include dose-dependent susceptibility, {.val SDD}. This note will be shown once for this session.", as_note = FALSE) } numerator <- sum(!is.na(y) & y %in% as.double(ab_result), na.rm = TRUE) denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(anyNA(y)))) @@ -152,7 +147,7 @@ sir_calc <- function(..., # may contain NAs in any column other_values <- setdiff(c(NA, denominator_vals), ab_result) if ("SDD" %in% ab_result && "SDD" %in% unlist(x_transposed) && message_not_thrown_before("sir_calc", only_count, ab_result, entire_session = TRUE)) { - message_("Note that `", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "()` will also include dose-dependent susceptibility, 'SDD'. This note will be shown once for this session.", as_note = FALSE) + message_("Note that {.fun ", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "} will also include dose-dependent susceptibility, {.val SDD}. This note will be shown once for this session.", as_note = FALSE) } numerator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) any(y %in% ab_result, na.rm = TRUE))) denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(all(y %in% other_values) & anyNA(y)))) @@ -164,7 +159,7 @@ sir_calc <- function(..., print_warning <- TRUE } if ("SDD" %in% ab_result && "SDD" %in% x && message_not_thrown_before("sir_calc", only_count, ab_result, entire_session = TRUE)) { - message_("Note that `", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "()` will also include dose-dependent susceptibility, 'SDD'. This note will be shown once for this session.", as_note = FALSE) + message_("Note that `", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "()` will also include dose-dependent susceptibility, {.val SDD}. This note will be shown once for this session.", as_note = FALSE) } numerator <- sum(x %in% ab_result, na.rm = TRUE) denominator <- sum(x %in% denominator_vals, na.rm = TRUE) @@ -172,8 +167,8 @@ sir_calc <- function(..., if (print_warning == TRUE) { if (message_not_thrown_before("sir_calc")) { - warning_("Increase speed by transforming to class 'sir' on beforehand:\n", - " your_data %>% mutate_if(is_sir_eligible, as.sir)", + warning_("Increase speed by transforming to class {.cls sir} on beforehand:\n", + highlight_code(" your_data %>% mutate_if(is_sir_eligible, as.sir)"), call = FALSE ) } diff --git a/R/top_n_microorganisms.R b/R/top_n_microorganisms.R index 873003dc8..4b08f2c85 100755 --- a/R/top_n_microorganisms.R +++ b/R/top_n_microorganisms.R @@ -62,7 +62,7 @@ top_n_microorganisms <- function(x, n, property = "species", n_for_each = NULL, meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x)) if (is.null(col_mo)) { col_mo <- search_type_in_df(x = x, type = "mo", info = TRUE) - stop_if(is.null(col_mo), "`col_mo` must be set") + stop_if(is.null(col_mo), "{.arg col_mo} must be set") } x.bak <- x diff --git a/R/translate.R b/R/translate.R index 8cf706247..6690aa144 100755 --- a/R/translate.R +++ b/R/translate.R @@ -249,7 +249,7 @@ translate_into_language <- function(from, any_form_in_patterns <- tryCatch( any(from_unique %like% paste0("(", paste(gsub(" +\\(.*", "", df_trans$pattern), collapse = "|"), ")")), 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) } ) @@ -293,11 +293,11 @@ translate_into_language <- function(from, 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()) { - message(word_wrap( + message(font_blue(word_wrap( "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.", - add_fn = list(font_blue), as_note = TRUE - )) + as_note = TRUE + ))) } out diff --git a/R/zz_deprecated.R b/R/zz_deprecated.R index 82fc127cb..fb9b7c1dc 100755 --- a/R/zz_deprecated.R +++ b/R/zz_deprecated.R @@ -124,7 +124,7 @@ deprecation_warning <- function(old = NULL, new = NULL, fn = NULL, extra_msg = N ". The old name will be removed in future version, so please update your code.", ifelse(type == "argument", ". While the old argument still works, it will be removed in a future version, so please update your code.", - " and will be removed in a future version, see `?AMR-deprecated`." + " and will be removed in a future version, see {.topic [AMR-deprecated](AMR::AMR-deprecated)}." ) ), ifelse(!is.null(extra_msg), diff --git a/R/zzz.R b/R/zzz.R index 9da1110f9..39eca912f 100755 --- a/R/zzz.R +++ b/R/zzz.R @@ -116,43 +116,40 @@ AMR_env$cross_icon <- if (isTRUE(base::l10n_info()$`UTF-8`)) "\u00d7" else "x" .onAttach <- function(libname, pkgname) { if (interactive() && is.null(getOption("AMR_guideline"))) { - packageStartupMessage( - word_wrap( - "Assuming ", AMR::clinical_breakpoints$guideline[1], " as the default AMR guideline, see `?AMR-options` to change this.", - add_fn = NULL - ) - ) + packageStartupMessage(format_inline_( + "Assuming ", AMR::clinical_breakpoints$guideline[1], " as the default AMR guideline, see {.topic [AMR-options](AMR::AMR-options)} to change this." + )) } # if custom ab option is available, load it if (!is.null(getOption("AMR_custom_ab")) && file.exists(getOption("AMR_custom_ab", default = ""))) { if (getOption("AMR_custom_ab") %unlike% "[.]rds$") { - packageStartupMessage("The file with custom antimicrobials must be an RDS file. Set the option `AMR_custom_ab` to another path.") + packageStartupMessage(format_inline_("The file with custom antimicrobials must be an RDS file. Set the option {.code AMR_custom_ab} to another path.")) } else { - packageStartupMessage("Adding custom antimicrobials from '", getOption("AMR_custom_ab"), "'...", appendLF = FALSE) + packageStartupMessage(format_inline_("Adding custom antimicrobials from '", getOption("AMR_custom_ab"), "'..."), appendLF = FALSE) x <- readRDS_AMR(getOption("AMR_custom_ab")) tryCatch( { suppressWarnings(suppressMessages(add_custom_antimicrobials(x))) packageStartupMessage("OK.") }, - error = function(e) packageStartupMessage("Failed: ", conditionMessage(e)) + error = function(e) packageStartupMessage(format_inline_("Failed: ", conditionMessage(e))) ) } } # if custom mo option is available, load it if (!is.null(getOption("AMR_custom_mo")) && file.exists(getOption("AMR_custom_mo", default = ""))) { if (getOption("AMR_custom_mo") %unlike% "[.]rds$") { - packageStartupMessage("The file with custom microorganisms must be an RDS file. Set the option `AMR_custom_mo` to another path.") + packageStartupMessage(format_inline_("The file with custom microorganisms must be an RDS file. Set the option {.code AMR_custom_mo} to another path.")) } else { - packageStartupMessage("Adding custom microorganisms from '", getOption("AMR_custom_mo"), "'...", appendLF = FALSE) + packageStartupMessage(format_inline_("Adding custom microorganisms from '", getOption("AMR_custom_mo"), "'..."), appendLF = FALSE) x <- readRDS_AMR(getOption("AMR_custom_mo")) tryCatch( { suppressWarnings(suppressMessages(add_custom_microorganisms(x))) packageStartupMessage("OK.") }, - error = function(e) packageStartupMessage("Failed: ", conditionMessage(e)) + error = function(e) packageStartupMessage(format_inline_("Failed: ", conditionMessage(e))) ) } } diff --git a/tests/testthat/test-mo.R b/tests/testthat/test-mo.R index 7bec1d7ad..78653ce2e 100644 --- a/tests/testthat/test-mo.R +++ b/tests/testthat/test-mo.R @@ -270,10 +270,8 @@ test_that("test-mo.R", { ))), c("B_MCRBC_PRXY", "B_STRPT_SUIS", "B_KLBSL_TRRG") ) - expect_output(print(mo_uncertainties())) + x <- as.mo("Sta. aur") - # many hits - expect_output(print(mo_uncertainties())) # no viruses expect_equal(suppressWarnings(as.mo("Virus")), as.mo("UNKNOWN")) diff --git a/tests/testthat/test-proportion.R b/tests/testthat/test-proportion.R index 93a01ad6e..58e489b9f 100755 --- a/tests/testthat/test-proportion.R +++ b/tests/testthat/test-proportion.R @@ -138,7 +138,6 @@ test_that("test-proportion.R", { expect_error(proportion_I("test", as_percent = "test")) expect_error(proportion_S("test", minimum = "test")) expect_error(proportion_S("test", as_percent = "test")) - expect_error(proportion_S("test", also_single_tested = TRUE)) # check too low amount of isolates expect_identical( diff --git a/tests/testthat/test-zzz.R b/tests/testthat/test-zzz.R index b40e4fb92..602ac21fa 100644 --- a/tests/testthat/test-zzz.R +++ b/tests/testthat/test-zzz.R @@ -36,6 +36,7 @@ test_that("test-zzz.R", { # functions used by import_fn() import_functions <- c( "%chin%" = "data.table", + "ansi_has_hyperlink_support" = "cli", "anti_join" = "dplyr", "as.data.table" = "data.table", "as_tibble" = "tibble", @@ -79,6 +80,11 @@ test_that("test-zzz.R", { "freq.default" = "cleaner", "percentage" = "cleaner", # cli + "cli_abort" = "cli", + "cli_inform" = "cli", + "cli_warn" = "cli", + "code_highlight" = "cli", + "format_inline" = "cli", "symbol" = "cli", # curl "has_internet" = "curl", @@ -161,7 +167,9 @@ test_that("test-zzz.R", { "vec_math" = "vctrs", "vec_ptype2" = "vctrs", "vec_ptype_abbr" = "vctrs", - "vec_ptype_full" = "vctrs" + "vec_ptype_full" = "vctrs", + # usethis + "use_course" = "usethis" ) import_functions <- c(import_functions, call_functions)