new verbose

NEWS.md

@@ -11,6 +11,8 @@
   * Better error handling when rules cannot be applied (i.e. new values could not be inserted)
   * The amount of affected values will now only be measured once per row/column combination
   * Data set `septic_patients` now reflects these changes
+* Empty values as input for `as.mo` will be processed faster
+* Fewer than 3 characters as input for `as.mo` will return NA
 * Added parameter `combine_IR` (TRUE/FALSE) to functions `portion_df` and `count_df`, to indicate that all values of I and R must be merged into one, so the output only consists of S vs. IR (susceptible vs. non-susceptible)
 * Fix for `portion_*(..., as_percent = TRUE)` when minimal amount of isolates would not be met
 * Using `portion_*` functions now throws a warning when total available isolate is below parameter `minimum`

R/eucast.R

@@ -25,7 +25,7 @@
 #' @param rules a character vector that specifies which rules should be applied - one or more of \code{c("breakpoints", "expert", "other", "all")}
 #' @param amcl,amik,amox,ampi,azit,azlo,aztr,cefa,cfep,cfot,cfox,cfra,cfta,cftr,cfur,chlo,cipr,clar,clin,clox,coli,czol,dapt,doxy,erta,eryt,fosf,fusi,gent,imip,kana,levo,linc,line,mero,mezl,mino,moxi,nali,neom,neti,nitr,norf,novo,oflo,oxac,peni,pita,poly,pris,qida,rifa,roxi,siso,teic,tetr,tica,tige,tobr,trim,trsu,vanc column name of an antibiotic, see Details
 #' @param col_bactid Deprecated. Use \code{col_mo} instead.
-#' @param verbose a logical to indicate whether extensive info should be printed to the console about which rows and columns are effected with their old and new values
+#' @param verbose a logical to indicate whether extensive info should be returned as a \code{data.frame} with info about which rows and columns are effected
 #' @param ... parameters that are passed on to \code{EUCAST_rules}
 #' @details To define antibiotics column names, input a text or use \code{NA} to skip a column (e.g. \code{tica = NA}). Non-existing columns will anyway be skipped with a warning. See the Antibiotics section for an explanation of the abbreviations.
 #' @section Antibiotics:
@@ -97,7 +97,7 @@
 #' @export
 #' @importFrom dplyr %>% select pull mutate_at vars
 #' @importFrom crayon bold bgGreen bgYellow bgRed black green blue
-#' @return Value of parameter \code{tbl}, possibly with edited values of antibiotics.
+#' @return The input of \code{tbl}, possibly with edited values of antibiotics. Or, if \code{verbose = TRUE}, a \code{data.frame} with verbose info.
 #' @source
 #'   \itemize{
 #'     \item{
@@ -325,7 +325,14 @@ EUCAST_rules <- function(tbl,
 
   amount_changed <- 0
   amount_affected_rows <- integer(0)
-  verbose_info <- ""
+  verbose_info <- data.frame(rule_type = character(0),
+                             rule_set = character(0),
+                             force_to = character(0),
+                             found = integer(0),
+                             changed = integer(0),
+                             target_columns = integer(0),
+                             target_rows = integer(0),
+                             stringsAsFactors = FALSE)
 
   # helper function for editing the table
   edit_rsi <- function(to, rule, rows, cols) {
@@ -354,13 +361,15 @@ EUCAST_rules <- function(tbl,
       changed_results <<- changed_results + sum(before != after, na.rm = TRUE) # will be reset at start of every rule
 
       if (verbose == TRUE) {
-        verbose_info <<- paste0(verbose_info,
+        verbose_new <- data.frame(rule_type = rule[1],
-                                "\n\nRule Type: ", rule[1],
+                                  rule_set = rule[2],
-                                "\nRule Set:  ", rule[2],
+                                  force_to = to,
-                                "\nEffect:    Set to '", to, "' (",
+                                  found = length(before),
-                                length(before), " found, ", sum(before != after, na.rm = TRUE), " changed): ",
+                                  changed = sum(before != after, na.rm = TRUE),
-                                "cols '", paste(cols, collapse = "', '"),
+                                  stringsAsFactors = FALSE)
-                                "' of rows ", paste(rows, collapse = ", "))
+        verbose_new$target_columns <- list(unname(cols))
+        verbose_new$target_rows <- list(unname(rows))
+        verbose_info <<- rbind(verbose_info, verbose_new)
       }
     }
   }
@@ -1649,8 +1658,8 @@ EUCAST_rules <- function(tbl,
              amount_changed %>% format(big.mark = ","), 'test results.\n\n'))
   }
 
