P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2024-12-27 06:46:12 +01:00
Code Releases Activity

(v2.1.1.9053) add verbose to as.sir(), unit test fix

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends 2024-06-17 10:38:45 +02:00
parent 68f7795481
commit 2dee1d71dc
7 changed files with 64 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR Package: AMR
Version: 2.1.1.9052 Version: 2.1.1.9053
Date: 2024-06-16 Date: 2024-06-17
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

2
NEWS.md
View File

@ -1,4 +1,4 @@
# AMR 2.1.1.9052 # AMR 2.1.1.9053
*(this beta version will eventually become v3.0. We're happy to reach a new major milestone soon, which will be all about the new One Health support!)* *(this beta version will eventually become v3.0. We're happy to reach a new major milestone soon, which will be all about the new One Health support!)*

13
R/aa_helper_functions.R
View File

@ -1340,23 +1340,24 @@ progress_ticker <- function(n = 1, n_min = 0, print = TRUE, clear = TRUE, title
} }
set_clean_class(pb, new_class = "txtProgressBar") set_clean_class(pb, new_class = "txtProgressBar")
} else if (n >= n_min) { } else if (n >= n_min) {
# use `progress`, which also has a timer
progress_bar <- import_fn("progress_bar", "progress", error_on_fail = FALSE)
if (!is.null(progress_bar)) {
# so we use progress::progress_bar
# a close()-method was also added, see below for that
title <- trimws2(title) title <- trimws2(title)
if (title != "") { if (title != "") {
title <- paste0(title, " ") title <- paste0(title, " ")
} }
progress_bar <- import_fn("progress_bar", "progress", error_on_fail = FALSE)
if (!is.null(progress_bar)) {
# so we use progress::progress_bar
# a close()-method was also added, see below for that
pb <- progress_bar$new( pb <- progress_bar$new(
show_after = 0,
format = paste0(title, format = paste0(title,
ifelse(only_bar_percent == TRUE, "[:bar] :percent", "[:bar] :percent (:current/:total,:eta)")), ifelse(only_bar_percent == TRUE, "[:bar] :percent", "[:bar] :percent (:current/:total,:eta)")),
clear = clear, clear = clear,
total = n total = n
) )
} else { } else {
# use base R # use base R's txtProgressBar
cat(title, "\n", sep = "")
pb <- utils::txtProgressBar(max = n, style = 3) pb <- utils::txtProgressBar(max = n, style = 3)
pb$tick <- function() { pb$tick <- function() {
pb$up(pb$getVal() + 1) pb$up(pb$getVal() + 1)

78
R/sir.R
View File

@ -50,6 +50,7 @@
#' @param include_PKPD a [logical] to indicate that PK/PD clinical breakpoints must be applied as a last resort - the default is `TRUE`. Can also be set with the [package option][AMR-options] [`AMR_include_PKPD`][AMR-options]. #' @param include_PKPD a [logical] to indicate that PK/PD clinical breakpoints must be applied as a last resort - the default is `TRUE`. Can also be set with the [package option][AMR-options] [`AMR_include_PKPD`][AMR-options].
#' @param breakpoint_type the type of breakpoints to use, either `r vector_or(clinical_breakpoints$type)`. ECOFF stands for Epidemiological Cut-Off values. The default is `"human"`, which can also be set with the [package option][AMR-options] [`AMR_breakpoint_type`][AMR-options]. If `host` is set to values of veterinary species, this will automatically be set to `"animal"`. #' @param breakpoint_type the type of breakpoints to use, either `r vector_or(clinical_breakpoints$type)`. ECOFF stands for Epidemiological Cut-Off values. The default is `"human"`, which can also be set with the [package option][AMR-options] [`AMR_breakpoint_type`][AMR-options]. If `host` is set to values of veterinary species, this will automatically be set to `"animal"`.
#' @param host a vector (or column name) with [character]s to indicate the host. Only useful for veterinary breakpoints, as it requires `breakpoint_type = "animal"`. The values can be any text resembling the animal species, even in any of the `r length(LANGUAGES_SUPPORTED)` supported languages of this package. For foreign languages, be sure to set the language with [set_AMR_locale()] (though it will be automatically guessed based on the system language). #' @param host a vector (or column name) with [character]s to indicate the host. Only useful for veterinary breakpoints, as it requires `breakpoint_type = "animal"`. The values can be any text resembling the animal species, even in any of the `r length(LANGUAGES_SUPPORTED)` supported languages of this package. For foreign languages, be sure to set the language with [set_AMR_locale()] (though it will be automatically guessed based on the system language).
#' @param verbose a [logical] to indicate that all notes should be printed during interpretation of MIC values or disk diffusion values.
#' @param reference_data a [data.frame] to be used for interpretation, which defaults to the [clinical_breakpoints] data set. Changing this argument allows for using own interpretation guidelines. This argument must contain a data set that is equal in structure to the [clinical_breakpoints] data set (same column names and column types). Please note that the `guideline` argument will be ignored when `reference_data` is manually set. #' @param reference_data a [data.frame] to be used for interpretation, which defaults to the [clinical_breakpoints] data set. Changing this argument allows for using own interpretation guidelines. This argument must contain a data set that is equal in structure to the [clinical_breakpoints] data set (same column names and column types). Please note that the `guideline` argument will be ignored when `reference_data` is manually set.
#' @param threshold maximum fraction of invalid antimicrobial interpretations of `x`, see *Examples* #' @param threshold maximum fraction of invalid antimicrobial interpretations of `x`, see *Examples*
#' @param ... for using on a [data.frame]: names of columns to apply [as.sir()] on (supports tidy selection such as `column1:column4`). Otherwise: arguments passed on to methods. #' @param ... for using on a [data.frame]: names of columns to apply [as.sir()] on (supports tidy selection such as `column1:column4`). Otherwise: arguments passed on to methods.
@ -473,6 +474,7 @@ as.sir.mic <- function(x,
include_PKPD = getOption("AMR_include_PKPD", TRUE), include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"), breakpoint_type = getOption("AMR_breakpoint_type", "human"),
host = NULL, host = NULL,
verbose = FALSE,
...) { ...) {
as_sir_method( as_sir_method(
method_short = "mic", method_short = "mic",
@ -489,6 +491,7 @@ as.sir.mic <- function(x,
include_PKPD = include_PKPD, include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type, breakpoint_type = breakpoint_type,
host = host, host = host,
verbose = verbose,
... ...
) )
} }
@ -506,6 +509,7 @@ as.sir.disk <- function(x,
include_PKPD = getOption("AMR_include_PKPD", TRUE), include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"), breakpoint_type = getOption("AMR_breakpoint_type", "human"),
host = NULL, host = NULL,
verbose = FALSE,
...) { ...) {
as_sir_method( as_sir_method(
method_short = "disk", method_short = "disk",
@ -522,6 +526,7 @@ as.sir.disk <- function(x,
include_PKPD = include_PKPD, include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type, breakpoint_type = breakpoint_type,
host = NULL, host = NULL,
verbose = verbose,
... ...
) )
} }
@ -539,7 +544,8 @@ as.sir.data.frame <- function(x,
include_screening = getOption("AMR_include_screening", FALSE), include_screening = getOption("AMR_include_screening", FALSE),
include_PKPD = getOption("AMR_include_PKPD", TRUE), include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"), breakpoint_type = getOption("AMR_breakpoint_type", "human"),
host = NULL) { host = NULL,
verbose = FALSE) {
meet_criteria(x, allow_class = "data.frame") # will also check for dimensions > 0 meet_criteria(x, allow_class = "data.frame") # will also check for dimensions > 0
meet_criteria(col_mo, allow_class = "character", is_in = colnames(x), allow_NULL = TRUE) meet_criteria(col_mo, allow_class = "character", is_in = colnames(x), allow_NULL = TRUE)
meet_criteria(guideline, allow_class = "character", has_length = 1) meet_criteria(guideline, allow_class = "character", has_length = 1)
@ -551,6 +557,7 @@ as.sir.data.frame <- function(x,
meet_criteria(include_PKPD, allow_class = "logical", has_length = 1) meet_criteria(include_PKPD, allow_class = "logical", has_length = 1)
meet_criteria(breakpoint_type, allow_class = "character", is_in = reference_data$type, has_length = 1) meet_criteria(breakpoint_type, allow_class = "character", is_in = reference_data$type, has_length = 1)
meet_criteria(host, allow_class = c("character", "factor"), allow_NULL = TRUE, allow_NA = TRUE) meet_criteria(host, allow_class = c("character", "factor"), allow_NULL = TRUE, allow_NA = TRUE)
meet_criteria(verbose, allow_class = "logical", has_length = 1)
x.bak <- x x.bak <- x
for (i in seq_len(ncol(x))) { for (i in seq_len(ncol(x))) {
# don't keep factors, overwriting them is hard # don't keep factors, overwriting them is hard
@ -701,6 +708,7 @@ as.sir.data.frame <- function(x,
include_PKPD = include_PKPD, include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type, breakpoint_type = breakpoint_type,
host = host, host = host,
verbose = verbose,
is_data.frame = TRUE is_data.frame = TRUE
) )
} else if (types[i] == "disk") { } else if (types[i] == "disk") {
@ -720,6 +728,7 @@ as.sir.data.frame <- function(x,
include_PKPD = include_PKPD, include_PKPD = include_PKPD,
breakpoint_type = breakpoint_type, breakpoint_type = breakpoint_type,
host = host, host = host,
verbose = verbose,
is_data.frame = TRUE is_data.frame = TRUE
) )
} else if (types[i] == "sir") { } else if (types[i] == "sir") {
@ -808,6 +817,7 @@ as_sir_method <- function(method_short,
include_PKPD, include_PKPD,
breakpoint_type, breakpoint_type,
host, host,
verbose,
...) { ...) {
meet_criteria(x, allow_NA = TRUE, .call_depth = -2) meet_criteria(x, allow_NA = TRUE, .call_depth = -2)
meet_criteria(mo, allow_class = c("mo", "character"), has_length = c(1, length(x)), allow_NULL = TRUE, .call_depth = -2) meet_criteria(mo, allow_class = c("mo", "character"), has_length = c(1, length(x)), allow_NULL = TRUE, .call_depth = -2)
@ -822,6 +832,7 @@ as_sir_method <- function(method_short,
check_reference_data(reference_data, .call_depth = -2) check_reference_data(reference_data, .call_depth = -2)
meet_criteria(breakpoint_type, allow_class = "character", is_in = reference_data$type, has_length = 1, .call_depth = -2) meet_criteria(breakpoint_type, allow_class = "character", is_in = reference_data$type, has_length = 1, .call_depth = -2)
meet_criteria(host, allow_class = c("character", "factor"), allow_NULL = TRUE, allow_NA = TRUE, .call_depth = -2) meet_criteria(host, allow_class = c("character", "factor"), allow_NULL = TRUE, allow_NA = TRUE, .call_depth = -2)
meet_criteria(verbose, allow_class = "logical", has_length = 1, .call_depth = -2)
# backward compatibilty # backward compatibilty
dots <- list(...) dots <- list(...)
@ -852,7 +863,7 @@ as_sir_method <- function(method_short,
host <- convert_host(host) host <- convert_host(host)
if (message_not_thrown_before("as.sir", "sir_interpretation_history")) { if (message_not_thrown_before("as.sir", "sir_interpretation_history")) {
message_("Run `sir_interpretation_history()` afterwards to retrieve a logbook with all the details of the breakpoint interpretations. Note that some ", ifelse(breakpoint_type == "animal", "animal hosts and ", ""), "microorganisms might not have breakpoints for each antimicrobial drug in ", guideline_coerced, ".\n\n") message_("Run `sir_interpretation_history()` afterwards to retrieve a logbook with all the details of the breakpoint interpretations.\n\n", add_fn = font_red)
} }
if (breakpoint_type == "animal" && message_not_thrown_before("as.sir", "host_preferred_order")) { if (breakpoint_type == "animal" && message_not_thrown_before("as.sir", "host_preferred_order")) {
message_("Please note that in the absence of specific veterinary breakpoints for certain animal hosts, breakpoints for dogs, cattle, swine, cats, horse, aquatic, and poultry, in that order, are used as substitutes.\n\n") message_("Please note that in the absence of specific veterinary breakpoints for certain animal hosts, breakpoints for dogs, cattle, swine, cats, horse, aquatic, and poultry, in that order, are used as substitutes.\n\n")
@ -1002,16 +1013,6 @@ as_sir_method <- function(method_short,
""), ""),
"... ") "... ")
msg_note <- function(messages, font_fn = font_black) {
messages <- unique(messages)
for (i in seq_len(length(messages))) {
messages[i] <- word_wrap(extra_indent = 5, messages[i])
}
message(
paste0(" ", font_fn(AMR_env$bullet_icon), " ", font_fn(messages, collapse = NULL), collapse = "\n")
)
}
method <- method_short method <- method_short
metadata_mo <- get_mo_uncertainties() metadata_mo <- get_mo_uncertainties()
@ -1076,7 +1077,7 @@ as_sir_method <- function(method_short,
add_intrinsic_resistance_to_AMR_env() add_intrinsic_resistance_to_AMR_env()
} }
if (nrow(df_unique) < 10) { if (nrow(df_unique) < 10 || nrow(breakpoints) == 0) {
# only print intro under 10 items, otherwise progressbar will print this and then it will be printed double # only print intro under 10 items, otherwise progressbar will print this and then it will be printed double
message_(intro_txt, appendLF = FALSE, as_note = FALSE) message_(intro_txt, appendLF = FALSE, as_note = FALSE)
} }
@ -1111,6 +1112,7 @@ as_sir_method <- function(method_short,
ab_current <- df_unique[i, "ab", drop = TRUE] ab_current <- df_unique[i, "ab", drop = TRUE]
host_current <- df_unique[i, "host", drop = TRUE] host_current <- df_unique[i, "host", drop = TRUE]
uti_current <- df_unique[i, "uti", drop = TRUE] uti_current <- df_unique[i, "uti", drop = TRUE]
notes_current <- character(0)
if (isFALSE(uti_current)) { if (isFALSE(uti_current)) {
# no preference, so no filter on UTIs # no preference, so no filter on UTIs
rows <- which(df$mo == mo_current & df$ab == ab_current & df$host == host_current) rows <- which(df$mo == mo_current & df$ab == ab_current & df$host == host_current)
@ -1162,14 +1164,15 @@ as_sir_method <- function(method_short,
data.frame( data.frame(
datetime = vectorise_log_entry(Sys.time(), length(rows)), datetime = vectorise_log_entry(Sys.time(), length(rows)),
index = rows, index = rows,
ab_user = vectorise_log_entry(ab.bak[match(ab_current, df$ab)][1], length(rows)), ab_given = vectorise_log_entry(ab.bak[match(ab_current, df$ab)][1], length(rows)),
mo_user = vectorise_log_entry(mo.bak[match(mo_current, df$mo)][1], length(rows)), mo_given = vectorise_log_entry(mo.bak[match(mo_current, df$mo)][1], length(rows)),
host_given = vectorise_log_entry(host_current, length(rows)),
ab = vectorise_log_entry(ab_current, length(rows)), ab = vectorise_log_entry(ab_current, length(rows)),
mo = vectorise_log_entry(mo_current, length(rows)), mo = vectorise_log_entry(mo_current, length(rows)),
host = vectorise_log_entry(host_current, length(rows)),
method = vectorise_log_entry(method_coerced, length(rows)), method = vectorise_log_entry(method_coerced, length(rows)),
input = vectorise_log_entry(as.double(values), length(rows)), input = vectorise_log_entry(as.double(values), length(rows)),
outcome = vectorise_log_entry(NA_sir_, length(rows)), outcome = vectorise_log_entry(NA_sir_, length(rows)),
host = vectorise_log_entry(host_current, length(rows)),
notes = vectorise_log_entry("NO BREAKPOINT AVAILABLE", length(rows)), notes = vectorise_log_entry("NO BREAKPOINT AVAILABLE", length(rows)),
guideline = vectorise_log_entry(guideline_coerced, length(rows)), guideline = vectorise_log_entry(guideline_coerced, length(rows)),
ref_table = vectorise_log_entry(NA_character_, length(rows)), ref_table = vectorise_log_entry(NA_character_, length(rows)),
@ -1211,8 +1214,7 @@ as_sir_method <- function(method_short,
subset(host_match == TRUE) subset(host_match == TRUE)
} else { } else {
# no breakpoint found for this host, so sort on mostly available guidelines # no breakpoint found for this host, so sort on mostly available guidelines
notes <- c(notes, paste0("Using ", font_bold(breakpoints_current$host[1]), " breakpoints since ", font_bold(host_current), " for ", ab_formatted, " in ", mo_formatted, " are not available.")) notes_current <- c(notes_current, paste0("Using ", font_bold(breakpoints_current$host[1]), " breakpoints since ", font_bold(host_current), " for ", ab_formatted, " in ", mo_formatted, " are not available."))
rise_notes <- TRUE
} }
} }
@ -1225,20 +1227,20 @@ as_sir_method <- function(method_short,
} }
if (nrow(breakpoints_current) == 1 && all(breakpoints_current$uti == TRUE) && any(uti_current %in% c(FALSE, NA)) && message_not_thrown_before("as.sir", "uti", ab_current)) { if (nrow(breakpoints_current) == 1 && all(breakpoints_current$uti == TRUE) && any(uti_current %in% c(FALSE, NA)) && message_not_thrown_before("as.sir", "uti", ab_current)) {
# only UTI breakpoints available # only UTI breakpoints available
notes <- c(notes, paste0("Breakpoints for ", font_bold(ab_formatted), " in ", mo_formatted, " are only available for (uncomplicated) urinary tract infections (UTI); assuming `uti = TRUE`.")) notes_current <- c(notes_current, paste0("Breakpoints for ", font_bold(ab_formatted), " in ", mo_formatted, " are only available for (uncomplicated) urinary tract infections (UTI); assuming `uti = TRUE`."))
} else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && any(is.na(uti_current)) && all(c(TRUE, FALSE) %in% breakpoints_current$uti, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteUTI", mo_current, ab_current)) { } else if (nrow(breakpoints_current) > 1 && length(unique(breakpoints_current$site)) > 1 && any(is.na(uti_current)) && all(c(TRUE, FALSE) %in% breakpoints_current$uti, na.rm = TRUE) && message_not_thrown_before("as.sir", "siteUTI", mo_current, ab_current)) {
# both UTI and Non-UTI breakpoints available # both UTI and Non-UTI breakpoints available
notes <- c(notes, paste0("Breakpoints for UTI ", font_bold("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, ". Use argument `uti` to set which isolates are from urine. See `?as.sir`.")) notes_current <- c(notes_current, paste0("Breakpoints for UTI ", font_bold("and"), " non-UTI available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, ". Use argument `uti` to set which isolates are from urine. See `?as.sir`."))
breakpoints_current <- breakpoints_current %pm>% breakpoints_current <- breakpoints_current %pm>%
pm_filter(uti == FALSE) pm_filter(uti == FALSE)
} 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
notes <- c(notes, paste0("Multiple breakpoints available for ", font_bold(ab_formatted), " in ", mo_formatted, " - assuming ", site, ".")) notes_current <- c(notes_current, paste0("Multiple breakpoints available for ", font_bold(ab_formatted), " in ", mo_formatted, " - assuming ", site, "."))
} }
# first check if mo is intrinsic resistant # first check if mo is intrinsic resistant
if (isTRUE(add_intrinsic_resistance) && guideline_coerced %like% "EUCAST" && paste(mo_current, ab_current) %in% AMR_env$intrinsic_resistant) { if (isTRUE(add_intrinsic_resistance) && guideline_coerced %like% "EUCAST" && paste(mo_current, ab_current) %in% AMR_env$intrinsic_resistant) {
notes <- c(notes, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, "")) notes_current <- c(notes_current, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, ""))
new_sir <- rep(as.sir("R"), length(rows)) new_sir <- rep(as.sir("R"), length(rows))
} else if (nrow(breakpoints_current) == 0) { } else if (nrow(breakpoints_current) == 0) {
# no rules available # no rules available
@ -1248,10 +1250,10 @@ as_sir_method <- function(method_short,
breakpoints_current <- breakpoints_current[1L, , drop = FALSE] breakpoints_current <- breakpoints_current[1L, , drop = FALSE]
if (any(breakpoints_current$mo == "UNKNOWN", na.rm = TRUE) | any(breakpoints_current$ref_tbl %like% "PK.*PD", na.rm = TRUE)) { if (any(breakpoints_current$mo == "UNKNOWN", na.rm = TRUE) | any(breakpoints_current$ref_tbl %like% "PK.*PD", na.rm = TRUE)) {
notes <- c(notes, "Some PK/PD breakpoints were applied - use `include_PKPD = FALSE` to prevent this") notes_current <- c(notes_current, "Some PK/PD breakpoints were applied - use `include_PKPD = FALSE` to prevent this")
} }
if (any(breakpoints_current$site %like% "screen", na.rm = TRUE) | any(breakpoints_current$ref_tbl %like% "screen", na.rm = TRUE)) { if (any(breakpoints_current$site %like% "screen", na.rm = TRUE) | any(breakpoints_current$ref_tbl %like% "screen", na.rm = TRUE)) {
notes <- c(notes, "Some screening breakpoints were applied - use `include_screening = FALSE` to prevent this") notes_current <- c(notes_current, "Some screening breakpoints were applied - use `include_screening = FALSE` to prevent this")
} }
if (method == "mic") { if (method == "mic") {
@ -1285,15 +1287,16 @@ as_sir_method <- function(method_short,
data.frame( data.frame(
datetime = vectorise_log_entry(Sys.time(), length(rows)), datetime = vectorise_log_entry(Sys.time(), length(rows)),
index = rows, index = rows,
ab_user = vectorise_log_entry(ab.bak[match(ab_current, df$ab)][1], length(rows)), ab_given = vectorise_log_entry(ab.bak[match(ab_current, df$ab)][1], length(rows)),
mo_user = vectorise_log_entry(mo.bak[match(mo_current, df$mo)][1], length(rows)), mo_given = vectorise_log_entry(mo.bak[match(mo_current, df$mo)][1], length(rows)),
host_given = vectorise_log_entry(host_current, length(rows)),
ab = vectorise_log_entry(breakpoints_current[, "ab", drop = TRUE], length(rows)), ab = vectorise_log_entry(breakpoints_current[, "ab", drop = TRUE], length(rows)),
mo = vectorise_log_entry(breakpoints_current[, "mo", drop = TRUE], length(rows)), mo = vectorise_log_entry(breakpoints_current[, "mo", drop = TRUE], length(rows)),
host = vectorise_log_entry(breakpoints_current[, "host", drop = TRUE], length(rows)),
method = vectorise_log_entry(method_coerced, length(rows)), method = vectorise_log_entry(method_coerced, length(rows)),
input = vectorise_log_entry(as.double(values), length(rows)), input = vectorise_log_entry(as.double(values), length(rows)),
outcome = vectorise_log_entry(as.sir(new_sir), length(rows)), outcome = vectorise_log_entry(as.sir(new_sir), length(rows)),
host = vectorise_log_entry(breakpoints_current[, "host", drop = TRUE], length(rows)), notes = vectorise_log_entry(paste0(font_stripstyle(notes_current), collapse = "\n"), length(rows)),
notes = vectorise_log_entry(paste0(font_stripstyle(notes), collapse = "\n"), length(rows)),
guideline = vectorise_log_entry(guideline_coerced, length(rows)), guideline = vectorise_log_entry(guideline_coerced, length(rows)),
ref_table = vectorise_log_entry(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)), ref_table = vectorise_log_entry(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)),
uti = vectorise_log_entry(breakpoints_current[, "uti", drop = TRUE], length(rows)), uti = vectorise_log_entry(breakpoints_current[, "uti", drop = TRUE], length(rows)),
@ -1303,6 +1306,7 @@ as_sir_method <- function(method_short,
) )
} }
notes <- c(notes, notes_current)
df[rows, "result"] <- new_sir df[rows, "result"] <- new_sir
} }
@ -1315,14 +1319,15 @@ as_sir_method <- function(method_short,
} }
if (isTRUE(rise_warning)) { if (isTRUE(rise_warning)) {
message(font_rose_bg(" WARNING ")) message(font_rose_bg(" WARNING "))
} else if (isTRUE(rise_notes)) { } else if (length(notes) > 0) {
message(font_yellow_bg(paste0(" NOTE", ifelse(length(notes) > 1, "S ", " ")))) message(font_yellow_bg(" NOTES "))
if (length(notes) > 1) { if (isTRUE(verbose) || length(notes) == 1) {
plural <- c("were", "s", "them") for (i in seq_len(length(notes))) {
} else { message(word_wrap(" ", AMR_env$bullet_icon, " ", notes[i], add_fn = font_black))
plural <- c("was", "", "it") }
} 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 ", plural[1], " ", length(notes), " note", plural[2], ". Print or View `sir_interpretation_history()` to examine ", plural[3], ".", add_fn = font_black))
} else { } else {
message(font_green_bg(" OK ")) message(font_green_bg(" OK "))
} }
@ -1342,10 +1347,9 @@ sir_interpretation_history <- function(clean = FALSE) {
out$outcome <- as.sir(out$outcome) out$outcome <- as.sir(out$outcome)
if (NROW(out) > 0) { if (NROW(out) > 0) {
# sort descending on time # sort descending on time
out <- out[order(out$datetime, out$index, decreasing = TRUE), , drop = FALSE] out <- out[order(format(out$datetime, "%Y%m%d%H%M"), out$index, decreasing = TRUE), , drop = FALSE]
} }
# keep stored for next use
if (isTRUE(clean)) { if (isTRUE(clean)) {
AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE] AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE]
} }

7
R/zzz.R
View File

@ -58,14 +58,15 @@ AMR_env$av_previously_coerced <- data.frame(
AMR_env$sir_interpretation_history <- data.frame( AMR_env$sir_interpretation_history <- data.frame(
datetime = Sys.time()[0], datetime = Sys.time()[0],
index = integer(0), index = integer(0),
ab_user = character(0), ab_given = character(0),
mo_user = character(0), mo_given = character(0),
host_given = character(0),
ab = set_clean_class(character(0), c("ab", "character")), ab = set_clean_class(character(0), c("ab", "character")),
mo = set_clean_class(character(0), c("mo", "character")), mo = set_clean_class(character(0), c("mo", "character")),
host = character(0),
method = character(0), method = character(0),
input = double(0), input = double(0),
outcome = NA_sir_[0], outcome = NA_sir_[0],
host = character(0),
notes = character(0), notes = character(0),
guideline = character(0), guideline = character(0),
ref_table = character(0), ref_table = character(0),

9
inst/tinytest/test-sir.R
View File

@ -179,7 +179,7 @@ expect_equal(suppressMessages(
expect_true(is.data.frame(sir_interpretation_history(clean = FALSE))) expect_true(is.data.frame(sir_interpretation_history(clean = FALSE)))
expect_true(is.data.frame(sir_interpretation_history(clean = TRUE))) expect_true(is.data.frame(sir_interpretation_history(clean = TRUE)))
expect_true(is.null(sir_interpretation_history())) expect_true(NROW(sir_interpretation_history()) == 0)
# cutoffs at MIC = 8 # cutoffs at MIC = 8
expect_equal( expect_equal(
@ -319,10 +319,9 @@ expect_identical(out_vet$FLR, as.sir(c("S", "S", NA, "S", "S", NA, "I", "R", NA,
sir_history <- sir_interpretation_history() sir_history <- sir_interpretation_history()
expect_identical(sir_history$host, expect_identical(sir_history$host,
c("cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", c("poultry", "cattle", "poultry", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "dogs", "horse", "dogs", "horse", "horse", "horse", "cattle", "horse", "cattle", "cattle", "cattle",
"cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "dogs", "dogs", "cattle", "cattle", "cats", "cattle", "cattle", "cattle", "cattle", "dogs", "dogs", "dogs", "dogs", "dogs", "dogs", "cattle", "dogs", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cats", "cats",
"cats", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "cattle", "dogs", "cats", "cats", "cats", "cats", "cattle", "cats", "cattle", "cattle", "cats", "cattle", "cats", "cattle", "cattle"))
"dogs", "cattle", "cattle", "cats", "cats"))
# ECOFF ------------------------------------------------------------------- # ECOFF -------------------------------------------------------------------

7
man/as.sir.Rd
View File

@ -54,6 +54,7 @@ is_sir_eligible(x, threshold = 0.05)
include_PKPD = getOption("AMR_include_PKPD", TRUE), include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"), breakpoint_type = getOption("AMR_breakpoint_type", "human"),
host = NULL, host = NULL,
verbose = FALSE,
... ...
) )
@ -69,6 +70,7 @@ is_sir_eligible(x, threshold = 0.05)
include_PKPD = getOption("AMR_include_PKPD", TRUE), include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"), breakpoint_type = getOption("AMR_breakpoint_type", "human"),
host = NULL, host = NULL,
verbose = FALSE,
... ...
) )
@ -84,7 +86,8 @@ is_sir_eligible(x, threshold = 0.05)
include_screening = getOption("AMR_include_screening", FALSE), include_screening = getOption("AMR_include_screening", FALSE),
include_PKPD = getOption("AMR_include_PKPD", TRUE), include_PKPD = getOption("AMR_include_PKPD", TRUE),
breakpoint_type = getOption("AMR_breakpoint_type", "human"), breakpoint_type = getOption("AMR_breakpoint_type", "human"),
host = NULL host = NULL,
verbose = FALSE
) )
sir_interpretation_history(clean = FALSE) sir_interpretation_history(clean = FALSE)
@ -120,6 +123,8 @@ sir_interpretation_history(clean = FALSE)
\item{host}{a vector (or column name) with \link{character}s to indicate the host. Only useful for veterinary breakpoints, as it requires \code{breakpoint_type = "animal"}. The values can be any text resembling the animal species, even in any of the 20 supported languages of this package. For foreign languages, be sure to set the language with \code{\link[=set_AMR_locale]{set_AMR_locale()}} (though it will be automatically guessed based on the system language).} \item{host}{a vector (or column name) with \link{character}s to indicate the host. Only useful for veterinary breakpoints, as it requires \code{breakpoint_type = "animal"}. The values can be any text resembling the animal species, even in any of the 20 supported languages of this package. For foreign languages, be sure to set the language with \code{\link[=set_AMR_locale]{set_AMR_locale()}} (though it will be automatically guessed based on the system language).}
\item{verbose}{a \link{logical} to indicate that all notes should be printed during interpretation of MIC values or disk diffusion values.}
\item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}) - the default is the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.} \item{col_mo}{column name of the names or codes of the microorganisms (see \code{\link[=as.mo]{as.mo()}}) - the default is the first column of class \code{\link{mo}}. Values will be coerced using \code{\link[=as.mo]{as.mo()}}.}
\item{clean}{a \link{logical} to indicate whether previously stored results should be forgotten after returning the 'logbook' with results} \item{clean}{a \link{logical} to indicate whether previously stored results should be forgotten after returning the 'logbook' with results}