1
0
mirror of https://github.com/msberends/AMR.git synced 2026-03-19 17:02:24 +01:00

19 Commits

Author SHA1 Message Date
Claude
51f689b069 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
2026-03-19 10:39:26 +00:00
Claude
1dabd4df3d 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
2026-03-19 08:35:26 +00:00
Claude
5173009625 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
2026-03-19 07:42:42 +00:00
Claude
80e267f0d1 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
2026-03-19 07:40:09 +00:00
Claude
05d3ca941f 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
2026-03-19 07:29:04 +00:00
Claude
ec310ed76b 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
2026-03-19 07:24:09 +00:00
Claude
3e4983ff93 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
2026-03-18 23:36:53 +00:00
Claude
7218812c99 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
2026-03-18 23:23:20 +00:00
Claude
eae14d44bf 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
2026-03-18 23:09:02 +00:00
Claude
11c175ae19 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
2026-03-18 23:06:36 +00:00
Claude
ec3b12b937 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
2026-03-18 22:56:44 +00:00
Claude
5ecbc9001e 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
2026-03-18 22:47:38 +00:00
Claude
8760c6d85a 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
2026-03-18 22:41:43 +00:00
Claude
3928a3de55 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
2026-03-18 22:37:46 +00:00
Claude
10c00ff606 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
2026-03-18 22:23:39 +00:00
Claude
b7edf3e548 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
2026-03-18 22:14:30 +00:00
Claude
0cc154257a 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
2026-03-18 20:06:52 +00:00
Claude
4798d2c55e 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
2026-03-18 16:06:30 +00:00
Claude
ad31fba556 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
2026-03-18 12:10:17 +00:00
46 changed files with 463 additions and 444 deletions

View File

@@ -28,11 +28,8 @@
# ==================================================================== # # ==================================================================== #
on: on:
pull_request:
# run in each PR in this repo
branches: '**'
push: push:
branches: '**' branches: [main]
schedule: schedule:
# also run a schedule everyday at 1 AM. # also run a schedule everyday at 1 AM.
# this is to check that all dependencies are still available (see R/zzz.R) # this is to check that all dependencies are still available (see R/zzz.R)

View File

@@ -29,10 +29,11 @@
on: on:
pull_request: pull_request:
# run in each PR in this repo # run in each PR in this repo (1 worker, see matrix logic below)
branches: '**' branches: '**'
push: push:
branches: '**' # only on main; pushing to a PR branch is already covered by pull_request above
branches: [main]
schedule: schedule:
# also run a schedule everyday at 1 AM. # also run a schedule everyday at 1 AM.
# this is to check that all dependencies are still available (see R/zzz.R) # this is to check that all dependencies are still available (see R/zzz.R)
@@ -41,7 +42,22 @@ on:
name: check-recent name: check-recent
jobs: 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: R-code-check:
needs: setup
runs-on: ${{ matrix.config.os }} runs-on: ${{ matrix.config.os }}
continue-on-error: ${{ matrix.config.allowfail }} continue-on-error: ${{ matrix.config.allowfail }}
@@ -50,23 +66,7 @@ jobs:
strategy: strategy:
fail-fast: false fail-fast: false
matrix: matrix: ${{ fromJSON(needs.setup.outputs.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}
env: env:
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}

View File

@@ -29,8 +29,8 @@
on: on:
push: push:
# only run after a git push on any branch in this repo # only run after a git push on the main branch
branches: '**' branches: [main]
name: check-old name: check-old

View File

@@ -28,10 +28,12 @@
# ==================================================================== # # ==================================================================== #
on: on:
push:
branches: '**'
pull_request: pull_request:
# run on every PR update (once per push)
branches: '**' branches: '**'
push:
# only on main; PR pushes are already covered by pull_request above
branches: [main]
name: code-coverage name: code-coverage

View File

@@ -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): 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 1. **`DESCRIPTION`** — the `Version:` field
2. **`NEWS.md`** — the top-level heading `# AMR <version>` 2. **`NEWS.md`** — **only replace line 1** (the `# AMR <version>` 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. 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.

View File

@@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 3.0.1.9035 Version: 3.0.1.9038
Date: 2026-03-18 Date: 2026-03-19
Title: Antimicrobial Resistance Data Analysis Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR) Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by data analysis and to work with microbial and antimicrobial properties by

10
NEWS.md
View File

