1
0
mirror of https://github.com/msberends/AMR.git synced 2026-03-31 00:16:08 +02:00

5 Commits

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

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b
2026-03-18 20:06:52 +00:00
Claude
4798d2c55e Replace {.fun} with {.help} for all exported functions in messaging
All function names referenced via {.fun …} in cli-style messages are
exported in NAMESPACE, so {.help …} is the appropriate markup — it
renders as a clickable help link rather than plain function styling.

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b
2026-03-18 16:06:30 +00:00
Claude
ad31fba556 Modernise messaging infrastructure with cli support
Rewrites message_(), warning_(), stop_() to use cli::cli_inform(),
cli::cli_warn(), and cli::cli_abort() when the cli package is available,
with a fully functional plain-text fallback for environments without cli.

Key changes:
- New cli_to_plain() helper converts cli inline markup ({.fun}, {.arg},
  {.val}, {.field}, {.cls}, {.pkg}, {.href}, {.url}, etc.) to readable
  plain-text equivalents for the non-cli fallback path
- word_wrap() simplified: drops add_fn, ANSI re-index algorithm, RStudio
  link injection, and operator spacing hack; returns pasted input unchanged
  when cli is available
- stop_() no longer references AMR_env$cli_abort; uses pkg_is_available()
  directly; passes sys.call() objects to cli::cli_abort() call= argument
- Removed add_fn parameter from message_(), warning_(), and word_wrap()
- All call sites across R/ updated: add_fn arguments removed, some paste0-
  based string construction converted to cli glue syntax ({.fun as.mo},
  {.arg col_mo}, {n} results, etc.)
- cli already listed in Suggests; no DESCRIPTION dependency changes needed

https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b
2026-03-18 12:10:17 +00:00
8439e9c1d2 (v3.0.1.9035) fix loading in Positron 2026-03-18 10:32:11 +01:00
4dc3ec0008 (v3.0.1.9034) Add amr_course() 2026-03-11 16:07:31 +01:00
25 changed files with 374 additions and 307 deletions

View File

@@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 3.0.1.9033 Version: 3.0.1.9036
Date: 2026-03-09 Date: 2026-03-18
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

View File

@@ -172,6 +172,7 @@ export(all_sir_predictors)
export(aminoglycosides) export(aminoglycosides)
export(aminopenicillins) export(aminopenicillins)
export(amr_class) export(amr_class)
export(amr_course)
export(amr_distance_from_row) export(amr_distance_from_row)
export(amr_selector) export(amr_selector)
export(anti_join_microorganisms) export(anti_join_microorganisms)

15
NEWS.md
View File

