(v2.1.1.9052) unit test fix

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)

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)

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!)*
 

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")) {

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_fn(AMR_env$bullet_icon), " ", font_fn(messages, collapse = NULL), collapse = "\n")
-      paste0("  ", font_black(AMR_env$bullet_icon), " ", font_black(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."))
+        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."))
-        # 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."))
+        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`.")
+      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`."))
-      rise_warning <- 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)),
+          ab_user = vectorise_log_entry(ab.bak[match(ab_current, df$ab)][1], length(rows)),
-          mo_user = rep(mo.bak[match(mo_current, df$mo)][1], length(rows)),
+          mo_user = vectorise_log_entry(mo.bak[match(mo_current, df$mo)][1], length(rows)),
-          ab = rep(ab_current, length(rows)),
+          ab = vectorise_log_entry(breakpoints_current[, "ab", drop = TRUE], length(rows)),
-          mo = rep(breakpoints_current[, "mo", drop = TRUE], length(rows)),
+          mo = vectorise_log_entry(breakpoints_current[, "mo", drop = TRUE], length(rows)),
-          method = rep(method_coerced, length(rows)),
+          method = vectorise_log_entry(method_coerced, length(rows)),
-          input = as.double(values),
+          input = vectorise_log_entry(as.double(values), length(rows)),
-          outcome = as.sir(new_sir),
+          outcome = vectorise_log_entry(as.sir(new_sir), length(rows)),
-          host = rep(breakpoints_current[, "host", drop = TRUE], length(rows)),
+          host = vectorise_log_entry(breakpoints_current[, "host", drop = TRUE], length(rows)),
-          notes = rep(paste0(notes, collapse = " "), length(rows)),
+          notes = vectorise_log_entry(paste0(font_stripstyle(notes), collapse = "\n"), length(rows)),
-          guideline = rep(guideline_coerced, length(rows)),
+          guideline = vectorise_log_entry(guideline_coerced, length(rows)),
-          ref_table = rep(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)),
+          ref_table = vectorise_log_entry(breakpoints_current[, "ref_tbl", drop = TRUE], length(rows)),
-          uti = rep(breakpoints_current[, "uti", drop = TRUE], length(rows)),
+          uti = vectorise_log_entry(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)),
+          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) {
+  } else if (isTRUE(rise_notes)) {
-    message(font_yellow_bg(" NOTES "))
+    message(font_yellow_bg(paste0(" NOTE", ifelse(length(notes) > 1, "S ", " "))))
-  } else if (length(msgs) == 0) {
+    if (length(notes) > 1) {
-    message(font_green_bg(" OK "))
+      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)
+    out <- import_fn("as_tibble", "tibble")(out)
-  } else {
-    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

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")))

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")) {