@@ -1,4 +1,4 @@
# AMR 3.0.1.9035 # AMR 3.0.1.9038
### New ### New
* Integration with the **tidymodels** framework to allow seamless use of SIR, MIC and disk data in modelling pipelines via `recipes` * Integration with the **tidymodels** framework to allow seamless use of SIR, MIC and disk data in modelling pipelines via `recipes`
@@ -30,6 +30,9 @@
* Fixed SIR and MIC coercion of combined values, e.g. `as.sir("<= 0.002; S") ` or `as.mic("S; 0.002")` (#252) * Fixed SIR and MIC coercion of combined values, e.g. `as.sir("<= 0.002; S") ` or `as.mic("S; 0.002")` (#252)
### Updates ### Updates
* Replaced all bare backtick-quoted text in `message_()`, `warning_()`, and `stop_()` calls with proper cli inline markup (`{.arg}`, `{.cls}`, `{.fun}`, `{.pkg}`, `{.code}`); rewrote `print.ab` to use a cli named-vector with `*` bullets and code highlighting when cli is available
* Added `format_inline_()` helper that formats a cli-markup string and returns it (rather than emitting it), using `cli::format_inline()` when available and `cli_to_plain()` otherwise; used this in `.onAttach` to replace the duplicated cli/non-cli startup message pattern
* All inline `{variable}` / `{expression}` in messaging calls are now pre-evaluated via `paste0()`, so users without cli or glue never see raw template syntax
* `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). * `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. * `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`) * 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`)
@@ -44,6 +47,11 @@
* Removed the `"inverse"` option, which has now become redundant * Removed the `"inverse"` option, which has now become redundant
* `ab_group()` now returns values consist with the AMR selectors (#246) * `ab_group()` now returns values consist with the AMR selectors (#246)
* Added two new `NA` objects, `NA_ab_` and `NA_mo_`, analogous to base R's `NA_character_` and `NA_integer_`, for use in pipelines that require typed missing values * Added two new `NA` objects, `NA_ab_` and `NA_mo_`, analogous to base R's `NA_character_` and `NA_integer_`, for use in pipelines that require typed missing values
* `message_()`, `warning_()`, `stop_()` now use `cli` markup when available, with plain-text fallback; removed `add_fn` parameter from `message_()`, `warning_()`, `word_wrap()`
* New internal `cli_to_plain()` converts `cli` markup to plain text for non-cli path
* All internal call sites updated to `cli` glue syntax
* CI dev-version and old-tinytest workflows now only run on `main` branch pushes
* Single-quoted literal values in messaging calls replaced with `{.val}`, `{.cls}`, `{.field}`, or `{.code}` markup throughout
# AMR 3.0.1 # AMR 3.0.1

View File

@@ -304,9 +304,8 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
if (!is.null(found)) { if (!is.null(found)) {
# this column should contain logicals # this column should contain logicals
if (!is.logical(x[, found, drop = TRUE])) { if (!is.logical(x[, found, drop = TRUE])) {
message_("Column '", font_bold(found), "' found as input for `", ifelse(add_col_prefix, "col_", ""), type, message_("Column '", font_bold(found), "' found as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type,
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.", "}, but this column does not contain {.code TRUE}/{.code FALSE} values and was ignored."
add_fn = font_red
) )
found <- NULL found <- NULL
} }
@@ -383,6 +382,27 @@ pkg_is_available <- function(pkg, also_load = FALSE, min_version = NULL) {
isTRUE(out) 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) { import_fn <- function(name, pkg, error_on_fail = TRUE) {
if (isTRUE(error_on_fail)) { if (isTRUE(error_on_fail)) {
stop_ifnot_installed(pkg) stop_ifnot_installed(pkg)
@@ -397,8 +417,8 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
getExportedValue(name = name, ns = asNamespace(pkg)), getExportedValue(name = name, ns = asNamespace(pkg)),
error = function(e) { error = function(e) {
if (isTRUE(error_on_fail)) { if (isTRUE(error_on_fail)) {
stop_("function `", name, "()` is not an exported object from package '", pkg, stop_("function {.code ", name, "()} is not an exported object from package '", pkg,
"'. Please create an issue at ", font_url("https://github.com/msberends/AMR/issues"), ". Many thanks!", "'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
call = FALSE call = FALSE
) )
} else { } else {
@@ -408,30 +428,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: # this alternative wrapper to the message(), warning() and stop() functions:
# - wraps text to never break lines within words # - wraps text to never break lines within words (plain-text fallback only)
# - ignores formatted text while wrapping # - adds indentation for note-style messages (plain-text fallback only)
# - adds indentation dependent on the type of message (such as NOTE) # When cli is available this just returns the pasted input; cli handles formatting.
# - can add additional formatting functions like blue or bold text
word_wrap <- function(..., word_wrap <- function(...,
add_fn = list(),
as_note = FALSE, as_note = FALSE,
width = 0.95 * getOption("width"), width = 0.95 * getOption("width"),
extra_indent = 0) { extra_indent = 0) {
if (pkg_is_available("cli", min_version = "3.0.0")) {
return(paste0(c(...), collapse = ""))
}
msg <- paste0(c(...), collapse = "") msg <- paste0(c(...), collapse = "")
if (isTRUE(as_note)) { if (isTRUE(as_note)) {
msg <- paste0(AMR_env$info_icon, " ", gsub("^note:? ?", "", msg, ignore.case = TRUE)) msg <- paste0(AMR_env$info_icon, " ", gsub("^note:? ?", "", msg, ignore.case = TRUE))
} }
if (grepl("\n", msg, fixed = TRUE)) {
if (msg %like% "\n") {
# run word_wraps() over every line here, bind them and return again
return(paste0( return(paste0(
vapply( vapply(
FUN.VALUE = character(1), FUN.VALUE = character(1),
trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"), trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"),
word_wrap, word_wrap,
add_fn = add_fn,
as_note = FALSE, as_note = FALSE,
width = width, width = width,
extra_indent = extra_indent extra_indent = extra_indent
@@ -439,146 +537,75 @@ word_wrap <- function(...,
collapse = "\n" collapse = "\n"
)) ))
} }
wrapped <- paste0(strwrap(msg, width = width), collapse = "\n")
# correct for operators (will add the space later on) if (grepl("\u2139 ", msg, fixed = TRUE)) {
ops <- "([,./><\\]\\[])" indentation <- 2L + extra_indent
msg <- gsub(paste0(ops, " ", ops), "\\1\\2", msg, perl = TRUE) } else if (grepl("^=> ", msg)) {
# we need to correct for already applied style, that adds text like "\033[31m\" indentation <- 3L + extra_indent
msg_stripped <- gsub("(.*)?\\033\\]8;;.*\\a(.*?)\\033\\]8;;\\a(.*)", "\\1\\2\\3", msg, perl = TRUE) # for font_url()
msg_stripped <- font_stripstyle(msg_stripped)
# where are the spaces now?
msg_stripped_wrapped <- paste0(
strwrap(msg_stripped,
simplify = TRUE,
width = width
),
collapse = "\n"
)
msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")),
collapse = "\n"
)
msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "", fixed = TRUE)) == " ")
msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "", fixed = TRUE)) != "\n")
# so these are the indices of spaces that need to be replaced
replace_spaces <- which(!msg_stripped_spaces %in% msg_stripped_wrapped_spaces)
# put it together
msg <- unlist(strsplit(msg, " ", fixed = TRUE))
msg[replace_spaces] <- paste0(msg[replace_spaces], "\n")
# add space around operators again
msg <- gsub(paste0(ops, ops), "\\1 \\2", msg, perl = TRUE)
msg <- paste0(msg, collapse = " ")
msg <- gsub("\n ", "\n", msg, fixed = TRUE)
if (msg_stripped %like% "\u2139 ") {
indentation <- 2 + extra_indent
} else if (msg_stripped %like% "^=> ") {
indentation <- 3 + extra_indent
} else { } else {
indentation <- 0 + extra_indent indentation <- 0L + extra_indent
} }
msg <- gsub("\n", paste0("\n", strrep(" ", indentation)), msg, fixed = TRUE) if (indentation > 0L) {
# remove trailing empty characters wrapped <- gsub("\n", paste0("\n", strrep(" ", indentation)), wrapped, fixed = TRUE)
msg <- gsub("(\n| )+$", "", msg)
if (length(add_fn) > 0) {
if (!is.list(add_fn)) {
add_fn <- list(add_fn)
}
for (i in seq_len(length(add_fn))) {
msg <- add_fn[[i]](msg)
}
} }
gsub("(\n| )+$", "", wrapped)
# format backticks
if (pkg_is_available("cli") && in_rstudio() &&
tryCatch(getExportedValue("versionInfo", ns = asNamespace("rstudioapi"))()$version > "2023.6.0.0", error = function(e) {
return(FALSE)
})) {
# we are in a recent version of RStudio, so do something nice: add links to our help pages in the console.
parts <- strsplit(msg, "`", fixed = TRUE)[[1]]
cmds <- parts %in% paste0(ls(envir = asNamespace("AMR")), "()")
# functions with a dot are not allowed: https://github.com/rstudio/rstudio/issues/11273#issuecomment-1156193252
# lead them to the help page of our package
parts[cmds & parts %like% "[.]"] <- font_url(
url = paste0("ide:help:AMR::", gsub("()", "", parts[cmds & parts %like% "[.]"], fixed = TRUE)),
txt = parts[cmds & parts %like% "[.]"]
)
# datasets should give help page as well
parts[parts %in% c("antimicrobials", "microorganisms", "microorganisms.codes", "microorganisms.groups")] <- font_url(
url = paste0("ide:help:AMR::", gsub("()", "", parts[parts %in% c("antimicrobials", "microorganisms", "microorganisms.codes", "microorganisms.groups")], fixed = TRUE)),
txt = parts[parts %in% c("antimicrobials", "microorganisms", "microorganisms.codes", "microorganisms.groups")]
)
# text starting with `?` must also lead to the help page
parts[parts %like% "^[?].+"] <- font_url(
url = paste0("ide:help:AMR::", gsub("?", "", parts[parts %like% "^[?].+"], fixed = TRUE)),
txt = parts[parts %like% "^[?].+"]
)
msg <- paste0(parts, collapse = "`")
}
# msg <- gsub("`(.+?)`", font_grey_bg("`\\1`"), msg)
# clean introduced whitespace in between fullstops
msg <- gsub("[.] +[.]", "..", msg)
# remove extra space that was introduced (e.g. "Smith et al. , 2022")
msg <- gsub(". ,", ".,", msg, fixed = TRUE)
msg <- gsub("[ ,", "[,", msg, fixed = TRUE)
msg <- gsub("/ /", "//", msg, fixed = TRUE)
msg
} }
message_ <- function(..., message_ <- function(...,
appendLF = TRUE, appendLF = TRUE,
add_fn = list(font_blue),
as_note = TRUE) { as_note = TRUE) {
message( if (pkg_is_available("cli", min_version = "3.0.0")) {
word_wrap(..., msg <- paste0(c(...), collapse = "")
add_fn = add_fn, if (isTRUE(as_note)) {
as_note = as_note cli::cli_inform(c("i" = msg), .envir = parent.frame())
), } else {
appendLF = appendLF cli::cli_inform(msg, .envir = parent.frame())
) }
} else {
plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
message(word_wrap(plain_msg, as_note = as_note), appendLF = appendLF)
}
} }
warning_ <- function(..., warning_ <- function(...,
add_fn = list(),
immediate = FALSE, immediate = FALSE,
call = FALSE) { call = FALSE) {
warning( if (pkg_is_available("cli", min_version = "3.0.0")) {
trimws2(word_wrap(..., msg <- paste0(c(...), collapse = "")
add_fn = add_fn, cli::cli_warn(msg, .envir = parent.frame())
as_note = FALSE } else {
)), plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
immediate. = immediate, warning(trimws2(word_wrap(plain_msg, as_note = FALSE)), immediate. = immediate, call. = call)
call. = call }
)
} }
# this alternative to the stop() function: # this alternative to the stop() function:
# - adds the function name where the error was thrown # - adds the function name where the error was thrown (plain-text fallback)
# - wraps text to never break lines within words # - wraps text to never break lines within words (plain-text fallback)
stop_ <- function(..., call = TRUE) { stop_ <- function(..., call = TRUE) {
msg <- paste0(c(...), collapse = "") msg <- paste0(c(...), collapse = "")
msg_call <- "" if (pkg_is_available("cli", min_version = "3.0.0")) {
if (!isFALSE(call)) {
if (isTRUE(call)) { if (isTRUE(call)) {
call <- as.character(sys.call(-1)[1]) call_obj <- sys.call(-1)
} else if (!isFALSE(call)) {
call_obj <- sys.call(call)
} else { } else {
# so you can go back more than 1 call, as used in sir_calc(), that now throws a reference to e.g. n_sir() call_obj <- NULL
call <- as.character(sys.call(call)[1])
} }
msg_call <- paste0("in ", call, "():") cli::cli_abort(msg, call = call_obj, .envir = parent.frame())
}
msg <- trimws2(word_wrap(msg, add_fn = list(), as_note = FALSE))
if (!is.null(AMR_env$cli_abort) && length(unlist(strsplit(msg, "\n", fixed = TRUE))) <= 1) {
if (is.character(call)) {
call <- as.call(str2lang(paste0(call, "()")))
} else {
call <- NULL
}
AMR_env$cli_abort(msg, call = call)
} else { } else {
stop(paste(msg_call, msg), call. = FALSE) msg_call <- ""
if (!isFALSE(call)) {
if (isTRUE(call)) {
call_name <- as.character(sys.call(-1)[1])
} else {
# go back more than 1 call, as used in sir_calc() to reference e.g. n_sir()
call_name <- as.character(sys.call(call)[1])
}
msg_call <- paste0("in ", call_name, "():")
}
plain_msg <- cli_to_plain(trimws2(word_wrap(msg, as_note = FALSE)), envir = parent.frame())
stop(paste(msg_call, plain_msg), call. = FALSE)
} }
} }
@@ -621,7 +648,7 @@ stop_ifnot <- function(expr, ..., call = TRUE) {
return_after_integrity_check <- function(value, type, check_vector) { return_after_integrity_check <- function(value, type, check_vector) {
if (!all(value[!is.na(value)] %in% check_vector)) { if (!all(value[!is.na(value)] %in% check_vector)) {
warning_(paste0("invalid ", type, ", NA generated")) warning_("invalid ", type, ", NA generated")
value[!value %in% check_vector] <- NA value[!value %in% check_vector] <- NA
} }
value value
@@ -757,7 +784,7 @@ format_class <- function(class, plural = FALSE) {
ifelse(plural, "s", "") ifelse(plural, "s", "")
) )
# exceptions # 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" class[class == "data.frame"] <- "a data set"
if ("list" %in% class) { if ("list" %in% class) {
class <- "a list" class <- "a list"
@@ -766,12 +793,12 @@ format_class <- function(class, plural = FALSE) {
class <- "a matrix" class <- "a matrix"
} }
if ("custom_eucast_rules" %in% class) { 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)) { 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 # output
vector_or(class, quotes = FALSE, sort = FALSE) vector_or(class, quotes = FALSE, sort = FALSE)
} }
@@ -806,11 +833,11 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
AMR_env$meet_criteria_error_txt <- NULL AMR_env$meet_criteria_error_txt <- NULL
if (is.null(object)) { 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()) return(invisible())
} }
if (is.null(dim(object)) && length(object) == 1 && suppressWarnings(is.na(object))) { # suppressWarnings for functions 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()) return(invisible())
} }
@@ -820,32 +847,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)) { if (!is.null(allow_class) && !(suppressWarnings(all(is.na(object))) && allow_NA == TRUE)) {
stop_ifnot(inherits(object, allow_class), "argument `", obj_name, stop_ifnot(inherits(object, allow_class), "argument {.arg ", obj_name,
"` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)), "} must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)), ", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)),
call = call_depth call = call_depth
) )
# check data.frames for data # check data.frames for data
if (inherits(object, "data.frame")) { if (inherits(object, "data.frame")) {
stop_if(any(dim(object) == 0), stop_if(any(dim(object) == 0),
"the data provided in argument `", obj_name, "the data provided in argument {.arg ", obj_name,
"` must contain rows and columns (current dimensions: ", "} must contain rows and columns (current dimensions: ",
paste(dim(object), collapse = "x"), ")", paste(dim(object), collapse = "x"), ")",
call = call_depth call = call_depth
) )
} }
} }
if (!is.null(has_length)) { if (!is.null(has_length)) {
stop_ifnot(length(object) %in% has_length, "argument `", obj_name, stop_ifnot(length(object) %in% has_length, "argument {.arg ", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""), "} must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"be of length ", vector_or(has_length, quotes = FALSE), "be of length ", vector_or(has_length, quotes = FALSE),
", not ", length(object), ", not ", length(object),
call = call_depth call = call_depth
) )
} }
if (!is.null(looks_like)) { if (!is.null(looks_like)) {
stop_ifnot(object %like% looks_like, "argument `", obj_name, stop_ifnot(object %like% looks_like, "argument {.arg ", obj_name,
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""), "} must ", # ifelse(allow_NULL, "be NULL or must ", ""),
"resemble the regular expression \"", looks_like, "\"", "resemble the regular expression \"", looks_like, "\"",
call = call_depth call = call_depth
) )
@@ -863,7 +890,7 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
if ("logical" %in% allow_class) { if ("logical" %in% allow_class) {
or_values <- paste0(or_values, ", or TRUE or FALSE") 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, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"must be either ", "must be either ",
"must only contain values " "must only contain values "
@@ -874,8 +901,8 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
) )
} }
if (isTRUE(is_positive)) { if (isTRUE(is_positive)) {
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name, stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument {.arg ", obj_name,
"` must ", "} must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a number higher than zero", "be a number higher than zero",
"all be numbers higher than zero" "all be numbers higher than zero"
@@ -884,8 +911,8 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
) )
} }
if (isTRUE(is_positive_or_zero)) { if (isTRUE(is_positive_or_zero)) {
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name, stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument {.arg ", obj_name,
"` must ", "} must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be zero or a positive number", "be zero or a positive number",
"all be zero or numbers higher than zero" "all be zero or numbers higher than zero"
@@ -894,8 +921,8 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
) )
} }
if (isTRUE(is_finite)) { if (isTRUE(is_finite)) {
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name, stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument {.arg ", obj_name,
"` must ", "} must ",
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1, ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
"be a finite number", "be a finite number",
"all be finite numbers" "all be finite numbers"
@@ -929,9 +956,9 @@ ascertain_sir_classes <- function(x, obj_name) {
sirs <- vapply(FUN.VALUE = logical(1), x, is.sir) sirs <- vapply(FUN.VALUE = logical(1), x, is.sir)
if (!any(sirs, na.rm = TRUE)) { if (!any(sirs, na.rm = TRUE)) {
warning_( warning_(
"the data provided in argument `", obj_name, "the data provided in argument {.arg ", obj_name,
"` should contain at least one column of class 'sir'. Eligible SIR column were now guessed. ", "} should contain at least one column of class {.cls sir}. Eligible SIR columns were now guessed. ",
"See `?as.sir`.", "See {.help [{.fun as.sir}](AMR::as.sir)}.",
immediate = TRUE immediate = TRUE
) )
sirs_eligible <- is_sir_eligible(x) sirs_eligible <- is_sir_eligible(x)
@@ -1033,13 +1060,13 @@ get_current_data <- function(arg_name, call) {
} else { } else {
examples <- "" 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 {.code data.frame} call",
examples, examples,
call = call call = call
) )
} else { } else {
# mimic a base R error that the argument is missing # 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 +1660,7 @@ if (!is.null(import_fn("where", "tidyselect", error_on_fail = FALSE))) {
where <- function(fn) { where <- function(fn) {
# based on https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32 # based on https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
if (!is.function(fn)) { 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 df <- pm_select_env$.data
cols <- pm_select_env$get_colnames() cols <- pm_select_env$get_colnames()
@@ -1648,7 +1675,7 @@ if (!is.null(import_fn("where", "tidyselect", error_on_fail = FALSE))) {
}, },
fn 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 data_cols <- cols
cols <- data_cols[preds] cols <- data_cols[preds]
which(data_cols %in% cols) which(data_cols %in% cols)

33
R/ab.R
View File

@@ -210,7 +210,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 progress <- progress_ticker(n = sum(!already_known), n_min = 25, print = info) # start if n >= 25
on.exit(close(progress)) 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)) { 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)}.")
} }
} }
@@ -551,14 +551,25 @@ type_sum.ab <- function(x, ...) {
print.ab <- function(x, ...) { print.ab <- function(x, ...) {
if (!is.null(attributes(x)$amr_selector)) { if (!is.null(attributes(x)$amr_selector)) {
function_name <- attributes(x)$amr_selector function_name <- attributes(x)$amr_selector
message_( if (pkg_is_available("cli", min_version = "3.0.0")) {
"This 'ab' vector was retrieved using `", function_name, "()`, which should normally be used inside a `dplyr` verb or `data.frame` call, e.g.:\n", cli::cli_inform(c(
" ", AMR_env$bullet_icon, " your_data %>% select(", function_name, "())\n", "i" = paste0("This {.cls ab} vector was retrieved using {.fun ", function_name, "}, which should normally be used inside a {.pkg dplyr} verb or {.code data.frame} call, e.g.:"),
" ", AMR_env$bullet_icon, " your_data %>% select(column_a, column_b, ", function_name, "())\n", "*" = highlight_code(paste0("your_data %>% select(", function_name, "()")),
" ", AMR_env$bullet_icon, " your_data %>% filter(any(", function_name, "() == \"R\"))\n", "*" = highlight_code(paste0("your_data %>% select(column_a, column_b, ", function_name, "()")),
" ", AMR_env$bullet_icon, " your_data[, ", function_name, "()]\n", "*" = highlight_code(paste0("your_data %>% filter(any(", function_name, "() == \"R\"))")),
" ", AMR_env$bullet_icon, " your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]" "*" = highlight_code(paste0("your_data[, ", function_name, "()]")),
) "*" = 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",
" ", 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, "())]"
), as_note = TRUE))
}
} }
cat("Class 'ab'\n") cat("Class 'ab'\n")
print(as.character(x), quote = FALSE) print(as.character(x), quote = FALSE)
@@ -704,8 +715,8 @@ get_translate_ab <- function(translate_ab) {
} else { } else {
translate_ab <- tolower(translate_ab) translate_ab <- tolower(translate_ab)
stop_ifnot(translate_ab %in% colnames(AMR::antimicrobials), 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", "invalid value for {.arg translate_ab}, this must be a column name of the {.topic [antimicrobials](AMR::antimicrobials)} data set\n",
"or `TRUE` (equals 'name') or `FALSE` to not translate at all.", "or {.code TRUE} (equals {.val name}) or {.code FALSE} to not translate at all.",
call = FALSE call = FALSE
) )
translate_ab translate_ab

View File

@@ -212,7 +212,7 @@ ab_from_text <- function(text,
} }
}) })
} else { } 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 # collapse text if needed

