From 68f7795481ae5b2b2a7fcef8d3b72e9d89adb373 Mon Sep 17 00:00:00 2001 From: Matthijs Berends Date: Sun, 16 Jun 2024 20:53:50 +0200 Subject: [PATCH] (v2.1.1.9052) unit test fix --- DESCRIPTION | 2 +- NAMESPACE | 1 + NEWS.md | 2 +- R/ab_selectors.R | 4 +- R/sir.R | 150 +++++++++++++-------- inst/tinytest/test-custom_microorganisms.R | 4 +- man/antibiotic_class_selectors.Rd | 4 +- 7 files changed, 106 insertions(+), 61 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 55655ecc..0c98a6d2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,5 +1,5 @@ Package: AMR -Version: 2.1.1.9051 +Version: 2.1.1.9052 Date: 2024-06-16 Title: Antimicrobial Resistance Data Analysis Description: Functions to simplify and standardise antimicrobial resistance (AMR) diff --git a/NAMESPACE b/NAMESPACE index e81a07bd..9d2d4e2f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -96,6 +96,7 @@ S3method(print,mo_renamed) S3method(print,mo_uncertainties) S3method(print,pca) S3method(print,sir) +S3method(print,sir_log) S3method(quantile,mic) S3method(rep,ab) S3method(rep,av) diff --git a/NEWS.md b/NEWS.md index 273a1598..cde96e62 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# AMR 2.1.1.9051 +# AMR 2.1.1.9052 *(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!)* diff --git a/R/ab_selectors.R b/R/ab_selectors.R index 56c6a7f8..9a962802 100755 --- a/R/ab_selectors.R +++ b/R/ab_selectors.R @@ -63,7 +63,7 @@ #' # dplyr ------------------------------------------------------------------- #' #' if (require("dplyr")) { -#'. example_isolates %>% select(carbapenems()) +#' example_isolates %>% select(carbapenems()) #' } #' #' if (require("dplyr")) { @@ -73,7 +73,7 @@ #' #' if (require("dplyr")) { #' # select only antibiotic columns with DDDs for oral treatment -#'. example_isolates %>% select(administrable_per_os()) +#' example_isolates %>% select(administrable_per_os()) #' } #' #' if (require("dplyr")) { diff --git a/R/sir.R b/R/sir.R index affb5ce0..b11c3155 100755 --- a/R/sir.R +++ b/R/sir.R @@ -1002,14 +1002,13 @@ as_sir_method <- function(method_short, ""), "... ") - msg_note <- function(messages) { + 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( - font_yellow_bg(paste0(" NOTE", ifelse(length(messages) > 1, "S", ""), " \n")), - paste0(" ", font_black(AMR_env$bullet_icon), " ", font_black(messages, collapse = NULL), collapse = "\n") + paste0(" ", font_fn(AMR_env$bullet_icon), " ", font_fn(messages, collapse = NULL), collapse = "\n") ) } @@ -1018,7 +1017,7 @@ as_sir_method <- function(method_short, metadata_mo <- get_mo_uncertainties() rise_warning <- FALSE - rise_note <- FALSE + rise_notes <- FALSE method_coerced <- toupper(method) ab_coerced <- as.ab(ab) @@ -1070,7 +1069,7 @@ as_sir_method <- function(method_short, subset(mo != "UNKNOWN" & ref_tbl %unlike% "PK.*PD") } - msgs <- character(0) + notes <- character(0) if (guideline_coerced %like% "EUCAST") { any_is_intrinsic_resistant <- FALSE @@ -1097,6 +1096,14 @@ as_sir_method <- function(method_short, return(rep(NA_sir_, nrow(df))) } + vectorise_log_entry <- function(x, len) { + if (length(x) == 1 && len > 1) { + rep(x, len) + } else { + x + } + } + # run the rules (df_unique is a row combination per mo/ab/uti/host) for (i in seq_len(nrow(df_unique))) { p$tick() @@ -1136,7 +1143,6 @@ as_sir_method <- function(method_short, suppressMessages(suppressWarnings(ab_name(ab_current, language = NULL, tolower = TRUE))), " (", ab_current, ")" ) - notes <- character(0) # gather all available breakpoints for current MO breakpoints_current <- breakpoints %pm>% @@ -1147,6 +1153,34 @@ as_sir_method <- function(method_short, mo_current_species_group, mo_current_other )) + + if (NROW(breakpoints_current) == 0) { + # no note about missing breakpoints - it's already in the header before the interpretation starts + AMR_env$sir_interpretation_history <- rbind_AMR( + AMR_env$sir_interpretation_history, + # recycling 1 to 2 rows does not always seem to work, which is why vectorise_log_entry() was added + data.frame( + datetime = vectorise_log_entry(Sys.time(), length(rows)), + index = rows, + ab_user = 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)), + ab = vectorise_log_entry(ab_current, length(rows)), + mo = vectorise_log_entry(mo_current, length(rows)), + method = vectorise_log_entry(method_coerced, length(rows)), + input = vectorise_log_entry(as.double(values), 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)), + guideline = vectorise_log_entry(guideline_coerced, length(rows)), + ref_table = vectorise_log_entry(NA_character_, length(rows)), + uti = vectorise_log_entry(uti_current, length(rows)), + breakpoint_S_R = vectorise_log_entry(NA_character_, length(rows)), + stringsAsFactors = FALSE + ) + ) + next + } + # set the host index according to most available breakpoints (see R/zzz.R where this is set in the pkg environment) breakpoints_current$host_index <- match(breakpoints_current$host, c("human", "ECOFF", AMR_env$host_preferred_order)) @@ -1154,6 +1188,7 @@ as_sir_method <- function(method_short, # (this will e.g. prefer 'species' breakpoints over 'order' breakpoints) if (all(uti_current == FALSE, na.rm = TRUE)) { breakpoints_current <- breakpoints_current %pm>% + # `uti` is a column in the data set # this will put UTI = FALSE first, then UTI = NA, then UTI = TRUE pm_mutate(uti_index = ifelse(is.na(uti) & uti == FALSE, 1, ifelse(is.na(uti), 2, @@ -1167,11 +1202,6 @@ as_sir_method <- function(method_short, pm_arrange(host_index, rank_index) } - if (NROW(breakpoints_current) == 0) { - # no note about missing breakpoints - it's already in the header before the interpretation starts - next - } - # veterinary host check host_current <- unique(df_unique[i, "host", drop = TRUE])[1] breakpoints_current$host_match <- breakpoints_current$host == host_current @@ -1181,12 +1211,12 @@ as_sir_method <- function(method_short, subset(host_match == TRUE) } else { # no breakpoint found for this host, so sort on mostly available guidelines - notes <- c(notes, paste0("No breakpoints available for ", font_bold(host_current), " for ", ab_formatted, " in ", mo_formatted, " - using ", font_bold(breakpoints_current$host[1]), " instead.")) - # msgs <- c(msgs, paste0("No breakpoints available for ", font_bold(host_current), " for ", ab_formatted, " in ", mo_formatted, " - using ", font_bold(breakpoints_current$host[1]), " instead.")) + 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.")) + rise_notes <- TRUE } } - # throw notes for different body sites + # throw messages for different body sites site <- breakpoints_current[1L, "site", drop = FALSE] # this is the one we'll take if (is.na(site)) { site <- paste0("an unspecified body site") @@ -1195,21 +1225,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)) { # only UTI breakpoints available - warning_("in `as.sir()`: interpretation of ", font_bold(ab_formatted), " is only available for (uncomplicated) urinary tract infections (UTI) for some microorganisms, thus assuming `uti = TRUE`. See `?as.sir`.") - rise_warning <- TRUE + 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`.")) } 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 - msgs <- c(msgs, 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 <- 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`.")) breakpoints_current <- breakpoints_current %pm>% 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)) { # breakpoints for multiple body sites available - msgs <- c(msgs, paste0("Multiple breakpoints available for ", ab_formatted, " in ", mo_formatted, " - assuming ", site, ".")) + notes <- c(notes, paste0("Multiple breakpoints available for ", font_bold(ab_formatted), " in ", mo_formatted, " - assuming ", site, ".")) } # 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) { - msgs <- c(msgs, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, "")) + notes <- c(notes, paste0("Intrinsic resistance applied for ", ab_formatted, " in ", mo_formatted, "")) new_sir <- rep(as.sir("R"), length(rows)) } else if (nrow(breakpoints_current) == 0) { # no rules available @@ -1219,10 +1248,10 @@ as_sir_method <- function(method_short, 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)) { - msgs <- c(msgs, "Some PK/PD breakpoints were applied - use `include_PKPD = FALSE` to prevent this") + notes <- c(notes, "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)) { - msgs <- c(msgs, "Some screening breakpoints were applied - use `include_screening = FALSE` to prevent this") + notes <- c(notes, "Some screening breakpoints were applied - use `include_screening = FALSE` to prevent this") } if (method == "mic") { @@ -1252,23 +1281,23 @@ as_sir_method <- function(method_short, # write to verbose output AMR_env$sir_interpretation_history <- rbind_AMR( AMR_env$sir_interpretation_history, - # recycling 1 to 2 rows does not seem to work, which is why rep() was added + # recycling 1 to 2 rows does not always seem to work, which is why vectorise_log_entry() was added data.frame( - datetime = rep(Sys.time(), length(rows)), + datetime = vectorise_log_entry(Sys.time(), length(rows)), index = rows, - ab_user = rep(ab.bak[match(ab_current, df$ab)][1], length(rows)), - mo_user = rep(mo.bak[match(mo_current, df$mo)][1], length(rows)), - ab = rep(ab_current, length(rows)), - mo = rep(breakpoints_current[, "mo", drop = TRUE], length(rows)), - method = rep(method_coerced, length(rows)), - input = as.double(values), - outcome = as.sir(new_sir), - host = rep(breakpoints_current[, "host", drop = TRUE], length(rows)), - notes = rep(paste0(notes, collapse = " "), length(rows)), - guideline = rep(guideline_coerced, length(rows)), - ref_table = rep(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)), - uti = rep(breakpoints_current[, "uti", drop = TRUE], length(rows)), - breakpoint_S_R = rep(paste0(breakpoints_current[, "breakpoint_S", drop = TRUE], "-", breakpoints_current[, "breakpoint_R", drop = TRUE]), length(rows)), + ab_user = 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)), + ab = vectorise_log_entry(breakpoints_current[, "ab", drop = TRUE], length(rows)), + mo = vectorise_log_entry(breakpoints_current[, "mo", drop = TRUE], length(rows)), + method = vectorise_log_entry(method_coerced, length(rows)), + input = vectorise_log_entry(as.double(values), 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), collapse = "\n"), length(rows)), + guideline = vectorise_log_entry(guideline_coerced, 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)), + breakpoint_S_R = vectorise_log_entry(paste0(breakpoints_current[, "breakpoint_S", drop = TRUE], "-", breakpoints_current[, "breakpoint_R", drop = TRUE]), length(rows)), stringsAsFactors = FALSE ) ) @@ -1278,7 +1307,7 @@ as_sir_method <- function(method_short, } close(p) - + # printing messages if (has_progress_bar == TRUE) { # the progress bar has overwritten the intro text, so: @@ -1286,16 +1315,20 @@ as_sir_method <- function(method_short, } if (isTRUE(rise_warning)) { message(font_rose_bg(" WARNING ")) - } else if (length(notes) > 0) { - message(font_yellow_bg(" NOTES ")) - } else if (length(msgs) == 0) { - message(font_green_bg(" OK ")) + } else if (isTRUE(rise_notes)) { + message(font_yellow_bg(paste0(" NOTE", ifelse(length(notes) > 1, "S ", " ")))) + if (length(notes) > 1) { + plural <- c("were", "s", "them") + } else { + plural <- c("was", "", "it") + } + 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 { - msg_note(sort(msgs)) + message(font_green_bg(" OK ")) } - + load_mo_uncertainties(metadata_mo) - + df$result } @@ -1306,24 +1339,33 @@ sir_interpretation_history <- function(clean = FALSE) { meet_criteria(clean, allow_class = "logical", has_length = 1) out <- AMR_env$sir_interpretation_history - if (NROW(out) == 0) { - message_("No results to return. Run `as.sir()` on MIC values or disk diffusion zones first to see a 'logbook' data set here.") - return(invisible(NULL)) - } out$outcome <- as.sir(out$outcome) + if (NROW(out) > 0) { + # sort descending on time + out <- out[order(out$datetime, out$index, decreasing = TRUE), , drop = FALSE] + } + # keep stored for next use if (isTRUE(clean)) { AMR_env$sir_interpretation_history <- AMR_env$sir_interpretation_history[0, , drop = FALSE] } - # sort descending on time - out <- out[order(out$datetime, decreasing = TRUE), , drop = FALSE] - if (pkg_is_available("tibble")) { - import_fn("as_tibble", "tibble")(out) - } else { - out + out <- import_fn("as_tibble", "tibble")(out) } + structure(out, class = c("sir_log", class(out))) +} + +#' @method print sir_log +#' @export +#' @noRd +print.sir_log <- function(x, ...) { + if (NROW(x) == 0) { + message_("No results to print. Run `as.sir()` on MIC values or disk diffusion zones first to print a 'logbook' data set here.") + return(invisible(NULL)) + } + class(x) <- class(x)[class(x) != "sir_log"] + print(x, ...) } # will be exported using s3_register() in R/zzz.R diff --git a/inst/tinytest/test-custom_microorganisms.R b/inst/tinytest/test-custom_microorganisms.R index 13a5702d..f7c45b77 100644 --- a/inst/tinytest/test-custom_microorganisms.R +++ b/inst/tinytest/test-custom_microorganisms.R @@ -28,7 +28,7 @@ # ==================================================================== # expect_identical(as.mo("Enterobacter asburiae/cloacae"), - as.mo("Enterobacter cloacae cloacae")) + as.mo("Enterobacter asburiae")) suppressMessages( add_custom_microorganisms( @@ -44,3 +44,5 @@ expect_identical(mo_gramstain("ENT_ASB_CLO", language = NULL), "Gram-negative") expect_identical(paste("B", AMR:::abbreviate_mo("Klebsiella"), AMR:::abbreviate_mo("pneumoniae", 4), sep = "_"), as.character(as.mo("Klebsiella pneumoniae"))) +expect_identical(paste("B", AMR:::abbreviate_mo("Aerococcus"), AMR:::abbreviate_mo("urinae", 4), sep = "_"), + as.character(as.mo("Aerococcus urinae"))) diff --git a/man/antibiotic_class_selectors.Rd b/man/antibiotic_class_selectors.Rd index 93ba5fa3..4c33101c 100644 --- a/man/antibiotic_class_selectors.Rd +++ b/man/antibiotic_class_selectors.Rd @@ -191,7 +191,7 @@ example_isolates # dplyr ------------------------------------------------------------------- if (require("dplyr")) { -. example_isolates \%>\% select(carbapenems()) + example_isolates \%>\% select(carbapenems()) } if (require("dplyr")) { @@ -201,7 +201,7 @@ if (require("dplyr")) { if (require("dplyr")) { # select only antibiotic columns with DDDs for oral treatment -. example_isolates \%>\% select(administrable_per_os()) + example_isolates \%>\% select(administrable_per_os()) } if (require("dplyr")) {