Reject invalid numeric PMF/prior vectors

NEWS.md

@@ -54,6 +54,10 @@ below are changes relative to that code as it stood in EpiNow2 1.9.0.
 
 ## Bug fixes
 
+- `NonParametric()` and `Dirichlet(prior = )` now reject a numeric PMF or weight
+  vector that contains negative or non-finite values, or is all zero, with an
+  informative error, instead of silently producing an invalid distribution.
+  Un-normalised non-negative weights are still accepted and normalised.
 - A distribution parameter given as a certain distribution (standard deviation
   0, e.g. `Normal(x, 0)`, which collapses to `Fixed(x)`) is now resolved to its
   point value at construction, so it behaves exactly like passing the number.

R/check.R

@@ -26,6 +26,39 @@ check_sparse_pmf_tail <- function(pmf, span = 5, tol = 1e-6) {
   }
 }
 
+#' Check that a numeric PMF or weight vector is valid
+#'
+#' @description
+#' A numeric probability mass function or weight vector must be numeric, contain
+#' only finite, non-negative values, and not be all zero, so that it can be
+#' normalised to sum to one. Raises an informative error otherwise.
+#' Un-normalised vectors are allowed: they are treated as weights and normalised
+#' by the caller.
+#'
+#' @param x A numeric vector.
+#' @param arg The name of the calling argument, used in the error messages.
+#' @return `x`, invisibly, if it is valid; otherwise an error is raised.
+#' @importFrom cli cli_abort
+#' @keywords internal
+check_pmf_values <- function(x, arg = "pmf") {
+  if (!is.numeric(x)) {
+    cli_abort("{.arg {arg}} must be a numeric vector.")
+  }
+  if (any(!is.finite(x))) {
+    cli_abort("{.arg {arg}} must contain only finite, non-missing values.")
+  }
+  if (any(x < 0)) {
+    cli_abort("{.arg {arg}} must not contain negative values.")
+  }
+  if (all(x == 0)) {
+    cli_abort(
+      "{.arg {arg}} must not be all zero; it cannot be normalised to a
+      probability mass function."
+    )
+  }
+  invisible(x)
+}
+
 #' Validate the structure of a `<dist_spec>`
 #'
 #' @description

R/dirichlet.R

@@ -48,6 +48,7 @@ Dirichlet <- function(alpha, prior, concentration, ...) {
     if (is(prior, "dist_spec")) {
       pmf <- get_pmf(discretise(prior))
     } else {
+      check_pmf_values(prior, "prior")
       pmf <- prior / sum(prior)
     }
     alpha <- concentration * pmf

R/nonparametric.R

@@ -27,6 +27,7 @@
 #' NonParametric(pmf = Dirichlet(c(1, 1, 1, 1)))
 NonParametric <- function(pmf, ...) {
   if (is.numeric(pmf)) {
+    check_pmf_values(pmf, "pmf")
     check_sparse_pmf_tail(pmf)
     pmf <- pmf / sum(pmf)
   }

tests/testthat/test-dirichlet.R

@@ -17,6 +17,14 @@ test_that("Dirichlet works with prior and concentration", {
   expect_equal(mean(result), prior / sum(prior))
 })
 
+test_that("Dirichlet rejects a bad numeric prior", {
+  expect_error(Dirichlet(prior = c(0.5, -0.1, 0.6), concentration = 10),
+    "negative"
+  )
+  expect_error(Dirichlet(prior = c(0.5, NA, 0.5), concentration = 10), "finite")
+  expect_error(Dirichlet(prior = c(0, 0, 0), concentration = 10), "all zero")
+})
+
 test_that("Dirichlet works with dist_spec prior", {
   dist <- LogNormal(meanlog = 1, sdlog = 0.5, max = 10)
   result <- Dirichlet(prior = dist, concentration = 5)

tests/testthat/test-nonparametric.R

@@ -13,6 +13,16 @@ test_that("a nonparametric distribution normalises its PMF", {
   )
 })
 
+test_that("NonParametric accepts un-normalised weights but rejects bad values", {
+  ## un-normalised weights are treated as such and normalised
+  expect_equal(get_pmf(NonParametric(c(1, 2, 1))), c(0.25, 0.5, 0.25))
+  ## genuinely invalid input errors rather than silently normalising
+  expect_error(NonParametric(c(0.5, -0.1, 0.6)), "negative")
+  expect_error(NonParametric(c(0.5, NA, 0.5)), "finite")
+  expect_error(NonParametric(c(0.5, Inf, 0.5)), "finite")
+  expect_error(NonParametric(c(0, 0, 0)), "all zero")
+})
+
 test_that("NonParametric works with Dirichlet prior", {
   prior <- c(0.1, 0.3, 0.4, 0.2)
   conc <- 10