View File

@@ -341,12 +341,12 @@ ab_url <- function(x, open = FALSE, ...) {
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(atcs)] NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(atcs)]
if (length(NAs) > 0) { 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 (open == TRUE) {
if (length(u) > 1 && !is.na(u[1L])) { 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])) { if (!is.na(u[1L])) {
utils::browseURL(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") vars <- get_column_abx(df, info = FALSE, only_sir_columns = FALSE, sort = FALSE, fn = "set_ab_names")
if (length(vars) == 0) { 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) return(data)
} }
} else { } else {

12
R/age.R
View File

@@ -67,7 +67,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
} else if (length(reference) == 1) { } else if (length(reference) == 1) {
reference <- rep(reference, length(x)) reference <- rep(reference, length(x))
} else { } 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, ...) 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)) { if (any(ages < 0, na.rm = TRUE)) {
ages[!is.na(ages) & ages < 0] <- NA 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)) { 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)) { 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)) { if (any(x < 0, na.rm = TRUE)) {
x[x < 0] <- NA 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)) { if (is.character(split_at)) {
split_at <- split_at[1L] 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 <- c(0, split_at)
} }
split_at <- split_at[!is.na(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 # turn input values to 'split_at' indices
y <- x 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) agegroups <- factor(lbls[y], levels = lbls, ordered = TRUE)
if (!is.null(names)) { 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 levels(agegroups) <- names
} }

