mirror of
https://github.com/msberends/AMR.git
synced 2026-03-19 21:02:27 +01:00
Replace bare backticks with cli inline markup across all messaging calls
- {.arg} for argument names in stop_/warning_/message_ calls
- {.cls} after "of class" text in format_class() and elsewhere
- {.fun} for function names (replaces `fn()` pattern)
- {.pkg} for tidyverse package names (dplyr, ggplot2)
- {.code} for code literals (TRUE, FALSE, expressions)
- Rewrite print.ab: use cli named-vector with * bullets and code
highlighting when cli >= 3.0.0; keep plain-text fallback otherwise
- Fix typo in as.sir(): "of must be" -> "or must be"
- switch sir.R verbose notes from message() to message_()
https://claude.ai/code/session_01XHWLohiSTdZvCutwD7ag2b
This commit is contained in:
@@ -1,6 +1,6 @@
|
|||||||
Package: AMR
|
Package: AMR
|
||||||
Version: 3.0.1.9036
|
Version: 3.0.1.9037
|
||||||
Date: 2026-03-18
|
Date: 2026-03-19
|
||||||
Title: Antimicrobial Resistance Data Analysis
|
Title: Antimicrobial Resistance Data Analysis
|
||||||
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
|
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
|
||||||
data analysis and to work with microbial and antimicrobial properties by
|
data analysis and to work with microbial and antimicrobial properties by
|
||||||
|
|||||||
3
NEWS.md
3
NEWS.md
@@ -1,4 +1,4 @@
|
|||||||
# AMR 3.0.1.9036
|
# AMR 3.0.1.9037
|
||||||
|
|
||||||
### New
|
### New
|
||||||
* Integration with the **tidymodels** framework to allow seamless use of SIR, MIC and disk data in modelling pipelines via `recipes`
|
* Integration with the **tidymodels** framework to allow seamless use of SIR, MIC and disk data in modelling pipelines via `recipes`
|
||||||
@@ -30,6 +30,7 @@
|
|||||||
* Fixed SIR and MIC coercion of combined values, e.g. `as.sir("<= 0.002; S") ` or `as.mic("S; 0.002")` (#252)
|
* Fixed SIR and MIC coercion of combined values, e.g. `as.sir("<= 0.002; S") ` or `as.mic("S; 0.002")` (#252)
|
||||||
|
|
||||||
### Updates
|
### Updates
|
||||||
|
* Replaced all bare backtick-quoted text in `message_()`, `warning_()`, and `stop_()` calls with proper cli inline markup (`{.arg}`, `{.cls}`, `{.fun}`, `{.pkg}`, `{.code}`); rewrote `print.ab` to use a cli named-vector with `*` bullets and code highlighting when cli is available
|
||||||
* `mdro()` now infers resistance for a _missing_ base drug column from an _available_ corresponding drug+inhibitor combination showing resistance (e.g., piperacillin is absent but required, while piperacillin/tazobactam available and resistant). Can be set with the new argument `infer_from_combinations`, which defaults to `TRUE` (#209). Note that this can yield a higher MDRO detection (which is a good thing as it has become more reliable).
|
* `mdro()` now infers resistance for a _missing_ base drug column from an _available_ corresponding drug+inhibitor combination showing resistance (e.g., piperacillin is absent but required, while piperacillin/tazobactam available and resistant). Can be set with the new argument `infer_from_combinations`, which defaults to `TRUE` (#209). Note that this can yield a higher MDRO detection (which is a good thing as it has become more reliable).
|
||||||
* `susceptibility()` and `resistance()` gained the argument `guideline`, which defaults to EUCAST, for interpreting the 'I' category correctly.
|
* `susceptibility()` and `resistance()` gained the argument `guideline`, which defaults to EUCAST, for interpreting the 'I' category correctly.
|
||||||
* Added to the `antimicrobials` data set: cefepime/taniborbactam (`FTA`), ceftibuten/avibactam (`CTA`), clorobiocin (`CLB`), kasugamycin (`KAS`), ostreogrycin (`OST`), taniborbactam (`TAN`), thiostrepton (`THS`), xeruborbactam (`XER`), and zorbamycin (`ZOR`)
|
* Added to the `antimicrobials` data set: cefepime/taniborbactam (`FTA`), ceftibuten/avibactam (`CTA`), clorobiocin (`CLB`), kasugamycin (`KAS`), ostreogrycin (`OST`), taniborbactam (`TAN`), thiostrepton (`THS`), xeruborbactam (`XER`), and zorbamycin (`ZOR`)
|
||||||
|
|||||||
@@ -304,8 +304,8 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
|
|||||||
if (!is.null(found)) {
|
if (!is.null(found)) {
|
||||||
# this column should contain logicals
|
# this column should contain logicals
|
||||||
if (!is.logical(x[, found, drop = TRUE])) {
|
if (!is.logical(x[, found, drop = TRUE])) {
|
||||||
message_("Column '", font_bold(found), "' found as input for `", ifelse(add_col_prefix, "col_", ""), type,
|
message_("Column '", font_bold(found), "' found as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type,
|
||||||
"`, but this column does not contain 'logical' values (TRUE/FALSE) and was ignored."
|
"}, but this column does not contain {.code TRUE}/{.code FALSE} values and was ignored."
|
||||||
)
|
)
|
||||||
found <- NULL
|
found <- NULL
|
||||||
}
|
}
|
||||||
@@ -771,7 +771,7 @@ format_class <- function(class, plural = FALSE) {
|
|||||||
ifelse(plural, "s", "")
|
ifelse(plural, "s", "")
|
||||||
)
|
)
|
||||||
# exceptions
|
# exceptions
|
||||||
class[class == "logical"] <- ifelse(plural, "a vector of `TRUE`/`FALSE`", "`TRUE` or `FALSE`")
|
class[class == "logical"] <- ifelse(plural, "a vector of {.code TRUE}/{.code FALSE}", "{.code TRUE} or {.code FALSE}")
|
||||||
class[class == "data.frame"] <- "a data set"
|
class[class == "data.frame"] <- "a data set"
|
||||||
if ("list" %in% class) {
|
if ("list" %in% class) {
|
||||||
class <- "a list"
|
class <- "a list"
|
||||||
@@ -780,12 +780,12 @@ format_class <- function(class, plural = FALSE) {
|
|||||||
class <- "a matrix"
|
class <- "a matrix"
|
||||||
}
|
}
|
||||||
if ("custom_eucast_rules" %in% class) {
|
if ("custom_eucast_rules" %in% class) {
|
||||||
class <- "input created with `custom_eucast_rules()`"
|
class <- "input created with {.fun custom_eucast_rules}"
|
||||||
}
|
}
|
||||||
if (any(c("mo", "ab", "sir") %in% class)) {
|
if (any(c("mo", "ab", "sir") %in% class)) {
|
||||||
class <- paste0("of class '", class[1L], "'")
|
class <- paste0("of class {.cls ", class[1L], "}")
|
||||||
}
|
}
|
||||||
class[class == class.bak] <- paste0("of class '", class[class == class.bak], "'")
|
class[class == class.bak] <- paste0("of class {.cls ", class[class == class.bak], "}")
|
||||||
# output
|
# output
|
||||||
vector_or(class, quotes = FALSE, sort = FALSE)
|
vector_or(class, quotes = FALSE, sort = FALSE)
|
||||||
}
|
}
|
||||||
@@ -820,11 +820,11 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
|||||||
AMR_env$meet_criteria_error_txt <- NULL
|
AMR_env$meet_criteria_error_txt <- NULL
|
||||||
|
|
||||||
if (is.null(object)) {
|
if (is.null(object)) {
|
||||||
stop_if(allow_NULL == FALSE, "argument `", obj_name, "` must not be NULL", call = call_depth)
|
stop_if(allow_NULL == FALSE, "argument {.arg ", obj_name, "} must not be NULL", call = call_depth)
|
||||||
return(invisible())
|
return(invisible())
|
||||||
}
|
}
|
||||||
if (is.null(dim(object)) && length(object) == 1 && suppressWarnings(is.na(object))) { # suppressWarnings for functions
|
if (is.null(dim(object)) && length(object) == 1 && suppressWarnings(is.na(object))) { # suppressWarnings for functions
|
||||||
stop_if(allow_NA == FALSE, "argument `", obj_name, "` must not be NA", call = call_depth)
|
stop_if(allow_NA == FALSE, "argument {.arg ", obj_name, "} must not be NA", call = call_depth)
|
||||||
return(invisible())
|
return(invisible())
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -834,32 +834,32 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
|||||||
}
|
}
|
||||||
|
|
||||||
if (!is.null(allow_class) && !(suppressWarnings(all(is.na(object))) && allow_NA == TRUE)) {
|
if (!is.null(allow_class) && !(suppressWarnings(all(is.na(object))) && allow_NA == TRUE)) {
|
||||||
stop_ifnot(inherits(object, allow_class), "argument `", obj_name,
|
stop_ifnot(inherits(object, allow_class), "argument {.arg ", obj_name,
|
||||||
"` must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
|
"} must be ", format_class(allow_class, plural = isTRUE(has_length > 1)),
|
||||||
", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)),
|
", i.e. not be ", format_class(class(object), plural = isTRUE(has_length > 1)),
|
||||||
call = call_depth
|
call = call_depth
|
||||||
)
|
)
|
||||||
# check data.frames for data
|
# check data.frames for data
|
||||||
if (inherits(object, "data.frame")) {
|
if (inherits(object, "data.frame")) {
|
||||||
stop_if(any(dim(object) == 0),
|
stop_if(any(dim(object) == 0),
|
||||||
"the data provided in argument `", obj_name,
|
"the data provided in argument {.arg ", obj_name,
|
||||||
"` must contain rows and columns (current dimensions: ",
|
"} must contain rows and columns (current dimensions: ",
|
||||||
paste(dim(object), collapse = "x"), ")",
|
paste(dim(object), collapse = "x"), ")",
|
||||||
call = call_depth
|
call = call_depth
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
if (!is.null(has_length)) {
|
if (!is.null(has_length)) {
|
||||||
stop_ifnot(length(object) %in% has_length, "argument `", obj_name,
|
stop_ifnot(length(object) %in% has_length, "argument {.arg ", obj_name,
|
||||||
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
"} must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
||||||
"be of length ", vector_or(has_length, quotes = FALSE),
|
"be of length ", vector_or(has_length, quotes = FALSE),
|
||||||
", not ", length(object),
|
", not ", length(object),
|
||||||
call = call_depth
|
call = call_depth
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
if (!is.null(looks_like)) {
|
if (!is.null(looks_like)) {
|
||||||
stop_ifnot(object %like% looks_like, "argument `", obj_name,
|
stop_ifnot(object %like% looks_like, "argument {.arg ", obj_name,
|
||||||
"` must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
"} must ", # ifelse(allow_NULL, "be NULL or must ", ""),
|
||||||
"resemble the regular expression \"", looks_like, "\"",
|
"resemble the regular expression \"", looks_like, "\"",
|
||||||
call = call_depth
|
call = call_depth
|
||||||
)
|
)
|
||||||
@@ -877,7 +877,7 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
|||||||
if ("logical" %in% allow_class) {
|
if ("logical" %in% allow_class) {
|
||||||
or_values <- paste0(or_values, ", or TRUE or FALSE")
|
or_values <- paste0(or_values, ", or TRUE or FALSE")
|
||||||
}
|
}
|
||||||
stop_ifnot(all(object %in% is_in.bak, na.rm = TRUE), "argument `", obj_name, "` ",
|
stop_ifnot(all(object %in% is_in.bak, na.rm = TRUE), "argument {.arg ", obj_name, "} ",
|
||||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||||
"must be either ",
|
"must be either ",
|
||||||
"must only contain values "
|
"must only contain values "
|
||||||
@@ -888,8 +888,8 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
|||||||
)
|
)
|
||||||
}
|
}
|
||||||
if (isTRUE(is_positive)) {
|
if (isTRUE(is_positive)) {
|
||||||
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument `", obj_name,
|
stop_if(is.numeric(object) && !all(object > 0, na.rm = TRUE), "argument {.arg ", obj_name,
|
||||||
"` must ",
|
"} must ",
|
||||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||||
"be a number higher than zero",
|
"be a number higher than zero",
|
||||||
"all be numbers higher than zero"
|
"all be numbers higher than zero"
|
||||||
@@ -898,8 +898,8 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
|||||||
)
|
)
|
||||||
}
|
}
|
||||||
if (isTRUE(is_positive_or_zero)) {
|
if (isTRUE(is_positive_or_zero)) {
|
||||||
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument `", obj_name,
|
stop_if(is.numeric(object) && !all(object >= 0, na.rm = TRUE), "argument {.arg ", obj_name,
|
||||||
"` must ",
|
"} must ",
|
||||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||||
"be zero or a positive number",
|
"be zero or a positive number",
|
||||||
"all be zero or numbers higher than zero"
|
"all be zero or numbers higher than zero"
|
||||||
@@ -908,8 +908,8 @@ meet_criteria <- function(object, # can be literally `list(...)` for `allow_argu
|
|||||||
)
|
)
|
||||||
}
|
}
|
||||||
if (isTRUE(is_finite)) {
|
if (isTRUE(is_finite)) {
|
||||||
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument `", obj_name,
|
stop_if(is.numeric(object) && !all(is.finite(object[!is.na(object)]), na.rm = TRUE), "argument {.arg ", obj_name,
|
||||||
"` must ",
|
"} must ",
|
||||||
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
ifelse(!is.null(has_length) && length(has_length) == 1 && has_length == 1,
|
||||||
"be a finite number",
|
"be a finite number",
|
||||||
"all be finite numbers"
|
"all be finite numbers"
|
||||||
@@ -943,8 +943,8 @@ ascertain_sir_classes <- function(x, obj_name) {
|
|||||||
sirs <- vapply(FUN.VALUE = logical(1), x, is.sir)
|
sirs <- vapply(FUN.VALUE = logical(1), x, is.sir)
|
||||||
if (!any(sirs, na.rm = TRUE)) {
|
if (!any(sirs, na.rm = TRUE)) {
|
||||||
warning_(
|
warning_(
|
||||||
"the data provided in argument `", obj_name,
|
"the data provided in argument {.arg ", obj_name,
|
||||||
"` should contain at least one column of class 'sir'. Eligible SIR column were now guessed. ",
|
"} should contain at least one column of class {.cls sir}. Eligible SIR columns were now guessed. ",
|
||||||
"See {.help [{.fun as.sir}](AMR::as.sir)}.",
|
"See {.help [{.fun as.sir}](AMR::as.sir)}.",
|
||||||
immediate = TRUE
|
immediate = TRUE
|
||||||
)
|
)
|
||||||
@@ -1047,13 +1047,13 @@ get_current_data <- function(arg_name, call) {
|
|||||||
} else {
|
} else {
|
||||||
examples <- ""
|
examples <- ""
|
||||||
}
|
}
|
||||||
stop_("this function must be used inside a `dplyr` verb or `data.frame` call",
|
stop_("this function must be used inside a {.pkg dplyr} verb or {.code data.frame} call",
|
||||||
examples,
|
examples,
|
||||||
call = call
|
call = call
|
||||||
)
|
)
|
||||||
} else {
|
} else {
|
||||||
# mimic a base R error that the argument is missing
|
# mimic a base R error that the argument is missing
|
||||||
stop_("argument `", arg_name, "` is missing with no default", call = call)
|
stop_("argument {.arg ", arg_name, "} is missing with no default", call = call)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1647,7 +1647,7 @@ if (!is.null(import_fn("where", "tidyselect", error_on_fail = FALSE))) {
|
|||||||
where <- function(fn) {
|
where <- function(fn) {
|
||||||
# based on https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
|
# based on https://github.com/nathaneastwood/poorman/blob/52eb6947e0b4430cd588976ed8820013eddf955f/R/where.R#L17-L32
|
||||||
if (!is.function(fn)) {
|
if (!is.function(fn)) {
|
||||||
stop_("`", deparse(substitute(fn)), "()` is not a valid predicate function.")
|
stop_("{.fun ", deparse(substitute(fn)), "} is not a valid predicate function.")
|
||||||
}
|
}
|
||||||
df <- pm_select_env$.data
|
df <- pm_select_env$.data
|
||||||
cols <- pm_select_env$get_colnames()
|
cols <- pm_select_env$get_colnames()
|
||||||
@@ -1662,7 +1662,7 @@ if (!is.null(import_fn("where", "tidyselect", error_on_fail = FALSE))) {
|
|||||||
},
|
},
|
||||||
fn
|
fn
|
||||||
))
|
))
|
||||||
if (!is.logical(preds)) stop_("`where()` must be used with functions that return `TRUE` or `FALSE`.")
|
if (!is.logical(preds)) stop_("{.fun where} must be used with functions that return {.code TRUE} or {.code FALSE}.")
|
||||||
data_cols <- cols
|
data_cols <- cols
|
||||||
cols <- data_cols[preds]
|
cols <- data_cols[preds]
|
||||||
which(data_cols %in% cols)
|
which(data_cols %in% cols)
|
||||||
|
|||||||
34
R/ab.R
34
R/ab.R
@@ -551,14 +551,28 @@ type_sum.ab <- function(x, ...) {
|
|||||||
print.ab <- function(x, ...) {
|
print.ab <- function(x, ...) {
|
||||||
if (!is.null(attributes(x)$amr_selector)) {
|
if (!is.null(attributes(x)$amr_selector)) {
|
||||||
function_name <- attributes(x)$amr_selector
|
function_name <- attributes(x)$amr_selector
|
||||||
message_(
|
if (pkg_is_available("cli", min_version = "3.0.0")) {
|
||||||
"This 'ab' vector was retrieved using `", function_name, "()`, which should normally be used inside a `dplyr` verb or `data.frame` call, e.g.:\n",
|
cli::cli_inform(
|
||||||
" ", AMR_env$bullet_icon, " your_data %>% select(", function_name, "())\n",
|
c(
|
||||||
" ", AMR_env$bullet_icon, " your_data %>% select(column_a, column_b, ", function_name, "())\n",
|
"i" = "This {.cls ab} vector was retrieved using {.fun {function_name}}, which should normally be used inside a {.pkg dplyr} verb or {.code data.frame} call, e.g.:",
|
||||||
" ", AMR_env$bullet_icon, " your_data %>% filter(any(", function_name, "() == \"R\"))\n",
|
"*" = "{.code your_data %>% select({function_name}())}",
|
||||||
" ", AMR_env$bullet_icon, " your_data[, ", function_name, "()]\n",
|
"*" = "{.code your_data %>% select(column_a, column_b, {function_name}())}",
|
||||||
" ", AMR_env$bullet_icon, " your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]"
|
"*" = "{.code your_data %>% filter(any({function_name}() == \"R\"))}",
|
||||||
)
|
"*" = "{.code your_data[, {function_name}()]}",
|
||||||
|
"*" = "{.code your_data[, c(\"column_a\", \"column_b\", {function_name}())]}"
|
||||||
|
),
|
||||||
|
.envir = environment()
|
||||||
|
)
|
||||||
|
} else {
|
||||||
|
message(word_wrap(paste0(
|
||||||
|
"This 'ab' vector was retrieved using `", function_name, "()`, which should normally be used inside a dplyr verb or data.frame call, e.g.:\n",
|
||||||
|
" ", AMR_env$bullet_icon, " your_data %>% select(", function_name, "())\n",
|
||||||
|
" ", AMR_env$bullet_icon, " your_data %>% select(column_a, column_b, ", function_name, "())\n",
|
||||||
|
" ", AMR_env$bullet_icon, " your_data %>% filter(any(", function_name, "() == \"R\"))\n",
|
||||||
|
" ", AMR_env$bullet_icon, " your_data[, ", function_name, "()]\n",
|
||||||
|
" ", AMR_env$bullet_icon, " your_data[, c(\"column_a\", \"column_b\", ", function_name, "())]"
|
||||||
|
), as_note = TRUE))
|
||||||
|
}
|
||||||
}
|
}
|
||||||
cat("Class 'ab'\n")
|
cat("Class 'ab'\n")
|
||||||
print(as.character(x), quote = FALSE)
|
print(as.character(x), quote = FALSE)
|
||||||
@@ -704,8 +718,8 @@ get_translate_ab <- function(translate_ab) {
|
|||||||
} else {
|
} else {
|
||||||
translate_ab <- tolower(translate_ab)
|
translate_ab <- tolower(translate_ab)
|
||||||
stop_ifnot(translate_ab %in% colnames(AMR::antimicrobials),
|
stop_ifnot(translate_ab %in% colnames(AMR::antimicrobials),
|
||||||
"invalid value for 'translate_ab', this must be a column name of the `antimicrobials` data set\n",
|
"invalid value for {.arg translate_ab}, this must be a column name of the {.topic [antimicrobials](AMR::antimicrobials)} data set\n",
|
||||||
"or `TRUE` (equals 'name') or `FALSE` to not translate at all.",
|
"or {.code TRUE} (equals {.val name}) or {.code FALSE} to not translate at all.",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
translate_ab
|
translate_ab
|
||||||
|
|||||||
@@ -341,12 +341,12 @@ ab_url <- function(x, open = FALSE, ...) {
|
|||||||
|
|
||||||
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(atcs)]
|
NAs <- ab_name(ab, tolower = TRUE, language = NULL)[!is.na(ab) & is.na(atcs)]
|
||||||
if (length(NAs) > 0) {
|
if (length(NAs) > 0) {
|
||||||
warning_("in `ab_url()`: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
|
warning_("in {.fun ab_url}: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
|
||||||
}
|
}
|
||||||
|
|
||||||
if (open == TRUE) {
|
if (open == TRUE) {
|
||||||
if (length(u) > 1 && !is.na(u[1L])) {
|
if (length(u) > 1 && !is.na(u[1L])) {
|
||||||
warning_("in `ab_url()`: only the first URL will be opened, as `browseURL()` only suports one string.")
|
warning_("in {.fun ab_url}: only the first URL will be opened, as {.fun browseURL} only suports one string.")
|
||||||
}
|
}
|
||||||
if (!is.na(u[1L])) {
|
if (!is.na(u[1L])) {
|
||||||
utils::browseURL(u[1L])
|
utils::browseURL(u[1L])
|
||||||
@@ -397,7 +397,7 @@ set_ab_names <- function(data, ..., property = "name", language = get_AMR_locale
|
|||||||
}
|
}
|
||||||
vars <- get_column_abx(df, info = FALSE, only_sir_columns = FALSE, sort = FALSE, fn = "set_ab_names")
|
vars <- get_column_abx(df, info = FALSE, only_sir_columns = FALSE, sort = FALSE, fn = "set_ab_names")
|
||||||
if (length(vars) == 0) {
|
if (length(vars) == 0) {
|
||||||
message_("No columns with antibiotic results found for `set_ab_names()`, leaving names unchanged.")
|
message_("No columns with antibiotic results found for {.fun set_ab_names}, leaving names unchanged.")
|
||||||
return(data)
|
return(data)
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
|
|||||||
12
R/age.R
12
R/age.R
@@ -67,7 +67,7 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
|
|||||||
} else if (length(reference) == 1) {
|
} else if (length(reference) == 1) {
|
||||||
reference <- rep(reference, length(x))
|
reference <- rep(reference, length(x))
|
||||||
} else {
|
} else {
|
||||||
stop_("`x` and `reference` must be of same length, or `reference` must be of length 1.")
|
stop_("{.arg x} and {.arg reference} must be of same length, or {.arg reference} must be of length 1.")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
x <- as.POSIXlt(x, ...)
|
x <- as.POSIXlt(x, ...)
|
||||||
@@ -109,10 +109,10 @@ age <- function(x, reference = Sys.Date(), exact = FALSE, na.rm = FALSE, ...) {
|
|||||||
|
|
||||||
if (any(ages < 0, na.rm = TRUE)) {
|
if (any(ages < 0, na.rm = TRUE)) {
|
||||||
ages[!is.na(ages) & ages < 0] <- NA
|
ages[!is.na(ages) & ages < 0] <- NA
|
||||||
warning_("in `age()`: NAs introduced for ages below 0.")
|
warning_("in {.fun age}: NAs introduced for ages below 0.")
|
||||||
}
|
}
|
||||||
if (any(ages > 120, na.rm = TRUE)) {
|
if (any(ages > 120, na.rm = TRUE)) {
|
||||||
warning_("in `age()`: some ages are above 120.")
|
warning_("in {.fun age}: some ages are above 120.")
|
||||||
}
|
}
|
||||||
|
|
||||||
if (isTRUE(na.rm)) {
|
if (isTRUE(na.rm)) {
|
||||||
@@ -191,7 +191,7 @@ age_groups <- function(x, split_at = c(0, 12, 25, 55, 75), names = NULL, na.rm =
|
|||||||
|
|
||||||
if (any(x < 0, na.rm = TRUE)) {
|
if (any(x < 0, na.rm = TRUE)) {
|
||||||
x[x < 0] <- NA
|
x[x < 0] <- NA
|
||||||
warning_("in `age_groups()`: NAs introduced for ages below 0.")
|
warning_("in {.fun age_groups}: NAs introduced for ages below 0.")
|
||||||
}
|
}
|
||||||
if (is.character(split_at)) {
|
if (is.character(split_at)) {
|
||||||
split_at <- split_at[1L]
|
split_at <- split_at[1L]
|
||||||
@@ -211,7 +211,7 @@ age_groups <- function(x, split_at = c(0, 12, 25, 55, 75), names = NULL, na.rm =
|
|||||||
split_at <- c(0, split_at)
|
split_at <- c(0, split_at)
|
||||||
}
|
}
|
||||||
split_at <- split_at[!is.na(split_at)]
|
split_at <- split_at[!is.na(split_at)]
|
||||||
stop_if(length(split_at) == 1, "invalid value for `split_at`.") # only 0 is available
|
stop_if(length(split_at) == 1, "invalid value for {.arg split_at}.") # only 0 is available
|
||||||
|
|
||||||
# turn input values to 'split_at' indices
|
# turn input values to 'split_at' indices
|
||||||
y <- x
|
y <- x
|
||||||
@@ -228,7 +228,7 @@ age_groups <- function(x, split_at = c(0, 12, 25, 55, 75), names = NULL, na.rm =
|
|||||||
agegroups <- factor(lbls[y], levels = lbls, ordered = TRUE)
|
agegroups <- factor(lbls[y], levels = lbls, ordered = TRUE)
|
||||||
|
|
||||||
if (!is.null(names)) {
|
if (!is.null(names)) {
|
||||||
stop_ifnot(length(names) == length(levels(agegroups)), "`names` must have the same length as the number of age groups (", length(levels(agegroups)), ").")
|
stop_ifnot(length(names) == length(levels(agegroups)), "{.arg names} must have the same length as the number of age groups (", length(levels(agegroups)), ").")
|
||||||
levels(agegroups) <- names
|
levels(agegroups) <- names
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -233,12 +233,12 @@ av_url <- function(x, open = FALSE, ...) {
|
|||||||
|
|
||||||
NAs <- av_name(av, tolower = TRUE, language = NULL)[!is.na(av) & is.na(atcs)]
|
NAs <- av_name(av, tolower = TRUE, language = NULL)[!is.na(av) & is.na(atcs)]
|
||||||
if (length(NAs) > 0) {
|
if (length(NAs) > 0) {
|
||||||
warning_("in `av_url()`: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
|
warning_("in {.fun av_url}: no ATC code available for ", vector_and(NAs, quotes = FALSE), ".")
|
||||||
}
|
}
|
||||||
|
|
||||||
if (open == TRUE) {
|
if (open == TRUE) {
|
||||||
if (length(u) > 1 && !is.na(u[1L])) {
|
if (length(u) > 1 && !is.na(u[1L])) {
|
||||||
warning_("in `av_url()`: only the first URL will be opened, as `browseURL()` only suports one string.")
|
warning_("in {.fun av_url}: only the first URL will be opened, as {.fun browseURL} only suports one string.")
|
||||||
}
|
}
|
||||||
if (!is.na(u[1L])) {
|
if (!is.na(u[1L])) {
|
||||||
utils::browseURL(u[1L])
|
utils::browseURL(u[1L])
|
||||||
|
|||||||
@@ -82,9 +82,9 @@ bug_drug_combinations <- function(x,
|
|||||||
# -- mo
|
# -- mo
|
||||||
if (is.null(col_mo)) {
|
if (is.null(col_mo)) {
|
||||||
col_mo <- search_type_in_df(x = x, type = "mo")
|
col_mo <- search_type_in_df(x = x, type = "mo")
|
||||||
stop_if(is.null(col_mo), "`col_mo` must be set")
|
stop_if(is.null(col_mo), "{.arg col_mo} must be set")
|
||||||
} else {
|
} else {
|
||||||
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' (`col_mo`) not found")
|
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' ({.arg col_mo}) not found")
|
||||||
}
|
}
|
||||||
|
|
||||||
x.bak <- x
|
x.bak <- x
|
||||||
@@ -226,7 +226,7 @@ format.bug_drug_combinations <- function(x,
|
|||||||
x.bak <- x
|
x.bak <- x
|
||||||
if (inherits(x, "grouped")) {
|
if (inherits(x, "grouped")) {
|
||||||
# bug_drug_combinations() has been run on groups, so de-group here
|
# bug_drug_combinations() has been run on groups, so de-group here
|
||||||
warning_("in `format()`: formatting the output of `bug_drug_combinations()` does not support grouped variables, they were ignored")
|
warning_("in {.fun format}: formatting the output of {.fun bug_drug_combinations} does not support grouped variables, they were ignored")
|
||||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||||
idx <- split(seq_len(nrow(x)), paste0(x$mo, "%%", x$ab))
|
idx <- split(seq_len(nrow(x)), paste0(x$mo, "%%", x$ab))
|
||||||
x <- data.frame(
|
x <- data.frame(
|
||||||
|
|||||||
@@ -166,5 +166,5 @@ clear_custom_antimicrobials <- function() {
|
|||||||
n2 <- nrow(AMR_env$AB_lookup)
|
n2 <- nrow(AMR_env$AB_lookup)
|
||||||
AMR_env$custom_ab_codes <- character(0)
|
AMR_env$custom_ab_codes <- character(0)
|
||||||
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(AMR_env$ab_previously_coerced$ab %in% AMR_env$AB_lookup$ab), , drop = FALSE]
|
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(AMR_env$ab_previously_coerced$ab %in% AMR_env$AB_lookup$ab), , drop = FALSE]
|
||||||
message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal `antimicrobials` data set.")
|
message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal {.topic [antimicrobials](AMR::antimicrobials)} data set.")
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -266,8 +266,8 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
|
|||||||
)
|
)
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
stop_ifnot(is.logical(qry), "in {.help [{.fun custom_mdro_guideline}](AMR::custom_mdro_guideline)}: rule ", i, " (`", guideline[[i]]$query,
|
stop_ifnot(is.logical(qry), "in {.help [{.fun custom_mdro_guideline}](AMR::custom_mdro_guideline)}: rule ", i, " ({.code ", guideline[[i]]$query,
|
||||||
"`) must return {.code TRUE} or {.code FALSE}, not ",
|
"}) must return {.code TRUE} or {.code FALSE}, not ",
|
||||||
format_class(class(qry), plural = FALSE),
|
format_class(class(qry), plural = FALSE),
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
|
|||||||
@@ -128,7 +128,7 @@
|
|||||||
#' }
|
#' }
|
||||||
add_custom_microorganisms <- function(x) {
|
add_custom_microorganisms <- function(x) {
|
||||||
meet_criteria(x, allow_class = "data.frame")
|
meet_criteria(x, allow_class = "data.frame")
|
||||||
stop_ifnot("genus" %in% tolower(colnames(x)), paste0("`x` must contain column 'genus'."))
|
stop_ifnot("genus" %in% tolower(colnames(x)), "{.arg x} must contain column 'genus'.")
|
||||||
|
|
||||||
add_MO_lookup_to_AMR_env()
|
add_MO_lookup_to_AMR_env()
|
||||||
|
|
||||||
|
|||||||
2
R/disk.R
2
R/disk.R
@@ -119,7 +119,7 @@ as.disk <- function(x, na.rm = FALSE) {
|
|||||||
sort() %pm>%
|
sort() %pm>%
|
||||||
vector_and(quotes = TRUE)
|
vector_and(quotes = TRUE)
|
||||||
cur_col <- get_current_column()
|
cur_col <- get_current_column()
|
||||||
warning_("in `as.disk()`: ", na_after - na_before, " result",
|
warning_("in {.fun as.disk}: ", na_after - na_before, " result",
|
||||||
ifelse(na_after - na_before > 1, "s", ""),
|
ifelse(na_after - na_before > 1, "s", ""),
|
||||||
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
||||||
" truncated (",
|
" truncated (",
|
||||||
|
|||||||
@@ -215,7 +215,7 @@ is_new_episode <- function(x, episode_days = NULL, case_free_days = NULL, ...) {
|
|||||||
|
|
||||||
exec_episode <- function(x, episode_days, case_free_days, ...) {
|
exec_episode <- function(x, episode_days, case_free_days, ...) {
|
||||||
stop_ifnot(is.null(episode_days) || is.null(case_free_days),
|
stop_ifnot(is.null(episode_days) || is.null(case_free_days),
|
||||||
"either argument `episode_days` or argument `case_free_days` must be set.",
|
"either argument {.arg episode_days} or argument {.arg case_free_days} must be set.",
|
||||||
call = -2
|
call = -2
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|||||||
@@ -295,7 +295,7 @@ geom_sir <- function(position = NULL,
|
|||||||
...) {
|
...) {
|
||||||
x <- x[1]
|
x <- x[1]
|
||||||
stop_ifnot_installed("ggplot2")
|
stop_ifnot_installed("ggplot2")
|
||||||
stop_if(is.data.frame(position), "`position` is invalid. Did you accidentally use '%>%' instead of '+'?")
|
stop_if(is.data.frame(position), "{.arg position} is invalid. Did you accidentally use {.code %>%} instead of {.code +}?")
|
||||||
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
|
meet_criteria(position, allow_class = "character", has_length = 1, is_in = c("fill", "stack", "dodge"), allow_NULL = TRUE)
|
||||||
meet_criteria(x, allow_class = "character", has_length = 1)
|
meet_criteria(x, allow_class = "character", has_length = 1)
|
||||||
meet_criteria(fill, allow_class = "character", has_length = 1)
|
meet_criteria(fill, allow_class = "character", has_length = 1)
|
||||||
|
|||||||
@@ -267,7 +267,7 @@ get_column_abx <- function(x,
|
|||||||
if (all_okay == TRUE) {
|
if (all_okay == TRUE) {
|
||||||
message_(" OK.", as_note = FALSE)
|
message_(" OK.", as_note = FALSE)
|
||||||
} else if (!isFALSE(dups)) {
|
} else if (!isFALSE(dups)) {
|
||||||
message_("WARNING: some results from {.help [{.fun as.ab}](AMR::as.ab)} are duplicated: ", vector_and(dups, quotes = "`"), as_note = FALSE)
|
message_("WARNING: some results from {.help [{.fun as.ab}](AMR::as.ab)} are duplicated: ", vector_and(dups, quotes = FALSE), as_note = FALSE)
|
||||||
} else {
|
} else {
|
||||||
message_(" WARNING.", as_note = FALSE)
|
message_(" WARNING.", as_note = FALSE)
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -1062,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 {.help [{.fun eucast_rules}](AMR::eucast_rules)}: not all columns with antimicrobial results are of class 'sir'. Transform them on beforehand, with e.g.:\n",
|
"in {.help [{.fun eucast_rules}](AMR::eucast_rules)}: not all columns with antimicrobial results are of class {.cls sir}. Transform them on beforehand, e.g.:\n",
|
||||||
" - ", highlight_code(paste0(x_deparsed, " %>% as.sir(", ifelse(length(warn_lacking_sir_class) == 1,
|
" - ", highlight_code(paste0(x_deparsed, " %>% as.sir(", ifelse(length(warn_lacking_sir_class) == 1,
|
||||||
warn_lacking_sir_class,
|
warn_lacking_sir_class,
|
||||||
paste0(warn_lacking_sir_class[1], ":", warn_lacking_sir_class[length(warn_lacking_sir_class)])
|
paste0(warn_lacking_sir_class[1], ":", warn_lacking_sir_class[length(warn_lacking_sir_class)])
|
||||||
|
|||||||
@@ -185,7 +185,7 @@ join_microorganisms <- function(type, x, by, suffix, ...) {
|
|||||||
}
|
}
|
||||||
|
|
||||||
if (type %like% "full|left|right|inner" && NROW(joined) > NROW(x)) {
|
if (type %like% "full|left|right|inner" && NROW(joined) > NROW(x)) {
|
||||||
warning_("in `{type}_microorganisms()`: the newly joined data set contains {nrow(joined) - nrow(x)} rows more than the number of rows of {.arg x}.")
|
warning_("in {.fun {type}_microorganisms}: the newly joined data set contains {nrow(joined) - nrow(x)} rows more than the number of rows of {.arg x}.")
|
||||||
}
|
}
|
||||||
|
|
||||||
as_original_data_class(joined, class(x.bak)) # will remove tibble groups
|
as_original_data_class(joined, class(x.bak)) # will remove tibble groups
|
||||||
|
|||||||
@@ -159,7 +159,7 @@ key_antimicrobials <- function(x = NULL,
|
|||||||
col_mo <- search_type_in_df(x = x, type = "mo", info = FALSE)
|
col_mo <- search_type_in_df(x = x, type = "mo", info = FALSE)
|
||||||
}
|
}
|
||||||
if (is.null(col_mo)) {
|
if (is.null(col_mo)) {
|
||||||
warning_("in `key_antimicrobials()`: no column found for `col_mo`, ignoring antibiotics set in `gram_negative` and `gram_positive`, and antimycotics set in `antifungal`")
|
warning_("in {.fun key_antimicrobials}: no column found for {.arg col_mo}, ignoring antibiotics set in {.arg gram_negative} and {.arg gram_positive}, and antimycotics set in {.arg antifungal}")
|
||||||
gramstain <- NA_character_
|
gramstain <- NA_character_
|
||||||
kingdom <- NA_character_
|
kingdom <- NA_character_
|
||||||
} else {
|
} else {
|
||||||
@@ -237,7 +237,7 @@ key_antimicrobials <- function(x = NULL,
|
|||||||
)
|
)
|
||||||
|
|
||||||
if (length(unique(key_ab)) == 1) {
|
if (length(unique(key_ab)) == 1) {
|
||||||
warning_("in `key_antimicrobials()`: no distinct key antibiotics determined.")
|
warning_("in {.fun key_antimicrobials}: no distinct key antibiotics determined.")
|
||||||
}
|
}
|
||||||
|
|
||||||
key_ab
|
key_ab
|
||||||
@@ -310,7 +310,7 @@ antimicrobials_equal <- function(y,
|
|||||||
meet_criteria(type, allow_class = "character", has_length = 1, is_in = c("points", "keyantimicrobials"))
|
meet_criteria(type, allow_class = "character", has_length = 1, is_in = c("points", "keyantimicrobials"))
|
||||||
meet_criteria(ignore_I, allow_class = "logical", has_length = 1)
|
meet_criteria(ignore_I, allow_class = "logical", has_length = 1)
|
||||||
meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
|
meet_criteria(points_threshold, allow_class = c("numeric", "integer"), has_length = 1, is_positive = TRUE, is_finite = TRUE)
|
||||||
stop_ifnot(length(y) == length(z), "length of `y` and `z` must be equal")
|
stop_ifnot(length(y) == length(z), "length of {.arg y} and {.arg z} must be equal")
|
||||||
|
|
||||||
key2sir <- function(val) {
|
key2sir <- function(val) {
|
||||||
val <- strsplit(val, "", fixed = TRUE)[[1L]]
|
val <- strsplit(val, "", fixed = TRUE)[[1L]]
|
||||||
|
|||||||
8
R/mic.R
8
R/mic.R
@@ -269,7 +269,7 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all", round_to_next_log2
|
|||||||
sort() %pm>%
|
sort() %pm>%
|
||||||
vector_and(quotes = TRUE)
|
vector_and(quotes = TRUE)
|
||||||
cur_col <- get_current_column()
|
cur_col <- get_current_column()
|
||||||
warning_("in `as.mic()`: ", na_after - na_before, " result",
|
warning_("in {.fun as.mic}: ", na_after - na_before, " result",
|
||||||
ifelse(na_after - na_before > 1, "s", ""),
|
ifelse(na_after - na_before > 1, "s", ""),
|
||||||
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
||||||
" truncated (",
|
" truncated (",
|
||||||
@@ -441,7 +441,7 @@ all_valid_mics <- function(x) {
|
|||||||
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, mic)
|
#' @rawNamespace if(getRversion() >= "3.0.0") S3method(pillar::pillar_shaft, mic)
|
||||||
pillar_shaft.mic <- function(x, ...) {
|
pillar_shaft.mic <- function(x, ...) {
|
||||||
if (!identical(levels(x), VALID_MIC_LEVELS) && message_not_thrown_before("pillar_shaft.mic")) {
|
if (!identical(levels(x), VALID_MIC_LEVELS) && message_not_thrown_before("pillar_shaft.mic")) {
|
||||||
warning_(AMR_env$sup_1_icon, " These columns contain an outdated or altered structure - convert with `as.mic()` to update",
|
warning_(AMR_env$sup_1_icon, " These columns contain an outdated or altered structure - convert with {.fun as.mic} to update",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -508,7 +508,7 @@ as.vector.mic <- function(x, mode = "numneric", ...) {
|
|||||||
y <- as.mic(y)
|
y <- as.mic(y)
|
||||||
calls <- unlist(lapply(sys.calls(), as.character))
|
calls <- unlist(lapply(sys.calls(), as.character))
|
||||||
if (any(calls %in% c("rbind", "cbind")) && message_not_thrown_before("as.vector.mic")) {
|
if (any(calls %in% c("rbind", "cbind")) && message_not_thrown_before("as.vector.mic")) {
|
||||||
warning_("Functions `rbind()` and `cbind()` cannot preserve the structure of MIC values. Use dplyr's `bind_rows()` or `bind_cols()` instead.", call = FALSE)
|
warning_("Functions {.fun rbind} and {.fun cbind} cannot preserve the structure of MIC values. Use {.pkg dplyr}'s {.fun bind_rows} or {.fun bind_cols} instead.", call = FALSE)
|
||||||
}
|
}
|
||||||
y
|
y
|
||||||
}
|
}
|
||||||
@@ -601,7 +601,7 @@ sort.mic <- function(x, decreasing = FALSE, ...) {
|
|||||||
#' @export
|
#' @export
|
||||||
#' @noRd
|
#' @noRd
|
||||||
hist.mic <- function(x, ...) {
|
hist.mic <- function(x, ...) {
|
||||||
warning_("in `hist()`: use `plot()` or ggplot2's `autoplot()` for optimal plotting of MIC values")
|
warning_("in {.fun hist}: use {.fun plot} or {.pkg ggplot2}'s {.fun autoplot} for optimal plotting of MIC values")
|
||||||
hist(log2(x))
|
hist(log2(x))
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
6
R/mo.R
6
R/mo.R
@@ -500,7 +500,7 @@ as.mo <- function(x,
|
|||||||
)
|
)
|
||||||
if (any(out %in% AMR_env$MO_lookup$mo[match(post_Becker, AMR_env$MO_lookup$fullname)])) {
|
if (any(out %in% AMR_env$MO_lookup$mo[match(post_Becker, AMR_env$MO_lookup$fullname)])) {
|
||||||
if (message_not_thrown_before("as.mo", "becker")) {
|
if (message_not_thrown_before("as.mo", "becker")) {
|
||||||
warning_("in `as.mo()`: Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ",
|
warning_("in {.fun as.mo}: Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ",
|
||||||
vector_and(font_italic(gsub("Staphylococcus", "S.", post_Becker, fixed = TRUE), collapse = NULL), quotes = FALSE),
|
vector_and(font_italic(gsub("Staphylococcus", "S.", post_Becker, fixed = TRUE), collapse = NULL), quotes = FALSE),
|
||||||
". Categorisation to CoNS/CoPS was taken from the original scientific publication(s).",
|
". Categorisation to CoNS/CoPS was taken from the original scientific publication(s).",
|
||||||
immediate = TRUE, call = FALSE
|
immediate = TRUE, call = FALSE
|
||||||
@@ -545,7 +545,7 @@ as.mo <- function(x,
|
|||||||
out[is.na(out) & !is.na(x)] <- "UNKNOWN"
|
out[is.na(out) & !is.na(x)] <- "UNKNOWN"
|
||||||
AMR_env$mo_failures <- unique(x[out == "UNKNOWN" & !toupper(x) %in% c("UNKNOWN", "CON", "UNK") & !x %like_case% "^[(]unknown [a-z]+[)]$" & !is.na(x)])
|
AMR_env$mo_failures <- unique(x[out == "UNKNOWN" & !toupper(x) %in% c("UNKNOWN", "CON", "UNK") & !x %like_case% "^[(]unknown [a-z]+[)]$" & !is.na(x)])
|
||||||
if (length(AMR_env$mo_failures) > 0) {
|
if (length(AMR_env$mo_failures) > 0) {
|
||||||
warning_("The following input could not be coerced and was returned as \"UNKNOWN\": ", vector_and(AMR_env$mo_failures, quotes = TRUE), ".\nYou can retrieve this list with `mo_failures()`.", call = FALSE)
|
warning_("The following input could not be coerced and was returned as \"UNKNOWN\": ", vector_and(AMR_env$mo_failures, quotes = TRUE), ".\nYou can retrieve this list with {.fun mo_failures}.", call = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
# Return class ----
|
# Return class ----
|
||||||
@@ -1049,7 +1049,7 @@ print.mo_renamed <- function(x, extra_txt = "", n = 25, ...) {
|
|||||||
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
|
" -> ", font_italic(x$new[rows], collapse = NULL), x$ref_new[rows],
|
||||||
collapse = "\n"
|
collapse = "\n"
|
||||||
),
|
),
|
||||||
ifelse(NROW(x) > n, paste0("\n\nOnly the first ", n, " (out of ", NROW(x), ") are shown. Run `print(mo_renamed(), n = ...)` to view more entries (might be slow), or save `mo_renamed()` to an object."), "")
|
ifelse(NROW(x) > n, paste0("\n\nOnly the first ", n, " (out of ", NROW(x), ") are shown. Run {.code print(mo_renamed(), n = ...)} to view more entries (might be slow), or save {.fun mo_renamed} to an object."), "")
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -584,7 +584,7 @@ mo_is_intrinsic_resistant <- function(x, ab, language = get_AMR_locale(), keep_s
|
|||||||
ab <- rep(ab, length(x))
|
ab <- rep(ab, length(x))
|
||||||
}
|
}
|
||||||
if (length(x) != length(ab)) {
|
if (length(x) != length(ab)) {
|
||||||
stop_("length of `x` and `ab` must be equal, or one of them must be of length 1.")
|
stop_("length of {.arg x} and {.arg ab} must be equal, or one of them must be of length 1.")
|
||||||
}
|
}
|
||||||
|
|
||||||
# show used version number once per session (AMR_env will reload every session)
|
# show used version number once per session (AMR_env will reload every session)
|
||||||
@@ -943,7 +943,7 @@ mo_url <- function(x, open = FALSE, language = get_AMR_locale(), keep_synonyms =
|
|||||||
|
|
||||||
if (isTRUE(open)) {
|
if (isTRUE(open)) {
|
||||||
if (length(u) > 1) {
|
if (length(u) > 1) {
|
||||||
warning_("in `mo_url()`: only the first URL will be opened, as R's built-in function `browseURL()` only suports one string.")
|
warning_("in {.fun mo_url}: only the first URL will be opened, as R's built-in function {.fun browseURL} only suports one string.")
|
||||||
}
|
}
|
||||||
utils::browseURL(u[1L])
|
utils::browseURL(u[1L])
|
||||||
}
|
}
|
||||||
|
|||||||
2
R/pca.R
2
R/pca.R
@@ -114,7 +114,7 @@ pca <- function(x,
|
|||||||
|
|
||||||
x <- as.data.frame(new_list, stringsAsFactors = FALSE)
|
x <- as.data.frame(new_list, stringsAsFactors = FALSE)
|
||||||
if (any(vapply(FUN.VALUE = logical(1), x, function(y) !is.numeric(y)))) {
|
if (any(vapply(FUN.VALUE = logical(1), x, function(y) !is.numeric(y)))) {
|
||||||
warning_("in `pca()`: be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. See Examples in `?pca`.", call = FALSE)
|
warning_("in {.fun pca}: be sure to first calculate the resistance (or susceptibility) of variables with antimicrobial test results, since PCA works with numeric variables only. See {.help [{.fun pca}](AMR::pca)}.", call = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
# set column names
|
# set column names
|
||||||
|
|||||||
@@ -258,11 +258,11 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
|
|||||||
} else if (any(other_x %in% colnames(df))) {
|
} else if (any(other_x %in% colnames(df))) {
|
||||||
aest_val <- intersect(other_x, colnames(df))[1]
|
aest_val <- intersect(other_x, colnames(df))[1]
|
||||||
} else {
|
} else {
|
||||||
stop_("No support for plotting df with `scale_", aest, "_mic()` with columns ", vector_and(colnames(df), sort = FALSE))
|
stop_("No support for plotting df with {.fun scale_", aest, "_mic} with columns ", vector_and(colnames(df), sort = FALSE))
|
||||||
}
|
}
|
||||||
mics <- rescale_mic(x = as.double(as.mic(df[[aest_val]])), keep_operators = "none", mic_range = NULL, as.mic = TRUE)
|
mics <- rescale_mic(x = as.double(as.mic(df[[aest_val]])), keep_operators = "none", mic_range = NULL, as.mic = TRUE)
|
||||||
if (!is.null(self$mic_values_rescaled) && any(mics < min(self$mic_values_rescaled, na.rm = TRUE) | mics > max(self$mic_values_rescaled, na.rm = TRUE), na.rm = TRUE)) {
|
if (!is.null(self$mic_values_rescaled) && any(mics < min(self$mic_values_rescaled, na.rm = TRUE) | mics > max(self$mic_values_rescaled, na.rm = TRUE), na.rm = TRUE)) {
|
||||||
warning_("The value for `", aest_val, "` is outside the plotted MIC range, consider using/updating the `mic_range` argument in `scale_", aest, "_mic()`.")
|
warning_("The value for {.field ", aest_val, "} is outside the plotted MIC range, consider using/updating the {.arg mic_range} argument in {.fun scale_", aest, "_mic}.")
|
||||||
}
|
}
|
||||||
out[[aest_val]] <- log2(as.double(mics))
|
out[[aest_val]] <- log2(as.double(mics))
|
||||||
} else {
|
} else {
|
||||||
@@ -1443,10 +1443,10 @@ scale_sir_colours <- function(...,
|
|||||||
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
|
meet_criteria(colours_SIR, allow_class = "character", has_length = c(1, 3, 4))
|
||||||
|
|
||||||
if ("fill" %in% aesthetics && message_not_thrown_before("scale_sir_colours", "fill", entire_session = TRUE)) {
|
if ("fill" %in% aesthetics && message_not_thrown_before("scale_sir_colours", "fill", entire_session = TRUE)) {
|
||||||
warning_("Using `scale_sir_colours()` for the `fill` aesthetic has been superseded by `scale_fill_sir()`, please use that instead. This warning will be shown once per session.")
|
warning_("Using {.fun scale_sir_colours} for the {.code fill} aesthetic has been superseded by {.fun scale_fill_sir}, please use that instead. This warning will be shown once per session.")
|
||||||
}
|
}
|
||||||
if (any(c("colour", "color") %in% aesthetics) && message_not_thrown_before("scale_sir_colours", "colour", entire_session = TRUE)) {
|
if (any(c("colour", "color") %in% aesthetics) && message_not_thrown_before("scale_sir_colours", "colour", entire_session = TRUE)) {
|
||||||
warning_("Using `scale_sir_colours()` for the `colour` aesthetic has been superseded by `scale_colour_sir()`, please use that instead. This warning will be shown once per session.")
|
warning_("Using {.fun scale_sir_colours} for the {.code colour} aesthetic has been superseded by {.fun scale_colour_sir}, please use that instead. This warning will be shown once per session.")
|
||||||
}
|
}
|
||||||
|
|
||||||
if ("colours" %in% names(list(...))) {
|
if ("colours" %in% names(list(...))) {
|
||||||
|
|||||||
@@ -138,7 +138,7 @@ resistance_predict <- function(x,
|
|||||||
extra_msg = paste0("Use the tidymodels framework instead, for which we have written a basic and short introduction on our website: ", font_url("https://amr-for-r.org/articles/AMR_with_tidymodels.html", txt = font_bold("AMR with tidymodels")))
|
extra_msg = paste0("Use the tidymodels framework instead, for which we have written a basic and short introduction on our website: ", font_url("https://amr-for-r.org/articles/AMR_with_tidymodels.html", txt = font_bold("AMR with tidymodels")))
|
||||||
)
|
)
|
||||||
|
|
||||||
stop_if(is.null(model), 'choose a regression model with the `model` argument, e.g. resistance_predict(..., model = "binomial")')
|
stop_if(is.null(model), 'choose a regression model with the {.arg model} argument, e.g. {.code resistance_predict(..., model = "binomial")}')
|
||||||
|
|
||||||
x.bak <- x
|
x.bak <- x
|
||||||
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
x <- as.data.frame(x, stringsAsFactors = FALSE)
|
||||||
@@ -146,7 +146,7 @@ resistance_predict <- function(x,
|
|||||||
# -- date
|
# -- date
|
||||||
if (is.null(col_date)) {
|
if (is.null(col_date)) {
|
||||||
col_date <- search_type_in_df(x = x, type = "date")
|
col_date <- search_type_in_df(x = x, type = "date")
|
||||||
stop_if(is.null(col_date), "`col_date` must be set")
|
stop_if(is.null(col_date), "{.arg col_date} must be set")
|
||||||
}
|
}
|
||||||
stop_ifnot(
|
stop_ifnot(
|
||||||
col_date %in% colnames(x),
|
col_date %in% colnames(x),
|
||||||
@@ -357,7 +357,7 @@ ggplot_sir_predict <- function(x,
|
|||||||
meet_criteria(ribbon, allow_class = "logical", has_length = 1)
|
meet_criteria(ribbon, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
stop_ifnot_installed("ggplot2")
|
stop_ifnot_installed("ggplot2")
|
||||||
stop_ifnot(inherits(x, "resistance_predict"), "`x` must be a resistance prediction model created with resistance_predict()")
|
stop_ifnot(inherits(x, "resistance_predict"), "{.arg x} must be a resistance prediction model created with {.fun resistance_predict}")
|
||||||
|
|
||||||
if (attributes(x)$I_as_S == TRUE) {
|
if (attributes(x)$I_as_S == TRUE) {
|
||||||
ylab <- "%R"
|
ylab <- "%R"
|
||||||
|
|||||||
6
R/sir.R
6
R/sir.R
@@ -816,7 +816,7 @@ as.sir.data.frame <- function(x,
|
|||||||
# column found, transform to logical
|
# column found, transform to logical
|
||||||
stop_if(
|
stop_if(
|
||||||
length(col_uti) != 1 | !col_uti %in% colnames(x),
|
length(col_uti) != 1 | !col_uti %in% colnames(x),
|
||||||
"argument `uti` must be a [logical] vector, of must be a single column name of `x`"
|
"argument {.arg uti} must be a [logical] vector, or must be a single column name of {.arg x}"
|
||||||
)
|
)
|
||||||
uti <- as.logical(x[, col_uti, drop = TRUE])
|
uti <- as.logical(x[, col_uti, drop = TRUE])
|
||||||
}
|
}
|
||||||
@@ -1720,7 +1720,7 @@ as_sir_method <- function(method_short,
|
|||||||
pm_filter(uti == FALSE)
|
pm_filter(uti == FALSE)
|
||||||
notes_current <- paste0(
|
notes_current <- paste0(
|
||||||
notes_current, "\n",
|
notes_current, "\n",
|
||||||
paste0("Breakpoints for UTI ", font_bold("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, ". Use argument `uti` to set which isolates are from urine. See {.help [{.fun as.sir}](AMR::as.sir)}.")
|
paste0("Breakpoints for UTI ", font_bold("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, ". Use argument {.arg uti} to set which isolates are from urine. See {.help [{.fun as.sir}](AMR::as.sir)}.")
|
||||||
)
|
)
|
||||||
} else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && all(breakpoints_current$uti == FALSE, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteOther", mo_current, ab_current)) {
|
} else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && all(breakpoints_current$uti == FALSE, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteOther", mo_current, ab_current)) {
|
||||||
# breakpoints for multiple body sites available
|
# breakpoints for multiple body sites available
|
||||||
@@ -1943,7 +1943,7 @@ as_sir_method <- function(method_short,
|
|||||||
# if (isTRUE(verbose) || length(notes) == 1 || NROW(AMR_env$sir_interpretation_history) == 0) {
|
# if (isTRUE(verbose) || length(notes) == 1 || NROW(AMR_env$sir_interpretation_history) == 0) {
|
||||||
if (isTRUE(verbose)) {
|
if (isTRUE(verbose)) {
|
||||||
for (i in seq_along(notes)) {
|
for (i in seq_along(notes)) {
|
||||||
message(word_wrap(" ", AMR_env$bullet_icon, " ", notes[i]))
|
message_(notes[i], as_note = FALSE)
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
# message(word_wrap(" ", AMR_env$bullet_icon, " There were multiple notes. Print or View `sir_interpretation_history()` to examine them, or use `as.sir(..., verbose = TRUE)` next time to directly print them here.", add_fn = font_black))
|
# message(word_wrap(" ", AMR_env$bullet_icon, " There were multiple notes. Print or View `sir_interpretation_history()` to examine them, or use `as.sir(..., verbose = TRUE)` next time to directly print them here.", add_fn = font_black))
|
||||||
|
|||||||
@@ -144,7 +144,7 @@ sir_calc <- function(...,
|
|||||||
FUN = min
|
FUN = min
|
||||||
)
|
)
|
||||||
if ("SDD" %in% ab_result && "SDD" %in% y && message_not_thrown_before("sir_calc", only_count, ab_result, entire_session = TRUE)) {
|
if ("SDD" %in% ab_result && "SDD" %in% y && message_not_thrown_before("sir_calc", only_count, ab_result, entire_session = TRUE)) {
|
||||||
message_("Note that `", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "()` will also include dose-dependent susceptibility, {.val SDD}. This note will be shown once for this session.", as_note = FALSE)
|
message_("Note that {.fun ", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "} will also include dose-dependent susceptibility, {.val SDD}. This note will be shown once for this session.", as_note = FALSE)
|
||||||
}
|
}
|
||||||
numerator <- sum(!is.na(y) & y %in% as.double(ab_result), na.rm = TRUE)
|
numerator <- sum(!is.na(y) & y %in% as.double(ab_result), na.rm = TRUE)
|
||||||
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(anyNA(y))))
|
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(anyNA(y))))
|
||||||
@@ -152,7 +152,7 @@ sir_calc <- function(...,
|
|||||||
# may contain NAs in any column
|
# may contain NAs in any column
|
||||||
other_values <- setdiff(c(NA, denominator_vals), ab_result)
|
other_values <- setdiff(c(NA, denominator_vals), ab_result)
|
||||||
if ("SDD" %in% ab_result && "SDD" %in% unlist(x_transposed) && message_not_thrown_before("sir_calc", only_count, ab_result, entire_session = TRUE)) {
|
if ("SDD" %in% ab_result && "SDD" %in% unlist(x_transposed) && message_not_thrown_before("sir_calc", only_count, ab_result, entire_session = TRUE)) {
|
||||||
message_("Note that `", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "()` will also include dose-dependent susceptibility, {.val SDD}. This note will be shown once for this session.", as_note = FALSE)
|
message_("Note that {.fun ", ifelse(only_count, "count", "proportion"), "_", ifelse("S" %in% ab_result, "S", ""), "I", ifelse("R" %in% ab_result, "R", ""), "} will also include dose-dependent susceptibility, {.val SDD}. This note will be shown once for this session.", as_note = FALSE)
|
||||||
}
|
}
|
||||||
numerator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) any(y %in% ab_result, na.rm = TRUE)))
|
numerator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) any(y %in% ab_result, na.rm = TRUE)))
|
||||||
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(all(y %in% other_values) & anyNA(y))))
|
denominator <- sum(vapply(FUN.VALUE = logical(1), x_transposed, function(y) !(all(y %in% other_values) & anyNA(y))))
|
||||||
|
|||||||
@@ -62,7 +62,7 @@ top_n_microorganisms <- function(x, n, property = "species", n_for_each = NULL,
|
|||||||
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
meet_criteria(col_mo, allow_class = "character", has_length = 1, allow_NULL = TRUE, is_in = colnames(x))
|
||||||
if (is.null(col_mo)) {
|
if (is.null(col_mo)) {
|
||||||
col_mo <- search_type_in_df(x = x, type = "mo", info = TRUE)
|
col_mo <- search_type_in_df(x = x, type = "mo", info = TRUE)
|
||||||
stop_if(is.null(col_mo), "`col_mo` must be set")
|
stop_if(is.null(col_mo), "{.arg col_mo} must be set")
|
||||||
}
|
}
|
||||||
|
|
||||||
x.bak <- x
|
x.bak <- x
|
||||||
|
|||||||
Reference in New Issue
Block a user