@@ -1,4 +1,12 @@
# AMR 3.0.1.9033 # AMR 3.0.1.9036
### 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
* 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`
@@ -13,9 +21,9 @@
- `as.sir()` gained an argument `as_wt_nwt`, which defaults to `TRUE` only when `breakpoint_type = "ECOFF"` (#254) - `as.sir()` gained an argument `as_wt_nwt`, which defaults to `TRUE` only when `breakpoint_type = "ECOFF"` (#254)
- This transforms the output from S/R to WT/NWT - This transforms the output from S/R to WT/NWT
- Functions such as `susceptibility()` count WT as S and NWT as R - Functions such as `susceptibility()` count WT as S and NWT as R
* `interpretive_rules()`, which allows future implementation of CLSI interpretive rules (#235) * Function `interpretive_rules()`, which allows future implementation of CLSI interpretive rules (#235)
- `eucast_rules()` has become a wrapper around that function - `eucast_rules()` has become a wrapper around that function
* Two new `NA` objects, `NA_ab_` and `NA_mo_`, analogous to base R's `NA_character_` and `NA_integer_`, for use in pipelines that require typed missing values * Function `amr_course()`, which allows for automated download and unpacking of a GitHub repository for e.g. webinar use
### Fixes ### Fixes
* Fixed a bug in `as.sir()` where values that were purely numeric (e.g., `"1"`) and matched the broad SIR-matching regex would be incorrectly stripped of all content by the Unicode letter filter * Fixed a bug in `as.sir()` where values that were purely numeric (e.g., `"1"`) and matched the broad SIR-matching regex would be incorrectly stripped of all content by the Unicode letter filter
@@ -43,6 +51,7 @@
* This results in more reliable behaviour compared to previous versions for capped MIC values * This results in more reliable behaviour compared to previous versions for capped MIC values
* Removed the `"inverse"` option, which has now become redundant * Removed the `"inverse"` option, which has now become redundant
* `ab_group()` now returns values consist with the AMR selectors (#246) * `ab_group()` now returns values consist with the AMR selectors (#246)
* Added two new `NA` objects, `NA_ab_` and `NA_mo_`, analogous to base R's `NA_character_` and `NA_integer_`, for use in pipelines that require typed missing values
# AMR 3.0.1 # AMR 3.0.1

View File

@@ -305,8 +305,7 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
# this column should contain logicals # this column should contain logicals
if (!is.logical(x[, found, drop = TRUE])) { if (!is.logical(x[, found, drop = TRUE])) {
message_("Column '", font_bold(found), "' found as input for `", ifelse(add_col_prefix, "col_", ""), type, message_("Column '", font_bold(found), "' found as input for `", ifelse(add_col_prefix, "col_", ""), type,
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored.", "`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored."
add_fn = font_red
) )
found <- NULL found <- NULL
} }
@@ -387,17 +386,18 @@ 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" && tryCatch(!rstudioapi::isAvailable(), error = function(e) TRUE)) { if (pkg == "rstudioapi" && !in_rstudio()) {
# only allow rstudioapi to be imported if RStudio is available # only allow rstudioapi to be imported if we're in RStudio
return(NULL) return(NULL)
} }
tryCatch( tryCatch(
# don't use get() to avoid fetching non-API functions # don't use get() to avoid fetching non-API functions
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 `", name, "()` is not an exported object from package '", pkg,
"'. Please create an issue at ", font_url("https://github.com/msberends/AMR/issues"), ". Many thanks!", "'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
call = FALSE call = FALSE
) )
} else { } else {
@@ -407,30 +407,99 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
) )
} }
# Convert cli glue markup to plain text for the non-cli fallback path.
# Called by message_(), warning_(), and stop_() when cli is not available.
cli_to_plain <- function(msg, envir = parent.frame()) {
resolve <- function(x) {
# If x looks like {expr}, evaluate the inner expression
if (grepl("^\\{.+\\}$", x)) {
inner <- substring(x, 2L, nchar(x) - 1L)
tryCatch(
paste0(as.character(eval(parse(text = inner), envir = envir)), collapse = ", "),
error = function(e) x
)
} else {
x
}
}
apply_sub <- function(msg, pattern, formatter) {
while (grepl(pattern, msg, perl = TRUE)) {
m <- regexec(pattern, msg, perl = TRUE)
matches <- regmatches(msg, m)[[1]]
if (length(matches) < 2L) break
full_match <- matches[1L]
content <- matches[2L]
replacement <- formatter(content)
idx <- regexpr(full_match, msg, fixed = TRUE)
if (idx == -1L) break
msg <- paste0(
substr(msg, 1L, idx - 1L),
replacement,
substr(msg, idx + nchar(full_match), nchar(msg))
)
}
msg
}
# cli inline markup -> plain-text equivalents (one level of glue nesting allowed)
msg <- apply_sub(msg, "\\{\\.fun (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "()`"))
msg <- apply_sub(msg, "\\{\\.arg (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "`"))
msg <- apply_sub(msg, "\\{\\.code (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "`"))
msg <- apply_sub(msg, "\\{\\.val (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0('"', resolve(c), '"'))
msg <- apply_sub(msg, "\\{\\.field (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0('"', resolve(c), '"'))
msg <- apply_sub(msg, "\\{\\.cls (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("<", resolve(c), ">"))
msg <- apply_sub(msg, "\\{\\.pkg (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
msg <- apply_sub(msg, "\\{\\.strong (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
msg <- apply_sub(msg, "\\{\\.emph (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
msg <- apply_sub(msg, "\\{\\.help (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "`"))
msg <- apply_sub(msg, "\\{\\.url (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
msg <- apply_sub(msg, "\\{\\.href ([^}]+)\\}", function(c) strsplit(resolve(c), " ", fixed = TRUE)[[1L]][1L])
# bare {variable} or {expression} -> evaluate in caller's environment
while (grepl("\\{[^{}]+\\}", msg)) {
m <- regexec("\\{([^{}]+)\\}", msg, perl = TRUE)
matches <- regmatches(msg, m)[[1]]
if (length(matches) < 2L) break
full_match <- matches[1L]
inner <- matches[2L]
replacement <- tryCatch(
paste0(as.character(eval(parse(text = inner), envir = envir)), collapse = ", "),
error = function(e) full_match
)
idx <- regexpr(full_match, msg, fixed = TRUE)
if (idx == -1L) break
msg <- paste0(
substr(msg, 1L, idx - 1L),
replacement,
substr(msg, idx + nchar(full_match), nchar(msg))
)
}
msg
}
# this alternative wrapper to the message(), warning() and stop() functions: # this alternative wrapper to the message(), warning() and stop() functions:
# - wraps text to never break lines within words # - wraps text to never break lines within words (plain-text fallback only)
# - ignores formatted text while wrapping # - adds indentation for note-style messages (plain-text fallback only)
# - adds indentation dependent on the type of message (such as NOTE) # When cli is available this just returns the pasted input; cli handles formatting.
# - can add additional formatting functions like blue or bold text
word_wrap <- function(..., word_wrap <- function(...,
add_fn = list(),
as_note = FALSE, as_note = FALSE,
width = 0.95 * getOption("width"), width = 0.95 * getOption("width"),
extra_indent = 0) { extra_indent = 0) {
if (pkg_is_available("cli")) {
return(paste0(c(...), collapse = ""))
}
msg <- paste0(c(...), collapse = "") msg <- paste0(c(...), collapse = "")
if (isTRUE(as_note)) { if (isTRUE(as_note)) {
msg <- paste0(AMR_env$info_icon, " ", gsub("^note:? ?", "", msg, ignore.case = TRUE)) msg <- paste0(AMR_env$info_icon, " ", gsub("^note:? ?", "", msg, ignore.case = TRUE))
} }
if (grepl("\n", msg, fixed = TRUE)) {
if (msg %like% "\n") {
# run word_wraps() over every line here, bind them and return again
return(paste0( return(paste0(
vapply( vapply(
FUN.VALUE = character(1), FUN.VALUE = character(1),
trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"), trimws(unlist(strsplit(msg, "\n", fixed = TRUE)), which = "right"),
word_wrap, word_wrap,
add_fn = add_fn,
as_note = FALSE, as_note = FALSE,
width = width, width = width,
extra_indent = extra_indent extra_indent = extra_indent
@@ -438,146 +507,75 @@ word_wrap <- function(...,
collapse = "\n" collapse = "\n"
)) ))
} }
wrapped <- paste0(strwrap(msg, width = width), collapse = "\n")
# correct for operators (will add the space later on) if (grepl("\u2139 ", msg, fixed = TRUE)) {
ops <- "([,./><\\]\\[])" indentation <- 2L + extra_indent
msg <- gsub(paste0(ops, " ", ops), "\\1\\2", msg, perl = TRUE) } else if (grepl("^=> ", msg)) {
# we need to correct for already applied style, that adds text like "\033[31m\" indentation <- 3L + extra_indent
msg_stripped <- gsub("(.*)?\\033\\]8;;.*\\a(.*?)\\033\\]8;;\\a(.*)", "\\1\\2\\3", msg, perl = TRUE) # for font_url()
msg_stripped <- font_stripstyle(msg_stripped)
# where are the spaces now?
msg_stripped_wrapped <- paste0(
strwrap(msg_stripped,
simplify = TRUE,
width = width
),
collapse = "\n"
)
msg_stripped_wrapped <- paste0(unlist(strsplit(msg_stripped_wrapped, "(\n|\\*\\|\\*)")),
collapse = "\n"
)
msg_stripped_spaces <- which(unlist(strsplit(msg_stripped, "", fixed = TRUE)) == " ")
msg_stripped_wrapped_spaces <- which(unlist(strsplit(msg_stripped_wrapped, "", fixed = TRUE)) != "\n")
# so these are the indices of spaces that need to be replaced
replace_spaces <- which(!msg_stripped_spaces %in% msg_stripped_wrapped_spaces)
# put it together
msg <- unlist(strsplit(msg, " ", fixed = TRUE))
msg[replace_spaces] <- paste0(msg[replace_spaces], "\n")
# add space around operators again
msg <- gsub(paste0(ops, ops), "\\1 \\2", msg, perl = TRUE)
msg <- paste0(msg, collapse = " ")
msg <- gsub("\n ", "\n", msg, fixed = TRUE)
if (msg_stripped %like% "\u2139 ") {
indentation <- 2 + extra_indent
} else if (msg_stripped %like% "^=> ") {
indentation <- 3 + extra_indent
} else { } else {
indentation <- 0 + extra_indent indentation <- 0L + extra_indent
} }
msg <- gsub("\n", paste0("\n", strrep(" ", indentation)), msg, fixed = TRUE) if (indentation > 0L) {
# remove trailing empty characters wrapped <- gsub("\n", paste0("\n", strrep(" ", indentation)), wrapped, fixed = TRUE)
msg <- gsub("(\n| )+$", "", msg)
if (length(add_fn) > 0) {
if (!is.list(add_fn)) {
add_fn <- list(add_fn)
}
for (i in seq_len(length(add_fn))) {
msg <- add_fn[[i]](msg)
}
} }
gsub("(\n| )+$", "", wrapped)
# format backticks
if (pkg_is_available("cli") && in_rstudio() &&
tryCatch(getExportedValue("versionInfo", ns = asNamespace("rstudioapi"))()$version > "2023.6.0.0", error = function(e) {
return(FALSE)
})) {
# we are in a recent version of RStudio, so do something nice: add links to our help pages in the console.
parts <- strsplit(msg, "`", fixed = TRUE)[[1]]
cmds <- parts %in% paste0(ls(envir = asNamespace("AMR")), "()")
# functions with a dot are not allowed: https://github.com/rstudio/rstudio/issues/11273#issuecomment-1156193252
# lead them to the help page of our package
parts[cmds & parts %like% "[.]"] <- font_url(
url = paste0("ide:help:AMR::", gsub("()", "", parts[cmds & parts %like% "[.]"], fixed = TRUE)),
txt = parts[cmds & parts %like% "[.]"]
)
# datasets should give help page as well
parts[parts %in% c("antimicrobials", "microorganisms", "microorganisms.codes", "microorganisms.groups")] <- font_url(
url = paste0("ide:help:AMR::", gsub("()", "", parts[parts %in% c("antimicrobials", "microorganisms", "microorganisms.codes", "microorganisms.groups")], fixed = TRUE)),
txt = parts[parts %in% c("antimicrobials", "microorganisms", "microorganisms.codes", "microorganisms.groups")]
)
# text starting with `?` must also lead to the help page
parts[parts %like% "^[?].+"] <- font_url(
url = paste0("ide:help:AMR::", gsub("?", "", parts[parts %like% "^[?].+"], fixed = TRUE)),
txt = parts[parts %like% "^[?].+"]
)
msg <- paste0(parts, collapse = "`")
}
msg <- gsub("`(.+?)`", font_grey_bg("`\\1`"), msg)
# clean introduced whitespace in between fullstops
msg <- gsub("[.] +[.]", "..", msg)
# remove extra space that was introduced (e.g. "Smith et al. , 2022")
msg <- gsub(". ,", ".,", msg, fixed = TRUE)
msg <- gsub("[ ,", "[,", msg, fixed = TRUE)
msg <- gsub("/ /", "//", msg, fixed = TRUE)
msg
} }
message_ <- function(..., message_ <- function(...,
appendLF = TRUE, appendLF = TRUE,
add_fn = list(font_blue),
as_note = TRUE) { as_note = TRUE) {
message( if (pkg_is_available("cli")) {
word_wrap(..., msg <- paste0(c(...), collapse = "")
add_fn = add_fn, if (isTRUE(as_note)) {
as_note = as_note cli::cli_inform(c("i" = msg), .envir = parent.frame())
), } else {
appendLF = appendLF cli::cli_inform(msg, .envir = parent.frame())
) }
} else {
plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
message(word_wrap(plain_msg, as_note = as_note), appendLF = appendLF)
}
} }
warning_ <- function(..., warning_ <- function(...,
add_fn = list(),
immediate = FALSE, immediate = FALSE,
call = FALSE) { call = FALSE) {
warning( if (pkg_is_available("cli")) {
trimws2(word_wrap(..., msg <- paste0(c(...), collapse = "")
add_fn = add_fn, cli::cli_warn(msg, .envir = parent.frame())
as_note = FALSE } else {
)), plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())
immediate. = immediate, warning(trimws2(word_wrap(plain_msg, as_note = FALSE)), immediate. = immediate, call. = call)
call. = call }
)
} }
# this alternative to the stop() function: # this alternative to the stop() function:
# - adds the function name where the error was thrown # - adds the function name where the error was thrown (plain-text fallback)
# - wraps text to never break lines within words # - wraps text to never break lines within words (plain-text fallback)
stop_ <- function(..., call = TRUE) { stop_ <- function(..., call = TRUE) {
msg <- paste0(c(...), collapse = "") msg <- paste0(c(...), collapse = "")
msg_call <- "" if (pkg_is_available("cli")) {
if (!isFALSE(call)) {
if (isTRUE(call)) { if (isTRUE(call)) {
call <- as.character(sys.call(-1)[1]) call_obj <- sys.call(-1)
} else if (!isFALSE(call)) {
call_obj <- sys.call(call)
} else { } else {
# so you can go back more than 1 call, as used in sir_calc(), that now throws a reference to e.g. n_sir() call_obj <- NULL
call <- as.character(sys.call(call)[1])
} }
msg_call <- paste0("in ", call, "():") cli::cli_abort(msg, call = call_obj, .envir = parent.frame())
}
msg <- trimws2(word_wrap(msg, add_fn = list(), as_note = FALSE))
if (!is.null(AMR_env$cli_abort) && length(unlist(strsplit(msg, "\n", fixed = TRUE))) <= 1) {
if (is.character(call)) {
call <- as.call(str2lang(paste0(call, "()")))
} else {
call <- NULL
}
AMR_env$cli_abort(msg, call = call)
} else { } else {
stop(paste(msg_call, msg), call. = FALSE) msg_call <- ""
if (!isFALSE(call)) {
if (isTRUE(call)) {
call_name <- as.character(sys.call(-1)[1])
} else {
# go back more than 1 call, as used in sir_calc() to reference e.g. n_sir()
call_name <- as.character(sys.call(call)[1])
}
msg_call <- paste0("in ", call_name, "():")
}
plain_msg <- cli_to_plain(trimws2(word_wrap(msg, as_note = FALSE)), envir = parent.frame())
stop(paste(msg_call, plain_msg), call. = FALSE)
} }
} }
@@ -620,7 +618,7 @@ stop_ifnot <- function(expr, ..., call = TRUE) {
return_after_integrity_check <- function(value, type, check_vector) { return_after_integrity_check <- function(value, type, check_vector) {
if (!all(value[!is.na(value)] %in% check_vector)) { if (!all(value[!is.na(value)] %in% check_vector)) {
warning_(paste0("invalid ", type, ", NA generated")) warning_("invalid ", type, ", NA generated")
value[!value %in% check_vector] <- NA value[!value %in% check_vector] <- NA
} }
value value
@@ -930,7 +928,7 @@ ascertain_sir_classes <- function(x, obj_name) {
warning_( warning_(
"the data provided in argument `", obj_name, "the data provided in argument `", 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 'sir'. Eligible SIR column were now guessed. ",
"See `?as.sir`.", "See {.help AMR::as.sir}().",
immediate = TRUE immediate = TRUE
) )
sirs_eligible <- is_sir_eligible(x) sirs_eligible <- is_sir_eligible(x)

62
R/amr_course.R Normal file
View File

@@ -0,0 +1,62 @@
# ==================================================================== #
# TITLE: #
# AMR: An R Package for Working with Antimicrobial Resistance Data #
# #
# SOURCE CODE: #
# https://github.com/msberends/AMR #
# #
# PLEASE CITE THIS SOFTWARE AS: #
# Berends MS, Luz CF, Friedrich AW, et al. (2022). #
# AMR: An R Package for Working with Antimicrobial Resistance Data. #
# Journal of Statistical Software, 104(3), 1-31. #
# https://doi.org/10.18637/jss.v104.i03 #
# #
# Developed at the University of Groningen and the University Medical #
# Center Groningen in The Netherlands, in collaboration with many #
# colleagues from around the world, see our website. #
# #
# This R package is free software; you can freely use and distribute #
# it for both personal and commercial purposes under the terms of the #
# GNU General Public License version 2.0 (GNU GPL-2), as published by #
# the Free Software Foundation. #
# We created this package for both routine data analysis and academic #
# research and it was publicly released in the hope that it will be #
# useful, but it comes WITHOUT ANY WARRANTY OR LIABILITY. #
# #
# Visit our website for the full manual and a complete tutorial about #
# how to conduct AMR data analysis: https://amr-for-r.org #
# ==================================================================== #
#' Download and Unpack an AMR Course Repository
#'
#' Downloads and unpacks a GitHub repository containing course materials, using [usethis::use_course()]. This is a convenience wrapper intended for use in educational settings, such as workshops or tutorials associated with the AMR package.
#' @param github_repo A character string specifying the GitHub repository with username and repo name, e.g. `"https://github.com/username/repo"`.
#' @param branch A character string specifying the branch to download. Defaults to `"main"`.
#' @param ... Additional arguments passed on to [usethis::use_course()].
#' @details
#' This function constructs a ZIP archive URL from the provided `github_repo` and `branch`, then delegates to [usethis::use_course()] to handle the download and extraction.
#'
#' The function is designed for interactive use in course or workshop settings and is not intended for use in non-interactive or automated pipelines.
#' @return
#' Called for its side effect. [usethis::use_course()] will prompt the user to choose a destination and open the extracted project. Returns invisibly whatever [usethis::use_course()] returns.
#' @seealso [usethis::use_course()]
#' @export
#' @examples
#' \dontrun{
#'
#' # Let this run by users, e.g., webinar participants
#' amr_course("https://github.com/my_user_name/our_AMR_course")
#' }
amr_course <- function(github_repo, branch = "main", ...) {
if (!"usethis" %in% rownames(utils::installed.packages())) {
if ("rlang" %in% rownames(utils::installed.packages())) {
rlang::check_installed("usethis")
} else {
stop("Package usethis is not installed. Please run: install.packages(\"usethis\")", call. = FALSE)
}
}
url <- paste0(github_repo, "/archive/refs/heads/", branch, ".zip")
use_course <- import_fn("use_course", "usethis")
message("This will download and unpack the contents of a repository.\n")
use_course(url, ...)
}

View File

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

View File

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

View File

@@ -150,15 +150,15 @@ custom_eucast_rules <- function(...) {
) )
stop_if( stop_if(
identical(dots, "error"), identical(dots, "error"),
"rules must be a valid formula inputs (e.g., using '~'), see `?custom_eucast_rules`" "rules must be a valid formula inputs (e.g., using '~'), see {.help AMR::custom_eucast_rules}()"
) )
n_dots <- length(dots) n_dots <- length(dots)
stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using `?custom_eucast_rules`.") stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using {.help AMR::custom_eucast_rules}().")
out <- vector("list", n_dots) out <- vector("list", n_dots)
for (i in seq_len(n_dots)) { for (i in seq_len(n_dots)) {
stop_ifnot( stop_ifnot(
inherits(dots[[i]], "formula"), inherits(dots[[i]], "formula"),
"rule ", i, " must be a valid formula input (e.g., using '~'), see `?custom_eucast_rules`" "rule ", i, " must be a valid formula input (e.g., using '~'), see {.help AMR::custom_eucast_rules}()"
) )
# Query # Query
@@ -180,7 +180,7 @@ custom_eucast_rules <- function(...) {
result <- dots[[i]][[3]] result <- dots[[i]][[3]]
stop_ifnot( stop_ifnot(
deparse(result) %like% "==", deparse(result) %like% "==",
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see `?custom_eucast_rules`" "the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see {.help AMR::custom_eucast_rules}()"
) )
result_group <- as.character(result)[[2]] result_group <- as.character(result)[[2]]
result_group <- as.character(str2lang(result_group)) result_group <- as.character(str2lang(result_group))

View File

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

View File

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

View File

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

View File

@@ -56,11 +56,6 @@ format_eucast_version_nr <- function(version, markdown = TRUE) {
#' Apply Interpretive Rules #' Apply Interpretive Rules
#' #'
#' @description #' @description
#' **WORK IN PROGRESS**
#'
# TODO Remove this remark before next release
#' **The `interpretive_rules()` function is new, to allow CLSI 'rules' too. The old `eucast_rules()` function will stay as a wrapper, but we need to generalise more parts of the underlying code to allow more than just EUCAST.**
#'
#' Apply rules from clinical breakpoints notes and expected resistant phenotypes as defined by e.g. the European Committee on Antimicrobial Susceptibility Testing (EUCAST, <https://www.eucast.org>), see *Source*. Use [eucast_dosage()] to get a [data.frame] with advised dosages of a certain bug-drug combination, which is based on the [dosage] data set. #' Apply rules from clinical breakpoints notes and expected resistant phenotypes as defined by e.g. the European Committee on Antimicrobial Susceptibility Testing (EUCAST, <https://www.eucast.org>), see *Source*. Use [eucast_dosage()] to get a [data.frame] with advised dosages of a certain bug-drug combination, which is based on the [dosage] data set.
#' #'
#' To improve the interpretation of the antibiogram before CLSI/EUCAST interpretive rules are applied, some AMR-specific rules can be applied at default, see *Details*. #' To improve the interpretation of the antibiogram before CLSI/EUCAST interpretive rules are applied, some AMR-specific rules can be applied at default, see *Details*.
@@ -197,19 +192,19 @@ interpretive_rules <- function(x,
stop_if( stop_if(
!is.na(ampc_cephalosporin_resistance) && !any(c("expert", "all") %in% rules), !is.na(ampc_cephalosporin_resistance) && !any(c("expert", "all") %in% rules),
"For the `ampc_cephalosporin_resistance` argument to work, the `rules` argument must contain `\"expert\"` or `\"all\"`." "For the {.arg ampc_cephalosporin_resistance} argument to work, the {.arg rules} argument must contain {.code \"expert\"} or {.code \"all\"}."
) )
add_MO_lookup_to_AMR_env() add_MO_lookup_to_AMR_env()
if ("custom" %in% rules && is.null(custom_rules)) { if ("custom" %in% rules && is.null(custom_rules)) {
warning_("in `eucast_rules()`: no custom rules were set with the `custom_rules` argument", warning_("in {.help AMR::eucast_rules}(): no custom rules were set with the {.arg custom_rules} argument",
immediate = TRUE immediate = TRUE
) )
rules <- rules[rules != "custom"] rules <- rules[rules != "custom"]
if (length(rules) == 0) { if (length(rules) == 0) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_("No other rules were set, returning original data", add_fn = font_red, as_note = FALSE) message_("No other rules were set, returning original data", as_note = FALSE)
} }
return(x) return(x)
} }
@@ -237,7 +232,7 @@ interpretive_rules <- function(x,
q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt) q_continue <- utils::menu(choices = c("OK", "Cancel"), graphics = FALSE, title = txt)
} }
if (q_continue %in% c(FALSE, 2)) { if (q_continue %in% c(FALSE, 2)) {
message_("Cancelled, returning original data", add_fn = font_red, as_note = FALSE) message_("Cancelled, returning original data", as_note = FALSE)
return(x) return(x)
} }
} }
@@ -246,7 +241,7 @@ interpretive_rules <- function(x,
# -- mo # -- mo
if (is.null(col_mo)) { if (is.null(col_mo)) {
col_mo <- search_type_in_df(x = x, type = "mo", info = info) col_mo <- search_type_in_df(x = x, type = "mo", info = info)
stop_if(is.null(col_mo), "`col_mo` must be set") stop_if(is.null(col_mo), "{.arg col_mo} must be set")
} }
decimal.mark <- getOption("OutDec") decimal.mark <- getOption("OutDec")
@@ -464,7 +459,7 @@ interpretive_rules <- function(x,
x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL, info = FALSE) x$gramstain <- mo_gramstain(x[, col_mo, drop = TRUE], language = NULL, info = FALSE)
x$genus_species <- trimws(paste(x$genus, x$species)) x$genus_species <- trimws(paste(x$genus, x$species))
if (isTRUE(info) && NROW(x.bak) > 10000) { if (isTRUE(info) && NROW(x.bak) > 10000) {
message_("OK.", add_fn = list(font_green, font_bold), as_note = FALSE) message_("OK.", as_note = FALSE)
} }
n_added <- 0 n_added <- 0
@@ -486,7 +481,7 @@ interpretive_rules <- function(x,
"Rules by the ", "Rules by the ",
font_bold(paste0("AMR package v", utils::packageDescription("AMR")$Version)), font_bold(paste0("AMR package v", utils::packageDescription("AMR")$Version)),
" (", format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"), " (", format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"),
"), see `?eucast_rules`\n" "), see {.help AMR::eucast_rules}()\n"
) )
)) ))
cat("\n\n") cat("\n\n")
@@ -600,23 +595,13 @@ interpretive_rules <- function(x,
} else { } else {
if (isTRUE(info)) { if (isTRUE(info)) {
cat("\n") cat("\n")
message_(paste0( message_("Skipping inhibitor-inheritance rules defined by this AMR package: setting S to drug+inhibitor where drug is S, and setting R to drug where drug+inhibitor is R. Add \"other\" or \"all\" to the {.arg rules} argument to apply those rules.")
font_red("Skipping inhibitor-inheritance rules defined by this AMR package: setting "),
font_green_bg(" S "),
font_red(" to drug+inhibitor where drug is "),
font_green_bg(" S "),
font_red(", and setting "),
font_rose_bg(" R "),
font_red(" to drug where drug+inhibitor is "),
font_rose_bg(" R "),
font_red(". Add \"other\" or \"all\" to the `rules` argument to apply those rules.")
))
} }
} }
if (!any(c("all", "custom") %in% rules) && !is.null(custom_rules)) { if (!any(c("all", "custom") %in% rules) && !is.null(custom_rules)) {
if (isTRUE(info)) { if (isTRUE(info)) {
message_("Skipping custom EUCAST rules, since the `rules` argument does not contain \"custom\".") message_("Skipping custom EUCAST rules, since the {.arg rules} argument does not contain {.code \"custom\"}.")
} }
custom_rules <- NULL custom_rules <- NULL
} }
@@ -678,8 +663,7 @@ interpretive_rules <- function(x,
if (isTRUE(info)) { if (isTRUE(info)) {
message_("Using column '", cols_ab[names(cols_ab) == ab], message_("Using column '", cols_ab[names(cols_ab) == ab],
"' as ", ab_name(ab_s, language = NULL, tolower = TRUE), "' as ", ab_name(ab_s, language = NULL, tolower = TRUE),
" since a column '", ab_s, "' is missing but required for the chosen rules", " since a column '", ab_s, "' is missing but required for the chosen rules"
add_fn = font_red
) )
} }
cols_ab <- c(cols_ab, stats::setNames(unname(cols_ab[names(cols_ab) == ab]), ab_s)) cols_ab <- c(cols_ab, stats::setNames(unname(cols_ab[names(cols_ab) == ab]), ab_s))
@@ -903,7 +887,7 @@ interpretive_rules <- function(x,
for (i in seq_len(length(custom_rules))) { for (i in seq_len(length(custom_rules))) {
rule <- custom_rules[[i]] rule <- custom_rules[[i]]
rows <- tryCatch(which(eval(parse(text = rule$query), envir = x)), rows <- tryCatch(which(eval(parse(text = rule$query), envir = x)),
error = function(e) stop_(paste0(conditionMessage(e), font_red(" (check available data and compare with the custom rules set)")), call = FALSE) error = function(e) stop_(conditionMessage(e), " (check available data and compare with the custom rules set)", call = FALSE)
) )
cols <- as.character(rule$result_group) cols <- as.character(rule$result_group)
cols <- c( cols <- c(
@@ -1078,7 +1062,7 @@ interpretive_rules <- function(x,
warn_lacking_sir_class <- warn_lacking_sir_class[order(colnames(x.bak))] warn_lacking_sir_class <- warn_lacking_sir_class[order(colnames(x.bak))]
warn_lacking_sir_class <- warn_lacking_sir_class[!is.na(warn_lacking_sir_class)] warn_lacking_sir_class <- warn_lacking_sir_class[!is.na(warn_lacking_sir_class)]
warning_( warning_(
"in `eucast_rules()`: not all columns with antimicrobial results are of class 'sir'. Transform them on beforehand, with e.g.:\n", "in {.help AMR::eucast_rules}(): not all columns with antimicrobial results are of class 'sir'. Transform them on beforehand, with e.g.:\n",
" - ", x_deparsed, " %>% as.sir(", ifelse(length(warn_lacking_sir_class) == 1, " - ", 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)])
@@ -1113,7 +1097,7 @@ eucast_rules <- function(x,
rules = getOption("AMR_interpretive_rules", default = c("breakpoints", "expected_phenotypes")), rules = getOption("AMR_interpretive_rules", default = c("breakpoints", "expected_phenotypes")),
...) { ...) {
if (!is.null(getOption("AMR_eucastrules", default = NULL))) { if (!is.null(getOption("AMR_eucastrules", default = NULL))) {
warning_("The global option `AMR_eucastrules` that you have set is now invalid was ignored - set `AMR_interpretive_rules` instead. See `?AMR-options`.") warning_("The global option {.code AMR_eucastrules} that you have set is now invalid was ignored - set {.code AMR_interpretive_rules} instead. See {.code ?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", ...)
} }
@@ -1170,7 +1154,7 @@ edit_sir <- function(x,
isSIR <- !isNA & (new_edits[rows, cols] == "S" | new_edits[rows, cols] == "I" | new_edits[rows, cols] == "R" | new_edits[rows, cols] == "SDD" | new_edits[rows, cols] == "NI" | new_edits[rows, cols] == "WT" | new_edits[rows, cols] == "NWT" | new_edits[rows, cols] == "NS") isSIR <- !isNA & (new_edits[rows, cols] == "S" | new_edits[rows, cols] == "I" | new_edits[rows, cols] == "R" | new_edits[rows, cols] == "SDD" | new_edits[rows, cols] == "NI" | new_edits[rows, cols] == "WT" | new_edits[rows, cols] == "NWT" | new_edits[rows, cols] == "NS")
non_SIR <- !isSIR non_SIR <- !isSIR
if (isFALSE(overwrite) && any(isSIR) && message_not_thrown_before("edit_sir.warning_overwrite")) { if (isFALSE(overwrite) && any(isSIR) && message_not_thrown_before("edit_sir.warning_overwrite")) {
warning_("Some values had SIR values and were not overwritten, since `overwrite = FALSE`.") warning_("Some values had SIR values and were not overwritten, since {.code overwrite = FALSE}.")
} }
tryCatch( tryCatch(
# insert into original table # insert into original table
@@ -1194,7 +1178,7 @@ edit_sir <- function(x,
suppressWarnings(new_edits[rows, cols][non_SIR] <<- to) suppressWarnings(new_edits[rows, cols][non_SIR] <<- to)
} }
warning_( warning_(
"in `eucast_rules()`: value \"", to, "\" added to the factor levels of column", "in {.help 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."
@@ -1202,7 +1186,7 @@ edit_sir <- function(x,
txt_warning() txt_warning()
warned <- FALSE warned <- FALSE
} else { } else {
warning_("in `eucast_rules()`: ", w$message) warning_("in {.help AMR::eucast_rules}(): ", w$message)
txt_warning() txt_warning()
} }
}, },

View File

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

View File

@@ -187,7 +187,7 @@ key_antimicrobials <- function(x = NULL,
"No columns available ", "No columns available ",
paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ") paste0("Only using ", values_new_length, " out of ", values_old_length, " defined columns ")
), ),
"as key antimicrobials for ", name, "s. See `?key_antimicrobials`." "as key antimicrobials for ", name, "s. See {.help AMR::key_antimicrobials}()."
) )
} }

View File

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

20
R/mo.R
View File

@@ -402,7 +402,12 @@ as.mo <- function(x,
top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs top_hits <- mo_to_search[order(m, decreasing = TRUE, na.last = NA)] # na.last = NA will remove the NAs
if (length(top_hits) == 0) { if (length(top_hits) == 0) {
warning_("No hits found for \"", x_search, "\" with minimum_matching_score = ", ifelse(is.null(minimum_matching_score), paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"), minimum_matching_score), ". Try setting this value lower or even to 0.", call = FALSE) warning_("No hits found for \"", x_search, "\" with minimum_matching_score = ",
ifelse(is.null(minimum_matching_score),
paste0("NULL (=", round(min(minimum_matching_score_current, na.rm = TRUE), 3), ")"),
minimum_matching_score
),
". Try setting this value lower or even to 0.", call = FALSE)
result_mo <- NA_character_ result_mo <- NA_character_
} else { } else {
result_mo <- MO_lookup_current$mo[match(top_hits[1], MO_lookup_current$fullname)] result_mo <- MO_lookup_current$mo[match(top_hits[1], MO_lookup_current$fullname)]
@@ -902,14 +907,14 @@ rep.mo <- function(x, ...) {
print.mo_uncertainties <- function(x, n = 10, ...) { print.mo_uncertainties <- function(x, n = 10, ...) {
more_than_50 <- FALSE more_than_50 <- FALSE
if (NROW(x) == 0) { if (NROW(x) == 0) {
cat(word_wrap("No uncertainties to show. Only uncertainties of the last call to `as.mo()` or any `mo_*()` function are stored.\n\n", add_fn = font_blue)) cat(font_blue(word_wrap("No uncertainties to show. Only uncertainties of the last call to `as.mo()` or any `mo_*()` function are stored.\n\n")))
return(invisible(NULL)) return(invisible(NULL))
} else if (NROW(x) > 50) { } else if (NROW(x) > 50) {
more_than_50 <- TRUE more_than_50 <- TRUE
x <- x[1:50, , drop = FALSE] x <- x[1:50, , drop = FALSE]
} }
cat(word_wrap("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See `?mo_matching_score`.\n\n", add_fn = font_blue)) cat(font_blue(word_wrap("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See {.help AMR::mo_matching_score}().\n\n")))
add_MO_lookup_to_AMR_env() add_MO_lookup_to_AMR_env()
@@ -919,13 +924,12 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
col_green <- function(x) font_green_bg(x, collapse = NULL) col_green <- function(x) font_green_bg(x, collapse = NULL)
if (has_colour()) { if (has_colour()) {
cat(word_wrap("Colour keys: ", cat(font_blue(word_wrap("Colour keys: ",
col_red(" 0.000-0.549 "), col_red(" 0.000-0.549 "),
col_orange(" 0.550-0.649 "), col_orange(" 0.550-0.649 "),
col_yellow(" 0.650-0.749 "), col_yellow(" 0.650-0.749 "),
col_green(" 0.750-1.000"), col_green(" 0.750-1.000")
add_fn = font_blue )), font_green_bg(" "), "\n", sep = "")
), font_green_bg(" "), "\n", sep = "")
} }
score_set_colour <- function(text, scores) { score_set_colour <- function(text, scores) {
@@ -1028,7 +1032,7 @@ print.mo_uncertainties <- function(x, n = 10, ...) {
#' @noRd #' @noRd
print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) { print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
if (NROW(x) == 0) { if (NROW(x) == 0) {
cat(word_wrap("No renamed taxonomy to show. Only renamed taxonomy of the last call of `as.mo()` or any `mo_*()` function are stored.\n", add_fn = font_blue)) cat(font_blue(word_wrap("No renamed taxonomy to show. Only renamed taxonomy of the last call of `as.mo()` or any `mo_*()` function are stored.\n")))
return(invisible(NULL)) return(invisible(NULL))
} }

View File

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

View File

@@ -412,7 +412,7 @@ create_scale_sir <- function(aesthetics, colours_SIR, language, eucast_I, ...) {
scale$labels <- function(x) { scale$labels <- function(x) {
stop_ifnot(all(x %in% c(levels(NA_sir_), "SI", "IR", NA)), stop_ifnot(all(x %in% c(levels(NA_sir_), "SI", "IR", NA)),
"Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see `?as.sir`.", "Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see {.help AMR::as.sir}().",
call = FALSE call = FALSE
) )
x <- as.character(x) x <- as.character(x)

View File

@@ -238,7 +238,7 @@ resistance_predict <- function(x,
prediction <- predictmodel$fit prediction <- predictmodel$fit
se <- predictmodel$se.fit se <- predictmodel$se.fit
} else { } else {
stop("no valid model selected. See `?resistance_predict`.") stop("no valid model selected. See {.help AMR::resistance_predict}().")
} }
# prepare the output dataframe # prepare the output dataframe

51
R/sir.R
View File

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

View File

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

View File

@@ -118,8 +118,7 @@ AMR_env$cross_icon <- if (isTRUE(base::l10n_info()$`UTF-8`)) "\u00d7" else "x"
if (interactive() && is.null(getOption("AMR_guideline"))) { if (interactive() && is.null(getOption("AMR_guideline"))) {
packageStartupMessage( packageStartupMessage(
word_wrap( word_wrap(
"Assuming ", AMR::clinical_breakpoints$guideline[1], " as the default AMR guideline, see `?AMR-options` to change this.", "Assuming ", AMR::clinical_breakpoints$guideline[1], " as the default AMR guideline, see `?AMR-options` to change this."
add_fn = NULL
) )
) )
} }

View File

@@ -245,12 +245,14 @@ reference:
- title: "Other: miscellaneous functions" - title: "Other: miscellaneous functions"
desc: > desc: >
These functions are mostly for internal use, but some of Miscellaneous functions that support various parts of an AMR analysis,
them may also be suitable for your analysis. Especially the such as working with ages, joining tables, principal component analysis,
'like' function can be useful: `if (x %like% y) {...}`. and other utilities. Especially the 'like' function can be useful:
`if (x %like% y) {...}`.
contents: contents:
- "`age_groups`" - "`age_groups`"
- "`age`" - "`age`"
- "`amr_course`"
- "`export_ncbi_biosample`" - "`export_ncbi_biosample`"
- "`availability`" - "`availability`"
- "`get_AMR_locale`" - "`get_AMR_locale`"

36
man/amr_course.Rd Normal file
View File

@@ -0,0 +1,36 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/amr_course.R
\name{amr_course}
\alias{amr_course}
\title{Download and Unpack an AMR Course Repository}
\usage{
amr_course(github_repo, branch = "main", ...)
}
\arguments{
\item{github_repo}{A character string specifying the GitHub repository with username and repo name, e.g. \code{"https://github.com/username/repo"}.}
\item{branch}{A character string specifying the branch to download. Defaults to \code{"main"}.}
\item{...}{Additional arguments passed on to \code{\link[usethis:zip-utils]{usethis::use_course()}}.}
}
\value{
Called for its side effect. \code{\link[usethis:zip-utils]{usethis::use_course()}} will prompt the user to choose a destination and open the extracted project. Returns invisibly whatever \code{\link[usethis:zip-utils]{usethis::use_course()}} returns.
}
\description{
Downloads and unpacks a GitHub repository containing course materials, using \code{\link[usethis:zip-utils]{usethis::use_course()}}. This is a convenience wrapper intended for use in educational settings, such as workshops or tutorials associated with the AMR package.
}
\details{
This function constructs a ZIP archive URL from the provided \code{github_repo} and \code{branch}, then delegates to \code{\link[usethis:zip-utils]{usethis::use_course()}} to handle the download and extraction.
The function is designed for interactive use in course or workshop settings and is not intended for use in non-interactive or automated pipelines.
}
\examples{
\dontrun{
# Let this run by users, e.g., webinar participants
amr_course("https://github.com/my_user_name/our_AMR_course")
}
}
\seealso{
\code{\link[usethis:zip-utils]{usethis::use_course()}}
}

View File

@@ -76,10 +76,6 @@ eucast_dosage(ab, administration = "iv", version_breakpoints = 15)
The input of \code{x}, possibly with edited values of antimicrobials. Or, if \code{verbose = TRUE}, a \link{data.frame} with all original and new values of the affected bug-drug combinations. The input of \code{x}, possibly with edited values of antimicrobials. Or, if \code{verbose = TRUE}, a \link{data.frame} with all original and new values of the affected bug-drug combinations.
} }
\description{ \description{
\strong{WORK IN PROGRESS}
\strong{The \code{interpretive_rules()} function is new, to allow CLSI 'rules' too. The old \code{eucast_rules()} function will stay as a wrapper, but we need to generalise more parts of the underlying code to allow more than just EUCAST.}
Apply rules from clinical breakpoints notes and expected resistant phenotypes as defined by e.g. the European Committee on Antimicrobial Susceptibility Testing (EUCAST, \url{https://www.eucast.org}), see \emph{Source}. Use \code{\link[=eucast_dosage]{eucast_dosage()}} to get a \link{data.frame} with advised dosages of a certain bug-drug combination, which is based on the \link{dosage} data set. Apply rules from clinical breakpoints notes and expected resistant phenotypes as defined by e.g. the European Committee on Antimicrobial Susceptibility Testing (EUCAST, \url{https://www.eucast.org}), see \emph{Source}. Use \code{\link[=eucast_dosage]{eucast_dosage()}} to get a \link{data.frame} with advised dosages of a certain bug-drug combination, which is based on the \link{dosage} data set.
To improve the interpretation of the antibiogram before CLSI/EUCAST interpretive rules are applied, some AMR-specific rules can be applied at default, see \emph{Details}. To improve the interpretation of the antibiogram before CLSI/EUCAST interpretive rules are applied, some AMR-specific rules can be applied at default, see \emph{Details}.