View File

@@ -837,7 +837,7 @@ amr_select_exec <- function(function_name,
#' @export #' @export
#' @noRd #' @noRd
print.amr_selector <- function(x, ...) { 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 immediate = TRUE
) )
cat("Class 'amr_selector'\n") 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 (message_not_thrown_before(function_name, sort(agents))) {
if (length(agents) == 0) { if (length(agents) == 0) {
if (is.null(ab_group)) { 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") { } else if (ab_group == "administrable_per_os") {
message_("No orally administrable drugs found", examples, ".") message_("No orally administrable drugs found", examples, ".")
} else if (ab_group == "administrable_iv") { } else if (ab_group == "administrable_iv") {

View File

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

View File

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

View File

@@ -168,7 +168,7 @@ av_from_text <- function(text,
} }
}) })
} else { } 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 # collapse text if needed

View File

@@ -233,12 +233,12 @@ av_url <- function(x, open = FALSE, ...) {
NAs <- av_name(av, tolower = TRUE, language = NULL)[!is.na(av) & is.na(atcs)] NAs <- av_name(av, tolower = TRUE, language = NULL)[!is.na(av) & is.na(atcs)]
if (length(NAs) > 0) { 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 (open == TRUE) {
if (length(u) > 1 && !is.na(u[1L])) { 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])) { if (!is.na(u[1L])) {
utils::browseURL(u[1L]) utils::browseURL(u[1L])

View File

@@ -82,9 +82,9 @@ bug_drug_combinations <- function(x,
# -- mo # -- mo
if (is.null(col_mo)) { if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "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 { } 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 x.bak <- x
@@ -226,7 +226,7 @@ format.bug_drug_combinations <- function(x,
x.bak <- x x.bak <- x
if (inherits(x, "grouped")) { if (inherits(x, "grouped")) {
# bug_drug_combinations() has been run on groups, so de-group here # 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) x <- as.data.frame(x, stringsAsFactors = FALSE)
idx <- split(seq_len(nrow(x)), paste0(x$mo, "%%", x$ab)) idx <- split(seq_len(nrow(x)), paste0(x$mo, "%%", x$ab))
x <- data.frame( x <- data.frame(

View File

@@ -128,7 +128,7 @@ count_resistant <- function(...,
# other arguments for meet_criteria are handled by sir_calc() # other arguments for meet_criteria are handled by sir_calc()
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1) 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)) { 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.") message_("This message will be shown once per session.")
} }
tryCatch( tryCatch(
@@ -152,7 +152,7 @@ count_susceptible <- function(...,
# other arguments for meet_criteria are handled by sir_calc() # other arguments for meet_criteria are handled by sir_calc()
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1) 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)) { 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.") message_("This message will be shown once per session.")
} }
tryCatch( tryCatch(

View File

@@ -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] 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") 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 #' @rdname add_custom_antimicrobials
@@ -166,5 +166,5 @@ clear_custom_antimicrobials <- function() {
n2 <- nrow(AMR_env$AB_lookup) n2 <- nrow(AMR_env$AB_lookup)
AMR_env$custom_ab_codes <- character(0) 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] 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.")
} }

View File

@@ -150,15 +150,15 @@ custom_eucast_rules <- function(...) {
) )
stop_if( stop_if(
identical(dots, "error"), 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) 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) out <- vector("list", n_dots)
for (i in seq_len(n_dots)) { for (i in seq_len(n_dots)) {
stop_ifnot( stop_ifnot(
inherits(dots[[i]], "formula"), inherits(dots[[i]], "formula"),
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?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 # Query
@@ -180,7 +180,7 @@ custom_eucast_rules <- function(...) {
result <- dots[[i]][[3]] result <- dots[[i]][[3]]
stop_ifnot( stop_ifnot(
deparse(result) %like% "==", 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(result)[[2]]
result_group <- as.character(str2lang(result_group)) result_group <- as.character(str2lang(result_group))

View File

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

View File

@@ -128,7 +128,7 @@
#' } #' }
add_custom_microorganisms <- function(x) { add_custom_microorganisms <- function(x) {
meet_criteria(x, allow_class = "data.frame") 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() 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)) AMR_env$MO_lookup <- unique(rbind_AMR(AMR_env$MO_lookup, new_df))
class(AMR_env$MO_lookup$mo) <- c("mo", "character") class(AMR_env$MO_lookup$mo) <- c("mo", "character")
if (nrow(x) <= 3) { 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 { } 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$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_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] 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, ...) { abbreviate_mo <- function(x, minlength = 5, prefix = "", hyphen_as_space = FALSE, ...) {

View File

@@ -119,7 +119,7 @@ as.disk <- function(x, na.rm = FALSE) {
sort() %pm>% sort() %pm>%
vector_and(quotes = TRUE) vector_and(quotes = TRUE)
cur_col <- get_current_column() cur_col <- get_current_column()
warning_("in `as.disk()`: ", na_after - na_before, " result", warning_("in {.fun as.disk}: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""), ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")), ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (", " truncated (",

View File

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

View File

@@ -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, ...) { exec_episode <- function(x, episode_days, case_free_days, ...) {
stop_ifnot(is.null(episode_days) || is.null(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 call = -2
) )

View File

@@ -295,7 +295,7 @@ geom_sir <- function(position = NULL,
...) { ...) {
x <- x[1] x <- x[1]
stop_ifnot_installed("ggplot2") 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(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(x, allow_class = "character", has_length = 1)
meet_criteria(fill, allow_class = "character", has_length = 1) meet_criteria(fill, allow_class = "character", has_length = 1)

View File

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

View File

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

View File

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

View File

@@ -159,7 +159,7 @@ key_antimicrobials <- function(x = NULL,
col_mo <- search_type_in_df(x = x, type = "mo", info = FALSE) col_mo <- search_type_in_df(x = x, type = "mo", info = FALSE)
} }
if (is.null(col_mo)) { 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_ gramstain <- NA_character_
kingdom <- NA_character_ kingdom <- NA_character_
} else { } else {
@@ -187,7 +187,7 @@ key_antimicrobials <- function(x = NULL,
"No columns available ", "No columns available ",
paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ") 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) { 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 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(type, allow_class = "character", has_length = 1, is_in = c("points", "keyantimicrobials"))
meet_criteria(ignore_I, allow_class = "logical", has_length = 1) 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) 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) { key2sir <- function(val) {
val <- strsplit(val, "", fixed = TRUE)[[1L]] val <- strsplit(val, "", fixed = TRUE)[[1L]]

View File

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

View File

@@ -269,7 +269,7 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all", round_to_next_log2
sort() %pm>% sort() %pm>%
vector_and(quotes = TRUE) vector_and(quotes = TRUE)
cur_col <- get_current_column() cur_col <- get_current_column()
warning_("in `as.mic()`: ", na_after - na_before, " result", warning_("in {.fun as.mic}: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""), ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")), ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
" truncated (", " truncated (",
@@ -441,7 +441,7 @@ all_valid_mics <- function(x) {
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, mic) #' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, mic)
pillar_shaft.mic <- function(x, ...) { pillar_shaft.mic <- function(x, ...) {
if (!identical(levels(x), VALID_MIC_LEVELS) && message_not_thrown_before("pillar_shaft.mic")) { 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 call = FALSE
) )
} }
@@ -508,7 +508,7 @@ as.vector.mic <- function(x, mode = "numneric", ...) {
y <- as.mic(y) y <- as.mic(y)
calls <- unlist(lapply(sys.calls(), as.character)) calls <- unlist(lapply(sys.calls(), as.character))
if (any(calls %in% c("rbind", "cbind")) && message_not_thrown_before("as.vector.mic")) { 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 y
} }
@@ -601,7 +601,7 @@ sort.mic <- function(x, decreasing = FALSE, ...) {
#' @export #' @export
#' @noRd #' @noRd
hist.mic <- function(x, ...) { 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)) hist(log2(x))
} }

28
R/mo.R
View File

@@ -402,7 +402,12 @@ as.mo <- function(x,
top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs
if (length(top_hits) == 0) { if (length(top_hits) == 0) {
warning_("No hits found for \"", x_search, "\" with minimum_matching_score = ", ifelse(is.null(minimum_matching_score), paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"), minimum_matching_score), ". Try setting this value lower or even to 0.", call = FALSE) warning_("No hits found for \"", x_search, "\" with minimum_matching_score = ",
ifelse(is.null(minimum_matching_score),
paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"),
minimum_matching_score
),
". Try setting this value lower or even to 0.", call = FALSE)
result_mo <- NA_character_ result_mo <- NA_character_
} else { } else {
result_mo <- MO_lookup_current$mo[match(top_hits[1], MO_lookup_current$fullname)] result_mo <- MO_lookup_current$mo[match(top_hits[1], MO_lookup_current$fullname)]
@@ -478,7 +483,7 @@ as.mo <- function(x,
} }
} else if (is.null(getOption("AMR_keep_synonyms")) && length(AMR_env$mo_renamed$old) > 0 && message_not_thrown_before("as.mo", "keep_synonyms_warning", entire_session = TRUE)) { } else if (is.null(getOption("AMR_keep_synonyms")) && length(AMR_env$mo_renamed$old) > 0 && message_not_thrown_before("as.mo", "keep_synonyms_warning", entire_session = TRUE)) {
# keep synonyms is TRUE, so check if any do have synonyms # keep synonyms is TRUE, so check if any do have synonyms
warning_("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 ", highlight_code("as.mo(..., keep_synonyms = FALSE)"), " to clean the input to currently accepted taxonomic names, or set the R option {.code AMR_keep_synonyms} to {.code FALSE}. This warning will be shown once per session.", call = FALSE)
} }
# Apply Becker ---- # Apply Becker ----
@@ -495,7 +500,7 @@ as.mo <- function(x,
) )
if (any(out %in% AMR_env$MO_lookup$mo[match(post_Becker, AMR_env$MO_lookup$fullname)])) { 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")) { 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), 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).", ". Categorisation to CoNS/CoPS was taken from the original scientific publication(s).",
immediate = TRUE, call = FALSE immediate = TRUE, call = FALSE
@@ -540,7 +545,7 @@ as.mo <- function(x,
out[is.na(out) & !is.na(x)] <- "UNKNOWN" 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)]) 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) { 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 ---- # Return class ----
@@ -902,14 +907,14 @@ rep.mo <- function(x, ...) {
print.mo_uncertainties <- function(x, n = 10, ...) { print.mo_uncertainties <- function(x, n = 10, ...) {
more_than_50 <- FALSE more_than_50 <- FALSE
if (NROW(x) == 0) { if (NROW(x) == 0) {
cat(word_wrap("No uncertainties to show. Only uncertainties of the last call to `as.mo()` or any `mo_*()` function are stored.\n\n", add_fn = font_blue)) cat(font_blue(word_wrap("No uncertainties to show. Only uncertainties of the last call to {.help [{.fun as.mo}](AMR::as.mo)} or any mo_*() function are stored.\n\n")))
return(invisible(NULL)) return(invisible(NULL))
} else if (NROW(x) > 50) { } else if (NROW(x) > 50) {
more_than_50 <- TRUE more_than_50 <- TRUE
x <- x[1:50, , drop = FALSE] x <- x[1:50, , drop = FALSE]
} }
cat(word_wrap("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See `?mo_matching_score`.\n\n", add_fn = font_blue)) cat(font_blue(word_wrap("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See {.help [{.fun mo_matching_score}](AMR::mo_matching_score)}.\n\n")))
add_MO_lookup_to_AMR_env() add_MO_lookup_to_AMR_env()
@@ -919,13 +924,12 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
col_green <- function(x) font_green_bg(x, collapse = NULL) col_green <- function(x) font_green_bg(x, collapse = NULL)
if (has_colour()) { if (has_colour()) {
cat(word_wrap("Colour keys: ", cat(font_blue(word_wrap("Colour keys: ",
col_red(" 0.000-0.549 "), col_red(" 0.000-0.549 "),
col_orange(" 0.550-0.649 "), col_orange(" 0.550-0.649 "),
col_yellow(" 0.650-0.749 "), col_yellow(" 0.650-0.749 "),
col_green(" 0.750-1.000"), col_green(" 0.750-1.000")
add_fn = font_blue )), font_green_bg(" "), "\n", sep = "")
), font_green_bg(" "), "\n", sep = "")
} }
score_set_colour <- function(text, scores) { score_set_colour <- function(text, scores) {
@@ -1028,7 +1032,7 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
#' @noRd #' @noRd
print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) { print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
if (NROW(x) == 0) { if (NROW(x) == 0) {
cat(word_wrap("No renamed taxonomy to show. Only renamed taxonomy of the last call of `as.mo()` or any `mo_*()` function are stored.\n", add_fn = font_blue)) cat(font_blue(word_wrap("No renamed taxonomy to show. Only renamed taxonomy of the last call of {.help [{.fun as.mo}](AMR::as.mo)} or any mo_*() function are stored.\n")))
return(invisible(NULL)) return(invisible(NULL))
} }
@@ -1045,7 +1049,7 @@ print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows], " -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
collapse = "\n" 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."), "") ifelse(NROW(x) > n, paste0("\n\nOnly the first ", n, " (out of ", NROW(x), ") are shown. Run {.code print(mo_renamed(), n = ...)} to view more entries (might be slow), or save {.fun mo_renamed} to an object."), "")
) )
} }

View File

@@ -584,7 +584,7 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_AMR_locale(), keep_s
ab <- rep(ab, length(x)) ab <- rep(ab, length(x))
} }
if (length(x) != length(ab)) { 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) # 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 (isTRUE(open)) {
if (length(u) > 1) { 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]) 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 (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
if (message_not_thrown_before(fn = fn)) { 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]) return(df[, mo, drop = TRUE])
} else { } 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)
} }
} }

View File

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

View File

@@ -114,7 +114,7 @@ pca <- function(x,
x <- as.data.frame(new_list, stringsAsFactors = FALSE) x <- as.data.frame(new_list, stringsAsFactors = FALSE)
if (any(vapply(FUN.VALUE = logical(1), x, function(y) !is.numeric(y)))) { 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 # set column names

View File

@@ -258,11 +258,11 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
} else if (any(other_x %in% colnames(df))) { } else if (any(other_x %in% colnames(df))) {
aest_val <- intersect(other_x, colnames(df))[1] aest_val <- intersect(other_x, colnames(df))[1]
} else { } 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) 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)) { 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)) out[[aest_val]] <- log2(as.double(mics))
} else { } else {
@@ -412,7 +412,7 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
scale$labels <- function(x) { scale$labels <- function(x) {
stop_ifnot(all(x %in% c(levels(NA_sir_), "SI", "IR", NA)), 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 call = FALSE
) )
x <- as.character(x) 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)) 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)) { 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)) { 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(...))) { if ("colours" %in% names(list(...))) {

View File

@@ -238,7 +238,7 @@ resistance <- function(...,
# other arguments for meet_criteria are handled by sir_calc() # other arguments for meet_criteria are handled by sir_calc()
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1) 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)) { 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.") message_("This message will be shown once per session.")
} }
tryCatch( tryCatch(
@@ -266,7 +266,7 @@ susceptibility <- function(...,
# other arguments for meet_criteria are handled by sir_calc() # other arguments for meet_criteria are handled by sir_calc()
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1) 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)) { 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.") message_("This message will be shown once per session.")
} }
tryCatch( tryCatch(

View File

@@ -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"))) 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.bak <- x
x <- as.data.frame(x, stringsAsFactors = FALSE) x <- as.data.frame(x, stringsAsFactors = FALSE)
@@ -146,7 +146,7 @@ resistance_predict <- function(x,
# -- date # -- date
if (is.null(col_date)) { if (is.null(col_date)) {
col_date <- search_type_in_df(x = x, type = "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( stop_ifnot(
col_date %in% colnames(x), col_date %in% colnames(x),
@@ -238,7 +238,7 @@ resistance_predict <- function(x,
prediction <- predictmodel$fit prediction <- predictmodel$fit
se <- predictmodel$se.fit se <- predictmodel$se.fit
} else { } 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 # prepare the output dataframe
@@ -357,7 +357,7 @@ ggplot_sir_predict <- function(x,
meet_criteria(ribbon, allow_class = "logical", has_length = 1) meet_criteria(ribbon, allow_class = "logical", has_length = 1)
stop_ifnot_installed("ggplot2") 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) { if (attributes(x)$I_as_S == TRUE) {
ylab <- "%R" ylab <- "%R"

67
R/sir.R
View File

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

View File

@@ -144,7 +144,7 @@ sir_calc <- function(...,
FUN = min FUN = min
) )
if ("SDD" %in% ab_result && "SDD" %in% y && message_not_thrown_before("sir_calc", only_count, ab_result, entire_session = TRUE)) { 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) 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)))) denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(anyNA(y))))
@@ -152,7 +152,7 @@ sir_calc <- function(...,
# may contain NAs in any column # may contain NAs in any column
other_values <- setdiff(c(NA, denominator_vals), ab_result) 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)) { 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))) 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)))) denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(all(y %in% other_values) & anyNA(y))))
@@ -164,7 +164,7 @@ sir_calc <- function(...,
print_warning <- TRUE print_warning <- TRUE
} }
if ("SDD" %in% ab_result && "SDD" %in% x && message_not_thrown_before("sir_calc", only_count, ab_result, entire_session = 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) numerator <- sum(x %in% ab_result, na.rm = TRUE)
denominator <- sum(x %in% denominator_vals, na.rm = TRUE) denominator <- sum(x %in% denominator_vals, na.rm = TRUE)
@@ -172,8 +172,8 @@ sir_calc <- function(...,
if (print_warning == TRUE) { if (print_warning == TRUE) {
if (message_not_thrown_before("sir_calc")) { if (message_not_thrown_before("sir_calc")) {
warning_("Increase speed by transforming to class 'sir' on beforehand:\n", warning_("Increase speed by transforming to class {.cls sir} on beforehand:\n",
" your_data %>% mutate_if(is_sir_eligible, as.sir)", highlight_code(" your_data %>% mutate_if(is_sir_eligible, as.sir)"),
call = FALSE call = FALSE
) )
} }

View File

@@ -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)) meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
if (is.null(col_mo)) { if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = TRUE) 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 x.bak <- x

View File

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

View File

@@ -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.", ". The old name will be removed in future version, so please update your code.",
ifelse(type == "argument", ifelse(type == "argument",
". While the old argument still works, it will be removed in a future version, so please update your code.", ". 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), ifelse(!is.null(extra_msg),

21
R/zzz.R
View File

@@ -116,43 +116,40 @@ AMR_env$cross_icon <- if (isTRUE(base::l10n_info()$`UTF-8`)) "\u00d7" else "x"
.onAttach <- function(libname, pkgname) { .onAttach <- function(libname, pkgname) {
if (interactive() && is.null(getOption("AMR_guideline"))) { if (interactive() && is.null(getOption("AMR_guideline"))) {
packageStartupMessage( packageStartupMessage(format_inline_(
word_wrap( "Assuming ", AMR::clinical_breakpoints$guideline[1], " as the default AMR guideline, see {.topic [AMR-options](AMR::AMR-options)} to change this."
"Assuming ", AMR::clinical_breakpoints$guideline[1], " as the default AMR guideline, see `?AMR-options` to change this.", ))
add_fn = NULL
)
)
} }
# if custom ab option is available, load it # if custom ab option is available, load it
if (!is.null(getOption("AMR_custom_ab")) && file.exists(getOption("AMR_custom_ab", default = ""))) { if (!is.null(getOption("AMR_custom_ab")) && file.exists(getOption("AMR_custom_ab", default = ""))) {
if (getOption("AMR_custom_ab") %unlike% "[.]rds$") { 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 { } 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")) x <- readRDS_AMR(getOption("AMR_custom_ab"))
tryCatch( tryCatch(
{ {
suppressWarnings(suppressMessages(add_custom_antimicrobials(x))) suppressWarnings(suppressMessages(add_custom_antimicrobials(x)))
packageStartupMessage("OK.") 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 custom mo option is available, load it
if (!is.null(getOption("AMR_custom_mo")) && file.exists(getOption("AMR_custom_mo", default = ""))) { if (!is.null(getOption("AMR_custom_mo")) && file.exists(getOption("AMR_custom_mo", default = ""))) {
if (getOption("AMR_custom_mo") %unlike% "[.]rds$") { 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 { } 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")) x <- readRDS_AMR(getOption("AMR_custom_mo"))
tryCatch( tryCatch(
{ {
suppressWarnings(suppressMessages(add_custom_microorganisms(x))) suppressWarnings(suppressMessages(add_custom_microorganisms(x)))
packageStartupMessage("OK.") packageStartupMessage("OK.")
}, },
error = function(e) packageStartupMessage("Failed: ", conditionMessage(e)) error = function(e) packageStartupMessage(format_inline_("Failed: ", conditionMessage(e)))
) )
} }
} }