diff --git a/R/api.R b/R/api.R index 0f2ccf6..9449171 100644 --- 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 index d09e7c9..136b580 100644 --- 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 index bc642f4..6fcf868 100644 --- 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 index 6dc032d..1638003 100644 --- 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) -}) \ No newline at end of file +}) + +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))) +})