Add more checks on delay_density, fixes #89

R/estimate_ascertainment.R

@@ -80,10 +80,14 @@ estimate_ascertainment <- function(data,
 
   # check delay_density and run over short sequence to test output
   stopifnot(
-    "`delay_density` must be a distribution density function with 1 argument
-    evaluating density at a vector of values and returning a numeric vector.
+    "`delay_density` must be a function evaluating distribution density at a
+    vector of values and returning a numeric vector of the same length.
     E.g. function(x) stats::dgamma(x = x, shape = 5, scale = 1)" =
-      checkmate::test_function(delay_density, null.ok = TRUE)
+      (checkmate::test_function(delay_density) &&
+        checkmate::test_numeric(delay_density(seq(10)),
+          lower = 0,
+          any.missing = FALSE, finite = TRUE, len = 10L
+        )) || is.null(delay_density)
   )
 
   # match argument for type

R/estimate_outcomes.R

@@ -53,10 +53,14 @@ estimate_outcomes <- function(data,
     any.missing = FALSE
   )
   stopifnot(
-    "`delay_density` must be a distribution density function with 1 argument
-    evaluating density at a vector of values and returning a numeric vector.
+    "`delay_density` must be a function evaluating distribution density at a
+    vector of values and returning a numeric vector of the same length.
     E.g. function(x) stats::dgamma(x = x, shape = 5, scale = 1)" =
-      checkmate::test_function(delay_density, null.ok = TRUE)
+      (checkmate::test_function(delay_density) &&
+        checkmate::test_numeric(delay_density(seq(10)),
+          lower = 0,
+          any.missing = FALSE, finite = TRUE, len = 10L
+        )) || is.null(delay_density)
   )
 
   pmf_vals <- delay_density(seq(from = 0, to = nrow(data) - 1L))

R/estimate_rolling.R

@@ -70,10 +70,14 @@ cfr_rolling <- function(data,
     # this solution works when df$date is `Date`
     # this may need more thought for dates that are integers, POSIXct,
     # or other units; consider the units package
-    "`delay_density` must be a distribution density function with 1 argument
-    evaluating density at a vector of values and returning a numeric vector.
+    "`delay_density` must be a function evaluating distribution density at a
+    vector of values and returning a numeric vector of the same length.
     E.g. function(x) stats::dgamma(x = x, shape = 5, scale = 1)" =
-      checkmate::test_function(delay_density, null.ok = TRUE)
+      (checkmate::test_function(delay_density) &&
+        checkmate::test_numeric(delay_density(seq(10)),
+          lower = 0,
+          any.missing = FALSE, finite = TRUE, len = 10L
+        )) || is.null(delay_density)
   )
   checkmate::assert_count(poisson_threshold)
 

R/estimate_static.R

@@ -118,10 +118,14 @@ cfr_static <- function(data,
     # this solution works when df$date is `Date`
     # this may need more thought for dates that are integers, POSIXct,
     # or other units; consider the units package
-    "`delay_density` must be a distribution density function with 1 argument
-    evaluating density at a vector of values and returning a numeric vector.
+    "`delay_density` must be a function evaluating distribution density at a
+    vector of values and returning a numeric vector of the same length.
     E.g. function(x) stats::dgamma(x = x, shape = 5, scale = 1)" =
-      checkmate::test_function(delay_density, null.ok = TRUE)
+      (checkmate::test_function(delay_density) &&
+        checkmate::test_numeric(delay_density(seq(10)),
+          lower = 0,
+          any.missing = FALSE, finite = TRUE, len = 10L
+        )) || is.null(delay_density)
   )
   checkmate::assert_count(poisson_threshold)
 

R/estimate_time_varying.R

@@ -110,10 +110,14 @@ cfr_time_varying <- function(data,
   stopifnot(
     "`smoothing_window` must be an odd number greater than 0" =
       (smoothing_window %% 2 != 0),
-    "`delay_density` must be a distribution density function with 1 argument
-    evaluating density at a vector of values and returning a numeric vector.
+    "`delay_density` must be a function evaluating distribution density at a
+    vector of values and returning a numeric vector of the same length.
     E.g. function(x) stats::dgamma(x = x, shape = 5, scale = 1)" =
-      checkmate::test_function(delay_density, null.ok = TRUE)
+      (checkmate::test_function(delay_density) &&
+        checkmate::test_numeric(delay_density(seq(10)),
+          lower = 0,
+          any.missing = FALSE, finite = TRUE, len = 10L
+        )) || is.null(delay_density)
   )
 
   # prepare a new dataframe with smoothed columns if requested

tests/testthat/test-delay_density.R

@@ -0,0 +1,192 @@
+# Test for delay density passed to cfr_*()
+test_that("CFR functions work with delay_density as lambda", {
+  # Checks pass and cfr_static function works
+  ddens <- function(x) stats::dgamma(x, 5, 1)
+  expect_no_condition(
+    cfr_static(ebola1976, delay_density = ddens)
+  )
+  expect_no_condition(
+    cfr_rolling(ebola1976, delay_density = ddens)
+  )
+  expect_no_condition(
+    cfr_time_varying(ebola1976, delay_density = ddens)
+  )
+  expect_no_condition(
+    estimate_ascertainment(
+      ebola1976,
+      delay_density = ddens, severity_baseline = 0.7
+    )
+  )
+})
+
+test_that("CFR functions work with delay_density as <distcrete>", {
+  # Checks pass and cfr_static function works with disctcrete
+  ddens <- distcrete::distcrete("gamma", 1, shape = 2.4, scale = 3.33)$d
+  expect_no_condition(
+    cfr_static(ebola1976, delay_density = ddens)
+  )
+  expect_no_condition(
+    cfr_rolling(ebola1976, delay_density = ddens)
+  )
+  expect_no_condition(
+    cfr_time_varying(ebola1976, delay_density = ddens)
+  )
+  expect_no_condition(
+    estimate_ascertainment(
+      ebola1976,
+      delay_density = ddens, severity_baseline = 0.7
+    )
+  )
+})
+
+# Test error cases
+msg <- "(`delay_density` must be)*(function evaluating distribution density)"
+
+test_that("Input checking on delay_density works", {
+  # Checks fail on badly specified delay_density fns
+
+  # Function returns NULL
+  ddens <- function(x) NULL
+  expect_error(
+    cfr_static(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_rolling(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_time_varying(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    estimate_ascertainment(
+      ebola1976,
+      delay_density = ddens, severity_baseline = 0.7
+    ),
+    regexp = msg
+  )
+
+  # Function returns non-numeric
+  # NOTE the use of seq_along - there are no checks that the fn
+  # is statistically correct or a valid density function
+  ddens <- function(x) as.character(seq_along(x))
+  expect_error(
+    cfr_static(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_rolling(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_time_varying(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    estimate_ascertainment(
+      ebola1976,
+      delay_density = ddens, severity_baseline = 0.7
+    ),
+    regexp = msg
+  )
+
+  # Function returns Inf
+  ddens <- function(x) rep(Inf, times = length(x))
+  expect_error(
+    cfr_static(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_rolling(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_time_varying(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    estimate_ascertainment(
+      ebola1976,
+      delay_density = ddens, severity_baseline = 0.7
+    ),
+    regexp = msg
+  )
+
+  # Function returns negative values
+  # NOTE the use of seq_along - there are no checks that the fn
+  # is statistically correct or a valid density function
+  ddens <- function(x) -seq_along(x)
+  expect_error(
+    cfr_static(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_rolling(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_time_varying(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    estimate_ascertainment(
+      ebola1976,
+      delay_density = ddens, severity_baseline = 0.7
+    ),
+    regexp = msg
+  )
+
+  # Function returns NAs
+  # NOTE the use of seq_along - there are no checks that the fn
+  # is statistically correct or a valid density function
+  ddens <- function(x) {
+    y <- seq_along(x)
+    y[1] <- NA_real_
+  }
+  expect_error(
+    cfr_static(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_rolling(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_time_varying(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    estimate_ascertainment(
+      ebola1976,
+      delay_density = ddens, severity_baseline = 0.7
+    ),
+    regexp = msg
+  )
+
+  # Function returns wrong length
+  # NOTE the use of seq_along - there are no checks that the fn
+  # is statistically correct or a valid density function
+  ddens <- function(x) {
+    head(seq_along(x))
+  }
+  expect_error(
+    cfr_static(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_rolling(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    cfr_time_varying(ebola1976, delay_density = ddens),
+    regexp = msg
+  )
+  expect_error(
+    estimate_ascertainment(
+      ebola1976,
+      delay_density = ddens, severity_baseline = 0.7
+    ),
+    regexp = msg
+  )
+})