mirror of
https://github.com/msberends/AMR.git
synced 2026-03-19 19:02:27 +01:00
Compare commits
19 Commits
main
...
claude/mig
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
51f689b069 | ||
|
|
1dabd4df3d | ||
|
|
5173009625 | ||
|
|
80e267f0d1 | ||
|
|
05d3ca941f | ||
|
|
ec310ed76b | ||
|
|
3e4983ff93 | ||
|
|
7218812c99 | ||
|
|
eae14d44bf | ||
|
|
11c175ae19 | ||
|
|
ec3b12b937 | ||
|
|
5ecbc9001e | ||
|
|
8760c6d85a | ||
|
|
3928a3de55 | ||
|
|
10c00ff606 | ||
|
|
b7edf3e548 | ||
|
|
0cc154257a | ||
|
|
4798d2c55e | ||
|
|
ad31fba556 |
@@ -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)
|
||||||
|
|||||||
38
.github/workflows/check-current-testthat.yaml
vendored
38
.github/workflows/check-current-testthat.yaml
vendored
@@ -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 }}
|
||||||
|
|||||||
4
.github/workflows/check-old-tinytest.yaml
vendored
4
.github/workflows/check-old-tinytest.yaml
vendored
@@ -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
|
||||||
|
|
||||||
|
|||||||
6
.github/workflows/codecovr.yaml
vendored
6
.github/workflows/codecovr.yaml
vendored
@@ -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
|
||||||
|
|
||||||
|
|||||||
@@ -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.
|
||||||
|
|
||||||
|
|||||||
@@ -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
10
NEWS.md
@@ -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
|
||||||
|
|||||||
@@ -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
33
R/ab.R
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
12
R/age.R
@@ -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
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -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") {
|
||||||
|
|||||||
@@ -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
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -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
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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])
|
||||||
|
|||||||
@@ -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(
|
||||||
|
|||||||
@@ -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(
|
||||||
|
|||||||
@@ -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.")
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -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))
|
||||||
|
|||||||
@@ -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
|
||||||
)
|
)
|
||||||
|
|||||||
@@ -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, ...) {
|
||||||
|
|||||||
2
R/disk.R
2
R/disk.R
@@ -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 (",
|
||||||
|
|||||||
@@ -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
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -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
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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
|
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -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()
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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]]
|
||||||
|
|||||||
26
R/mdro.R
26
R/mdro.R
@@ -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", ...)
|
||||||
}
|
}
|
||||||
|
|||||||
8
R/mic.R
8
R/mic.R
@@ -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
28
R/mo.R
@@ -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."), "")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -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)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -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)
|
||||||
}
|
}
|
||||||
|
|||||||
2
R/pca.R
2
R/pca.R
@@ -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
|
||||||
|
|||||||
10
R/plotting.R
10
R/plotting.R
@@ -258,11 +258,11 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
|||||||
} else if (any(other_x %in% colnames(df))) {
|
} 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(...))) {
|
||||||
|
|||||||
@@ -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(
|
||||||
|
|||||||
@@ -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
67
R/sir.R
@@ -441,7 +441,7 @@ is_sir_eligible <- function(x, threshold = 0.05) {
|
|||||||
return(unname(vapply(FUN.VALUE = logical(1), x, is_sir_eligible)))
|
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)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
10
R/sir_calc.R
10
R/sir_calc.R
@@ -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
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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
21
R/zzz.R
@@ -116,43 +116,40 @@ AMR_env$cross_icon <- if (isTRUE(base::l10n_info()$`UTF-8`)) "\u00d7" else "x"
|
|||||||
|
|
||||||
.onAttach <- function(libname, pkgname) {
|
.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)))
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
Reference in New Issue
Block a user