Add classes to all loo warnings

DESCRIPTION

@@ -39,6 +39,7 @@ Imports:
     matrixStats (>= 0.52),
     parallel,
     posterior (>= 1.7.0),
+    rlang (>= 1.0.6),
     stats
 Suggests:
     bayesplot (>= 1.7.0),

NEWS.md

@@ -11,6 +11,10 @@ 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
+* All warnings now have the class `loo_warning` and a class for each cause;
+diagnostics warnings have the class `loo_warning_diagnostic` by
+@florence-bockting in #417
+
 
 # loo 2.10.1
 

R/diagnostics.R

@@ -272,8 +272,9 @@ plot.psis_loo <- function(x,
   k[is.na(k)] <- 0  # FIXME when reloo is changed to make NA k values -Inf
   k_inf <- !is.finite(k)
   if (any(k_inf)) {
-    warning(signif(100 * mean(k_inf), 2),
-            "% of Pareto k estimates are Inf/NA/NaN and not plotted.")
+    .warn(signif(100 * mean(k_inf), 2),
+          "% of Pareto k estimates are Inf/NA/NaN and not plotted.",
+          class = "loo_warning_pareto_k_not_plotted")
   }
 
   if (diagnostic == "ESS" || diagnostic == "n_eff") {

R/helpers.R

@@ -259,8 +259,8 @@ loo_cores <- function(cores) {
   loo_cores_op <- getOption("loo.cores", NA)
   if (!is.na(loo_cores_op) && (loo_cores_op != cores)) {
     cores <- loo_cores_op
-    warning("'loo.cores' is deprecated, please use 'mc.cores' or pass 'cores' explicitly.",
-            call. = FALSE)
+    .warn("'loo.cores' is deprecated, please use 'mc.cores' or pass 'cores' explicitly.",
+          class = "loo_warning_deprecated")
   }
   return(cores)
 }

R/loo-package.R

@@ -39,6 +39,44 @@
 #'   diagnostics and effective sample size and Monte Carlo standard error
 #'   estimates.
 #'
+#' @section Warning classes:
+#'
+#' Every warning signaled by \pkg{loo} has the class `loo_warning` and one
+#' class for its cause. Warnings that question the reliability of a result
+#' also have the class `loo_warning_diagnostic`. Use these classes to handle
+#' or muffle a specific warning, for example with [withCallingHandlers()]
+#' and `invokeRestart("muffleWarning")`.
+#'
+#' Diagnostic warnings:
+#'
+#' * `loo_warning_pareto_k_high`: Some Pareto k values are too high.
+#' * `loo_warning_pareto_tail_not_fitted`: There are not enough tail samples to
+#' fit the generalized Pareto distribution.
+#' * `loo_warning_pareto_tail_constant`: All tail values are the same.
+#' * `loo_warning_p_waic_high`: Some `p_waic` estimates are greater than 0.4.
+#' * `loo_warning_moment_match_failed`: Moment matching failed for some
+#' observations.
+#' * `loo_warning_moment_match_max_iters`: Moment matching reached
+#' `max_iters`.
+#' * `loo_warning_large_kf`: The accuracy of self-normalized importance
+#' sampling may be bad.
+#' * `loo_warning_y_mismatch`: The models do not have the same `y` variable.
+#' * `loo_warning_cv_mismatch`: The models use different types of
+#' cross-validation or different numbers of folds.
+#' * `loo_warning_chance_difference`: The difference in performance is
+#' potentially due to chance.
+#' * `loo_warning_subsample_se`: A subsampling standard error is naive or
+#' negative.
+#'
+#' Other warnings:
+#'
+#' * `loo_warning_multicore_unavailable`: Multicore is not implemented for
+#' the selected method.
+#' * `loo_warning_pareto_k_not_plotted`: Some Pareto k values are `Inf`, `NA`,
+#' or `NaN` and are not plotted.
+#' * `loo_warning_llfun_not_matrix`: The values from `llfun` are not a matrix
+#' and were coerced.
+#' * `loo_warning_deprecated`: A deprecated feature was used.
 #'
 #' @template loo-and-psis-references
 #' @template stacking-references

R/loo.R

@@ -549,18 +549,6 @@ log_var_epd_ratio <- function(log_lik_ratio, lw, r_eff) {
   matrixStats::colLogSumExps(2 * (lw + log_abs_diff)) - log(r_eff)
 }
 
-
-#' Warning message if r_eff not specified
-#' @noRd
-throw_loo_r_eff_warning <- function() {
-  warning(
-    "Relative effective sample sizes ('r_eff' argument) not specified.\n",
-    "For models fit with MCMC, the reported PSIS ESS and \n",
-    "MCSE estimates can be over-optimistic.",
-    call. = FALSE
-  )
-}
-
 #' Combine many psis objects into a single psis object
 #'
 #' @noRd
@@ -621,12 +609,12 @@ NULL
   if (is.character(i)) {
     needs_warning <- which(flags == i)
     if (length(needs_warning)) {
-      warning(
+      .warn(
         "Accessing ", flags[needs_warning], " using '[' is deprecated ",
         "and will be removed in a future release. ",
         "Please extract the ", flags[needs_warning],
         " estimate from the 'estimates' component instead.",
-        call. = FALSE
+        class = "loo_warning_deprecated"
       )
     }
   }
@@ -643,12 +631,12 @@ NULL
   if (is.character(i)) {
     needs_warning <- which(flags == i)
     if (length(needs_warning)) {
-      warning(
+      .warn(
         "Accessing ", flags[needs_warning], " using '[[' is deprecated ",
         "and will be removed in a future release. ",
         "Please extract the ", flags[needs_warning],
         " estimate from the 'estimates' component instead.",
-        call. = FALSE
+        class = "loo_warning_deprecated"
       )
     }
   }
@@ -664,12 +652,12 @@ NULL
              "elpd_waic", "se_elpd_waic", "p_waic", "se_p_waic", "waic", "se_waic")
   needs_warning <- which(flags == name)
   if (length(needs_warning)) {
-    warning(
+    .warn(
       "Accessing ", flags[needs_warning], " using '$' is deprecated ",
       "and will be removed in a future release. ",
       "Please extract the ", flags[needs_warning],
       " estimate from the 'estimates' component instead.",
-      call. = FALSE
+      class = "loo_warning_deprecated"
     )
   }
   NextMethod()

R/loo_compare.R

@@ -286,22 +286,22 @@ loo_compare_checks <- function(loos) {
     isTRUE(all.equal(x, yhash[[1]]))
   })
   if (!all(yhash_ok)) {
-    warning("Not all models have the same y variable. ('yhash' attributes do not match)",
-            call. = FALSE)
+    .warn_diagnostic("Not all models have the same y variable. ('yhash' attributes do not match)",
+                     class = "loo_warning_y_mismatch")
   }
 
   if (all(sapply(loos, is.kfold))) {
     Ks <- unlist(lapply(loos, attr, which = "K"))
     if (!all(Ks == Ks[1])) {
-      warning("Not all kfold objects have the same K value. ",
-              "For a more accurate comparison use the same number of folds. ",
-              call. = FALSE)
+      .warn_diagnostic("Not all kfold objects have the same K value. ",
+                       "For a more accurate comparison use the same number of folds. ",
+                       class = "loo_warning_cv_mismatch")
     }
   } else if (any(sapply(loos, is.kfold)) && any(sapply(loos, is.psis_loo))) {
-    warning("Comparing LOO-CV to K-fold-CV. ",
-            "For a more accurate comparison use the same number of folds ",
-            "or loo for all models compared.",
-            call. = FALSE)
+    .warn_diagnostic("Comparing LOO-CV to K-fold-CV. ",
+                     "For a more accurate comparison use the same number of folds ",
+                     "or loo for all models compared.",
+                     class = "loo_warning_cv_mismatch")
   }
 }
 
@@ -405,9 +405,9 @@ loo_order_stat_check <- function(loos, ord) {
 
   if (max(elpd_diff) <= order_stat) {
     # flag warning if we suspect no model is theoretically better than the baseline
-    warning("Difference in performance potentially due to chance. ",
-            "See McLatchie and Vehtari (2023) for details.",
-            call. = FALSE)
+    .warn_diagnostic("Difference in performance potentially due to chance. ",
+                     "See McLatchie and Vehtari (2023) for details.",
+                     class = "loo_warning_chance_difference")
   }
 }
 

R/loo_compare.psis_loo_ss_list.R

@@ -51,7 +51,7 @@ loo_compare_ss <- function(ref_loo, compare_loo){
 
   # Using HH estimation
   if (ref_loo[[1]]$loo_subsampling$estimator == "hh_pps" | compare_loo[[1]]$loo_subsampling$estimator == "hh_pps"){
-    warning("Hansen-Hurwitz estimator used. Naive diff SE is used.", call. = FALSE)
+    .warn_diagnostic("Hansen-Hurwitz estimator used. Naive diff SE is used.", class = "loo_warning_subsample_se")
     return(loo_compare_ss_naive(ref_loo, compare_loo))
   }
 
@@ -70,8 +70,8 @@ loo_compare_ss <- function(ref_loo, compare_loo){
 
   # If different samples
   if (!compare_subset_of_ref & !ref_subset_of_compare){
-    warning("Different subsamples in '", names(ref_loo), "' and '", names(compare_loo),
-            "'. Naive diff SE is used.", call. = FALSE)
+    .warn_diagnostic("Different subsamples in '", names(ref_loo), "' and '", names(compare_loo),
+                     "'. Naive diff SE is used.", class = "loo_warning_subsample_se")
     return(loo_compare_ss_naive(ref_loo, compare_loo))
   }
 }
@@ -152,22 +152,22 @@ loo_compare_checks.psis_loo_ss_list <- function(loos) {
     isTRUE(all.equal(x, yhash[[1]]))
   })
   if (!all(yhash_ok)) {
-    warning("Not all models have the same y variable. ('yhash' attributes do not match)",
-            call. = FALSE)
+    .warn_diagnostic("Not all models have the same y variable. ('yhash' attributes do not match)",
+                     class = "loo_warning_y_mismatch")
   }
 
   if (all(sapply(loos, is.kfold))) {
     Ks <- unlist(lapply(loos, attr, which = "K"))
     if (!all(Ks == Ks[1])) {
-      warning("Not all kfold objects have the same K value. ",
-              "For a more accurate comparison use the same number of folds. ",
-              call. = FALSE)
+      .warn_diagnostic("Not all kfold objects have the same K value. ",
+                       "For a more accurate comparison use the same number of folds. ",
+                       class = "loo_warning_cv_mismatch")
     }
   } else if (any(sapply(loos, is.kfold)) && any(sapply(loos, is.psis_loo))) {
-    warning("Comparing LOO-CV to K-fold-CV. ",
-            "For a more accurate comparison use the same number of folds ",
-            "or loo for all models compared.",
-            call. = FALSE)
+    .warn_diagnostic("Comparing LOO-CV to K-fold-CV. ",
+                     "For a more accurate comparison use the same number of folds ",
+                     "or loo for all models compared.",
+                     class = "loo_warning_cv_mismatch")
   }
 }
 

R/loo_moment_matching.R

@@ -736,23 +736,23 @@ throw_moment_match_error_warning <- function(failed, stopped, error_msg) {
       "observations are the PSIS results without moment matching.\n"
     ))
   }
