Signal each class of posterior warning once

NEWS.md

@@ -11,6 +11,8 @@ comparison-model minus reference-model by @florence-bockting in #391
 * Fix `crps()` and `scrps()` ignoring the `permutations` argument for numeric
 input by @thanasibakis in #398
 * Speed up the Bayesian bootstrap in `pseudobma_weights()` by @VisruthSK in #368
+* Signal each class of posterior warning once per call in `relative_eff()`,
+`E_loo()`, and `loo_moment_match()` by @florence-bockting in #416
 
 # loo 2.10.1
 

R/E_loo.R

@@ -271,15 +271,17 @@ E_loo_khat.default <- function(x, psis_object, log_ratios, ...) {
 #' @export
 E_loo_khat.matrix <- function(x, psis_object, log_ratios, ...) {
   tail_lengths <- attr(psis_object, "tail_len")
-  if (is.null(x)) {
-    sapply(seq_len(ncol(log_ratios)), function(i) {
-      .E_loo_khat_i(x, log_ratios[, i], tail_lengths[i])
-    })
-  } else {
-    sapply(seq_len(ncol(log_ratios)), function(i) {
-      .E_loo_khat_i(x[, i], log_ratios[, i], tail_lengths[i])
-    })
-  }
+  .collect_warnings(
+    if (is.null(x)) {
+      sapply(seq_len(ncol(log_ratios)), function(i) {
+        .E_loo_khat_i(x, log_ratios[, i], tail_lengths[i])
+      })
+    } else {
+      sapply(seq_len(ncol(log_ratios)), function(i) {
+        .E_loo_khat_i(x[, i], log_ratios[, i], tail_lengths[i])
+      })
+    }
+  )
 }
 
 #' Compute function-specific khat estimates

R/effective_sample_sizes.R

@@ -63,7 +63,7 @@ relative_eff.array <- function(x, ..., cores = getOption("mc.cores", 1)) {
   S <- prod(dim(x)[1:2]) # posterior sample size = iter * chains
 
   if (cores == 1) {
-    n_eff_vec <- apply(x, 3, posterior::ess_mean)
+    n_eff_vec <- .collect_warnings(apply(x, 3, posterior::ess_mean))
   } else {
     if (!os_is_windows()) {
       n_eff_list <-
@@ -105,14 +105,15 @@ relative_eff.function <-
     N <- dim(data)[1]
 
     if (cores == 1) {
-      n_eff_list <-
+      n_eff_list <- .collect_warnings(
         lapply(
           X = seq_len(N),
           FUN = function(i) {
             val_i <- f_i(data_i = data[i, , drop = FALSE], draws = draws, ...)
             relative_eff.default(as.vector(val_i), chain_id = chain_id, cores = 1)
           }
         )
+      )
     } else {
       if (!os_is_windows()) {
         n_eff_list <-

R/helpers.R

@@ -280,3 +280,23 @@ release_questions <- function() {
 is_constant <- function(x, tol = .Machine$double.eps) {
   abs(max(x) - min(x)) < tol
 }
+
+#' Collect posterior warnings and signal each class once
+#'
+#' @noRd
+#' @param expr Expression to evaluate.
+#' @return The value of `expr`.
+.collect_warnings <- function(expr) {
+  collected <- list()
+  out <- withCallingHandlers(
+    expr,
+    posterior_warning = function(cnd) {
+      collected[[class(cnd)[1]]] <<- cnd
+      invokeRestart("muffleWarning")
+    }
+  )
+  for (cnd in collected) {
+    warning(cnd)
+  }
+  out
+}

R/loo_moment_matching.R

@@ -123,7 +123,9 @@ loo_moment_match.default <- function(x, loo, post_draws, log_lik_i,
   }
 
   if (cores == 1) {
-    mm_list <- lapply(X = I, FUN = function(i) loo_moment_match_i_fun(i))
+    mm_list <- .collect_warnings(
+      lapply(X = I, FUN = function(i) loo_moment_match_i_fun(i))
+    )
   }
   else {
     if (!os_is_windows()) {

tests/testthat/test_0_helpers.R

@@ -91,3 +91,29 @@ test_that("loo_cores works", {
   expect_warning(expect_equal(loo_cores(10), 2), "deprecated")
   options(loo.cores = NULL)
 })
+
+test_that(".collect_warnings() signals each posterior class once", {
+  warn_classed <- function(class) {
+    warning(structure(
+      class = c(class, "posterior_warning", "warning", "condition"),
+      list(message = class, call = NULL)
+    ))
+  }
+  caught <- character()
+  out <- withCallingHandlers(
+    .collect_warnings({
+      warn_classed("a")
+      warn_classed("a")
+      .collect_warnings(warn_classed("b"))
+      warn_classed("b")
+      warning("other")
+      1
+    }),
+    warning = function(cnd) {
+      caught <<- c(caught, conditionMessage(cnd))
+      invokeRestart("muffleWarning")
+    }
+  )
+  expect_equal(out, 1)
+  expect_equal(caught, c("other", "a", "b"))
+})