Add condition classes to all posterior warnings

NEWS.md

@@ -8,6 +8,8 @@
 result instead of about three.
 * `subset_draws()` returns its input without copying it when every variable is
 selected.
+* All warnings now have the class `posterior_warning` and a class for each
+cause. Calling packages can catch, count, or muffle each type of warning (#470).
 
 ### Bug Fixes
 

R/as_draws.R

@@ -118,7 +118,8 @@ check_variables_are_numeric <- function(
   if (any(non_numeric_cols)) {
     warning_no_call(
       to,
-      " does not support non-numeric variables (e.g., factors). Converting non-numeric variables to numeric."
+      " does not support non-numeric variables (e.g., factors). Converting non-numeric variables to numeric.",
+      class = "posterior_warning_non_numeric"
     )
   }
   if (convert) {

R/as_draws_df.R

@@ -235,7 +235,10 @@ dplyr_reconstruct.draws_df <- function(data, template) {
 # from the data frame
 drop_draws_class_if_metadata_removed <- function(x, warn = TRUE) {
   if (!all(reserved_df_variables() %in% names(x))) {
-    if (warn) warning_no_call("Dropping 'draws_df' class as required metadata was removed.")
+    if (warn) warning_no_call(
+      "Dropping 'draws_df' class as required metadata was removed.",
+      class = "posterior_warning_draws_df_dropped"
+    )
     class(x) <- setdiff(class(x), c("draws_df", "draws"))
   }
   x

R/convergence.R

@@ -792,7 +792,10 @@ fold_draws <- function(x) {
   # Safety check for negative values and with max ess equal to ess*log10(ess)
   tau_bound <- 1 / log10(ess)
   if (tau_hat < tau_bound) {
-    warning_no_call("The ESS has been capped to avoid unstable estimates.")
+    warning_no_call(
+      "The ESS has been capped to avoid unstable estimates.",
+      class = "posterior_warning_ess_capped"
+    )
     tau_hat <- tau_bound
   }
   ess <- ess / tau_hat

R/gpd.R

@@ -26,7 +26,7 @@ qgeneralized_pareto <- function(p, mu = 0, sigma = 1, k = 0, lower.tail = TRUE,
   # and replacing them here avoids a second warning from log() or log1p().
   invalid <- which(if (log.p) p > 0 else p < 0 | p > 1)
   if (length(invalid)) {
-    warning_no_call("NaNs produced")
+    warning_no_call("NaNs produced", class = "posterior_warning_nans_produced")
     p[invalid] <- NaN
   }
   if (log.p) {

R/merge_chains.R

@@ -89,7 +89,8 @@ warn_merge_chains <- function(type = c("match", "index")) {
       switch(type, ".",
         match = " due to chain information not matching.",
         index = " due to manually indexing draws."
-      )
+      ),
+      class = "posterior_warning_chains_dropped"
     )
   }
   invisible(NULL)

R/misc.R

@@ -211,8 +211,8 @@ stop_no_call <- function(...) {
   stop(..., call. = FALSE)
 }
 
-warning_no_call <- function(...) {
-  warning(..., call. = FALSE)
+warning_no_call <- function(..., class = NULL) {
+  rlang::warn(paste0(...), class = c(class, "posterior_warning"))
 }
 
 SW <- function(expr) {

R/nested_rhat.R

@@ -62,7 +62,8 @@ rhat_nested.rvar <- function(x, superchain_ids, ...) {
   # check that all chains are assigned a superchain
   if (length(superchain_ids) != nchains) {
     warning_no_call("Length of superchain_ids not equal to number of chains, ",
-                    "returning NA.")
+                    "returning NA.",
+                    class = "posterior_warning_superchain_ids_length")
     return(NA_real_)
   }
 
@@ -72,7 +73,8 @@ rhat_nested.rvar <- function(x, superchain_ids, ...) {
 
   if (nchains_per_superchain != min(superchain_id_table)) {
     warning_no_call("Number of chains per superchain is not the same for ",
-                    "each superchain, returning NA.")
+                    "each superchain, returning NA.",
+                    class = "posterior_warning_superchain_unequal")
     return(NA_real_)
   }
 

R/pareto_smooth.R

@@ -279,7 +279,10 @@ pareto_smooth.default <- function(x,
 
   # check for infinite or na values
   if (should_return_NA(x)) {
-    warning_no_call("Input contains infinite or NA values, is constant or has constant tail. Fitting of generalized Pareto distribution not performed.")
+    warning_no_call(
+      "Input contains infinite or NA values, is constant or has constant tail. Fitting of generalized Pareto distribution not performed.",
+      class = "posterior_warning_pareto_invalid_input"
+    )
     return(pareto_diags_na(x, return_k, extra_diags))
   }
 
@@ -301,18 +304,25 @@ pareto_smooth.default <- function(x,
   }
 
   if (is.na(ndraws_tail)) {
-    warning_no_call("Input contains infinite or NA values, is constant, or has constant tail. Fitting of generalized Pareto distribution not performed.")
+    warning_no_call(
+      "Input contains infinite or NA values, is constant, or has constant tail. Fitting of generalized Pareto distribution not performed.",
+      class = "posterior_warning_pareto_invalid_input"
+    )
     return(pareto_diags_na(x, return_k, extra_diags))
   }
 
   if (ndraws_tail < 5) {
     warning_no_call("Number of tail draws cannot be less than 5. ",
-            "Changing to ", 5, ".")
+            "Changing to ", 5, ".",
+            class = "posterior_warning_pareto_tail_too_short")
     ndraws_tail <- 5
   }
 
   if (ndraws_tail >= length(x)){
-    warning_no_call("Tail draws (", ndraws_tail, ") not strictly less than total draws (", length(x), "). Fitting of generalized Pareto distribution not performed.")
+    warning_no_call(
+      "Tail draws (", ndraws_tail, ") not strictly less than total draws (", length(x), "). Fitting of generalized Pareto distribution not performed.",
+      class = "posterior_warning_pareto_tail_exceeds_draws"
+    )
     return(pareto_diags_na(x, return_k, extra_diags))
   }
 
@@ -321,7 +331,8 @@ pareto_smooth.default <- function(x,
     if (ndraws_tail > ndraws / 2) {
       warning_no_call("Number of tail draws cannot be more than half ",
               "the total number of draws if both tails are fit, ",
-              "changing to ", ndraws / 2, ".")
+              "changing to ", ndraws / 2, ".",
+              class = "posterior_warning_pareto_tail_too_long")
       ndraws_tail <- ndraws / 2
     }
 
@@ -488,7 +499,8 @@ ps_tail <- function(x,
   if (ndraws_tail < 5) {
     warning_no_call(
       "Can't fit generalized Pareto distribution ",
-      "because ndraws_tail is less than 5."
+      "because ndraws_tail is less than 5.",
+      class = "posterior_warning_pareto_tail_not_fitted"
     )
     return(list(x = x, k = NA))
   }

R/pit.R

@@ -121,7 +121,8 @@ pit.draws_matrix <- function(x, y, weights = NULL, log = FALSE, ...) {
         max(pit),
         "\nRounding PIT > 1 to 1.",
         sep = ""
-      )
+      ),
+      class = "posterior_warning_pit_above_one"
     )
   }
 
@@ -445,7 +446,7 @@ validate_pit_weights <- function(weights, x, log) {
   cols <- lapply(seq_along(vars), function(var_idx) {
     tryCatch(
       validate_weights(weights[, var_idx], x[, var_idx], log),
-      posterior_degenerate_weights_error = function(cnd) NULL
+      posterior_error_degenerate_weights = function(cnd) NULL
     )
   })
   degenerate <- vapply(cols, is.null, logical(1))
@@ -454,7 +455,8 @@ validate_pit_weights <- function(weights, x, log) {
       "All draws have zero weight for ",
       paste0("'", vars[degenerate], "'", collapse = ", "),
       ". Returning NA for ",
-      if (sum(degenerate) > 1) "those variables." else "that variable."
+      if (sum(degenerate) > 1) "those variables." else "that variable.",
+      class = "posterior_warning_zero_weight"
     )
     cols[degenerate] <- list(rep(NA_real_, ndraws(x)))
   }

R/posterior-package.R

@@ -1,7 +1,7 @@
 #' Tools for working with posterior (and prior) distributions
 #'
 #' @name posterior-package
-#' @aliases posterior
+#' @aliases posterior posterior_warning
 #'
 #' @import checkmate
 #' @import stats
@@ -65,4 +65,42 @@
 #' match between two objects involved in a binary operation. Whether this
 #' causes a warning can be controlled by this option.
 #'
+#' @section Warning and error classes:
+#'
+#' Every warning signaled by \pkg{posterior} has the class
+#' `posterior_warning` and one class for its cause. Use these classes to
+#' handle or muffle a specific warning, for example with
+#' [withCallingHandlers()] and `invokeRestart("muffleWarning")`.
+#'
+#' * `posterior_warning_ess_capped`: An ESS estimate was capped.
+#' * `posterior_warning_superchain_ids_length`: The length of
+#' `superchain_ids` does not equal the number of chains.
+#' * `posterior_warning_superchain_unequal`: The superchains do not have the
+#' same number of chains.
+#' * `posterior_warning_non_numeric`: Non-numeric variables (e.g., factors)
+#' were converted to numeric.
+#' * `posterior_warning_chains_dropped`: Chains were dropped.
+#' * `posterior_warning_no_variables`: No variables with unreserved names
+#' were found.
+#' * `posterior_warning_odd_iterations`: The number of iterations is not
+#' even.
+#' * `posterior_warning_pit_above_one`: Some PIT values are larger than 1.
+#' * `posterior_warning_zero_weight`: All draws of a variable have zero
+#' weight.
+#' * `posterior_warning_nans_produced`: NaNs were produced.
+#' * `posterior_warning_draws_df_dropped`: The `draws_df` class was dropped.
+#' * `posterior_warning_pareto_invalid_input`: The input to Pareto smoothing
+#' contains infinite or `NA` values, is constant, or has a constant tail.
+#' * `posterior_warning_pareto_tail_too_short`: The number of tail draws was
+#' increased to 5.
+#' * `posterior_warning_pareto_tail_exceeds_draws`: The number of tail draws
+#' is not less than the total number of draws.
+#' * `posterior_warning_pareto_tail_too_long`: The number of tail draws is
+#' more than half of the total number of draws.
+#' * `posterior_warning_pareto_tail_not_fitted`: The generalized Pareto
+#' distribution was not fitted because there are fewer than 5 tail draws.
+#'
+#' The error signaled when all weights are zero has the class
+#' `posterior_error_degenerate_weights`.
+#'
 "_PACKAGE"

R/split_chains.R

@@ -27,7 +27,8 @@ split_chains.draws <- function(x, ...) {
   if (niter %% 2 != 0) {
     warning_no_call(
       "Number of iterations is not even. Removing the last iteration ",
-      "in order to split chains into two parts of equal length."
+      "in order to split chains into two parts of equal length.",
+      class = "posterior_warning_odd_iterations"
     )
     niter <- niter - 1
   }

R/summarise_draws.R

@@ -174,7 +174,8 @@ summarise_draws.draws <- function(
   if (!length(variables_x)) {
     warning_no_call(
       "The draws object contained no variables with unreserved names. ",
-      "No summaries were computed."
+      "No summaries were computed.",
+      class = "posterior_warning_no_variables"
     )
     return(tibble::tibble(character()))
   }

R/weight_draws.R

@@ -214,7 +214,7 @@ validate_weights <- function(weights, draws, log = FALSE) {
         "If the weights underflowed to zero, pass them on the log scale ",
         "with `log = TRUE`."
       ),
-      class = "posterior_degenerate_weights_error"
+      class = "posterior_error_degenerate_weights"
     ))
   }
   weights

tests/testthat/test-convergence.R

@@ -46,6 +46,26 @@ test_that("negative ess estimates are avoided with a warning", {
   expect_equal(ess, 3000)
 })
 
+test_that("capped ess warning has posterior warning classes", {
+  x <- stats::arima.sim(list(ar=-0.9), 1000)
+  w <- tryCatch(ess_basic(x), warning = identity)
+  expect_s3_class(w, "posterior_warning_ess_capped")
+  expect_s3_class(w, "posterior_warning")
+})
+
+test_that("calling code can count and muffle classed warnings", {
+  x <- replicate(3, stats::arima.sim(list(ar=-0.9), 1000))
+  n_capped <- 0
+  expect_silent(withCallingHandlers(
+    apply(x, 2, ess_basic),
+    posterior_warning_ess_capped = function(w) {
+      n_capped <<- n_capped + 1
+      invokeRestart("muffleWarning")
+    }
+  ))
+  expect_equal(n_capped, 3)
+})
+
 test_that("mcse diagnostics return reasonable values", {
   tau <- extract_variable_matrix(example_draws(), "tau")
 

tests/testthat/test-misc.R

@@ -0,0 +1,10 @@
+test_that("warning_no_call() adds the cause and shared classes", {
+  w <- tryCatch(
+    warning_no_call("a", 1, class = "posterior_warning_test"),
+    warning = identity
+  )
+  expect_s3_class(w, "posterior_warning_test")
+  expect_s3_class(w, "posterior_warning")
+  expect_equal(conditionMessage(w), "a1")
+  expect_null(conditionCall(w))
+})

tests/testthat/test-weight_draws.R

@@ -9,7 +9,7 @@ test_that("weight_draws rejects weights with no probability mass", {
   expect_error(weight_draws(x, exp(rep(-800, n))), "log = TRUE", fixed = TRUE)
 
   # the error is classed, so callers can handle it per variable
-  expect_error(weight_draws(x, rep(0, n)), class = "posterior_degenerate_weights_error")
+  expect_error(weight_draws(x, rep(0, n)), class = "posterior_error_degenerate_weights")
 
   # a single draw carrying all the mass is still valid
   w <- c(1, rep(0, n - 1))