-  warning(
+  .warn_diagnostic(
     msg,
     "The cause was an error in 'log_prob_upars', 'log_lik_i_upars' or ",
     "'log_lik_i', or a parallel worker that did not return a result. The ",
     "first error message:\n", error_msg[1],
-    call. = FALSE
+    class = "loo_warning_moment_match_failed"
   )
 }
 
 #' Warning message if max_iters is reached
 #' @noRd
 throw_moment_match_max_iters_warning <- function() {
-  warning(
+  .warn_diagnostic(
     "The maximum number of moment matching iterations ('max_iters' argument)
     was reached.\n",
     "Increasing the value may improve accuracy.",
-    call. = FALSE
+    class = "loo_warning_moment_match_max_iters"
   )
 }
 
@@ -769,10 +769,10 @@ throw_large_kf_warning <- function(kf, k_threshold, split_failed = FALSE) {
     } else {
       advice <- "Setting the argument 'split' to 'TRUE' will likely improve accuracy."
     }
-    warning(
+    .warn_diagnostic(
       "The accuracy of self-normalized importance sampling may be bad.\n",
       advice,
-      call. = FALSE
+      class = "loo_warning_large_kf"
     )
   }
 }

R/loo_subsample.R

@@ -584,8 +584,8 @@ elpd_loo_approximation <- function(.llfun, data, draws, cores, loo_approximation
     }
 
     p_eff_approx <- numeric(N)