-  if (verbose_info != "") {
+  if (verbose == TRUE) {
-    message("Verbose information:", verbose_info)
+    return(verbose_info)
   }
 
   tbl_original

R/mo.R

@@ -173,6 +173,8 @@ exec_as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain =
   x_input <- x
   # only check the uniques, which is way faster
   x <- unique(x)
+  # remove empty values (to later fill them in again)
+  x <- x[!is.na(x) & !is.null(x) & !identical(x, "")]
 
   MOs <- NULL # will be set later, if needed
   MOs_mostprevalent <- NULL # will be set later, if needed
@@ -263,9 +265,15 @@ exec_as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain =
     # cat(paste0('x_trimmed_species  "', x_trimmed_species, '"\n'))
 
     for (i in 1:length(x)) {
-      if (identical(x_trimmed[i], "") | is.na(x_trimmed[i])) {
+      if (identical(x_trimmed[i], "")) {
         # empty values
-        x[i] <- NA
+        x[i] <- NA_character_
+        next
+      }
+      if (nchar(x_trimmed[i]) < 3) {
+        # fewer than 3 chars, add as failure
+        x[i] <- NA_character_
+        failures <- c(failures, x_backup[i])
         next
       }
 
@@ -586,7 +594,7 @@ exec_as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain =
 
   failures <- failures[!failures %in% c(NA, NULL, NaN)]
   if (length(failures) > 0) {
-    warning("These ", length(failures) , " values could not be coerced (try again with allow_uncertain = TRUE): ",
+    warning("These ", length(failures) , " values could not be coerced: ",
             paste('"', unique(failures), '"', sep = "", collapse = ', '),
             ".",
             call. = FALSE)
@@ -653,8 +661,12 @@ exec_as.mo <- function(x, Becker = FALSE, Lancefield = FALSE, allow_uncertain =
     x[x == MOs[mo == 'B_STRPTC_SAL', ..property][[1]][1L]] <- MOs[mo == 'B_STRPTC_GRK', ..property][[1]][1L]
   }
 
+  x_input_unique <- unique(x_input)
+  # fill in empty values again
+  x[is.na(x_input_unique) | is.null(x_input_unique) | identical(x_input_unique, "")] <- NA
+
   # left join the found results to the original input values (x_input)
-  df_found <- data.frame(input = as.character(unique(x_input)),
+  df_found <- data.frame(input = as.character(x_input_unique),
                          found = x,
                          stringsAsFactors = FALSE)
   df_input <- data.frame(input = as.character(x_input),

man/EUCAST.Rd

@@ -56,12 +56,12 @@ interpretive_reading(...)
 
 \item{col_bactid}{Deprecated. Use \code{col_mo} instead.}
 
-\item{verbose}{a logical to indicate whether extensive info should be printed to the console about which rows and columns are effected with their old and new values}
+\item{verbose}{a logical to indicate whether extensive info should be returned as a \code{data.frame} with info about which rows and columns are effected}
 
 \item{...}{parameters that are passed on to \code{EUCAST_rules}}
 }
 \value{
-Value of parameter \code{tbl}, possibly with edited values of antibiotics.
+The input of \code{tbl}, possibly with edited values of antibiotics. Or, if \code{verbose = TRUE}, a \code{data.frame} with verbose info.
 }
 \description{
 Apply susceptibility rules as defined by the European Committee on Antimicrobial Susceptibility Testing (EUCAST, \url{http://eucast.org}), see \emph{Source}. This includes (1) expert rules, (2) intrinsic resistance and (3) inferred resistance as defined in their breakpoint tables.

tests/testthat/test-eucast.R

@@ -73,6 +73,6 @@ test_that("EUCAST rules work", {
       , info = FALSE))$amox,
     "S")
 
-  expect_message(suppressWarnings(EUCAST_rules(septic_patients, verbose = TRUE)))
+  expect_output(suppressWarnings(EUCAST_rules(septic_patients, verbose = TRUE)))
 
 })