mirror of
https://github.com/msberends/AMR.git
synced 2026-03-30 20:55:53 +02:00
Compare commits
6 Commits
0cc154257a
...
main
| Author | SHA1 | Date | |
|---|---|---|---|
| 3a736bc484 | |||
| 9c95aa455c | |||
| 2a8a1eda97 | |||
| 975a690c10 | |||
| 3d1412e8c9 | |||
|
|
4171d5b778 |
@@ -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.9036
|
Version: 3.0.1.9041
|
||||||
Date: 2026-03-18
|
Date: 2026-03-30
|
||||||
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
|
||||||
@@ -63,7 +63,8 @@ Suggests:
|
|||||||
tidyselect,
|
tidyselect,
|
||||||
tinytest,
|
tinytest,
|
||||||
vctrs,
|
vctrs,
|
||||||
xml2
|
xml2,
|
||||||
|
usethis
|
||||||
VignetteBuilder: knitr,rmarkdown
|
VignetteBuilder: knitr,rmarkdown
|
||||||
URL: https://amr-for-r.org, https://github.com/msberends/AMR
|
URL: https://amr-for-r.org, https://github.com/msberends/AMR
|
||||||
BugReports: https://github.com/msberends/AMR/issues
|
BugReports: https://github.com/msberends/AMR/issues
|
||||||
|
|||||||
13
NEWS.md
13
NEWS.md
@@ -1,14 +1,7 @@
|
|||||||
# AMR 3.0.1.9036
|
# AMR 3.0.1.9041
|
||||||
|
|
||||||
### Updates
|
|
||||||
* Modernised messaging infrastructure: `message_()`, `warning_()`, and `stop_()` now use `cli` for rich formatting (colours, inline markup, hyperlinks) when the `cli` package is installed, with a fully functional plain-text fallback when `cli` is absent
|
|
||||||
* Removed `add_fn` parameter from `message_()`, `warning_()`, and `word_wrap()` — styling is now handled by `cli` markup or dropped from the plain-text path
|
|
||||||
* New internal helper `cli_to_plain()` converts cli inline markup (`{.fun}`, `{.arg}`, `{.val}`, etc.) to plain-text equivalents for the non-cli fallback path
|
|
||||||
* Call sites across all R source files updated from `paste0()`-based string construction to cli glue syntax (e.g. `{.fun as.mo}`, `{.arg col_mo}`, `{n} results`)
|
|
||||||
|
|
||||||
# AMR 3.0.1.9035
|
|
||||||
|
|
||||||
### New
|
### New
|
||||||
|
* Support for clinical breakpoints of 2026 of both CLSI and EUCAST, by adding all of their over 5,700 new clinical breakpoints to the `clinical_breakpoints` data set for usage in `as.sir()`. EUCAST 2026 is now the new default guideline for all MIC and disk diffusion interpretations.
|
||||||
* 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`
|
||||||
- `step_mic_log2()` to transform `<mic>` columns with log2, and `step_sir_numeric()` to convert `<sir>` columns to numeric
|
- `step_mic_log2()` to transform `<mic>` columns with log2, and `step_sir_numeric()` to convert `<sir>` columns to numeric
|
||||||
- New `tidyselect` helpers:
|
- New `tidyselect` helpers:
|
||||||
@@ -31,6 +24,7 @@
|
|||||||
* Fixed a bug in `as.ab()` where certain AB codes containing "PH" or "TH" (such as `ETH`, `MTH`, `PHE`, `PHN`, `STH`, `THA`, `THI1`) would incorrectly return `NA` when combined in a vector with any untranslatable value (#245)
|
* Fixed a bug in `as.ab()` where certain AB codes containing "PH" or "TH" (such as `ETH`, `MTH`, `PHE`, `PHN`, `STH`, `THA`, `THI1`) would incorrectly return `NA` when combined in a vector with any untranslatable value (#245)
|
||||||
* Fixed a bug in `antibiogram()` for when no antimicrobials are set
|
* Fixed a bug in `antibiogram()` for when no antimicrobials are set
|
||||||
* Fixed a bug in `as.sir()` where for numeric input the arguments `S`, `I`, and `R` would not be considered (#244)
|
* Fixed a bug in `as.sir()` where for numeric input the arguments `S`, `I`, and `R` would not be considered (#244)
|
||||||
|
* Fixed a bug in plotting MIC values when `keep_operators = "all"`
|
||||||
* Fixed some foreign translations of antimicrobial drugs
|
* Fixed some foreign translations of antimicrobial drugs
|
||||||
* Fixed a bug for printing column names to the console when using `mutate_at(vars(...), as.mic)` (#249)
|
* Fixed a bug for printing column names to the console when using `mutate_at(vars(...), as.mic)` (#249)
|
||||||
* Fixed a bug to disregard `NI` for susceptibility proportion functions
|
* Fixed a bug to disregard `NI` for susceptibility proportion functions
|
||||||
@@ -38,6 +32,7 @@
|
|||||||
* 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
|
||||||
|
* Extensive `cli` integration for better message handling and clickable links in messages and warnings (#191, #265)
|
||||||
* `mdro()` now infers resistance for a _missing_ base drug column from an _available_ corresponding drug+inhibitor combination showing resistance (e.g., piperacillin is absent but required, while piperacillin/tazobactam available and resistant). Can be set with the new argument `infer_from_combinations`, which defaults to `TRUE` (#209). Note that this can yield a higher MDRO detection (which is a good thing as it has become more reliable).
|
* `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`)
|
||||||
|
|||||||
@@ -253,12 +253,9 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
|
|||||||
# WHONET support
|
# WHONET support
|
||||||
found <- sort(colnames(x)[colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)"])
|
found <- sort(colnames(x)[colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)"])
|
||||||
if (!inherits(pm_pull(x, found), c("Date", "POSIXct"))) {
|
if (!inherits(pm_pull(x, found), c("Date", "POSIXct"))) {
|
||||||
stop(
|
stop_("Found column {.field ", font_bold(found), "} to be used as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type,
|
||||||
font_red(paste0(
|
"}, but this column contains no valid dates. Transform its values to valid dates first.",
|
||||||
"Found column '", font_bold(found), "' to be used as input for `", ifelse(add_col_prefix, "col_", ""), type,
|
call = FALSE
|
||||||
"`, but this column contains no valid dates. Transform its values to valid dates first."
|
|
||||||
)),
|
|
||||||
call. = FALSE
|
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
} else if (any(vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct"))))) {
|
} else if (any(vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct"))))) {
|
||||||
@@ -304,8 +301,9 @@ 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_(
|
||||||
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored."
|
"Column {.field ", font_bold(found), "} found as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type,
|
||||||
|
"}, but this column does not contain {.code TRUE}/{.code FALSE} values and was ignored."
|
||||||
)
|
)
|
||||||
found <- NULL
|
found <- NULL
|
||||||
}
|
}
|
||||||
@@ -316,9 +314,9 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
|
|||||||
|
|
||||||
if (!is.null(found) && isTRUE(info)) {
|
if (!is.null(found) && isTRUE(info)) {
|
||||||
if (message_not_thrown_before("search_in_type", type)) {
|
if (message_not_thrown_before("search_in_type", type)) {
|
||||||
msg <- paste0("Using column '", font_bold(found), "' as input for `", ifelse(add_col_prefix, "col_", ""), type, "`.")
|
msg <- paste0("Using column {.field ", font_bold(found), "} as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type, "}.")
|
||||||
if (type %in% c("keyantibiotics", "keyantimicrobials", "specimen")) {
|
if (type %in% c("keyantibiotics", "keyantimicrobials", "specimen")) {
|
||||||
msg <- paste(msg, "Use", font_bold(paste0(ifelse(add_col_prefix, "col_", ""), type), "= FALSE"), "to prevent this.")
|
msg <- paste(msg, "Use {.arg ", paste0(ifelse(add_col_prefix, "col_", ""), type), "= FALSE} to prevent this.")
|
||||||
}
|
}
|
||||||
message_(msg)
|
message_(msg)
|
||||||
}
|
}
|
||||||
@@ -386,7 +384,7 @@ 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)
|
||||||
}
|
}
|
||||||
if (pkg == "rstudioapi" && !in_rstudio()) {
|
if (pkg == "rstudioapi" && (!in_rstudio() || !interactive())) {
|
||||||
# only allow rstudioapi to be imported if we're in RStudio
|
# only allow rstudioapi to be imported if we're in RStudio
|
||||||
return(NULL)
|
return(NULL)
|
||||||
}
|
}
|
||||||
@@ -396,7 +394,7 @@ 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 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
|
||||||
)
|
)
|
||||||
@@ -407,6 +405,30 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
|
|||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
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")) {
|
||||||
|
if (!cli::ansi_has_hyperlink_support()) {
|
||||||
|
msg <- simplify_help_markup(msg)
|
||||||
|
}
|
||||||
|
cli::format_inline(msg)
|
||||||
|
} else {
|
||||||
|
cli_to_plain(msg, envir = parent.frame())
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
# Convert cli glue markup to plain text for the non-cli fallback path.
|
# Convert cli glue markup to plain text for the non-cli fallback path.
|
||||||
# Called by message_(), warning_(), and stop_() when cli is not available.
|
# Called by message_(), warning_(), and stop_() when cli is not available.
|
||||||
cli_to_plain <- function(msg, envir = parent.frame()) {
|
cli_to_plain <- function(msg, envir = parent.frame()) {
|
||||||
@@ -425,7 +447,7 @@ cli_to_plain <- function(msg, envir = parent.frame()) {
|
|||||||
|
|
||||||
apply_sub <- function(msg, pattern, formatter) {
|
apply_sub <- function(msg, pattern, formatter) {
|
||||||
while (grepl(pattern, msg, perl = TRUE)) {
|
while (grepl(pattern, msg, perl = TRUE)) {
|
||||||
m <- regexec(pattern, msg, perl = TRUE)
|
m <- regexec(pattern, msg)
|
||||||
matches <- regmatches(msg, m)[[1]]
|
matches <- regmatches(msg, m)[[1]]
|
||||||
if (length(matches) < 2L) break
|
if (length(matches) < 2L) break
|
||||||
full_match <- matches[1L]
|
full_match <- matches[1L]
|
||||||
@@ -443,22 +465,31 @@ cli_to_plain <- function(msg, envir = parent.frame()) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
# cli inline markup -> plain-text equivalents (one level of glue nesting allowed)
|
# 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, "\\{\\.fun (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "()`"))
|
||||||
msg <- apply_sub(msg, "\\{\\.arg (\\{[^}]+\\}|[^}]+)\\}", 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, "\\{\\.code (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "`"))
|
||||||
msg <- apply_sub(msg, "\\{\\.val (\\{[^}]+\\}|[^}]+)\\}", 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, "\\{\\.field (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0('"', resolve(c), '"'))
|
||||||
msg <- apply_sub(msg, "\\{\\.cls (\\{[^}]+\\}|[^}]+)\\}", 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, "\\{\\.pkg (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
|
||||||
msg <- apply_sub(msg, "\\{\\.strong (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", 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, "\\{\\.emph (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
|
||||||
msg <- apply_sub(msg, "\\{\\.help (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "`"))
|
msg <- apply_sub(msg, "\\{\\.help ([^}]+)\\}", function(c) {
|
||||||
msg <- apply_sub(msg, "\\{\\.url (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
|
# Handle [display text](topic) markdown link format: extract just the display text
|
||||||
msg <- apply_sub(msg, "\\{\\.href ([^}]+)\\}", function(c) strsplit(resolve(c), " ", fixed = TRUE)[[1L]][1L])
|
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
|
# bare {variable} or {expression} -> evaluate in caller's environment
|
||||||
while (grepl("\\{[^{}]+\\}", msg)) {
|
while (grepl("\\{[^{}]+\\}", msg)) {
|
||||||
m <- regexec("\\{([^{}]+)\\}", msg, perl = TRUE)
|
m <- regexec("\\{([^{}]+)\\}", msg)
|
||||||
matches <- regmatches(msg, m)[[1]]
|
matches <- regmatches(msg, m)[[1]]
|
||||||
if (length(matches) < 2L) break
|
if (length(matches) < 2L) break
|
||||||
full_match <- matches[1L]
|
full_match <- matches[1L]
|
||||||
@@ -487,7 +518,7 @@ word_wrap <- function(...,
|
|||||||
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")) {
|
if (pkg_is_available("cli", min_version = "3.0.0")) {
|
||||||
return(paste0(c(...), collapse = ""))
|
return(paste0(c(...), collapse = ""))
|
||||||
}
|
}
|
||||||
msg <- paste0(c(...), collapse = "")
|
msg <- paste0(c(...), collapse = "")
|
||||||
@@ -521,15 +552,46 @@ word_wrap <- function(...,
|
|||||||
gsub("(\n| )+$", "", wrapped)
|
gsub("(\n| )+$", "", wrapped)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
simplify_help_markup <- function(msg) {
|
||||||
|
# {.help [{.fun fn}](pkg::fn)} -> {.code fn()}
|
||||||
|
# {.help [display](topic)} -> {.code display}
|
||||||
|
msg <- gsub(
|
||||||
|
"\\{\\.help \\[\\{\\.fun ([^}]+)\\}\\]\\([^)]+\\)\\}",
|
||||||
|
"{.code \\1()}",
|
||||||
|
msg,
|
||||||
|
perl = TRUE
|
||||||
|
)
|
||||||
|
msg <- gsub(
|
||||||
|
"\\{\\.help \\[([^]]+)\\]\\([^)]+\\)\\}",
|
||||||
|
"{.code \\1}",
|
||||||
|
msg,
|
||||||
|
perl = TRUE
|
||||||
|
)
|
||||||
|
# {.topic [display](topic)} -> {.code ?display}
|
||||||
|
msg <- gsub(
|
||||||
|
"\\{\\.topic \\[([^]]+)\\]\\([^)]+\\)\\}",
|
||||||
|
"{.code ?\\1}",
|
||||||
|
msg,
|
||||||
|
perl = TRUE
|
||||||
|
)
|
||||||
|
msg
|
||||||
|
}
|
||||||
|
|
||||||
message_ <- function(...,
|
message_ <- function(...,
|
||||||
appendLF = TRUE,
|
appendLF = TRUE,
|
||||||
as_note = TRUE) {
|
as_note = TRUE) {
|
||||||
if (pkg_is_available("cli")) {
|
if (pkg_is_available("cli", min_version = "3.0.0")) {
|
||||||
msg <- paste0(c(...), collapse = "")
|
msg <- paste0(c(...), collapse = "")
|
||||||
|
if (!cli::ansi_has_hyperlink_support()) {
|
||||||
|
msg <- simplify_help_markup(msg)
|
||||||
|
}
|
||||||
if (isTRUE(as_note)) {
|
if (isTRUE(as_note)) {
|
||||||
cli::cli_inform(c("i" = msg), .envir = parent.frame())
|
cli::cli_inform(c("i" = msg), .envir = parent.frame())
|
||||||
} else {
|
} else if (isTRUE(appendLF)) {
|
||||||
cli::cli_inform(msg, .envir = parent.frame())
|
cli::cli_inform(msg, .envir = parent.frame())
|
||||||
|
} else {
|
||||||
|
# This mirrors what rlang::inform() does internally (cat() to stderr), so it behaves consistently with cli_inform() output
|
||||||
|
cat(format_inline_(msg), file = stderr())
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
|
plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
|
||||||
@@ -540,8 +602,11 @@ message_ <- function(...,
|
|||||||
warning_ <- function(...,
|
warning_ <- function(...,
|
||||||
immediate = FALSE,
|
immediate = FALSE,
|
||||||
call = FALSE) {
|
call = FALSE) {
|
||||||
if (pkg_is_available("cli")) {
|
if (pkg_is_available("cli", min_version = "3.0.0")) {
|
||||||
msg <- paste0(c(...), collapse = "")
|
msg <- paste0(c(...), collapse = "")
|
||||||
|
if (!cli::ansi_has_hyperlink_support()) {
|
||||||
|
msg <- simplify_help_markup(msg)
|
||||||
|
}
|
||||||
cli::cli_warn(msg, .envir = parent.frame())
|
cli::cli_warn(msg, .envir = parent.frame())
|
||||||
} else {
|
} else {
|
||||||
plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
|
plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
|
||||||
@@ -554,7 +619,10 @@ warning_ <- function(...,
|
|||||||
# - wraps text to never break lines within words (plain-text fallback)
|
# - 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 = "")
|
||||||
if (pkg_is_available("cli")) {
|
if (!cli::ansi_has_hyperlink_support()) {
|
||||||
|
msg <- simplify_help_markup(msg)
|
||||||
|
}
|
||||||
|
if (pkg_is_available("cli", min_version = "3.0.0")) {
|
||||||
if (isTRUE(call)) {
|
if (isTRUE(call)) {
|
||||||
call_obj <- sys.call(-1)
|
call_obj <- sys.call(-1)
|
||||||
} else if (!isFALSE(call)) {
|
} else if (!isFALSE(call)) {
|
||||||
@@ -754,7 +822,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"
|
||||||
@@ -763,12 +831,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)
|
||||||
}
|
}
|
||||||
@@ -803,11 +871,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())
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -817,32 +885,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
|
||||||
)
|
)
|
||||||
@@ -860,7 +928,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 "
|
||||||
@@ -871,8 +939,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"
|
||||||
@@ -881,8 +949,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"
|
||||||
@@ -891,8 +959,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"
|
||||||
@@ -926,9 +994,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 {.help AMR::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)
|
||||||
@@ -1030,13 +1098,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 {.cls 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)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1630,7 +1698,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()
|
||||||
@@ -1645,7 +1713,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)
|
||||||
|
|||||||
54
R/ab.R
54
R/ab.R
@@ -191,12 +191,13 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
x_new[known_codes_cid] <- AMR_env$AB_lookup$ab[match(x[known_codes_cid], AMR_env$AB_lookup$cid)]
|
x_new[known_codes_cid] <- AMR_env$AB_lookup$ab[match(x[known_codes_cid], AMR_env$AB_lookup$cid)]
|
||||||
previously_coerced <- x %in% AMR_env$ab_previously_coerced$x
|
previously_coerced <- x %in% AMR_env$ab_previously_coerced$x
|
||||||
x_new[previously_coerced & is.na(x_new)] <- AMR_env$ab_previously_coerced$ab[match(x[is.na(x_new) & x %in% AMR_env$ab_previously_coerced$x], AMR_env$ab_previously_coerced$x)]
|
x_new[previously_coerced & is.na(x_new)] <- AMR_env$ab_previously_coerced$ab[match(x[is.na(x_new) & x %in% AMR_env$ab_previously_coerced$x], AMR_env$ab_previously_coerced$x)]
|
||||||
previously_coerced_mention <- x %in% AMR_env$ab_previously_coerced$x & !x %in% AMR_env$AB_lookup$ab & !x %in% AMR_env$AB_lookup$generalised_name
|
previously_coerced_mention <- !is.na(x) & x %in% AMR_env$ab_previously_coerced$x & !x %in% AMR_env$AB_lookup$ab & !x %in% AMR_env$AB_lookup$generalised_name
|
||||||
if (any(previously_coerced_mention) && isTRUE(info) && message_not_thrown_before("as.ab", entire_session = TRUE)) {
|
if (any(previously_coerced_mention) && isTRUE(info) && message_not_thrown_before("as.ab", entire_session = TRUE)) {
|
||||||
|
only_one <- length(unique(which(x[which(previously_coerced)] %in% x_bak_clean))) == 1
|
||||||
message_(
|
message_(
|
||||||
"Returning previously coerced ",
|
"Returning ", ifelse(only_one, "a ", ""), "previously coerced ",
|
||||||
ifelse(length(unique(which(x[which(previously_coerced)] %in% x_bak_clean))) > 1, "value for an antimicrobial", "values for various antimicrobials"),
|
ifelse(only_one, "value for an antimicrobial", "values for various antimicrobials"),
|
||||||
". Run `ab_reset_session()` to reset this. This note will be shown once per session."
|
". Run {.help [{.fun ab_reset_session}](AMR::ab_reset_session)} to reset this. This note will be shown once per session."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -210,7 +211,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
progress <- progress_ticker(n = sum(!already_known), n_min = 25, print = info) # start if n >= 25
|
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)}.")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -444,7 +445,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
# take failed ATC codes apart from rest
|
# take failed ATC codes apart from rest
|
||||||
if (length(x_unknown_ATCs) > 0 && fast_mode == FALSE) {
|
if (length(x_unknown_ATCs) > 0 && fast_mode == FALSE) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `as.ab()`: these ATC codes are not (yet) in the antimicrobials data set: ",
|
"in {.help [{.fun as.ab}](AMR::as.ab)}: these ATC codes are not (yet) in the antimicrobials data set: ",
|
||||||
vector_and(x_unknown_ATCs), "."
|
vector_and(x_unknown_ATCs), "."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -458,12 +459,14 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
x_unknown <- x_unknown[!x_unknown %in% c("", NA)]
|
x_unknown <- x_unknown[!x_unknown %in% c("", NA)]
|
||||||
if (length(x_unknown) > 0 && fast_mode == FALSE) {
|
if (length(x_unknown) > 0 && fast_mode == FALSE) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `as.ab()`: ", ifelse(length(unique(x_unknown)) == 1, "this value", "these values"), " could not be coerced to a valid antimicrobial ID: ",
|
"in {.help [{.fun as.ab}](AMR::as.ab)}: ", ifelse(length(unique(x_unknown)) == 1, "this value", "these values"), " could not be coerced to a valid antimicrobial ID: ",
|
||||||
vector_and(x_unknown), "."
|
vector_and(x_unknown), "."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
# Throw note about uncertainties
|
# Throw note about uncertainties
|
||||||
|
x_uncertain <- x_uncertain[!is.na(x_uncertain)]
|
||||||
|
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[!is.na(AMR_env$ab_previously_coerced$x), ]
|
||||||
if (isTRUE(info) && length(x_uncertain) > 0 && fast_mode == FALSE) {
|
if (isTRUE(info) && length(x_uncertain) > 0 && fast_mode == FALSE) {
|
||||||
x_uncertain <- unique(x_uncertain)
|
x_uncertain <- unique(x_uncertain)
|
||||||
if (message_not_thrown_before("as.ab", "uncertainties", x_bak)) {
|
if (message_not_thrown_before("as.ab", "uncertainties", x_bak)) {
|
||||||
@@ -481,7 +484,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
}
|
}
|
||||||
message_(
|
message_(
|
||||||
"Antimicrobial translation was uncertain for ", examples,
|
"Antimicrobial translation was uncertain for ", examples,
|
||||||
". If required, use `add_custom_antimicrobials()` to add custom entries."
|
". If required, use {.help [{.fun add_custom_antimicrobials}](AMR::add_custom_antimicrobials)} to add custom entries."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
@@ -526,7 +529,7 @@ NA_ab_ <- set_clean_class(NA_character_,
|
|||||||
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, ab)
|
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, ab)
|
||||||
pillar_shaft.ab <- function(x, ...) {
|
pillar_shaft.ab <- function(x, ...) {
|
||||||
out <- trimws(format(x))
|
out <- trimws(format(x))
|
||||||
out[is.na(x)] <- font_na(NA)
|
out[is.na(x)] <- pillar::style_na(NA)
|
||||||
|
|
||||||
# add the names to the drugs as mouse-over!
|
# add the names to the drugs as mouse-over!
|
||||||
if (in_rstudio()) {
|
if (in_rstudio()) {
|
||||||
@@ -551,16 +554,27 @@ 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 {.cls data.frame} call, e.g.:"),
|
||||||
" ", AMR_env$bullet_icon, " your_data %>% select(column_a, column_b, ", function_name, "())\n",
|
paste0("\u00a0\u00a0", AMR_env$bullet_icon, " ", highlight_code(paste0("your_data %>% select(", function_name, "())"))),
|
||||||
" ", AMR_env$bullet_icon, " your_data %>% filter(any(", function_name, "() == \"R\"))\n",
|
paste0("\u00a0\u00a0", AMR_env$bullet_icon, " ", highlight_code(paste0("your_data %>% select(column_a, column_b, ", function_name, "())"))),
|
||||||
" ", AMR_env$bullet_icon, " your_data[, ", function_name, "()]\n",
|
paste0("\u00a0\u00a0", AMR_env$bullet_icon, " ", highlight_code(paste0("your_data %>% filter(any(", function_name, "() == \"R\"))"))),
|
||||||
" ", AMR_env$bullet_icon, " your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]"
|
paste0("\u00a0\u00a0", AMR_env$bullet_icon, " ", highlight_code(paste0("your_data[, ", function_name, "()]"))),
|
||||||
)
|
paste0("\u00a0\u00a0", AMR_env$bullet_icon, " ", highlight_code(paste0("your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]")))
|
||||||
|
))
|
||||||
|
} else {
|
||||||
|
message(word_wrap(paste0(
|
||||||
|
"This 'ab' vector was retrieved using `", function_name, "()`, which should normally be used inside a dplyr verb or data.frame call, e.g.:\n",
|
||||||
|
"\u00a0\u00a0", AMR_env$bullet_icon, " your_data %>% select(", function_name, "())\n",
|
||||||
|
"\u00a0\u00a0", AMR_env$bullet_icon, " your_data %>% select(column_a, column_b, ", function_name, "())\n",
|
||||||
|
"\u00a0\u00a0", AMR_env$bullet_icon, " your_data %>% filter(any(", function_name, "() == \"R\"))\n",
|
||||||
|
"\u00a0\u00a0", AMR_env$bullet_icon, " your_data[, ", function_name, "()]\n",
|
||||||
|
"\u00a0\u00a0", AMR_env$bullet_icon, " your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]"
|
||||||
|
), as_note = TRUE))
|
||||||
|
}
|
||||||
}
|
}
|
||||||
cat("Class 'ab'\n")
|
cat(format_inline_("Class {.cls ab}\n"))
|
||||||
print(as.character(x), quote = FALSE)
|
print(as.character(x), quote = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -704,8 +718,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 {.help [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
|
||||||
|
|||||||
@@ -265,7 +265,7 @@ ab_ddd <- function(x, administration = "oral", ...) {
|
|||||||
|
|
||||||
if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
|
if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `ab_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
"in {.help [{.fun ab_ddd}](AMR::ab_ddd)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||||
"Please refer to the WHOCC website:\n",
|
"Please refer to the WHOCC website:\n",
|
||||||
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
||||||
)
|
)
|
||||||
@@ -285,7 +285,7 @@ ab_ddd_units <- function(x, administration = "oral", ...) {
|
|||||||
|
|
||||||
if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
|
if (any(ab_name(x, language = NULL) %like% "/" & is.na(out))) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `ab_ddd_units()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
"in {.help [{.fun ab_ddd_units}](AMR::ab_ddd_units)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||||
"Please refer to the WHOCC website:\n",
|
"Please refer to the WHOCC website:\n",
|
||||||
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
||||||
)
|
)
|
||||||
@@ -341,12 +341,12 @@ ab_url <- function(x, open = FALSE, ...) {
|
|||||||
|
|
||||||
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(atcs)]
|
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 {
|
||||||
@@ -424,7 +424,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
|
|||||||
)
|
)
|
||||||
if (any(x %in% c("", NA))) {
|
if (any(x %in% c("", NA))) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `set_ab_names()`: no ", property, " found for column(s): ",
|
"in {.help [{.fun set_ab_names}](AMR::set_ab_names)}: no ", property, " found for column(s): ",
|
||||||
vector_and(vars[x %in% c("", NA)], sort = FALSE)
|
vector_and(vars[x %in% c("", NA)], sort = FALSE)
|
||||||
)
|
)
|
||||||
x[x %in% c("", NA)] <- vars[x %in% c("", NA)]
|
x[x %in% c("", NA)] <- vars[x %in% c("", NA)]
|
||||||
|
|||||||
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
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -678,7 +678,7 @@ not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, ver
|
|||||||
agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]
|
agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]
|
||||||
if (length(agents) > 0 &&
|
if (length(agents) > 0 &&
|
||||||
message_not_thrown_before("not_intrinsic_resistant", sort(agents))) {
|
message_not_thrown_before("not_intrinsic_resistant", sort(agents))) {
|
||||||
agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
|
agents_formatted <- paste0("{.field ", font_bold(agents, collapse = NULL), "}")
|
||||||
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
|
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
|
||||||
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
|
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
|
||||||
agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
|
agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
|
||||||
@@ -722,7 +722,7 @@ amr_select_exec <- function(function_name,
|
|||||||
if (any(untreatable %in% names(ab_in_data))) {
|
if (any(untreatable %in% names(ab_in_data))) {
|
||||||
if (message_not_thrown_before(function_name, "amr_class", "untreatable")) {
|
if (message_not_thrown_before(function_name, "amr_class", "untreatable")) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `", function_name, "()`: some drugs were ignored since they cannot be used for treatment: ",
|
"in {.help [{.fun ", function_name, "}](AMR::", function_name, ")}: some drugs were ignored since they cannot be used for treatment: ",
|
||||||
vector_and(
|
vector_and(
|
||||||
ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
|
ab_name(names(ab_in_data)[names(ab_in_data) %in% untreatable],
|
||||||
language = NULL,
|
language = NULL,
|
||||||
@@ -797,14 +797,14 @@ amr_select_exec <- function(function_name,
|
|||||||
if (only_treatable == TRUE) {
|
if (only_treatable == TRUE) {
|
||||||
if (message_not_thrown_before(function_name, "amr_class", "untreatable")) {
|
if (message_not_thrown_before(function_name, "amr_class", "untreatable")) {
|
||||||
message_(
|
message_(
|
||||||
"in `", function_name, "()`: ",
|
"in {.help [{.fun ", function_name, "}](AMR::", function_name, ")}: ",
|
||||||
vector_and(
|
vector_and(
|
||||||
paste0(
|
paste0(
|
||||||
ab_name(abx[abx %in% untreatable],
|
ab_name(abx[abx %in% untreatable],
|
||||||
language = NULL,
|
language = NULL,
|
||||||
tolower = TRUE
|
tolower = TRUE
|
||||||
),
|
),
|
||||||
" (`", abx[abx %in% untreatable], "`)"
|
" ({.field ", font_bold(abx[abx %in% untreatable], collapse = NULL), "})"
|
||||||
),
|
),
|
||||||
quotes = FALSE,
|
quotes = FALSE,
|
||||||
sort = TRUE,
|
sort = TRUE,
|
||||||
@@ -837,10 +837,10 @@ 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 {.arg with = FALSE}, see our examples at {.help [{.fun amr_selector}](AMR::amr_selector)}.",
|
||||||
immediate = TRUE
|
immediate = TRUE
|
||||||
)
|
)
|
||||||
cat("Class 'amr_selector'\n")
|
cat(format_inline_("Class {.cls amr_selector}\n"))
|
||||||
print(as.character(x), quote = FALSE)
|
print(as.character(x), quote = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -937,7 +937,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
|
|||||||
if (length(e1) > 1) {
|
if (length(e1) > 1) {
|
||||||
message_(
|
message_(
|
||||||
"Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
|
"Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
|
||||||
". Wrap around `all()` or `any()` to prevent this note."
|
". Wrap around {.fun all} or {.fun any} to prevent this note."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
@@ -962,7 +962,7 @@ any.amr_selector_any_all <- function(..., na.rm = FALSE) {
|
|||||||
if (length(e1) > 1) {
|
if (length(e1) > 1) {
|
||||||
message_(
|
message_(
|
||||||
"Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
|
"Assuming a filter on ", type, " ", length(e1), " ", gsub("[\\(\\)]", "", fn_name),
|
||||||
". Wrap around `all()` or `any()` to prevent this note."
|
". Wrap around {.fun all} or {.fun any} to prevent this note."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
@@ -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") {
|
||||||
@@ -1071,12 +1071,12 @@ message_agent_names <- function(function_name, agents, ab_group = NULL, examples
|
|||||||
message_("No antimicrobial drugs of class '", ab_group, "' found", examples, ".")
|
message_("No antimicrobial drugs of class '", ab_group, "' found", examples, ".")
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
|
agents_formatted <- paste0("{.field ", font_bold(agents, collapse = NULL), "}")
|
||||||
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
|
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
|
||||||
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
|
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
|
||||||
agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
|
agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
|
||||||
message_(
|
message_(
|
||||||
"For `", function_name, "(",
|
"For {.help [", function_name, "(",
|
||||||
ifelse(function_name == "amr_class",
|
ifelse(function_name == "amr_class",
|
||||||
paste0("\"", amr_class_args, "\""),
|
paste0("\"", amr_class_args, "\""),
|
||||||
ifelse(!is.null(call),
|
ifelse(!is.null(call),
|
||||||
@@ -1084,7 +1084,7 @@ message_agent_names <- function(function_name, agents, ab_group = NULL, examples
|
|||||||
""
|
""
|
||||||
)
|
)
|
||||||
),
|
),
|
||||||
")` using ",
|
")](AMR::", function_name, ")} using ",
|
||||||
ifelse(length(agents) == 1, "column ", "columns "),
|
ifelse(length(agents) == 1, "column ", "columns "),
|
||||||
vector_and(agents_formatted, quotes = FALSE, sort = FALSE)
|
vector_and(agents_formatted, quotes = FALSE, sort = FALSE)
|
||||||
)
|
)
|
||||||
|
|||||||
@@ -583,9 +583,9 @@ antibiogram.default <- function(x,
|
|||||||
if (length(existing_ab_combined_cols) > 0 && !is.null(ab_transform)) {
|
if (length(existing_ab_combined_cols) > 0 && !is.null(ab_transform)) {
|
||||||
ab_transform <- NULL
|
ab_transform <- NULL
|
||||||
warning_(
|
warning_(
|
||||||
"Detected column name(s) containing the '+' character, which conflicts with the expected syntax in `antibiogram()`: the '+' is used to combine separate antimicrobial drug columns (e.g., \"AMP+GEN\").\n\n",
|
"Detected column name(s) containing the '+' character, which conflicts with the expected syntax in {.help [{.fun antibiogram}](AMR::antibiogram)}: the '+' is used to combine separate antimicrobial drug columns (e.g., \"AMP+GEN\").\n\n",
|
||||||
"To avoid incorrectly guessing which antimicrobials this represents, `ab_transform` was automatically set to `NULL`.\n\n",
|
"To avoid incorrectly guessing which antimicrobials this represents, {.arg ab_transform} was automatically set to {.code NULL}.\n\n",
|
||||||
"If this is unintended, please rename the column(s) to avoid using '+' in the name, or set `ab_transform = NULL` explicitly to suppress this message."
|
"If this is unintended, please rename the column(s) to avoid using '+' in the name, or set {.code ab_transform = NULL} explicitly to suppress this message."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
antimicrobials <- ab_trycatch
|
antimicrobials <- ab_trycatch
|
||||||
@@ -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 {.arg 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 {.arg minimum} = {minimum} results and were ignored")
|
message_("NOTE: ", mins, " combinations had less than {.arg minimum} = ", minimum, " results and were ignored")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
@@ -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 {.help AMR::wisca}() or {.help AMR::antibiogram}() (with {.code 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
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -180,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 {.help AMR::atc_online_property}(): no properties found for ATC ", atc_code[i], ". Please check {.href {atc_url} this WHOCC webpage}.")
|
message_("{.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
|
||||||
}
|
}
|
||||||
|
|||||||
10
R/av.R
10
R/av.R
@@ -475,7 +475,7 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
|||||||
# take failed ATC codes apart from rest
|
# take failed ATC codes apart from rest
|
||||||
if (length(x_unknown_ATCs) > 0 && fast_mode == FALSE) {
|
if (length(x_unknown_ATCs) > 0 && fast_mode == FALSE) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `as.av()`: these ATC codes are not (yet) in the antivirals data set: ",
|
"in {.help [{.fun as.av}](AMR::as.av)}: these ATC codes are not (yet) in the antivirals data set: ",
|
||||||
vector_and(x_unknown_ATCs), "."
|
vector_and(x_unknown_ATCs), "."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -486,7 +486,7 @@ as.av <- function(x, flag_multiple_results = TRUE, info = interactive(), ...) {
|
|||||||
)
|
)
|
||||||
if (length(x_unknown) > 0 && fast_mode == FALSE) {
|
if (length(x_unknown) > 0 && fast_mode == FALSE) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `as.av()`: these values could not be coerced to a valid antiviral drug ID: ",
|
"in {.help [{.fun as.av}](AMR::as.av)}: these values could not be coerced to a valid antiviral drug ID: ",
|
||||||
vector_and(x_unknown), "."
|
vector_and(x_unknown), "."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -511,8 +511,8 @@ is.av <- function(x) {
|
|||||||
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, av)
|
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, av)
|
||||||
pillar_shaft.av <- function(x, ...) {
|
pillar_shaft.av <- function(x, ...) {
|
||||||
out <- trimws(format(x))
|
out <- trimws(format(x))
|
||||||
out[!is.na(x)] <- gsub("+", font_subtle("+"), out[!is.na(x)], fixed = TRUE)
|
out[!is.na(x)] <- gsub("+", pillar::style_subtle("+"), out[!is.na(x)], fixed = TRUE)
|
||||||
out[is.na(x)] <- font_na(NA)
|
out[is.na(x)] <- pillar::style_na(NA)
|
||||||
create_pillar_column(out, align = "left", min_width = 4)
|
create_pillar_column(out, align = "left", min_width = 4)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -526,7 +526,7 @@ type_sum.av <- function(x, ...) {
|
|||||||
#' @export
|
#' @export
|
||||||
#' @noRd
|
#' @noRd
|
||||||
print.av <- function(x, ...) {
|
print.av <- function(x, ...) {
|
||||||
cat("Class 'av'\n")
|
cat(format_inline_("Class {.cls av}\n"))
|
||||||
print(as.character(x), quote = FALSE)
|
print(as.character(x), quote = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -162,7 +162,7 @@ av_ddd <- function(x, administration = "oral", ...) {
|
|||||||
|
|
||||||
if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
|
if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `av_ddd()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
"in {.help [{.fun av_ddd}](AMR::av_ddd)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||||
"Please refer to the WHOCC website:\n",
|
"Please refer to the WHOCC website:\n",
|
||||||
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
||||||
)
|
)
|
||||||
@@ -182,7 +182,7 @@ av_ddd_units <- function(x, administration = "oral", ...) {
|
|||||||
|
|
||||||
if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
|
if (any(av_name(x, language = NULL) %like% "/" & is.na(out))) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `av_ddd_units()`: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
"in {.help [{.fun av_ddd_units}](AMR::av_ddd_units)}: DDDs of some combined products are available for different dose combinations and not (yet) part of the AMR package.",
|
||||||
"Please refer to the WHOCC website:\n",
|
"Please refer to the WHOCC website:\n",
|
||||||
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
"atcddd.fhi.no/ddd/list_of_ddds_combined_products/"
|
||||||
)
|
)
|
||||||
@@ -233,12 +233,12 @@ av_url <- function(x, open = FALSE, ...) {
|
|||||||
|
|
||||||
NAs <- av_name(av, tolower = TRUE, language = NULL)[!is.na(av) & is.na(atcs)]
|
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 {.field ", font_bold(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 {.help [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 {.help AMR::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 {.help AMR::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 {.help AMR::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 {.help AMR::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 {.help AMR::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 {.help AMR::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 {.help AMR::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 {.help AMR::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
|
||||||
@@ -235,9 +235,9 @@ print.custom_mdro_guideline <- function(x, ...) {
|
|||||||
for (i in seq_len(length(x))) {
|
for (i in seq_len(length(x))) {
|
||||||
rule <- x[[i]]
|
rule <- x[[i]]
|
||||||
rule$query <- format_custom_query_rule(rule$query)
|
rule$query <- format_custom_query_rule(rule$query)
|
||||||
cat(" ", i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then: "), font_red(rule$value), "\n", sep = "")
|
cat("\u00a0\u00a0", i, ". ", font_bold("If "), font_blue(rule$query), font_bold(" then: "), font_red(rule$value), "\n", sep = "")
|
||||||
}
|
}
|
||||||
cat(" ", i + 1, ". ", font_bold("Otherwise: "), font_red(paste0("Negative")), "\n", sep = "")
|
cat("\u00a0\u00a0", i + 1, ". ", font_bold("Otherwise: "), font_red(paste0("Negative")), "\n", sep = "")
|
||||||
cat("\nUnmatched rows will return ", font_red("NA"), ".\n", sep = "")
|
cat("\nUnmatched rows will return ", font_red("NA"), ".\n", sep = "")
|
||||||
if (isTRUE(attributes(x)$as_factor)) {
|
if (isTRUE(attributes(x)$as_factor)) {
|
||||||
cat("Results will be of class 'factor', with ordered levels: ", paste0(attributes(x)$values, collapse = " < "), "\n", sep = "")
|
cat("Results will be of class 'factor', with ordered levels: ", paste0(attributes(x)$values, collapse = " < "), "\n", sep = "")
|
||||||
@@ -259,15 +259,15 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
|
|||||||
}
|
}
|
||||||
)
|
)
|
||||||
if (identical(qry, "error")) {
|
if (identical(qry, "error")) {
|
||||||
warning_("in {.help AMR::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: ",
|
" ({.code ", as.character(guideline[[i]]$query), "}) was ignored because of this error message: ",
|
||||||
AMR_env$err_msg,
|
AMR_env$err_msg,
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
stop_ifnot(is.logical(qry), "in {.help AMR::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 {.code TRUE} or {.code 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 {.code 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, ...) {
|
||||||
|
|||||||
8
R/disk.R
8
R/disk.R
@@ -119,9 +119,9 @@ 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 {.help [{.fun as.disk}](AMR::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 {.field ", font_bold(cur_col, collapse = NULL), "}")),
|
||||||
" truncated (",
|
" truncated (",
|
||||||
round(((na_after - na_before) / length(x)) * 100),
|
round(((na_after - na_before) / length(x)) * 100),
|
||||||
"%) that were invalid disk zones: ",
|
"%) that were invalid disk zones: ",
|
||||||
@@ -162,7 +162,7 @@ is.disk <- function(x) {
|
|||||||
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, disk)
|
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, disk)
|
||||||
pillar_shaft.disk <- function(x, ...) {
|
pillar_shaft.disk <- function(x, ...) {
|
||||||
out <- trimws(format(x))
|
out <- trimws(format(x))
|
||||||
out[is.na(x)] <- font_na(NA)
|
out[is.na(x)] <- pillar::style_na(NA)
|
||||||
create_pillar_column(out, align = "right", width = 2)
|
create_pillar_column(out, align = "right", width = 2)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -170,7 +170,7 @@ pillar_shaft.disk <- function(x, ...) {
|
|||||||
#' @export
|
#' @export
|
||||||
#' @noRd
|
#' @noRd
|
||||||
print.disk <- function(x, ...) {
|
print.disk <- function(x, ...) {
|
||||||
cat("Class 'disk'\n")
|
cat(format_inline_("Class {.cls disk}\n"))
|
||||||
print(as.integer(x), quote = FALSE)
|
print(as.integer(x), quote = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -333,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 {.code ", column, "} not found.",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -373,7 +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, "'")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
if (!is.null(col_keyantimicrobials)) {
|
if (!is.null(col_keyantimicrobials)) {
|
||||||
@@ -430,7 +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 {.strong {length(c(row.start:row.end))} first isolates}, as all isolates were different microbial species",
|
n_rows <- length(c(row.start:row.end))
|
||||||
|
message_("=> Found {.strong ", n_rows, " first isolates}, as all isolates were different microbial species",
|
||||||
as_note = FALSE
|
as_note = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -447,13 +448,15 @@ first_isolate <- function(x = NULL,
|
|||||||
if (!is.null(col_keyantimicrobials)) {
|
if (!is.null(col_keyantimicrobials)) {
|
||||||
if (isTRUE(info) && message_not_thrown_before("first_isolate", "type")) {
|
if (isTRUE(info) && message_not_thrown_before("first_isolate", "type")) {
|
||||||
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"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
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
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -537,7 +540,7 @@ first_isolate <- function(x = NULL,
|
|||||||
paste0('"', x, '"')
|
paste0('"', x, '"')
|
||||||
}
|
}
|
||||||
})
|
})
|
||||||
message_("\nGroup: {toString(paste0(names(group), ' = ', group))}\n",
|
message_("\nGroup: ", toString(paste0(names(group), " = ", group)), "\n",
|
||||||
as_note = FALSE
|
as_note = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -551,7 +554,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 {.field ", font_bold(col_mo), "})"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
|
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
|
||||||
@@ -562,7 +565,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 {.field ", font_bold(col_mo), "})"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE
|
x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- 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)
|
||||||
|
|||||||
@@ -86,7 +86,7 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_s
|
|||||||
} else {
|
} else {
|
||||||
if (isTRUE(verbose)) {
|
if (isTRUE(verbose)) {
|
||||||
message_(
|
message_(
|
||||||
"Using column '", font_bold(ab_result), "' as input for ", search_string,
|
"Using column {.field ", font_bold(ab_result), "} as input for ", search_string,
|
||||||
" (", ab_name(search_string, language = NULL, tolower = TRUE), ")."
|
" (", ab_name(search_string, language = NULL, tolower = TRUE), ")."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -146,7 +146,7 @@ get_column_abx <- function(x,
|
|||||||
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
meet_criteria(only_sir_columns, allow_class = "logical", has_length = 1)
|
||||||
meet_criteria(sort, allow_class = "logical", has_length = 1)
|
meet_criteria(sort, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info) && message_not_thrown_before("get_column_abx", colnames(x))) {
|
||||||
message_("Auto-guessing columns suitable for analysis", appendLF = FALSE, as_note = FALSE)
|
message_("Auto-guessing columns suitable for analysis", appendLF = FALSE, as_note = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -210,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_("WARNING: some columns returned NA for {.help AMR::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,
|
||||||
@@ -267,7 +267,7 @@ get_column_abx <- function(x,
|
|||||||
if (all_okay == TRUE) {
|
if (all_okay == TRUE) {
|
||||||
message_(" OK.", as_note = FALSE)
|
message_(" OK.", as_note = FALSE)
|
||||||
} else if (!isFALSE(dups)) {
|
} else if (!isFALSE(dups)) {
|
||||||
message_("WARNING: some results from {.help AMR::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.", as_note = FALSE)
|
message_(" WARNING.", as_note = FALSE)
|
||||||
}
|
}
|
||||||
@@ -275,7 +275,7 @@ get_column_abx <- function(x,
|
|||||||
for (i in seq_len(length(out))) {
|
for (i in seq_len(length(out))) {
|
||||||
if (isTRUE(verbose) && !out[i] %in% duplicates) {
|
if (isTRUE(verbose) && !out[i] %in% duplicates) {
|
||||||
message_(
|
message_(
|
||||||
"Using column '", font_bold(out[i]), "' as input for ", names(out)[i],
|
"Using column {.field ", font_bold(out[i]), "} as input for ", names(out)[i],
|
||||||
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")."
|
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -284,7 +284,7 @@ get_column_abx <- function(x,
|
|||||||
if (names(out)[i] != already_set_as) {
|
if (names(out)[i] != already_set_as) {
|
||||||
message_(
|
message_(
|
||||||
paste0(
|
paste0(
|
||||||
"Column '", font_bold(out[i]), "' will not be used for ",
|
"Column {.field ", 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."
|
||||||
)
|
)
|
||||||
|
|||||||
@@ -198,7 +198,7 @@ interpretive_rules <- function(x,
|
|||||||
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 {.help AMR::eucast_rules}(): no custom rules were set with the {.arg 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"]
|
||||||
@@ -329,7 +329,7 @@ interpretive_rules <- function(x,
|
|||||||
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 EUCAST rules depend on it.")
|
message_("Using column {.field ", font_bold(cols_ab[names(cols_ab) == "AMX"]), "} as input for ampicillin since many EUCAST 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"])))
|
||||||
}
|
}
|
||||||
@@ -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 {.help AMR::eucast_rules}()\n"
|
"), see {.help [{.fun eucast_rules}](AMR::eucast_rules)}\n"
|
||||||
)
|
)
|
||||||
))
|
))
|
||||||
cat("\n\n")
|
cat("\n\n")
|
||||||
@@ -510,8 +510,8 @@ interpretive_rules <- function(x,
|
|||||||
|
|
||||||
## Set base to R where base + enzyme inhibitor is R ----
|
## Set base to R where base + enzyme inhibitor is R ----
|
||||||
rule_current <- paste0(
|
rule_current <- paste0(
|
||||||
ab_enzyme$base_name[i], " (`", col_base, "`) = R if ",
|
ab_enzyme$base_name[i], " ({.field ", font_bold(col_base), "}) = R if ",
|
||||||
tolower(ab_enzyme$enzyme_name[i]), " (`", col_enzyme, "`) = R"
|
tolower(ab_enzyme$enzyme_name[i]), " ({.field ", font_bold(col_enzyme), "}) = R"
|
||||||
)
|
)
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
cat(word_wrap(rule_current,
|
cat(word_wrap(rule_current,
|
||||||
@@ -551,8 +551,8 @@ interpretive_rules <- function(x,
|
|||||||
|
|
||||||
## Set base + enzyme inhibitor to S where base is S ----
|
## Set base + enzyme inhibitor to S where base is S ----
|
||||||
rule_current <- paste0(
|
rule_current <- paste0(
|
||||||
ab_enzyme$enzyme_name[i], " (`", col_enzyme, "`) = S if ",
|
ab_enzyme$enzyme_name[i], " ({.field ", font_bold(col_enzyme), "}) = S if ",
|
||||||
tolower(ab_enzyme$base_name[i]), " (`", col_base, "`) = S"
|
tolower(ab_enzyme$base_name[i]), " ({.field ", font_bold(col_base), "}) = S"
|
||||||
)
|
)
|
||||||
|
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
@@ -661,9 +661,10 @@ interpretive_rules <- function(x,
|
|||||||
ab <- gsub("-S$", "", ab_s)
|
ab <- gsub("-S$", "", ab_s)
|
||||||
if (ab %in% names(cols_ab) && !ab_s %in% names(cols_ab)) {
|
if (ab %in% names(cols_ab) && !ab_s %in% names(cols_ab)) {
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
message_("Using column '", cols_ab[names(cols_ab) == ab],
|
message_(
|
||||||
"' as ", ab_name(ab_s, language = NULL, tolower = TRUE),
|
"Using column {.field ", font_bold(cols_ab[names(cols_ab) == ab]),
|
||||||
" since a column '", ab_s, "' is missing but required for the chosen rules"
|
"} as ", ab_name(ab_s, language = NULL, tolower = TRUE),
|
||||||
|
" since a column {.code ", ab_s, "} is missing but required for the chosen rules"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
cols_ab <- c(cols_ab, stats::setNames(unname(cols_ab[names(cols_ab) == ab]), ab_s))
|
cols_ab <- c(cols_ab, stats::setNames(unname(cols_ab[names(cols_ab) == ab]), ab_s))
|
||||||
@@ -805,7 +806,7 @@ interpretive_rules <- function(x,
|
|||||||
")$"
|
")$"
|
||||||
)
|
)
|
||||||
} else if (like_is_one_of != "like") {
|
} else if (like_is_one_of != "like") {
|
||||||
stop("invalid value for column 'like.is.one_of'", call. = FALSE)
|
stop("invalid value for column {.field like.is.one_of}", call. = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
if (is.na(source_antibiotics)) {
|
if (is.na(source_antibiotics)) {
|
||||||
@@ -1050,9 +1051,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 = "")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1062,13 +1063,13 @@ interpretive_rules <- function(x,
|
|||||||
warn_lacking_sir_class <- warn_lacking_sir_class[order(colnames(x.bak))]
|
warn_lacking_sir_class <- warn_lacking_sir_class[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 {.help AMR::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))"))
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1097,7 +1098,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 {.code AMR_eucastrules} that you have set is now invalid was ignored - set {.code AMR_interpretive_rules} instead. See {.code ?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", ...)
|
||||||
}
|
}
|
||||||
@@ -1178,7 +1179,7 @@ edit_sir <- function(x,
|
|||||||
suppressWarnings(new_edits[rows, cols][non_SIR] <<- to)
|
suppressWarnings(new_edits[rows, cols][non_SIR] <<- to)
|
||||||
}
|
}
|
||||||
warning_(
|
warning_(
|
||||||
"in {.help AMR::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."
|
||||||
@@ -1186,7 +1187,7 @@ edit_sir <- function(x,
|
|||||||
txt_warning()
|
txt_warning()
|
||||||
warned <- FALSE
|
warned <- FALSE
|
||||||
} else {
|
} else {
|
||||||
warning_("in {.help AMR::eucast_rules}(): ", w$message)
|
warning_("in {.help [{.fun eucast_rules}](AMR::eucast_rules)}: ", w$message)
|
||||||
txt_warning()
|
txt_warning()
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
|
|||||||
@@ -145,7 +145,7 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
|
|||||||
} else {
|
} else {
|
||||||
stop_if(is.null(by), "no column with microorganism names or codes found, set this column with {.arg 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}"', 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 {.arg 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 {
|
||||||
@@ -182,12 +182,12 @@ key_antimicrobials <- function(x = NULL,
|
|||||||
any(filter, na.rm = TRUE) &&
|
any(filter, na.rm = TRUE) &&
|
||||||
message_not_thrown_before("key_antimicrobials", name)) {
|
message_not_thrown_before("key_antimicrobials", name)) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `key_antimicrobials()`: ",
|
"in {.help [{.fun key_antimicrobials}](AMR::key_antimicrobials)}: ",
|
||||||
ifelse(values_new_length == 0,
|
ifelse(values_new_length == 0,
|
||||||
"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 {.help AMR::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]]
|
||||||
|
|||||||
12
R/mdro.R
12
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 {.arg only_sir_columns} being {.code TRUE}. Transform columns with {.help AMR::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 {.help AMR::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
|
||||||
@@ -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 {.help AMR::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",
|
||||||
@@ -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.")
|
message_("Using column {.field ", font_bold(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"])))
|
||||||
}
|
}
|
||||||
@@ -1888,8 +1888,8 @@ mdro <- function(x = NULL,
|
|||||||
if (any(x$MDRO == -1, na.rm = TRUE)) {
|
if (any(x$MDRO == -1, na.rm = TRUE)) {
|
||||||
if (message_not_thrown_before("mdro", "availability")) {
|
if (message_not_thrown_before("mdro", "availability")) {
|
||||||
warning_(
|
warning_(
|
||||||
"in `mdro()`: NA introduced for isolates where the available percentage of antimicrobial classes was below ",
|
"in {.help [{.fun mdro}](AMR::mdro)}: NA introduced for isolates where the available percentage of antimicrobial classes was below ",
|
||||||
percentage(pct_required_classes), " (set with `pct_required_classes`)"
|
percentage(pct_required_classes), " (set with {.arg pct_required_classes})"
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
# set these -1s to NA
|
# set these -1s to NA
|
||||||
|
|||||||
35
R/mic.R
35
R/mic.R
@@ -72,7 +72,7 @@ COMMON_MIC_VALUES <- c(
|
|||||||
#' ```
|
#' ```
|
||||||
#' x <- random_mic(10)
|
#' x <- random_mic(10)
|
||||||
#' x
|
#' x
|
||||||
#' #> Class 'mic'
|
#' #> Class <mic>
|
||||||
#' #> [1] 16 1 8 8 64 >=128 0.0625 32 32 16
|
#' #> [1] 16 1 8 8 64 >=128 0.0625 32 32 16
|
||||||
#'
|
#'
|
||||||
#' is.factor(x)
|
#' is.factor(x)
|
||||||
@@ -89,7 +89,7 @@ COMMON_MIC_VALUES <- c(
|
|||||||
#'
|
#'
|
||||||
#' ```
|
#' ```
|
||||||
#' x[x > 4]
|
#' x[x > 4]
|
||||||
#' #> Class 'mic'
|
#' #> Class <mic>
|
||||||
#' #> [1] 16 8 8 64 >=128 32 32 16
|
#' #> [1] 16 8 8 64 >=128 32 32 16
|
||||||
#'
|
#'
|
||||||
#' df <- data.frame(x, hospital = "A")
|
#' df <- data.frame(x, hospital = "A")
|
||||||
@@ -174,7 +174,7 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all", round_to_next_log2
|
|||||||
keep_operators <- "none"
|
keep_operators <- "none"
|
||||||
}
|
}
|
||||||
|
|
||||||
if (is.mic(x) && (keep_operators == "all" || !any(x %like% "[>=<]", na.rm = TRUE))) {
|
if (any(is.mic(x)) && (keep_operators == "all" || !any(x %like% "[>=<]", na.rm = TRUE))) {
|
||||||
if (isTRUE(round_to_next_log2)) {
|
if (isTRUE(round_to_next_log2)) {
|
||||||
x <- roundup_to_nearest_log2(x)
|
x <- roundup_to_nearest_log2(x)
|
||||||
}
|
}
|
||||||
@@ -269,9 +269,9 @@ 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 {.help [{.fun as.mic}](AMR::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 {.field ", font_bold(cur_col, collapse = NULL), "}")),
|
||||||
" truncated (",
|
" truncated (",
|
||||||
round(((na_after - na_before) / length(x)) * 100),
|
round(((na_after - na_before) / length(x)) * 100),
|
||||||
"%) that were invalid MICs: ",
|
"%) that were invalid MICs: ",
|
||||||
@@ -322,16 +322,17 @@ NA_mic_ <- set_clean_class(factor(NA, levels = VALID_MIC_LEVELS, ordered = TRUE)
|
|||||||
#' @export
|
#' @export
|
||||||
rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE, round_to_next_log2 = FALSE) {
|
rescale_mic <- function(x, mic_range, keep_operators = "edges", as.mic = TRUE, round_to_next_log2 = FALSE) {
|
||||||
meet_criteria(mic_range, allow_class = c("numeric", "integer", "logical", "mic"), has_length = 2, allow_NA = TRUE, allow_NULL = TRUE)
|
meet_criteria(mic_range, allow_class = c("numeric", "integer", "logical", "mic"), has_length = 2, allow_NA = TRUE, allow_NULL = TRUE)
|
||||||
|
|
||||||
if (is.numeric(mic_range)) {
|
if (is.numeric(mic_range)) {
|
||||||
mic_range <- trimws(format(mic_range, scientific = FALSE))
|
mic_range <- trimws(format(mic_range, scientific = FALSE))
|
||||||
mic_range <- gsub("[.]0+$", "", mic_range)
|
mic_range <- gsub("[.]0+$", "", mic_range)
|
||||||
mic_range[mic_range == "NA"] <- NA_character_
|
mic_range[mic_range == "NA"] <- NA_character_
|
||||||
} else if (is.mic(mic_range)) {
|
} else if (any(is.mic(mic_range))) {
|
||||||
mic_range <- as.character(mic_range)
|
mic_range <- as.character(mic_range)
|
||||||
}
|
}
|
||||||
stop_ifnot(
|
stop_ifnot(
|
||||||
all(mic_range %in% c(VALID_MIC_LEVELS, NA)),
|
all(mic_range %in% c(VALID_MIC_LEVELS, NA)),
|
||||||
"Values in `mic_range` must be valid MIC values. ",
|
"Values in {.arg mic_range} must be valid MIC values. ",
|
||||||
"The allowed range is ", format(as.double(as.mic(VALID_MIC_LEVELS)[1]), scientific = FALSE), " to ", format(as.double(as.mic(VALID_MIC_LEVELS)[length(VALID_MIC_LEVELS)]), scientific = FALSE), ". ",
|
"The allowed range is ", format(as.double(as.mic(VALID_MIC_LEVELS)[1]), scientific = FALSE), " to ", format(as.double(as.mic(VALID_MIC_LEVELS)[length(VALID_MIC_LEVELS)]), scientific = FALSE), ". ",
|
||||||
"Unvalid: ", vector_and(mic_range[!mic_range %in% c(VALID_MIC_LEVELS, NA)], quotes = FALSE), "."
|
"Unvalid: ", vector_and(mic_range[!mic_range %in% c(VALID_MIC_LEVELS, NA)], quotes = FALSE), "."
|
||||||
)
|
)
|
||||||
@@ -441,23 +442,19 @@ 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
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
crude_numbers <- as.double(x)
|
crude_numbers <- as.double(x)
|
||||||
operators <- gsub("[^<=>]+", "", as.character(x))
|
operators <- gsub("[^<=>]+", "", as.character(x))
|
||||||
# colourise operators
|
# colourise operators
|
||||||
operators[!is.na(operators) & operators != ""] <- font_silver(operators[!is.na(operators) & operators != ""], collapse = NULL)
|
operators[!is.na(operators) & operators != ""] <- pillar::style_subtle(operators[!is.na(operators) & operators != ""])
|
||||||
out <- trimws(paste0(operators, trimws(format(crude_numbers))))
|
out <- trimws(paste0(operators, trimws(format(crude_numbers))))
|
||||||
out[is.na(x)] <- font_na(NA)
|
out[is.na(x)] <- pillar::style_na(NA)
|
||||||
# make trailing zeroes less visible
|
# make trailing zeroes less visible
|
||||||
if (is_dark()) {
|
out[out %like% "[.]"] <- gsub("([.]?0+)$", pillar::style_subtle("\\1"), out[out %like% "[.]"], perl = TRUE)
|
||||||
fn <- font_silver
|
|
||||||
} else {
|
|
||||||
fn <- font_white
|
|
||||||
}
|
|
||||||
out[out %like% "[.]"] <- gsub("([.]?0+)$", fn("\\1"), out[out %like% "[.]"], perl = TRUE)
|
|
||||||
create_pillar_column(out, align = "right", width = max(nchar(font_stripstyle(out))))
|
create_pillar_column(out, align = "right", width = max(nchar(font_stripstyle(out))))
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -475,7 +472,7 @@ type_sum.mic <- function(x, ...) {
|
|||||||
#' @export
|
#' @export
|
||||||
#' @noRd
|
#' @noRd
|
||||||
print.mic <- function(x, ...) {
|
print.mic <- function(x, ...) {
|
||||||
cat("Class 'mic'")
|
cat(format_inline_("Class {.cls mic}"))
|
||||||
if (!identical(levels(x), VALID_MIC_LEVELS)) {
|
if (!identical(levels(x), VALID_MIC_LEVELS)) {
|
||||||
cat(font_red(" with an outdated or altered structure - convert with `as.mic()` to update"))
|
cat(font_red(" with an outdated or altered structure - convert with `as.mic()` to update"))
|
||||||
}
|
}
|
||||||
@@ -508,7 +505,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 +598,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))
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
165
R/mo.R
165
R/mo.R
@@ -249,7 +249,7 @@ as.mo <- function(x,
|
|||||||
if (length(which(ind)) > 0 && isTRUE(info) && message_not_thrown_before("as.mo_microorganisms.codes", is.na(out), toupper(x))) {
|
if (length(which(ind)) > 0 && isTRUE(info) && message_not_thrown_before("as.mo_microorganisms.codes", is.na(out), toupper(x))) {
|
||||||
message_(
|
message_(
|
||||||
"Retrieved value", ifelse(sum(ind) > 1, "s", ""),
|
"Retrieved value", ifelse(sum(ind) > 1, "s", ""),
|
||||||
" from the `microorganisms.codes` data set for ", vector_and(toupper(x)[ind]), "."
|
" from the {.help [microorganisms.codes](AMR::microorganisms.codes)} data set for ", vector_and(paste0("{.val ", toupper(x)[ind], "}"), quotes = FALSE), "."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
# From SNOMED ----
|
# From SNOMED ----
|
||||||
@@ -267,7 +267,7 @@ as.mo <- function(x,
|
|||||||
if (isTRUE(info) && message_not_thrown_before("as.mo", old, new, entire_session = TRUE) && any(is.na(old) & !is.na(new), na.rm = TRUE)) {
|
if (isTRUE(info) && message_not_thrown_before("as.mo", old, new, entire_session = TRUE) && any(is.na(old) & !is.na(new), na.rm = TRUE)) {
|
||||||
message_(
|
message_(
|
||||||
"Returning previously coerced value", ifelse(sum(is.na(old) & !is.na(new)) > 1, "s", ""),
|
"Returning previously coerced value", ifelse(sum(is.na(old) & !is.na(new)) > 1, "s", ""),
|
||||||
" for ", vector_and(x[is.na(old) & !is.na(new)]), ". Run `mo_reset_session()` to reset this. This note will be shown once per session for this input."
|
" for ", vector_and(x[is.na(old) & !is.na(new)]), ". Run {.help [{.fun mo_reset_session}](AMR::mo_reset_session)} to reset this. This note will be shown once per session for this input."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -407,7 +407,9 @@ as.mo <- function(x,
|
|||||||
paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"),
|
paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"),
|
||||||
minimum_matching_score
|
minimum_matching_score
|
||||||
),
|
),
|
||||||
". Try setting this value lower or even to 0.", call = FALSE)
|
". 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)]
|
||||||
@@ -453,8 +455,8 @@ as.mo <- function(x,
|
|||||||
if (length(AMR_env$mo_uncertainties$original_input) <= 3) {
|
if (length(AMR_env$mo_uncertainties$original_input) <= 3) {
|
||||||
examples <- vector_and(
|
examples <- vector_and(
|
||||||
paste0(
|
paste0(
|
||||||
'"', AMR_env$mo_uncertainties$original_input,
|
"{.val ", AMR_env$mo_uncertainties$original_input,
|
||||||
'" (assumed ', italicise(AMR_env$mo_uncertainties$fullname), ")"
|
"} (assumed ", italicise(AMR_env$mo_uncertainties$fullname), ")"
|
||||||
),
|
),
|
||||||
quotes = FALSE
|
quotes = FALSE
|
||||||
)
|
)
|
||||||
@@ -463,7 +465,7 @@ as.mo <- function(x,
|
|||||||
}
|
}
|
||||||
msg <- c(msg, paste0(
|
msg <- c(msg, paste0(
|
||||||
"Microorganism translation was uncertain for ", examples,
|
"Microorganism translation was uncertain for ", examples,
|
||||||
". Run `mo_uncertainties()` to review ", plural[2], ", or use `add_custom_microorganisms()` to add custom entries."
|
". Run {.help [{.fun mo_uncertainties}](AMR::mo_uncertainties)} to review ", plural[2], ", or use {.help [{.fun add_custom_microorganisms}](AMR::add_custom_microorganisms)} to add custom entries."
|
||||||
))
|
))
|
||||||
|
|
||||||
for (m in msg) {
|
for (m in msg) {
|
||||||
@@ -479,11 +481,11 @@ as.mo <- function(x,
|
|||||||
if (isFALSE(keep_synonyms)) {
|
if (isFALSE(keep_synonyms)) {
|
||||||
out[!is.na(out_current)] <- out_current[!is.na(out_current)]
|
out[!is.na(out_current)] <- out_current[!is.na(out_current)]
|
||||||
if (isTRUE(info) && length(AMR_env$mo_renamed$old) > 0) {
|
if (isTRUE(info) && length(AMR_env$mo_renamed$old) > 0) {
|
||||||
print(mo_renamed(), extra_txt = " (use `keep_synonyms = TRUE` to leave uncorrected)")
|
print(mo_renamed(), extra_txt = " (use {.arg keep_synonyms = TRUE} to leave uncorrected)")
|
||||||
}
|
}
|
||||||
} else if (is.null(getOption("AMR_keep_synonyms")) && length(AMR_env$mo_renamed$old) > 0 && message_not_thrown_before("as.mo", "keep_synonyms_warning", entire_session = TRUE)) {
|
} 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 {.arg keep_synonyms = FALSE} to clean the input to currently accepted taxonomic names, or set the R option {.code AMR_keep_synonyms} to {.code FALSE}. This warning will be shown once per session.", call = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
# Apply Becker ----
|
# Apply Becker ----
|
||||||
@@ -500,7 +502,7 @@ as.mo <- function(x,
|
|||||||
)
|
)
|
||||||
if (any(out %in% AMR_env$MO_lookup$mo[match(post_Becker, AMR_env$MO_lookup$fullname)])) {
|
if (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 {.help [{.fun as.mo}](AMR::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
|
||||||
@@ -545,7 +547,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 ----
|
||||||
@@ -646,13 +648,13 @@ pillar_shaft.mo <- function(x, ...) {
|
|||||||
add_MO_lookup_to_AMR_env()
|
add_MO_lookup_to_AMR_env()
|
||||||
out <- trimws(format(x))
|
out <- trimws(format(x))
|
||||||
# grey out the kingdom (part until first "_")
|
# grey out the kingdom (part until first "_")
|
||||||
out[!is.na(x)] <- gsub("^([A-Z]+_)(.*)", paste0(font_subtle("\\1"), "\\2"), out[!is.na(x)], perl = TRUE)
|
out[!is.na(x)] <- gsub("^([A-Z]+_)(.*)", paste0(pillar::style_subtle("\\1"), "\\2"), out[!is.na(x)], perl = TRUE)
|
||||||
# and grey out every _
|
# and grey out every _
|
||||||
out[!is.na(x)] <- gsub("_", font_subtle("_"), out[!is.na(x)])
|
out[!is.na(x)] <- gsub("_", pillar::style_subtle("_"), out[!is.na(x)])
|
||||||
|
|
||||||
# markup NA and UNKNOWN
|
# markup NA and UNKNOWN
|
||||||
out[is.na(x)] <- font_na(" NA")
|
out[is.na(x)] <- pillar::style_na(" NA")
|
||||||
out[x == "UNKNOWN"] <- font_na(" UNKNOWN")
|
out[x == "UNKNOWN"] <- pillar::style_na(" UNKNOWN")
|
||||||
|
|
||||||
# markup manual codes
|
# markup manual codes
|
||||||
out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo] <- font_blue(out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo], collapse = NULL)
|
out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo] <- font_blue(out[x %in% AMR_env$MO_lookup$mo & !x %in% AMR::microorganisms$mo], collapse = NULL)
|
||||||
@@ -671,20 +673,20 @@ pillar_shaft.mo <- function(x, ...) {
|
|||||||
(!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) {
|
(!is.null(df) && !all(unlist(df[, which(mo_cols), drop = FALSE]) %in% all_mos))) {
|
||||||
# markup old mo codes
|
# markup old mo codes
|
||||||
out[!x %in% all_mos] <- font_italic(
|
out[!x %in% all_mos] <- font_italic(
|
||||||
font_na(x[!x %in% all_mos],
|
pillar::style_na(x[!x %in% all_mos],
|
||||||
collapse = NULL
|
collapse = NULL
|
||||||
),
|
),
|
||||||
collapse = NULL
|
collapse = NULL
|
||||||
)
|
)
|
||||||
# throw a warning with the affected column name(s)
|
# throw a warning with the affected column name(s)
|
||||||
if (!is.null(mo_cols)) {
|
if (!is.null(mo_cols)) {
|
||||||
col <- paste0("Column ", vector_or(colnames(df)[mo_cols], quotes = TRUE, sort = FALSE))
|
col <- paste0("Column ", vector_or(paste0("{.field ", font_bold(colnames(df)[mo_cols], collapse = NULL), "}"), quotes = TRUE, sort = FALSE))
|
||||||
} else {
|
} else {
|
||||||
col <- "The data"
|
col <- "The data"
|
||||||
}
|
}
|
||||||
warning_(
|
warning_(
|
||||||
col, " contains old MO codes (from a previous AMR package version). ",
|
col, " contains old MO codes (from a previous AMR package version). ",
|
||||||
"Please update your MO codes with `as.mo()`.",
|
"Please update your MO codes with {.help [{.fun as.mo}](AMR::as.mo)}.",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -781,7 +783,7 @@ get_skimmers.mo <- function(column) {
|
|||||||
#' @noRd
|
#' @noRd
|
||||||
print.mo <- function(x, print.shortnames = FALSE, ...) {
|
print.mo <- function(x, print.shortnames = FALSE, ...) {
|
||||||
add_MO_lookup_to_AMR_env()
|
add_MO_lookup_to_AMR_env()
|
||||||
cat("Class 'mo'\n")
|
cat(format_inline_("Class {.cls mo}\n"))
|
||||||
x_names <- names(x)
|
x_names <- names(x)
|
||||||
if (is.null(x_names) & print.shortnames == TRUE) {
|
if (is.null(x_names) & print.shortnames == TRUE) {
|
||||||
x_names <- tryCatch(mo_shortname(x, ...), error = function(e) NULL)
|
x_names <- tryCatch(mo_shortname(x, ...), error = function(e) NULL)
|
||||||
@@ -791,7 +793,7 @@ print.mo <- function(x, print.shortnames = FALSE, ...) {
|
|||||||
if (!all(x %in% c(AMR_env$MO_lookup$mo, NA))) {
|
if (!all(x %in% c(AMR_env$MO_lookup$mo, NA))) {
|
||||||
warning_(
|
warning_(
|
||||||
"Some MO codes are from a previous AMR package version. ",
|
"Some MO codes are from a previous AMR package version. ",
|
||||||
"Please update the MO codes with `as.mo()`.",
|
"Please update the MO codes with {.help [{.fun as.mo}](AMR::as.mo)}.",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -825,7 +827,7 @@ as.data.frame.mo <- function(x, ...) {
|
|||||||
if (!all(x %in% c(AMR_env$MO_lookup$mo, NA))) {
|
if (!all(x %in% c(AMR_env$MO_lookup$mo, NA))) {
|
||||||
warning_(
|
warning_(
|
||||||
"The data contains old MO codes (from a previous AMR package version). ",
|
"The data contains old MO codes (from a previous AMR package version). ",
|
||||||
"Please update your MO codes with `as.mo()`."
|
"Please update your MO codes with {.help [{.fun as.mo}](AMR::as.mo)}."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
nm <- deparse1(substitute(x))
|
nm <- deparse1(substitute(x))
|
||||||
@@ -907,14 +909,16 @@ 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(font_blue(word_wrap("No uncertainties to show. Only uncertainties of the last call to `as.mo()` or any `mo_*()` function are stored.\n\n")))
|
message_("No uncertainties to show. Only uncertainties of the last call to {.help [{.fun as.mo}](AMR::as.mo)} or any {.help [{.fun mo_*}](AMR::mo_property)} function are stored.")
|
||||||
return(invisible(NULL))
|
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(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 AMR::mo_matching_score}().\n\n")))
|
message_("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See {.help [{.fun mo_matching_score}](AMR::mo_matching_score)}.",
|
||||||
|
as_note = FALSE
|
||||||
|
)
|
||||||
|
|
||||||
add_MO_lookup_to_AMR_env()
|
add_MO_lookup_to_AMR_env()
|
||||||
|
|
||||||
@@ -924,12 +928,13 @@ 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(font_blue(word_wrap("Colour keys: ",
|
cat(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")
|
||||||
)), font_green_bg(" "), "\n", sep = "")
|
), font_green_bg(" "), "\n", sep = "")
|
||||||
}
|
}
|
||||||
|
|
||||||
score_set_colour <- function(text, scores) {
|
score_set_colour <- function(text, scores) {
|
||||||
@@ -960,21 +965,6 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
|
|||||||
# sort on descending scores
|
# sort on descending scores
|
||||||
candidates_formatted <- candidates_formatted[order(1 - scores)]
|
candidates_formatted <- candidates_formatted[order(1 - scores)]
|
||||||
scores_formatted <- scores_formatted[order(1 - scores)]
|
scores_formatted <- scores_formatted[order(1 - scores)]
|
||||||
|
|
||||||
candidates <- word_wrap(
|
|
||||||
paste0(
|
|
||||||
"Also matched: ",
|
|
||||||
vector_and(
|
|
||||||
paste0(
|
|
||||||
candidates_formatted,
|
|
||||||
font_blue(paste0(" (", scores_formatted, ")"), collapse = NULL)
|
|
||||||
),
|
|
||||||
quotes = FALSE, sort = FALSE
|
|
||||||
)
|
|
||||||
),
|
|
||||||
extra_indent = nchar("Also matched: "),
|
|
||||||
width = 0.9 * getOption("width", 100)
|
|
||||||
)
|
|
||||||
} else {
|
} else {
|
||||||
candidates <- ""
|
candidates <- ""
|
||||||
}
|
}
|
||||||
@@ -984,46 +974,54 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
|
|||||||
n = x[i, ]$fullname
|
n = x[i, ]$fullname
|
||||||
)
|
)
|
||||||
score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3))
|
score_formatted <- trimws(formatC(round(score, 3), format = "f", digits = 3))
|
||||||
txt <- paste(txt,
|
|
||||||
|
out <- paste0(
|
||||||
paste0(
|
paste0(
|
||||||
|
"", strrep(font_grey("-"), times = getOption("width", 100) - 1), "\n",
|
||||||
|
"{.val ", x[i, ]$original_input, "}",
|
||||||
|
" -> ",
|
||||||
paste0(
|
paste0(
|
||||||
"", strrep(font_grey("-"), times = getOption("width", 100)), "\n",
|
font_bold(italicise(x[i, ]$fullname)),
|
||||||
'"', x[i, ]$original_input, '"',
|
" (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")"
|
||||||
" -> ",
|
)
|
||||||
paste0(
|
|
||||||
font_bold(italicise(x[i, ]$fullname)),
|
|
||||||
" (", x[i, ]$mo, ", ", score_set_colour(score_formatted, score), ")"
|
|
||||||
)
|
|
||||||
),
|
|
||||||
collapse = "\n"
|
|
||||||
),
|
),
|
||||||
ifelse(x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")],
|
collapse = "\n"
|
||||||
paste0(
|
|
||||||
strrep(" ", nchar(x[i, ]$original_input) + 6),
|
|
||||||
ifelse(x[i, ]$keep_synonyms == FALSE,
|
|
||||||
# Add note if result was coerced to accepted taxonomic name
|
|
||||||
font_red(paste0("This outdated taxonomic name was converted to ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL),
|
|
||||||
# Or add note if result is currently another taxonomic name
|
|
||||||
font_red(paste0(font_bold("Note: "), "The current name is ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", AMR_env$MO_lookup$ref[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], ")."), collapse = NULL)
|
|
||||||
)
|
|
||||||
),
|
|
||||||
""
|
|
||||||
),
|
|
||||||
candidates,
|
|
||||||
sep = "\n"
|
|
||||||
)
|
)
|
||||||
txt <- gsub("[\n]+", "\n", txt)
|
message_(out, as_note = FALSE)
|
||||||
# remove first and last break
|
|
||||||
txt <- gsub("(^[\n]|[\n]$)", "", txt)
|
if (x[i, ]$mo %in% AMR_env$MO_lookup$mo[which(AMR_env$MO_lookup$status == "synonym")]) {
|
||||||
txt <- paste0("\n", txt, "\n")
|
out2 <- paste0(
|
||||||
|
strrep(" ", nchar(x[i, ]$original_input) + 6),
|
||||||
|
ifelse(x[i, ]$keep_synonyms == FALSE,
|
||||||
|
# Add note if result was coerced to accepted taxonomic name
|
||||||
|
font_red(paste0("This outdated taxonomic name was converted to ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", synonym_mo_to_accepted_mo(x[i, ]$mo), ")."), collapse = NULL),
|
||||||
|
# Or add note if result is currently another taxonomic name
|
||||||
|
font_red(paste0(font_bold("Note: "), "The current name is ", font_italic(AMR_env$MO_lookup$fullname[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], collapse = NULL), " (", AMR_env$MO_lookup$ref[match(synonym_mo_to_accepted_mo(x[i, ]$mo), AMR_env$MO_lookup$mo)], ")."), collapse = NULL)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
message_(out2, as_note = FALSE)
|
||||||
|
}
|
||||||
|
|
||||||
|
other_matches <- paste0(
|
||||||
|
"Also matched: ",
|
||||||
|
vector_and(
|
||||||
|
paste0(
|
||||||
|
candidates_formatted,
|
||||||
|
font_blue(paste0(" (", scores_formatted, ")"), collapse = NULL)
|
||||||
|
),
|
||||||
|
quotes = FALSE, sort = FALSE
|
||||||
|
)
|
||||||
|
)
|
||||||
|
message_(other_matches, as_note = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
cat(txt)
|
|
||||||
if (isTRUE(any_maxed_out)) {
|
if (isTRUE(any_maxed_out)) {
|
||||||
cat(font_blue(word_wrap("\nOnly the first ", n, " other matches of each record are shown. Run `print(mo_uncertainties(), n = ...)` to view more entries, or save `mo_uncertainties()` to an object.")))
|
cat("\n")
|
||||||
|
message_("Only the first ", n, " other matches of each record are shown. Run {.help [`print(mo_uncertainties(), n = ...)`](AMR::mo_uncertainties)} to view more entries, or save {.help [{.fun mo_uncertainties}](AMR::mo_uncertainties)} to an object.")
|
||||||
}
|
}
|
||||||
if (isTRUE(more_than_50)) {
|
if (isTRUE(more_than_50)) {
|
||||||
cat(font_blue(word_wrap("\nOnly the first 50 uncertainties are shown. Run `View(mo_uncertainties())` to view all entries, or save `mo_uncertainties()` to an object.")))
|
cat("\n")
|
||||||
|
message_("Only the first 50 uncertainties are shown. Run {.help [`View(mo_uncertainties())`](AMR::mo_uncertainties)} to view all entries, or save {.help [{.fun mo_uncertainties}](AMR::mo_uncertainties)} to an object.")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1032,7 +1030,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(font_blue(word_wrap("No renamed taxonomy to show. Only renamed taxonomy of the last call of `as.mo()` or any `mo_*()` function are stored.\n")))
|
message_("No renamed taxonomy to show. Only renamed taxonomy of the last call of {.help [{.fun as.mo}](AMR::as.mo)} or any {.help [{.fun mo_*}](AMR::mo_property)} function are stored.")
|
||||||
return(invisible(NULL))
|
return(invisible(NULL))
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1043,14 +1041,17 @@ print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
|
|||||||
|
|
||||||
rows <- seq_len(min(NROW(x), n))
|
rows <- seq_len(min(NROW(x), n))
|
||||||
|
|
||||||
message_(
|
message_("The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":")
|
||||||
"The following microorganism", ifelse(NROW(x) > 1, "s were", " was"), " taxonomically renamed", extra_txt, ":\n",
|
old_format <- format(paste0(font_italic(x$old[rows], collapse = NULL), x$ref_old[rows])) # format() will set trailing spaces for textual alignment
|
||||||
paste0(" ", AMR_env$bullet_icon, " ", font_italic(x$old[rows], collapse = NULL), x$ref_old[rows],
|
old_format <- gsub(" ", "\u00a0", old_format, fixed = TRUE)
|
||||||
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
|
for (old_tax in rows) {
|
||||||
collapse = "\n"
|
message_("\u00a0\u00a0", AMR_env$bullet_icon, " ", old_format[old_tax], " -> ", font_italic(x$new[old_tax]), x$ref_new[old_tax], as_note = FALSE)
|
||||||
),
|
}
|
||||||
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."), "")
|
if (NROW(x) > n) {
|
||||||
)
|
message_("\u00a0\u00a0Only the first ", n, " (out of ", NROW(x), ") are shown. Run {.code print(mo_renamed(), n = ...)} to view more entries (might be slow), or save {.fun mo_renamed} to an object.",
|
||||||
|
as_note = FALSE
|
||||||
|
)
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# UNDOCUMENTED HELPER FUNCTIONS -------------------------------------------
|
# UNDOCUMENTED HELPER FUNCTIONS -------------------------------------------
|
||||||
@@ -1255,14 +1256,14 @@ replace_old_mo_codes <- function(x, property) {
|
|||||||
}
|
}
|
||||||
if (property != "mo") {
|
if (property != "mo") {
|
||||||
warning_(
|
warning_(
|
||||||
"in `mo_", property, "()`: the input contained ", n_matched,
|
"in {.help [{.fun mo_", property, "}](AMR::mo_", property, ")}: the input contained ", n_matched,
|
||||||
" old MO code", ifelse(n_matched == 1, "", "s"),
|
" old MO code", ifelse(n_matched == 1, "", "s"),
|
||||||
" (", n_unique, "from a previous AMR package version). ",
|
" (", n_unique, "from a previous AMR package version). ",
|
||||||
"Please update your MO codes with `as.mo()` to increase speed."
|
"Please update your MO codes with {.help [{.fun as.mo}](AMR::as.mo)} to increase speed."
|
||||||
)
|
)
|
||||||
} else {
|
} else {
|
||||||
warning_(
|
warning_(
|
||||||
"in `as.mo()`: the input contained ", n_matched,
|
"in {.help [{.fun as.mo}](AMR::as.mo)}: the input contained ", n_matched,
|
||||||
" old MO code", ifelse(n_matched == 1, "", "s"),
|
" old MO code", ifelse(n_matched == 1, "", "s"),
|
||||||
" (", n_unique, "from a previous AMR package version). ",
|
" (", n_unique, "from a previous AMR package version). ",
|
||||||
n_solved, " old MO code", ifelse(n_solved == 1, "", "s"),
|
n_solved, " old MO code", ifelse(n_solved == 1, "", "s"),
|
||||||
|
|||||||
@@ -270,7 +270,6 @@ mo_shortname <- function(x, language = get_AMR_locale(), keep_synonyms = getOpti
|
|||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#' @rdname mo_property
|
#' @rdname mo_property
|
||||||
#' @export
|
#' @export
|
||||||
mo_subspecies <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", FALSE), ...) {
|
mo_subspecies <- function(x, language = get_AMR_locale(), keep_synonyms = getOption("AMR_keep_synonyms", FALSE), ...) {
|
||||||
@@ -584,7 +583,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 +942,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 +1042,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 {.field ", 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)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -75,7 +75,7 @@
|
|||||||
#'
|
#'
|
||||||
#' ```
|
#' ```
|
||||||
#' as.mo("lab_mo_ecoli")
|
#' as.mo("lab_mo_ecoli")
|
||||||
#' #> Class 'mo'
|
#' #> Class <mo>
|
||||||
#' #> [1] B_ESCHR_COLI
|
#' #> [1] B_ESCHR_COLI
|
||||||
#'
|
#'
|
||||||
#' mo_genus("lab_mo_kpneumoniae")
|
#' mo_genus("lab_mo_kpneumoniae")
|
||||||
@@ -85,7 +85,7 @@
|
|||||||
#' as.mo(c("Escherichia coli", "E. coli", "lab_mo_ecoli"))
|
#' as.mo(c("Escherichia coli", "E. coli", "lab_mo_ecoli"))
|
||||||
#' #> NOTE: Translation to one microorganism was guessed with uncertainty.
|
#' #> NOTE: Translation to one microorganism was guessed with uncertainty.
|
||||||
#' #> Use mo_uncertainties() to review it.
|
#' #> Use mo_uncertainties() to review it.
|
||||||
#' #> Class 'mo'
|
#' #> Class <mo>
|
||||||
#' #> [1] B_ESCHR_COLI B_ESCHR_COLI B_ESCHR_COLI
|
#' #> [1] B_ESCHR_COLI B_ESCHR_COLI B_ESCHR_COLI
|
||||||
#' ```
|
#' ```
|
||||||
#'
|
#'
|
||||||
@@ -108,7 +108,7 @@
|
|||||||
#' #> NOTE: Updated mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
|
#' #> NOTE: Updated mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
|
||||||
#' #> '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
|
#' #> '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
|
||||||
#' #> "Organisation XYZ" and "mo"
|
#' #> "Organisation XYZ" and "mo"
|
||||||
#' #> Class 'mo'
|
#' #> Class <mo>
|
||||||
#' #> [1] B_ESCHR_COLI
|
#' #> [1] B_ESCHR_COLI
|
||||||
#'
|
#'
|
||||||
#' mo_genus("lab_Staph_aureus")
|
#' mo_genus("lab_Staph_aureus")
|
||||||
@@ -249,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 {.help AMR::set_mo_source}() on this file. In any case, the option {.code 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))
|
||||||
@@ -289,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 {.code mo}", call = FALSE)
|
||||||
} else {
|
} else {
|
||||||
return(FALSE)
|
return(FALSE)
|
||||||
}
|
}
|
||||||
@@ -313,14 +313,14 @@ check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_o
|
|||||||
}
|
}
|
||||||
if (colnames(x)[1] != "mo" && nrow(x) > length(unique(x[, 1, drop = TRUE]))) {
|
if (colnames(x)[1] != "mo" && nrow(x) > length(unique(x[, 1, drop = TRUE]))) {
|
||||||
if (stop_on_error == TRUE) {
|
if (stop_on_error == TRUE) {
|
||||||
stop_(refer_to_name, " contains duplicate values in column '", colnames(x)[1], "'", call = FALSE)
|
stop_(refer_to_name, " contains duplicate values in column {.field ", font_bold(colnames(x)[1]), "}", call = FALSE)
|
||||||
} else {
|
} else {
|
||||||
return(FALSE)
|
return(FALSE)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
if (colnames(x)[2] != "mo" && nrow(x) > length(unique(x[, 2, drop = TRUE]))) {
|
if (colnames(x)[2] != "mo" && nrow(x) > length(unique(x[, 2, drop = TRUE]))) {
|
||||||
if (stop_on_error == TRUE) {
|
if (stop_on_error == TRUE) {
|
||||||
stop_(refer_to_name, " contains duplicate values in column '", colnames(x)[2], "'", call = FALSE)
|
stop_(refer_to_name, " contains duplicate values in column {.field ", font_bold(colnames(x)[2]), "}", 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
|
||||||
|
|||||||
51
R/plotting.R
51
R/plotting.R
@@ -258,15 +258,15 @@ 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 ", font_bold(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 {
|
||||||
self$mic_values_rescaled <- rescale_mic(x = as.double(as.mic(df[[aest]])), keep_operators = keep_operators, mic_range = mic_range, as.mic = TRUE)
|
self$mic_values_rescaled <- rescale_mic(x = as.character(df[[aest]]), keep_operators = keep_operators, mic_range = mic_range, as.mic = TRUE)
|
||||||
# create new breaks and labels here
|
# create new breaks and labels here
|
||||||
lims <- range(self$mic_values_rescaled, na.rm = TRUE)
|
lims <- range(self$mic_values_rescaled, na.rm = TRUE)
|
||||||
# support inner and outer 'mic_range' settings (e.g., the data ranges 0.5-8 and 'mic_range' is set to 0.025-32)
|
# support inner and outer 'mic_range' settings (e.g., the data ranges 0.5-8 and 'mic_range' is set to 0.025-32)
|
||||||
@@ -280,11 +280,21 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
|||||||
ind_max <- which(COMMON_MIC_VALUES >= lims[2])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES >= lims[2]] - lims[2]))] # Closest index where COMMON_MIC_VALUES >= lims[2]
|
ind_max <- which(COMMON_MIC_VALUES >= lims[2])[which.min(abs(COMMON_MIC_VALUES[COMMON_MIC_VALUES >= lims[2]] - lims[2]))] # Closest index where COMMON_MIC_VALUES >= lims[2]
|
||||||
|
|
||||||
self$mic_values_levels <- as.mic(COMMON_MIC_VALUES[ind_min:ind_max])
|
self$mic_values_levels <- as.mic(COMMON_MIC_VALUES[ind_min:ind_max])
|
||||||
|
if (length(unique(self$mic_values_levels)) > 1) {
|
||||||
|
if (keep_operators == "all" && !all(self$mic_values_rescaled %in% self$mic_values_levels, na.rm = TRUE)) {
|
||||||
|
self$mic_values_levels <- unique(sort(c(self$mic_values_levels, self$mic_values_rescaled)))
|
||||||
|
|
||||||
if (keep_operators %in% c("edges", "all") && length(unique(self$mic_values_levels)) > 1) {
|
# collision = same log2 position, but different string labels
|
||||||
self$mic_values_levels[1] <- paste0("<=", self$mic_values_levels[1])
|
log_positions <- log2(as.double(self$mic_values_levels))
|
||||||
self$mic_values_levels[length(self$mic_values_levels)] <- paste0(">=", self$mic_values_levels[length(self$mic_values_levels)])
|
dup_positions <- log_positions[duplicated(log_positions) | duplicated(log_positions, fromLast = TRUE)]
|
||||||
|
colliding_labels <- as.character(self$mic_values_levels)[log_positions %in% dup_positions]
|
||||||
|
self$warn_keep_all_operators <- length(unique(colliding_labels)) > 1
|
||||||
|
} else if (keep_operators == "edges") {
|
||||||
|
self$mic_values_levels[1] <- paste0("<=", self$mic_values_levels[1])
|
||||||
|
self$mic_values_levels[length(self$mic_values_levels)] <- paste0(">=", self$mic_values_levels[length(self$mic_values_levels)])
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
self$mic_values_log <- log2(as.double(self$mic_values_rescaled))
|
self$mic_values_log <- log2(as.double(self$mic_values_rescaled))
|
||||||
|
|
||||||
if (aest == "y" && "group" %in% colnames(df)) {
|
if (aest == "y" && "group" %in% colnames(df)) {
|
||||||
@@ -312,7 +322,26 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
|||||||
}
|
}
|
||||||
scale$labels <- function(..., self) {
|
scale$labels <- function(..., self) {
|
||||||
if (is.null(self$mic_breaks_set)) {
|
if (is.null(self$mic_breaks_set)) {
|
||||||
self$mic_values_levels
|
if (isTRUE(self$warn_keep_all_operators)) {
|
||||||
|
lookup <- tapply(
|
||||||
|
as.character(self$mic_values_rescaled),
|
||||||
|
self$mic_values_log,
|
||||||
|
function(x) paste(unique(x), collapse = ", ")
|
||||||
|
)
|
||||||
|
level_log <- as.character(log2(as.double(self$mic_values_levels)))
|
||||||
|
|
||||||
|
if (any(grepl(", ", lookup))) {
|
||||||
|
warning_("Using {.arg keep_operators = \"all\"} caused MIC values with different operators to share the same log2 position on the axis. These have been combined into a single label (e.g., {.val ", lookup[grepl(", ", lookup)][1], "}).", call = FALSE)
|
||||||
|
}
|
||||||
|
|
||||||
|
ifelse(
|
||||||
|
level_log %in% names(lookup),
|
||||||
|
lookup[level_log],
|
||||||
|
as.character(self$mic_values_levels)
|
||||||
|
)
|
||||||
|
} else {
|
||||||
|
self$mic_values_levels
|
||||||
|
}
|
||||||
} else {
|
} else {
|
||||||
breaks <- tryCatch(scale$breaks(), error = function(e) NULL)
|
breaks <- tryCatch(scale$breaks(), error = function(e) NULL)
|
||||||
if (!is.null(breaks)) {
|
if (!is.null(breaks)) {
|
||||||
@@ -412,7 +441,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 {.help AMR::as.sir}().",
|
"Apply `scale_", aesthetics[1], "_sir()` to a variable of class {.cls sir}, see {.help [{.fun as.sir}](AMR::as.sir)}.",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
x <- as.character(x)
|
x <- as.character(x)
|
||||||
@@ -1443,10 +1472,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(...))) {
|
||||||
@@ -1590,7 +1619,7 @@ expand_SIR_colours <- function(colours_SIR, unname = TRUE) {
|
|||||||
# named input: match and reorder
|
# named input: match and reorder
|
||||||
stop_ifnot(
|
stop_ifnot(
|
||||||
all(names(colours_SIR) %in% sir_order),
|
all(names(colours_SIR) %in% sir_order),
|
||||||
"Unknown names in `colours_SIR`. Expected any of: ", vector_or(levels(NA_sir_), quotes = FALSE, sort = FALSE), "."
|
"Unknown names in {.arg colours_SIR}. Expected any of: ", vector_or(levels(NA_sir_), quotes = FALSE, sort = FALSE), "."
|
||||||
)
|
)
|
||||||
if (length(colours_SIR) == 4) {
|
if (length(colours_SIR) == 4) {
|
||||||
# add colours for SI (same as S) and IR (same as R)
|
# add colours for SI (same as S) and IR (same as R)
|
||||||
|
|||||||
@@ -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(
|
||||||
@@ -346,7 +346,7 @@ sir_confidence_interval <- function(...,
|
|||||||
if (n < minimum) {
|
if (n < minimum) {
|
||||||
warning_("Introducing NA: ",
|
warning_("Introducing NA: ",
|
||||||
ifelse(n == 0, "no", paste("only", n)),
|
ifelse(n == 0, "no", paste("only", n)),
|
||||||
" results available for `sir_confidence_interval()` (`minimum` = ", minimum, ").",
|
" results available for {.help [{.fun sir_confidence_interval}](AMR::sir_confidence_interval)} (whilst {.arg minimum = ", minimum, "}).",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
if (is.character(out)) {
|
if (is.character(out)) {
|
||||||
|
|||||||
@@ -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,11 +146,11 @@ 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),
|
||||||
"column '", col_date, "' not found"
|
"column {.code ", col_date, "} not found"
|
||||||
)
|
)
|
||||||
|
|
||||||
year <- function(x) {
|
year <- function(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 {.help AMR::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"
|
||||||
|
|||||||
131
R/sir.R
131
R/sir.R
@@ -471,7 +471,7 @@ is_sir_eligible <- function(x, threshold = 0.05) {
|
|||||||
if (!is.na(ab)) {
|
if (!is.na(ab)) {
|
||||||
# this is a valid antibiotic drug code
|
# this is a valid antibiotic drug code
|
||||||
message_(
|
message_(
|
||||||
"Column '", font_bold(cur_col), "' is SIR eligible (despite only having empty values), since it seems to be ",
|
"Column {.field ", font_bold(cur_col), "} is SIR eligible (despite only having empty values), since it seems to be ",
|
||||||
ab_name(ab, language = NULL, tolower = TRUE), " (", ab, ")"
|
ab_name(ab, language = NULL, tolower = TRUE), " (", ab, ")"
|
||||||
)
|
)
|
||||||
return(TRUE)
|
return(TRUE)
|
||||||
@@ -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 {.help AMR::as.sir}(): input values were guessed to be MIC values - preferably transform them with {.help AMR::as.mic}() before running {.help AMR::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 {.help AMR::as.sir}(): input values were guessed to be disk diffusion values - preferably transform them with {.help AMR::as.disk}() before running {.help AMR::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 {.help AMR::as.sir}(): Interpreting input value ", vector_and(out[!is.na(out)], quotes = FALSE, sort = FALSE))
|
message_("{.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,9 +610,9 @@ 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 {.help AMR::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 {.field ", font_bold(cur_col, collapse = NULL), "}")),
|
||||||
" truncated (",
|
" truncated (",
|
||||||
round(((na_after - na_before) / length(x)) * 100),
|
round(((na_after - na_before) / length(x)) * 100),
|
||||||
"%) that were invalid antimicrobial interpretations: ",
|
"%) that were invalid antimicrobial interpretations: ",
|
||||||
@@ -759,6 +759,10 @@ as.sir.data.frame <- function(x,
|
|||||||
meet_criteria(max_cores, allow_class = c("numeric", "integer"), has_length = 1)
|
meet_criteria(max_cores, allow_class = c("numeric", "integer"), has_length = 1)
|
||||||
x.bak <- x
|
x.bak <- x
|
||||||
|
|
||||||
|
if (isTRUE(info) && message_not_thrown_before("as.sir", "sir_interpretation_history")) {
|
||||||
|
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")
|
||||||
|
}
|
||||||
|
|
||||||
if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) {
|
if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) {
|
||||||
sel <- colnames(pm_select(x, ...))
|
sel <- colnames(pm_select(x, ...))
|
||||||
} else {
|
} else {
|
||||||
@@ -816,7 +820,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 +839,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 ", font_bold(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."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -858,7 +861,7 @@ as.sir.data.frame <- function(x,
|
|||||||
return(FALSE)
|
return(FALSE)
|
||||||
}
|
}
|
||||||
if (length(sel) == 0 || (length(sel) > 0 && ab %in% sel)) {
|
if (length(sel) == 0 || (length(sel) > 0 && ab %in% sel)) {
|
||||||
ab_coerced <- suppressWarnings(as.ab(ab, info = info))
|
ab_coerced <- suppressWarnings(as.ab(ab, info = FALSE))
|
||||||
if (is.na(ab_coerced) || (length(sel) > 0 & !ab %in% sel)) {
|
if (is.na(ab_coerced) || (length(sel) > 0 & !ab %in% sel)) {
|
||||||
# not even a valid AB code
|
# not even a valid AB code
|
||||||
return(FALSE)
|
return(FALSE)
|
||||||
@@ -908,6 +911,11 @@ as.sir.data.frame <- function(x,
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
if (isTRUE(info)) {
|
||||||
|
message_(as_note = FALSE) # empty line
|
||||||
|
message_("Processing columns:", as_note = FALSE)
|
||||||
|
}
|
||||||
|
|
||||||
run_as_sir_column <- function(i) {
|
run_as_sir_column <- function(i) {
|
||||||
ab_col <- ab_cols[i]
|
ab_col <- ab_cols[i]
|
||||||
out <- list(result = NULL, log = NULL)
|
out <- list(result = NULL, log = NULL)
|
||||||
@@ -970,12 +978,12 @@ as.sir.data.frame <- function(x,
|
|||||||
return(out)
|
return(out)
|
||||||
} else if (types[i] == "sir") {
|
} else if (types[i] == "sir") {
|
||||||
ab <- ab_col
|
ab <- ab_col
|
||||||
ab_coerced <- suppressWarnings(as.ab(ab, info = info))
|
ab_coerced <- suppressWarnings(as.ab(ab, info = FALSE))
|
||||||
show_message <- FALSE
|
show_message <- FALSE
|
||||||
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_("\u00a0\u00a0", AMR_env$bullet_icon, " Cleaning values in column ", paste0("{.field ", font_bold(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 +993,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_("\u00a0\u00a0", AMR_env$bullet_icon, " Assigning class {.cls sir} to already clean column ", paste0("{.field ", font_bold(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,
|
||||||
@@ -995,7 +1003,7 @@ as.sir.data.frame <- function(x,
|
|||||||
}
|
}
|
||||||
result <- as.sir.default(x = as.character(x[, ab, drop = TRUE]))
|
result <- as.sir.default(x = as.character(x[, ab, drop = TRUE]))
|
||||||
if (show_message == TRUE && isTRUE(info)) {
|
if (show_message == TRUE && isTRUE(info)) {
|
||||||
message(font_green_bg(" OK "))
|
message_(font_green_bg("\u00a0OK\u00a0"), as_note = FALSE)
|
||||||
}
|
}
|
||||||
out$result <- result
|
out$result <- result
|
||||||
out$log <- NULL
|
out$log <- NULL
|
||||||
@@ -1007,7 +1015,7 @@ as.sir.data.frame <- function(x,
|
|||||||
|
|
||||||
if (isTRUE(parallel) && n_cores > 1 && length(ab_cols) > 1) {
|
if (isTRUE(parallel) && n_cores > 1 && length(ab_cols) > 1) {
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
message()
|
message_(as_note = FALSE)
|
||||||
message_("Running in parallel mode using ", n_cores, " out of ", get_n_cores(Inf), " cores, on columns ", vector_and(font_bold(ab_cols, collapse = NULL), quotes = "'", sort = FALSE), "...", as_note = FALSE, appendLF = FALSE)
|
message_("Running in parallel mode using ", n_cores, " out of ", get_n_cores(Inf), " cores, on columns ", vector_and(font_bold(ab_cols, collapse = NULL), quotes = "'", sort = FALSE), "...", as_note = FALSE, appendLF = FALSE)
|
||||||
}
|
}
|
||||||
if (.Platform$OS.type == "windows" || getRversion() < "4.0.0") {
|
if (.Platform$OS.type == "windows" || getRversion() < "4.0.0") {
|
||||||
@@ -1027,15 +1035,15 @@ as.sir.data.frame <- function(x,
|
|||||||
result_list <- parallel::mclapply(seq_along(ab_cols), run_as_sir_column, mc.cores = n_cores)
|
result_list <- parallel::mclapply(seq_along(ab_cols), run_as_sir_column, mc.cores = n_cores)
|
||||||
}
|
}
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
message_(font_green_bg(" DONE "), as_note = FALSE)
|
message_(font_green_bg("\u00aDONE\u00a"), as_note = FALSE)
|
||||||
message()
|
message_(as_note = FALSE)
|
||||||
message_("Run {.help AMR::sir_interpretation_history}() to retrieve a logbook with all details of the breakpoint interpretations.")
|
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_(as_note = FALSE)
|
||||||
message_("Running in sequential mode. Consider setting {.arg parallel} to {.code TRUE} to speed up processing on multiple cores.\n")
|
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
|
||||||
@@ -1168,13 +1176,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 {.help AMR::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 {.help AMR::sir_interpretation_history}() afterwards to retrieve a logbook with all details of the breakpoint interpretations.\n\n")
|
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)
|
||||||
@@ -1222,7 +1230,7 @@ as_sir_method <- function(method_short,
|
|||||||
host <- convert_host(host, lang = language)
|
host <- convert_host(host, lang = language)
|
||||||
if (any(is.na(host) & !is.na(host.bak)) && isTRUE(info) && message_not_thrown_before("as.sir", "missing_hosts")) {
|
if (any(is.na(host) & !is.na(host.bak)) && isTRUE(info) && message_not_thrown_before("as.sir", "missing_hosts")) {
|
||||||
warning_("The following animal host(s) could not be coerced: ", vector_and(host.bak[is.na(host) & !is.na(host.bak)]), immediate = TRUE)
|
warning_("The following animal host(s) could not be coerced: ", vector_and(host.bak[is.na(host) & !is.na(host.bak)]), immediate = TRUE)
|
||||||
message() # new line
|
message_(as_note = FALSE) # new line
|
||||||
}
|
}
|
||||||
# TODO add a switch to turn this off? In interactive sessions perhaps ask the user. Default should be On.
|
# TODO add a switch to turn this off? In interactive sessions perhaps ask the user. Default should be On.
|
||||||
# if (breakpoint_type == "animal" && isTRUE(info) && message_not_thrown_before("as.sir", "host_missing_breakpoints")) {
|
# if (breakpoint_type == "animal" && isTRUE(info) && message_not_thrown_before("as.sir", "host_missing_breakpoints")) {
|
||||||
@@ -1247,7 +1255,7 @@ as_sir_method <- function(method_short,
|
|||||||
|
|
||||||
# get mo
|
# get mo
|
||||||
if (!is.null(current_df) && length(mo) == 1 && mo %in% colnames(current_df)) {
|
if (!is.null(current_df) && length(mo) == 1 && mo %in% colnames(current_df)) {
|
||||||
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
|
mo_var_found <- paste0(" based on column {.field ", font_bold(mo), "}")
|
||||||
mo <- current_df[[mo]]
|
mo <- current_df[[mo]]
|
||||||
} else if (length(mo) != length(x)) {
|
} else if (length(mo) != length(x)) {
|
||||||
mo_var_found <- ""
|
mo_var_found <- ""
|
||||||
@@ -1263,7 +1271,7 @@ as_sir_method <- function(method_short,
|
|||||||
silent = TRUE
|
silent = TRUE
|
||||||
)
|
)
|
||||||
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
|
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
|
||||||
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
|
mo_var_found <- paste0(" based on column {.field ", font_bold(mo), "}")
|
||||||
mo <- df[, mo, drop = TRUE]
|
mo <- df[, mo, drop = TRUE]
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
@@ -1276,9 +1284,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 {.arg mo} and no column of class 'mo' found). See {.help AMR::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,11 +1320,11 @@ 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 {.arg ab}). See {.help AMR::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)
|
||||||
ab <- suppressWarnings(as.ab(ab, info = info))
|
ab <- suppressWarnings(as.ab(ab, info = FALSE))
|
||||||
if (!is.null(list(...)$mo.bak)) {
|
if (!is.null(list(...)$mo.bak)) {
|
||||||
mo.bak <- list(...)$mo.bak
|
mo.bak <- list(...)$mo.bak
|
||||||
} else {
|
} else {
|
||||||
@@ -1328,7 +1336,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 {.help AMR::as.ab}().",
|
". Rename this column to a valid name or code, and check the output with {.help [{.fun as.ab}](AMR::as.ab)}.",
|
||||||
as_note = FALSE
|
as_note = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -1352,12 +1360,12 @@ 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 {.help 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.")
|
message_("{.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.")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
# format agents ----
|
# format agents ----
|
||||||
agent_formatted <- paste0("'", font_bold(ab.bak, collapse = NULL), "'")
|
agent_formatted <- paste0("{.field ", font_bold(ab.bak, collapse = NULL), "}")
|
||||||
agent_name <- ab_name(ab, tolower = TRUE, language = NULL, info = info)
|
agent_name <- ab_name(ab, tolower = TRUE, language = NULL, info = info)
|
||||||
same_ab <- generalise_antibiotic_name(ab) == generalise_antibiotic_name(agent_name)
|
same_ab <- generalise_antibiotic_name(ab) == generalise_antibiotic_name(agent_name)
|
||||||
same_ab.bak <- generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)
|
same_ab.bak <- generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)
|
||||||
@@ -1373,7 +1381,7 @@ as_sir_method <- function(method_short,
|
|||||||
)
|
)
|
||||||
# this intro text will also be printed in the progress bar if the `progress` package is installed
|
# this intro text will also be printed in the progress bar if the `progress` package is installed
|
||||||
intro_txt <- paste0(
|
intro_txt <- paste0(
|
||||||
"Interpreting ", method_long, ": ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
|
"\u00a0\u00a0", AMR_env$bullet_icon, " Interpreting ", method_long, ": ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
|
||||||
ifelse(length(unique(agent_formatted)) == 1, unique(agent_formatted), paste0(vector_and(agent_formatted, quotes = FALSE, sort = FALSE))),
|
ifelse(length(unique(agent_formatted)) == 1, unique(agent_formatted), paste0(vector_and(agent_formatted, quotes = FALSE, sort = FALSE))),
|
||||||
mo_var_found,
|
mo_var_found,
|
||||||
ifelse(identical(reference_data, AMR::clinical_breakpoints),
|
ifelse(identical(reference_data, AMR::clinical_breakpoints),
|
||||||
@@ -1391,7 +1399,7 @@ as_sir_method <- function(method_short,
|
|||||||
rise_warning <- FALSE
|
rise_warning <- FALSE
|
||||||
rise_notes <- FALSE
|
rise_notes <- FALSE
|
||||||
method_coerced <- toupper(method)
|
method_coerced <- toupper(method)
|
||||||
ab_coerced <- as.ab(ab, info = info)
|
ab_coerced <- as.ab(ab, info = FALSE)
|
||||||
|
|
||||||
if (identical(reference_data, AMR::clinical_breakpoints)) {
|
if (identical(reference_data, AMR::clinical_breakpoints)) {
|
||||||
breakpoints <- reference_data %pm>%
|
breakpoints <- reference_data %pm>%
|
||||||
@@ -1488,14 +1496,14 @@ as_sir_method <- function(method_short,
|
|||||||
# only print intro under 10 items, otherwise progressbar will print this and then it will be printed double
|
# only print intro under 10 items, otherwise progressbar will print this and then it will be printed double
|
||||||
message_(intro_txt, appendLF = FALSE, as_note = FALSE)
|
message_(intro_txt, appendLF = FALSE, as_note = FALSE)
|
||||||
}
|
}
|
||||||
p <- progress_ticker(n = nrow(df_unique), n_min = 10, title = font_blue(intro_txt), only_bar_percent = TRUE)
|
p <- progress_ticker(n = nrow(df_unique), n_min = 10, title = intro_txt, only_bar_percent = TRUE)
|
||||||
has_progress_bar <- !is.null(import_fn("progress_bar", "progress", error_on_fail = FALSE)) && nrow(df_unique) >= 10
|
has_progress_bar <- !is.null(import_fn("progress_bar", "progress", error_on_fail = FALSE)) && nrow(df_unique) >= 10
|
||||||
on.exit(close(p))
|
on.exit(close(p))
|
||||||
|
|
||||||
if (nrow(breakpoints) == 0) {
|
if (nrow(breakpoints) == 0) {
|
||||||
# apparently no breakpoints found
|
# apparently no breakpoints found
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
message(font_grey_bg(font_black(" NO BREAKPOINTS ")))
|
message_(font_grey_bg(font_black(" NO BREAKPOINTS ")), as_note = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
load_mo_uncertainties(metadata_mo)
|
load_mo_uncertainties(metadata_mo)
|
||||||
@@ -1721,7 +1729,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 {.help AMR::as.sir}().")
|
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`.")
|
||||||
)
|
)
|
||||||
} 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
|
||||||
@@ -1911,7 +1919,7 @@ as_sir_method <- function(method_short,
|
|||||||
host = vectorise_log_entry(breakpoints_current[, "host", drop = TRUE], length(rows)),
|
host = vectorise_log_entry(breakpoints_current[, "host", drop = TRUE], length(rows)),
|
||||||
input = vectorise_log_entry(as.character(input_clean), length(rows)),
|
input = vectorise_log_entry(as.character(input_clean), length(rows)),
|
||||||
outcome = vectorise_log_entry(as.sir(new_sir), length(rows)),
|
outcome = vectorise_log_entry(as.sir(new_sir), length(rows)),
|
||||||
notes = font_stripstyle(notes_current), # vectorise_log_entry(paste0(font_stripstyle(notes_current), collapse = "\n"), length(rows)),
|
notes = font_stripstyle(notes_current),
|
||||||
guideline = vectorise_log_entry(guideline_current, length(rows)),
|
guideline = vectorise_log_entry(guideline_current, length(rows)),
|
||||||
ref_table = vectorise_log_entry(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)),
|
ref_table = vectorise_log_entry(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)),
|
||||||
uti = vectorise_log_entry(breakpoints_current[, "uti", drop = TRUE], length(rows)),
|
uti = vectorise_log_entry(breakpoints_current[, "uti", drop = TRUE], length(rows)),
|
||||||
@@ -1936,21 +1944,21 @@ as_sir_method <- function(method_short,
|
|||||||
notes <- notes[!trimws2(notes) %in% c("", NA_character_)]
|
notes <- notes[!trimws2(notes) %in% c("", NA_character_)]
|
||||||
if (length(notes) > 0) {
|
if (length(notes) > 0) {
|
||||||
if (isTRUE(rise_warning)) {
|
if (isTRUE(rise_warning)) {
|
||||||
message(font_rose_bg(" WARNING "))
|
message_(font_rose_bg("\u00a0WARNING\u00a0"), as_note = FALSE)
|
||||||
} else {
|
} else {
|
||||||
message(font_yellow_bg(" NOTE "))
|
message_(font_yellow_bg("\u00a0NOTE\u00a0"), as_note = FALSE)
|
||||||
}
|
}
|
||||||
notes <- unique(notes)
|
notes <- unique(notes)
|
||||||
# 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]))
|
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("\u00a0\u00a0", AMR_env$bullet_icon, " There were multiple notes. Print or View `sir_interpretation_history()` to examine them, or use `as.sir(..., verbose = TRUE)` next time to directly print them here.", add_fn = font_black))
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
message(font_green_bg(" OK "))
|
message_(font_green_bg("\u00a0OK\u00a0"), as_note = FALSE)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1988,7 +1996,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 {.help AMR::as.sir}() on MIC values or disk diffusion zones (or on a {.cls data.frame} containing any of these) to print a 'logbook' data set here.")
|
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"]
|
||||||
@@ -2002,15 +2010,19 @@ pillar_shaft.sir <- function(x, ...) {
|
|||||||
if (has_colour()) {
|
if (has_colour()) {
|
||||||
# colours will anyway not work when has_colour() == FALSE,
|
# colours will anyway not work when has_colour() == FALSE,
|
||||||
# but then the indentation should also not be applied
|
# but then the indentation should also not be applied
|
||||||
out[is.na(x)] <- font_grey(" NA")
|
out[is.na(x)] <- pillar::style_subtle(" NA")
|
||||||
out[x == "S"] <- font_green_bg(" S ")
|
out[x == "S"] <- font_green_bg(" S ") # has font_black internally
|
||||||
out[x == "SDD"] <- font_green_lighter_bg(" SDD ")
|
out[x == "SDD"] <- font_green_lighter_bg(" SDD ") # has font_black internally
|
||||||
out[x == "I"] <- font_orange_bg(" I ")
|
if (getOption("AMR_guideline", "EUCAST")[1] == "EUCAST") {
|
||||||
out[x == "R"] <- font_rose_bg(" R ")
|
out[x == "I"] <- font_green_lighter_bg(" I ") # has font_black internally
|
||||||
out[x == "NI"] <- font_grey_bg(font_black(" NI "))
|
} else {
|
||||||
out[x == "WT"] <- font_green_bg(font_black(" WT "))
|
out[x == "I"] <- font_orange_bg(" I ") # has font_black internally
|
||||||
out[x == "NWT"] <- font_rose_bg(font_black(" NWT "))
|
}
|
||||||
out[x == "NS"] <- font_rose_bg(font_black(" NS "))
|
out[x == "R"] <- font_rose_bg(" R ") # has font_black internally
|
||||||
|
out[x == "NI"] <- font_grey_bg(font_black(" NI ", adapt = FALSE))
|
||||||
|
out[x == "WT"] <- font_green_bg(" WT ") # has font_black internally
|
||||||
|
out[x == "NWT"] <- font_rose_bg(" NWT ") # has font_black internally
|
||||||
|
out[x == "NS"] <- font_rose_bg(" NS ") # has font_black internally
|
||||||
}
|
}
|
||||||
create_pillar_column(out, align = "left", width = 5)
|
create_pillar_column(out, align = "left", width = 5)
|
||||||
}
|
}
|
||||||
@@ -2068,10 +2080,10 @@ freq.sir <- function(x, ...) {
|
|||||||
# this prevents the requirement for putting the dependency in Imports:
|
# this prevents the requirement for putting the dependency in Imports:
|
||||||
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(skimr::get_skimmers, sir)
|
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(skimr::get_skimmers, sir)
|
||||||
get_skimmers.sir <- function(column) {
|
get_skimmers.sir <- function(column) {
|
||||||
# TODO add here in AMR 3.1.0 details about guideline
|
# TODO #170 add here in AMR 3.1.0 details about guideline
|
||||||
skimr::sfl(
|
skimr::sfl(
|
||||||
skim_type = "sir",
|
skim_type = "sir",
|
||||||
# guideline = function(x) "EUCAST 2025", # or "Multiple"
|
# guideline = function(x) "EUCAST 2026", # or "Multiple"
|
||||||
# origin = function(x) "MIC", # or "Multiple"
|
# origin = function(x) "MIC", # or "Multiple"
|
||||||
count_S = count_S,
|
count_S = count_S,
|
||||||
count_I = count_I,
|
count_I = count_I,
|
||||||
@@ -2088,7 +2100,7 @@ get_skimmers.sir <- function(column) {
|
|||||||
#' @noRd
|
#' @noRd
|
||||||
print.sir <- function(x, ...) {
|
print.sir <- function(x, ...) {
|
||||||
x_name <- deparse(substitute(x))
|
x_name <- deparse(substitute(x))
|
||||||
cat("Class 'sir'\n")
|
cat(format_inline_("Class {.cls sir}\n"))
|
||||||
# TODO for #170
|
# TODO for #170
|
||||||
# if (!is.null(attributes(x)$guideline) && !all(is.na(attributes(x)$guideline))) {
|
# if (!is.null(attributes(x)$guideline) && !all(is.na(attributes(x)$guideline))) {
|
||||||
# cat(font_blue(word_wrap("These values were interpreted using ",
|
# cat(font_blue(word_wrap("These values were interpreted using ",
|
||||||
@@ -2227,10 +2239,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_("{.arg 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 {.help [clinical_breakpoints](AMR::clinical_breakpoints)} data set.", call = .call_depth)
|
||||||
}
|
}
|
||||||
if (!all(class_sir == class_ref)) {
|
if (!all(class_sir == class_ref)) {
|
||||||
stop_("{.arg reference_data} must be the same structure as the 'clinical_breakpoints' data set. Column '", names(class_ref[class_sir != class_ref][1]), "' is of class ", class_ref[class_sir != class_ref][1], ", but should be of class ", class_sir[class_sir != class_ref][1], ".", call = .call_depth)
|
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 {.help [clinical_breakpoints](AMR::clinical_breakpoints)} data set. Column ", paste0("{.field ", font_bold(bad_col, collapse = NULL), "}"), " is of class ", paste0("{.cls ", bad_cls, "}"), ", but should be of class ", paste0("{.cls ", exp_cls, "}"), call = .call_depth)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
17
R/sir_calc.R
17
R/sir_calc.R
@@ -60,11 +60,6 @@ sir_calc <- function(...,
|
|||||||
dots <- eval(substitute(alist(...)))
|
dots <- eval(substitute(alist(...)))
|
||||||
stop_if(length(dots) == 0, "no variables selected", call = -2)
|
stop_if(length(dots) == 0, "no variables selected", call = -2)
|
||||||
|
|
||||||
stop_if("also_single_tested" %in% names(dots),
|
|
||||||
"`also_single_tested` was replaced by `only_all_tested`.\n",
|
|
||||||
"Please read Details in the help page (`?proportion`) as this may have a considerable impact on your analysis.",
|
|
||||||
call = -2
|
|
||||||
)
|
|
||||||
ndots <- length(dots)
|
ndots <- length(dots)
|
||||||
|
|
||||||
if (is.data.frame(dots_df)) {
|
if (is.data.frame(dots_df)) {
|
||||||
@@ -144,7 +139,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 +147,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 +159,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 +167,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
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -209,7 +204,7 @@ sir_calc <- function(...,
|
|||||||
ifelse(denominator == 0, "no", paste("only", denominator)),
|
ifelse(denominator == 0, "no", paste("only", denominator)),
|
||||||
" results available",
|
" results available",
|
||||||
data_vars,
|
data_vars,
|
||||||
" (`minimum` = ", minimum, ").",
|
" (whilst {.arg minimum = ", minimum, "}).",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
fraction <- NA_real_
|
fraction <- NA_real_
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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),
|
||||||
|
|||||||
20
R/zzz.R
20
R/zzz.R
@@ -116,42 +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."
|
))
|
||||||
)
|
|
||||||
)
|
|
||||||
}
|
}
|
||||||
|
|
||||||
# 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)))
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -15,7 +15,7 @@ Overview:
|
|||||||
even WISCA
|
even WISCA
|
||||||
- Provides the **full microbiological taxonomy** of ~79 000 distinct
|
- Provides the **full microbiological taxonomy** of ~79 000 distinct
|
||||||
species and extensive info of ~620 antimicrobial drugs
|
species and extensive info of ~620 antimicrobial drugs
|
||||||
- Applies **CLSI 2011-2025** and **EUCAST 2011-2025** clinical and
|
- Applies **CLSI 2011-2026** and **EUCAST 2011-2026** clinical and
|
||||||
veterinary breakpoints, and ECOFFs, for MIC and disk zone
|
veterinary breakpoints, and ECOFFs, for MIC and disk zone
|
||||||
interpretation
|
interpretation
|
||||||
- Corrects for duplicate isolates, **calculates** and **predicts** AMR
|
- Corrects for duplicate isolates, **calculates** and **predicts** AMR
|
||||||
|
|||||||
@@ -37,6 +37,11 @@ devtools::load_all()
|
|||||||
|
|
||||||
# BE SURE TO RUN data-raw/_reproduction_scripts/reproduction_of_microorganisms.groups.R FIRST TO GET THE GROUPS!
|
# BE SURE TO RUN data-raw/_reproduction_scripts/reproduction_of_microorganisms.groups.R FIRST TO GET THE GROUPS!
|
||||||
|
|
||||||
|
# For non-interactive use
|
||||||
|
if (!interactive()) {
|
||||||
|
View <- glimpse
|
||||||
|
}
|
||||||
|
|
||||||
# READ DATA ----
|
# READ DATA ----
|
||||||
|
|
||||||
# files are retrieved from https://github.com/AClark-WHONET/AMRIE
|
# files are retrieved from https://github.com/AClark-WHONET/AMRIE
|
||||||
@@ -46,21 +51,21 @@ file_organisms <- file.path(github_repo, "Organisms.txt")
|
|||||||
file_breakpoints <- file.path(github_repo, "Breakpoints.txt")
|
file_breakpoints <- file.path(github_repo, "Breakpoints.txt")
|
||||||
file_antibiotics <- file.path(github_repo, "Antibiotics.txt")
|
file_antibiotics <- file.path(github_repo, "Antibiotics.txt")
|
||||||
|
|
||||||
whonet_organisms <- read_tsv(file_organisms, na = c("", "NA", "-"), show_col_types = FALSE, guess_max = Inf) |>
|
whonet_organisms_raw <- read_tsv(file_organisms, na = c("", "NA", "-"), show_col_types = FALSE, guess_max = Inf) |>
|
||||||
# remove old taxonomic names
|
# remove old taxonomic names
|
||||||
filter(TAXONOMIC_STATUS == "C") |>
|
filter(TAXONOMIC_STATUS == "C") |>
|
||||||
mutate(ORGANISM_CODE = toupper(WHONET_ORG_CODE))
|
mutate(ORGANISM_CODE = toupper(WHONET_ORG_CODE))
|
||||||
|
|
||||||
whonet_breakpoints <- read_tsv(file_breakpoints, na = c("", "NA", "-"), show_col_types = FALSE, guess_max = Inf) |>
|
whonet_breakpoints_raw <- read_tsv(file_breakpoints, na = c("", "NA", "-"), show_col_types = FALSE, guess_max = Inf) |>
|
||||||
filter(GUIDELINES %in% c("CLSI", "EUCAST"))
|
filter(GUIDELINES %in% c("CLSI", "EUCAST"))
|
||||||
|
|
||||||
whonet_antibiotics <- read_tsv(file_antibiotics, na = c("", "NA", "-"), show_col_types = FALSE, guess_max = Inf) |>
|
whonet_antibiotics_raw <- read_tsv(file_antibiotics, na = c("", "NA", "-"), show_col_types = FALSE, guess_max = Inf) |>
|
||||||
arrange(WHONET_ABX_CODE) |>
|
arrange(WHONET_ABX_CODE) |>
|
||||||
distinct(WHONET_ABX_CODE, .keep_all = TRUE)
|
distinct(WHONET_ABX_CODE, .keep_all = TRUE)
|
||||||
|
|
||||||
# MICROORGANISMS WHONET CODES ----
|
# MICROORGANISMS WHONET CODES ----
|
||||||
|
|
||||||
whonet_organisms <- whonet_organisms |>
|
whonet_organisms <- whonet_organisms_raw |>
|
||||||
select(ORGANISM_CODE, ORGANISM, SPECIES_GROUP, GBIF_TAXON_ID) |>
|
select(ORGANISM_CODE, ORGANISM, SPECIES_GROUP, GBIF_TAXON_ID) |>
|
||||||
mutate(
|
mutate(
|
||||||
# this one was called Issatchenkia orientalis, but it should be:
|
# this one was called Issatchenkia orientalis, but it should be:
|
||||||
@@ -110,6 +115,13 @@ organisms <- matched |> transmute(code = toupper(ORGANISM_CODE), group = SPECIES
|
|||||||
mutate(name = mo_name(mo, keep_synonyms = TRUE)) |>
|
mutate(name = mo_name(mo, keep_synonyms = TRUE)) |>
|
||||||
arrange(code)
|
arrange(code)
|
||||||
|
|
||||||
|
# self-defined codes in the MO table must be retained
|
||||||
|
existing_codes <- microorganisms$fullname[microorganisms$fullname %like% ".* \\("]
|
||||||
|
existing_codes <- gsub(".*\\((.*)\\)", "\\1", existing_codes)
|
||||||
|
|
||||||
|
organisms <- organisms |>
|
||||||
|
filter(!code %in% existing_codes)
|
||||||
|
|
||||||
# some subspecies exist, while their upper species do not, add them as the species level:
|
# some subspecies exist, while their upper species do not, add them as the species level:
|
||||||
subspp <- organisms |>
|
subspp <- organisms |>
|
||||||
filter(mo_species(mo, keep_synonyms = TRUE) == mo_subspecies(mo, keep_synonyms = TRUE) &
|
filter(mo_species(mo, keep_synonyms = TRUE) == mo_subspecies(mo, keep_synonyms = TRUE) &
|
||||||
@@ -139,9 +151,10 @@ organisms <- organisms |> filter(code != "XXX")
|
|||||||
# 2023-07-08 SGM is also Strep gamma in WHONET, must only be Slowly-growing Mycobacterium
|
# 2023-07-08 SGM is also Strep gamma in WHONET, must only be Slowly-growing Mycobacterium
|
||||||
# 2024-06-14 still the case
|
# 2024-06-14 still the case
|
||||||
# 2025-04-20 still the case
|
# 2025-04-20 still the case
|
||||||
|
# 2026-03-27 still the case, but fixed using `existing_codes` above
|
||||||
organisms |> filter(code == "SGM")
|
organisms |> filter(code == "SGM")
|
||||||
organisms <- organisms |>
|
# organisms <- organisms |>
|
||||||
filter(!(code == "SGM" & name %like% "Streptococcus"))
|
# filter(!(code == "SGM" & name %like% "Streptococcus"))
|
||||||
# this must be empty:
|
# this must be empty:
|
||||||
organisms$code[organisms$code |> duplicated()]
|
organisms$code[organisms$code |> duplicated()]
|
||||||
|
|
||||||
@@ -162,7 +175,7 @@ microorganisms.codes2 <- microorganisms.codes |>
|
|||||||
# new codes:
|
# new codes:
|
||||||
microorganisms.codes2$code[which(!microorganisms.codes2$code %in% microorganisms.codes$code)]
|
microorganisms.codes2$code[which(!microorganisms.codes2$code %in% microorganisms.codes$code)]
|
||||||
mo_name(microorganisms.codes2$mo[which(!microorganisms.codes2$code %in% microorganisms.codes$code)], keep_synonyms = TRUE)
|
mo_name(microorganisms.codes2$mo[which(!microorganisms.codes2$code %in% microorganisms.codes$code)], keep_synonyms = TRUE)
|
||||||
microorganisms.codes <- microorganisms.codes2
|
microorganisms.codes <- microorganisms.codes2 |> distinct()
|
||||||
|
|
||||||
# Run this part to update ASIARS-Net:
|
# Run this part to update ASIARS-Net:
|
||||||
# 2024-06-14: file not available anymore
|
# 2024-06-14: file not available anymore
|
||||||
@@ -201,10 +214,15 @@ devtools::load_all()
|
|||||||
|
|
||||||
# now that we have the correct MO codes, get the breakpoints and convert them
|
# now that we have the correct MO codes, get the breakpoints and convert them
|
||||||
|
|
||||||
whonet_breakpoints |>
|
whonet_breakpoints_raw |>
|
||||||
count(GUIDELINES, BREAKPOINT_TYPE) |>
|
count(GUIDELINES, BREAKPOINT_TYPE) |>
|
||||||
pivot_wider(names_from = BREAKPOINT_TYPE, values_from = n) |>
|
pivot_wider(names_from = BREAKPOINT_TYPE, values_from = n) |>
|
||||||
janitor::adorn_totals(where = c("row", "col"))
|
janitor::adorn_totals(where = c("row", "col"))
|
||||||
|
whonet_breakpoints_raw |>
|
||||||
|
filter(YEAR == format(Sys.Date(), "%Y")) |>
|
||||||
|
count(GUIDELINES, YEAR, BREAKPOINT_TYPE) |>
|
||||||
|
pivot_wider(names_from = BREAKPOINT_TYPE, values_from = n) |>
|
||||||
|
janitor::adorn_totals(where = c("row", "col"))
|
||||||
# compared to current
|
# compared to current
|
||||||
AMR::clinical_breakpoints |>
|
AMR::clinical_breakpoints |>
|
||||||
count(GUIDELINES = gsub("[^a-zA-Z]", "", guideline), type) |>
|
count(GUIDELINES = gsub("[^a-zA-Z]", "", guideline), type) |>
|
||||||
@@ -213,7 +231,7 @@ AMR::clinical_breakpoints |>
|
|||||||
as.data.frame() |>
|
as.data.frame() |>
|
||||||
janitor::adorn_totals(where = c("row", "col"))
|
janitor::adorn_totals(where = c("row", "col"))
|
||||||
|
|
||||||
breakpoints <- whonet_breakpoints |>
|
breakpoints <- whonet_breakpoints_raw |>
|
||||||
mutate(code = toupper(ORGANISM_CODE)) |>
|
mutate(code = toupper(ORGANISM_CODE)) |>
|
||||||
left_join(bind_rows(microorganisms.codes |> filter(!code %in% c("ALL", "GEN")),
|
left_join(bind_rows(microorganisms.codes |> filter(!code %in% c("ALL", "GEN")),
|
||||||
# GEN (Generic) and ALL (All) are PK/PD codes
|
# GEN (Generic) and ALL (All) are PK/PD codes
|
||||||
@@ -233,7 +251,7 @@ breakpoints <- breakpoints |>
|
|||||||
|
|
||||||
# and these ones have unknown antibiotics according to WHONET itself:
|
# and these ones have unknown antibiotics according to WHONET itself:
|
||||||
breakpoints |>
|
breakpoints |>
|
||||||
filter(!WHONET_ABX_CODE %in% whonet_antibiotics$WHONET_ABX_CODE) |>
|
filter(!WHONET_ABX_CODE %in% whonet_antibiotics_raw$WHONET_ABX_CODE) |>
|
||||||
count(GUIDELINES, WHONET_ABX_CODE) |>
|
count(GUIDELINES, WHONET_ABX_CODE) |>
|
||||||
mutate(ab = as.ab(WHONET_ABX_CODE, fast_mode = TRUE),
|
mutate(ab = as.ab(WHONET_ABX_CODE, fast_mode = TRUE),
|
||||||
ab_name = ab_name(ab))
|
ab_name = ab_name(ab))
|
||||||
@@ -296,7 +314,7 @@ breakpoints_new[which(breakpoints_new$method == "DISK"), "breakpoint_R"] <- as.d
|
|||||||
# regarding animal breakpoints, CLSI has adults and foals for horses, but only for amikacin - only keep adult horses
|
# regarding animal breakpoints, CLSI has adults and foals for horses, but only for amikacin - only keep adult horses
|
||||||
breakpoints_new |>
|
breakpoints_new |>
|
||||||
filter(host %like% "foal") |>
|
filter(host %like% "foal") |>
|
||||||
count(guideline, host)
|
count(guideline, host, ab)
|
||||||
breakpoints_new <- breakpoints_new |>
|
breakpoints_new <- breakpoints_new |>
|
||||||
filter(host %unlike% "foal") |>
|
filter(host %unlike% "foal") |>
|
||||||
mutate(host = ifelse(host %like% "horse", "horse", host))
|
mutate(host = ifelse(host %like% "horse", "horse", host))
|
||||||
@@ -304,7 +322,7 @@ breakpoints_new <- breakpoints_new |>
|
|||||||
# FIXES FOR WHONET ERRORS ----
|
# FIXES FOR WHONET ERRORS ----
|
||||||
m <- unique(as.double(as.mic(levels(as.mic(1)))))
|
m <- unique(as.double(as.mic(levels(as.mic(1)))))
|
||||||
|
|
||||||
# WHONET has no >1024 but instead uses 1025, 513, etc, so as.mic() cannot be used to clean.
|
# WHONET has no >1024 but instead uses 1025, 513, and 129, so as.mic() cannot be used to clean.
|
||||||
# instead, raise these one higher valid MIC factor level:
|
# instead, raise these one higher valid MIC factor level:
|
||||||
breakpoints_new |> filter(method == "MIC" & (!breakpoint_S %in% c(m, NA))) |> distinct(breakpoint_S)
|
breakpoints_new |> filter(method == "MIC" & (!breakpoint_S %in% c(m, NA))) |> distinct(breakpoint_S)
|
||||||
breakpoints_new |> filter(method == "MIC" & (!breakpoint_R %in% c(m, NA))) |> distinct(breakpoint_R)
|
breakpoints_new |> filter(method == "MIC" & (!breakpoint_R %in% c(m, NA))) |> distinct(breakpoint_R)
|
||||||
@@ -318,6 +336,7 @@ anyNA(breakpoints_new$breakpoint_S)
|
|||||||
|
|
||||||
# a lot of R breakpoints are missing, but for CLSI this is required and can be set using as.sir(..., substitute_missing_r_breakpoint = TRUE/FALSE, ...)
|
# a lot of R breakpoints are missing, but for CLSI this is required and can be set using as.sir(..., substitute_missing_r_breakpoint = TRUE/FALSE, ...)
|
||||||
# 2025-04-20/ For EUCAST, this should not be the case, only happens to old guideline now it seems
|
# 2025-04-20/ For EUCAST, this should not be the case, only happens to old guideline now it seems
|
||||||
|
# 2026-03-27/ Now 2026 is in it as well, but making R same to S is fine
|
||||||
breakpoints_new |>
|
breakpoints_new |>
|
||||||
filter(method == "MIC" & guideline %like% "EUCAST" & is.na(breakpoint_R)) |>
|
filter(method == "MIC" & guideline %like% "EUCAST" & is.na(breakpoint_R)) |>
|
||||||
count(guideline)
|
count(guideline)
|
||||||
@@ -325,10 +344,15 @@ breakpoints_new[which(breakpoints_new$method == "MIC" & breakpoints_new$guidelin
|
|||||||
|
|
||||||
|
|
||||||
# fix streptococci in WHONET table of EUCAST: Strep A, B, C and G must only include these groups and not all streptococci:
|
# fix streptococci in WHONET table of EUCAST: Strep A, B, C and G must only include these groups and not all streptococci:
|
||||||
breakpoints_new$mo[breakpoints_new$mo == "B_STRPT" & breakpoints_new$ref_tbl %like% "^strep.* a.* b.*c.*g"] <- as.mo("B_STRPT_ABCG")
|
# 2026-03-27/ Only erroneous in EUCAST until 2024, it's fixed for 2025 and 2026, but we need to fix this historically too
|
||||||
|
breakpoints_new$mo[breakpoints_new$guideline %like% "EUCAST" & breakpoints_new$mo == "B_STRPT" & breakpoints_new$ref_tbl %like% "^strep.* a.* b.*c.*g"] <- as.mo("B_STRPT_ABCG")
|
||||||
# Haemophilus same error (must only be H. influenzae)
|
# Haemophilus same error (must only be H. influenzae)
|
||||||
breakpoints_new$mo[breakpoints_new$mo == "B_HMPHL" & breakpoints_new$ref_tbl %like% "^h.* influenzae"] <- as.mo("B_HMPHL_INFL")
|
# 2026-03-27/ Only erroneous in EUCAST until 2024, it's fixed for 2025 and 2026, but we need to fix this historically too
|
||||||
|
breakpoints_new$mo[breakpoints_new$guideline %like% "EUCAST" & breakpoints_new$mo == "B_HMPHL" & breakpoints_new$ref_tbl %like% "^h.* influenzae"] <- as.mo("B_HMPHL_INFL")
|
||||||
# EUCAST says that for H. parainfluenzae the H. influenza rules can be used, so add them
|
# EUCAST says that for H. parainfluenzae the H. influenza rules can be used, so add them
|
||||||
|
breakpoints_new |>
|
||||||
|
filter(method == "MIC" & guideline %like% "EUCAST" & mo %like% as.mo("B_HMPHL")) |>
|
||||||
|
count(guideline, mo)
|
||||||
breakpoints_new <- breakpoints_new |>
|
breakpoints_new <- breakpoints_new |>
|
||||||
bind_rows(
|
bind_rows(
|
||||||
breakpoints_new |>
|
breakpoints_new |>
|
||||||
@@ -345,6 +369,17 @@ breakpoints_new |> filter(mo == as.mo("Streptococcus viridans") & ab == "GEH")
|
|||||||
breakpoints_new <- breakpoints_new |> filter(!(mo == as.mo("Streptococcus viridans") & ab == "GEN"))
|
breakpoints_new <- breakpoints_new |> filter(!(mo == as.mo("Streptococcus viridans") & ab == "GEN"))
|
||||||
# Nitrofurantoin in Staph (EUCAST) only applies to S. saprophyticus, while WHONET has the DISK correct but the MIC on genus level
|
# Nitrofurantoin in Staph (EUCAST) only applies to S. saprophyticus, while WHONET has the DISK correct but the MIC on genus level
|
||||||
breakpoints_new$mo[breakpoints_new$mo == "B_STPHY" & breakpoints_new$ab == "NIT" & breakpoints_new$guideline %like% "EUCAST"] <- as.mo("B_STPHY_SPRP")
|
breakpoints_new$mo[breakpoints_new$mo == "B_STPHY" & breakpoints_new$ab == "NIT" & breakpoints_new$guideline %like% "EUCAST"] <- as.mo("B_STPHY_SPRP")
|
||||||
|
|
||||||
|
# WHONET contains breakpoint for EUCAST that are not actually in EUCAST:
|
||||||
|
# IPM in M. morganii is not in it since v10
|
||||||
|
wrong <- with(breakpoints_new, guideline %like% "EUCAST" & ab == "IPM" & mo == as.mo("M. morganii") & ref_tbl != "ECOFF")
|
||||||
|
breakpoints_new |> filter(wrong)
|
||||||
|
breakpoints_new <- breakpoints_new |> filter(!wrong)
|
||||||
|
# Breakpoints for COPS were part of EUCAST until v11
|
||||||
|
wrong <- with(breakpoints_new, guideline %like% "EUCAST" & mo == as.mo("CoPS") & ref_tbl != "ECOFF")
|
||||||
|
breakpoints_new |> filter(wrong)
|
||||||
|
breakpoints_new <- breakpoints_new |> filter(!wrong)
|
||||||
|
|
||||||
# WHONET sets the 2023 breakpoints for SAM to MIC of 16/32 for Enterobacterales, should be MIC 8/32 like AMC (see issue #123 on github.com/msberends/AMR)
|
# WHONET sets the 2023 breakpoints for SAM to MIC of 16/32 for Enterobacterales, should be MIC 8/32 like AMC (see issue #123 on github.com/msberends/AMR)
|
||||||
# 2024-02-22/ fixed now
|
# 2024-02-22/ fixed now
|
||||||
|
|
||||||
@@ -389,7 +424,7 @@ breakpoints_new |>
|
|||||||
filter(id %in% .$id[which(duplicated(id))]) |>
|
filter(id %in% .$id[which(duplicated(id))]) |>
|
||||||
arrange(desc(guideline)) |>
|
arrange(desc(guideline)) |>
|
||||||
View()
|
View()
|
||||||
# 2024-06-19/ mostly ECOFFs, but there's no explanation in the whonet_breakpoints file, we have to remove duplicates
|
# 2024-06-19/ mostly ECOFFs, but there's no explanation in the whonet_breakpoints_raw df, we have to remove duplicates
|
||||||
# 2025-04-20/ same, most important one seems M. tuberculosis in CLSI (also in 2025)
|
# 2025-04-20/ same, most important one seems M. tuberculosis in CLSI (also in 2025)
|
||||||
breakpoints_new <- breakpoints_new |>
|
breakpoints_new <- breakpoints_new |>
|
||||||
distinct(guideline, type, host, method, site, mo, ab, uti, .keep_all = TRUE)
|
distinct(guideline, type, host, method, site, mo, ab, uti, .keep_all = TRUE)
|
||||||
@@ -398,9 +433,9 @@ breakpoints_new <- breakpoints_new |>
|
|||||||
# CHECKS AND SAVE TO PACKAGE ----
|
# CHECKS AND SAVE TO PACKAGE ----
|
||||||
|
|
||||||
# check again
|
# check again
|
||||||
breakpoints_new |> filter(guideline == "EUCAST 2025", ab == "AMC", mo == "B_[ORD]_ENTRBCTR", method == "MIC")
|
breakpoints_new |> filter(guideline == "EUCAST 2026", ab == "AMC", mo == "B_[ORD]_ENTRBCTR", method == "MIC")
|
||||||
# compare with current version
|
# compare with current version
|
||||||
clinical_breakpoints |> filter(guideline == "EUCAST 2024", ab == "AMC", mo == "B_[ORD]_ENTRBCTR", method == "MIC")
|
clinical_breakpoints |> filter(guideline == "EUCAST 2025", ab == "AMC", mo == "B_[ORD]_ENTRBCTR", method == "MIC")
|
||||||
|
|
||||||
# must have "human" and "ECOFF"
|
# must have "human" and "ECOFF"
|
||||||
breakpoints_new |> filter(mo == "B_STRPT_PNMN", ab == "AMP", guideline == "EUCAST 2020", method == "MIC")
|
breakpoints_new |> filter(mo == "B_STRPT_PNMN", ab == "AMP", guideline == "EUCAST 2020", method == "MIC")
|
||||||
|
|||||||
@@ -1 +1 @@
|
|||||||
c7062e60fa4fbc2eee233044d15903ce
|
c43a990cf91f959913d207e5a85e2bd5
|
||||||
|
|||||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@@ -2832,6 +2832,7 @@
|
|||||||
"FU-" "B_FSBCTR"
|
"FU-" "B_FSBCTR"
|
||||||
"FUA.SP" "F_FUSRM"
|
"FUA.SP" "F_FUSRM"
|
||||||
"FUL" "B_FSBCTR_ULCR"
|
"FUL" "B_FSBCTR_ULCR"
|
||||||
|
"FUO" "F_FUSRM_OXYS"
|
||||||
"FUR" "F_FUSRM"
|
"FUR" "F_FUSRM"
|
||||||
"FUROXY" "F_FUSRM_OXYS"
|
"FUROXY" "F_FUSRM_OXYS"
|
||||||
"FURPET" "F_FUSRM_PTRL"
|
"FURPET" "F_FUSRM_PTRL"
|
||||||
@@ -2936,6 +2937,7 @@
|
|||||||
"GLO.SP" "B_GLBCT"
|
"GLO.SP" "B_GLBCT"
|
||||||
"GLOSAN" "B_GLBCT_SNGN"
|
"GLOSAN" "B_GLBCT_SNGN"
|
||||||
"GLOSPP" "B_GLBCT"
|
"GLOSPP" "B_GLBCT"
|
||||||
|
"GLS" "B_GLSSR"
|
||||||
"GM+" "B_GRAMP"
|
"GM+" "B_GRAMP"
|
||||||
"GM-" "B_GRAMN"
|
"GM-" "B_GRAMN"
|
||||||
"GMO" "B_GEMLL_MRBL"
|
"GMO" "B_GEMLL_MRBL"
|
||||||
@@ -3026,7 +3028,6 @@
|
|||||||
"HABSPP" "B_HMTBC"
|
"HABSPP" "B_HMTBC"
|
||||||
"HAC" "B_AGGRG_ACTN"
|
"HAC" "B_AGGRG_ACTN"
|
||||||
"HACEK" "B_HACEK"
|
"HACEK" "B_HACEK"
|
||||||
"HACEK" "B_HACEK"
|
|
||||||
"HAE" "B_HMPHL"
|
"HAE" "B_HMPHL"
|
||||||
"HAE.SP" "B_HMPHL"
|
"HAE.SP" "B_HMPHL"
|
||||||
"HAEAEG" "B_HMPHL_AEGY"
|
"HAEAEG" "B_HMPHL_AEGY"
|
||||||
@@ -3122,7 +3123,7 @@
|
|||||||
"HPL" "B_HMPHL_PRPH"
|
"HPL" "B_HMPHL_PRPH"
|
||||||
"HPO" "F_OGATA"
|
"HPO" "F_OGATA"
|
||||||
"HPOSPP" "F_HNDRS_ASTR"
|
"HPOSPP" "F_HNDRS_ASTR"
|
||||||
"HPR" "B_HMPHL_PRSS"
|
"HPR" "B_GLSSR_PRSS"
|
||||||
"HPU" "B_HLCBCT_PLLR"
|
"HPU" "B_HLCBCT_PLLR"
|
||||||
"HPY" "B_HLCBCT_PYLR"
|
"HPY" "B_HLCBCT_PYLR"
|
||||||
"HRB" "B_HRBSP"
|
"HRB" "B_HRBSP"
|
||||||
@@ -3471,6 +3472,7 @@
|
|||||||
"LQU" "B_LGNLL_QTRN"
|
"LQU" "B_LGNLL_QTRN"
|
||||||
"LRC" "B_LPTSP_INTR"
|
"LRC" "B_LPTSP_INTR"
|
||||||
"LRE" "B_LCTBC_RETR"
|
"LRE" "B_LCTBC_RETR"
|
||||||
|
"LRF" "B_LCTCC_RFFN"
|
||||||
"LRI" "B_LMNRL_RCHR"
|
"LRI" "B_LMNRL_RCHR"
|
||||||
"LRU" "B_LGNLL_RBRL"
|
"LRU" "B_LGNLL_RBRL"
|
||||||
"LSA" "B_LCTBC_SLVR"
|
"LSA" "B_LCTBC_SLVR"
|
||||||
@@ -3760,6 +3762,7 @@
|
|||||||
"MNE" "B_MYCBC_NERM"
|
"MNE" "B_MYCBC_NERM"
|
||||||
"MNL" "B_MRXLL_NNLQ"
|
"MNL" "B_MRXLL_NNLQ"
|
||||||
"MNO" "B_MYCBC_NNCH"
|
"MNO" "B_MYCBC_NNCH"
|
||||||
|
"MNT" "B_MYCBC"
|
||||||
"MNV" "B_MNNHM_VRGN"
|
"MNV" "B_MNNHM_VRGN"
|
||||||
"MO-" "B_MRXLL"
|
"MO-" "B_MRXLL"
|
||||||
"MO.BOV" "B_MRXLL_BOVS"
|
"MO.BOV" "B_MRXLL_BOVS"
|
||||||
@@ -4295,6 +4298,7 @@
|
|||||||
"PAT.SP" "B_PANTO"
|
"PAT.SP" "B_PANTO"
|
||||||
"PAU" "B_SLMNL_ENTR_ENTR"
|
"PAU" "B_SLMNL_ENTR_ENTR"
|
||||||
"PAV" "B_AVBCT_AVIM"
|
"PAV" "B_AVBCT_AVIM"
|
||||||
|
"PBA" "B_PSDCL_ALBA"
|
||||||
"PBC" "B_PRVTL_BCCL"
|
"PBC" "B_PRVTL_BCCL"
|
||||||
"PBE" "B_PSTRL_BTTY"
|
"PBE" "B_PSTRL_BTTY"
|
||||||
"PBI" "B_PRBCT"
|
"PBI" "B_PRBCT"
|
||||||
@@ -4591,6 +4595,7 @@
|
|||||||
"PSA" "F_PSDLL"
|
"PSA" "F_PSDLL"
|
||||||
"PSA.SP" "F_PSDLL"
|
"PSA.SP" "F_PSDLL"
|
||||||
"PSASPP" "F_PSDLL"
|
"PSASPP" "F_PSDLL"
|
||||||
|
"PSB" "B_PSDCL"
|
||||||
"PSC" "F_PSDCH"
|
"PSC" "F_PSDCH"
|
||||||
"PSCSPP" "B_PSDCL"
|
"PSCSPP" "B_PSDCL"
|
||||||
"PSD" "B_STPHY_PSDN"
|
"PSD" "B_STPHY_PSDN"
|
||||||
@@ -4706,6 +4711,7 @@
|
|||||||
"RAH.SP" "B_RHNLL"
|
"RAH.SP" "B_RHNLL"
|
||||||
"RAHAQU" "B_RHNLL_AQTL"
|
"RAHAQU" "B_RHNLL_AQTL"
|
||||||
"RAHSPP" "B_RHNLL"
|
"RAHSPP" "B_RHNLL"
|
||||||
|
"RAI" "B_RLSTN_INSD"
|
||||||
"RAK" "B_RTTSA_AKAR"
|
"RAK" "B_RTTSA_AKAR"
|
||||||
"RAL" "B_RLSTN"
|
"RAL" "B_RLSTN"
|
||||||
"RAL.SP" "B_RLSTN"
|
"RAL.SP" "B_RLSTN"
|
||||||
@@ -4800,6 +4806,7 @@
|
|||||||
"ROD" "B_RDNTB"
|
"ROD" "B_RDNTB"
|
||||||
"RODPNE" "B_RDNTB_PNMT"
|
"RODPNE" "B_RDNTB_PNMT"
|
||||||
"RODSPP" "B_RDNTB"
|
"RODSPP" "B_RDNTB"
|
||||||
|
"ROK" "B_ROTHI_KRST"
|
||||||
"ROL" "F_RHZPS_MCRS"
|
"ROL" "F_RHZPS_MCRS"
|
||||||
"ROM" "B_RSMNS"
|
"ROM" "B_RSMNS"
|
||||||
"ROMMUC" "B_RSMNS"
|
"ROMMUC" "B_RSMNS"
|
||||||
@@ -5042,8 +5049,10 @@
|
|||||||
"SAV" "B_SLMNL_ARCH"
|
"SAV" "B_SLMNL_ARCH"
|
||||||
"SB2" "B_STRPT_BOVS"
|
"SB2" "B_STRPT_BOVS"
|
||||||
"SBA" "B_SLMNL_BRLL"
|
"SBA" "B_SLMNL_BRLL"
|
||||||
|
"SBC" "B_SLBCL"
|
||||||
"SBE" "B_SHWNL_BNTH"
|
"SBE" "B_SHWNL_BNTH"
|
||||||
"SBG" "B_SLMNL_BNGR"
|
"SBG" "B_SLMNL_BNGR"
|
||||||
|
"SBI" "B_SLBCL_SLVS"
|
||||||
"SBL" "B_SLMNL_BLCK"
|
"SBL" "B_SLMNL_BLCK"
|
||||||
"SBM" "B_SLMNL_BVSM"
|
"SBM" "B_SLMNL_BVSM"
|
||||||
"SBN" "B_SLMNL_BBRG"
|
"SBN" "B_SLMNL_BBRG"
|
||||||
@@ -5078,6 +5087,7 @@
|
|||||||
"SCS" "F_SCLCB_CNST"
|
"SCS" "F_SCLCB_CNST"
|
||||||
"SCT" "B_STRPT_CNST"
|
"SCT" "B_STRPT_CNST"
|
||||||
"SCU" "B_STPHY_CRNS"
|
"SCU" "B_STPHY_CRNS"
|
||||||
|
"SCV" "F_SCPLR_VCLS"
|
||||||
"SCY" "F_SCYTL"
|
"SCY" "F_SCYTL"
|
||||||
"SCYSPP" "F_SCYTL"
|
"SCYSPP" "F_SCYTL"
|
||||||
"SD1" "B_SHGLL_DYSN"
|
"SD1" "B_SHGLL_DYSN"
|
||||||
@@ -5656,6 +5666,7 @@
|
|||||||
"TAYSPP" "B_TYLRL"
|
"TAYSPP" "B_TYLRL"
|
||||||
"TBE" "F_GTRCH_RDLL"
|
"TBE" "F_GTRCH_RDLL"
|
||||||
"TBESPP" "F_TRCHS"
|
"TBESPP" "F_TRCHS"
|
||||||
|
"TBH" "F_TRCHP_BNHM"
|
||||||
"TBN" "B_TRPRL_BRNR"
|
"TBN" "B_TRPRL_BRNR"
|
||||||
"TCA" "F_DBRYM_CHVL"
|
"TCA" "F_DBRYM_CHVL"
|
||||||
"TCASPP" "F_CANDD"
|
"TCASPP" "F_CANDD"
|
||||||
@@ -5841,6 +5852,8 @@
|
|||||||
"TYASPP" "F_TRCHP"
|
"TYASPP" "F_TRCHP"
|
||||||
"TYE" "P_TRYPN_JNSN"
|
"TYE" "P_TRYPN_JNSN"
|
||||||
"TYI" "F_TRCHP_INDT"
|
"TYI" "F_TRCHP_INDT"
|
||||||
|
"TYM" "B_TRPHR"
|
||||||
|
"TYW" "B_TRPHR_WHPP"
|
||||||
"ULO" "F_ULCLD"
|
"ULO" "F_ULCLD"
|
||||||
"UNK" "UNKNOWN"
|
"UNK" "UNKNOWN"
|
||||||
"UPEC" "B_ESCHR_COLI"
|
"UPEC" "B_ESCHR_COLI"
|
||||||
@@ -5850,6 +5863,7 @@
|
|||||||
"UREPAR" "B_URPLS_PRVM"
|
"UREPAR" "B_URPLS_PRVM"
|
||||||
"URESPP" "B_URPLS"
|
"URESPP" "B_URPLS"
|
||||||
"UREURE" "B_URPLS_URLY"
|
"UREURE" "B_URPLS_URLY"
|
||||||
|
"URP" "B_URPLS_PRVM"
|
||||||
"UUR" "B_URPLS_URLY"
|
"UUR" "B_URPLS_URLY"
|
||||||
"V.ALG" "B_VIBRI_ALGN"
|
"V.ALG" "B_VIBRI_ALGN"
|
||||||
"V.CHO" "B_VIBRI_CHLR"
|
"V.CHO" "B_VIBRI_CHLR"
|
||||||
|
|||||||
Binary file not shown.
@@ -1 +1 @@
|
|||||||
986d5110a46bbf297ebaeb4dd5179fff
|
6ef98bb1bcd27052fde453bb12c0b285
|
||||||
|
|||||||
Binary file not shown.
BIN
data-raw/v_16.0__BreakpointTables.xlsx
Normal file
BIN
data-raw/v_16.0__BreakpointTables.xlsx
Normal file
Binary file not shown.
Binary file not shown.
Binary file not shown.
32
index.md
32
index.md
@@ -10,7 +10,7 @@
|
|||||||
even WISCA
|
even WISCA
|
||||||
- Provides the **full microbiological taxonomy** of ~79 000 distinct
|
- Provides the **full microbiological taxonomy** of ~79 000 distinct
|
||||||
species and extensive info of ~620 antimicrobial drugs
|
species and extensive info of ~620 antimicrobial drugs
|
||||||
- Applies **CLSI 2011-2025** and **EUCAST 2011-2025** clinical and
|
- Applies **CLSI 2011-2026** and **EUCAST 2011-2026** clinical and
|
||||||
veterinary breakpoints, and ECOFFs, for MIC and disk zone
|
veterinary breakpoints, and ECOFFs, for MIC and disk zone
|
||||||
interpretation
|
interpretation
|
||||||
- Corrects for duplicate isolates, **calculates** and **predicts** AMR
|
- Corrects for duplicate isolates, **calculates** and **predicts** AMR
|
||||||
@@ -68,7 +68,7 @@ species**](./reference/microorganisms.html) (updated June 2024) and all
|
|||||||
drugs**](./reference/antimicrobials.html) by name and code (including
|
drugs**](./reference/antimicrobials.html) by name and code (including
|
||||||
ATC, EARS-Net, ASIARS-Net, PubChem, LOINC and SNOMED CT), and knows all
|
ATC, EARS-Net, ASIARS-Net, PubChem, LOINC and SNOMED CT), and knows all
|
||||||
about valid SIR and MIC values. The integral clinical breakpoint
|
about valid SIR and MIC values. The integral clinical breakpoint
|
||||||
guidelines from CLSI 2011-2025 and EUCAST 2011-2025 are included, even
|
guidelines from CLSI 2011-2026 and EUCAST 2011-2026 are included, even
|
||||||
with epidemiological cut-off (ECOFF) values. It supports and can read
|
with epidemiological cut-off (ECOFF) values. It supports and can read
|
||||||
any data format, including WHONET data. This package works on Windows,
|
any data format, including WHONET data. This package works on Windows,
|
||||||
macOS and Linux with all versions of R since R-3.0 (April 2013). **It
|
macOS and Linux with all versions of R since R-3.0 (April 2013). **It
|
||||||
@@ -171,14 +171,14 @@ example_isolates %>%
|
|||||||
select(bacteria,
|
select(bacteria,
|
||||||
aminoglycosides(),
|
aminoglycosides(),
|
||||||
carbapenems())
|
carbapenems())
|
||||||
#> ℹ Using column 'mo' as input for `mo_fullname()`
|
#> ℹ Using column mo as input for `mo_fullname()`
|
||||||
#> ℹ Using column 'mo' as input for `mo_is_gram_negative()`
|
#> ℹ Using column mo as input for `mo_is_gram_negative()`
|
||||||
#> ℹ Using column 'mo' as input for `mo_is_intrinsic_resistant()`
|
#> ℹ Using column mo as input for `mo_is_intrinsic_resistant()`
|
||||||
#> ℹ Determining intrinsic resistance based on 'EUCAST Expected Resistant
|
#> ℹ Determining intrinsic resistance based on 'EUCAST Expected Resistant
|
||||||
#> Phenotypes' v1.2 (2023). This note will be shown once per session.
|
#> Phenotypes' v1.2 (2023). This note will be shown once per session.
|
||||||
#> ℹ For `aminoglycosides()` using columns 'GEN' (gentamicin), 'TOB'
|
#> ℹ For `aminoglycosides()` using columns GEN (gentamicin), TOB (tobramycin), AMK
|
||||||
#> (tobramycin), 'AMK' (amikacin), and 'KAN' (kanamycin)
|
#> (amikacin), and KAN (kanamycin)
|
||||||
#> ℹ For `carbapenems()` using columns 'IPM' (imipenem) and 'MEM' (meropenem)
|
#> ℹ For `carbapenems()` using columns IPM (imipenem) and MEM (meropenem)
|
||||||
#> # A tibble: 35 × 7
|
#> # A tibble: 35 × 7
|
||||||
#> bacteria GEN TOB AMK KAN IPM MEM
|
#> bacteria GEN TOB AMK KAN IPM MEM
|
||||||
#> <chr> <sir> <sir> <sir> <sir> <sir> <sir>
|
#> <chr> <sir> <sir> <sir> <sir> <sir> <sir>
|
||||||
@@ -215,9 +215,9 @@ output format automatically (such as markdown, LaTeX, HTML, etc.).
|
|||||||
``` r
|
``` r
|
||||||
antibiogram(example_isolates,
|
antibiogram(example_isolates,
|
||||||
antimicrobials = c(aminoglycosides(), carbapenems()))
|
antimicrobials = c(aminoglycosides(), carbapenems()))
|
||||||
#> ℹ For `aminoglycosides()` using columns 'GEN' (gentamicin), 'TOB'
|
#> ℹ For `aminoglycosides()` using columns GEN (gentamicin), TOB (tobramycin), AMK
|
||||||
#> (tobramycin), 'AMK' (amikacin), and 'KAN' (kanamycin)
|
#> (amikacin), and KAN (kanamycin)
|
||||||
#> ℹ For `carbapenems()` using columns 'IPM' (imipenem) and 'MEM' (meropenem)
|
#> ℹ For `carbapenems()` using columns IPM (imipenem) and MEM (meropenem)
|
||||||
```
|
```
|
||||||
|
|
||||||
| Pathogen | Amikacin | Gentamicin | Imipenem | Kanamycin | Meropenem | Tobramycin |
|
| Pathogen | Amikacin | Gentamicin | Imipenem | Kanamycin | Meropenem | Tobramycin |
|
||||||
@@ -344,15 +344,15 @@ out <- example_isolates %>%
|
|||||||
# calculate AMR using resistance(), over all aminoglycosides and polymyxins:
|
# calculate AMR using resistance(), over all aminoglycosides and polymyxins:
|
||||||
summarise(across(c(aminoglycosides(), polymyxins()),
|
summarise(across(c(aminoglycosides(), polymyxins()),
|
||||||
resistance))
|
resistance))
|
||||||
#> ℹ For `aminoglycosides()` using columns 'GEN' (gentamicin), 'TOB'
|
#> ℹ For `aminoglycosides()` using columns GEN (gentamicin), TOB (tobramycin), AMK
|
||||||
#> (tobramycin), 'AMK' (amikacin), and 'KAN' (kanamycin)
|
#> (amikacin), and KAN (kanamycin)
|
||||||
#> ℹ For `polymyxins()` using column 'COL' (colistin)
|
#> ℹ For `polymyxins()` using column COL (colistin)
|
||||||
#> Warning: There was 1 warning in `summarise()`.
|
#> Warning: There was 1 warning in `summarise()`.
|
||||||
#> ℹ In argument: `across(c(aminoglycosides(), polymyxins()), resistance)`.
|
#> ℹ In argument: `across(c(aminoglycosides(), polymyxins()), resistance)`.
|
||||||
#> ℹ In group 3: `ward = "Outpatient"`.
|
#> ℹ In group 3: `ward = "Outpatient"`.
|
||||||
#> Caused by warning:
|
#> Caused by warning:
|
||||||
#> ! Introducing NA: only 23 results available for KAN in group: ward =
|
#> ! Introducing NA: only 23 results available for KAN in group: ward = "Outpatient"
|
||||||
#> "Outpatient" (`minimum` = 30).
|
#> (whilst `minimum = 30`).
|
||||||
out
|
out
|
||||||
#> # A tibble: 3 × 6
|
#> # A tibble: 3 × 6
|
||||||
#> ward GEN TOB AMK KAN COL
|
#> ward GEN TOB AMK KAN COL
|
||||||
|
|||||||
@@ -18,14 +18,14 @@ This is an overview of all the package-specific options you can set in the \code
|
|||||||
\item \code{AMR_custom_ab} \cr A file location to an RDS file, to use custom antimicrobial drugs with this package. This is explained in \code{\link[=add_custom_antimicrobials]{add_custom_antimicrobials()}}.
|
\item \code{AMR_custom_ab} \cr A file location to an RDS file, to use custom antimicrobial drugs with this package. This is explained in \code{\link[=add_custom_antimicrobials]{add_custom_antimicrobials()}}.
|
||||||
\item \code{AMR_custom_mo} \cr A file location to an RDS file, to use custom microorganisms with this package. This is explained in \code{\link[=add_custom_microorganisms]{add_custom_microorganisms()}}.
|
\item \code{AMR_custom_mo} \cr A file location to an RDS file, to use custom microorganisms with this package. This is explained in \code{\link[=add_custom_microorganisms]{add_custom_microorganisms()}}.
|
||||||
\item \code{AMR_eucastrules} \cr A \link{character} to set the default types of rules for \code{\link[=eucast_rules]{eucast_rules()}} function, must be one or more of: \code{"breakpoints"}, \code{"expert"}, \code{"other"}, \code{"custom"}, \code{"all"}, and defaults to \code{c("breakpoints", "expert")}.
|
\item \code{AMR_eucastrules} \cr A \link{character} to set the default types of rules for \code{\link[=eucast_rules]{eucast_rules()}} function, must be one or more of: \code{"breakpoints"}, \code{"expert"}, \code{"other"}, \code{"custom"}, \code{"all"}, and defaults to \code{c("breakpoints", "expert")}.
|
||||||
\item \code{AMR_guideline} \cr A \link{character} to set the default guideline used throughout the \code{AMR} package wherever a \code{guideline} argument is available. This option is used as the default in e.g. \code{\link[=as.sir]{as.sir()}}, \code{\link[=resistance]{resistance()}}, \code{\link[=susceptibility]{susceptibility()}}, \code{\link[=interpretive_rules]{interpretive_rules()}} and many plotting functions. \strong{While unset}, the AMR package uses the latest implemented EUCAST guideline (currently EUCAST 2025).
|
\item \code{AMR_guideline} \cr A \link{character} to set the default guideline used throughout the \code{AMR} package wherever a \code{guideline} argument is available. This option is used as the default in e.g. \code{\link[=as.sir]{as.sir()}}, \code{\link[=resistance]{resistance()}}, \code{\link[=susceptibility]{susceptibility()}}, \code{\link[=interpretive_rules]{interpretive_rules()}} and many plotting functions. \strong{While unset}, the AMR package uses the latest implemented EUCAST guideline (currently EUCAST 2026).
|
||||||
\itemize{
|
\itemize{
|
||||||
\item For \code{\link[=as.sir]{as.sir()}}, this determines which clinical breakpoint guideline is used to interpret MIC values and disk diffusion diameters. It can be either the guideline name (e.g., \code{"CLSI"} or \code{"EUCAST"}) or the name including a year (e.g., \code{"CLSI 2019"}). Supported guidelines are EUCAST 2011 to 2025, and CLSI 2011 to 2025.
|
\item For \code{\link[=as.sir]{as.sir()}}, this determines which clinical breakpoint guideline is used to interpret MIC values and disk diffusion diameters. It can be either the guideline name (e.g., \code{"CLSI"} or \code{"EUCAST"}) or the name including a year (e.g., \code{"CLSI 2019"}). Supported guidelines are EUCAST 2011 to 2026, and CLSI 2011 to 2026.
|
||||||
\item For \code{\link[=resistance]{resistance()}} and \code{\link[=susceptibility]{susceptibility()}}, this setting determines how the \code{"I"} (Intermediate / Increased exposure) category is handled in calculations. Under CLSI, \code{"I"} is considered \emph{resistant} in susceptibility calculations; under EUCAST, \code{"I"} is considered \emph{susceptible} in susceptibility calculations. Explicitly setting this option ensures reproducible AMR proportion estimates.
|
\item For \code{\link[=resistance]{resistance()}} and \code{\link[=susceptibility]{susceptibility()}}, this setting determines how the \code{"I"} (Intermediate / Increased exposure) category is handled in calculations. Under CLSI, \code{"I"} is considered \emph{resistant} in susceptibility calculations; under EUCAST, \code{"I"} is considered \emph{susceptible} in susceptibility calculations. Explicitly setting this option ensures reproducible AMR proportion estimates.
|
||||||
\item For \code{\link[=interpretive_rules]{interpretive_rules()}}, this determines which guideline-specific interpretive (expert) rules are applied to antimicrobial test results, either EUCAST or CLSI.
|
\item For \code{\link[=interpretive_rules]{interpretive_rules()}}, this determines which guideline-specific interpretive (expert) rules are applied to antimicrobial test results, either EUCAST or CLSI.
|
||||||
\item For many plotting functions (e.g., for MIC or disk diffusion values), supplying \code{mo} and \code{ab} enables automatic SIR-based interpretative colouring. These colours are derived from \code{\link[=as.sir]{as.sir()}} in the background and therefore depend on the active \code{guideline} setting, which again uses EUCAST 2025 if not set explicitly.
|
\item For many plotting functions (e.g., for MIC or disk diffusion values), supplying \code{mo} and \code{ab} enables automatic SIR-based interpretative colouring. These colours are derived from \code{\link[=as.sir]{as.sir()}} in the background and therefore depend on the active \code{guideline} setting, which again uses EUCAST 2026 if not set explicitly.
|
||||||
}
|
}
|
||||||
\item \code{AMR_guideline} \cr A \link{character} to set the default guideline for interpreting MIC values and disk diffusion diameters with \code{\link[=as.sir]{as.sir()}}. Can be only the guideline name (e.g., \code{"CLSI"}) or the name with a year (e.g. \code{"CLSI 2019"}). The default to the latest implemented EUCAST guideline, currently \code{"EUCAST 2025"}. Supported guideline are currently EUCAST (2011-2025) and CLSI (2011-2025).
|
\item \code{AMR_guideline} \cr A \link{character} to set the default guideline for interpreting MIC values and disk diffusion diameters with \code{\link[=as.sir]{as.sir()}}. Can be only the guideline name (e.g., \code{"CLSI"}) or the name with a year (e.g. \code{"CLSI 2019"}). The default to the latest implemented EUCAST guideline, currently \code{"EUCAST 2026"}. Supported guideline are currently EUCAST (2011-2026) and CLSI (2011-2026).
|
||||||
\item \code{AMR_ignore_pattern} \cr A \link[base:regex]{regular expression} to ignore (i.e., make \code{NA}) any match given in \code{\link[=as.mo]{as.mo()}} and all \code{\link[=mo_property]{mo_*}} functions.
|
\item \code{AMR_ignore_pattern} \cr A \link[base:regex]{regular expression} to ignore (i.e., make \code{NA}) any match given in \code{\link[=as.mo]{as.mo()}} and all \code{\link[=mo_property]{mo_*}} functions.
|
||||||
\item \code{AMR_include_PKPD} \cr A \link{logical} to use in \code{\link[=as.sir]{as.sir()}}, to indicate that PK/PD clinical breakpoints must be applied as a last resort - the default is \code{TRUE}.
|
\item \code{AMR_include_PKPD} \cr A \link{logical} to use in \code{\link[=as.sir]{as.sir()}}, to indicate that PK/PD clinical breakpoints must be applied as a last resort - the default is \code{TRUE}.
|
||||||
\item \code{AMR_substitute_missing_r_breakpoint} \cr A \link{logical} to use in \code{\link[=as.sir]{as.sir()}}, to indicate that missing R breakpoints must be substituted with \code{"R"} - the default is \code{FALSE}.
|
\item \code{AMR_substitute_missing_r_breakpoint} \cr A \link{logical} to use in \code{\link[=as.sir]{as.sir()}}, to indicate that missing R breakpoints must be substituted with \code{"R"} - the default is \code{FALSE}.
|
||||||
|
|||||||
@@ -32,7 +32,7 @@ The \code{AMR} package is a peer-reviewed, \href{https://amr-for-r.org/#copyrigh
|
|||||||
|
|
||||||
This work was published in the Journal of Statistical Software (Volume 104(3); \doi{10.18637/jss.v104.i03}) and formed the basis of two PhD theses (\doi{10.33612/diss.177417131} and \doi{10.33612/diss.192486375}).
|
This work was published in the Journal of Statistical Software (Volume 104(3); \doi{10.18637/jss.v104.i03}) and formed the basis of two PhD theses (\doi{10.33612/diss.177417131} and \doi{10.33612/diss.192486375}).
|
||||||
|
|
||||||
After installing this package, R knows \href{https://amr-for-r.org/reference/microorganisms.html}{\strong{~79 000 distinct microbial species}} (updated June 2024) and all \href{https://amr-for-r.org/reference/antimicrobials.html}{\strong{~620 antimicrobial and antiviral drugs}} by name and code (including ATC, EARS-Net, ASIARS-Net, PubChem, LOINC and SNOMED CT), and knows all about valid SIR and MIC values. The integral clinical breakpoint guidelines from CLSI 2011-2025 and EUCAST 2011-2025 are included, even with epidemiological cut-off (ECOFF) values. It supports and can read any data format, including WHONET data. This package works on Windows, macOS and Linux with all versions of R since R-3.0 (April 2013). \strong{It was designed to work in any setting, including those with very limited resources}. It was created for both routine data analysis and academic research at the Faculty of Medical Sciences of the \href{https://www.rug.nl}{University of Groningen} and the \href{https://www.umcg.nl}{University Medical Center Groningen}.
|
After installing this package, R knows \href{https://amr-for-r.org/reference/microorganisms.html}{\strong{~79 000 distinct microbial species}} (updated June 2024) and all \href{https://amr-for-r.org/reference/antimicrobials.html}{\strong{~620 antimicrobial and antiviral drugs}} by name and code (including ATC, EARS-Net, ASIARS-Net, PubChem, LOINC and SNOMED CT), and knows all about valid SIR and MIC values. The integral clinical breakpoint guidelines from CLSI 2011-2026 and EUCAST 2011-2026 are included, even with epidemiological cut-off (ECOFF) values. It supports and can read any data format, including WHONET data. This package works on Windows, macOS and Linux with all versions of R since R-3.0 (April 2013). \strong{It was designed to work in any setting, including those with very limited resources}. It was created for both routine data analysis and academic research at the Faculty of Medical Sciences of the \href{https://www.rug.nl}{University of Groningen} and the \href{https://www.umcg.nl}{University Medical Center Groningen}.
|
||||||
|
|
||||||
The \code{AMR} package is available in English, Arabic, Bengali, Chinese, Czech, Danish, Dutch, Finnish, French, German, Greek, Hindi, Indonesian, Italian, Japanese, Korean, Norwegian, Polish, Portuguese, Romanian, Russian, Spanish, Swahili, Swedish, Turkish, Ukrainian, Urdu, and Vietnamese. Antimicrobial drug (group) names and colloquial microorganism names are provided in these languages.
|
The \code{AMR} package is available in English, Arabic, Bengali, Chinese, Czech, Danish, Dutch, Finnish, French, German, Greek, Hindi, Indonesian, Italian, Japanese, Korean, Norwegian, Polish, Portuguese, Romanian, Russian, Spanish, Swahili, Swedish, Turkish, Ukrainian, Urdu, and Vietnamese. Antimicrobial drug (group) names and colloquial microorganism names are provided in these languages.
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -50,13 +50,13 @@ Ordered \link{factor} with additional class \code{\link{mic}}, that in mathemati
|
|||||||
This transforms vectors to a new class \code{\link{mic}}, which treats the input as decimal numbers, while maintaining operators (such as ">=") and only allowing valid MIC values known to the field of (medical) microbiology.
|
This transforms vectors to a new class \code{\link{mic}}, which treats the input as decimal numbers, while maintaining operators (such as ">=") and only allowing valid MIC values known to the field of (medical) microbiology.
|
||||||
}
|
}
|
||||||
\details{
|
\details{
|
||||||
To interpret MIC values as SIR values, use \code{\link[=as.sir]{as.sir()}} on MIC values. It supports guidelines from EUCAST (2011-2025) and CLSI (2011-2025).
|
To interpret MIC values as SIR values, use \code{\link[=as.sir]{as.sir()}} on MIC values. It supports guidelines from EUCAST (2011-2026) and CLSI (2011-2026).
|
||||||
|
|
||||||
This class for MIC values is a quite a special data type: formally it is an ordered \link{factor} with valid MIC values as \link{factor} levels (to make sure only valid MIC values are retained), but for any mathematical operation it acts as decimal numbers:
|
This class for MIC values is a quite a special data type: formally it is an ordered \link{factor} with valid MIC values as \link{factor} levels (to make sure only valid MIC values are retained), but for any mathematical operation it acts as decimal numbers:
|
||||||
|
|
||||||
\if{html}{\out{<div class="sourceCode">}}\preformatted{x <- random_mic(10)
|
\if{html}{\out{<div class="sourceCode">}}\preformatted{x <- random_mic(10)
|
||||||
x
|
x
|
||||||
#> Class 'mic'
|
#> Class <mic>
|
||||||
#> [1] 16 1 8 8 64 >=128 0.0625 32 32 16
|
#> [1] 16 1 8 8 64 >=128 0.0625 32 32 16
|
||||||
|
|
||||||
is.factor(x)
|
is.factor(x)
|
||||||
@@ -72,7 +72,7 @@ median(x)
|
|||||||
This makes it possible to maintain operators that often come with MIC values, such ">=" and "<=", even when filtering using \link{numeric} values in data analysis, e.g.:
|
This makes it possible to maintain operators that often come with MIC values, such ">=" and "<=", even when filtering using \link{numeric} values in data analysis, e.g.:
|
||||||
|
|
||||||
\if{html}{\out{<div class="sourceCode">}}\preformatted{x[x > 4]
|
\if{html}{\out{<div class="sourceCode">}}\preformatted{x[x > 4]
|
||||||
#> Class 'mic'
|
#> Class <mic>
|
||||||
#> [1] 16 8 8 64 >=128 32 32 16
|
#> [1] 16 8 8 64 >=128 32 32 16
|
||||||
|
|
||||||
df <- data.frame(x, hospital = "A")
|
df <- data.frame(x, hospital = "A")
|
||||||
|
|||||||
@@ -16,11 +16,11 @@
|
|||||||
\source{
|
\source{
|
||||||
For interpretations of minimum inhibitory concentration (MIC) values and disk diffusion diameters:
|
For interpretations of minimum inhibitory concentration (MIC) values and disk diffusion diameters:
|
||||||
\itemize{
|
\itemize{
|
||||||
\item \strong{CLSI M39: Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data}, 2011-2025, \emph{Clinical and Laboratory Standards Institute} (CLSI). \url{https://clsi.org/standards/products/microbiology/documents/m39/}.
|
\item \strong{CLSI M39: Analysis and Presentation of Cumulative Antimicrobial Susceptibility Test Data}, 2011-2026, \emph{Clinical and Laboratory Standards Institute} (CLSI). \url{https://clsi.org/standards/products/microbiology/documents/m39/}.
|
||||||
\item \strong{CLSI M100: Performance Standard for Antimicrobial Susceptibility Testing}, 2011-2025, \emph{Clinical and Laboratory Standards Institute} (CLSI). \url{https://clsi.org/standards/products/microbiology/documents/m100/}.
|
\item \strong{CLSI M100: Performance Standard for Antimicrobial Susceptibility Testing}, 2011-2026, \emph{Clinical and Laboratory Standards Institute} (CLSI). \url{https://clsi.org/standards/products/microbiology/documents/m100/}.
|
||||||
\item \strong{CLSI VET01: Performance Standards for Antimicrobial Disk and Dilution Susceptibility Tests for Bacteria Isolated From Animals}, 2019-2025, \emph{Clinical and Laboratory Standards Institute} (CLSI). \url{https://clsi.org/standards/products/veterinary-medicine/documents/vet01/}.
|
\item \strong{CLSI VET01: Performance Standards for Antimicrobial Disk and Dilution Susceptibility Tests for Bacteria Isolated From Animals}, 2019-2026, \emph{Clinical and Laboratory Standards Institute} (CLSI). \url{https://clsi.org/standards/products/veterinary-medicine/documents/vet01/}.
|
||||||
\item \strong{EUCAST Breakpoint tables for interpretation of MICs and zone diameters}, 2011-2025, \emph{European Committee on Antimicrobial Susceptibility Testing} (EUCAST). \url{https://www.eucast.org/bacteria/clinical-breakpoints-and-interpretation/clinical-breakpoint-tables/}.
|
\item \strong{EUCAST Breakpoint tables for interpretation of MICs and zone diameters}, 2011-2026, \emph{European Committee on Antimicrobial Susceptibility Testing} (EUCAST). \url{https://www.eucast.org/bacteria/clinical-breakpoints-and-interpretation/clinical-breakpoint-tables/}.
|
||||||
\item \strong{WHONET} as a source for machine-reading the clinical breakpoints (\href{https://amr-for-r.org/reference/clinical_breakpoints.html#imported-from-whonet}{read more here}), 1989-2025, \emph{WHO Collaborating Centre for Surveillance of Antimicrobial Resistance}. \url{https://whonet.org/}.
|
\item \strong{WHONET} as a source for machine-reading the clinical breakpoints (\href{https://amr-for-r.org/reference/clinical_breakpoints.html#imported-from-whonet}{read more here}), 1989-2026, \emph{WHO Collaborating Centre for Surveillance of Antimicrobial Resistance}. \url{https://whonet.org/}.
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
\usage{
|
\usage{
|
||||||
@@ -94,7 +94,7 @@ Otherwise: arguments passed on to methods.}
|
|||||||
|
|
||||||
\item{ab}{A vector (or column name) with \link{character}s that can be coerced to a valid antimicrobial drug code with \code{\link[=as.ab]{as.ab()}}.}
|
\item{ab}{A vector (or column name) with \link{character}s that can be coerced to a valid antimicrobial drug code with \code{\link[=as.ab]{as.ab()}}.}
|
||||||
|
|
||||||
\item{guideline}{A guideline name (or column name) to use for SIR interpretation. Defaults to EUCAST 2025 (the latest implemented EUCAST guideline in the \link{clinical_breakpoints} data set), but can be set with the package option \code{\link[=AMR-options]{AMR_guideline}}. Currently supports EUCAST (2011-2025) and CLSI (2011-2025), see \emph{Details}. Using a column name allows for straightforward interpretation of historical data, which must be analysed in the context of, for example, different years.}
|
\item{guideline}{A guideline name (or column name) to use for SIR interpretation. Defaults to EUCAST 2026 (the latest implemented EUCAST guideline in the \link{clinical_breakpoints} data set), but can be set with the package option \code{\link[=AMR-options]{AMR_guideline}}. Currently supports EUCAST (2011-2026) and CLSI (2011-2026), see \emph{Details}. Using a column name allows for straightforward interpretation of historical data, which must be analysed in the context of, for example, different years.}
|
||||||
|
|
||||||
\item{uti}{(Urinary Tract Infection) a vector (or column name) with \link{logical}s (\code{TRUE} or \code{FALSE}) to specify whether a UTI specific interpretation from the guideline should be chosen. For using \code{\link[=as.sir]{as.sir()}} on a \link{data.frame}, this can also be a column containing \link{logical}s or when left blank, the data set will be searched for a column 'specimen', and rows within this column containing 'urin' (such as 'urine', 'urina') will be regarded isolates from a UTI. See \emph{Examples}.}
|
\item{uti}{(Urinary Tract Infection) a vector (or column name) with \link{logical}s (\code{TRUE} or \code{FALSE}) to specify whether a UTI specific interpretation from the guideline should be chosen. For using \code{\link[=as.sir]{as.sir()}} on a \link{data.frame}, this can also be a column containing \link{logical}s or when left blank, the data set will be searched for a column 'specimen', and rows within this column containing 'urin' (such as 'urine', 'urina') will be regarded isolates from a UTI. See \emph{Examples}.}
|
||||||
|
|
||||||
@@ -162,7 +162,7 @@ Ordered \link{factor} with new class \code{sir}
|
|||||||
\description{
|
\description{
|
||||||
Clean up existing SIR values, or interpret minimum inhibitory concentration (MIC) values and disk diffusion diameters according to EUCAST or CLSI. \code{\link[=as.sir]{as.sir()}} transforms the input to a new class \code{\link{sir}}, which is an ordered \link{factor} containing the levels \code{S}, \code{SDD}, \code{I}, \code{R}, \code{NI}.
|
Clean up existing SIR values, or interpret minimum inhibitory concentration (MIC) values and disk diffusion diameters according to EUCAST or CLSI. \code{\link[=as.sir]{as.sir()}} transforms the input to a new class \code{\link{sir}}, which is an ordered \link{factor} containing the levels \code{S}, \code{SDD}, \code{I}, \code{R}, \code{NI}.
|
||||||
|
|
||||||
Breakpoints are currently implemented from EUCAST 2011-2025 and CLSI 2011-2025, see \emph{Details}. All breakpoints used for interpretation are available in our \link{clinical_breakpoints} data set.
|
Breakpoints are currently implemented from EUCAST 2011-2026 and CLSI 2011-2026, see \emph{Details}. All breakpoints used for interpretation are available in our \link{clinical_breakpoints} data set.
|
||||||
}
|
}
|
||||||
\details{
|
\details{
|
||||||
\emph{Note: The clinical breakpoints in this package were validated through, and imported from, \href{https://whonet.org}{WHONET}. The public use of this \code{AMR} package has been endorsed by both CLSI and EUCAST. See \link{clinical_breakpoints} for more information.}
|
\emph{Note: The clinical breakpoints in this package were validated through, and imported from, \href{https://whonet.org}{WHONET}. The public use of this \code{AMR} package has been endorsed by both CLSI and EUCAST. See \link{clinical_breakpoints} for more information.}
|
||||||
@@ -215,12 +215,12 @@ as.sir(your_data, ..., parallel = TRUE)
|
|||||||
|
|
||||||
For interpreting MIC values as well as disk diffusion diameters, currently implemented guidelines are:
|
For interpreting MIC values as well as disk diffusion diameters, currently implemented guidelines are:
|
||||||
\itemize{
|
\itemize{
|
||||||
\item For \strong{clinical microbiology}: EUCAST 2011-2025 and CLSI 2011-2025;
|
\item For \strong{clinical microbiology}: EUCAST 2011-2026 and CLSI 2011-2026;
|
||||||
\item For \strong{veterinary microbiology}: EUCAST 2021-2025 and CLSI 2019-2025;
|
\item For \strong{veterinary microbiology}: EUCAST 2021-2026 and CLSI 2019-2026;
|
||||||
\item For \strong{ECOFFs} (Epidemiological Cut-off Values): EUCAST 2020-2025 and CLSI 2022-2025.
|
\item For \strong{ECOFFs} (Epidemiological Cut-off Values): EUCAST 2020-2026 and CLSI 2022-2026.
|
||||||
}
|
}
|
||||||
|
|
||||||
The \code{guideline} argument must be set to e.g., \code{"EUCAST 2025"} or \code{"CLSI 2025"}. By simply using \code{"EUCAST"} (the default) or \code{"CLSI"} as input, the latest included version of that guideline will automatically be selected. Importantly, using a column name of your data instead, allows for straightforward interpretation of historical data that must be analysed in the context of, for example, different years.
|
The \code{guideline} argument must be set to e.g., \code{"EUCAST 2026"} or \code{"CLSI 2026"}. By simply using \code{"EUCAST"} (the default) or \code{"CLSI"} as input, the latest included version of that guideline will automatically be selected. Importantly, using a column name of your data instead, allows for straightforward interpretation of historical data that must be analysed in the context of, for example, different years.
|
||||||
|
|
||||||
You can set your own data set using the \code{reference_data} argument. The \code{guideline} argument will then be ignored.
|
You can set your own data set using the \code{reference_data} argument. The \code{guideline} argument will then be ignored.
|
||||||
|
|
||||||
|
|||||||
@@ -5,7 +5,7 @@
|
|||||||
\alias{clinical_breakpoints}
|
\alias{clinical_breakpoints}
|
||||||
\title{Data Set with Clinical Breakpoints for SIR Interpretation}
|
\title{Data Set with Clinical Breakpoints for SIR Interpretation}
|
||||||
\format{
|
\format{
|
||||||
A \link[tibble:tibble]{tibble} with 40 217 observations and 14 variables:
|
A \link[tibble:tibble]{tibble} with 45 797 observations and 14 variables:
|
||||||
\itemize{
|
\itemize{
|
||||||
\item \code{guideline}\cr Name of the guideline
|
\item \code{guideline}\cr Name of the guideline
|
||||||
\item \code{type}\cr Breakpoint type, either "ECOFF", "animal", or "human"
|
\item \code{type}\cr Breakpoint type, either "ECOFF", "animal", or "human"
|
||||||
@@ -20,7 +20,7 @@ A \link[tibble:tibble]{tibble} with 40 217 observations and 14 variables:
|
|||||||
\item \code{breakpoint_S}\cr Lowest MIC value or highest number of millimetres that leads to "S"
|
\item \code{breakpoint_S}\cr Lowest MIC value or highest number of millimetres that leads to "S"
|
||||||
\item \code{breakpoint_R}\cr Highest MIC value or lowest number of millimetres that leads to "R", can be \code{NA}
|
\item \code{breakpoint_R}\cr Highest MIC value or lowest number of millimetres that leads to "R", can be \code{NA}
|
||||||
\item \code{uti}\cr A \link{logical} value (\code{TRUE}/\code{FALSE}) to indicate whether the rule applies to a urinary tract infection (UTI)
|
\item \code{uti}\cr A \link{logical} value (\code{TRUE}/\code{FALSE}) to indicate whether the rule applies to a urinary tract infection (UTI)
|
||||||
\item \code{is_SDD}\cr A \link{logical} value (\code{TRUE}/\code{FALSE}) to indicate whether the intermediate range between "S" and "R" should be interpreted as "SDD", instead of "I". This currently applies to 48 breakpoints.
|
\item \code{is_SDD}\cr A \link{logical} value (\code{TRUE}/\code{FALSE}) to indicate whether the intermediate range between "S" and "R" should be interpreted as "SDD", instead of "I". This currently applies to 72 breakpoints.
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
\usage{
|
\usage{
|
||||||
@@ -31,9 +31,9 @@ Data set containing clinical breakpoints to interpret MIC and disk diffusion to
|
|||||||
|
|
||||||
These breakpoints are currently implemented:
|
These breakpoints are currently implemented:
|
||||||
\itemize{
|
\itemize{
|
||||||
\item For \strong{clinical microbiology}: EUCAST 2011-2025 and CLSI 2011-2025;
|
\item For \strong{clinical microbiology}: EUCAST 2011-2026 and CLSI 2011-2026;
|
||||||
\item For \strong{veterinary microbiology}: EUCAST 2021-2025 and CLSI 2019-2025;
|
\item For \strong{veterinary microbiology}: EUCAST 2021-2026 and CLSI 2019-2026;
|
||||||
\item For \strong{ECOFFs} (Epidemiological Cut-off Values): EUCAST 2020-2025 and CLSI 2022-2025.
|
\item For \strong{ECOFFs} (Epidemiological Cut-off Values): EUCAST 2020-2026 and CLSI 2022-2026.
|
||||||
}
|
}
|
||||||
|
|
||||||
Use \code{\link[=as.sir]{as.sir()}} to transform MICs or disks measurements to SIR values.
|
Use \code{\link[=as.sir]{as.sir()}} to transform MICs or disks measurements to SIR values.
|
||||||
|
|||||||
@@ -3,9 +3,9 @@
|
|||||||
\docType{data}
|
\docType{data}
|
||||||
\name{microorganisms.codes}
|
\name{microorganisms.codes}
|
||||||
\alias{microorganisms.codes}
|
\alias{microorganisms.codes}
|
||||||
\title{Data Set with 6 036 Common Microorganism Codes}
|
\title{Data Set with 6 050 Common Microorganism Codes}
|
||||||
\format{
|
\format{
|
||||||
A \link[tibble:tibble]{tibble} with 6 036 observations and 2 variables:
|
A \link[tibble:tibble]{tibble} with 6 050 observations and 2 variables:
|
||||||
\itemize{
|
\itemize{
|
||||||
\item \code{code}\cr Commonly used code of a microorganism. \emph{\strong{This is a unique identifier.}}
|
\item \code{code}\cr Commonly used code of a microorganism. \emph{\strong{This is a unique identifier.}}
|
||||||
\item \code{mo}\cr ID of the microorganism in the \link{microorganisms} data set
|
\item \code{mo}\cr ID of the microorganism in the \link{microorganisms} data set
|
||||||
|
|||||||
@@ -58,7 +58,7 @@ It has now created a file \code{"~/mo_source.rds"} with the contents of our Exce
|
|||||||
And now we can use it in our functions:
|
And now we can use it in our functions:
|
||||||
|
|
||||||
\if{html}{\out{<div class="sourceCode">}}\preformatted{as.mo("lab_mo_ecoli")
|
\if{html}{\out{<div class="sourceCode">}}\preformatted{as.mo("lab_mo_ecoli")
|
||||||
#> Class 'mo'
|
#> Class <mo>
|
||||||
#> [1] B_ESCHR_COLI
|
#> [1] B_ESCHR_COLI
|
||||||
|
|
||||||
mo_genus("lab_mo_kpneumoniae")
|
mo_genus("lab_mo_kpneumoniae")
|
||||||
@@ -68,7 +68,7 @@ mo_genus("lab_mo_kpneumoniae")
|
|||||||
as.mo(c("Escherichia coli", "E. coli", "lab_mo_ecoli"))
|
as.mo(c("Escherichia coli", "E. coli", "lab_mo_ecoli"))
|
||||||
#> NOTE: Translation to one microorganism was guessed with uncertainty.
|
#> NOTE: Translation to one microorganism was guessed with uncertainty.
|
||||||
#> Use mo_uncertainties() to review it.
|
#> Use mo_uncertainties() to review it.
|
||||||
#> Class 'mo'
|
#> Class <mo>
|
||||||
#> [1] B_ESCHR_COLI B_ESCHR_COLI B_ESCHR_COLI
|
#> [1] B_ESCHR_COLI B_ESCHR_COLI B_ESCHR_COLI
|
||||||
}\if{html}{\out{</div>}}
|
}\if{html}{\out{</div>}}
|
||||||
|
|
||||||
@@ -89,7 +89,7 @@ If we edit the Excel file by, let's say, adding row 4 like this:
|
|||||||
#> NOTE: Updated mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
|
#> NOTE: Updated mo_source file '/Users/me/mo_source.rds' (0.3 kB) from
|
||||||
#> '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
|
#> '/Users/me/Documents/ourcodes.xlsx' (9 kB), columns
|
||||||
#> "Organisation XYZ" and "mo"
|
#> "Organisation XYZ" and "mo"
|
||||||
#> Class 'mo'
|
#> Class <mo>
|
||||||
#> [1] B_ESCHR_COLI
|
#> [1] B_ESCHR_COLI
|
||||||
|
|
||||||
mo_genus("lab_Staph_aureus")
|
mo_genus("lab_Staph_aureus")
|
||||||
|
|||||||
@@ -201,7 +201,7 @@ This package contains more functions that extend the \code{ggplot2} package, to
|
|||||||
|
|
||||||
The interpretation of "I" will be named "Increased exposure" for all EUCAST guidelines since 2019, and will be named "Intermediate" in all other cases.
|
The interpretation of "I" will be named "Increased exposure" for all EUCAST guidelines since 2019, and will be named "Intermediate" in all other cases.
|
||||||
|
|
||||||
For interpreting MIC values as well as disk diffusion diameters, the default guideline is EUCAST 2025, unless the package option \code{\link[=AMR-options]{AMR_guideline}} is set. See \code{\link[=as.sir]{as.sir()}} for more information.
|
For interpreting MIC values as well as disk diffusion diameters, the default guideline is EUCAST 2026, unless the package option \code{\link[=AMR-options]{AMR_guideline}} is set. See \code{\link[=as.sir]{as.sir()}} for more information.
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
\examples{
|
\examples{
|
||||||
|
|||||||
@@ -219,7 +219,6 @@ test_that("test-eucast_rules.R", {
|
|||||||
expect_inherits(eucast_dosage(c("tobra", "genta", "cipro")), "data.frame")
|
expect_inherits(eucast_dosage(c("tobra", "genta", "cipro")), "data.frame")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
x <- custom_eucast_rules(
|
x <- custom_eucast_rules(
|
||||||
AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
|
AMC == "R" & genus == "Klebsiella" ~ aminopenicillins == "R",
|
||||||
AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I",
|
AMC == "I" & genus == "Klebsiella" ~ aminopenicillins == "I",
|
||||||
|
|||||||
@@ -270,10 +270,8 @@ test_that("test-mo.R", {
|
|||||||
))),
|
))),
|
||||||
c("B_MCRBC_PRXY", "B_STRPT_SUIS", "B_KLBSL_TRRG")
|
c("B_MCRBC_PRXY", "B_STRPT_SUIS", "B_KLBSL_TRRG")
|
||||||
)
|
)
|
||||||
expect_output(print(mo_uncertainties()))
|
|
||||||
x <- as.mo("Sta. aur")
|
x <- as.mo("Sta. aur")
|
||||||
# many hits
|
|
||||||
expect_output(print(mo_uncertainties()))
|
|
||||||
|
|
||||||
# no viruses
|
# no viruses
|
||||||
expect_equal(suppressWarnings(as.mo("Virus")), as.mo("UNKNOWN"))
|
expect_equal(suppressWarnings(as.mo("Virus")), as.mo("UNKNOWN"))
|
||||||
|
|||||||
@@ -138,7 +138,6 @@ test_that("test-proportion.R", {
|
|||||||
expect_error(proportion_I("test", as_percent = "test"))
|
expect_error(proportion_I("test", as_percent = "test"))
|
||||||
expect_error(proportion_S("test", minimum = "test"))
|
expect_error(proportion_S("test", minimum = "test"))
|
||||||
expect_error(proportion_S("test", as_percent = "test"))
|
expect_error(proportion_S("test", as_percent = "test"))
|
||||||
expect_error(proportion_S("test", also_single_tested = TRUE))
|
|
||||||
|
|
||||||
# check too low amount of isolates
|
# check too low amount of isolates
|
||||||
expect_identical(
|
expect_identical(
|
||||||
|
|||||||
@@ -120,7 +120,7 @@ test_that("test-sir.R", {
|
|||||||
# allow for guideline length > 1
|
# allow for guideline length > 1
|
||||||
expect_equal(
|
expect_equal(
|
||||||
AMR:::get_guideline(c("CLSI", "CLSI", "CLSI2023", "EUCAST", "EUCAST2020"), AMR::clinical_breakpoints),
|
AMR:::get_guideline(c("CLSI", "CLSI", "CLSI2023", "EUCAST", "EUCAST2020"), AMR::clinical_breakpoints),
|
||||||
c("CLSI 2025", "CLSI 2025", "CLSI 2023", "EUCAST 2025", "EUCAST 2020")
|
c("CLSI 2026", "CLSI 2026", "CLSI 2023", "EUCAST 2026", "EUCAST 2020")
|
||||||
)
|
)
|
||||||
|
|
||||||
# these are used in the script
|
# these are used in the script
|
||||||
|
|||||||
@@ -36,6 +36,7 @@ test_that("test-zzz.R", {
|
|||||||
# functions used by import_fn()
|
# functions used by import_fn()
|
||||||
import_functions <- c(
|
import_functions <- c(
|
||||||
"%chin%" = "data.table",
|
"%chin%" = "data.table",
|
||||||
|
"ansi_has_hyperlink_support" = "cli",
|
||||||
"anti_join" = "dplyr",
|
"anti_join" = "dplyr",
|
||||||
"as.data.table" = "data.table",
|
"as.data.table" = "data.table",
|
||||||
"as_tibble" = "tibble",
|
"as_tibble" = "tibble",
|
||||||
@@ -79,6 +80,12 @@ test_that("test-zzz.R", {
|
|||||||
"freq.default" = "cleaner",
|
"freq.default" = "cleaner",
|
||||||
"percentage" = "cleaner",
|
"percentage" = "cleaner",
|
||||||
# cli
|
# cli
|
||||||
|
"ansi_has_hyperlink_support" = "cli",
|
||||||
|
"cli_abort" = "cli",
|
||||||
|
"cli_inform" = "cli",
|
||||||
|
"cli_warn" = "cli",
|
||||||
|
"code_highlight" = "cli",
|
||||||
|
"format_inline" = "cli",
|
||||||
"symbol" = "cli",
|
"symbol" = "cli",
|
||||||
# curl
|
# curl
|
||||||
"has_internet" = "curl",
|
"has_internet" = "curl",
|
||||||
@@ -124,6 +131,8 @@ test_that("test-zzz.R", {
|
|||||||
"availableCores" = "parallelly",
|
"availableCores" = "parallelly",
|
||||||
# pillar
|
# pillar
|
||||||
"pillar_shaft" = "pillar",
|
"pillar_shaft" = "pillar",
|
||||||
|
"style_na" = "pillar",
|
||||||
|
"style_subtle" = "pillar",
|
||||||
"tbl_format_footer" = "pillar",
|
"tbl_format_footer" = "pillar",
|
||||||
"tbl_sum" = "pillar",
|
"tbl_sum" = "pillar",
|
||||||
"type_sum" = "pillar",
|
"type_sum" = "pillar",
|
||||||
@@ -161,7 +170,9 @@ test_that("test-zzz.R", {
|
|||||||
"vec_math" = "vctrs",
|
"vec_math" = "vctrs",
|
||||||
"vec_ptype2" = "vctrs",
|
"vec_ptype2" = "vctrs",
|
||||||
"vec_ptype_abbr" = "vctrs",
|
"vec_ptype_abbr" = "vctrs",
|
||||||
"vec_ptype_full" = "vctrs"
|
"vec_ptype_full" = "vctrs",
|
||||||
|
# usethis
|
||||||
|
"use_course" = "usethis"
|
||||||
)
|
)
|
||||||
|
|
||||||
import_functions <- c(import_functions, call_functions)
|
import_functions <- c(import_functions, call_functions)
|
||||||
|
|||||||
Reference in New Issue
Block a user