diff --git a/NEWS.md b/NEWS.md index bcc1e16c..6040665c 100644 --- a/NEWS.md +++ b/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 diff --git a/R/E_loo.R b/R/E_loo.R index e360c3ef..3f783205 100644 --- a/R/E_loo.R +++ b/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 diff --git a/R/effective_sample_sizes.R b/R/effective_sample_sizes.R index 360a3098..3aa25d7d 100644 --- a/R/effective_sample_sizes.R +++ b/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,7 +105,7 @@ 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) { @@ -113,6 +113,7 @@ relative_eff.function <- relative_eff.default(as.vector(val_i), chain_id = chain_id, cores = 1) } ) + ) } else { if (!os_is_windows()) { n_eff_list <- diff --git a/R/helpers.R b/R/helpers.R index 37d407a8..d9d2ca8b 100644 --- a/R/helpers.R +++ b/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 +} diff --git a/R/loo_moment_matching.R b/R/loo_moment_matching.R index 08d6ced6..4ac89103 100644 --- a/R/loo_moment_matching.R +++ b/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()) { diff --git a/tests/testthat/test_0_helpers.R b/tests/testthat/test_0_helpers.R index a0add421..8628af1c 100644 --- a/tests/testthat/test_0_helpers.R +++ b/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")) +})