-    if (cores>1) warning("Multicore is not implemented for waic_delta",
-                         call. = FALSE)
+    if (cores>1) .warn("Multicore is not implemented for waic_delta",
+                       class = "loo_warning_multicore_unavailable")
 
     if (loo_approximation == "waic_grad") {
       for(i in 1:nrow(data)) {
@@ -1081,7 +1081,7 @@ loo_subsample_estimation_hh <- function(x) {
   if (hh_elpd_loo$hat_v_y_ppz > 0) {
     x$estimates["elpd_loo", "SE"]  <- sqrt(hh_elpd_loo$hat_v_y_ppz)
   } else {
-    warning("Negative estimate of SE, more subsampling obs. needed.", call. = FALSE)
+    .warn_diagnostic("Negative estimate of SE, more subsampling obs. needed.", class = "loo_warning_subsample_se")
     x$estimates["elpd_loo", "SE"]  <- NaN
   }
   x$estimates["elpd_loo", "subsampling SE"] <- sqrt(hh_elpd_loo$v_hat_y_ppz)
@@ -1091,7 +1091,7 @@ loo_subsample_estimation_hh <- function(x) {
   if (hh_p_loo$hat_v_y_ppz > 0) {
     x$estimates["p_loo", "SE"]  <- sqrt(hh_p_loo$hat_v_y_ppz)
   } else {
-    warning("Negative estimate of SE, more subsampling obs. needed.", call. = FALSE)
+    .warn_diagnostic("Negative estimate of SE, more subsampling obs. needed.", class = "loo_warning_subsample_se")
     x$estimates["elpd_loo", "SE"]  <- NaN
   }
   x$estimates["p_loo", "subsampling SE"] <- sqrt(hh_p_loo$v_hat_y_ppz)

R/print.R

@@ -238,7 +238,12 @@ print_mcse_summary <- function(x, digits) {
 
 # print and warning helpers
 .fr <- function(x, digits) format(round(x, digits), nsmall = digits)
-.warn <- function(..., call. = FALSE) warning(..., call. = call.)
+.warn <- function(..., class = NULL) {
+  rlang::warn(paste(c(...), collapse = ""), class = c(class, "loo_warning"))
+}
+.warn_diagnostic <- function(..., class) {
+  .warn(..., class = c(class, "loo_warning_diagnostic"))
+}
 .k_help <- function() "See help('pareto-k-diagnostic') for details.\n"
 
 # compatibility with old loo objects