P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2026-03-25 23:35:54 +01:00
Code Releases Activity

(v3.0.1.9039) cli fixes

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2026-03-23 10:38:28 +01:00
parent 975a690c10
commit 2a8a1eda97
24 changed files with 104 additions and 97 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@@ -1,6 +1,6 @@
Package: AMR
Version: 3.0.1.9038
Date: 2026-03-22
Version: 3.0.1.9039
Date: 2026-03-23
Title: Antimicrobial Resistance Data Analysis
Description: Functions to simplify and standardise antimicrobial resistance (AMR)
data analysis and to work with microbial and antimicrobial properties by

2
NEWS.md
View File

@@ -1,4 +1,4 @@
# AMR 3.0.1.9038
# AMR 3.0.1.9039
### New
* Integration with the **tidymodels** framework to allow seamless use of SIR, MIC and disk data in modelling pipelines via `recipes`

32
R/aa_helper_functions.R
View File

@@ -253,12 +253,9 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
# WHONET support
found <- sort(colnames(x)[colnames_formatted %like_case% "^(specimen date|specimen_date|spec_date)"])
if (!inherits(pm_pull(x, found), c("Date", "POSIXct"))) {
stop(
font_red(paste0(
"Found column '", font_bold(found), "' to be used as input for `", ifelse(add_col_prefix, "col_", ""), type,
"`, but this column contains no valid dates. Transform its values to valid dates first."
)),
call. = FALSE
stop_("Found column {.field ", font_bold(found), "} to be used as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type,
"}, but this column contains no valid dates. Transform its values to valid dates first.",
call = FALSE
)
}
} else if (any(vapply(FUN.VALUE = logical(1), x, function(x) inherits(x, c("Date", "POSIXct"))))) {
@@ -305,7 +302,7 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
# this column should contain logicals
if (!is.logical(x[, found, drop = TRUE])) {
message_(
"Column '", font_bold(found), "' found as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type,
"Column {.field ", font_bold(found), "} found as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type,
"}, but this column does not contain {.code TRUE}/{.code FALSE} values and was ignored."
)
found <- NULL
@@ -317,9 +314,9 @@ search_type_in_df <- function(x, type, info = TRUE, add_col_prefix = TRUE) {
if (!is.null(found) && isTRUE(info)) {
if (message_not_thrown_before("search_in_type", type)) {
msg <- paste0("Using column '", font_bold(found), "' as input for `", ifelse(add_col_prefix, "col_", ""), type, "`.")
msg <- paste0("Using column {.field ", font_bold(found), "} as input for {.arg ", ifelse(add_col_prefix, "col_", ""), type, "}.")
if (type %in% c("keyantibiotics", "keyantimicrobials", "specimen")) {
msg <- paste(msg, "Use", font_bold(paste0(ifelse(add_col_prefix, "col_", ""), type), "= FALSE"), "to prevent this.")
msg <- paste(msg, "Use {.arg ", paste0(ifelse(add_col_prefix, "col_", ""), type), "= FALSE} to prevent this.")
}
message_(msg)
}
@@ -556,24 +553,24 @@ word_wrap <- function(...,
}
simplify_help_markup <- function(msg) {
# {.help [{.fun fn}](pkg::fn)} -> {.code ?fn()}
# {.help [display](topic)} -> {.code ?display}
# {.help [{.fun fn}](pkg::fn)} -> {.code fn()}
# {.help [display](topic)} -> {.code display}
msg <- gsub(
"\\{\\.help \\[\\{\\.fun ([^}]+)\\}\\]\\([^)]+\\)\\}",
"{.code ?\\1()}",
"{.code \\1()}",
msg,
perl = TRUE
)
msg <- gsub(
"\\{\\.help \\[([^]]+)\\]\\([^)]+\\)\\}",
"{.code ?\\1}",
"{.code \\1}",
msg,
perl = TRUE
)
# {.topic [display](topic)} -> display (plain text)
# {.topic [display](topic)} -> {.code ?display}
msg <- gsub(
"\\{\\.topic \\[([^]]+)\\]\\([^)]+\\)\\}",
"\\1",
"{.code ?\\1}",
msg,
perl = TRUE
)
@@ -590,8 +587,11 @@ message_ <- function(...,
}
if (isTRUE(as_note)) {
cli::cli_inform(c("i" = msg), .envir = parent.frame())
} else {
} else if (isTRUE(appendLF)) {
cli::cli_inform(msg, .envir = parent.frame())
} else {
# This mirrors what rlang::inform() does internally (cat() to stderr), so it behaves consistently with cli_inform() output
cat(format_inline_(msg), file = stderr())
}
} else {
plain_msg <- cli_to_plain(paste0(c(...), collapse = ""), envir = parent.frame())

2
R/ab.R
View File

@@ -718,7 +718,7 @@ get_translate_ab <- function(translate_ab) {
} else {
translate_ab <- tolower(translate_ab)
stop_ifnot(translate_ab %in% colnames(AMR::antimicrobials),
"invalid value for {.arg translate_ab}, this must be a column name of the {.topic [antimicrobials](AMR::antimicrobials)} data set\n",
"invalid value for {.arg translate_ab}, this must be a column name of the {.help [antimicrobials](AMR::antimicrobials)} data set\n",
"or {.code TRUE} (equals {.val name}) or {.code FALSE} to not translate at all.",
call = FALSE
)

4
R/amr_selectors.R
View File

@@ -678,7 +678,7 @@ not_intrinsic_resistant <- function(only_sir_columns = FALSE, col_mo = NULL, ver
agents <- ab_in_data[ab_in_data %in% names(vars_df_R[which(vars_df_R)])]
if (length(agents) > 0 &&
message_not_thrown_before("not_intrinsic_resistant", sort(agents))) {
agents_formatted <- paste0("'", font_bold(agents, collapse = NULL), "'")
agents_formatted <- paste0("{.field ", font_bold(agents, collapse = NULL), "}")
agents_names <- ab_name(names(agents), tolower = TRUE, language = NULL)
need_name <- generalise_antibiotic_name(agents) != generalise_antibiotic_name(agents_names)
agents_formatted[need_name] <- paste0(agents_formatted[need_name], " (", agents_names[need_name], ")")
@@ -804,7 +804,7 @@ amr_select_exec <- function(function_name,
language = NULL,
tolower = TRUE
),
" ({.field ", abx[abx %in% untreatable], "})"
" ({.field ", font_bold(abx[abx %in% untreatable], collapse = NULL), "})"
),
quotes = FALSE,
sort = TRUE,

2
R/bug_drug_combinations.R
View File

@@ -84,7 +84,7 @@ bug_drug_combinations <- function(x,
col_mo <- search_type_in_df(x = x, type = "mo")
stop_if(is.null(col_mo), "{.arg col_mo} must be set")
} else {
stop_ifnot(col_mo %in% colnames(x), "column '", col_mo, "' ({.arg col_mo}) not found")
stop_ifnot(col_mo %in% colnames(x), "column {.field ", font_bold(col_mo), "} ({.arg col_mo}) not found")
}
x.bak <- x

2
R/custom_antimicrobials.R
View File

@@ -166,5 +166,5 @@ clear_custom_antimicrobials <- function() {
n2 <- nrow(AMR_env$AB_lookup)
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]
message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal {.topic [antimicrobials](AMR::antimicrobials)} data set.")
message_("Cleared ", nr2char(n - n2), " custom record", ifelse(n - n2 > 1, "s", ""), " from the internal {.help [antimicrobials](AMR::antimicrobials)} data set.")
}

2
R/custom_microorganisms.R
View File

@@ -128,7 +128,7 @@
#' }
add_custom_microorganisms <- function(x) {
meet_criteria(x, allow_class = "data.frame")
stop_ifnot("genus" %in% tolower(colnames(x)), "{.arg x} must contain column 'genus'.")
stop_ifnot("genus" %in% tolower(colnames(x)), "{.arg x} must contain column {.code genus}.")
add_MO_lookup_to_AMR_env()

4
R/disk.R
View File

@@ -119,9 +119,9 @@ as.disk <- function(x, na.rm = FALSE) {
sort() %pm>%
vector_and(quotes = TRUE)
cur_col <- get_current_column()
warning_("in {.fun as.disk}: ", na_after - na_before, " result",
warning_("in {.help [{.fun as.disk}](AMR::as.disk)}: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
ifelse(is.null(cur_col), "", paste0(" in column {.field ", font_bold(cur_col, collapse = NULL), "}")),
" truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid disk zones: ",

6
R/first_isolate.R
View File

@@ -333,7 +333,7 @@ first_isolate <- function(x = NULL,
check_columns_existance <- function(column, tblname = x) {
if (!is.null(column)) {
stop_ifnot(column %in% colnames(tblname),
"Column '{column}' not found.",
"Column {.code ", column, "} not found.",
call = FALSE
)
}
@@ -554,7 +554,7 @@ first_isolate <- function(x = NULL,
format(sum(x$newvar_mo == "UNKNOWN", na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark
),
" isolates with a microbial ID 'UNKNOWN' (in column '", font_bold(col_mo), "')"
" isolates with a microbial ID 'UNKNOWN' (in column {.field ", font_bold(col_mo), "})"
)
}
x[which(x$newvar_mo == "UNKNOWN"), "newvar_first_isolate"] <- include_unknown
@@ -565,7 +565,7 @@ first_isolate <- function(x = NULL,
"Excluding ", format(sum(is.na(x$newvar_mo), na.rm = TRUE),
decimal.mark = decimal.mark, big.mark = big.mark
),
" isolates with a microbial ID `NA` (in column '", font_bold(col_mo), "')"
" isolates with a microbial ID `NA` (in column {.field ", font_bold(col_mo), "})"
)
}
x[which(is.na(x$newvar_mo)), "newvar_first_isolate"] <- FALSE

6
R/guess_ab_col.R
View File

@@ -86,7 +86,7 @@ guess_ab_col <- function(x = NULL, search_string = NULL, verbose = FALSE, only_s
} else {
if (isTRUE(verbose)) {
message_(
"Using column '", font_bold(ab_result), "' as input for ", search_string,
"Using column {.field ", font_bold(ab_result), "} as input for ", search_string,
" (", ab_name(search_string, language = NULL, tolower = TRUE), ")."
)
}
@@ -275,7 +275,7 @@ get_column_abx <- function(x,
for (i in seq_len(length(out))) {
if (isTRUE(verbose) && !out[i] %in% duplicates) {
message_(
"Using column '", font_bold(out[i]), "' as input for ", names(out)[i],
"Using column {.field ", font_bold(out[i]), "} as input for ", names(out)[i],
" (", ab_name(names(out)[i], tolower = TRUE, language = NULL), ")."
)
}
@@ -284,7 +284,7 @@ get_column_abx <- function(x,
if (names(out)[i] != already_set_as) {
message_(
paste0(
"Column '", font_bold(out[i]), "' will not be used for ",
"Column {.field ", font_bold(out[i]), "} will not be used for ",
names(out)[i], " (", suppressMessages(ab_name(names(out)[i], tolower = TRUE, language = NULL, fast_mode = TRUE)), ")",
", as this antimicrobial has already been set."
)

18
R/interpretive_rules.R
View File

@@ -329,7 +329,7 @@ interpretive_rules <- function(x,
if (!"AMP" %in% names(cols_ab) && "AMX" %in% names(cols_ab)) {
# ampicillin column is missing, but amoxicillin is available
if (isTRUE(info)) {
message_("Using column '", cols_ab[names(cols_ab) == "AMX"], "' as input for ampicillin since many EUCAST rules depend on it.")
message_("Using column {.field ", font_bold(cols_ab[names(cols_ab) == "AMX"]), "} as input for ampicillin since many EUCAST rules depend on it.")
}
cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"])))
}
@@ -510,8 +510,8 @@ interpretive_rules <- function(x,
## Set base to R where base + enzyme inhibitor is R ----
rule_current <- paste0(
ab_enzyme$base_name[i], " ({.field ", col_base, "}) = R if ",
tolower(ab_enzyme$enzyme_name[i]), " ({.field ", col_enzyme, "}) = R"
ab_enzyme$base_name[i], " ({.field ", font_bold(col_base), "}) = R if ",
tolower(ab_enzyme$enzyme_name[i]), " ({.field ", font_bold(col_enzyme), "}) = R"
)
if (isTRUE(info)) {
cat(word_wrap(rule_current,
@@ -551,8 +551,8 @@ interpretive_rules <- function(x,
## Set base + enzyme inhibitor to S where base is S ----
rule_current <- paste0(
ab_enzyme$enzyme_name[i], " ({.field ", col_enzyme, "}) = S if ",
tolower(ab_enzyme$base_name[i]), " ({.field ", col_base, "}) = S"
ab_enzyme$enzyme_name[i], " ({.field ", font_bold(col_enzyme), "}) = S if ",
tolower(ab_enzyme$base_name[i]), " ({.field ", font_bold(col_base), "}) = S"
)
if (isTRUE(info)) {
@@ -662,9 +662,9 @@ interpretive_rules <- function(x,
if (ab %in% names(cols_ab) && !ab_s %in% names(cols_ab)) {
if (isTRUE(info)) {
message_(
"Using column '", cols_ab[names(cols_ab) == ab],
"' as ", ab_name(ab_s, language = NULL, tolower = TRUE),
" since a column '", ab_s, "' is missing but required for the chosen rules"
"Using column {.field ", font_bold(cols_ab[names(cols_ab) == ab]),
"} as ", ab_name(ab_s, language = NULL, tolower = TRUE),
" since a column {.code ", ab_s, "} is missing but required for the chosen rules"
)
}
cols_ab <- c(cols_ab, stats::setNames(unname(cols_ab[names(cols_ab) == ab]), ab_s))
@@ -806,7 +806,7 @@ interpretive_rules <- function(x,
")$"
)
} else if (like_is_one_of != "like") {
stop("invalid value for column 'like.is.one_of'", call. = FALSE)
stop("invalid value for column {.field like.is.one_of}", call. = FALSE)
}
if (is.na(source_antibiotics)) {

2
R/mdro.R
View File

@@ -476,7 +476,7 @@ mdro <- function(x = NULL,
if (!"AMP" %in% names(cols_ab) && "AMX" %in% names(cols_ab)) {
# ampicillin column is missing, but amoxicillin is available
if (isTRUE(info)) {
message_("Using column '", cols_ab[names(cols_ab) == "AMX"], "' as input for ampicillin since many MDRO rules depend on it.")
message_("Using column {.field ", font_bold(cols_ab[names(cols_ab) == "AMX"]), "} as input for ampicillin since many MDRO rules depend on it.")
}
cols_ab <- c(cols_ab, c(AMP = unname(cols_ab[names(cols_ab) == "AMX"])))
}

4
R/mic.R
View File

@@ -269,9 +269,9 @@ as.mic <- function(x, na.rm = FALSE, keep_operators = "all", round_to_next_log2
sort() %pm>%
vector_and(quotes = TRUE)
cur_col <- get_current_column()
warning_("in {.fun as.mic}: ", na_after - na_before, " result",
warning_("in {.help [{.fun as.mic}](AMR::as.mic)}: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
ifelse(is.null(cur_col), "", paste0(" in column {.field ", font_bold(cur_col, collapse = NULL), "}")),
" truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid MICs: ",

4
R/mo.R
View File

@@ -502,7 +502,7 @@ as.mo <- function(x,
)
if (any(out %in% AMR_env$MO_lookup$mo[match(post_Becker, AMR_env$MO_lookup$fullname)])) {
if (message_not_thrown_before("as.mo", "becker")) {
warning_("in {.fun as.mo}: Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ",
warning_("in {.help [{.fun as.mo}](AMR::as.mo)}: Becker ", font_italic("et al."), " (2014, 2019, 2020) does not contain these species named after their publication: ",
vector_and(font_italic(gsub("Staphylococcus", "S.", post_Becker, fixed = TRUE), collapse = NULL), quotes = FALSE),
". Categorisation to CoNS/CoPS was taken from the original scientific publication(s).",
immediate = TRUE, call = FALSE
@@ -680,7 +680,7 @@ pillar_shaft.mo <- function(x, ...) {
)
# throw a warning with the affected column name(s)
if (!is.null(mo_cols)) {
col <- paste0("Column ", vector_or(colnames(df)[mo_cols], quotes = TRUE, sort = FALSE))
col <- paste0("Column ", vector_or(paste0("{.field ", font_bold(colnames(df)[mo_cols], collapse = NULL), "}"), quotes = TRUE, sort = FALSE))
} else {
col <- "The data"
}

2
R/mo_property.R
View File

@@ -1042,7 +1042,7 @@ find_mo_col <- function(fn) {
)
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
if (message_not_thrown_before(fn = fn)) {
message_("Using column '", font_bold(mo), "' as input for {.help [{.fun ", fn, "}](AMR::", fn, ")}")
message_("Using column {.field ", font_bold(mo), "} as input for {.help [{.fun ", fn, "}](AMR::", fn, ")}")
}
return(df[, mo, drop = TRUE])
} else {

6
R/mo_source.R
View File

@@ -289,7 +289,7 @@ check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_o
}
if (!"mo" %in% colnames(x)) {
if (stop_on_error == TRUE) {
stop_(refer_to_name, " must contain a column {.field mo}", call = FALSE)
stop_(refer_to_name, " must contain a column {.code mo}", call = FALSE)
} else {
return(FALSE)
}
@@ -313,14 +313,14 @@ check_validity_mo_source <- function(x, refer_to_name = "`reference_df`", stop_o
}
if (colnames(x)[1] != "mo" && nrow(x) > length(unique(x[, 1, drop = TRUE]))) {
if (stop_on_error == TRUE) {
stop_(refer_to_name, " contains duplicate values in column '", colnames(x)[1], "'", call = FALSE)
stop_(refer_to_name, " contains duplicate values in column {.field ", font_bold(colnames(x)[1]), "}", call = FALSE)
} else {
return(FALSE)
}
}
if (colnames(x)[2] != "mo" && nrow(x) > length(unique(x[, 2, drop = TRUE]))) {
if (stop_on_error == TRUE) {
stop_(refer_to_name, " contains duplicate values in column '", colnames(x)[2], "'", call = FALSE)
stop_(refer_to_name, " contains duplicate values in column {.field ", font_bold(colnames(x)[2]), "}", call = FALSE)
} else {
return(FALSE)
}

2
R/plotting.R
View File

@@ -262,7 +262,7 @@ create_scale_mic <- function(aest, keep_operators, mic_range = NULL, ...) {
}
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)) {
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}.")
warning_("The value for {.field ", font_bold(aest_val), "} is outside the plotted MIC range, consider using/updating the {.arg mic_range} argument in {.fun scale_", aest, "_mic}.")
}
out[[aest_val]] <- log2(as.double(mics))
} else {

2
R/resistance_predict.R
View File

@@ -150,7 +150,7 @@ resistance_predict <- function(x,
}
stop_ifnot(
col_date %in% colnames(x),
"column '", col_date, "' not found"
"column {.code ", col_date, "} not found"
)
year <- function(x) {

65
R/sir.R
View File

@@ -471,7 +471,7 @@ is_sir_eligible <- function(x, threshold = 0.05) {
if (!is.na(ab)) {
# this is a valid antibiotic drug code
message_(
"Column '", font_bold(cur_col), "' is SIR eligible (despite only having empty values), since it seems to be ",
"Column {.field ", font_bold(cur_col), "} is SIR eligible (despite only having empty values), since it seems to be ",
ab_name(ab, language = NULL, tolower = TRUE), " (", ab, ")"
)
return(TRUE)
@@ -612,7 +612,7 @@ as.sir.default <- function(x,
cur_col <- get_current_column()
warning_("in {.help [{.fun as.sir}](AMR::as.sir)}: ", na_after - na_before, " result",
ifelse(na_after - na_before > 1, "s", ""),
ifelse(is.null(cur_col), "", paste0(" in column '", cur_col, "'")),
ifelse(is.null(cur_col), "", paste0(" in column {.field ", font_bold(cur_col, collapse = NULL), "}")),
" truncated (",
round(((na_after - na_before) / length(x)) * 100),
"%) that were invalid antimicrobial interpretations: ",
@@ -759,6 +759,10 @@ as.sir.data.frame <- function(x,
meet_criteria(max_cores, allow_class = c("numeric", "integer"), has_length = 1)
x.bak <- x
if (isTRUE(info) && message_not_thrown_before("as.sir", "sir_interpretation_history")) {
message_("Run {.help [{.fun sir_interpretation_history}](AMR::sir_interpretation_history)} afterwards to retrieve a logbook with all details of the breakpoint interpretations.\n\n")
}
if (tryCatch(length(list(...)) > 0, error = function(e) TRUE)) {
sel <- colnames(pm_select(x, ...))
} else {
@@ -835,7 +839,7 @@ as.sir.data.frame <- function(x,
message_(
"Assuming value", plural[1], " ",
vector_and(col_values, quotes = TRUE),
" in column ", paste0("{.field ", col_specimen, "}"), " reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1],
" in column ", paste0("{.field ", font_bold(col_specimen), "}"), " reflect", plural[2], " ", plural[3], "urinary tract infection", plural[1],
".\n Use `as.sir(uti = FALSE)` to prevent this."
)
}
@@ -857,7 +861,7 @@ as.sir.data.frame <- function(x,
return(FALSE)
}
if (length(sel) == 0 || (length(sel) > 0 && ab %in% sel)) {
ab_coerced <- suppressWarnings(as.ab(ab, info = info))
ab_coerced <- suppressWarnings(as.ab(ab, info = FALSE))
if (is.na(ab_coerced) || (length(sel) > 0 & !ab %in% sel)) {
# not even a valid AB code
return(FALSE)
@@ -907,6 +911,11 @@ as.sir.data.frame <- function(x,
}
}
if (isTRUE(info)) {
message_(as_note = FALSE) # empty line
message_("Processing columns:", as_note = FALSE)
}
run_as_sir_column <- function(i) {
ab_col <- ab_cols[i]
out <- list(result = NULL, log = NULL)
@@ -969,12 +978,12 @@ as.sir.data.frame <- function(x,
return(out)
} else if (types[i] == "sir") {
ab <- ab_col
ab_coerced <- suppressWarnings(as.ab(ab, info = info))
ab_coerced <- suppressWarnings(as.ab(ab, info = FALSE))
show_message <- FALSE
if (!all(x[, ab, drop = TRUE] %in% c("S", "SDD", "I", "R", "NI", NA), na.rm = TRUE)) {
show_message <- TRUE
if (isTRUE(info)) {
message_("Cleaning values in column ", paste0("{.field ", ab, "}"), " (",
message_("\u00a0\u00a0", AMR_env$bullet_icon, " Cleaning values in column ", paste0("{.field ", font_bold(ab), "}"), " (",
ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE, info = info), ")... ",
appendLF = FALSE,
@@ -984,7 +993,7 @@ as.sir.data.frame <- function(x,
} else if (!is.sir(x.bak[, ab, drop = TRUE])) {
show_message <- TRUE
if (isTRUE(info)) {
message_("Assigning class {.cls sir} to already clean column ", paste0("{.field ", ab, "}"), " (",
message_("\u00a0\u00a0", AMR_env$bullet_icon, " Assigning class {.cls sir} to already clean column ", paste0("{.field ", font_bold(ab), "}"), " (",
ifelse(ab_coerced != toupper(ab), paste0(ab_coerced, ", "), ""),
ab_name(ab_coerced, tolower = TRUE, language = NULL, info = info), ")... ",
appendLF = FALSE,
@@ -994,7 +1003,7 @@ as.sir.data.frame <- function(x,
}
result <- as.sir.default(x = as.character(x[, ab, drop = TRUE]))
if (show_message == TRUE && isTRUE(info)) {
message(font_green_bg(" OK "))
message_(font_green_bg("\u00a0OK\u00a0"), as_note = FALSE)
}
out$result <- result
out$log <- NULL
@@ -1006,7 +1015,7 @@ as.sir.data.frame <- function(x,
if (isTRUE(parallel) && n_cores > 1 && length(ab_cols) > 1) {
if (isTRUE(info)) {
message()
message_(as_note = FALSE)
message_("Running in parallel mode using ", n_cores, " out of ", get_n_cores(Inf), " cores, on columns ", vector_and(font_bold(ab_cols, collapse = NULL), quotes = "'", sort = FALSE), "...", as_note = FALSE, appendLF = FALSE)
}
if (.Platform$OS.type == "windows" || getRversion() < "4.0.0") {
@@ -1026,15 +1035,15 @@ as.sir.data.frame <- function(x,
result_list <- parallel::mclapply(seq_along(ab_cols), run_as_sir_column, mc.cores = n_cores)
}
if (isTRUE(info)) {
message_(font_green_bg(" DONE "), as_note = FALSE)
message()
message_(font_green_bg("\u00aDONE\u00a"), as_note = FALSE)
message_(as_note = FALSE)
message_("Run {.help [{.fun sir_interpretation_history}](AMR::sir_interpretation_history)} to retrieve a logbook with all details of the breakpoint interpretations.")
}
} else {
# sequential mode (non-parallel)
if (isTRUE(info) && n_cores > 1 && NROW(x) * NCOL(x) > 10000) {
# give a note that parallel mode might be better
message()
message_(as_note = FALSE)
message_("Running in sequential mode. Consider setting {.arg parallel} to {.code TRUE} to speed up processing on multiple cores.\n")
}
# this will contain a progress bar already
@@ -1221,7 +1230,7 @@ as_sir_method <- function(method_short,
host <- convert_host(host, lang = language)
if (any(is.na(host) & !is.na(host.bak)) && isTRUE(info) && message_not_thrown_before("as.sir", "missing_hosts")) {
warning_("The following animal host(s) could not be coerced: ", vector_and(host.bak[is.na(host) & !is.na(host.bak)]), immediate = TRUE)
message() # new line
message_(as_note = FALSE) # new line
}
# TODO add a switch to turn this off? In interactive sessions perhaps ask the user. Default should be On.
# if (breakpoint_type == "animal" && isTRUE(info) && message_not_thrown_before("as.sir", "host_missing_breakpoints")) {
@@ -1246,7 +1255,7 @@ as_sir_method <- function(method_short,
# get mo
if (!is.null(current_df) && length(mo) == 1 && mo %in% colnames(current_df)) {
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
mo_var_found <- paste0(" based on column {.field ", font_bold(mo), "}")
mo <- current_df[[mo]]
} else if (length(mo) != length(x)) {
mo_var_found <- ""
@@ -1262,7 +1271,7 @@ as_sir_method <- function(method_short,
silent = TRUE
)
if (!is.null(df) && !is.null(mo) && is.data.frame(df)) {
mo_var_found <- paste0(" based on column '", font_bold(mo), "'")
mo_var_found <- paste0(" based on column {.field ", font_bold(mo), "}")
mo <- df[, mo, drop = TRUE]
}
},
@@ -1315,7 +1324,7 @@ as_sir_method <- function(method_short,
}
ab.bak <- trimws2(ab)
ab <- suppressWarnings(as.ab(ab, info = info))
ab <- suppressWarnings(as.ab(ab, info = FALSE))
if (!is.null(list(...)$mo.bak)) {
mo.bak <- list(...)$mo.bak
} else {
@@ -1356,7 +1365,7 @@ as_sir_method <- function(method_short,
}
# format agents ----
agent_formatted <- paste0("'", font_bold(ab.bak, collapse = NULL), "'")
agent_formatted <- paste0("{.field ", font_bold(ab.bak, collapse = NULL), "}")
agent_name <- ab_name(ab, tolower = TRUE, language = NULL, info = info)
same_ab <- generalise_antibiotic_name(ab) == generalise_antibiotic_name(agent_name)
same_ab.bak <- generalise_antibiotic_name(ab.bak) == generalise_antibiotic_name(agent_name)
@@ -1372,7 +1381,7 @@ as_sir_method <- function(method_short,
)
# this intro text will also be printed in the progress bar if the `progress` package is installed
intro_txt <- paste0(
"Interpreting ", method_long, ": ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
"\u00a0\u00a0", AMR_env$bullet_icon, " Interpreting ", method_long, ": ", ifelse(isTRUE(list(...)$is_data.frame), "column ", ""),
ifelse(length(unique(agent_formatted)) == 1, unique(agent_formatted), paste0(vector_and(agent_formatted, quotes = FALSE, sort = FALSE))),
mo_var_found,
ifelse(identical(reference_data, AMR::clinical_breakpoints),
@@ -1390,7 +1399,7 @@ as_sir_method <- function(method_short,
rise_warning <- FALSE
rise_notes <- FALSE
method_coerced <- toupper(method)
ab_coerced <- as.ab(ab, info = info)
ab_coerced <- as.ab(ab, info = FALSE)
if (identical(reference_data, AMR::clinical_breakpoints)) {
breakpoints <- reference_data %pm>%
@@ -1487,14 +1496,14 @@ as_sir_method <- function(method_short,
# only print intro under 10 items, otherwise progressbar will print this and then it will be printed double
message_(intro_txt, appendLF = FALSE, as_note = FALSE)
}
p <- progress_ticker(n = nrow(df_unique), n_min = 10, title = font_blue(intro_txt), only_bar_percent = TRUE)
p <- progress_ticker(n = nrow(df_unique), n_min = 10, title = intro_txt, only_bar_percent = TRUE)
has_progress_bar <- !is.null(import_fn("progress_bar", "progress", error_on_fail = FALSE)) && nrow(df_unique) >= 10
on.exit(close(p))
if (nrow(breakpoints) == 0) {
# apparently no breakpoints found
if (isTRUE(info)) {
message(font_grey_bg(font_black(" NO BREAKPOINTS ")))
message_(font_grey_bg(font_black(" NO BREAKPOINTS ")), as_note = FALSE)
}
load_mo_uncertainties(metadata_mo)
@@ -1910,7 +1919,7 @@ as_sir_method <- function(method_short,
host = vectorise_log_entry(breakpoints_current[, "host", drop = TRUE], length(rows)),
input = vectorise_log_entry(as.character(input_clean), length(rows)),
outcome = vectorise_log_entry(as.sir(new_sir), length(rows)),
notes = font_stripstyle(notes_current), # vectorise_log_entry(paste0(font_stripstyle(notes_current), collapse = "\n"), length(rows)),
notes = cli_to_plain(font_stripstyle(notes_current)),
guideline = vectorise_log_entry(guideline_current, length(rows)),
ref_table = vectorise_log_entry(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)),
uti = vectorise_log_entry(breakpoints_current[, "uti", drop = TRUE], length(rows)),
@@ -1935,9 +1944,9 @@ as_sir_method <- function(method_short,
notes <- notes[!trimws2(notes) %in% c("", NA_character_)]
if (length(notes) > 0) {
if (isTRUE(rise_warning)) {
message(font_rose_bg(" WARNING "))
message_(font_rose_bg("\u00a0WARNING\u00a0"), as_note = FALSE)
} else {
message(font_yellow_bg(" NOTE "))
message_(font_yellow_bg("\u00a0NOTE\u00a0"), as_note = FALSE)
}
notes <- unique(notes)
# if (isTRUE(verbose) || length(notes) == 1 || NROW(AMR_env$sir_interpretation_history) == 0) {
@@ -1946,10 +1955,10 @@ as_sir_method <- function(method_short,
message_(notes[i], as_note = FALSE)
}
} else {
# message(word_wrap("\u00a0\u00a0", AMR_env$bullet_icon, " There were multiple notes. Print or View `sir_interpretation_history()` to examine them, or use `as.sir(..., verbose = TRUE)` next time to directly print them here.", add_fn = font_black))
# message_(word_wrap("\u00a0\u00a0", AMR_env$bullet_icon, " There were multiple notes. Print or View `sir_interpretation_history()` to examine them, or use `as.sir(..., verbose = TRUE)` next time to directly print them here.", add_fn = font_black))
}
} else {
message(font_green_bg(" OK "))
message_(font_green_bg("\u00a0OK\u00a0"), as_note = FALSE)
}
}
@@ -2226,13 +2235,13 @@ check_reference_data <- function(reference_data, .call_depth) {
class_sir <- vapply(FUN.VALUE = character(1), AMR::clinical_breakpoints, function(x) paste0("<", class(x), ">", collapse = " and "))
class_ref <- vapply(FUN.VALUE = character(1), reference_data, function(x) paste0("<", class(x), ">", collapse = " and "))
if (!all(names(class_sir) == names(class_ref))) {
stop_("{.arg reference_data} must have the same column names as the {.topic [clinical_breakpoints](AMR::clinical_breakpoints)} data set.", call = .call_depth)
stop_("{.arg reference_data} must have the same column names as the {.help [clinical_breakpoints](AMR::clinical_breakpoints)} data set.", call = .call_depth)
}
if (!all(class_sir == class_ref)) {
bad_col <- names(class_ref[class_sir != class_ref][1])
bad_cls <- gsub("<|>", "", class_ref[class_sir != class_ref][1])
exp_cls <- gsub("<|>", "", class_sir[class_sir != class_ref][1])
stop_("{.arg reference_data} must be the same structure as the {.topic [clinical_breakpoints](AMR::clinical_breakpoints)} data set. Column ", paste0("{.field ", bad_col, "}"), " is of class ", paste0("{.cls ", bad_cls, "}"), ", but should be of class ", paste0("{.cls ", exp_cls, "}"), call = .call_depth)
stop_("{.arg reference_data} must be the same structure as the {.help [clinical_breakpoints](AMR::clinical_breakpoints)} data set. Column ", paste0("{.field ", font_bold(bad_col, collapse = NULL), "}"), " is of class ", paste0("{.cls ", bad_cls, "}"), ", but should be of class ", paste0("{.cls ", exp_cls, "}"), call = .call_depth)
}
}
}

BIN
R/sysdata.rda
View File

Binary file not shown.

30
R/tidymodels.R
View File

@@ -122,14 +122,13 @@ all_disk_predictors <- function() {
#' @rdname amr-tidymodels
#' @export
step_mic_log2 <- function(
recipe,
...,
role = NA,
trained = FALSE,
columns = NULL,
skip = FALSE,
id = recipes::rand_id("mic_log2")
) {
recipe,
...,
role = NA,
trained = FALSE,
columns = NULL,
skip = FALSE,
id = recipes::rand_id("mic_log2")) {
recipes::add_step(
recipe,
step_mic_log2_new(
@@ -198,14 +197,13 @@ tidy.step_mic_log2 <- function(x, ...) {
#' @rdname amr-tidymodels
#' @export
step_sir_numeric <- function(
recipe,
...,
role = NA,
trained = FALSE,
columns = NULL,
skip = FALSE,
id = recipes::rand_id("sir_numeric")
) {
recipe,
...,
role = NA,
trained = FALSE,
columns = NULL,
skip = FALSE,
id = recipes::rand_id("sir_numeric")) {
recipes::add_step(
recipe,
step_sir_numeric_new(

BIN
data/antibiotics.rda
View File

Binary file not shown.

BIN
data/antimicrobials.rda
View File

Binary file not shown.