Check tail of nonparametric PMFs (#752)

* Add function to check pmf tail

* Add test

* Apply tail check to pmf

* Add NEWS item

* Improve documentation

* Update NEWS.md

Co-authored-by: Sam Abbott <[email protected]>

---------

Co-authored-by: Sam Abbott <[email protected]>

NEWS.md

@@ -11,6 +11,7 @@
 - The interface for defining delay distributions has been generalised to also cater for continuous distributions
 - When defining probability distributions these can now be truncated using the `tolerance` argument
 - Ornstein-Uhlenbeck and 5 / 2 Matérn kernels have been added. By @sbfnk in # and reviewed by @.
+- A warning is now thrown if nonparametric PMFs passed to delay options have consecutive tail values that are below a certain low threshold as these lead to loss in speed with little gain in accuracy. By @jamesmbaazam in #752 and reviewed by @seabbs.
 
 ## Bug fixes
 

R/checks.R

@@ -107,3 +107,27 @@ check_stan_delay <- function(dist) {
     )
   }
 }
+
+#' Check that PMF tail is not sparse
+#'
+#' @description Checks if the tail of a PMF vector has more than `span`
+#' consecutive values smaller than `tol` and throws a warning if so.
+#' @param pmf A probability mass function vector
+#' @param span The number of consecutive indices in the tail to check
+#' @param tol The value which to consider the tail as sparse
+#'
+#' @return Called for its side effects.
+#' @keywords internal
+check_sparse_pmf_tail <- function(pmf, span = 5, tol = 1e-6) {
+  if (all(pmf[(length(pmf) - span + 1):length(pmf)] < tol)) {
+    warning(
+      sprintf(
+        "The PMF tail has %s consecutive values smaller than %s.",
+        span, tol
+      ),
+      " This will drastically increase run time with very small increases ",
+      "in accuracy. Consider increasing the tail values of the PMF.",
+      call. = FALSE
+    )
+  }
+}

R/dist_spec.R

@@ -903,6 +903,7 @@ Fixed <- function(value, ...) {
 #' NonParametric(c(0.1, 0.3, 0.2, 0.4))
 #' NonParametric(c(0.1, 0.3, 0.2, 0.1, 0.1))
 NonParametric <- function(pmf, ...) {
+  check_sparse_pmf_tail(pmf)
   params <- list(pmf = pmf / sum(pmf))
   return(new_dist_spec(params, "nonparametric"))
 }

tests/testthat/test-checks.R

@@ -141,3 +141,8 @@ test_that("check_reports_valid errors for bad 'secondary' specifications", {
   # Run tests
   test_col_specs(secondary_col_dt, model = "estimate_secondary")
 })
+
+test_that("check_sparse_pmf_tail throws a warning as expected", {
+  pmf <- c(0.4, 0.30, 0.20, 0.05,  0.049995, 4.5e-06, rep(1e-7, 5))
+  expect_warning(check_sparse_pmf_tail(pmf), "consecutive values smaller than")
+})