Merge pull request #9 from seroanalytics/i8

I8 return errors as warnings
seroanalytics · Sep 17, 2024 · 58a663b · 58a663b
2 parents bba41d9 + 3758726
commit 58a663b
Show file tree

Hide file tree

Showing 4 changed files with 50 additions and 19 deletions.
diff --git a/R/api.R b/R/api.R
@@ -139,7 +139,7 @@ target_get_trace <- function(name,
                                        xtype = xtype,
                                        method = method,
                                        span = span,
-                                       k = k))
+                                       k = k), stop_on_error = FALSE)
       list(name = jsonlite::unbox(nms[[i]]),
            model = model$output,
            raw = data_out(groups[[i]], xcol),

diff --git a/R/utils.R b/R/utils.R
@@ -1,16 +1,27 @@
-with_warnings <- function(expr) {
+with_warnings <- function(expr, stop_on_error = TRUE) {
   my_warnings <- NULL
 
   w_handler <- function(w) {
-    my_warnings <<- c(my_warnings, jsonlite::unbox(conditionMessage(w)))
+    my_warnings <<- unique(c(my_warnings, jsonlite::unbox(conditionMessage(w))))
     invokeRestart("muffleWarning")
   }
 
-  e_handler <- function(e) {
+  e_handler_warn <- function(e) {
+    my_warnings <<- unique(c(my_warnings, jsonlite::unbox(conditionMessage(e))))
+    invokeRestart("muffleStop")
+  }
+
+  e_handler_stop <- function(e) {
     porcelain::porcelain_stop(jsonlite::unbox(conditionMessage(e)))
   }
 
-  val <- withCallingHandlers(expr, warning = w_handler, error = e_handler)
+  if (stop_on_error) {
+    e_handler <- e_handler_stop
+  } else {
+    e_handler <- e_handler_warn
+  }
+  val <- withCallingHandlers(withRestarts(expr, muffleStop = function() NULL),
+                             warning = w_handler, error = e_handler)
   list(output = val,
        warnings = my_warnings)
 }

diff --git a/inst/schema/DataSeries.schema.json b/inst/schema/DataSeries.schema.json
@@ -8,12 +8,12 @@
         "type": "string"
       },
       "model": {
-        "type": "object",
+        "type": ["object", "null"],
         "properties": {
           "x": {
             "type": "array",
             "items": {
-              "type": ["number", "string"]
+              "type": ["number", "string", "null"]
             }
           },
           "y": {
@@ -32,7 +32,7 @@
           "x": {
             "type": "array",
             "items": {
-              "type": ["number", "string"]
+              "type": ["number", "string", "null"]
             }
           },
           "y": {
@@ -42,17 +42,17 @@
             }
           }
         },
-        "warnings": {
-          "type": "array",
-          "items": {
-            "type": "string"
-          }
-        },
         "required": ["x", "y"],
         "additionalProperties": false
+      },
+      "warnings": {
+        "type": ["array", "null"],
+        "items": {
+          "type": "string"
+        }
       }
     },
-    "required": ["model", "raw", "warnings"],
-    "additionalProperties": true
+    "required": ["name", "model", "raw", "warnings"],
+    "additionalProperties": false
   }
 }
diff --git a/tests/testthat/test-read.R b/tests/testthat/test-read.R
@@ -314,9 +314,29 @@ test_that("can get dataset with dates", {
   full_range_dates <- c("2023-01-15", "2023-01-16", "2023-01-17", "2023-01-18", "2023-01-19", "2023-01-20")
   expect_equal(unlist(data$model[1, "x"]), full_range_dates)
   parsed <- lubridate::parse_date_time(dates, c("dmy", "mdy", "ymd", "ydm"))
-  suppressWarnings({m <- stats::loess(value ~ as.numeric(day), data = data.frame(day = parsed,
-                                                               value = 1:5))})
+  suppressWarnings({ m <- stats::loess(value ~ as.numeric(day), data = data.frame(day = parsed,
+                                                                                  value = 1:5)) })
   parsed_full_range <- lubridate::parse_date_time(full_range_dates, c("dmy", "mdy", "ymd", "ydm"))
   expected <- stats::predict(m, parsed_full_range)
   expect_equal(unlist(data$model[1, "y"]), expected)
-})
+})
+
+test_that("errors for disaggregated traces are returned as warnings", {
+  dat <- data.frame(biomarker = "ab",
+                    value = 1:10,
+                    day = 1:10,
+                    sex = c(rep("M", 9), "F"))
+  router <- build_routes(cookie_key)
+  local_add_dataset(dat, name = "testdataset")
+  res <- router$call(make_req("GET",
+                              "/dataset/testdataset/trace/ab/",
+                              qs = "method=gam&k=10&disaggregate=sex",
+                              HTTP_COOKIE = cookie))
+  expect_equal(res$status, 200)
+  body <- jsonlite::fromJSON(res$body)
+  data <- body$data
+  expect_equal(data$warnings,
+               list("Not enough (non-NA) data to do anything meaningful",
+                    "day has insufficient unique values to support 10 knots: reduce k."))
+  expect_true(all(is.na(data$model)))
+})