mirror of
https://github.com/msberends/AMR.git
synced 2026-03-30 21:36:05 +02:00
Compare commits
4 Commits
0cc154257a
...
8760c6d85a
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
8760c6d85a | ||
|
|
3928a3de55 | ||
|
|
10c00ff606 | ||
|
|
b7edf3e548 |
@@ -382,6 +382,14 @@ pkg_is_available <- function(pkg, also_load = FALSE, min_version = NULL) {
|
|||||||
isTRUE(out)
|
isTRUE(out)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
highlight_code <- function(code) {
|
||||||
|
if (pkg_is_available("cli", min_version = "3.0.0")) {
|
||||||
|
cli::code_highlight(code)
|
||||||
|
} else {
|
||||||
|
code
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
import_fn <- function(name, pkg, error_on_fail = TRUE) {
|
import_fn <- function(name, pkg, error_on_fail = TRUE) {
|
||||||
if (isTRUE(error_on_fail)) {
|
if (isTRUE(error_on_fail)) {
|
||||||
stop_ifnot_installed(pkg)
|
stop_ifnot_installed(pkg)
|
||||||
@@ -396,7 +404,7 @@ import_fn <- function(name, pkg, error_on_fail = TRUE) {
|
|||||||
getExportedValue(name = name, ns = asNamespace(pkg)),
|
getExportedValue(name = name, ns = asNamespace(pkg)),
|
||||||
error = function(e) {
|
error = function(e) {
|
||||||
if (isTRUE(error_on_fail)) {
|
if (isTRUE(error_on_fail)) {
|
||||||
stop_("function `", name, "()` is not an exported object from package '", pkg,
|
stop_("function {.code ", name, "()} is not an exported object from package '", pkg,
|
||||||
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
|
"'. Please create an issue at https://github.com/msberends/AMR/issues. Many thanks!",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
@@ -452,7 +460,16 @@ cli_to_plain <- function(msg, envir = parent.frame()) {
|
|||||||
msg <- apply_sub(msg, "\\{\\.pkg (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
|
msg <- apply_sub(msg, "\\{\\.pkg (\\{[^}]+\\}|[^}]+)\\}", function(c) resolve(c))
|
||||||
msg <- apply_sub(msg, "\\{\\.strong (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
|
msg <- apply_sub(msg, "\\{\\.strong (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
|
||||||
msg <- apply_sub(msg, "\\{\\.emph (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
|
msg <- apply_sub(msg, "\\{\\.emph (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("*", resolve(c), "*"))
|
||||||
msg <- apply_sub(msg, "\\{\\.help (\\{[^}]+\\}|[^}]+)\\}", function(c) paste0("`", resolve(c), "`"))
|
msg <- apply_sub(msg, "\\{\\.help ([^}]+)\\}", function(c) {
|
||||||
|
# Handle [display text](topic) markdown link format: extract just the display text
|
||||||
|
m <- regmatches(c, regexec("^\\[(.*)\\]\\([^)]*\\)$", c, perl = TRUE))[[1L]]
|
||||||
|
if (length(m) >= 2L) m[2L] else paste0("`", resolve(c), "`")
|
||||||
|
})
|
||||||
|
msg <- apply_sub(msg, "\\{\\.topic ([^}]+)\\}", function(c) {
|
||||||
|
# Handle [display text](topic) markdown link format: extract just the display text
|
||||||
|
m <- regmatches(c, regexec("^\\[(.*)\\]\\([^)]*\\)$", c, perl = TRUE))[[1L]]
|
||||||
|
if (length(m) >= 2L) m[2L] else paste0("?", resolve(c))
|
||||||
|
})
|
||||||
msg <- apply_sub(msg, "\\{\\.url (\\{[^}]+\\}|[^}]+)\\}", function(c) 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])
|
msg <- apply_sub(msg, "\\{\\.href ([^}]+)\\}", function(c) strsplit(resolve(c), " ", fixed = TRUE)[[1L]][1L])
|
||||||
|
|
||||||
@@ -487,7 +504,7 @@ word_wrap <- function(...,
|
|||||||
as_note = FALSE,
|
as_note = FALSE,
|
||||||
width = 0.95 * getOption("width"),
|
width = 0.95 * getOption("width"),
|
||||||
extra_indent = 0) {
|
extra_indent = 0) {
|
||||||
if (pkg_is_available("cli")) {
|
if (pkg_is_available("cli", min_version = "3.0.0")) {
|
||||||
return(paste0(c(...), collapse = ""))
|
return(paste0(c(...), collapse = ""))
|
||||||
}
|
}
|
||||||
msg <- paste0(c(...), collapse = "")
|
msg <- paste0(c(...), collapse = "")
|
||||||
@@ -524,7 +541,7 @@ word_wrap <- function(...,
|
|||||||
message_ <- function(...,
|
message_ <- function(...,
|
||||||
appendLF = TRUE,
|
appendLF = TRUE,
|
||||||
as_note = TRUE) {
|
as_note = TRUE) {
|
||||||
if (pkg_is_available("cli")) {
|
if (pkg_is_available("cli", min_version = "3.0.0")) {
|
||||||
msg <- paste0(c(...), collapse = "")
|
msg <- paste0(c(...), collapse = "")
|
||||||
if (isTRUE(as_note)) {
|
if (isTRUE(as_note)) {
|
||||||
cli::cli_inform(c("i" = msg), .envir = parent.frame())
|
cli::cli_inform(c("i" = msg), .envir = parent.frame())
|
||||||
@@ -540,7 +557,7 @@ message_ <- function(...,
|
|||||||
warning_ <- function(...,
|
warning_ <- function(...,
|
||||||
immediate = FALSE,
|
immediate = FALSE,
|
||||||
call = FALSE) {
|
call = FALSE) {
|
||||||
if (pkg_is_available("cli")) {
|
if (pkg_is_available("cli", min_version = "3.0.0")) {
|
||||||
msg <- paste0(c(...), collapse = "")
|
msg <- paste0(c(...), collapse = "")
|
||||||
cli::cli_warn(msg, .envir = parent.frame())
|
cli::cli_warn(msg, .envir = parent.frame())
|
||||||
} else {
|
} else {
|
||||||
@@ -554,7 +571,7 @@ warning_ <- function(...,
|
|||||||
# - wraps text to never break lines within words (plain-text fallback)
|
# - wraps text to never break lines within words (plain-text fallback)
|
||||||
stop_ <- function(..., call = TRUE) {
|
stop_ <- function(..., call = TRUE) {
|
||||||
msg <- paste0(c(...), collapse = "")
|
msg <- paste0(c(...), collapse = "")
|
||||||
if (pkg_is_available("cli")) {
|
if (pkg_is_available("cli", min_version = "3.0.0")) {
|
||||||
if (isTRUE(call)) {
|
if (isTRUE(call)) {
|
||||||
call_obj <- sys.call(-1)
|
call_obj <- sys.call(-1)
|
||||||
} else if (!isFALSE(call)) {
|
} else if (!isFALSE(call)) {
|
||||||
@@ -928,7 +945,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 {.help AMR::as.sir}().",
|
"See {.help [{.fun as.sir}](AMR::as.sir)}.",
|
||||||
immediate = TRUE
|
immediate = TRUE
|
||||||
)
|
)
|
||||||
sirs_eligible <- is_sir_eligible(x)
|
sirs_eligible <- is_sir_eligible(x)
|
||||||
|
|||||||
2
R/ab.R
2
R/ab.R
@@ -210,7 +210,7 @@ as.ab <- function(x, flag_multiple_results = TRUE, language = get_AMR_locale(),
|
|||||||
progress <- progress_ticker(n = sum(!already_known), n_min = 25, print = info) # start if n >= 25
|
progress <- progress_ticker(n = sum(!already_known), n_min = 25, print = info) # start if n >= 25
|
||||||
on.exit(close(progress))
|
on.exit(close(progress))
|
||||||
if (any(x_new[!already_known & !is.na(x_new)] %in% unlist(AMR_env$AV_lookup$generalised_all, use.names = FALSE), na.rm = TRUE)) {
|
if (any(x_new[!already_known & !is.na(x_new)] %in% unlist(AMR_env$AV_lookup$generalised_all, use.names = FALSE), na.rm = TRUE)) {
|
||||||
warning_("in `as.ab()`: some input seems to resemble antiviral drugs - use `as.av()` or e.g. `av_name()` for these, not `as.ab()` or e.g. `ab_name()`.")
|
warning_("in {.help [{.fun as.ab}](AMR::as.ab)}: some input seems to resemble antiviral drugs - use {.help [{.fun as.av}](AMR::as.av)} or e.g. {.help [{.fun av_name}](AMR::av_name)} for these, not {.help [{.fun as.ab}](AMR::as.ab)} or e.g. {.help [{.fun ab_name}](AMR::ab_name)}.")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -212,7 +212,7 @@ ab_from_text <- function(text,
|
|||||||
}
|
}
|
||||||
})
|
})
|
||||||
} else {
|
} else {
|
||||||
stop_("`type` must be either 'drug', 'dose' or 'administration'")
|
stop_("{.arg type} must be either 'drug', 'dose' or 'administration'")
|
||||||
}
|
}
|
||||||
|
|
||||||
# collapse text if needed
|
# collapse text if needed
|
||||||
|
|||||||
@@ -837,7 +837,7 @@ amr_select_exec <- function(function_name,
|
|||||||
#' @export
|
#' @export
|
||||||
#' @noRd
|
#' @noRd
|
||||||
print.amr_selector <- function(x, ...) {
|
print.amr_selector <- function(x, ...) {
|
||||||
warning_("It should never be needed to print an antimicrobial selector class. Are you using data.table? Then add the argument `with = FALSE`, see our examples at `?amr_selector`.",
|
warning_("It should never be needed to print an antimicrobial selector class. Are you using {.pkg data.table}? Then add the argument {.code with = FALSE}, see our examples at {.help [{.fun amr_selector}](AMR::amr_selector)}.",
|
||||||
immediate = TRUE
|
immediate = TRUE
|
||||||
)
|
)
|
||||||
cat("Class 'amr_selector'\n")
|
cat("Class 'amr_selector'\n")
|
||||||
@@ -1062,7 +1062,7 @@ message_agent_names <- function(function_name, agents, ab_group = NULL, examples
|
|||||||
if (message_not_thrown_before(function_name, sort(agents))) {
|
if (message_not_thrown_before(function_name, sort(agents))) {
|
||||||
if (length(agents) == 0) {
|
if (length(agents) == 0) {
|
||||||
if (is.null(ab_group)) {
|
if (is.null(ab_group)) {
|
||||||
message_("For `", function_name, "()` no antimicrobial drugs found", examples, ".")
|
message_("For {.help [{.fun ", function_name, "}](AMR::", function_name, ")} no antimicrobial drugs found", examples, ".")
|
||||||
} else if (ab_group == "administrable_per_os") {
|
} else if (ab_group == "administrable_per_os") {
|
||||||
message_("No orally administrable drugs found", examples, ".")
|
message_("No orally administrable drugs found", examples, ".")
|
||||||
} else if (ab_group == "administrable_iv") {
|
} else if (ab_group == "administrable_iv") {
|
||||||
|
|||||||
@@ -1198,7 +1198,7 @@ simulate_coverage <- function(params) {
|
|||||||
#' @param wisca_model The outcome of [wisca()] or [`antibiogram(..., wisca = TRUE)`][antibiogram()].
|
#' @param wisca_model The outcome of [wisca()] or [`antibiogram(..., wisca = TRUE)`][antibiogram()].
|
||||||
#' @rdname antibiogram
|
#' @rdname antibiogram
|
||||||
retrieve_wisca_parameters <- function(wisca_model, ...) {
|
retrieve_wisca_parameters <- function(wisca_model, ...) {
|
||||||
stop_ifnot(isTRUE(attributes(wisca_model)$wisca), "This function only applies to WISCA models. Use {.help AMR::wisca}() or {.help AMR::antibiogram}() (with {.code wisca = TRUE}) to create a WISCA model.")
|
stop_ifnot(isTRUE(attributes(wisca_model)$wisca), "This function only applies to WISCA models. Use {.help [{.fun wisca}](AMR::wisca)} or {.help [{.fun antibiogram}](AMR::antibiogram)} (with {.code wisca = TRUE}) to create a WISCA model.")
|
||||||
attributes(wisca_model)$wisca_parameters
|
attributes(wisca_model)$wisca_parameters
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -180,7 +180,7 @@ atc_online_property <- function(atc_code,
|
|||||||
colnames(out) <- gsub("^atc.*", "atc", tolower(colnames(out)))
|
colnames(out) <- gsub("^atc.*", "atc", tolower(colnames(out)))
|
||||||
|
|
||||||
if (length(out) == 0) {
|
if (length(out) == 0) {
|
||||||
message_("in {.help AMR::atc_online_property}(): no properties found for ATC ", atc_code[i], ". Please check {.href {atc_url} this WHOCC webpage}.")
|
message_("in {.help [{.fun atc_online_property}](AMR::atc_online_property)}: no properties found for ATC ", atc_code[i], ". Please check {.href {atc_url} this WHOCC webpage}.")
|
||||||
returnvalue[i] <- NA
|
returnvalue[i] <- NA
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -168,7 +168,7 @@ av_from_text <- function(text,
|
|||||||
}
|
}
|
||||||
})
|
})
|
||||||
} else {
|
} else {
|
||||||
stop_("`type` must be either 'drug', 'dose' or 'administration'")
|
stop_("{.arg type} must be either 'drug', 'dose' or 'administration'")
|
||||||
}
|
}
|
||||||
|
|
||||||
# collapse text if needed
|
# collapse text if needed
|
||||||
|
|||||||
@@ -128,7 +128,7 @@ count_resistant <- function(...,
|
|||||||
# other arguments for meet_criteria are handled by sir_calc()
|
# other arguments for meet_criteria are handled by sir_calc()
|
||||||
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1)
|
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1)
|
||||||
if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("count_resistant", "eucast_default", entire_session = TRUE)) {
|
if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("count_resistant", "eucast_default", entire_session = TRUE)) {
|
||||||
message_("`count_resistant()` assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the `guideline` argument or the `AMR_guideline` option to either \"CLSI\" or \"EUCAST\", see `?AMR-options`.")
|
message_("{.help [{.fun count_resistant}](AMR::count_resistant)} assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the {.arg guideline} argument or the {.code AMR_guideline} option to either \"CLSI\" or \"EUCAST\", see {.topic AMR-options}.")
|
||||||
message_("This message will be shown once per session.")
|
message_("This message will be shown once per session.")
|
||||||
}
|
}
|
||||||
tryCatch(
|
tryCatch(
|
||||||
@@ -152,7 +152,7 @@ count_susceptible <- function(...,
|
|||||||
# other arguments for meet_criteria are handled by sir_calc()
|
# other arguments for meet_criteria are handled by sir_calc()
|
||||||
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1)
|
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1)
|
||||||
if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("count_susceptible", "eucast_default", entire_session = TRUE)) {
|
if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("count_susceptible", "eucast_default", entire_session = TRUE)) {
|
||||||
message_("`count_susceptible()` assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the `guideline` argument or the `AMR_guideline` option to either \"CLSI\" or \"EUCAST\", see `?AMR-options`.")
|
message_("{.help [{.fun count_susceptible}](AMR::count_susceptible)} assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the {.arg guideline} argument or the {.code AMR_guideline} option to either \"CLSI\" or \"EUCAST\", see {.topic AMR-options}.")
|
||||||
message_("This message will be shown once per session.")
|
message_("This message will be shown once per session.")
|
||||||
}
|
}
|
||||||
tryCatch(
|
tryCatch(
|
||||||
|
|||||||
@@ -155,7 +155,7 @@ add_custom_antimicrobials <- function(x) {
|
|||||||
|
|
||||||
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$ab %in% c(x$ab, x$generalised_name) & !AMR_env$ab_previously_coerced$x %in% c(x$ab, x$generalised_name)), , drop = FALSE]
|
AMR_env$ab_previously_coerced <- AMR_env$ab_previously_coerced[which(!AMR_env$ab_previously_coerced$ab %in% c(x$ab, x$generalised_name) & !AMR_env$ab_previously_coerced$x %in% c(x$ab, x$generalised_name)), , drop = FALSE]
|
||||||
class(AMR_env$AB_lookup$ab) <- c("ab", "character")
|
class(AMR_env$AB_lookup$ab) <- c("ab", "character")
|
||||||
message_("Added ", nr2char(nrow(x)), " record", ifelse(nrow(x) > 1, "s", ""), " to the internal `antimicrobials` data set.")
|
message_("Added ", nr2char(nrow(x)), " record", ifelse(nrow(x) > 1, "s", ""), " to the internal {.code antimicrobials} data set.")
|
||||||
}
|
}
|
||||||
|
|
||||||
#' @rdname add_custom_antimicrobials
|
#' @rdname add_custom_antimicrobials
|
||||||
|
|||||||
@@ -150,15 +150,15 @@ custom_eucast_rules <- function(...) {
|
|||||||
)
|
)
|
||||||
stop_if(
|
stop_if(
|
||||||
identical(dots, "error"),
|
identical(dots, "error"),
|
||||||
"rules must be a valid formula inputs (e.g., using '~'), see {.help AMR::custom_eucast_rules}()"
|
"rules must be a valid formula inputs (e.g., using '~'), see {.help [{.fun custom_eucast_rules}](AMR::custom_eucast_rules)}"
|
||||||
)
|
)
|
||||||
n_dots <- length(dots)
|
n_dots <- length(dots)
|
||||||
stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using {.help AMR::custom_eucast_rules}().")
|
stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using {.help [{.fun custom_eucast_rules}](AMR::custom_eucast_rules)}.")
|
||||||
out <- vector("list", n_dots)
|
out <- vector("list", n_dots)
|
||||||
for (i in seq_len(n_dots)) {
|
for (i in seq_len(n_dots)) {
|
||||||
stop_ifnot(
|
stop_ifnot(
|
||||||
inherits(dots[[i]], "formula"),
|
inherits(dots[[i]], "formula"),
|
||||||
"rule ", i, " must be a valid formula input (e.g., using '~'), see {.help AMR::custom_eucast_rules}()"
|
"rule ", i, " must be a valid formula input (e.g., using '~'), see {.help [{.fun custom_eucast_rules}](AMR::custom_eucast_rules)}"
|
||||||
)
|
)
|
||||||
|
|
||||||
# Query
|
# Query
|
||||||
@@ -180,7 +180,7 @@ custom_eucast_rules <- function(...) {
|
|||||||
result <- dots[[i]][[3]]
|
result <- dots[[i]][[3]]
|
||||||
stop_ifnot(
|
stop_ifnot(
|
||||||
deparse(result) %like% "==",
|
deparse(result) %like% "==",
|
||||||
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see {.help AMR::custom_eucast_rules}()"
|
"the result of rule ", i, " (the part after the `~`) must contain `==`, such as in `... ~ ampicillin == \"R\"`, see {.help [{.fun custom_eucast_rules}](AMR::custom_eucast_rules)}"
|
||||||
)
|
)
|
||||||
result_group <- as.character(result)[[2]]
|
result_group <- as.character(result)[[2]]
|
||||||
result_group <- as.character(str2lang(result_group))
|
result_group <- as.character(str2lang(result_group))
|
||||||
|
|||||||
@@ -145,15 +145,15 @@ custom_mdro_guideline <- function(..., as_factor = TRUE) {
|
|||||||
)
|
)
|
||||||
stop_if(
|
stop_if(
|
||||||
identical(dots, "error"),
|
identical(dots, "error"),
|
||||||
"rules must be a valid formula inputs (e.g., using '~'), see {.help AMR::mdro}()"
|
"rules must be a valid formula inputs (e.g., using '~'), see {.help [{.fun mdro}](AMR::mdro)}"
|
||||||
)
|
)
|
||||||
n_dots <- length(dots)
|
n_dots <- length(dots)
|
||||||
stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using {.help AMR::mdro}().")
|
stop_if(n_dots == 0, "no custom rules were set. Please read the documentation using {.help [{.fun mdro}](AMR::mdro)}.")
|
||||||
out <- vector("list", n_dots)
|
out <- vector("list", n_dots)
|
||||||
for (i in seq_len(n_dots)) {
|
for (i in seq_len(n_dots)) {
|
||||||
stop_ifnot(
|
stop_ifnot(
|
||||||
inherits(dots[[i]], "formula"),
|
inherits(dots[[i]], "formula"),
|
||||||
"rule ", i, " must be a valid formula input (e.g., using '~'), see {.help AMR::mdro}()"
|
"rule ", i, " must be a valid formula input (e.g., using '~'), see {.help [{.fun mdro}](AMR::mdro)}"
|
||||||
)
|
)
|
||||||
|
|
||||||
# Query
|
# Query
|
||||||
@@ -202,7 +202,7 @@ c.custom_mdro_guideline <- function(x, ..., as_factor = NULL) {
|
|||||||
}
|
}
|
||||||
for (g in list(...)) {
|
for (g in list(...)) {
|
||||||
stop_ifnot(inherits(g, "custom_mdro_guideline"),
|
stop_ifnot(inherits(g, "custom_mdro_guideline"),
|
||||||
"for combining custom MDRO guidelines, all rules must be created with {.help AMR::custom_mdro_guideline}()",
|
"for combining custom MDRO guidelines, all rules must be created with {.help [{.fun custom_mdro_guideline}](AMR::custom_mdro_guideline)}",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
vals <- attributes(x)$values
|
vals <- attributes(x)$values
|
||||||
@@ -259,14 +259,14 @@ run_custom_mdro_guideline <- function(df, guideline, info) {
|
|||||||
}
|
}
|
||||||
)
|
)
|
||||||
if (identical(qry, "error")) {
|
if (identical(qry, "error")) {
|
||||||
warning_("in {.help AMR::custom_mdro_guideline}(): rule ", i,
|
warning_("in {.help [{.fun custom_mdro_guideline}](AMR::custom_mdro_guideline)}: rule ", i,
|
||||||
" (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
|
" (`", as.character(guideline[[i]]$query), "`) was ignored because of this error message: ",
|
||||||
AMR_env$err_msg,
|
AMR_env$err_msg,
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
next
|
next
|
||||||
}
|
}
|
||||||
stop_ifnot(is.logical(qry), "in {.help AMR::custom_mdro_guideline}(): rule ", i, " (`", guideline[[i]]$query,
|
stop_ifnot(is.logical(qry), "in {.help [{.fun custom_mdro_guideline}](AMR::custom_mdro_guideline)}: rule ", i, " (`", 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
|
||||||
|
|||||||
@@ -281,9 +281,9 @@ add_custom_microorganisms <- function(x) {
|
|||||||
AMR_env$MO_lookup <- unique(rbind_AMR(AMR_env$MO_lookup, new_df))
|
AMR_env$MO_lookup <- unique(rbind_AMR(AMR_env$MO_lookup, new_df))
|
||||||
class(AMR_env$MO_lookup$mo) <- c("mo", "character")
|
class(AMR_env$MO_lookup$mo) <- c("mo", "character")
|
||||||
if (nrow(x) <= 3) {
|
if (nrow(x) <= 3) {
|
||||||
message_("Added ", vector_and(italicise(x$fullname), quotes = FALSE), " to the internal `microorganisms` data set.")
|
message_("Added ", vector_and(italicise(x$fullname), quotes = FALSE), " to the internal {.code microorganisms} data set.")
|
||||||
} else {
|
} else {
|
||||||
message_("Added ", nr2char(nrow(x)), " records to the internal `microorganisms` data set.")
|
message_("Added ", nr2char(nrow(x)), " records to the internal {.code microorganisms} data set.")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -303,7 +303,7 @@ clear_custom_microorganisms <- function() {
|
|||||||
AMR_env$custom_mo_codes <- character(0)
|
AMR_env$custom_mo_codes <- character(0)
|
||||||
AMR_env$mo_previously_coerced <- AMR_env$mo_previously_coerced[which(AMR_env$mo_previously_coerced$mo %in% AMR_env$MO_lookup$mo), , drop = FALSE]
|
AMR_env$mo_previously_coerced <- AMR_env$mo_previously_coerced[which(AMR_env$mo_previously_coerced$mo %in% AMR_env$MO_lookup$mo), , drop = FALSE]
|
||||||
AMR_env$mo_uncertainties <- AMR_env$mo_uncertainties[0, , drop = FALSE]
|
AMR_env$mo_uncertainties <- AMR_env$mo_uncertainties[0, , drop = FALSE]
|
||||||
message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal `microorganisms` data set.")
|
message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal {.code microorganisms} data set.")
|
||||||
}
|
}
|
||||||
|
|
||||||
abbreviate_mo <- function(x, minlength = 5, prefix = "", hyphen_as_space = FALSE, ...) {
|
abbreviate_mo <- function(x, minlength = 5, prefix = "", hyphen_as_space = FALSE, ...) {
|
||||||
|
|||||||
@@ -210,7 +210,7 @@ get_column_abx <- function(x,
|
|||||||
newnames <- suppressWarnings(as.ab(names(dots), info = FALSE))
|
newnames <- suppressWarnings(as.ab(names(dots), info = FALSE))
|
||||||
if (anyNA(newnames)) {
|
if (anyNA(newnames)) {
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
message_("WARNING: some columns returned NA for {.help AMR::as.ab}()", as_note = FALSE)
|
message_("WARNING: some columns returned NA for {.help [{.fun as.ab}](AMR::as.ab)}", as_note = FALSE)
|
||||||
}
|
}
|
||||||
warning_("Invalid antibiotic reference(s): ", vector_and(names(dots)[is.na(newnames)], quotes = FALSE),
|
warning_("Invalid antibiotic reference(s): ", vector_and(names(dots)[is.na(newnames)], quotes = FALSE),
|
||||||
call = FALSE,
|
call = FALSE,
|
||||||
@@ -267,7 +267,7 @@ get_column_abx <- function(x,
|
|||||||
if (all_okay == TRUE) {
|
if (all_okay == TRUE) {
|
||||||
message_(" OK.", as_note = FALSE)
|
message_(" OK.", as_note = FALSE)
|
||||||
} else if (!isFALSE(dups)) {
|
} else if (!isFALSE(dups)) {
|
||||||
message_("WARNING: some results from {.help AMR::as.ab}() are duplicated: ", vector_and(dups, quotes = "`"), as_note = FALSE)
|
message_("WARNING: some results from {.help [{.fun as.ab}](AMR::as.ab)} are duplicated: ", vector_and(dups, quotes = "`"), as_note = FALSE)
|
||||||
} else {
|
} else {
|
||||||
message_(" WARNING.", as_note = FALSE)
|
message_(" WARNING.", as_note = FALSE)
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -198,7 +198,7 @@ interpretive_rules <- function(x,
|
|||||||
add_MO_lookup_to_AMR_env()
|
add_MO_lookup_to_AMR_env()
|
||||||
|
|
||||||
if ("custom" %in% rules && is.null(custom_rules)) {
|
if ("custom" %in% rules && is.null(custom_rules)) {
|
||||||
warning_("in {.help AMR::eucast_rules}(): no custom rules were set with the {.arg custom_rules} argument",
|
warning_("in {.help [{.fun eucast_rules}](AMR::eucast_rules)}: no custom rules were set with the {.arg custom_rules} argument",
|
||||||
immediate = TRUE
|
immediate = TRUE
|
||||||
)
|
)
|
||||||
rules <- rules[rules != "custom"]
|
rules <- rules[rules != "custom"]
|
||||||
@@ -481,7 +481,7 @@ interpretive_rules <- function(x,
|
|||||||
"Rules by the ",
|
"Rules by the ",
|
||||||
font_bold(paste0("AMR package v", utils::packageDescription("AMR")$Version)),
|
font_bold(paste0("AMR package v", utils::packageDescription("AMR")$Version)),
|
||||||
" (", format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"),
|
" (", format(as.Date(utils::packageDescription("AMR")$Date), format = "%Y"),
|
||||||
"), see {.help AMR::eucast_rules}()\n"
|
"), see {.help [{.fun eucast_rules}](AMR::eucast_rules)}\n"
|
||||||
)
|
)
|
||||||
))
|
))
|
||||||
cat("\n\n")
|
cat("\n\n")
|
||||||
@@ -1050,9 +1050,9 @@ interpretive_rules <- function(x,
|
|||||||
cat(paste0(font_grey(strrep("-", 0.95 * getOption("width", 100))), "\n"))
|
cat(paste0(font_grey(strrep("-", 0.95 * getOption("width", 100))), "\n"))
|
||||||
|
|
||||||
if (isFALSE(verbose) && total_n_added + total_n_changed > 0) {
|
if (isFALSE(verbose) && total_n_added + total_n_changed > 0) {
|
||||||
cat("\n", word_wrap("Use `eucast_rules(..., verbose = TRUE)` (on your original data) to get a data.frame with all specified edits instead."), "\n\n", sep = "")
|
cat("\n", word_wrap("Use ", highlight_code("eucast_rules(..., verbose = TRUE)"), " (on your original data) to get a data.frame with all specified edits instead."), "\n\n", sep = "")
|
||||||
} else if (isTRUE(verbose)) {
|
} else if (isTRUE(verbose)) {
|
||||||
cat("\n", word_wrap("Used 'Verbose mode' (`verbose = TRUE`), which returns a data.frame with all specified edits.\nUse `verbose = FALSE` to apply the rules on your data."), "\n\n", sep = "")
|
cat("\n", word_wrap("Used 'Verbose mode' ({.code verbose = TRUE}), which returns a data.frame with all specified edits.\nUse {.code verbose = FALSE} to apply the rules on your data."), "\n\n", sep = "")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1062,13 +1062,13 @@ interpretive_rules <- function(x,
|
|||||||
warn_lacking_sir_class <- warn_lacking_sir_class[order(colnames(x.bak))]
|
warn_lacking_sir_class <- warn_lacking_sir_class[order(colnames(x.bak))]
|
||||||
warn_lacking_sir_class <- warn_lacking_sir_class[!is.na(warn_lacking_sir_class)]
|
warn_lacking_sir_class <- warn_lacking_sir_class[!is.na(warn_lacking_sir_class)]
|
||||||
warning_(
|
warning_(
|
||||||
"in {.help AMR::eucast_rules}(): not all columns with antimicrobial results are of class 'sir'. Transform them on beforehand, with e.g.:\n",
|
"in {.help [{.fun eucast_rules}](AMR::eucast_rules)}: not all columns with antimicrobial results are of class 'sir'. Transform them on beforehand, with e.g.:\n",
|
||||||
" - ", x_deparsed, " %>% as.sir(", ifelse(length(warn_lacking_sir_class) == 1,
|
" - ", highlight_code(paste0(x_deparsed, " %>% as.sir(", ifelse(length(warn_lacking_sir_class) == 1,
|
||||||
warn_lacking_sir_class,
|
warn_lacking_sir_class,
|
||||||
paste0(warn_lacking_sir_class[1], ":", warn_lacking_sir_class[length(warn_lacking_sir_class)])
|
paste0(warn_lacking_sir_class[1], ":", warn_lacking_sir_class[length(warn_lacking_sir_class)])
|
||||||
), ")\n",
|
), ")")), "\n",
|
||||||
" - ", x_deparsed, " %>% mutate_if(is_sir_eligible, as.sir)\n",
|
" - ", highlight_code(paste0(x_deparsed, " %>% mutate_if(is_sir_eligible, as.sir)")), "\n",
|
||||||
" - ", x_deparsed, " %>% mutate(across(where(is_sir_eligible), as.sir))"
|
" - ", highlight_code(paste0(x_deparsed, " %>% mutate(across(where(is_sir_eligible), as.sir))"))
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1097,7 +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 {.code AMR_eucastrules} that you have set is now invalid was ignored - set {.code AMR_interpretive_rules} instead. See {.code ?AMR-options}.")
|
warning_("The global option {.code AMR_eucastrules} that you have set is now invalid was ignored - set {.code AMR_interpretive_rules} instead. See {.topic AMR-options}.")
|
||||||
}
|
}
|
||||||
interpretive_rules(x = x, col_mo = col_mo, info = info, rules = rules, guideline = "EUCAST", ...)
|
interpretive_rules(x = x, col_mo = col_mo, info = info, rules = rules, guideline = "EUCAST", ...)
|
||||||
}
|
}
|
||||||
@@ -1178,7 +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 {.help AMR::eucast_rules}(): value \"", to, "\" added to the factor levels of column",
|
"in {.help [{.fun eucast_rules}](AMR::eucast_rules)}: value \"", to, "\" added to the factor levels of column",
|
||||||
ifelse(length(cols) == 1, "", "s"),
|
ifelse(length(cols) == 1, "", "s"),
|
||||||
" ", vector_and(cols, quotes = "`", sort = FALSE),
|
" ", vector_and(cols, quotes = "`", sort = FALSE),
|
||||||
" because this value was not an existing factor level."
|
" because this value was not an existing factor level."
|
||||||
@@ -1186,7 +1186,7 @@ edit_sir <- function(x,
|
|||||||
txt_warning()
|
txt_warning()
|
||||||
warned <- FALSE
|
warned <- FALSE
|
||||||
} else {
|
} else {
|
||||||
warning_("in {.help AMR::eucast_rules}(): ", w$message)
|
warning_("in {.help [{.fun eucast_rules}](AMR::eucast_rules)}: ", w$message)
|
||||||
txt_warning()
|
txt_warning()
|
||||||
}
|
}
|
||||||
},
|
},
|
||||||
|
|||||||
@@ -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 {.help AMR::key_antimicrobials}()."
|
"as key antimicrobials for ", name, "s. See {.help [{.fun key_antimicrobials}](AMR::key_antimicrobials)}."
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
6
R/mdro.R
6
R/mdro.R
@@ -170,9 +170,9 @@ mdro <- function(x = NULL,
|
|||||||
meet_criteria(infer_from_combinations, allow_class = "logical", has_length = 1)
|
meet_criteria(infer_from_combinations, allow_class = "logical", has_length = 1)
|
||||||
|
|
||||||
if (isTRUE(only_sir_columns) && !any(is.sir(x))) {
|
if (isTRUE(only_sir_columns) && !any(is.sir(x))) {
|
||||||
stop_("There were no SIR columns found in the data set, despite {.arg only_sir_columns} being {.code TRUE}. Transform columns with {.help AMR::as.sir}() for valid antimicrobial interpretations.")
|
stop_("There were no SIR columns found in the data set, despite {.arg only_sir_columns} being {.code TRUE}. Transform columns with {.help [{.fun as.sir}](AMR::as.sir)} for valid antimicrobial interpretations.")
|
||||||
} else if (!isTRUE(only_sir_columns) && !any(is.sir(x)) && !any(is_sir_eligible(x))) {
|
} else if (!isTRUE(only_sir_columns) && !any(is.sir(x)) && !any(is_sir_eligible(x))) {
|
||||||
stop_("There were no eligible SIR columns found in the data set. Transform columns with {.help AMR::as.sir}() for valid antimicrobial interpretations.")
|
stop_("There were no eligible SIR columns found in the data set. Transform columns with {.help [{.fun as.sir}](AMR::as.sir)} for valid antimicrobial interpretations.")
|
||||||
}
|
}
|
||||||
|
|
||||||
# get gene values as TRUE/FALSE
|
# get gene values as TRUE/FALSE
|
||||||
@@ -251,7 +251,7 @@ mdro <- function(x = NULL,
|
|||||||
guideline.bak <- guideline
|
guideline.bak <- guideline
|
||||||
if (is.list(guideline)) {
|
if (is.list(guideline)) {
|
||||||
# Custom MDRO guideline ---------------------------------------------------
|
# Custom MDRO guideline ---------------------------------------------------
|
||||||
stop_ifnot(inherits(guideline, "custom_mdro_guideline"), "use {.help AMR::custom_mdro_guideline}() to create custom guidelines")
|
stop_ifnot(inherits(guideline, "custom_mdro_guideline"), "use {.help [{.fun custom_mdro_guideline}](AMR::custom_mdro_guideline)} to create custom guidelines")
|
||||||
if (isTRUE(info)) {
|
if (isTRUE(info)) {
|
||||||
txt <- paste0(
|
txt <- paste0(
|
||||||
"Determining MDROs based on custom rules",
|
"Determining MDROs based on custom rules",
|
||||||
|
|||||||
8
R/mo.R
8
R/mo.R
@@ -483,7 +483,7 @@ as.mo <- function(x,
|
|||||||
}
|
}
|
||||||
} else if (is.null(getOption("AMR_keep_synonyms")) && length(AMR_env$mo_renamed$old) > 0 && message_not_thrown_before("as.mo", "keep_synonyms_warning", entire_session = TRUE)) {
|
} else if (is.null(getOption("AMR_keep_synonyms")) && length(AMR_env$mo_renamed$old) > 0 && message_not_thrown_before("as.mo", "keep_synonyms_warning", entire_session = TRUE)) {
|
||||||
# keep synonyms is TRUE, so check if any do have synonyms
|
# keep synonyms is TRUE, so check if any do have synonyms
|
||||||
warning_("Function `as.mo()` returned ", nr2char(length(unique(AMR_env$mo_renamed$old))), " outdated taxonomic name", ifelse(length(unique(AMR_env$mo_renamed$old)) > 1, "s", ""), ". Use `as.mo(..., keep_synonyms = FALSE)` to clean the input to currently accepted taxonomic names, or set the R option `AMR_keep_synonyms` to `FALSE`. This warning will be shown once per session.", call = FALSE)
|
warning_("{.help [{.fun as.mo}](AMR::as.mo)} returned ", nr2char(length(unique(AMR_env$mo_renamed$old))), " outdated taxonomic name", ifelse(length(unique(AMR_env$mo_renamed$old)) > 1, "s", ""), ". Use ", highlight_code("as.mo(..., keep_synonyms = FALSE)"), " to clean the input to currently accepted taxonomic names, or set the R option {.code AMR_keep_synonyms} to {.code FALSE}. This warning will be shown once per session.", call = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
# Apply Becker ----
|
# Apply Becker ----
|
||||||
@@ -907,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(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")))
|
cat(font_blue(word_wrap("No uncertainties to show. Only uncertainties of the last call to {.help [{.fun as.mo}](AMR::as.mo)} or any mo_*() function are stored.\n\n")))
|
||||||
return(invisible(NULL))
|
return(invisible(NULL))
|
||||||
} else if (NROW(x) > 50) {
|
} else if (NROW(x) > 50) {
|
||||||
more_than_50 <- TRUE
|
more_than_50 <- TRUE
|
||||||
x <- x[1:50, , drop = FALSE]
|
x <- x[1:50, , drop = FALSE]
|
||||||
}
|
}
|
||||||
|
|
||||||
cat(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")))
|
cat(font_blue(word_wrap("Matching scores are based on the resemblance between the input and the full taxonomic name, and the pathogenicity in humans. See {.help [{.fun mo_matching_score}](AMR::mo_matching_score)}.\n\n")))
|
||||||
|
|
||||||
add_MO_lookup_to_AMR_env()
|
add_MO_lookup_to_AMR_env()
|
||||||
|
|
||||||
@@ -1032,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(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")))
|
cat(font_blue(word_wrap("No renamed taxonomy to show. Only renamed taxonomy of the last call of {.help [{.fun as.mo}](AMR::as.mo)} or any mo_*() function are stored.\n")))
|
||||||
return(invisible(NULL))
|
return(invisible(NULL))
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -1043,10 +1043,10 @@ find_mo_col <- function(fn) {
|
|||||||
)
|
)
|
||||||
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
|
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
|
||||||
if (message_not_thrown_before(fn = fn)) {
|
if (message_not_thrown_before(fn = fn)) {
|
||||||
message_("Using column '", font_bold(mo), "' as input for `", fn, "()`")
|
message_("Using column '", font_bold(mo), "' as input for {.help [{.fun ", fn, "}](AMR::", fn, ")}")
|
||||||
}
|
}
|
||||||
return(df[, mo, drop = TRUE])
|
return(df[, mo, drop = TRUE])
|
||||||
} else {
|
} else {
|
||||||
stop_("argument `x` is missing and no column with info about microorganisms could be found.", call = -2)
|
stop_("argument {.arg x} is missing and no column with info about microorganisms could be found.", call = -2)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -249,7 +249,7 @@ get_mo_source <- function(destination = getOption("AMR_mo_source", "~/mo_source.
|
|||||||
current_ext <- regexpr("\\.([[:alnum:]]+)$", destination)
|
current_ext <- regexpr("\\.([[:alnum:]]+)$", destination)
|
||||||
current_ext <- ifelse(current_ext > -1L, substring(destination, current_ext + 1L), "")
|
current_ext <- ifelse(current_ext > -1L, substring(destination, current_ext + 1L), "")
|
||||||
vowel <- ifelse(current_ext %like% "^[AEFHILMNORSX]", "n", "")
|
vowel <- ifelse(current_ext %like% "^[AEFHILMNORSX]", "n", "")
|
||||||
stop_("The AMR mo source must be an RDS file, not a{vowel} {toupper(current_ext)} file. If \"{basename(destination)}\" was meant as your input file, use {.help AMR::set_mo_source}() on this file. In any case, the option {.code AMR_mo_source} must be set to another path.")
|
stop_("The AMR mo source must be an RDS file, not a{vowel} {toupper(current_ext)} file. If \"{basename(destination)}\" was meant as your input file, use {.help [{.fun set_mo_source}](AMR::set_mo_source)} on this file. In any case, the option {.code AMR_mo_source} must be set to another path.")
|
||||||
}
|
}
|
||||||
if (is.null(AMR_env$mo_source)) {
|
if (is.null(AMR_env$mo_source)) {
|
||||||
AMR_env$mo_source <- readRDS_AMR(path.expand(destination))
|
AMR_env$mo_source <- readRDS_AMR(path.expand(destination))
|
||||||
|
|||||||
@@ -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 {.help AMR::as.sir}().",
|
"Apply `scale_", aesthetics[1], "_sir()` to a variable of class 'sir', see {.help [{.fun as.sir}](AMR::as.sir)}.",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
x <- as.character(x)
|
x <- as.character(x)
|
||||||
|
|||||||
@@ -238,7 +238,7 @@ resistance <- function(...,
|
|||||||
# other arguments for meet_criteria are handled by sir_calc()
|
# other arguments for meet_criteria are handled by sir_calc()
|
||||||
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1)
|
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1)
|
||||||
if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("resistance", "eucast_default", entire_session = TRUE)) {
|
if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("resistance", "eucast_default", entire_session = TRUE)) {
|
||||||
message_("`resistance()` assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the `guideline` argument or the `AMR_guideline` option to either \"CLSI\" or \"EUCAST\", see `?AMR-options`.")
|
message_("{.help [{.fun resistance}](AMR::resistance)} assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the {.arg guideline} argument or the {.code AMR_guideline} option to either \"CLSI\" or \"EUCAST\", see {.topic AMR-options}.")
|
||||||
message_("This message will be shown once per session.")
|
message_("This message will be shown once per session.")
|
||||||
}
|
}
|
||||||
tryCatch(
|
tryCatch(
|
||||||
@@ -266,7 +266,7 @@ susceptibility <- function(...,
|
|||||||
# other arguments for meet_criteria are handled by sir_calc()
|
# other arguments for meet_criteria are handled by sir_calc()
|
||||||
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1)
|
meet_criteria(guideline, allow_class = "character", is_in = c("EUCAST", "CLSI"), has_length = 1)
|
||||||
if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("susceptibility", "eucast_default", entire_session = TRUE)) {
|
if (is.null(getOption("AMR_guideline")) && missing(guideline) && message_not_thrown_before("susceptibility", "eucast_default", entire_session = TRUE)) {
|
||||||
message_("`susceptibility()` assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the `guideline` argument or the `AMR_guideline` option to either \"CLSI\" or \"EUCAST\", see `?AMR-options`.")
|
message_("{.help [{.fun susceptibility}](AMR::susceptibility)} assumes the EUCAST guideline and thus considers the 'I' category susceptible. Set the {.arg guideline} argument or the {.code AMR_guideline} option to either \"CLSI\" or \"EUCAST\", see {.topic AMR-options}.")
|
||||||
message_("This message will be shown once per session.")
|
message_("This message will be shown once per session.")
|
||||||
}
|
}
|
||||||
tryCatch(
|
tryCatch(
|
||||||
|
|||||||
@@ -238,7 +238,7 @@ resistance_predict <- function(x,
|
|||||||
prediction <- predictmodel$fit
|
prediction <- predictmodel$fit
|
||||||
se <- predictmodel$se.fit
|
se <- predictmodel$se.fit
|
||||||
} else {
|
} else {
|
||||||
stop("no valid model selected. See {.help AMR::resistance_predict}().")
|
stop("no valid model selected. See {.help [{.fun resistance_predict}](AMR::resistance_predict)}.")
|
||||||
}
|
}
|
||||||
|
|
||||||
# prepare the output dataframe
|
# prepare the output dataframe
|
||||||
|
|||||||
30
R/sir.R
30
R/sir.R
@@ -529,10 +529,10 @@ as.sir.default <- function(x,
|
|||||||
if (all(x %unlike% "(S|I|R)", na.rm = TRUE) && !all(x %in% c(1, 2, 3, 4, 5), na.rm = TRUE)) {
|
if (all(x %unlike% "(S|I|R)", na.rm = TRUE) && !all(x %in% c(1, 2, 3, 4, 5), na.rm = TRUE)) {
|
||||||
# check if they are actually MICs or disks
|
# check if they are actually MICs or disks
|
||||||
if (all_valid_mics(x)) {
|
if (all_valid_mics(x)) {
|
||||||
warning_("in {.help AMR::as.sir}(): input values were guessed to be MIC values - preferably transform them with {.help AMR::as.mic}() before running {.help AMR::as.sir}().")
|
warning_("in {.help [{.fun as.sir}](AMR::as.sir)}: input values were guessed to be MIC values - preferably transform them with {.help [{.fun as.mic}](AMR::as.mic)} before running {.help [{.fun as.sir}](AMR::as.sir)}.")
|
||||||
return(as.sir(as.mic(x), ...))
|
return(as.sir(as.mic(x), ...))
|
||||||
} else if (all_valid_disks(x)) {
|
} else if (all_valid_disks(x)) {
|
||||||
warning_("in {.help AMR::as.sir}(): input values were guessed to be disk diffusion values - preferably transform them with {.help AMR::as.disk}() before running {.help AMR::as.sir}().")
|
warning_("in {.help [{.fun as.sir}](AMR::as.sir)}: input values were guessed to be disk diffusion values - preferably transform them with {.help [{.fun as.disk}](AMR::as.disk)} before running {.help [{.fun as.sir}](AMR::as.sir)}.")
|
||||||
return(as.sir(as.disk(x), ...))
|
return(as.sir(as.disk(x), ...))
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
@@ -601,7 +601,7 @@ as.sir.default <- function(x,
|
|||||||
ifelse(length(out7) > 0, paste0("7 as \"", out7, "\""), NA_character_),
|
ifelse(length(out7) > 0, paste0("7 as \"", out7, "\""), NA_character_),
|
||||||
ifelse(length(out8) > 0, paste0("8 as \"", out8, "\""), NA_character_)
|
ifelse(length(out8) > 0, paste0("8 as \"", out8, "\""), NA_character_)
|
||||||
)
|
)
|
||||||
message_("in {.help AMR::as.sir}(): Interpreting input value ", vector_and(out[!is.na(out)], quotes = FALSE, sort = FALSE))
|
message_("in {.help [{.fun as.sir}](AMR::as.sir)}: Interpreting input value ", vector_and(out[!is.na(out)], quotes = FALSE, sort = FALSE))
|
||||||
}
|
}
|
||||||
|
|
||||||
if (na_before != na_after) {
|
if (na_before != na_after) {
|
||||||
@@ -610,7 +610,7 @@ as.sir.default <- function(x,
|
|||||||
sort() %pm>%
|
sort() %pm>%
|
||||||
vector_and(quotes = TRUE)
|
vector_and(quotes = TRUE)
|
||||||
cur_col <- get_current_column()
|
cur_col <- get_current_column()
|
||||||
warning_("in {.help AMR::as.sir}(): ", na_after - na_before, " result",
|
warning_("in {.help [{.fun as.sir}](AMR::as.sir)}: ", na_after - na_before, " result",
|
||||||
ifelse(na_after - na_before > 1, "s", ""),
|
ifelse(na_after - na_before > 1, "s", ""),
|
||||||
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
|
||||||
" truncated (",
|
" truncated (",
|
||||||
@@ -1029,7 +1029,7 @@ 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 {.help AMR::sir_interpretation_history}() to retrieve a logbook with all details of the breakpoint interpretations.")
|
message_("Run {.help [{.fun sir_interpretation_history}](AMR::sir_interpretation_history)} to retrieve a logbook with all details of the breakpoint interpretations.")
|
||||||
}
|
}
|
||||||
} else {
|
} else {
|
||||||
# sequential mode (non-parallel)
|
# sequential mode (non-parallel)
|
||||||
@@ -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 {.help AMR::as.sir}() are no longer used: ", vector_and(names(dots), quotes = "`"), ".", call = FALSE)
|
warning_("These arguments in {.help [{.fun as.sir}](AMR::as.sir)} are no longer used: ", vector_and(names(dots), quotes = "`"), ".", call = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
current_sir_interpretation_history <- NROW(AMR_env$sir_interpretation_history)
|
current_sir_interpretation_history <- NROW(AMR_env$sir_interpretation_history)
|
||||||
|
|
||||||
if (isTRUE(info) && message_not_thrown_before("as.sir", "sir_interpretation_history")) {
|
if (isTRUE(info) && message_not_thrown_before("as.sir", "sir_interpretation_history")) {
|
||||||
message_("Run {.help AMR::sir_interpretation_history}() afterwards to retrieve a logbook with all details of the breakpoint interpretations.\n\n")
|
message_("Run {.help [{.fun sir_interpretation_history}](AMR::sir_interpretation_history)} afterwards to retrieve a logbook with all details of the breakpoint interpretations.\n\n")
|
||||||
}
|
}
|
||||||
|
|
||||||
current_df <- tryCatch(get_current_data(NA, 0), error = function(e) NULL)
|
current_df <- tryCatch(get_current_data(NA, 0), error = function(e) NULL)
|
||||||
@@ -1276,9 +1276,9 @@ as_sir_method <- function(method_short,
|
|||||||
mo_var_found <- ""
|
mo_var_found <- ""
|
||||||
}
|
}
|
||||||
if (is.null(mo)) {
|
if (is.null(mo)) {
|
||||||
stop_("No information was supplied about the microorganisms (missing argument {.arg mo} and no column of class 'mo' found). See {.help AMR::as.sir}().\n\n",
|
stop_("No information was supplied about the microorganisms (missing argument {.arg mo} and no column of class 'mo' found). See {.help [{.fun as.sir}](AMR::as.sir)}.\n\n",
|
||||||
"To transform certain columns with e.g. mutate(), use `data %>% mutate(across(..., as.sir, mo = x))`, where x is your column with microorganisms.\n",
|
"To transform certain columns with e.g. mutate(), use ", highlight_code("data %>% mutate(across(..., as.sir, mo = x))"), ", where x is your column with microorganisms.\n",
|
||||||
"To transform all ", method_long, " in a data set, use `data %>% as.sir()` or `data %>% mutate_if(is.", method_short, ", as.sir)`.",
|
"To transform all ", method_long, " in a data set, use ", highlight_code("data %>% as.sir()"), " or ", highlight_code(paste0("data %>% mutate_if(is.", method_short, ", as.sir)")), ".",
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -1312,7 +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 {.arg ab}). See {.help AMR::as.sir}().", call = FALSE)
|
stop_("No unambiguous name was supplied about the antibiotic (argument {.arg ab}). See {.help [{.fun as.sir}](AMR::as.sir)}.", call = FALSE)
|
||||||
}
|
}
|
||||||
|
|
||||||
ab.bak <- trimws2(ab)
|
ab.bak <- trimws2(ab)
|
||||||
@@ -1328,7 +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 {.help AMR::as.ab}().",
|
". Rename this column to a valid name or code, and check the output with {.help [{.fun as.ab}](AMR::as.ab)}.",
|
||||||
as_note = FALSE
|
as_note = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
@@ -1352,7 +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 {.help AMR::as.sir}(): using {.arg add_intrinsic_resistance} is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
|
message_("in {.help [{.fun as.sir}](AMR::as.sir)}: using {.arg add_intrinsic_resistance} is only useful when using EUCAST guidelines, since the rules for intrinsic resistance are based on EUCAST.")
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@@ -1721,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 {.help AMR::as.sir}().")
|
paste0("Breakpoints for UTI ", font_bold("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, ". Use argument `uti` to set which isolates are from urine. See {.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
|
||||||
@@ -1988,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 {.help AMR::as.sir}() on MIC values or disk diffusion zones (or on a {.cls data.frame} containing any of these) to print a 'logbook' data set here.")
|
message_("No results to print. First run {.help [{.fun as.sir}](AMR::as.sir)} on MIC values or disk diffusion zones (or on a {.cls data.frame} containing any of these) to print a '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"]
|
||||||
|
|||||||
@@ -173,7 +173,7 @@ sir_calc <- function(...,
|
|||||||
if (print_warning == TRUE) {
|
if (print_warning == TRUE) {
|
||||||
if (message_not_thrown_before("sir_calc")) {
|
if (message_not_thrown_before("sir_calc")) {
|
||||||
warning_("Increase speed by transforming to class 'sir' on beforehand:\n",
|
warning_("Increase speed by transforming to class 'sir' on beforehand:\n",
|
||||||
" your_data %>% mutate_if(is_sir_eligible, as.sir)",
|
highlight_code(" your_data %>% mutate_if(is_sir_eligible, as.sir)"),
|
||||||
call = FALSE
|
call = FALSE
|
||||||
)
|
)
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -124,7 +124,7 @@ deprecation_warning <- function(old = NULL, new = NULL, fn = NULL, extra_msg = N
|
|||||||
". The old name will be removed in future version, so please update your code.",
|
". The old name will be removed in future version, so please update your code.",
|
||||||
ifelse(type == "argument",
|
ifelse(type == "argument",
|
||||||
". While the old argument still works, it will be removed in a future version, so please update your code.",
|
". While the old argument still works, it will be removed in a future version, so please update your code.",
|
||||||
" and will be removed in a future version, see `?AMR-deprecated`."
|
" and will be removed in a future version, see {.topic AMR-deprecated}."
|
||||||
)
|
)
|
||||||
),
|
),
|
||||||
ifelse(!is.null(extra_msg),
|
ifelse(!is.null(extra_msg),
|
||||||
|
|||||||
Reference in New Issue
Block a user