add some warm and fuzzies

Author: philchalmers

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: SimDesign
 Title: Structure for Organizing Monte Carlo Simulation Designs
-Version: 2.6.4
+Version: 2.6.5
 Authors@R: c(person("Phil", "Chalmers", email = "[email protected]", role = c("aut", "cre"),
                     comment = c(ORCID="0000-0001-5332-2810")),
              person("Matthew", "Sigal", role = c("ctb")),

NEWS.md

@@ -2,6 +2,13 @@
 
 ## Changes in SimDesign 2.7
 
+- `SimExtract()` gains a `fuzzy` argument to allow fuzzy matching of error and warning messages.
+  This helps collapse very similar errors messages in the recorded tables,
+  thereby improving how to discern any pattern in the errors/warnings (e.g., Messages such as 
+  *"ERROR: system is computationally singular: reciprocal condition number = 9.63735e-18"* and 
+  *"ERROR: system is computationally singular: reciprocal condition number = 6.74615e-17"* are 
+  effectively the same, and so their number of recorded occurrences should be collapsed)
+
 - Added `AnalyseIf()` function to allow specific analysis function to be included explicitly. Useful
   when the defined analysis function is not compatible with a row-condition in the `Design` object. 
   Only relevant when the `analyse` argument was defined as a named list of functions

R/SimExtract.R

@@ -18,6 +18,12 @@
 #'   Note that \code{'warning_seeds'} are not stored automatically in
 #'   simulations and require passing \code{store_warning_seeds = TRUE} to \code{\link{runSimulation}}.
 #'
+#' @param fuzzy logical; use fuzzy string matching to reduce effectively identical messages?
+#'   For example, when attempting to invert a matrix the error message
+#'   \emph{"System is computationally singular: reciprocal condition number = 1.92747e-17"} and
+#'   \emph{"System is computationally singular: reciprocal condition number = 2.15321e-16"} are
+#'   effectively the same, and likely should be reported in the same columns of the extracted output
+#'
 #' @export
 #'
 #' @references
@@ -70,7 +76,7 @@
 #'
 #'
 #' }
-SimExtract <- function(object, what){
+SimExtract <- function(object, what, fuzzy = TRUE){
     stopifnot(is(object, "SimDesign"))
     what <- tolower(what)
     pick <- attr(object, 'design_names')$design
@@ -82,25 +88,31 @@ SimExtract <- function(object, what){
     ret <- if(what == 'results'){
         extract_results(object)
     } else if(what == 'errors'){
-        cbind(Design, extract_errors(object))
+        cbind(Design, extract_errors(object, fuzzy=fuzzy))
     } else if(what == 'summarise'){
         extract_summarise(object)
     } else if(what == 'error_seeds'){
         extract_error_seeds(object)
     } else if(what == 'warnings'){
-        cbind(Design, extract_warnings(object))
+        cbind(Design, extract_warnings(object, fuzzy=fuzzy))
     } else if(what == 'warning_seeds'){
         extract_warning_seeds(object)
     } else stop('Input provided to \"what" is not supported')
     ret
 }
 
-extract_errors <- function(object){
-    attr(object, 'ERROR_msg')
+extract_errors <- function(object, fuzzy){
+    ret <- attr(object, 'ERROR_msg')
+    if(fuzzy)
+        ret <- fuzzy_reduce(ret)
+    ret
 }
 
-extract_warnings <- function(object){
-    attr(object, 'WARNING_msg')
+extract_warnings <- function(object, fuzzy){
+    ret <- attr(object, 'WARNING_msg')
+    if(fuzzy)
+        ret <- fuzzy_reduce(ret)
+    ret
 }
 
 extract_results <- function(object){
@@ -142,3 +154,19 @@ extract_summarise <- function(object){
     names(ret) <- nms
     ret
 }
+
+fuzzy_reduce <- function(df){
+    nms <- colnames(df)
+    matched <- logical(length(nms))
+    unames <- c()
+    udf <- df[,0]
+    for(i in 1L:length(nms)){
+        if(matched[i]) next
+        unames <- c(unames, nms[i])
+        udf <- cbind(udf, df[,i])
+        temp_matched <- agrepl(nms[i], nms)
+        udf[,ncol(udf)] <- rowSums(df[,temp_matched], na.rm = TRUE)
+        matched <- matched | temp_matched
+    }
+    udf
+}

man/SimExtract.Rd

@@ -644,5 +644,28 @@ test_that('SimDesign', {
     expect_true(all(c("analyse1.a1", "analyse2.a2") %in% names(res)))
     expect_true(is.na(res$analyse1.a1[2]))
 
+    # fuzzy strings
+    Analyse <- function(condition, dat, fixed_objects = NULL) {
+        C <- matrix(c(1,.2, 0, 1), 2)
+        if(sample(c(TRUE, FALSE), 1))
+            C[2,2] <- runif(1, -1e-8, 1e-8)
+        ret <- det(solve(C %*% t(C)))
+        ret
+    }
+
+    Summarise <- function(condition, results, fixed_objects = NULL) {
+        ret <- c(bias = NaN, RMSE = NaN)
+        ret
+    }
+
+    #-------------------------------------------------------------------
+
+    res <- runSimulation(replications=200, analyse=Analyse, summarise=Summarise,
+                         verbose=FALSE, seed = 1234)
+    out <- SimExtract(res, what = 'errors')
+    expect_true(ncol(out) == 2L)
+    out <- SimExtract(res, what = 'errors', fuzzy = FALSE)
+    expect_true(ncol(out) > 2L)
+
 })