diff --git a/.gitignore b/.gitignore
index bc23df9e..e52fad9c 100644
--- a/.gitignore
+++ b/.gitignore
@@ -30,4 +30,6 @@ release-prep.R
# personal maintainer scratch (not shared)
internal-notes/
+notes/loo_se.pdf
+notes/loo-compare-se-diff.md
CRAN-SUBMISSION
diff --git a/NAMESPACE b/NAMESPACE
index 6f0be7f6..79f01035 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -48,13 +48,14 @@ S3method(loo_moment_match,default)
S3method(loo_predictive_metric,matrix)
S3method(loo_scrps,matrix)
S3method(loo_subsample,"function")
+S3method(model_compare,default)
+S3method(model_compare,psis_loo_ss_list)
S3method(nobs,psis_loo_ss)
S3method(plot,loo)
S3method(plot,psis)
S3method(plot,psis_loo)
S3method(pointwise,loo)
S3method(print,compare.loo)
-S3method(print,compare.loo_ss)
S3method(print,importance_sampling)
S3method(print,importance_sampling_loo)
S3method(print,kfold)
@@ -106,6 +107,7 @@ export(.thin_draws)
export(E_loo)
export(compare)
export(crps)
+export(custom_measure)
export(elpd)
export(example_loglik_array)
export(example_loglik_matrix)
@@ -158,6 +160,7 @@ export(measure_r2)
export(measure_rmse)
export(measure_rps)
export(measure_srps)
+export(model_compare)
export(nlist)
export(obs_idx)
export(pareto_k_ids)
diff --git a/NEWS.md b/NEWS.md
index 40bf3243..6cf3bdaf 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -7,6 +7,20 @@
* New predictive performance API: `insample_pred_measure()`, `loo_pred_measure()`,
`kfold_pred_measure()`, `test_pred_measure()`, and `pred_measure()` with
built-in measures via `measure_*()` and [supported_measures_list()].
+* New `model_compare()` compares models on all measures of a `*_pred_measure()`
+ result by @florence-bockting in #380.
+* `loo_compare()` is deprecated. Use `model_compare()`. Methods in other
+ packages (e.g. **brms**) still dispatch.
+* `model_compare()` compares each measure against its own best model. It shows
+ loss measures on the utility scale.
+* `model_compare()` ranks models by `elpd` when all models share it. Otherwise,
+ it ranks them by the first shared measure in alphabetical order.
+* New `custom_measure()` sets the name, the loss flag, and the SE of the
+ difference for a custom measure.
+* `print()` on a comparison has the new argument `measures`. It marks each
+ loss measure with a flipped sign.
+* `loo_pred_measure()` warns when `loo_moment_match()` or `reloo()` corrected
+ the `loo` object and the measure is not `elpd`, `mlpd`, or `ic`.
* Improve numerical stability in `loo()`, `psis()`, model weighting, subsampling,
and moment matching in #395
* Fix `loo_compare()` when used with subsampling: compute model comparison by
diff --git a/R/compare.R b/R/compare.R
index a0c7819d..c7826d44 100644
--- a/R/compare.R
+++ b/R/compare.R
@@ -1,6 +1,6 @@
#' Model comparison (deprecated, old version)
#'
-#' **This function is deprecated**. Please use the new [loo_compare()] function
+#' **This function is deprecated**. Please use the new [model_compare()] function
#' instead. See `vignette("migration-guide", package = "loo")` for details.
#' `compare()` and `R/compare.R` are scheduled for removal in a future release.
#'
@@ -60,7 +60,7 @@
#' }
#'
compare <- function(..., x = list()) {
- .Deprecated("loo_compare")
+ .Deprecated("model_compare")
dots <- list(...)
if (length(dots)) {
if (length(x)) {
diff --git a/R/helpers.R b/R/helpers.R
index 37d407a8..709ec2ff 100644
--- a/R/helpers.R
+++ b/R/helpers.R
@@ -265,18 +265,34 @@ loo_cores <- function(cores) {
return(cores)
}
-
-# nocov start
-# release reminders (for devtools)
-release_questions <- function() {
- c(
- "Have you updated references?",
- "Have you updated inst/CITATION?",
- "Have you updated the vignettes?"
- )
-}
-# nocov end
-
is_constant <- function(x, tol = .Machine$double.eps) {
abs(max(x) - min(x)) < tol
}
+
+#' Issue a deprecation warning the first time it is triggered in a session
+#'
+#' Repeated calls with the same `id` are silent, so a script calling a
+#' deprecated function in a loop is not flooded with warnings. `old` is passed
+#' on explicitly so the message does not depend on which method called this.
+#' Which `id`s have already warned is kept in `state`, an environment created
+#' once when the package is built and private to this function.
+#'
+#' @noRd
+#' @param id Identifier for the deprecation; one warning per `id` per session.
+#' @param new,old Name of the replacement and deprecated function.
+#' @return `TRUE` if a warning was issued, `FALSE` otherwise, invisibly.
+#'
+.deprecate_once <- local({
+ state <- new.env(parent = emptyenv())
+ function(id, new, old = id) {
+ if (isTRUE(state[[id]])) {
+ return(invisible(FALSE))
+ }
+ state[[id]] <- TRUE
+ warning(
+ "'", old, "' is deprecated. Use '", new, "' instead.\n",
+ call. = FALSE, immediate. = TRUE
+ )
+ invisible(TRUE)
+ }
+})
diff --git a/R/kfold-generic.R b/R/kfold-generic.R
index bed45b15..d5f4026f 100644
--- a/R/kfold-generic.R
+++ b/R/kfold-generic.R
@@ -7,7 +7,7 @@
#'
#' The **Value** section below describes the objects that `kfold()`
#' methods should return in order to be compatible with
-#' [loo_compare()] and the **loo** package print methods.
+#' [model_compare()] and the **loo** package print methods.
#'
#'
#' @name kfold-generic
@@ -25,7 +25,7 @@
#'
#' It is important for the object to have at least these classes and
#' components so that it is compatible with other functions like
-#' [loo_compare()] and `print()` methods.
+#' [model_compare()] and `print()` methods.
#'
NULL
diff --git a/R/loo-glossary.R b/R/loo-glossary.R
index bb1cb809..33580c2f 100644
--- a/R/loo-glossary.R
+++ b/R/loo-glossary.R
@@ -14,6 +14,8 @@
#' Note: VGG2017 refers to Vehtari, Gelman, and Gabry (2017). See
#' **References**, below.
#'
+#' @seealso [model_compare()], [loo_compare()]
+#'
#' @section ELPD and `elpd_loo`:
#'
#' The ELPD is the theoretical expected log pointwise predictive density for a new
@@ -39,7 +41,7 @@
#' estimate is an accurate estimate for the scale, it ignores the skewness. When
#' making model comparisons, the SE of the component-wise (pairwise) differences
#' should be used instead (see the `se_diff` section below and Eq 24 in
-#' VGG2017). Sivula et al. (2022) discuss the conditions when the normal
+#' VGG2017). Sivula et al. (2025) discuss the conditions when the normal
#' approximation used for SE and `se_diff` is good.
#'
#' @section Monte Carlo SE of elpd_loo:
@@ -141,10 +143,39 @@
#' detect the problem.
#' }
#'
+#' @section Model comparison with `model_compare()` and `loo_compare()`:
+#'
+#' Two functions perform model comparison, and both are available to users:
+#'
+#' * [model_compare()] is the current interface. It compares `"loo"`, `"waic"`,
+#' and `"kfold"` objects on ELPD, and [`pred_measure`][pred_measure] results
+#' on every predictive measure the models share.
+#'
+#' * [loo_compare()] is **deprecated** in favor of `model_compare()`, but it
+#' still works and is still an exported generic, so `loo_compare` methods
+#' registered by other packages keep dispatching. It keeps its previous
+#' behavior: it accepts only `"loo"`, `"waic"`, and `"kfold"` objects and
+#' compares them on ELPD. Passing [`pred_measure`][pred_measure] results
+#' produces an error. The deprecation warning is issued once per session.
+#'
+#' `loo_compare()` and `model_compare()` return the same object: a data frame
+#' including the `p_worse`, `diag_diff`, and `diag_elpd` columns. The terms
+#' `elpd_diff`, `se_diff`, `p_worse`, `diag_diff`, and `diag_elpd` are defined
+#' below. The remaining sections, on comparisons of several predictive
+#' measures at once, apply to `model_compare()` only, since `loo_compare()`
+#' cannot produce such a comparison. See
+#' `vignette("migration-guide", package = "loo")` for the migration path.
+#'
+#' Below, "the comparison output" refers to the object returned by either
+#' function, and "the reference model" to the model each difference is computed
+#' against, which is the best model on the measure.
+#'
#' @section elpd_diff:
#' `elpd_diff` is the difference in `elpd_loo` for two models. If more
#' than two models are compared, the difference is computed relative to the
-#' model with highest `elpd_loo`.
+#' reference model, which is the model with the highest `elpd_loo` in
+#' `loo_compare()` and in `model_compare()` the model with the best
+#' performance on each measure.
#'
#' @section se_diff:
#'
@@ -161,7 +192,7 @@
#'
#' p_worse = pnorm(0, elpd_diff, se_diff).
#'
-#' The best-ranked model (the first row in the `loo_compare()` output, where
+#' The reference model (the row of the comparison output where
#' `elpd_diff = 0`) always receives `NA`, since the comparison is defined
#' relative to that model.
#'
@@ -176,19 +207,18 @@
#' appear more clearly worse than the data actually support. Conversely, when
#' `elpd_diff` is biased due to an unreliable LOO approximation, `p_worse` can
#' point in the wrong direction entirely. When any of these conditions are
-#' present, `diag_diff` or `diag_elpd` will be flagged in the `loo_compare()`
-#' output.
-#' For further guidance, see the sections below and the case study on
+#' present, `diag_diff` or `diag_elpd` will be flagged in the comparison
+#' output. For further guidance, see the sections below and the case study on
#' [Uncertainty in Bayesian LOO-CV Model Comparison](
#' https://users.aalto.fi/~ave/casestudies/LOO_uncertainty/loo_uncertainty.html).
#'
#' @section `diag_diff` (pairwise comparison diagnostics):
#'
-#' `diag_diff` is a diagnostic column in the `loo_compare()` output for each
-#' model comparison against the current reference model. It flags conditions
-#' under which the normal approximation behind `se_diff` and `p_worse` is likely
-#' to be poorly calibrated. The column contains a short label when a condition
-#' is detected, and is empty otherwise.
+#' `diag_diff` is a diagnostic column in the `model_compare()` and
+#' `loo_compare()` output for each model comparison against the current
+#' reference model. It flags conditions under which the normal approximation
+#' behind `se_diff` and `p_worse` is likely to be poorly calibrated. The column
+#' contains a short label when a condition is detected, and is empty otherwise.
#'
#' The column `diag_diff` currently flags two problems:
#'
@@ -210,7 +240,7 @@
#'
#' The conditions flagged by `diag_diff` are not independent: they tend to
#' co-occur, and when they do, some flags carry more information than others.
-#' `loo_compare()` therefore follows a priority hierarchy and shows only the
+#' Both functions therefore follow a priority hierarchy and show only the
#' most critical flag in the table output.
#'
#' The hierarchy is as follows:
@@ -233,12 +263,12 @@
#'
#' @section `diag_elpd`:
#'
-#' `diag_elpd` is a diagnostic column in the `loo_compare()` output that flags
-#' when the PSIS-LOO approximation for an individual model is unreliable. Unlike
-#' `diag_diff`, which concerns the *comparison* between models, `diag_elpd`
-#' concerns the quality of the `elpd_loo` estimate for each model individually.
-#' It contains a short text label when a problem is detected, and is empty
-#' otherwise.
+#' `diag_elpd` is a diagnostic column in the `model_compare()` and
+#' `loo_compare()` output that flags when the PSIS-LOO approximation for an
+#' individual model is unreliable. Unlike `diag_diff`, which concerns the
+#' *comparison* between models, `diag_elpd` concerns the quality of the
+#' `elpd_loo` estimate for each model individually. It contains a short text
+#' label when a problem is detected, and is empty otherwise.
#'
#' ### `K k_psis > t` (K observations with Pareto-k values > t)
#'
@@ -252,6 +282,116 @@
#' This is qualitatively different from the calibration issues flagged by
#' `diag_diff`: here the estimate itself may be wrong, not just uncertain.
#'
+#' The flag is not specific to ELPD: `mae_loo`, `mse_loo`, `r2_loo` and the
+#' rest are biased by unreliable importance sampling for the same reason. It is
+#' a property of one model's approximation, and does not depend on which model
+#' is used as the comparison reference. In an ELPD-only comparison (i.e., all
+#' `loo_compare()` output, and `model_compare()` on `"loo"`, `"waic"`, or
+#' `"kfold"` objects) `print()` shows it as a column of the single difference
+#' table. In a multi-measure `model_compare()` comparison it is instead reported
+#' once per model above the per-measure difference tables, rather than inside
+#' any one of them.
+#'
#' See for further information on Pareto-k values the "Pareto k estimates"
#' section.
+#'
+#' @section Multi-measure model comparisons:
+#'
+#' The remaining sections describe comparisons that only [model_compare()] can
+#' produce; the deprecated `loo_compare()` rejects
+#' [`pred_measure`][pred_measure] inputs.
+#'
+#' When comparing [`loo_pred_measure()`][loo_pred_measure] objects with
+#' `model_compare()`, paired differences are computed for every predictive
+#' measure common to all models. Rows are ordered by `"elpd"` when all models
+#' share it, and otherwise by the first shared measure in alphabetical order. Each measure is compared against the
+#' model that is best on that measure, so different difference columns may use
+#' different reference models.
+#'
+#' ### `{measure}_diff` and `{measure}_se_diff`
+#'
+#' For each non-ELPD measure `m`, `model_compare()` adds columns `m_diff` and
+#' `m_se_diff`. In all cases `m_diff` is the difference between the two overall
+#' estimates on a utility scale (higher is better; loss measures such as MSE,
+#' Brier score, and SRPS have their sign flipped from the raw loss orientation).
+#' Measures already returned on a utility scale (e.g. ELPD, CRPS/RPS) are not
+#' sign-flipped. Negative `m_diff` values then indicate worse performance than
+#' the reference model, which has `m_diff = 0`.
+#'
+#' How `m_se_diff` is obtained depends on the measure:
+#'
+#' * When the overall estimate is a sum or mean of pointwise contributions, it
+#' is computed from paired pointwise differences using the same approach as
+#' `elpd_diff` and `se_diff` (Eq 24 in VGG2017 for sums; the mean analogue for
+#' means). This covers ELPD, `mlpd`, `ic`, `mae`, `mse`, `acc`, `brier`, and
+#' the ranked probability scores.
+#' * When a built-in measure is a transformation of such quantities, it supplies
+#' its own delta-method standard error (`se_diff_fun`). For `rmse` this is the
+#' first-order bivariate Taylor approximation propagated from the MSE scale,
+#' which requires the covariance between the two models' pointwise squared
+#' errors and is therefore not a paired pointwise standard deviation. For
+#' `r2` it is the trivariate analogue, which additionally propagates the
+#' uncertainty in the baseline `MSE(y)` shared by both models.
+#' * For custom measures it comes from the measure's own
+#' `attr(my_fun, "measure_se_diff")` declaration, set with
+#' [custom_measure()]. It is `NA` when the measure declares nothing.
+#'
+#' The reference model has `m_se_diff = 0` whenever an `m_se_diff` is available.
+#' Which measures are losses is recorded in the `loss` element of the
+#' `measure_info` attribute on each `*_pred_measure()` result. `print()` marks
+#' each flipped loss with "sign flipped" (see [model_compare()]).
+#'
+#' ELPD-family measures use the column names `elpd_diff` and `se_diff` rather
+#' than a prefixed form. Only ELPD comparisons include `p_worse` and `diag_diff`;
+#' these diagnostics do not apply to other predictive measures.
+#'
+#' ### `measure_info`
+#'
+#' Attribute on all `*_pred_measure()` and [pred_measure()] results: a named
+#' list of per-measure information used by [model_compare()]. Each entry
+#' is a list with:
+#'
+#' * `loss`: whether lower values of the measure are better. Measure values are
+#' always stored on the measure's own scale, so this describes both the
+#' measure and the values recorded for it
+#' * `diff_method`: how the standard error of the difference is obtained:
+#' `"sum"` or `"mean"` (paired pointwise differences),
+#' `"measure_specific"` (the built-in measure's own `se_diff_fun`), or
+#' `"custom"`. Nothing is inferred from a measure's values. Under `"custom"`
+#' the standard error comes from the measure's `se_diff_fun` declaration:
+#' a function, the `"sum"`/`"mean"` pointwise formulas, or nothing for an
+#' `NA` standard error. A missing standard error is not an
+#' error state as the difference itself is still reported.
+#' * `se_diff_fun`: for built-in measures with
+#' `diff_method = "measure_specific"`, the name of the built-in implementation
+#' used. For custom measures, whatever the measure declared in
+#' `attr(my_fun, "measure_se_diff")`; absent when it declared nothing.
+#' * `extra`: optional list of auxiliary data the measure stored for the
+#' standard error of its difference, present only for measures that need it
+#' (`r2` stores the pointwise baseline `(y_i - mean(y))^2`, which `y` no
+#' longer supplies by the time [model_compare()] runs; `bacc` stores the class
+#' index of each observation, which its pointwise values do not determine).
+#' Custom measures return it as an `extra` element, and it is passed on to
+#' their `se_diff_fun`. It is excluded from the consistency check below, since it
+#' varies with the data rather than with the measure itself.
+#'
+#' Built-in measures take `loss`, `diff_method`, and `se_diff_fun` from the
+#' package measure registry. Custom measures always get `diff_method = "custom"`
+#' and take `loss` and `se_diff_fun` from the arguments of the same name in
+#' [custom_measure()]. With `loss = TRUE` lower values are better; without it
+#' they are treated as utilities (see [insample_pred_measure()]).
+#' [model_compare()] requires all models to provide matching `measure_info` for
+#' each shared measure; a mismatched `measure_loss` or `measure_se_diff`
+#' declaration, or missing `measure_info` on some models, produces an error.
+#'
+#' ### `compare_measures` and related attributes
+#'
+#' Attribute `compare_reference` is a named character vector recording the
+#' reference model used for each measure. Attribute `compare_measures` lists all
+#' measures that were compared, and `sign_converted_measures` lists loss
+#' measures whose sign was flipped onto the utility scale. The print method
+#' shows the ranking measure by default (the first compared measure); use
+#' `print(x, measures = "all")` or `print(x, measures = c("rmse", "r2"))` to
+#' display additional measure tables. Each printed table is sorted by its own
+#' measure, best model first, so the same model need not lead every table.
NULL
diff --git a/R/loo.R b/R/loo.R
index 0b284297..b89fe175 100644
--- a/R/loo.R
+++ b/R/loo.R
@@ -95,7 +95,7 @@
#' * [psis()] for the underlying Pareto Smoothed Importance Sampling (PSIS)
#' procedure used in the LOO-CV approximation.
#' * [pareto-k-diagnostic] for convenience functions for looking at diagnostics.
-#' * [loo_compare()] for model comparison.
+#' * [model_compare()] for model comparison.
#'
#' @template loo-and-psis-references
#'
@@ -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
diff --git a/R/loo_approximate_posterior.R b/R/loo_approximate_posterior.R
index 3a3bce09..24f3203b 100644
--- a/R/loo_approximate_posterior.R
+++ b/R/loo_approximate_posterior.R
@@ -27,7 +27,7 @@
#' }
#' }
#'
-#' @seealso [loo()], [psis()], [loo_compare()]
+#' @seealso [loo()], [psis()], [model_compare()]
#' @template loo-large-data-references
#'
#' @export loo_approximate_posterior
diff --git a/R/loo_compare.R b/R/loo_compare.R
index 4e7146b6..54739ac7 100644
--- a/R/loo_compare.R
+++ b/R/loo_compare.R
@@ -1,106 +1,38 @@
-#' Model comparison
+#' Model comparison (deprecated)
#'
-#' @description Compare fitted models based on [ELPD][loo-glossary].
+#' @description
+#' **This function is deprecated**. Please use the new [model_compare()] function
+#' instead. See `vignette("migration-guide", package = "loo")` for details.
+#'
+#' `loo_compare()` remains an exported generic so that `loo_compare` methods
+#' registered by other packages keep dispatching as before, but it is frozen at
+#' its previous behavior: it compares `"loo"`, `"waic"`, and `"kfold"` objects on
+#' [ELPD][loo-glossary] only. Comparing
+#' [`pred_measure`][pred_measure] results requires [model_compare()].
+#'
+#' The deprecation warning is issued once per session, so a script that calls
+#' `loo_compare()` repeatedly is not flooded with warnings.
#'
#' @export
#' @param x An object of class `"loo"` or a list of such objects. If a list is
-#' used then the list names will be used as the model names in the output. See
-#' **Examples**.
+#' used then the list names will be used as the model names in the output.
#' @param ... Additional objects of class `"loo"`, if not passed in as a single
#' list.
+#' @return See [model_compare()]. For the inputs `loo_compare()` still accepts,
+#' the result is identical to what [model_compare()] returns.
#'
-#' @return A data frame with class `"compare.loo"` that has its own
-#' print method. See the **Details** and **Examples** sections.
-#'
-#' @details
-#' When comparing two fitted models, we can estimate the difference in their
-#' expected predictive accuracy by the difference in
-#' [`elpd_loo`][loo-glossary] or `elpd_waic` (or multiplied by \eqn{-2}, if
-#' desired, to be on the deviance scale).
-#'
-#' ## `elpd_diff` and `se_diff`
-#' When using `loo_compare()`, the returned data frame will have one row per
-#' model and several columns of estimates. The values of
-#' [`elpd_diff`][loo-glossary] and [`se_diff`][loo-glossary] are computed by
-#' making pairwise comparisons between each model and the model with the
-#' largest ELPD (the model listed first). Therefore, the first `elpd_diff`
-#' value will always be `0` (i.e., the difference between the preferred model
-#' and itself) and the rest of the values will be negative.
-#'
-#' To compute the standard error of the difference in [ELPD][loo-glossary] ---
-#' which should not be expected to equal the difference of the standard errors
-#' --- we use a paired estimate to take advantage of the fact that the same
-#' set of \eqn{N} data points was used to fit both models. These calculations
-#' should be most useful when \eqn{N} is large, because then non-normality of
-#' the distribution is not such an issue when estimating the uncertainty in
-#' these sums. These standard errors, for all their flaws, should give a
-#' better sense of uncertainty than what is obtained using the current
-#' standard approach of comparing differences of deviances to a Chi-squared
-#' distribution, a practice derived for Gaussian linear models or
-#' asymptotically, and which only applies to nested models in any case.
-#'
-#' ## `p_worse`, `diag_diff`, and `diag_elpd`
-#' The values in the `p_worse` column show the probability of each model
-#' having worse ELPD than the best model. These probabilities are computed
-#' with a normal approximation using the values from `elpd_diff` and
-#' `se_diff`. Sivula et al. (2025) present the conditions when the normal
-#' approximation used for SE and `se_diff` is good, and the column
-#' `diag_diff` contains possible diagnostic messages:
-#'
-#' * `N < 100` (small data)
-#' * `|elpd_diff| < 4` (models make similar predictions)
-#'
-#' If either of these diagnostic messages is shown, the error distribution is
-#' skewed or thick tailed and the normal approximation based on `elpd_diff`
-#' and `se_diff` is not well calibrated. In that case, the probabilities
-#' `p_worse` are likely to be too large. However, `elpd_diff` and `se_diff`
-#' will still be indicative of the differences and uncertainties (for example,
-#' if `|elpd_diff|` is many times larger than `se_diff` the difference is quite
-#' certain). In addition, if the model is not well specificed and there are
-#' outliers, the error distribution can also be skewed or thick tailed and the
-#' normal approximation is not well calibrated. Possible model misspecification
-#' and outliers can be diagnosed with usual predictive checking methods.
-#'
-#' The column `diag_elpd` shows the PSIS-LOO Pareto k diagnostic for the
-#' pointwise ELPD computations for each model. If `K k_psis > 0.7` is shown,
-#' where `K` is the number of high Pareto k values in the PSIS
-#' computation, then there may be significant bias in `elpd_diff` favoring
-#' models with a large number of high Pareto k values.
-#'
-#' ## Warnings for many model comparisons
-#' If more than \eqn{11} models are compared, we internally recompute the model
-#' differences using the median model by ELPD as the baseline model. We then
-#' estimate whether the differences in predictive performance are potentially
-#' due to chance as described by McLatchie and Vehtari (2023). This will flag
-#' a warning if it is deemed that there is a risk of over-fitting due to the
-#' selection process. In that case users are recommended to avoid model
-#' selection based on LOO-CV, and instead to favor model averaging/stacking or
-#' projection predictive inference.
-#'
-#' @seealso
-#' * The [FAQ page](https://mc-stan.org/loo/articles/online-only/faq.html) on
-#' the __loo__ website for answers to frequently asked questions.
-#' @template loo-and-compare-references
+#' @seealso [model_compare()]
#'
#' @examples
-#' # very artificial example, just for demonstration!
#' LL <- example_loglik_array()
-#' loo1 <- loo(LL) # should be worst model when compared
-#' loo2 <- loo(LL + 1) # should be second best model when compared
-#' loo3 <- loo(LL + 2) # should be best model when compared
+#' loo1 <- loo(LL)
+#' loo2 <- loo(LL + 1)
#'
-#' comp <- loo_compare(loo1, loo2, loo3)
-#' print(comp, digits = 2)
-#' print(comp, simplify = FALSE) # full table
+#' # deprecated; identical to model_compare(loo1, loo2)
+#' suppressWarnings(loo_compare(loo1, loo2))
#'
-#' # can use a list of objects with custom names
-#' # the names will be used in the output
-#' loo_compare(list("apple" = loo1, "banana" = loo2, "cherry" = loo3))
-#'
-#' \dontrun{
-#' # works for waic (and kfold) too
-#' loo_compare(waic(LL), waic(LL - 10))
-#' }
+#' # use this instead
+#' model_compare(loo1, loo2)
#'
loo_compare <- function(x, ...) {
UseMethod("loo_compare")
@@ -109,355 +41,23 @@ loo_compare <- function(x, ...) {
#' @rdname loo_compare
#' @export
loo_compare.default <- function(x, ...) {
- if (is.loo(x)) {
- dots <- list(...)
- loos <- c(list(x), dots)
- } else {
- if (!is.list(x) || !length(x)) {
- stop("'x' must be a list if not a 'loo' object.")
- }
- if (length(list(...))) {
- stop("If 'x' is a list then '...' should not be specified.")
- }
- loos <- x
- }
-
- # if subsampling is used
- if (any(sapply(loos, inherits, "psis_loo_ss"))) {
- return(loo_compare.psis_loo_ss_list(loos))
- }
-
- # run pre-comparison checks
- loo_compare_checks(loos)
-
- # compute elpd_diff and se_elpd_diff relative to best model
- comp <- loo_compare_matrix(loos)
- ord <- loo_compare_order(loos)
- rnms <- rownames(comp)
- diffs <- mapply(FUN = elpd_diffs, loos[ord[1]], loos[ord])
- colnames(diffs) <- rnms
- elpd_diff <- apply(diffs, 2, sum)
- se_diff <- apply(diffs, 2, se_elpd_diff)
-
- # compute probabilities that a model has worse elpd than the best model
- # using a normal approximation (Sivula et al., 2025)
- p_worse <- stats::pnorm(0, elpd_diff, se_diff)
- p_worse[elpd_diff == 0] <- NA
-
- comp <- cbind(
- data.frame(
- model = rnms,
- elpd_diff = elpd_diff,
- se_diff = se_diff,
- p_worse = p_worse,
- diag_diff = diag_diff(nrow(diffs), elpd_diff),
- diag_elpd = diag_elpd(loos[ord])
- ),
- as.data.frame(comp)
- )
- rownames(comp) <- NULL
-
- # run order statistics-based checks for many model comparisons
- loo_order_stat_check(loos, ord)
-
- class(comp) <- c("compare.loo", class(comp))
- comp
-}
-
-#' @rdname loo_compare
-#' @export
-#' @param digits For the print method only, the number of digits to use when
-#' printing.
-#' @param p_worse For the print method only, should we include the normal
-#' approximation based probability of each model having worse performance than
-#' the best model? The default is `TRUE`.
-#' @param simplify For the print method only, should the output be simplified to
-#' only include the model names, ELPD differences, and (when `p_worse = TRUE`)
-#' diagnostic columns? The default is `TRUE`. Set to `FALSE` to also print the
-#' available estimate columns (pointwise ELPD, LOOIC/WAIC, and their standard
-#' errors).
-print.compare.loo <- function(x, ..., digits = 1, p_worse = TRUE,
- simplify = TRUE) {
- if (inherits(x, "old_compare.loo")) {
- return(unclass(x))
- }
- if (!inherits(x, "data.frame")) {
- class(x) <- c(class(x), "data.frame")
- }
- if (!all(c("model", "elpd_diff", "se_diff") %in% colnames(x))) {
- print(as.data.frame(x))
- return(x)
- }
- base_cols <- c("model", "elpd_diff", "se_diff")
- diag_cols <- c("p_worse", "diag_diff", "diag_elpd")
- show_diag <- p_worse && "p_worse" %in% colnames(x)
-
- estimate_cols <- setdiff(colnames(x), c(base_cols, diag_cols))
- estimate_cols <- estimate_cols[vapply(x[estimate_cols], is.numeric, logical(1))]
-
- cols <- c(
- base_cols,
- if (show_diag) diag_cols,
- if (!simplify) estimate_cols
- )
- cols <- intersect(cols, colnames(x))
-
- x2 <- x[, cols, drop = FALSE]
-
- fmt_cols <- setdiff(cols, c("model", "diag_diff", "diag_elpd"))
- if (length(fmt_cols)) {
- if ("p_worse" %in% fmt_cols) {
- x2$p_worse <- .fr(x2$p_worse, digits = 2)
- fmt_cols <- setdiff(fmt_cols, "p_worse")
- }
- if (length(fmt_cols)) {
- x2[fmt_cols] <- .fr(x2[fmt_cols], digits)
- }
- }
- # Use `as.data.frame(x2)` here to drop "compare.loo"
- # so print() uses print.data.frame.
- print(as.data.frame(x2), quote = FALSE, row.names = FALSE)
-
- # show glossary for diagnostic flags
- has_diag <- any(nzchar(x[["diag_diff"]], keepNA = FALSE), na.rm = TRUE) ||
- any(nzchar(x[["diag_elpd"]], keepNA = FALSE), na.rm = TRUE)
- if (has_diag && p_worse) {
- message(
- "\nDiagnostic flags present.\n",
- "See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)\n",
- "or https://mc-stan.org/loo/reference/loo-glossary.html."
- )
- }
- invisible(x)
-}
-
-
-# internal ----------------------------------------------------------------
-
-#' Compute pointwise elpd differences
-#' @noRd
-#' @param loo_a,loo_b Two `"loo"` objects.
-elpd_diffs <- function(loo_a, loo_b) {
- pt_a <- loo_a$pointwise
- pt_b <- loo_b$pointwise
- elpd <- grep("^elpd", colnames(pt_a))
- pt_b[, elpd] - pt_a[, elpd]
-}
+ .deprecate_once("loo_compare", new = "model_compare")
-#' Compute standard error of the elpd difference
-#' @noRd
-#' @param diffs Vector of pointwise elpd differences
-se_elpd_diff <- function(diffs) {
- N <- length(diffs)
- # As `elpd_diff` is defined as the sum of N independent components,
- # we can compute the standard error by using the standard deviation
- # of the N components and multiplying by `sqrt(N)`.
- sqrt(N) * sd(diffs)
-}
-
-#' Perform checks on `"loo"` objects before comparison
-#' @noRd
-#' @param loos List of `"loo"` objects.
-#' @return Nothing, just possibly throws errors/warnings.
-loo_compare_checks <- function(loos) {
- ## errors
- if (length(loos) <= 1L) {
- stop("'loo_compare' requires at least two models.", call.=FALSE)
- }
- if (!all(sapply(loos, is.loo))) {
- stop("All inputs should have class 'loo'.", call.=FALSE)
- }
-
- Ns <- vapply(loos, function(x) nrow(x$pointwise), integer(1))
- if (any(Ns != Ns[1L])) {
+ loos <- .model_compare_inputs(x, ...)
+ if (any(vapply(loos, is.pred_measure, logical(1)))) {
stop(
- paste0(
- "All models must have the same number of observations, but models have inconsistent observation counts: ",
- paste(paste0("'", find_model_names(loos), "' (", Ns, ")"), collapse = ", ")
- ),
+ "`loo_compare()` compares only 'loo', 'waic', and 'kfold' objects. ",
+ "Use `model_compare()` to compare 'pred_measure' results.",
call. = FALSE
)
}
- ## warnings
-
- yhash <- lapply(loos, attr, which = "yhash")
- yhash_ok <- sapply(yhash, function(x) { # ok only if all yhash are same (all NULL is ok)
- 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)
- }
-
- 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)
- }
- } 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)
- }
+ model_compare(loos)
}
-
-#' Find the model names associated with `"loo"` objects
-#'
+#' @rdname loo_compare
#' @export
-#' @param x List of `"loo"` objects.
-#' @return Character vector of model names the same length as `x.`
-#'
-find_model_names <- function(x) {
- stopifnot(is.list(x))
- out_names <- character(length(x))
-
- names1 <- names(x)
- names2 <- lapply(x, "attr", "model_name", exact = TRUE)
- names3 <- lapply(x, "[[", "model_name")
- names4 <- paste0("model", seq_along(x))
-
- for (j in seq_along(x)) {
- if (isTRUE(nzchar(names1[j]))) {
- out_names[j] <- names1[j]
- } else if (length(names2[[j]])) {
- out_names[j] <- names2[[j]]
- } else if (length(names3[[j]])) {
- out_names[j] <- names3[[j]]
- } else {
- out_names[j] <- names4[j]
- }
- }
- out_names
-}
-
-
-#' Compute the loo_compare matrix
-#' @noRd
-#' @param loos List of `"loo"` objects.
-loo_compare_matrix <- function(loos){
- tmp <- sapply(loos, function(x) {
- est <- x$estimates
- setNames(c(est), nm = c(rownames(est), paste0("se_", rownames(est))))
- })
- colnames(tmp) <- find_model_names(loos)
- rnms <- rownames(tmp)
- comp <- tmp
- ord <- loo_compare_order(loos)
- comp <- t(comp)[ord, ]
- patts <- c("elpd", "p_", "^waic$|^looic$", "^se_waic$|^se_looic$")
- col_ord <- unlist(sapply(patts, function(p) grep(p, colnames(comp))),
- use.names = FALSE)
- comp <- comp[, col_ord]
- comp
-}
-
-#' Computes the order of loos for comparison
-#' @noRd
-#' @param loos List of `"loo"` objects.
-loo_compare_order <- function(loos){
- tmp <- sapply(loos, function(x) {
- est <- x$estimates
- setNames(c(est), nm = c(rownames(est), paste0("se_", rownames(est))))
- })
- colnames(tmp) <- find_model_names(loos)
- rnms <- rownames(tmp)
- ord <- order(tmp[grep("^elpd", rnms), ], decreasing = TRUE)
- ord
-}
-
-#' Perform checks on `"loo"` objects __after__ comparison
-#' @noRd
-#' @param loos List of `"loo"` objects.
-#' @param ord List of `"loo"` object orderings.
-#' @return Nothing, just possibly throws errors/warnings.
-loo_order_stat_check <- function(loos, ord) {
-
- ## breaks
-
- if (length(loos) <= 11L) {
- # procedure cannot be diagnosed for fewer than ten candidate models
- # (total models = worst model + ten candidates)
- # break from function
- return(NULL)
- }
-
- ## warnings
-
- # compute the elpd differences from the median model
- baseline_idx <- middle_idx(ord)
- diffs <- mapply(FUN = elpd_diffs, loos[ord[baseline_idx]], loos[ord])
- elpd_diff <- apply(diffs, 2, sum)
-
- # estimate the standard deviation of the upper-half-normal
- diff_median <- stats::median(elpd_diff)
- elpd_diff_trunc <- elpd_diff[elpd_diff >= diff_median]
- n_models <- sum(!is.na(elpd_diff_trunc))
- candidate_sd <- sqrt(1 / n_models * sum(elpd_diff_trunc^2, na.rm = TRUE))
-
- # estimate expected best diff under null hypothesis
- K <- length(loos) - 1
- order_stat <- order_stat_heuristic(K, candidate_sd)
-
- 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)
- }
-}
-
-#' Returns the middle index of a vector
-#' @noRd
-#' @param vec A vector.
-#' @return Integer index value.
-middle_idx <- function(vec) floor(length(vec) / 2)
-
-#' Computes maximum order statistic from K Gaussians
-#' @noRd
-#' @param K Number of Gaussians.
-#' @param c Scaling of the order statistic.
-#' @return Numeric expected maximum from K samples from a Gaussian with mean
-#' zero and scale `"c"`
-order_stat_heuristic <- function(K, c) {
- qnorm(p = 1 - 1 / (K * 2), mean = 0, sd = c)
-}
-
-#' Count number of high Pareto k values in PSIS-LOO and create diagnostic message
-#' @noRd
-#' @param loos Ordered list of loo objects.
-#' @return Character vector of diagnostic messages.
-diag_elpd <- function(loos) {
- sapply(loos, function(loo) {
- k <- loo$diagnostics[["pareto_k"]]
- if (is.null(k)) {
- out <- ""
- } else {
- S <- dim(loo)[1]
- khat_threshold <- ps_khat_threshold(S)
- K <- sum(k > khat_threshold)
- out <- ifelse(K == 0, "", paste0(K, " k_psis > ", round(khat_threshold, 2)))
- }
- out
- })
-}
-
-#' Create diagnostic for elpd differences
-#' @noRd
-#' @param N Number of data points.
-#' @param elpd_diff Vector of elpd differences.
-#' @return Character vector of diagnostic messages.
-diag_diff <- function(N, elpd_diff) {
- if (N < 100) {
- diag_diff <- rep("N < 100", length(elpd_diff))
- diag_diff[elpd_diff == 0] <- ""
- } else {
- diag_diff <- rep("", length(elpd_diff))
- diag_diff[elpd_diff > -4 & elpd_diff != 0] <- "|elpd_diff| < 4"
- }
- diag_diff
+loo_compare.psis_loo_ss_list <- function(x, ...) {
+ .deprecate_once("loo_compare", new = "model_compare")
+ model_compare.psis_loo_ss_list(x, ...)
}
diff --git a/R/loo_moment_matching.R b/R/loo_moment_matching.R
index 2d14e20b..0df390c8 100644
--- a/R/loo_moment_matching.R
+++ b/R/loo_moment_matching.R
@@ -158,6 +158,9 @@ loo_moment_match.default <- function(x, loo, post_draws, log_lik_i,
attr(loo$psis_object, "norm_const_log") <- matrixStats::colLogSumExps(loo$psis_object$log_weights)
loo$psis_object$diagnostics <- loo$diagnostics
}
+ if (length(I) > 0) {
+ attr(loo, "posthoc") <- union(attr(loo, "posthoc"), "moment_match")
+ }
# combined estimates
cols_to_summarize <- !(colnames(loo$pointwise) %in% c("mcse_elpd_loo",
diff --git a/R/loo_subsample.R b/R/loo_subsample.R
index 4aad6d46..e0a9f5f3 100644
--- a/R/loo_subsample.R
+++ b/R/loo_subsample.R
@@ -24,7 +24,7 @@
#' same length containing the posterior density and the approximation density
#' for the individual draws.
#'
-#' @seealso [loo()], [psis()], [loo_compare()]
+#' @seealso [loo()], [psis()], [loo_compare()], [model_compare()]
#' @template loo-large-data-references
#'
#' @export loo_subsample loo_subsample.function
diff --git a/R/model_compare-pred_measure.R b/R/model_compare-pred_measure.R
new file mode 100644
index 00000000..825454d6
--- /dev/null
+++ b/R/model_compare-pred_measure.R
@@ -0,0 +1,628 @@
+#' Is an object a predictive measure result?
+#' @noRd
+is.pred_measure <- function(x) {
+ inherits(x, "pred_measure")
+}
+
+#' Is an object a PSIS-LOO predictive measure result?
+#' @noRd
+is.loo_pred_measure <- function(x) {
+ inherits(x, "loo_pred_measure")
+}
+
+#' Resolve the shared evaluation source of `pred_measure` inputs
+#'
+#' All models in one comparison must be evaluated the same way: paired
+#' differences between, say, a LOO and a k-fold result would contrast different
+#' held-out schemes rather than the models themselves. Measure names are also
+#' suffixed by source, so mixed inputs share no comparable `pointwise` columns.
+#' @noRd
+#' @param loos List of `"pred_measure"` objects.
+#' @return The shared `source` string: `"loo"`, `"kfold"`, `"test"`, or
+#' `"insample"`.
+.compare_source <- function(loos) {
+ sources <- vapply(loos, function(x) {
+ source <- attr(x, "source")
+ if (is.null(source)) NA_character_ else source
+ }, character(1))
+
+ if (anyNA(sources)) {
+ stop(
+ "All inputs must be results of insample_pred_measure(), ",
+ "loo_pred_measure(), kfold_pred_measure(), or test_pred_measure().",
+ call. = FALSE
+ )
+ }
+ if (any(sources != sources[1L])) {
+ labels <- unique(vapply(loos, .pred_measure_source_label, character(1)))
+ stop(
+ paste0(
+ "All models must be evaluated on the same source, but got: ",
+ paste(labels, collapse = ", "),
+ ". Recompute all models with the same *_pred_measure() function."
+ ),
+ call. = FALSE
+ )
+ }
+ unname(sources[1L])
+}
+
+#' Warn that in-sample comparisons are optimistically biased
+#' @noRd
+throw_insample_compare_warning <- function(source) {
+ if (!identical(source, "insample")) {
+ return(invisible(NULL))
+ }
+ warning(
+ "Comparing in-sample predictive measures. In-sample scores are ",
+ "optimistically biased and favor more complex models. For out-of-sample ",
+ "comparison use loo_pred_measure(), kfold_pred_measure(), or ",
+ "test_pred_measure().",
+ call. = FALSE
+ )
+ invisible(NULL)
+}
+
+#' Compare `loo_pred_measure` objects (multi-measure path)
+#' @noRd
+#' @param loos List of `pred_measure` objects, all sharing one evaluation
+#' source.
+compare_pred_measure <- function(loos) {
+ source <- .compare_source(loos)
+ model_compare_checks(
+ loos,
+ class_check = is.pred_measure,
+ class_msg = "All inputs must have class 'pred_measure'.",
+ kfold_checks = FALSE
+ )
+ throw_insample_compare_warning(source)
+ if (identical(source, "kfold")) {
+ throw_kfold_K_mismatch_warning(loos)
+ throw_kfold_folds_mismatch_warning(loos)
+ }
+ .compare_metadata_check(loos)
+ throw_omitted_compare_measures_warning(loos)
+
+ rank_measure <- .resolve_rank_measure(loos)
+ compare_cols <- .compare_pointwise_cols(loos)
+ custom_se_diffs <- .resolve_custom_se_diffs(loos, compare_cols)
+ ord <- model_compare_order(loos, rank_measure$internal)
+ loos_ord <- loos[ord]
+
+ comp <- model_compare_matrix(
+ loos_ord,
+ bare_names = TRUE,
+ ord = seq_along(loos_ord)
+ )
+ rnms <- rownames(comp)
+ n_obs <- nrow(loos_ord[[1L]]$pointwise)
+
+ diff_cols <- list()
+ ref_models <- character(0)
+ for (col in compare_cols) {
+ bare <- .display_name(col, loos_ord)
+ ref_idx <- model_compare_order(loos_ord, col)[[1L]]
+ ref_loo <- loos_ord[[ref_idx]]
+ ref_models[[bare]] <- rnms[[ref_idx]]
+ method <- .measure_pointwise_diff_method(loos_ord, col)
+ se_fn <- if (identical(method, "custom")) custom_se_diffs[[bare]] else NULL
+ if (is.character(se_fn)) {
+ .check_declared_aggregation(loos_ord, col, se_fn)
+ }
+ pair_stats <- vapply(
+ loos_ord,
+ .pair_measure_stats,
+ FUN.VALUE = c(diff = 0, se = 0),
+ ref = ref_loo,
+ col = col,
+ method = method,
+ loos = loos_ord,
+ se_fn = se_fn
+ )
+ measure_diff <- pair_stats["diff", ]
+ measure_se <- pair_stats["se", ]
+
+ if (.is_elpd_measure(col)) {
+ diff_cols$elpd_diff <- measure_diff
+ diff_cols$se_diff <- measure_se
+ p_worse <- stats::pnorm(0, measure_diff, measure_se)
+ p_worse[measure_diff == 0] <- NA_real_
+ diff_cols$p_worse <- p_worse
+ diff_cols$diag_diff <- diag_diff(n_obs, measure_diff)
+ } else {
+ diff_cols[[paste0(bare, "_diff")]] <- measure_diff
+ diff_cols[[paste0(bare, "_se_diff")]] <- measure_se
+ }
+ }
+
+ model_cols <- data.frame(
+ model = rnms,
+ diff_cols,
+ stringsAsFactors = FALSE
+ )
+ if (identical(source, "loo")) {
+ model_cols$diag_elpd <- diag_elpd(loos_ord)
+ }
+
+ comp <- cbind(model_cols, as.data.frame(comp))
+ rownames(comp) <- NULL
+
+ model_order_stat_check(
+ loos_ord,
+ seq_along(loos_ord),
+ rank_col = rank_measure$internal
+ )
+
+ attr(comp, "compare_reference") <- ref_models
+ attr(comp, "compare_source") <- source
+ attr(comp, "compare_K") <- if (identical(source, "kfold")) {
+ Ks <- unlist(lapply(loos, attr, which = "K"))
+ if (length(Ks) == length(loos) && all(Ks == Ks[[1L]])) unname(Ks[[1L]])
+ }
+ attr(comp, "compare_N") <- n_obs
+ attr(comp, "compare_measures") <- .compare_measures(loos)
+ attr(comp, "sign_converted_measures") <- .compare_sign_converted_measures(
+ compare_cols,
+ loos
+ )
+ class(comp) <- c("compare.loo", class(comp))
+ comp
+}
+
+#' Common `pointwise` columns across models, excluding complexity terms
+#' @noRd
+.compare_pointwise_cols <- function(loos) {
+ cols <- Reduce(
+ intersect,
+ lapply(loos, function(x) colnames(x$pointwise))
+ )
+ cols <- cols[!cols %in% c("p_loo", "p_waic", "p_kfold")]
+ bare <- vapply(cols, .display_name, character(1), loos = loos)
+ cols[order(bare != "elpd", bare, method = "radix")]
+}
+
+#' Check that `measure_info` is consistent across models
+#' @noRd
+.compare_metadata_check <- function(loos) {
+ bare_measures <- .compare_measures(loos)
+ if (!length(bare_measures)) {
+ return(invisible(NULL))
+ }
+
+ for (bare in bare_measures) {
+ infos <- lapply(loos, function(x) {
+ measure_info <- attr(x, "measure_info")
+ if (is.null(measure_info)) {
+ return(NULL)
+ }
+ measure_info[[bare]]
+ })
+ has_info <- !vapply(infos, is.null, logical(1))
+ if (!all(has_info)) {
+ stop(
+ if (any(has_info)) "Not all models provide" else "No model provides",
+ " `measure_info` for measure '",
+ bare,
+ "'. Recompute all inputs with the current version of `loo_pred_measure()`.",
+ call. = FALSE
+ )
+ }
+ non_null <- lapply(infos[has_info], function(info) {
+ info$extra <- NULL
+ info
+ })
+ if (length(non_null) > 1L) {
+ ref <- non_null[[1L]]
+ inconsistent <- vapply(
+ non_null[-1L],
+ function(info) !identical(info, ref),
+ logical(1)
+ )
+ if (any(inconsistent)) {
+ stop(
+ "Models disagree on `measure_info` for measure '",
+ bare,
+ "'. For a custom measure, ensure all models use the same ",
+ "`measure_loss` and `measure_se_diff` declarations.",
+ call. = FALSE
+ )
+ }
+ }
+ }
+
+ invisible(NULL)
+}
+
+#' Warn when models do not share the same predictive measures
+#' @noRd
+throw_omitted_compare_measures_warning <- function(loos) {
+ model_names <- find_model_names(loos)
+ if (anyDuplicated(model_names)) {
+ model_names <- make.unique(model_names, sep = "_")
+ }
+ by_model <- stats::setNames(
+ lapply(loos, function(x) {
+ cols <- colnames(x$pointwise)
+ cols <- cols[!cols %in% c("p_loo", "p_waic", "p_kfold")]
+ unname(vapply(cols, .display_name, character(1), loos = loos))
+ }),
+ model_names
+ )
+ common <- Reduce(intersect, by_model)
+ omitted <- setdiff(unique(unlist(by_model)), common)
+ if (!length(omitted)) {
+ return(invisible(NULL))
+ }
+ omitted <- sort(omitted)
+
+ omitted_detail <- vapply(
+ omitted,
+ function(measure) {
+ present <- names(by_model)[vapply(
+ by_model,
+ function(measures) measure %in% measures,
+ logical(1)
+ )]
+ paste0(measure, " (", paste(present, collapse = ", "), ")")
+ },
+ character(1)
+ )
+
+ warning(
+ paste0(
+ "Omitted measures: ",
+ paste(omitted_detail, collapse = ", "),
+ ". Compared: ",
+ paste(common, collapse = ", "),
+ "."
+ ),
+ call. = FALSE
+ )
+}
+
+#' Bare measure names available for comparison across models
+#' @noRd
+.compare_measures <- function(loos) {
+ cols <- .compare_pointwise_cols(loos)
+ unname(vapply(cols, .display_name, character(1), loos = loos))
+}
+
+#' Bare and internal `pointwise` column names of the ranking measure
+#' @noRd
+.resolve_rank_measure <- function(loos) {
+ cols <- .compare_pointwise_cols(loos)
+ if (!length(cols)) {
+ stop("No measure is shared by all models.", call. = FALSE)
+ }
+ internal <- cols[1L]
+ list(
+ bare = .display_name(internal, loos),
+ internal = internal
+ )
+}
+
+#' Is a measure an ELPD-family measure (for `p_worse` / `diag_diff`)?
+#'
+#' Matches on the raw column name: every source suffix (`elpd_loo`,
+#' `elpd_kfold`, `elpd_test`, bare `elpd`) shares the `elpd` prefix, so no
+#' suffix stripping is needed here.
+#' @noRd
+.is_elpd_measure <- function(name) {
+ grepl("^elpd", name)
+}
+
+#' Look up the per-measure information recorded on a result object
+#' @noRd
+.get_measure_info <- function(loos, bare) {
+ measure_info <- attr(loos[[1L]], "measure_info")
+ if (is.null(measure_info)) {
+ return(NULL)
+ }
+ measure_info[[bare]]
+}
+
+#' Names of the built-in measures that are losses (lower is better)
+#' @noRd
+.builtin_loss_measures <- function() {
+ names(Filter(function(spec) isTRUE(spec$loss), .measure_spec))
+}
+
+#' Whether a measure is a loss (lower is better)
+#'
+#' Measure values are always stored on the measure's own scale, so this equally
+#' describes the measure and the values recorded for it.
+#' @noRd
+.measure_is_loss <- function(name, loos = NULL) {
+ bare <- .display_name(name, loos)
+
+ if (!is.null(loos)) {
+ info <- .get_measure_info(loos, bare)
+ if (!is.null(info) && !is.null(info$loss)) {
+ return(isTRUE(info$loss))
+ }
+ }
+
+ spec <- .measure_spec[[bare]]
+ if (!is.null(spec)) {
+ return(isTRUE(spec$loss))
+ }
+ bare %in% .builtin_loss_measures()
+}
+
+#' Bare names of measures whose sign is flipped for `model_compare()`
+#' @noRd
+.compare_sign_converted_measures <- function(cols, loos) {
+ bare <- vapply(cols, .display_name, character(1), loos = loos)
+ unique(bare[vapply(
+ cols,
+ function(col) .measure_is_loss(col, loos),
+ logical(1)
+ )])
+}
+
+#' How to aggregate paired pointwise differences for a measure
+#'
+#' Taken from the measure's stored `measure_info`: `"sum"` or `"mean"` when
+#' the overall estimate is the sum or the mean of its pointwise contributions,
+#' `"measure_specific"` when the built-in measure supplies its own
+#' `se_diff_fun`, and `"custom"` for custom measures, whose standard error
+#' comes from their `measure_se_diff` declaration.
+#' Nothing is inferred. Every compared measure carries a `diff_method`;
+#' `.compare_metadata_check()` has already rejected the inputs otherwise, so the
+#' `elpd`/`ic` branch below only covers direct internal calls.
+#' @noRd
+.measure_pointwise_diff_method <- function(loos, col) {
+ bare <- .display_name(col, loos)
+ info <- .get_measure_info(loos, bare)
+ if (!is.null(info) && !is.null(info$diff_method)) {
+ return(info$diff_method)
+ }
+
+ if (.is_elpd_measure(col) || bare == "ic") {
+ return("sum")
+ }
+
+ stop(
+ "No `measure_info` for measure '",
+ bare,
+ "'. Recompute all inputs with the current version of `loo_pred_measure()`.",
+ call. = FALSE
+ )
+}
+
+#' Check that a declared `"sum"`/`"mean"` aggregation matches the estimate
+#'
+#' Only called when a custom measure declares `measure_se_diff = "sum"` or
+#' `"mean"`. This is the computation `.measure_pointwise_diff_method()`
+#' used to run as autodetection, inverted: rather than guessing the aggregation,
+#' it verifies the one the user asserted.
+#' @noRd
+.check_declared_aggregation <- function(loos, col, method) {
+ ref <- loos[[1L]]
+ est <- ref$estimates[col, "Estimate"]
+ pw <- ref$pointwise[, col, drop = TRUE]
+ agg <- if (identical(method, "sum")) sum(pw) else mean(pw)
+
+ ok <- length(pw) > 0L && is.finite(est) && is.finite(agg)
+ if (ok) {
+ tol <- sqrt(.Machine$double.eps) * max(abs(c(est, pw)), na.rm = TRUE)
+ ok <- isTRUE(all.equal(est, agg, tolerance = tol, check.attributes = FALSE))
+ }
+ if (!ok) {
+ warning(
+ "`measure_se_diff = \"", method, "\"` was declared for measure '",
+ .display_name(col, loos), "', but ", method,
+ "(pointwise) does not reproduce its estimate.\n",
+ "The reported standard error may be wrong.",
+ call. = FALSE
+ )
+ }
+ invisible(NULL)
+}
+
+#' Resolve a built-in measure's `se_diff_fun`
+#'
+#' Built-in measures with `diff_method = "measure_specific"` name an entry of
+#' `.se_diff_funs`. Custom measures never reach this; their standard error comes
+#' from their `measure_se_diff` declaration, see `.resolve_custom_se_diffs()`.
+#' @noRd
+.measure_se_diff_fun <- function(loos, col) {
+ bare <- .display_name(col, loos)
+ info <- .get_measure_info(loos, bare)
+
+ fun <- info$se_diff_fun
+ if (is.null(fun)) {
+ fun <- .measure_spec[[bare]]$se_diff_fun
+ }
+ if (is.character(fun)) {
+ fun <- .se_diff_funs[[fun]]
+ }
+ if (!is.function(fun)) {
+ stop(
+ paste0(
+ "No 'se_diff_fun' available for measure '", bare, "'."
+ ),
+ call. = FALSE
+ )
+ }
+ fun
+}
+
+#' Accepted string shorthands for `measure_se_diff`
+#' @noRd
+.se_diff_keywords <- c("sum", "mean")
+
+#' Validate one `measure_se_diff` value
+#' @noRd
+#' @param origin Where the value came from, in the words the user knows it by.
+#' @return The value itself, or `NULL`.
+.check_se_diff_value <- function(value, bare, origin = "`se_diff_fun`") {
+ if (is.null(value) || is.function(value)) {
+ return(value)
+ }
+ if (is.character(value) && length(value) == 1L &&
+ value %in% .se_diff_keywords) {
+ return(value)
+ }
+ stop(
+ "Invalid ", origin, " for custom measure '", bare,
+ "'. It must be a function, ",
+ paste0("\"", .se_diff_keywords, "\"", collapse = " or "),
+ ", or NULL; see custom_measure().",
+ call. = FALSE
+ )
+}
+
+#' Inform about custom measures that declare no standard error of the difference
+#'
+#' The difference is still reported; only its standard error is `NA`.
+#' @noRd
+inform_missing_custom_se_diff <- function(bare) {
+ message(
+ if (length(bare) == 1L) "Custom measure " else "Custom measures ",
+ paste(bare, collapse = ", "),
+ if (length(bare) == 1L) " declares" else " declare",
+ " no `se_diff_fun`, so ",
+ paste0(bare, "_se_diff", collapse = ", "),
+ if (length(bare) == 1L) " is" else " are",
+ " NA.\nDeclare it with `custom_measure(se_diff_fun = )`."
+ )
+ invisible(NULL)
+}
+
+#' Look up the declared standard error of the difference for custom measures
+#'
+#' Custom measures carry `diff_method = "custom"`. A measure declares the
+#' standard error of its difference with `custom_measure(se_diff_fun = )`, stored
+#' in `measure_info` as `se_diff_fun`. A measure that declares nothing gets an
+#' `NA` standard error.
+#' @noRd
+#' @return Named list keyed by bare measure name; each element is a function,
+#' `"sum"`, `"mean"`, or `NULL`.
+.resolve_custom_se_diffs <- function(loos, compare_cols) {
+ is_custom <- vapply(
+ compare_cols,
+ function(col) {
+ identical(.measure_pointwise_diff_method(loos, col), "custom")
+ },
+ logical(1)
+ )
+ custom_bare <- unname(vapply(
+ compare_cols[is_custom],
+ .display_name,
+ character(1),
+ loos = loos
+ ))
+
+ if (!length(custom_bare)) {
+ return(list())
+ }
+
+ declared <- stats::setNames(
+ lapply(custom_bare, function(bare) {
+ .get_measure_info(loos, bare)$se_diff_fun
+ }),
+ custom_bare
+ )
+ missing_decl <- custom_bare[vapply(declared, is.null, logical(1))]
+ if (length(missing_decl)) {
+ inform_missing_custom_se_diff(missing_decl)
+ }
+ declared
+}
+
+#' Assemble one model's inputs for an `se_diff_fun`
+#'
+#' Every element describes the single model `x`, on the measure's natural scale,
+#' including `extra`, which is read from that model's own `measure_info` rather
+#' than the reference model's.
+#' @noRd
+.se_diff_input <- function(x, col) {
+ list(
+ estimate = x$estimates[col, "Estimate"],
+ se = x$estimates[col, "SE"],
+ pointwise = x$pointwise[, col, drop = TRUE],
+ extra = .get_measure_info(list(x), .display_name(col, list(x)))$extra
+ )
+}
+
+#' Validate the value returned by an `se_diff_fun`
+#' @noRd
+#' @param what Name of the argument or attribute the function came from, used
+#' only to make the error point at what the user can change.
+.validate_se_diff <- function(se, col, loos = NULL, what = "se_diff_fun") {
+ if (!is.numeric(se) || length(se) != 1L) {
+ stop(
+ paste0(
+ "The `", what, "` for measure '", .display_name(col, loos),
+ "' must return a numeric scalar."
+ ),
+ call. = FALSE
+ )
+ }
+ unname(se)
+}
+
+#' Paired measure difference and SE for one model vs a reference
+#' @noRd
+#' @param se_fn For `method = "custom"` only: the measure's declared
+#' `measure_se_diff`. A function, the string
+#' `"sum"` or `"mean"`, or `NULL` for an `NA` standard error.
+.pair_measure_stats <- function(cmp, ref, col, method = NULL, loos = list(ref),
+ se_fn = NULL) {
+ if (is.null(method)) {
+ method <- .measure_pointwise_diff_method(c(list(ref, cmp)), col)
+ }
+
+ flip <- .measure_is_loss(col, loos)
+ est_utility <- function(estimates) {
+ val <- estimates[col, "Estimate"]
+ if (flip) -val else val
+ }
+
+ if (method == "custom") {
+ if (is.character(se_fn)) {
+ method <- se_fn
+ } else {
+ diff <- est_utility(cmp$estimates) - est_utility(ref$estimates)
+ if (is.null(se_fn)) {
+ return(c(diff = diff, se = NA_real_))
+ }
+ se <- se_fn(
+ ref = .se_diff_input(ref, col),
+ cmp = .se_diff_input(cmp, col)
+ )
+ return(c(
+ diff = diff,
+ se = .validate_se_diff(se, col, loos)
+ ))
+ }
+ }
+
+ if (method == "measure_specific") {
+ se_diff_fun <- .measure_se_diff_fun(loos, col)
+ se <- se_diff_fun(
+ ref = .se_diff_input(ref, col),
+ cmp = .se_diff_input(cmp, col)
+ )
+ return(c(
+ diff = est_utility(cmp$estimates) - est_utility(ref$estimates),
+ se = .validate_se_diff(se, col, loos)
+ ))
+ }
+
+ to_utility <- function(pointwise) {
+ x <- pointwise[, col, drop = TRUE]
+ if (flip) -x else x
+ }
+ diffs <- to_utility(cmp$pointwise) - to_utility(ref$pointwise)
+
+ diff <- if (method == "sum") sum(diffs) else mean(diffs)
+ se <- if (method == "sum") {
+ se_elpd_diff(diffs)
+ } else {
+ N <- length(diffs)
+ if (N <= 1L) 0 else stats::sd(diffs) / sqrt(N)
+ }
+ c(diff = diff, se = se)
+}
diff --git a/R/model_compare-print.R b/R/model_compare-print.R
new file mode 100644
index 00000000..83d433f8
--- /dev/null
+++ b/R/model_compare-print.R
@@ -0,0 +1,523 @@
+#' @rdname model_compare
+#' @export
+#' @param digits For the print method only, the number of decimal places to
+#' print. The default `NULL` gives each measure its own: 1 for `elpd` and
+#' `ic`, and 3 for `mlpd` and for the bounded measures (`r2`, `acc`, `bacc`,
+#' `brier`). A measure on the scale of the data (`mae`, `rmse`, `mse`, `rps`,
+#' `srps`, and any custom measure) takes the places that show two significant
+#' digits of its own standard error, at most 4.
+#' Pass a single number for one format in every column, or a named vector
+#' such as `c(r2 = 2, rmse = 3)` to override single measures. `p_worse`
+#' always prints with 2 places.
+#' @param p_worse For the print method only, should we include the normal
+#' approximation based probability of each model having worse performance than
+#' the reference model? The default is `TRUE`.
+#' @param simplify For the print method only, should the output be simplified to
+#' only include the model names, differences, and (when `p_worse = TRUE`)
+#' diagnostic columns? The default is `TRUE`. Set to `FALSE` to also print the
+#' available estimate columns: pointwise ELPD, LOOIC/WAIC and their standard
+#' errors for classic comparisons. For [`pred_measure`][pred_measure]
+#' comparisons each printed table gains the estimate and standard error of
+#' its own measure, and an ELPD table also gains `p` and `se_p`. With the
+#' default `measures = NULL` one table is printed, and it gains the estimates
+#' of every compared measure. The difference columns are never added.
+#' @param measures For `pred_measure` comparisons only, which measures to
+#' print diff tables for. `NULL` (default) prints only the ranking measure
+#' (the first compared measure, `"elpd"` when present);
+#' `"all"` prints all compared measures; or a character vector of measure
+#' names (e.g. `c("elpd", "mse")`). Each table is sorted by its own measure,
+#' best model first, so the same model need not lead every table.
+print.compare.loo <- function(x, ..., digits = NULL, p_worse = TRUE,
+ simplify = TRUE, measures = NULL) {
+ if (inherits(x, "old_compare.loo")) {
+ return(unclass(x))
+ }
+ if (!inherits(x, "data.frame")) {
+ class(x) <- c(class(x), "data.frame")
+ }
+
+ compare_measures <- attr(x, "compare_measures")
+ if (!is.null(compare_measures)) {
+ return(.print_compare_pred_measure(
+ x,
+ digits = digits,
+ p_worse = p_worse,
+ simplify = simplify,
+ measures = measures
+ ))
+ }
+
+ if (!is.null(measures) && !all(measures %in% c("elpd", "all"))) {
+ warning("`measures` is ignored for comparisons of 'loo' objects, ",
+ "which contain only elpd.", call. = FALSE)
+ }
+
+ if (!all(c("model", "elpd_diff", "se_diff") %in% colnames(x))) {
+ print(as.data.frame(x))
+ return(x)
+ }
+ base_cols <- c("model", "elpd_diff", "se_diff", "subsampling_se_diff")
+ diag_cols <- c("p_worse", "diag_diff", "diag_elpd")
+ show_diag <- p_worse && "p_worse" %in% colnames(x)
+
+ estimate_cols <- setdiff(colnames(x), c(base_cols, diag_cols))
+ estimate_cols <- estimate_cols[vapply(x[estimate_cols], is.numeric, logical(1))]
+
+ cols <- c(
+ base_cols,
+ if (show_diag) diag_cols,
+ if (!simplify) estimate_cols
+ )
+ cols <- intersect(cols, colnames(x))
+
+ x2 <- x[, cols, drop = FALSE]
+
+ fmt_cols <- setdiff(cols, c("model", "diag_diff", "diag_elpd"))
+ if (length(fmt_cols)) {
+ d <- .resolve_digits(digits, "elpd", x$se_diff)
+ if ("p_worse" %in% fmt_cols) {
+ x2$p_worse <- .fr(x2$p_worse, digits = 2)
+ fmt_cols <- setdiff(fmt_cols, "p_worse")
+ }
+ if (length(fmt_cols)) {
+ x2[fmt_cols] <- .fr(x2[fmt_cols], d)
+ }
+ }
+ # Use `as.data.frame(x2)` here to drop "compare.loo"
+ # so print() uses print.data.frame.
+ print(as.data.frame(x2), quote = FALSE, row.names = FALSE)
+
+ .print_compare_diag_message(x, p_worse = p_worse)
+ invisible(x)
+}
+
+#' Print `compare.loo` results from `pred_measure` comparisons
+#' @noRd
+.print_compare_pred_measure <- function(x, digits, p_worse, simplify,
+ measures) {
+ compare_measures <- attr(x, "compare_measures")
+ compare_source <- attr(x, "compare_source")
+ primary_measure <- compare_measures[[1L]]
+
+ measures_to_print <- if (is.null(measures)) {
+ primary_measure
+ } else if (identical(measures, "all")) {
+ compare_measures
+ } else {
+ measures
+ }
+
+ unknown <- setdiff(measures_to_print, compare_measures)
+ if (length(unknown)) {
+ stop(
+ paste0(
+ "Unknown measure(s) in `measures`: ",
+ paste(unknown, collapse = ", "),
+ ". Available measures: ",
+ paste(compare_measures, collapse = ", ")
+ ),
+ call. = FALSE
+ )
+ }
+
+ if (identical(measures, "all") && length(compare_measures) > 4L) {
+ message(
+ "Printing ", length(compare_measures), " measure comparisons; ",
+ "consider `measures = c(...)`."
+ )
+ }
+
+ .cat_wrapped(
+ .compare_reference_line(x, compare_measures)
+ )
+
+ if (!is.null(compare_source) && !identical(compare_source, "loo")) {
+ .cat_wrapped(
+ "Predictive measures evaluated on ",
+ .compare_source_phrase(x, compare_source),
+ "."
+ )
+ }
+
+ psis_shown <- .print_psis_diag_block(x)
+ if (psis_shown && is.null(measures)) {
+ cat("\n")
+ }
+
+ flipped <- attr(x, "sign_converted_measures")
+ for (measure in measures_to_print) {
+ if (!is.null(measures)) {
+ cat(
+ "\n-- ", measure, " (vs ", .measure_ref_model(x, measure),
+ if (measure %in% flipped) ", sign flipped", ") --\n",
+ sep = ""
+ )
+ }
+ .print_compare_measure_table(
+ x,
+ measure = measure,
+ digits = digits,
+ p_worse = p_worse,
+ simplify = simplify,
+ all_estimates = is.null(measures)
+ )
+ }
+
+ .print_sign_flip_note(intersect(measures_to_print, flipped))
+
+ has_diag_msg <- .print_compare_diag_message(
+ x,
+ p_worse = p_worse,
+ measures = measures_to_print
+ )
+
+ if (is.null(measures)) {
+ other <- setdiff(compare_measures, primary_measure)
+ if (length(other)) {
+ # The per-measure references are named in the header line, so this only
+ # has to say which measures exist and how to see them.
+ message(
+ if (has_diag_msg) "\n",
+ "Use print(x, measures = \"all\") to see all measures."
+ )
+ }
+ }
+
+ invisible(x)
+}
+
+#' Name the source a comparison was evaluated on
+#'
+#' The fold count and the number of held-out observations tell the reader how
+#' much data each estimate rests on, so they are named where the source is.
+#' Either falls back to the plain phrase when the number is unknown.
+#' @noRd
+.compare_source_phrase <- function(x, source) {
+ switch(
+ source,
+ kfold = {
+ K <- attr(x, "compare_K")
+ paste0(if (is.null(K)) "K" else K, "-fold cross-validation")
+ },
+ test = {
+ n <- attr(x, "compare_N")
+ paste0(
+ "held-out test data",
+ if (is.null(n)) "" else paste0(" (N = ", n, ")")
+ )
+ },
+ insample = "in-sample (training) data",
+ source
+ )
+}
+
+#' Header line naming the reference each difference is computed against
+#'
+#' Always printed, so the reference is never left implicit. Each measure keeps
+#' its own best model as reference.
+#' @noRd
+#' @param x A `"compare.loo"` data frame.
+#' @param compare_measures Bare names of all compared measures.
+#' @return A single string.
+.compare_reference_line <- function(x, compare_measures) {
+ refs <- vapply(compare_measures, .measure_ref_model, character(1), x = x)
+ if (length(compare_measures) == 1L) {
+ return(paste0(
+ "Models ranked by ", compare_measures, " (reference: ", refs, ")."
+ ))
+ }
+ if (length(compare_measures) > 4L) {
+ return(paste0(
+ "Each measure compared against its own best model (",
+ compare_measures[[1L]], ": ", refs[[1L]], ", ...)."
+ ))
+ }
+ paste0(
+ "Each measure compared against its own best model (",
+ paste0(compare_measures, ": ", refs, collapse = ", "),
+ ")."
+ )
+}
+
+#' Split `diag_elpd` entries into their count and threshold
+#' @noRd
+#' @param flags Character vector of `diag_elpd` values, such as
+#' `"25 k_psis > 0.62"`.
+#' @return Data frame with numeric `bad_k` and `threshold`, both `NA` for an
+#' entry that does not match, so an unrecognised value is passed through
+#' rather than silently dropped.
+.parse_diag_psis <- function(flags) {
+ parts <- regmatches(flags, regexec("^([0-9]+) k_psis > ([0-9.]+)$", flags))
+ field <- function(i) {
+ vapply(
+ parts,
+ function(p) if (length(p) == 3L) as.numeric(p[[i]]) else NA_real_,
+ numeric(1)
+ )
+ }
+ data.frame(bad_k = field(2L), threshold = field(3L))
+}
+
+#' Print prose wrapped to the conventional 80-column terminal width
+#'
+#' Tables are wrapped by `print.data.frame()` at `getOption("width")`; this does
+#' the same for the sentences around them, capped at 80 so the output stays
+#' within a standard terminal however wide the option is set.
+#' @noRd
+#' @param ... Pieces of a single line, pasted together.
+.cat_wrapped <- function(...) {
+ width <- min(getOption("width", 80L), 80L)
+ cat(paste(strwrap(paste0(...), width = width), collapse = "\n"), "\n", sep = "")
+}
+
+#' Explain the sign of the differences when a printed measure is a loss
+#' @noRd
+#' @param flipped Bare names of the printed measures with a flipped sign.
+.print_sign_flip_note <- function(flipped) {
+ if (!length(flipped)) {
+ return(invisible(FALSE))
+ }
+ cat("\n")
+ .cat_wrapped("All differences: 0 = best model, negative = worse.")
+ .cat_wrapped(
+ "Signs flipped for loss measures: ", paste(flipped, collapse = ", "), "."
+ )
+ invisible(TRUE)
+}
+
+#' Describe how many of the compared models a flag applies to
+#' @noRd
+#' @param n Number of flagged models.
+#' @param total Number of compared models.
+#' @return A string such as `"2 of 3 models"`, `"all 3 models"`, or
+#' `"both models"`.
+.n_of_models <- function(n, total) {
+ if (n < total) {
+ return(paste0(n, " of ", total, " models"))
+ }
+ if (total == 2L) "both models" else paste0("all ", total, " models")
+}
+
+#' Print the PSIS-LOO diagnostics block
+#'
+#' Pareto \eqn{\hat{k}} describes a model's PSIS-LOO approximation, not any one
+#' measure and not the comparison, so it is reported once per model above the
+#' per-measure difference tables. Nothing is printed when no model is flagged,
+#' or for sources other than LOO, which carry no `diag_elpd` column.
+#' @noRd
+#' @param x A `"compare.loo"` data frame.
+#' @return `TRUE` invisibly when a block was printed.
+.print_psis_diag_block <- function(x) {
+ col <- x[["diag_elpd"]]
+ if (is.null(col)) {
+ return(invisible(FALSE))
+ }
+ flagged <- !is.na(col) & nzchar(col, keepNA = FALSE)
+ if (!any(flagged)) {
+ return(invisible(FALSE))
+ }
+
+ n_models <- length(col)
+ models <- x$model[flagged]
+ parsed <- .parse_diag_psis(col[flagged])
+
+ # An unparsed entry has no count to sort or tabulate by, so fall back to the
+ # stored strings rather than inventing numbers for them.
+ if (anyNA(parsed$bad_k)) {
+ .cat_wrapped(
+ "PSIS-LOO unreliable for ", .n_of_models(length(models), n_models),
+ "; measures may be biased."
+ )
+ print(
+ data.frame(
+ model = models,
+ diag_elpd = col[flagged],
+ stringsAsFactors = FALSE
+ ),
+ quote = FALSE,
+ row.names = FALSE
+ )
+ return(invisible(TRUE))
+ }
+
+ ord <- order(parsed$bad_k, decreasing = TRUE)
+ models <- models[ord]
+ parsed <- parsed[ord, , drop = FALSE]
+ # Thresholds depend on the number of draws, so models need not share one.
+ common <- length(unique(parsed$threshold)) == 1L
+
+ if (length(models) == 1L) {
+ .cat_wrapped(
+ "PSIS-LOO unreliable for ", models, " (", parsed$bad_k,
+ " obs, k_psis > ", parsed$threshold, "); measures may be biased."
+ )
+ return(invisible(TRUE))
+ }
+
+ .cat_wrapped(
+ "PSIS-LOO unreliable for ", .n_of_models(length(models), n_models),
+ if (common) paste0(" (k_psis > ", parsed$threshold[[1L]], ")") else "",
+ "; measures may be biased."
+ )
+ block <- data.frame(
+ model = models,
+ bad_k = parsed$bad_k,
+ stringsAsFactors = FALSE
+ )
+ if (!common) {
+ block$k_psis_threshold <- parsed$threshold
+ }
+ print(block, quote = FALSE, row.names = FALSE)
+ invisible(TRUE)
+}
+
+#' Print one measure's comparison table
+#' @noRd
+.print_compare_measure_table <- function(
+ x, measure, digits, p_worse, simplify = TRUE, all_estimates = FALSE
+) {
+ if (.is_elpd_measure(measure)) {
+ diff_col <- "elpd_diff"
+ se_col <- "se_diff"
+ diff_name <- "elpd_diff"
+ se_name <- "se_diff"
+ } else {
+ diff_col <- paste0(measure, "_diff")
+ se_col <- paste0(measure, "_se_diff")
+ diff_name <- diff_col
+ # Print the column name the object actually carries, so the header matches
+ # `comp$mae_se_diff` and names the measure an NA belongs to.
+ se_name <- se_col
+ }
+
+ if (!all(c(diff_col, se_col) %in% colnames(x))) {
+ stop(
+ "Comparison columns for measure '", measure, "' are missing.",
+ call. = FALSE
+ )
+ }
+
+ # The data frame carries one row order for all measures (by the first), but a
+ # measure's own best model need not be first in it. Sort each printed table by
+ # its own difference so the best model is always the first row and the
+ # differences run in decreasing order.
+ ord <- order(x[[diff_col]], decreasing = TRUE, na.last = TRUE)
+ d <- .resolve_digits(digits, measure, x[[se_col]])
+ x2 <- data.frame(
+ model = x$model[ord],
+ diff = unname(.fr(x[[diff_col]][ord], d)),
+ se_diff = unname(.fr(x[[se_col]][ord], d)),
+ check.names = FALSE,
+ stringsAsFactors = FALSE
+ )
+ names(x2)[2:3] <- c(diff_name, se_name)
+
+ if (.is_elpd_measure(measure) && p_worse && "p_worse" %in% colnames(x)) {
+ x2$p_worse <- unname(.fr(x[["p_worse"]][ord], digits = 2))
+ x2$diag_diff <- x[["diag_diff"]][ord]
+ }
+
+ # The frame carries every measure's per-model estimate and SE under its bare
+ # name (`model_compare_matrix(bare_names = TRUE)`), plus one difference pair
+ # per measure. `simplify = FALSE` adds estimate columns after the diagnostic
+ # columns, as the classic path does. The difference columns are left out:
+ # each is relative to its own measure's reference model, so it belongs only
+ # in its own table. `measures` also selects the estimates. A table asked for
+ # by name carries its own measure alone, so `measures = "r2"` prints only r2
+ # columns. The default `measures = NULL` restricts nothing, so its single
+ # table carries every measure. `p` is an ELPD companion, so it rides with it.
+ if (!simplify) {
+ if (all_estimates) {
+ all_measures <- attr(x, "compare_measures")
+ diff_cols <- c(
+ "elpd_diff", "se_diff",
+ paste0(all_measures, "_diff"), paste0(all_measures, "_se_diff")
+ )
+ est_cols <- setdiff(
+ colnames(x),
+ c("model", "p_worse", "diag_diff", "diag_elpd", diff_cols)
+ )
+ est_cols <- est_cols[vapply(x[est_cols], is.numeric, logical(1))]
+ # The frame keeps the estimates in one block and the standard errors in
+ # the next, so a wide table wraps with `se_r2` under `elpd`. Reorder each
+ # estimate next to its own SE. Only the order changes: a column outside
+ # `compare_measures` keeps its place at the end.
+ paired <- unlist(lapply(all_measures, function(m) {
+ pair <- c(m, paste0("se_", m))
+ if (.is_elpd_measure(m)) c(pair, "p", "se_p") else pair
+ }))
+ est_cols <- c(intersect(paired, est_cols), setdiff(est_cols, paired))
+ } else {
+ est_cols <- c(measure, paste0("se_", measure))
+ if (.is_elpd_measure(measure)) {
+ est_cols <- c(est_cols, "p", "se_p")
+ }
+ est_cols <- intersect(est_cols, colnames(x))
+ }
+ for (col in est_cols) {
+ m <- sub("^se_", "", col)
+ if (identical(m, "p")) {
+ m <- measure
+ }
+ se_vals <- x[[if (startsWith(col, "se_")) col else paste0("se_", col)]]
+ x2[[col]] <- unname(.fr(x[[col]][ord], .resolve_digits(digits, m, se_vals)))
+ }
+ }
+
+ print(x2, quote = FALSE, row.names = FALSE)
+}
+
+#' Print diagnostic glossary message for compare output
+#' @noRd
+.print_compare_diag_message <- function(x, p_worse, measures = NULL) {
+ if (!is.null(measures) && !any(.is_elpd_measure(measures))) {
+ return(invisible(FALSE))
+ }
+ diag_cols <- c("diag_diff", "diag_elpd")
+ has_diag <- any(
+ vapply(
+ intersect(diag_cols, colnames(x)),
+ function(col) any(nzchar(x[[col]], keepNA = FALSE), na.rm = TRUE),
+ logical(1)
+ )
+ )
+ if (has_diag && p_worse) {
+ message(
+ "\nDiagnostic flags present.\n",
+ "See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)\n",
+ "or https://mc-stan.org/loo/reference/loo-glossary.html."
+ )
+ }
+ invisible(has_diag && p_worse)
+}
+
+#' Measure-name suffix used by a comparison's evaluation source
+#'
+#' `.measure_result_name()` suffixes measure names by source (`elpd_loo`,
+#' `elpd_kfold`, `elpd_test`, and a bare `elpd` for in-sample). This is the
+#' inverse, so display names can be recovered for any source.
+#' @noRd
+#' @param loos List of `"pred_measure"` objects, or `NULL` when the source is
+#' unknown (falls back to the LOO suffix).
+.compare_suffix <- function(loos = NULL) {
+ if (is.null(loos)) {
+ return("_loo")
+ }
+ source <- attr(loos[[1L]], "source")
+ if (is.null(source) || identical(source, "insample")) "" else paste0("_", source)
+}
+
+#' Strip the source suffix for `model_compare` display names
+#' @noRd
+#' @param col Measure column name.
+#' @param loos List of model results the column came from; determines which
+#' suffix to strip. Deriving the suffix from the source (rather than matching
+#' any of `_loo|_kfold|_test`) keeps a custom measure named e.g. `my_test`
+#' intact outside a test-set comparison.
+.display_name <- function(col, loos = NULL) {
+ suffix <- .compare_suffix(loos)
+ if (!nzchar(suffix)) {
+ return(col)
+ }
+ sub(paste0(suffix, "$"), "", col)
+}
diff --git a/R/model_compare.R b/R/model_compare.R
new file mode 100644
index 00000000..ea8244ed
--- /dev/null
+++ b/R/model_compare.R
@@ -0,0 +1,715 @@
+#' Model comparison
+#'
+#' @description Compare fitted models on [ELPD][loo-glossary] or, for
+#' [`pred_measure`][pred_measure] results, on several predictive performance
+#' measures at once.
+#'
+#' `model_compare()` accepts two families of input:
+#'
+#' * **Classic results** --- `"loo"`, `"waic"`, and `"kfold"` objects, compared
+#' on ELPD alone.
+#' * **Predictive measure results** --- objects from
+#' [`loo_pred_measure()`][loo_pred_measure],
+#' [`kfold_pred_measure()`][kfold_pred_measure],
+#' [`test_pred_measure()`][test_pred_measure], or
+#' [`insample_pred_measure()`][insample_pred_measure], compared on every
+#' measure the models share.
+#'
+#' All models in one call must be evaluated the same way. Differences between,
+#' say, a LOO and a k-fold result would contrast held-out schemes rather than
+#' models, so mixed inputs are an error.
+#'
+#' @export
+#' @param x An object of class `"loo"` or `"pred_measure"`, or a list of such
+#' objects. List names are used as the model names in the output. See
+#' **Examples**.
+#' @param ... Additional objects of class `"loo"` or `"pred_measure"`, if not
+#' passed in as a single list. Naming every model here, as in
+#' `model_compare(A = m1, B = m2)`, names the models in the output, exactly as
+#' the list form does.
+#' @return A data frame of class `"compare.loo"` with one row per model and its
+#' own print method.
+#'
+#' For classic `"loo"` / `"waic"` / `"kfold"` comparisons the columns are
+#' unchanged from previous versions: `model`, `elpd_diff`, `se_diff`,
+#' `p_worse`, `diag_diff`, `diag_elpd`, and the estimate columns of the input
+#' objects.
+#'
+#' For [`pred_measure`][pred_measure] comparisons there is a `{measure}_diff`
+#' and a `{measure}_se_diff` column for every measure shared by all models
+#' (e.g. `rmse_diff`, `rmse_se_diff`). ELPD-family measures use `elpd_diff`
+#' and `se_diff` instead. `p_worse` and `diag_diff` are computed for ELPD
+#' only. `diag_elpd` holds per-model Pareto \eqn{\hat{k}} diagnostics and is
+#' present only for [`loo_pred_measure()`][loo_pred_measure] comparisons, the
+#' only source with Pareto \eqn{\hat{k}} values.
+#'
+#' The object also carries the following attributes:
+#' \describe{
+#' \item{`compare_reference`}{
+#' A named character vector giving, for each measure, the model its
+#' differences were computed against, which is that measure's own best
+#' model.
+#' }
+#' \item{`compare_measures`}{
+#' Bare names of all measures that were compared.
+#' }
+#' \item{`sign_converted_measures`}{
+#' Bare names of the loss measures whose sign was flipped onto the utility
+#' scale.
+#' }
+#' \item{`compare_source`}{
+#' The shared evaluation source: `"loo"`, `"kfold"`, `"test"`, or
+#' `"insample"`.
+#' }
+#' }
+#' `compare_reference` is set for every comparison; the last three are set
+#' for [`pred_measure`][pred_measure] comparisons only.
+#'
+#' @details
+#' ## Differences and their standard errors
+#' Differences are pairwise: every model is compared with one reference model,
+#' whose own `{measure}_diff` is therefore `0`. The reference is the best
+#' model on that measure, so `mse_diff` may use a different reference than
+#' `elpd_diff`, and the remaining differences for a measure are all negative.
+#' Rows are ordered by `"elpd"` when all models share it. Otherwise, rows are
+#' ordered by the first shared measure in alphabetical order.
+#'
+#' The standard error of a difference is a paired estimate, which uses the
+#' fact that the same \eqn{N} data points were used for both models. It should
+#' not be expected to equal the difference of the two models' standard errors.
+#'
+#' ## `p_worse`, `diag_diff`, and `diag_elpd`
+#' `p_worse` is the probability that a model has worse ELPD than the reference
+#' model, computed with a normal approximation from `elpd_diff` and `se_diff`.
+#' Sivula et al. (2025) give the conditions under which that approximation is
+#' good; `diag_diff` reports the two that fail most often:
+#'
+#' * `N < 100` (small data)
+#' * `|elpd_diff| < 4` (models make similar predictions)
+#'
+#' Either message means the error distribution is skewed or thick tailed, the
+#' normal approximation is not well calibrated, and `p_worse` is likely too
+#' large. If `|elpd_diff|` is many times `se_diff` the difference is
+#' quite certain. Model misspecification and outliers also skew the error
+#' distribution, and can be diagnosed with the usual predictive checks.
+#'
+#' `diag_elpd` reports the PSIS-LOO Pareto \eqn{\hat{k}} diagnostic for each
+#' model's pointwise ELPD. An entry `K k_psis > 0.7`, where `K` counts the
+#' high Pareto \eqn{\hat{k}} values, warns of possible bias in `elpd_diff`
+#' favoring models with many such values. Pareto \eqn{\hat{k}} describes a
+#' model's PSIS-LOO approximation rather than any one measure or pair of
+#' models, and every LOO measure uses the same importance weights, so for
+#' `pred_measure` comparisons `print()` reports it once per model in a block
+#' above the difference tables instead of as a column inside one of them. The
+#' `diag_elpd` column is still returned on the object.
+#'
+#' ## Comparing `pred_measure` objects
+#' When all inputs are predictive measure results sharing one evaluation
+#' source, paired differences are computed for every measure present in all
+#' models. Measures are matched on their bare names, so the source suffix
+#' (`_loo`, `_kfold`, `_test`, or none for in-sample) is handled
+#' transparently. When the models were evaluated on different `measure` sets,
+#' only the shared measures are compared and a warning lists the omitted ones.
+#'
+#' The data frame carries one row order for all measures, but each *printed*
+#' measure table is sorted by its own difference, so the best model on that
+#' measure always leads its table and the differences run in decreasing order.
+#' Use `print(x, measures = "all")` to display a table for every compared
+#' measure; see [loo-glossary] for column definitions.
+#'
+#' ## Utility scale and sign conversion
+#' Measures differ in orientation in their raw form: ELPD and SRPS/SCRPS are
+#' utilities (higher is better), while MSE, RPS/CRPS and the Brier score are
+#' losses (lower is better). All `{measure}_diff` values are reported on a
+#' common utility scale, so loss measures have their sign flipped and a
+#' negative `{measure}_diff` always means worse performance than the
+#' reference. Which measures are losses is recorded in the `loss` element of
+#' each measure's entry in the `measure_info` attribute of an
+#' `*_pred_measure()` result. The flipped measures are named in the
+#' `sign_converted_measures` attribute. `print()` marks them with
+#' "sign flipped" in the table header and names them below the tables.
+#'
+#' A custom measure is treated as a utility unless it declares otherwise with
+#' `loss = TRUE` in [custom_measure()]. The declaration also determines the
+#' ranking direction, so an undeclared loss is both flipped and ranked in the
+#' wrong direction; see [insample_pred_measure()].
+#'
+#' ## Standard error of a measure difference
+#' How `{measure}_se_diff` is obtained is recorded in the `diff_method`
+#' element of the measure's entry in `measure_info`:
+#'
+#' * `"sum"` or `"mean"`: the overall estimate is the sum (`elpd`, `ic`) or the
+#' mean (`mlpd`, `mae`, `mse`, `acc`, `rps`, `srps`, `brier`) of its
+#' pointwise contributions, so the standard error is computed from paired
+#' pointwise differences (the same formula as `se_diff`).
+#' * `"measure_specific"`: the overall estimate is not a sum or mean of
+#' pointwise contributions (`r2`, `rmse`, `bacc`), so the measure supplies
+#' its own standard error of the difference.
+#' * `"custom"`: the standard error comes from the measure's own
+#' `attr(my_fun, "measure_se_diff")` declaration, set with
+#' [custom_measure()]. `{measure}_se_diff` is `NA` when the measure
+#' declares nothing.
+#'
+#' ## Source-specific behavior
+#' Comparisons behave the same way across sources, with three exceptions:
+#'
+#' * **`diag_elpd`** is produced only for
+#' [`loo_pred_measure()`][loo_pred_measure] comparisons, since Pareto
+#' \eqn{\hat{k}} diagnostics exist only for PSIS-LOO.
+#' * **K-fold** comparisons warn when the models do not share the same number
+#' of folds, matching the behavior for plain `"kfold"` objects.
+#' * **In-sample** comparisons warn that in-sample scores are optimistically
+#' biased and favor more complex models. They are supported for
+#' completeness, but out-of-sample sources should be preferred for model
+#' selection.
+#'
+#' ## Warnings for many model comparisons
+#' If more than \eqn{11} models are compared, we internally recompute the model
+#' differences using the median model (by ELPD, or by the ranking measure
+#' for `pred_measure` comparisons) as the baseline, and estimate whether the
+#' differences in predictive performance are potentially due to chance as
+#' described by McLatchie and Vehtari (2023). This flags a warning if there is
+#' a risk of over-fitting due to the selection process. In that case users are
+#' recommended to avoid model selection based on LOO-CV, and instead to favor
+#' model averaging/stacking or projection predictive inference.
+#'
+#' @seealso
+#' * The [FAQ page](https://mc-stan.org/loo/articles/online-only/faq.html) on
+#' the __loo__ website for answers to frequently asked questions.
+#' * The article
+#' [Model comparison: Explanation of `model_compare()`](https://mc-stan.org/loo/articles/articles-online-only/model-comparison.html)
+#' on the __loo__ website, for how the differences and their standard errors
+#' are computed for each measure.
+#' @template loo-and-compare-references
+#'
+#' @examples
+#' # very artificial example, just for demonstration!
+#' LL <- example_loglik_array()
+#' loo1 <- loo(LL) # should be worst model when compared
+#' loo2 <- loo(LL + 1) # should be second best model when compared
+#' loo3 <- loo(LL + 2) # should be best model when compared
+#'
+#' comp <- model_compare(loo1, loo2, loo3)
+#' print(comp, digits = 2)
+#'
+#' # can use a list of objects with custom names
+#' # the names will be used in the output
+#' model_compare(list("apple" = loo1, "banana" = loo2, "cherry" = loo3))
+#'
+#' \dontrun{
+#' # works for waic (and kfold) too
+#' model_compare(waic(LL), waic(LL - 10))
+#'
+#' # compare multiple predictive measures from loo_pred_measure()
+#' if (requireNamespace("brms", quietly = TRUE)) {
+#' fit1 <- brms::brm(
+#' Reaction ~ Days, data = lme4::sleepstudy,
+#' refresh = 0, chains = 2, iter = 1000
+#' )
+#' fit2 <- brms::brm(
+#' Reaction ~ poly(Days, 2), data = lme4::sleepstudy,
+#' refresh = 0, chains = 2, iter = 1000
+#' )
+#' pm1 <- loo_pred_measure(
+#' loo = loo(fit1, save_psis = TRUE),
+#' y = fit1$data$Reaction,
+#' mupred = brms::posterior_epred(fit1),
+#' measures = c("rmse", "r2")
+#' )
+#' pm2 <- loo_pred_measure(
+#' loo = loo(fit2, save_psis = TRUE),
+#' y = fit2$data$Reaction,
+#' mupred = brms::posterior_epred(fit2),
+#' measures = c("rmse", "r2")
+#' )
+#' comp <- model_compare(pm1, pm2)
+#' print(comp)
+#' print(comp, measures = "all")
+#'
+#' # the same works for k-fold CV
+#' folds <- kfold_split_random(K = 5, N = nrow(lme4::sleepstudy))
+#' kf1 <- brms::kfold(fit1, folds = folds, save_fits = TRUE)
+#' kf2 <- brms::kfold(fit2, folds = folds, save_fits = TRUE)
+#' kpm1 <- kfold_pred_measure(
+#' y = fit1$data$Reaction,
+#' mupred = brms::kfold_predict(kf1, method = "fitted")$yrep,
+#' kfold = kf1,
+#' measures = "rmse"
+#' )
+#' kpm2 <- kfold_pred_measure(
+#' y = fit2$data$Reaction,
+#' mupred = brms::kfold_predict(kf2, method = "fitted")$yrep,
+#' kfold = kf2,
+#' measures = "rmse"
+#' )
+#' model_compare(kpm1, kpm2)
+#'
+#' # mixing evaluation sources is an error
+#' try(model_compare(pm1, kpm2))
+#' }
+#' }
+#'
+model_compare <- function(x, ...) {
+ if (missing(x)) {
+ dots <- list(...)
+ if (!length(dots)) {
+ stop("No models supplied.", call. = FALSE)
+ }
+ return(model_compare(dots))
+ }
+ UseMethod("model_compare")
+}
+
+#' @rdname model_compare
+#' @export
+model_compare.default <- function(x, ...) {
+ loos <- .model_compare_inputs(x, ...)
+
+ # if subsampling is used
+ if (any(sapply(loos, inherits, "psis_loo_ss"))) {
+ return(model_compare.psis_loo_ss_list(loos))
+ }
+
+ # `pred_measure` objects must be tested before any `is.loo()` check: results
+ # from `loo_pred_measure()` and `kfold_pred_measure()` inherit the classes of
+ # the `loo`/`kfold` object they were built from.
+ is_pm <- vapply(loos, is.pred_measure, logical(1))
+
+ if (all(is_pm)) {
+ return(compare_pred_measure(loos))
+ }
+
+ if (any(is_pm)) {
+ stop(
+ "Cannot mix 'pred_measure' objects with plain 'loo' objects. ",
+ "Compare models using the same *_pred_measure() function for each model.",
+ call. = FALSE
+ )
+ }
+
+ # run pre-comparison checks
+ model_compare_checks(loos)
+
+ # compute elpd_diff and se_elpd_diff relative to best model
+ ord <- model_compare_order(loos)
+ comp <- model_compare_matrix(loos, ord = ord)
+ rnms <- rownames(comp)
+ diffs <- mapply(FUN = elpd_diffs, loos[ord[1L]], loos[ord])
+ colnames(diffs) <- rnms
+ elpd_diff <- apply(diffs, 2, sum)
+ se_diff <- apply(diffs, 2, se_elpd_diff)
+
+ # compute probabilities that a model has worse elpd than the best model
+ # using a normal approximation
+ # (Sivula et al., 2025)
+ p_worse <- stats::pnorm(0, elpd_diff, se_diff)
+ p_worse[elpd_diff == 0] <- NA
+
+ comp <- cbind(
+ data.frame(
+ model = rnms,
+ elpd_diff = elpd_diff,
+ se_diff = se_diff,
+ p_worse = p_worse,
+ diag_diff = diag_diff(nrow(diffs), elpd_diff),
+ diag_elpd = diag_elpd(loos[ord])
+ ),
+ as.data.frame(comp)
+ )
+ rownames(comp) <- NULL
+
+ # run order statistics-based checks for many model comparisons
+ model_order_stat_check(loos, ord)
+
+ # Same attribute contract as the `pred_measure` path, with the single
+ # measure `"elpd"`.
+ attr(comp, "compare_reference") <- c(elpd = rnms[[1L]])
+ class(comp) <- c("compare.loo", class(comp))
+ comp
+}
+
+#' Reference model a measure's differences were computed against
+#'
+#' Each measure has its own best model as reference, recorded in attribute `compare_reference`. Falls back to the first row for objects
+#' created before that attribute existed.
+#' @noRd
+.measure_ref_model <- function(x, measure) {
+ refs <- attr(x, "compare_reference")
+ if (!is.null(refs) && measure %in% names(refs)) {
+ return(refs[[measure]])
+ }
+ x$model[[1L]]
+}
+
+#' Normalize `model_compare()` inputs to a list of model results
+#' @noRd
+.model_compare_inputs <- function(x, ...) {
+ if (is.loo(x) || inherits(x, "pred_measure")) {
+ dots <- list(...)
+ return(c(list(x), dots))
+ }
+ if (!is.list(x) || !length(x)) {
+ stop(
+ "'x' must be a list if not a 'loo' or 'pred_measure' object.",
+ call. = FALSE
+ )
+ }
+ if (length(list(...))) {
+ stop("If 'x' is a list then '...' should not be specified.", call. = FALSE)
+ }
+ x
+}
+
+#' Compute pointwise elpd differences
+#' @noRd
+#' @param loo_a,loo_b Two `"loo"` objects.
+elpd_diffs <- function(loo_a, loo_b) {
+ pt_a <- loo_a$pointwise
+ pt_b <- loo_b$pointwise
+ elpd <- grep("^elpd", colnames(pt_a))
+ pt_b[, elpd] - pt_a[, elpd]
+}
+
+#' Compute standard error of the elpd difference
+#' @noRd
+#' @param diffs Vector of pointwise elpd differences
+se_elpd_diff <- function(diffs) {
+ N <- length(diffs)
+ # As `elpd_diff` is defined as the sum of N independent components,
+ # we can compute the standard error by using the standard deviation
+ # of the N components and multiplying by `sqrt(N)`.
+ sqrt(N) * sd(diffs)
+}
+
+#' Warn when k-fold results do not share the same number of folds
+#' @noRd
+#' @param loos List of `"kfold"` or `"kfold_pred_measure"` objects.
+throw_kfold_K_mismatch_warning <- function(loos) {
+ Ks <- unlist(lapply(loos, attr, which = "K"))
+ if (length(Ks) == length(loos) && !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
+ )
+ }
+ invisible(NULL)
+}
+
+#' Warn when k-fold results do not share the same fold assignment
+#' @noRd
+#' @param loos List of `"kfold"` or `"kfold_pred_measure"` objects.
+#' @details The fold labels are arbitrary. The check therefore relabels each
+#' vector by first appearance. Two runs that split the data in the same way
+#' then agree, whatever the labels are. A `NULL` `folds` attribute means the
+#' object does not record the split. The check is then not possible.
+throw_kfold_folds_mismatch_warning <- function(loos) {
+ folds <- lapply(loos, attr, which = "folds")
+ if (any(vapply(folds, is.null, logical(1)))) {
+ return(invisible(NULL))
+ }
+ canonical <- lapply(folds, function(f) {
+ as.integer(factor(f, levels = unique(f)))
+ })
+ same <- vapply(
+ canonical,
+ function(f) identical(f, canonical[[1L]]),
+ logical(1)
+ )
+ if (!all(same)) {
+ warning(
+ "Not all kfold objects use the same fold assignment.", call. = FALSE
+ )
+ }
+ invisible(NULL)
+}
+
+#' Perform checks on `"loo"` objects before comparison
+#' @noRd
+#' @param loos List of `"loo"` objects.
+#' @param class_check Function returning `TRUE` for valid input objects.
+#' @param class_msg Error message when `class_check` fails.
+#' @param kfold_checks If `TRUE`, run k-fold comparison warnings.
+#' @param n_fun Function returning one model's number of observations. A
+#' `"psis_loo_ss"` object subsamples its `pointwise` matrix, so it reports the
+#' size of the full data instead.
+#' @return Nothing, just possibly throws errors/warnings.
+model_compare_checks <- function(
+ loos,
+ class_check = is.loo,
+ class_msg = "All inputs should have class 'loo'.",
+ kfold_checks = TRUE,
+ n_fun = function(x) nrow(x$pointwise)
+) {
+ ## errors
+ if (length(loos) <= 1L) {
+ stop("At least two models are required for comparison.", call. = FALSE)
+ }
+ if (!all(vapply(loos, class_check, logical(1)))) {
+ stop(class_msg, call. = FALSE)
+ }
+
+ Ns <- vapply(loos, function(x) as.integer(n_fun(x)), integer(1))
+ if (any(Ns != Ns[1L])) {
+ stop(
+ paste0(
+ "All models must have the same number of observations, but models have inconsistent observation counts: ",
+ paste(paste0("'", find_model_names(loos), "' (", Ns, ")"), collapse = ", ")
+ ),
+ call. = FALSE
+ )
+ }
+
+ ## warnings
+
+ yhash <- lapply(loos, attr, which = "yhash")
+ yhash_ok <- vapply(yhash, function(x) {
+ isTRUE(all.equal(x, yhash[[1]]))
+ }, logical(1))
+ if (!all(yhash_ok)) {
+ warning(
+ "Not all models have the same y variable. ('yhash' attributes do not match)",
+ call. = FALSE
+ )
+ }
+
+ if (!kfold_checks) {
+ return(invisible(NULL))
+ }
+
+ if (all(vapply(loos, is.kfold, logical(1)))) {
+ throw_kfold_K_mismatch_warning(loos)
+ throw_kfold_folds_mismatch_warning(loos)
+ } else if (any(vapply(loos, is.kfold, logical(1))) &&
+ any(vapply(loos, is.psis_loo, logical(1)))) {
+ 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
+ )
+ }
+}
+
+#' Find the model names associated with `"loo"` objects
+#'
+#' @export
+#' @param x List of `"loo"` objects.
+#' @return Character vector of model names the same length as `x.`
+#'
+find_model_names <- function(x) {
+ stopifnot(is.list(x))
+ out_names <- character(length(x))
+
+ names1 <- names(x)
+ names2 <- lapply(x, "attr", "model_name", exact = TRUE)
+ names3 <- lapply(x, "[[", "model_name")
+ names4 <- paste0("model", seq_along(x))
+
+ for (j in seq_along(x)) {
+ if (isTRUE(nzchar(names1[j]))) {
+ out_names[j] <- names1[j]
+ } else if (length(names2[[j]])) {
+ out_names[j] <- names2[[j]]
+ } else if (length(names3[[j]])) {
+ out_names[j] <- names3[[j]]
+ } else {
+ out_names[j] <- names4[j]
+ }
+ }
+ out_names
+}
+
+#' Build estimates table for `model_compare()` ordering and matrix output
+#' @noRd
+.model_compare_estimates_table <- function(loos, bare_names = FALSE,
+ subsampling = FALSE) {
+ sapply(loos, function(x) {
+ est <- x$estimates
+ rows <- if (bare_names) .display_name(rownames(est), loos) else rownames(est)
+ nms <- c(rows, paste0("se_", rows))
+ # A `psis_loo_ss` object carries a third estimate column, the subsampling
+ # standard error, so its table needs a third name set.
+ if (subsampling) {
+ nms <- c(nms, paste0("subsampling_se_", rows))
+ }
+ setNames(c(est), nm = nms)
+ })
+}
+
+#' Compute the model_compare matrix
+#' @noRd
+#' @param loos List of `"loo"` objects.
+#' @param bare_names If `TRUE`, strip `_loo` suffixes from estimate row names.
+#' @param ord Optional model ordering indices; computed from ELPD when `NULL`.
+model_compare_matrix <- function(loos, bare_names = FALSE, ord = NULL,
+ subsampling = FALSE) {
+ tmp <- .model_compare_estimates_table(
+ loos,
+ bare_names = bare_names,
+ subsampling = subsampling
+ )
+ colnames(tmp) <- find_model_names(loos)
+ comp <- t(tmp)
+
+ if (is.null(ord)) {
+ ord <- model_compare_order(loos)
+ }
+ comp <- comp[ord, , drop = FALSE]
+
+ patts <- if (bare_names) {
+ c("^elpd$", "^p$", "^se_elpd$", "^se_p$")
+ } else if (subsampling) {
+ # Left unanchored, so each `subsampling_se_*` column is picked up beside
+ # its `se_*` counterpart.
+ c("elpd", "p_", "^waic$|^looic$", "se_waic$|se_looic$")
+ } else {
+ c("elpd", "p_", "^waic$|^looic$", "^se_waic$|^se_looic$")
+ }
+ col_ord <- unique(unlist(
+ lapply(patts, function(p) grep(p, colnames(comp))),
+ use.names = FALSE
+ ))
+ if (bare_names) {
+ other <- setdiff(seq_len(ncol(comp)), col_ord)
+ comp <- comp[, c(col_ord, other), drop = FALSE]
+ } else {
+ comp <- comp[, col_ord, drop = FALSE]
+ }
+ comp
+}
+
+#' Computes the order of loos for comparison
+#' @noRd
+#' @param loos List of `"loo"` objects.
+#' @param rank_col Optional internal `pointwise` column name used for ranking.
+model_compare_order <- function(loos, rank_col = NULL) {
+ if (is.null(rank_col)) {
+ tmp <- .model_compare_estimates_table(loos, bare_names = FALSE)
+ colnames(tmp) <- find_model_names(loos)
+ rnms <- rownames(tmp)
+ return(order(tmp[grep("^elpd", rnms), ], decreasing = TRUE))
+ }
+
+ est_row <- vapply(loos, function(x) {
+ val <- x$estimates[rank_col, "Estimate"]
+ if (.measure_is_loss(rank_col, loos)) -val else val
+ }, numeric(1))
+ order(est_row, decreasing = TRUE)
+}
+
+#' Perform checks on `"loo"` objects __after__ comparison
+#' @noRd
+#' @param loos List of `"loo"` objects.
+#' @param ord List of `"loo"` object orderings.
+#' @param measure_diff Optional precomputed model differences for the rank
+#' measure; computed from the median model when `NULL`.
+#' @param rank_col Optional internal `pointwise` column name used for the
+#' median-baseline differences when `measure_diff` is `NULL` and inputs are not
+#' classic `"loo"` objects.
+#' @return Nothing, just possibly throws errors/warnings.
+model_order_stat_check <- function(loos, ord, measure_diff = NULL, rank_col = NULL) {
+
+ ## breaks
+
+ if (length(loos) <= 11L) {
+ # procedure cannot be diagnosed for fewer than ten candidate models
+ # (total models = worst model + ten candidates)
+ # break from function
+ return(invisible(NULL))
+ }
+
+ ## warnings
+
+ if (is.null(measure_diff)) {
+ # compute differences from the median model
+ baseline_idx <- middle_idx(ord)
+ ref_loo <- loos[[ord[baseline_idx]]]
+ if (is.null(rank_col)) {
+ diffs <- mapply(FUN = elpd_diffs, loos[ord[baseline_idx]], loos[ord])
+ measure_diff <- apply(diffs, 2, sum)
+ } else {
+ method <- .measure_pointwise_diff_method(loos, rank_col)
+ measure_diff <- vapply(
+ loos[ord],
+ .pair_measure_stats,
+ FUN.VALUE = c(diff = 0, se = 0),
+ ref = ref_loo,
+ col = rank_col,
+ method = method,
+ loos = loos
+ )["diff", ]
+ }
+ }
+
+ # estimate the standard deviation of the upper-half-normal
+ diff_median <- stats::median(measure_diff)
+ measure_diff_trunc <- measure_diff[measure_diff >= diff_median]
+ n_models <- sum(!is.na(measure_diff_trunc))
+ candidate_sd <- sqrt(1 / n_models * sum(measure_diff_trunc^2, na.rm = TRUE))
+
+ # estimate expected best diff under null hypothesis
+ K <- length(loos) - 1
+ order_stat <- order_stat_heuristic(K, candidate_sd)
+
+ if (max(measure_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)
+ }
+ invisible(NULL)
+}
+
+#' Returns the middle index of a vector
+#' @noRd
+#' @param vec A vector.
+#' @return Integer index value.
+middle_idx <- function(vec) floor(length(vec) / 2)
+
+#' Computes maximum order statistic from K Gaussians
+#' @noRd
+#' @param K Number of Gaussians.
+#' @param c Scaling of the order statistic.
+#' @return Numeric expected maximum from K samples from a Gaussian with mean
+#' zero and scale `"c"`
+order_stat_heuristic <- function(K, c) {
+ qnorm(p = 1 - 1 / (K * 2), mean = 0, sd = c)
+}
+
+#' Count number of high Pareto k values in PSIS-LOO and create diagnostic message
+#' @noRd
+#' @param loos Ordered list of loo objects.
+#' @return Character vector of diagnostic messages.
+diag_elpd <- function(loos) {
+ sapply(loos, function(loo) {
+ k <- loo$diagnostics[["pareto_k"]]
+ if (is.null(k)) {
+ out <- ""
+ } else {
+ S <- dim(loo)[1]
+ khat_threshold <- ps_khat_threshold(S)
+ K <- sum(k > khat_threshold)
+ out <- ifelse(K == 0, "", paste0(K, " k_psis > ", round(khat_threshold, 2)))
+ }
+ out
+ })
+}
+
+#' Create diagnostic for elpd differences
+#' @noRd
+#' @param N Number of data points.
+#' @param elpd_diff Vector of elpd differences.
+#' @return Character vector of diagnostic messages.
+diag_diff <- function(N, elpd_diff) {
+ if (N < 100) {
+ diag_diff <- rep("N < 100", length(elpd_diff))
+ diag_diff[elpd_diff == 0] <- ""
+ } else {
+ diag_diff <- rep("", length(elpd_diff))
+ # The reference model need not be the best one, so a difference can be
+ # positive: the flag is about the magnitude, not the sign.
+ diag_diff[abs(elpd_diff) < 4 & elpd_diff != 0] <- "|elpd_diff| < 4"
+ }
+ diag_diff
+}
diff --git a/R/loo_compare.psis_loo_ss_list.R b/R/model_compare.psis_loo_ss_list.R
similarity index 52%
rename from R/loo_compare.psis_loo_ss_list.R
rename to R/model_compare.psis_loo_ss_list.R
index b84f7b5d..1a2bffa5 100644
--- a/R/loo_compare.psis_loo_ss_list.R
+++ b/R/model_compare.psis_loo_ss_list.R
@@ -2,32 +2,37 @@
#' @noRd
#' @param x A list with `psis_loo` objects.
#' @param ... Currently ignored.
-#' @return A `compare.loo_ss` object.
-#' @author Mans Magnusson
+#' @return A `compare.loo` data frame, as `model_compare.default()` returns,
+#' with an extra `subsampling_se_diff` column.
#' @export
-loo_compare.psis_loo_ss_list <- function(x, ...) {
-
+model_compare.psis_loo_ss_list <- function(x, ...) {
checkmate::assert_list(x, any.missing = FALSE, min.len = 1)
for(i in seq_along(x)){
if (!inherits(x[[i]], "psis_loo_ss")) x[[i]] <- as.psis_loo_ss.psis_loo(x[[i]])
}
- loo_compare_checks.psis_loo_ss_list(x)
+ # A `psis_loo_ss` object subsamples its `pointwise` matrix, so the shared
+ # check compares the full data size instead.
+ model_compare_checks(x, n_fun = function(x) x$loo_subsampling$data_dim[1])
- comp <- loo_compare_matrix.psis_loo_ss_list(x)
- ord <- loo_compare_order(x)
+ comp <- model_compare_matrix(x, subsampling = TRUE)
+ ord <- model_compare_order(x)
names(x) <- rownames(comp)[order(ord)]
rnms <- rownames(comp)
elpd_diff_mat <- matrix(0, nrow = nrow(comp), ncol = 3,
dimnames = list(rnms, c("elpd_diff", "se_diff", "subsampling_se_diff")))
for(i in 2:length(ord)){
- elpd_diff_mat[i,] <- loo_compare_ss(ref_loo = x[ord[1]], compare_loo = x[ord[i]])
+ elpd_diff_mat[i,] <- model_compare_ss(ref_loo = x[ord[1]], compare_loo = x[ord[i]])
}
- comp <- cbind(elpd_diff_mat, comp)
- rownames(comp) <- rnms
-
- class(comp) <- c("compare.loo_ss", "compare.loo", class(comp))
+ comp <- cbind(
+ data.frame(model = rnms, stringsAsFactors = FALSE),
+ as.data.frame(elpd_diff_mat),
+ as.data.frame(comp)
+ )
+ rownames(comp) <- NULL
+
+ class(comp) <- c("compare.loo", "data.frame")
return(comp)
}
@@ -36,7 +41,7 @@ loo_compare.psis_loo_ss_list <- function(x, ...) {
#' @param ref_loo A named list with a `psis_loo_ss` object.
#' @param compare_loo A named list with a `psis_loo_ss` object.
#' @return A 1 by 3 elpd_diff estimation.
-loo_compare_ss <- function(ref_loo, compare_loo){
+model_compare_ss <- function(ref_loo, compare_loo){
checkmate::assert_list(ref_loo, names = "named")
checkmate::assert_list(compare_loo, names = "named")
checkmate::assert_class(ref_loo[[1]], "psis_loo_ss")
@@ -52,12 +57,12 @@ 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)
- return(loo_compare_ss_naive(ref_loo, compare_loo))
+ return(model_compare_ss_naive(ref_loo, compare_loo))
}
# Same observations in both
if (compare_subset_of_ref & ref_subset_of_compare){
- return(loo_compare_ss_diff(ref_loo, compare_loo))
+ return(model_compare_ss_diff(ref_loo, compare_loo))
}
# Use subset
@@ -65,28 +70,29 @@ loo_compare_ss <- function(ref_loo, compare_loo){
if (compare_subset_of_ref) ref_loo[[1]] <- update(object = ref_loo[[1]], observations = compare_loo[[1]])
if (ref_subset_of_compare) compare_loo[[1]] <- update(compare_loo[[1]], observations = ref_loo[[1]])
message("Estimated elpd_diff using observations included in loo calculations for all models.")
- return(loo_compare_ss_diff(ref_loo, compare_loo))
+ return(model_compare_ss_diff(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)
- return(loo_compare_ss_naive(ref_loo, compare_loo))
+ return(model_compare_ss_naive(ref_loo, compare_loo))
}
}
#' Compute a naive diff SE
#' @noRd
-#' @inheritParams loo_compare_ss
+#' @inheritParams model_compare_ss
#' @return a 1 by 3 elpd_diff estimation
-loo_compare_ss_naive <- function(ref_loo, compare_loo){
+model_compare_ss_naive <- function(ref_loo, compare_loo){
checkmate::assert_list(ref_loo, names = "named")
checkmate::assert_list(compare_loo, names = "named")
checkmate::assert_class(ref_loo[[1]], "psis_loo_ss")
checkmate::assert_class(compare_loo[[1]], "psis_loo_ss")
- elpd_loo_diff <- compare_loo[[1]]$estimates["elpd_loo", "Estimate"] - ref_loo[[1]]$estimates["elpd_loo", "Estimate"]
+ elpd_loo_diff <- compare_loo[[1]]$estimates["elpd_loo", "Estimate"] -
+ ref_loo[[1]]$estimates["elpd_loo", "Estimate"]
elpd_loo_diff_se <- sqrt(
(ref_loo[[1]]$estimates["elpd_loo", "SE"])^2 +
(compare_loo[[1]]$estimates["elpd_loo", "SE"])^2)
@@ -99,9 +105,9 @@ loo_compare_ss_naive <- function(ref_loo, compare_loo){
#' Compare a effective diff SE
#' @noRd
-#' @inheritParams loo_compare_ss
+#' @inheritParams model_compare_ss
#' @return a 1 by 3 elpd_diff estimation
-loo_compare_ss_diff <- function(ref_loo, compare_loo){
+model_compare_ss_diff <- function(ref_loo, compare_loo){
checkmate::assert_list(ref_loo, names = "named")
checkmate::assert_list(compare_loo, names = "named")
checkmate::assert_class(ref_loo[[1]], "psis_loo_ss")
@@ -122,86 +128,3 @@ loo_compare_ss_diff <- function(ref_loo, compare_loo){
c(elpd_loo_diff, elpd_loo_diff_se, elpd_loo_diff_subsampling_se)
}
-
-
-#' Check list of `psis_loo` objects
-#' @details Similar to `loo_compare_checks()` but checks dim size rather than
-#' pointwise dim since different pointwise sizes of `psis_loo_ss` will work.
-#' Can probably be removed by refactoring `loo_compare_checks()`.
-#' @noRd
-#' @inheritParams loo_compare_ss
-#' @return A 1 by 3 elpd_diff estimation.
-loo_compare_checks.psis_loo_ss_list <- function(loos) {
- ## errors
- if (length(loos) <= 1L) {
- stop("'loo_compare' requires at least two models.", call.=FALSE)
- }
- if (!all(sapply(loos, is.loo))) {
- stop("All inputs should have class 'loo'.", call.=FALSE)
- }
-
- Ns <- sapply(loos, function(x) x$loo_subsampling$data_dim[1])
- if (!all(Ns == Ns[1L])) {
- stop("Not all models have the same number of data points.", call.=FALSE)
- }
-
- ## warnings
-
- yhash <- lapply(loos, attr, which = "yhash")
- yhash_ok <- sapply(yhash, function(x) { # ok only if all yhash are same (all NULL is ok)
- 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)
- }
-
- 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)
- }
- } 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)
- }
-}
-
-#' @rdname loo_compare
-#' @export
-print.compare.loo_ss <- function(x, ..., digits = 1) {
- xcopy <- x
- if (NCOL(xcopy) >= 2) {
- xcopy <- xcopy[, c("elpd_diff", "se_diff", "subsampling_se_diff")]
- }
- print(.fr(xcopy, digits), quote = FALSE)
- invisible(x)
-}
-
-#' Compute comparison matrix for `psis_loo_ss` objects
-#' @noRd
-#' @keywords internal
-#' @param loos List of `psis_loo_ss` objects.
-#' @return A `compare.loo_ss` matrix.
-loo_compare_matrix.psis_loo_ss_list <- function(loos){
- tmp <- sapply(loos, function(x) {
- est <- x$estimates
- setNames(c(est), nm = c(rownames(est),
- paste0("se_", rownames(est)),
- paste0("subsampling_se_", rownames(est))))
- })
- colnames(tmp) <- find_model_names(loos)
- rnms <- rownames(tmp)
- comp <- tmp
- ord <- loo_compare_order(loos)
- comp <- t(comp)[ord, ]
- patts <- c("elpd", "p_", "^waic$|^looic$", "se_waic$|se_looic$")
- col_ord <- unlist(sapply(patts, function(p) grep(p, colnames(comp))),
- use.names = FALSE)
- comp <- comp[, col_ord]
- comp
-}
diff --git a/R/pred_measure-builtin.R b/R/pred_measure-builtin.R
index 3f9748be..51ab489a 100644
--- a/R/pred_measure-builtin.R
+++ b/R/pred_measure-builtin.R
@@ -5,11 +5,6 @@
#' before computing each per-observation contribution.
#' @param pointwise Optional numeric vector of precomputed per-observation
#' contributions. When supplied, `ylp` and `log_weights` are ignored.
-#' @param higher_is_better Logical or `NULL`; whether larger values indicate
-#' better predictive performance. `NULL` (default) keeps each measure's
-#' natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-#' Set `TRUE` for a utility scale (higher is better) or `FALSE` for a loss
-#' scale (lower is better).
#'
#' @return An object of class `"measure"`: a list with:
#' \describe{
@@ -117,7 +112,6 @@ ptw_log_pred_density <- function(ylp, psis_log_weights = NULL) {
#' pointwise log predictive density contributions (\eqn{\mathrm{lppd}_i}), using
#' [ptw_log_pred_density()]. ELPD is returned on the utility scale (higher is
#' better), consistent with the sign convention used throughout this package.
-#' Manual change of sign convention is possible via `higher_is_better`.
#'
#' @inheritParams measure_density_params
#' @inheritParams measure_params
@@ -144,7 +138,7 @@ ptw_log_pred_density <- function(ylp, psis_log_weights = NULL) {
#' measure_elpd(LLarr)
#' @export
measure_elpd <- function(
- ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL
+ ylp, log_weights = NULL, pointwise = NULL
) {
inputs <- .lppd_from_inputs(ylp, log_weights, pointwise, "measure_elpd")
lppd_i <- inputs$lppd_i
@@ -160,8 +154,7 @@ measure_elpd <- function(
)
.create_measure_structure(
- res, higher_is_better, "elpd",
- n_draws = inputs$n_draws, n_obs = inputs$n_obs
+ res, "elpd", n_draws = inputs$n_draws, n_obs = inputs$n_obs
)
}
@@ -180,7 +173,7 @@ measure_elpd <- function(
#' measure_mlpd(ylp)
#' @export
measure_mlpd <- function(
- ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL
+ ylp, log_weights = NULL, pointwise = NULL
) {
inputs <- .lppd_from_inputs(ylp, log_weights, pointwise, "measure_mlpd")
lppd_i <- inputs$lppd_i
@@ -196,7 +189,7 @@ measure_mlpd <- function(
pointwise = lppd_i
)
.create_measure_structure(
- res, higher_is_better, "mlpd", n_draws = inputs$n_draws, n_obs = n_obs
+ res, "mlpd", n_draws = inputs$n_draws, n_obs = n_obs
)
}
@@ -217,7 +210,7 @@ measure_mlpd <- function(
#' measure_ic(ylp)
#' @export
measure_ic <- function(
- ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL
+ ylp, log_weights = NULL, pointwise = NULL
) {
inputs <- .lppd_from_inputs(ylp, log_weights, pointwise, "measure_ic")
ic_i <- if (is.null(pointwise)) -2 * inputs$lppd_i else inputs$lppd_i
@@ -233,7 +226,7 @@ measure_ic <- function(
pointwise = ic_i
)
.create_measure_structure(
- res, higher_is_better, "ic", n_draws = inputs$n_draws, n_obs = n_obs
+ res, "ic", n_draws = inputs$n_draws, n_obs = n_obs
)
}
@@ -258,7 +251,7 @@ measure_ic <- function(
#' measure_acc(y, mupred)
#' @export
measure_acc <- function(
- y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL
+ y, mupred, log_weights = NULL, pointwise = NULL
) {
if (!is.null(pointwise)) {
.inform_ignored_inputs(
@@ -282,7 +275,7 @@ measure_acc <- function(
pointwise = acc_i
)
.create_measure_structure(
- res, higher_is_better, "acc", n_draws = n_draws, n_obs = n_obs
+ res, "acc", n_draws = n_draws, n_obs = n_obs
)
}
@@ -302,14 +295,21 @@ measure_acc <- function(
#' measure_bacc(y, mupred)
#' @export
measure_bacc <- function(
- y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL
+ y, mupred, log_weights = NULL, pointwise = NULL
) {
- .validate_numeric_vector(y, arg = "y")
+ if (is.null(pointwise)) {
+ .validate_numeric_vector(y, arg = "y")
+ }
+
classes <- sort(unique(y))
K <- length(classes)
- if (K < 2) {
+ class_id <- match(y, classes)
+ n_c <- tabulate(class_id, nbins = K)
+
+ if (is.null(pointwise) && K < 2) {
cli::cli_abort("{.fn bacc} requires at least two outcome classes.")
}
+
if (!is.null(pointwise)) {
if (length(pointwise) != length(y)) {
cli::cli_abort("{.arg pointwise} and {.arg y} must have the same length.")
@@ -327,18 +327,22 @@ measure_bacc <- function(
n_obs <- ncol(mupred)
acc_i <- .acc_pointwise(y, mupred, log_weights)
}
-
+
acc_c <- vapply(classes, function(c) mean(acc_i[y == c]), numeric(1))
- n_c <- tabulate(match(y, classes))
- bacc_i <- acc_i / (K * n_c[match(y, classes)])
-
+ bacc_i <- acc_i / (K * n_c[class_id])
+
res <- list(
estimate = mean(acc_c),
se = sqrt(sum(acc_c * (1 - acc_c) / n_c)) / K,
- pointwise = bacc_i
+ pointwise = bacc_i,
+ # the class strata are what makes a difference of balanced accuracies more
+ # than a mean of pointwise differences, and `.se_diff_bacc()` cannot
+ # recover them from `bacc_i`: every misclassified observation stores a
+ # zero whatever its class
+ extra = list(class_id = class_id)
)
.create_measure_structure(
- res, higher_is_better, "bacc", n_draws = n_draws, n_obs = n_obs
+ res, "bacc", n_draws = n_draws, n_obs = n_obs
)
}
@@ -360,7 +364,7 @@ measure_bacc <- function(
#' measure_brier(y, ypred)
#' @export
measure_brier <- function(
- y, ypred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL
+ y, ypred, log_weights = NULL, pointwise = NULL
) {
if (!is.null(pointwise)) {
.inform_ignored_inputs(
@@ -403,7 +407,7 @@ measure_brier <- function(
pointwise = bs_i
)
.create_measure_structure(
- res, higher_is_better, "brier", n_draws = n_draws, n_obs = n_obs
+ res, "brier", n_draws = n_draws, n_obs = n_obs
)
}
@@ -426,7 +430,7 @@ measure_brier <- function(
#' measure_mae(y, mupred)
#' @export
measure_mae <- function(
- y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL
+ y, mupred, log_weights = NULL, pointwise = NULL
) {
inputs <- .point_error_from_inputs(
y, mupred, log_weights, pointwise, "mae", abs
@@ -439,8 +443,7 @@ measure_mae <- function(
pointwise = mae_i
)
.create_measure_structure(
- res, higher_is_better, "mae",
- n_draws = inputs$n_draws, n_obs = inputs$n_obs
+ res, "mae", n_draws = inputs$n_draws, n_obs = inputs$n_obs
)
}
@@ -460,7 +463,7 @@ measure_mae <- function(
#' measure_mse(y, mupred)
#' @export
measure_mse <- function(
- y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL
+ y, mupred, log_weights = NULL, pointwise = NULL
) {
inputs <- .point_error_from_inputs(
y, mupred, log_weights, pointwise, "mse", function(e) e^2
@@ -473,8 +476,7 @@ measure_mse <- function(
pointwise = sqe_i
)
.create_measure_structure(
- res, higher_is_better, "mse",
- n_draws = inputs$n_draws, n_obs = inputs$n_obs
+ res, "mse", n_draws = inputs$n_draws, n_obs = inputs$n_obs
)
}
@@ -493,7 +495,7 @@ measure_mse <- function(
#' measure_rmse(y, mupred)
#' @export
measure_rmse <- function(
- y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL
+ y, mupred, log_weights = NULL, pointwise = NULL
) {
mse_res <- measure_mse(
y = y, mupred = mupred, log_weights = log_weights,
@@ -516,10 +518,37 @@ measure_rmse <- function(
pointwise = sqe_i
)
.create_measure_structure(
- res, higher_is_better, "rmse", n_draws = n_draws, n_obs = n_obs
+ res, "rmse", n_draws = n_draws, n_obs = n_obs
)
}
+#' Delta-method standard error of an R-squared quantity
+#'
+#' The R-squared of one model and the difference in R-squared between two
+#' models have the same form: a mean of squared-error contributions divided by
+#' the model-independent baseline `MSE(y)`. Their standard errors are therefore
+#' the same first-order Taylor approximation, evaluated either at one model's
+#' pointwise squared errors or at the pointwise differences between two models.
+#'
+#' Writing `c = mean(sqe) / MSE(y)`, the three-term expansion
+#' `Var[MSE] - 2 * c * Cov[MSE, MSE(y)] + c^2 * Var[MSE(y)]`, scaled by
+#' `MSE(y)^-1`, is exactly the standard error of the mean of
+#' `sqe_i - c * mse_y_i`. That is the form used here: it needs one variance
+#' rather than three moments, it cannot go negative under the square root, and
+#' it is exactly `0` when `sqe` is identically zero, as it is when a model is
+#' compared against itself.
+#'
+#' @noRd
+#' @param sqe Pointwise squared errors of one model, or pointwise differences
+#' in squared error between two models.
+#' @param mse_y_i Pointwise baseline `(y_i - mean(y))^2`.
+#' @return Numeric scalar standard error.
+.se_r2_delta <- function(sqe, mse_y_i) {
+ mse_y_hat <- mean(mse_y_i)
+ scaled <- sqe - (mean(sqe) / mse_y_hat) * mse_y_i
+ sqrt(var(scaled) / length(sqe)) / mse_y_hat
+}
+
#' Predictive R-squared (`r2`)
#'
#' Computes predictive R-squared as one minus the ratio of prediction MSE to
@@ -537,7 +566,7 @@ measure_rmse <- function(
#' measure_r2(y, mupred)
#' @export
measure_r2 <- function(
- y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL
+ y, mupred, log_weights = NULL, pointwise = NULL
) {
.validate_numeric_vector(y, arg = "y")
if (var(y) == 0) {
@@ -559,25 +588,21 @@ measure_r2 <- function(
mse_y_i <- (y - mean(y))^2
mse_y_hat <- mean(mse_y_i)
-
- var_mse_hat <- mse_res$estimates[2]^2
- cov_mse_msey <- stats::cov(sqe_i, mse_y_i) / n_obs
- var_mse_y_hat <- var(mse_y_i) / n_obs
-
- t1 <- var_mse_hat
- t2 <- -2 * (mse_hat / mse_y_hat) * cov_mse_msey
- t3 <- (mse_hat^2 / mse_y_hat^2) * var_mse_y_hat
- se_r2 <- sqrt(t1 + t2 + t3) * (1 / mse_y_hat)
-
+
est_r2 <- 1 - mse_hat / mse_y_hat
-
+ se_r2 <- .se_r2_delta(sqe_i, mse_y_i)
+
res <- list(
estimate = est_r2,
se = se_r2,
- pointwise = sqe_i
+ pointwise = sqe_i,
+ # `model_compare()` needs the baseline to propagate uncertainty into the
+ # standard error of an r2 difference; `y` is gone by then. See
+ # `.se_diff_r2()`.
+ extra = list(mse_y_i = mse_y_i)
)
.create_measure_structure(
- res, higher_is_better, "r2", n_draws = n_draws, n_obs = n_obs
+ res, "r2", n_draws = n_draws, n_obs = n_obs
)
}
@@ -616,22 +641,39 @@ measure_r2 <- function(
#' both discrete and continuous outcomes; see Hosking (1990, 1996) for
#' theoretical justification in the discrete case.
#'
-#' If log-weights (`log_weights`) are provided (e.g., PSIS weights
-#' for LOO cross-validation), a weighted PWM estimator is used instead, which
-#' accounts for the importance weights when estimating expectations.
+#' The term \eqn{E[|X - X'|]} is computed as a weighted average over all pairs
+#' of draws,
+#' \deqn{E[|X - X'|] = \frac{\sum_i \sum_{j \neq i} w_i w_j |x_i - x_j|}{1 -
+#' \sum_i w_i^2},}
+#' which is evaluated in \eqn{O(S \log S)} using the sorted draws and the
+#' cumulative sums of their weights. If log-weights (`log_weights`) are provided
+#' (e.g., PSIS weights for LOO cross-validation), the \eqn{w_i} are the
+#' normalized importance weights and \eqn{E[|X - y|]} is likewise a weighted
+#' mean. Otherwise the weights are equal, \eqn{w_i = 1/S}, and the expression
+#' reduces to the usual unbiased PWM estimator with the \eqn{1 / (S (S - 1))}
+#' normalization. Because the estimate is a convex combination of
+#' \eqn{|x_i - x_j|}, it is always non-negative and invariant to shifts of
+#' `ypred`.
#'
#' **Sign convention:**
#'
-#' Unscaled scores are returned as losses (lower is better). Scaled scores are
-#' returned as utilities (higher is better), after Bolin & Wallin (2023). Set
-#' `higher_is_better` to select the orientation you want.
+#' Unscaled scores (RPS, CRPS) are returned on the loss scale of Gneiting &
+#' Raftery (2007): lower is better. Scaled scores (SRPS, SCRPS) follow Bolin &
+#' Wallin (2023) and are returned on the utility scale: higher is better.
+#' [model_compare()] reports differences for both on the utility scale, so no
+#' manual conversion is needed there. The deprecated [crps()] returned the
+#' negated unscaled score; `-measure_rps(...)$pointwise` reproduces it.
#'
#' @param y A numeric vector of \eqn{n} observed outcomes. May be integer-valued
#' (for RPS/SRPS) or continuous (for CRPS/SCRPS).
#' @param ypred A numeric matrix of posterior predictive draws with dimensions
#' \eqn{S \times n} (draws × observations).
-#' @param pointwise Optional numeric vector of precomputed pointwise rps values.
-#' If provided, `y`, `ypred`, and `log_weights` are ignored.
+#' @param pointwise Optional numeric vector of precomputed pointwise values, on
+#' the scale of the measure that is returned: RPS/CRPS when `scaled = FALSE`
+#' and SRPS/SCRPS when `scaled = TRUE`. The values are used as they are, with
+#' no further transformation; in particular, unscaled values are not converted
+#' to the scaled variant. If provided, `y`, `ypred`, and `log_weights` are
+#' ignored.
#' @param scaled Logical; if `TRUE`, computes the scaled variant (SRPS for
#' discrete outcomes, SCRPS for continuous outcomes). Default is `FALSE`.
#' @inheritParams measure_params
@@ -684,12 +726,14 @@ measure_r2 <- function(
#' weather forecasts. *Mathematical Geosciences*, 50:209–234.
#'
#' @export
-measure_rps <- function(y, ypred, log_weights = NULL, pointwise = NULL, scaled = FALSE,
- higher_is_better = NULL) {
+measure_rps <- function(y, ypred, log_weights = NULL, pointwise = NULL,
+ scaled = FALSE) {
if (is.null(pointwise)) {
+ .validate_numeric_vector(y, arg = "y")
+ .validate_numeric_matrix(ypred, arg = "ypred", ncol = length(y))
n_draws <- nrow(ypred)
n_obs <- ncol(ypred)
-
+
w <- if (is.null(log_weights)) {
NULL
} else {
@@ -740,7 +784,7 @@ measure_rps <- function(y, ypred, log_weights = NULL, pointwise = NULL, scaled =
)
name <- if(isTRUE(scaled)) "srps" else "rps"
.create_measure_structure(
- res, higher_is_better, name, n_draws = n_draws, n_obs = n_obs
+ res, name, n_draws = n_draws, n_obs = n_obs
)
}
@@ -763,11 +807,10 @@ measure_rps <- function(y, ypred, log_weights = NULL, pointwise = NULL, scaled =
#' measure_srps(y, ypred)
#'
#' @export
-measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL,
- higher_is_better = NULL) {
+measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL) {
measure_rps(
- y = y, ypred = ypred, log_weights = log_weights,
- scaled = TRUE, higher_is_better = higher_is_better
+ y = y, ypred = ypred, log_weights = log_weights, pointwise = pointwise,
+ scaled = TRUE
)
}
@@ -787,24 +830,269 @@ measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL,
# `mlpd`, `ic`). `.elpd_pointwise()` gives that vector for the source.
# `.compute_measure()` passes it as `pointwise`, optionally through
# `elpd_transform` first.
+# `digits` is the default number of decimal places `print()` uses for the
+# measure. A measure on the scale of the data
+# (`mae`, `rmse`, `mse`, `rps`, `srps`) sets no value. `.measure_digits()`
+# then takes the places from the standard error.
.measure_spec <- list(
- elpd = list(fun = measure_elpd, loss = FALSE, needs_elpd = TRUE),
+ elpd = list(
+ fun = measure_elpd,
+ loss = FALSE,
+ diff_method = "sum",
+ needs_elpd = TRUE,
+ digits = 1
+ ),
ic = list(
- fun = measure_ic, loss = TRUE,
- needs_elpd = TRUE, elpd_transform = function(x) -2 * x
+ fun = measure_ic,
+ loss = TRUE,
+ diff_method = "sum",
+ needs_elpd = TRUE,
+ elpd_transform = function(x) -2 * x,
+ digits = 1
),
- mlpd = list(fun = measure_mlpd, loss = FALSE, needs_elpd = TRUE),
- mae = list(fun = measure_mae, loss = TRUE),
- r2 = list(fun = measure_r2, loss = FALSE),
- rmse = list(fun = measure_rmse, loss = TRUE),
- mse = list(fun = measure_mse, loss = TRUE),
- acc = list(fun = measure_acc, loss = FALSE),
- bacc = list(fun = measure_bacc, loss = FALSE),
- rps = list(fun = measure_rps, loss = TRUE),
- srps = list(fun = measure_srps, loss = FALSE),
- brier = list(fun = measure_brier, loss = TRUE)
+ mlpd = list(
+ fun = measure_mlpd,
+ loss = FALSE,
+ diff_method = "mean",
+ needs_elpd = TRUE,
+ digits = 3
+ ),
+ mae = list(fun = measure_mae, loss = TRUE, diff_method = "mean"),
+ r2 = list(
+ fun = measure_r2,
+ loss = FALSE,
+ diff_method = "measure_specific",
+ se_diff_fun = "r2",
+ digits = 3
+ ),
+ rmse = list(
+ fun = measure_rmse,
+ loss = TRUE,
+ diff_method = "measure_specific",
+ se_diff_fun = "rmse"
+ ),
+ mse = list(fun = measure_mse, loss = TRUE, diff_method = "mean"),
+ acc = list(fun = measure_acc, loss = FALSE, diff_method = "mean", digits = 3),
+ bacc = list(
+ fun = measure_bacc,
+ loss = FALSE,
+ diff_method = "measure_specific",
+ se_diff_fun = "bacc",
+ digits = 3
+ ),
+ # unscaled RPS/CRPS is the Gneiting & Raftery (2007) loss; the scaled variant
+ # follows Bolin & Wallin (2023), where larger is better
+ rps = list(fun = measure_rps, loss = TRUE, diff_method = "mean"),
+ srps = list(fun = measure_srps, loss = FALSE, diff_method = "mean"),
+ brier = list(
+ fun = measure_brier,
+ loss = TRUE,
+ diff_method = "mean",
+ digits = 3
+ )
)
+# measure-specific standard errors -----------------------------
+#
+# Measures whose overall estimate is not a sum or mean of pointwise
+# contributions cannot use the paired pointwise standard error. They register a
+# `se_diff_fun` in `.measure_spec`, naming an entry of `.se_diff_funs` below.
+# Custom measures take theirs from `attr(fun, "measure_se_diff")`, under the
+# same calling contract.
+#
+# Such a function receives `ref` and `cmp`, each a list with the elements
+# `estimate`, `se`, `pointwise`, and `extra` for one model, always on the
+# measure's natural scale, and returns the standard
+# error of the difference as a numeric scalar. The difference itself is always
+# `estimate_cmp - estimate_ref` and is computed by `model_compare()`.
+
+#' Standard error of an RMSE difference
+#'
+#' First-order bivariate Taylor (delta method) approximation of the standard
+#' error of \eqn{RMSE(M_cmp) - RMSE(M_ref)}, propagated from the MSE scale on
+#' which the pointwise squared errors live.
+#'
+#' @noRd
+#' @param ref,cmp Per-model inputs; `pointwise` holds squared errors.
+#' @return Numeric scalar standard error.
+.se_diff_rmse <- function(ref, cmp) {
+ sqe_ref <- ref$pointwise
+ sqe_cmp <- cmp$pointwise
+ n <- length(sqe_ref)
+ mse_ref <- mean(sqe_ref)
+ mse_cmp <- mean(sqe_cmp)
+
+ # a perfect predictor leaves the ratios below undefined; `measure_rmse()`
+ # reports a zero standard error in that case, so do the same here
+ if (n <= 1L || mse_ref <= 0 || mse_cmp <= 0) {
+ return(0)
+ }
+
+ # `Var(mse_cmp) / mse_cmp + Var(mse_ref) / mse_ref -
+ # 2 * Cov(mse_cmp, mse_ref) / sqrt(mse_cmp * mse_ref)` is exactly the variance
+ # of the mean of the paired contrast below, so forming the contrast pointwise
+ # and taking one variance keeps the three terms from being computed and
+ # subtracted separately. That makes the estimator structurally non-negative
+ # (no correlation above one to clamp) and makes two models with the same
+ # squared errors cancel bit-for-bit rather than leave rounding noise that
+ # `sqrt()` then amplifies to ~1e-7.
+ z <- sqe_cmp / sqrt(mse_cmp) - sqe_ref / sqrt(mse_ref)
+
+ 0.5 * sqrt(stats::var(z) / n)
+}
+
+#' Standard error of an R-squared difference
+#'
+#' First-order trivariate Taylor (delta method) approximation of the standard
+#' error of \eqn{R^2(M_cmp) - R^2(M_ref)}. The difference equals
+#' \eqn{-MSE(M_cmp, M_ref) / MSE(y)}, so it is the same expansion as the
+#' single-model standard error in `measure_r2()` with the pointwise squared
+#' errors replaced by their pointwise differences; both go through
+#' `.se_r2_delta()`.
+#'
+#' @noRd
+#' @param ref,cmp Per-model inputs; `pointwise` holds squared errors and
+#' `extra$mse_y_i` the baseline `(y_i - mean(y))^2` stored by `measure_r2()`.
+#' @return Numeric scalar standard error, or `NA_real_` when the baseline is
+#' unavailable.
+.se_diff_r2 <- function(ref, cmp) {
+ # the baseline is a property of `y`, so either model's copy will do; models
+ # fitted to different `y` are already reported by the `yhash` warning
+ mse_y_i <- if (!is.null(ref$extra$mse_y_i)) {
+ ref$extra$mse_y_i
+ } else {
+ cmp$extra$mse_y_i
+ }
+
+ # objects computed before the baseline was stored cannot support the
+ # covariance terms; report the difference without a standard error rather
+ # than refusing the whole comparison
+ if (!is.numeric(mse_y_i) || length(mse_y_i) != length(ref$pointwise)) {
+ return(NA_real_)
+ }
+
+ .se_r2_delta(cmp$pointwise - ref$pointwise, mse_y_i)
+}
+
+#' Standard error of a balanced-accuracy difference
+#'
+#' Balanced accuracy averages class-wise accuracies, so a difference of two
+#' balanced accuracies is a difference of two stratified means, not a mean of
+#' pointwise differences. The two sources of dependence separate: the class
+#' strata are disjoint sets of observations and so contribute independent
+#' variances, while within a stratum both models score the *same* `n_c`
+#' observations and are therefore paired. Writing
+#' \eqn{d_i = acc_i(M_cmp) - acc_i(M_ref)},
+#'
+#' \deqn{SE = \frac{1}{K} \sqrt{\sum_c Var(d_i : i \in c) / n_c}}
+#'
+#' which is the difference-analogue of the single-model
+#' \eqn{\sqrt{\sum_c acc_c (1 - acc_c) / n_c} / K} in `measure_bacc()`: the
+#' per-stratum binomial variance replaced by the paired-difference variance.
+#' Within a stratum this is the McNemar variance of a paired difference of
+#' proportions, \eqn{(b + c)/n_c^2 - (b - c)^2/n_c^3} in discordant-pair form,
+#' up to the \eqn{n_c/(n_c - 1)} of the sample variance.
+#'
+#' For binary outcomes balanced accuracy is \eqn{(sens + spec)/2}, so this is
+#' the estimand of Newcombe (2001) at a mixing parameter of one half, and half
+#' the difference of two Youden indices in a paired design (Chen et al., 2015).
+#'
+#' @references
+#' Newcombe, R. G. (2001). Simultaneous comparison of sensitivity and
+#' specificity of two tests in the paired design: a straightforward graphical
+#' approach. *Statistics in Medicine*, 20(6):907--915.
+#'
+#' Chen, F., Xue, Y., Tan, M. T., and Chen, P. (2015). Efficient statistical
+#' tests to compare Youden index: accounting for contingency correlation.
+#' *Statistics in Medicine*, 34(9):1560--1576.
+#'
+#' @noRd
+#' @param ref,cmp Per-model inputs; `pointwise` holds `acc_i / (K * n_c)` and
+#' `extra$class_id` the class index stored by `measure_bacc()`.
+#' @return Numeric scalar standard error, or `NA_real_` when the class strata
+#' are unavailable.
+.se_diff_bacc <- function(ref, cmp) {
+ # the strata are a property of `y`, so either model's copy will do; models
+ # fitted to different `y` are already reported by the `yhash` warning
+ class_id <- ref$extra$class_id
+ if (is.null(class_id)) {
+ class_id <- cmp$extra$class_id
+ }
+
+ n <- length(ref$pointwise)
+ # objects computed before the strata were stored cannot be stratified;
+ # report the difference without a standard error rather than refusing the
+ # whole comparison
+ if (!is.numeric(class_id) || length(class_id) != n) {
+ return(NA_real_)
+ }
+
+ n_c <- tabulate(class_id)
+ K <- length(n_c)
+ # undo the `acc_i / (K * n_c)` scaling to recover the 0/1 accuracies, so the
+ # variances below are on the natural per-observation scale
+ d <- (cmp$pointwise - ref$pointwise) * (K * n_c[class_id])
+
+ # a stratum holding a single observation supports no variance estimate and
+ # contributes nothing, matching `measure_bacc()`, where `acc_c` is then 0 or
+ # 1 and its binomial variance vanishes
+ var_c <- vapply(
+ seq_len(K),
+ function(k) {
+ if (n_c[k] < 2L) 0 else stats::var(d[class_id == k]) / n_c[k]
+ },
+ numeric(1)
+ )
+
+ sqrt(sum(var_c)) / K
+}
+
+# registry of built-in `se_diff_fun` implementations, referenced by name from
+# `.measure_spec` so that stored objects carry a string rather than a closure
+.se_diff_funs <- list(
+ rmse = .se_diff_rmse,
+ r2 = .se_diff_r2,
+ bacc = .se_diff_bacc
+)
+
+#' Return the per-measure information recorded on a result object
+#' @noRd
+#' @param measure_entry Normalized measure entry, or a built-in measure name.
+.measure_info <- function(measure_entry) {
+ if (is.character(measure_entry)) {
+ measure_entry <- list(
+ name = measure_entry,
+ type = "builtin",
+ key = measure_entry
+ )
+ }
+
+ if (measure_entry$type == "builtin") {
+ entry <- .measure_spec[[measure_entry$key]]
+ if (is.null(entry)) {
+ return(NULL)
+ }
+ return(list(
+ loss = isTRUE(entry$loss),
+ diff_method = entry$diff_method,
+ se_diff_fun = entry$se_diff_fun
+ ))
+ }
+
+ # A custom measure may declare how the standard error of its difference is
+ # computed, through `attr(fun, "measure_se_diff")`. The declaration is
+ # recorded here, so a later `model_compare()` finds it without an argument.
+ # When the measure declares nothing, `se_diff_fun` is absent and
+ # `model_compare()` reports an `NA` standard error.
+ # Whether the measure is a loss is declared the same way, through
+ # `attr(fun, "measure_loss")`.
+ list(
+ loss = isTRUE(measure_entry$loss),
+ diff_method = "custom",
+ se_diff_fun = measure_entry$se_diff
+ )
+}
+
#' Supported predictive measure names
#'
#' A character vector of measure names that can be passed to the `measures`
@@ -815,17 +1103,7 @@ measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL,
supported_measures_list <- names(.measure_spec)
# internal function that produces output format for measures
-.create_measure_structure <- function(
- res, higher_is_better, measure_name, n_draws, n_obs
-) {
- if (!is.null(higher_is_better)) {
- spec <- .measure_spec[[measure_name]]
- natural_higher <- is.null(spec) || !isTRUE(spec$loss)
- if (xor(natural_higher, isTRUE(higher_is_better))) {
- res$estimate <- -res$estimate
- res$pointwise <- -res$pointwise
- }
- }
+.create_measure_structure <- function(res, measure_name, n_draws, n_obs) {
out <- list()
out$estimates <- matrix(
c(res$estimate, res$se),
@@ -837,6 +1115,9 @@ supported_measures_list <- names(.measure_spec)
ncol = 1,
dimnames = list(NULL, measure_name)
)
+ # `extra` carries auxiliary data for `se_diff_fun()`, on the measure's
+ # natural scale; absent when the measure stores nothing
+ out$extra <- res$extra
structure(
out,
diff --git a/R/pred_measure-compute.R b/R/pred_measure-compute.R
index 367a1485..1f996b3d 100644
--- a/R/pred_measure-compute.R
+++ b/R/pred_measure-compute.R
@@ -27,16 +27,36 @@
#' \itemize{
#' \item A **character vector** of built-in names; see
#' [supported_measures_list].
-#' \item A **function** with attribute `"measure_name"` for one custom measure.
+#' \item A **function** built with [custom_measure()] for one custom
+#' measure.
#' \item A **list** mixing character scalars (built-in names) and named
#' functions (custom measures), e.g. `list("rps", my_metric = my_fun)`.
#' }
#' Custom functions are called with any of `y`, `ypred`, `mupred`, `ylp`, and
#' `log_weights` that appear in their formals, plus arguments from `control`.
#' They must return a list with `estimates` and `pointwise`.
-#' @param measure_name For a single custom function, set
-#' `attr(my_fun, "measure_name") <- "my_metric"` before passing `my_fun` to
-#' `measures`.
+#'
+#' A custom measure declares whether it is a loss (lower is better) or a
+#' utility (higher is better) with `loss` in [custom_measure()]. Without it a
+#' custom measure is taken to be a utility. [model_compare()] uses the declaration to
+#' put all measures on a common utility scale and to rank models, so an
+#' undeclared loss is compared and ranked in the wrong direction.
+#'
+#' A custom measure can declare how the standard error of a difference
+#' between two models is computed, with `se_diff_fun` in [custom_measure()].
+#' It accepts a function
+#' `function(ref, cmp) ...` or the shorthands `"sum"` and `"mean"` for the
+#' paired pointwise formulas. Without a declaration, [model_compare()]
+#' reports the difference with an `NA` standard error. A function receives one list per model with elements
+#' `estimate`, `se`, `pointwise`, and `extra`, always on the measure's natural
+#' scale, and must return the standard error of the difference as a numeric
+#' scalar.
+#'
+#' `extra` is for anything the standard error needs that the pointwise values
+#' do not carry. Return it as an additional list element `extra` from the
+#' measure function and it is stored alongside the estimates and passed on to
+#' its `measure_se_diff` function; the built-in `r2` uses it for the baseline
+#' `(y_i - mean(y))^2`, which cannot be recovered once `y` is out of scope.
#' @param group_ids Optional vector of group identifiers for grouped summaries
#' (reserved; not yet implemented).
#' @param loo A [loo::loo()] result, computed with
@@ -77,19 +97,17 @@ do_pred_measure <- function(
control = list()
) {
# input validation ---------------------------------------------------
- .validate_control(control)
-
if (!is.null(group_ids)) {
cli::cli_abort(
"`group_ids` is reserved for future feature but is not yet implemented."
)
}
+ .validate_control(control, .normalize_measure(measures))
measures <- .prepare_measures(
measures, predperf, supported_measures_list, source
)
needs_elpd <- .any_needs_elpd(measures)
-
if (source == "loo") {
if (is.null(predperf)) {
if (!is.null(loo) && is.null(loo$psis_object)) {
@@ -97,6 +115,7 @@ do_pred_measure <- function(
"No `psis_object` found in `loo` object. Did you run loo(..., save_psis = 'TRUE')."
))
}
+ .warn_posthoc(loo, measures)
} else {
if (is.null(psis_object) && !is.null(predperf$psis_object)) {
cli::cli_inform("Using psis_object for LOO CV from `predperf`")
@@ -165,6 +184,13 @@ do_pred_measure <- function(
if (is.null(result_name)) {
result_name <- entry$name
}
+ # A measure may rename its own result: `rps` with `scaled = TRUE` returns
+ # `srps`. Read the spec under that name, or the requested measure's
+ # orientation leaks into the renamed row and inverts the ranking.
+ info_entry <- entry
+ if (entry$type == "builtin" && !is.null(.measure_spec[[result_name]])) {
+ info_entry$key <- result_name
+ }
# add new measures to existing pred_measure results
name_updated <- .measure_result_name(source, result_name)
if (!is.null(estimates) && name_updated %in% rownames(estimates)) {
@@ -178,7 +204,9 @@ do_pred_measure <- function(
mat = estimates,
name = result_name,
values = .measure_estimate_se(sel_measure),
- margin = 1
+ margin = 1,
+ measure_entry = info_entry,
+ extra = sel_measure$extra
)
pointwise <- .merge_matrix(
source = source,
@@ -228,6 +256,56 @@ do_pred_measure <- function(
# internal helper functions ---------------------------------------------------
+#' Detect a post-hoc correction of a loo object
+#'
+#' `loo_moment_match()` sets the `posthoc` attribute. `brms::reloo()` sets
+#' `diagnostics$pareto_k` to 0 for the refitted observations but does not
+#' change `psis_object`, so the two sets of Pareto k values differ.
+#'
+#' @param loo A [loo::loo()] result with a `psis_object`.
+#'
+#' @return A character vector of method names, or `NULL`.
+#' @noRd
+.detect_posthoc <- function(loo) {
+ method <- attr(loo, "posthoc")
+ k_loo <- loo$diagnostics$pareto_k
+ k_psis <- loo$psis_object$diagnostics$pareto_k
+ if (!is.null(k_loo) && !is.null(k_psis) && !isTRUE(all.equal(k_loo, k_psis))) {
+ method <- union(method, "reloo")
+ }
+ method
+}
+
+#' Warn if measures other than elpd use a post-hoc corrected loo object
+#'
+#' A post-hoc method corrects `pointwise[, "elpd_loo"]` only. The other
+#' measures use `psis_object$log_weights` with the original draws in `ypred`
+#' and `mupred`, so their values are not corrected.
+#'
+#' @param loo A [loo::loo()] result with a `psis_object`.
+#' @param measures Measure entries from `.prepare_measures()`.
+#'
+#' @return `NULL`, invisibly. Called for the warning.
+#' @noRd
+.warn_posthoc <- function(loo, measures) {
+ method <- .detect_posthoc(loo)
+ if (is.null(method)) {
+ return(invisible(NULL))
+ }
+ not_elpd <- vapply(measures, function(e) {
+ !(e$type == "builtin" && isTRUE(.measure_spec[[e$key]]$needs_elpd))
+ }, logical(1L))
+ if (any(not_elpd)) {
+ keys <- vapply(measures[not_elpd], function(e) e$name, character(1L))
+ cli::cli_warn(c(
+ "The {.arg loo} object was corrected with {.val {method}}.",
+ "!" = "Only {.val elpd}, {.val mlpd} and {.val ic} include this correction.",
+ "i" = "{.val {keys}} use{?s/} the uncorrected PSIS weights."
+ ))
+ }
+ invisible(NULL)
+}
+
#' Resolve or compute the PSIS object for LOO scoring
#'
#' @description
@@ -412,10 +490,10 @@ do_pred_measure <- function(
) {
if (measure_entry$type == "builtin") {
spec <- .measure_spec[[measure_entry$key]]
- measure_fun <- spec$fun
- if (is.null(measure_fun)) {
+ if (is.null(spec)) {
cli::cli_abort("Unknown built-in measure {.val {measure_entry$key}}.")
}
+ measure_fun <- spec$fun
} else {
spec <- NULL
measure_fun <- measure_entry$key
@@ -535,6 +613,12 @@ do_pred_measure <- function(
#' `(estimate, se)`; for `margin = 2`, length-`n` pointwise vector.
#' @param margin `1` to merge along rows (estimates table), `2` along columns
#' (pointwise table).
+#' @param measure_entry Optional normalized measure entry; when merging an
+#' estimates row (`margin = 1`), the `measure_info` used by [model_compare()]
+#' is recorded from this entry.
+#' @param extra Optional list of auxiliary data the measure stores for its
+#' `se_diff_fun` (the measure result's `extra` element); recorded in `measure_info`
+#' when merging an estimates row (`margin = 1`).
#'
#' @return Updated matrix with `name` as a row or column name.
#'
@@ -550,7 +634,15 @@ do_pred_measure <- function(
}
#' @noRd
-.merge_matrix <- function(source, mat, name, values, margin) {
+.merge_matrix <- function(
+ source,
+ mat,
+ name,
+ values,
+ margin,
+ measure_entry = NULL,
+ extra = NULL
+) {
is_row <- margin == 1
bind_fn <- if (is_row) rbind else cbind
name_updated <- .measure_result_name(source, name)
@@ -561,8 +653,31 @@ do_pred_measure <- function(
matrix(values, ncol = 1, dimnames = list(NULL, name_updated))
}
- if (is.null(mat)) return(new_slice)
- bind_fn(mat, new_slice)
+ info <- if (is_row && !is.null(measure_entry)) {
+ .measure_info(measure_entry)
+ }
+ if (!is.null(info) && !is.null(extra)) {
+ info$extra <- extra
+ }
+
+ old_info <- if (is_row && !is.null(mat)) {
+ attr(mat, "measure_info")
+ }
+
+ mat <- if (is.null(mat)) new_slice else bind_fn(mat, new_slice)
+
+ if (is_row && (!is.null(info) || !is.null(old_info))) {
+ measure_info <- old_info
+ if (is.null(measure_info)) {
+ measure_info <- list()
+ }
+ if (!is.null(info)) {
+ measure_info[[name]] <- info
+ }
+ attr(mat, "measure_info") <- measure_info
+ }
+
+ mat
}
#' Construct the S3 predictive measure result object
@@ -585,8 +700,9 @@ do_pred_measure <- function(
#' @param save_psis Logical; if `TRUE`, include `psis_object` in the result.
#'
#' @return A list with elements `estimates`, `pointwise`, and optionally
-#' `diagnostics`, `psis_object`, and `log_weights`. Class attributes are added
-#' by \code{.add_attributes()}.
+#' `diagnostics`, `psis_object`, and `log_weights`. Attribute `measure_info`
+#' records per-measure metadata for measures added in the current call. Class
+#' attributes are added by \code{.add_attributes()}.
#'
#' @noRd
.build_pred_measure <- function(
@@ -596,6 +712,12 @@ do_pred_measure <- function(
psis_object,
save_psis
) {
+ measure_info <- attr(estimates, "measure_info")
+ if (is.null(measure_info)) {
+ measure_info <- list()
+ }
+ attr(estimates, "measure_info") <- NULL
+
output_list <- list(
estimates = estimates,
pointwise = pointwise
@@ -610,22 +732,29 @@ do_pred_measure <- function(
output_list$log_weights <- psis_object$log_weights
}
- structure(output_list)
+ structure(
+ output_list,
+ measure_info = measure_info
+ )
}
#' Attach S3 classes and metadata attributes to a result
#'
#' @description
-#' Sets `class`, `source`, and `dims` attributes on a predictive measure object.
+#' Sets `class`, `source`, `dims`, and `measure_info` attributes on a predictive
+#' measure object.
#'
#' When updating an existing result (`predperf` is not `NULL`), copies attributes
#' from `predperf` and refreshes `dims` from newly supplied input matrices.
+#' Merges `measure_info` from the prior result with any new entries supplied on
+#' `predperf_res` (from \code{.build_pred_measure()}).
#' When `save_psis = FALSE`, clears any stored `psis_object` from the prior
#' result.
#'
#' For new objects, copies relevant attributes from `loo` or `kfold` inputs
#' (e.g. `yhash`, `model_name`, fold structure) and assigns a source-specific
-#' subclass (`"insample_pred_measure"`, `"loo_pred_measure"`, etc.).
+#' subclass (`"insample_pred_measure"`, `"loo_pred_measure"`, etc.). Sets
+#' `measure_info`, seeding the `elpd` entry.
#'
#' @param save_psis Logical; when `FALSE` and accumulating, clears stored
#' `psis_object` from the prior result.
@@ -645,13 +774,30 @@ do_pred_measure <- function(
#' @return The updated `predperf_res` with class and attributes set.
#'
#' @noRd
-.add_attributes <- function(save_psis, predperf_res, y, ypred, mupred, ylp, ylp_test, kfold, loo, predperf, source) {
+.add_attributes <- function(
+ save_psis,
+ predperf_res,
+ y,
+ ypred,
+ mupred,
+ ylp,
+ ylp_test,
+ kfold,
+ loo,
+ predperf,
+ source
+) {
+ new_info <- attr(predperf_res, "measure_info")
+ if (is.null(new_info)) {
+ new_info <- list()
+ }
+
if (!is.null(predperf)) {
if (isFALSE(save_psis)) {
predperf$psis_object <- NULL
}
attributes(predperf_res) <- attributes(predperf)
-
+
dims <- if (!is.null(ypred)) {
dim(ypred)
} else if (!is.null(mupred)) {
@@ -662,10 +808,21 @@ do_pred_measure <- function(
attr(predperf, "dims")
}
attr(predperf_res, "dims") <- dims
-
+ measure_info <- attr(predperf, "measure_info")
+ if (is.null(measure_info)) {
+ measure_info <- list()
+ }
+ if (is.null(measure_info$elpd)) {
+ measure_info$elpd <- .measure_info("elpd")
+ }
+ if (length(new_info)) {
+ measure_info[names(new_info)] <- new_info
+ }
+ attr(predperf_res, "measure_info") <- measure_info
+
return(predperf_res)
}
-
+
predperf_res <- switch(
source,
kfold = .copy_attrs(
@@ -709,6 +866,13 @@ do_pred_measure <- function(
}
attr(predperf_res, "class") <- classes
attr(predperf_res, "source") <- source
-
- return(predperf_res)
-}
\ No newline at end of file
+ measure_info <- list(
+ elpd = .measure_info("elpd")
+ )
+ if (length(new_info)) {
+ measure_info[names(new_info)] <- new_info
+ }
+ attr(predperf_res, "measure_info") <- measure_info
+
+ predperf_res
+}
diff --git a/R/pred_measure-helpers.R b/R/pred_measure-helpers.R
index f5e637bb..224681e8 100644
--- a/R/pred_measure-helpers.R
+++ b/R/pred_measure-helpers.R
@@ -3,7 +3,8 @@
#' @description
#' Converts `measure` (character, function, list, or `NULL`) into a list of
#' entries with elements `name`, `type` (`"builtin"` or `"custom"`), and `key`
-#' (built-in name or function).
+#' (built-in name or function). Custom entries also carry `loss`, taken from
+#' `attr(fun, "measure_loss")`.
#'
#' @param measure User-supplied `measure` argument.
#'
@@ -40,13 +41,8 @@
if (is.character(el) && length(el) == 1L) {
list(name = el, type = "builtin", key = el)
} else if (is.function(el)) {
- if (is.null(nm) || !nzchar(nm)) {
- cli::cli_abort(c(
- "Each custom function in {.arg measure} must be named.",
- "i" = "Use {.code measures = list(my_metric = my_fun)}."
- ))
- }
- list(name = nm, type = "custom", key = el)
+ name <- if (is.null(nm) || !nzchar(nm)) NULL else nm
+ .measure_entry_custom(el, name = name)
} else {
cli::cli_abort(c(
"Each element of {.arg measure} must be a character scalar (built-in",
@@ -68,18 +64,59 @@
#' Build a custom measure entry from a function
#'
+#' The name and the orientation of a measure are properties of its definition,
+#' so both are declared once on the function via `attr(fun, "measure_name")`
+#' and `attr(fun, "measure_loss")` rather than at every call. A custom measure
+#' is a utility (higher is better) unless it declares itself a loss.
+#'
#' @param fun Function implementing a custom measure.
+#' @param name Measure name, when it comes from the name of a `measure` list
+#' element rather than from `attr(fun, "measure_name")`.
#' @noRd
-.measure_entry_custom <- function(fun) {
- name <- attr(fun, "measure_name", exact = TRUE)
- if (is.null(name) || length(name) != 1L || !nzchar(name)) {
- cli::cli_abort(c(
- "A custom function passed to {.arg measure} must have attribute",
- "{.code measure_name}.",
- "i" = "Set {.code attr(my_fun, \"measure_name\") <- \"my_metric\"}."
- ))
+.measure_entry_custom <- function(fun, name = NULL) {
+ if (is.null(name)) {
+ name <- attr(fun, "measure_name", exact = TRUE)
+ if (is.null(name) || length(name) != 1L || !nzchar(name)) {
+ stop(
+ "A custom measure needs a name. Create it with ",
+ "custom_measure(fun, name = \"my_metric\").",
+ call. = FALSE
+ )
+ }
+ } else {
+ attr_name <- attr(fun, "measure_name", exact = TRUE)
+ if (!is.null(attr_name) && length(attr_name) == 1L && nzchar(attr_name) &&
+ !identical(attr_name, name)) {
+ cli::cli_warn(c(
+ "Custom measure named {.val {name}} in {.arg measure} also has",
+ "{.code attr(fun, \"measure_name\") = {.val {attr_name}}}.",
+ "i" = "Using the list name {.val {name}}; the attribute is ignored here."
+ ))
+ }
+ }
+
+ loss <- attr(fun, "measure_loss", exact = TRUE)
+ if (is.null(loss)) {
+ loss <- FALSE
+ } else if (!is.logical(loss) || length(loss) != 1L || is.na(loss)) {
+ stop(
+ "Custom measure '", name, "' must declare loss as TRUE or FALSE; ",
+ "see custom_measure().",
+ call. = FALSE
+ )
+ }
+
+ # A measure that knows how to compute the standard error of its own
+ # difference declares it here, so a comparison needs no extra argument.
+ se_diff <- attr(fun, "measure_se_diff", exact = TRUE)
+ if (!is.null(se_diff)) {
+ se_diff <- .check_se_diff_value(
+ se_diff, name, origin = "`se_diff_fun`"
+ )
}
- list(name = name, type = "custom", key = fun)
+
+ list(name = name, type = "custom", key = fun, loss = loss,
+ se_diff = se_diff)
}
#' Check duplicate measure names
@@ -261,6 +298,13 @@
}
# pass measure name if user set it as attribute
attr(res, "measure") <- measure_name
+ if (!is.null(res$extra) && !is.list(res$extra)) {
+ cli::cli_abort(c(
+ "{.field extra} from custom measure {.val {measure_name}} must be a list.",
+ "i" = "It is handed to its {.code se_diff_fun(ref, cmp)} as
+ {.code ref$extra} and {.code cmp$extra}."
+ ))
+ }
invisible(res)
}
@@ -596,6 +640,7 @@
)
}
+
#' Probability-weighted moment estimator of E|X - X'|
#'
#' @description
@@ -618,6 +663,10 @@
#' non-negative, so `log()` of it in the scaled scores is always defined, and
#' the coefficients sum to zero, so it is invariant to shifts of `ypred`.
#'
+#' This is the bias-corrected weighted Gini mean difference, not the estimator
+#' derived in `notes/crps_pwm.pdf`; see decision D5 in `notes/developer-notes.md`
+#' for why that derivation is not used here.
+#'
#' @param ypred Numeric matrix of posterior predictive draws (`n_draws`
#' \eqn{\times} `n_obs`), where rows are draws and columns are observations.
#' @param w Optional numeric matrix of column-normalized weights on the
@@ -664,20 +713,22 @@
)
}
-
-
#' Validate control argument
-#'
+#'
#' @description
-#' Validates that the arguments passed to the control list are valid
-#' arguments for the corresponding function. If not, a warning is issued that
+#' Validates that the arguments passed to the control list are valid
+#' arguments for the corresponding function. If not, a warning is issued that
#' corresponding invalid argument is ignored.
-#'
+#'
#' @param control Named list of per-measure settings.
+#' @param measures Optional list of normalized measure entries from
+#' `.prepare_measures()`. When supplied, control names are resolved against
+#' the requested measures, so custom measures are validated against their own
+#' formals; without it only built-in names can be checked.
#'
#' @keywords internal
#' @noRd
-.validate_control <- function(control) {
+.validate_control <- function(control, measures = NULL) {
res <- checkmate::check_list(control, types = "list", names = "named")
if (!isTRUE(res)) {
cli::cli_abort(c(
@@ -685,17 +736,45 @@
"i" = "Expected format: {.code list(fun_name = list(arg1 = val1, arg2 = val2))}"
))
}
-
+
+ # without `measures` the requested measures are unknown, so a control name is
+ # only checked against the built-in registry
+ known_measures <- !is.null(measures)
+ if (is.null(measures)) {
+ measures <- list()
+ }
+ entries <- stats::setNames(
+ measures,
+ vapply(measures, function(e) e$name, character(1L))
+ )
+
for (func_name in names(control)) {
- invalid_args <- names(control[[func_name]])[
- !names(control[[func_name]]) %in% names(formals(match.fun(paste0("measure_", func_name))))
- ]
+ entry <- if (func_name %in% names(entries)) entries[[func_name]] else NULL
+ # custom measures are validated against their own formals, built-ins
+ # against the registry; a name matching neither accepts nothing
+ valid_args <- if (!is.null(entry) && identical(entry$type, "custom")) {
+ names(formals(entry$key))
+ } else if (is.null(entry) && known_measures) {
+ NULL
+ } else {
+ spec <- .measure_spec[[if (is.null(entry)) func_name else entry$key]]
+ if (is.null(spec)) NULL else names(formals(spec$fun))
+ }
+ if (is.null(valid_args)) {
+ cli::cli_warn(c(
+ "Ignoring {.arg control} entry {.val {func_name}}, which matches no",
+ "measure being computed."
+ ))
+ next
+ }
+ invalid_args <- setdiff(names(control[[func_name]]), valid_args)
if (length(invalid_args) > 0) {
cli::cli_warn(
"Ignoring {.arg {invalid_args}} as it is not a valid argument of {.fn {func_name}}."
)
}
}
+ invisible(NULL)
}
#' Subset measure results
diff --git a/R/pred_measure.R b/R/pred_measure.R
index b2c51fae..0ec52d56 100644
--- a/R/pred_measure.R
+++ b/R/pred_measure.R
@@ -28,7 +28,11 @@
#' }
#'
#' The attribute `source` is `"insample"`. Attribute `dims` gives posterior
-#' draws × observations. Use [print()] for a readable summary table.
+#' draws × observations. Attribute `measure_info` records what `model_compare()`
+#' needs to know about each measure; see section below. Use [print()]
+#' for a readable summary table.
+#'
+#' @template measure-info-attribute
#'
#' @details
#' **Input requirements by measure.** Supply only the inputs each measure
@@ -48,11 +52,21 @@
#' [overview of scores and metrics](https://mc-stan.org/loo/articles/articles-online-only/overview-measures.html)
#' article for definitions and orientation (higher vs lower is better).
#'
-#' **Custom measures.** A function passed to `measures` must have attribute
-#' `measure_name` and return `estimate`, `se`, and `pointwise`. Only arguments
+#' **Custom measures.** Build a custom measure with [custom_measure()]. The
+#' function must return `estimate`, `se`, and `pointwise`. Only arguments
#' declared in the function signature among `y`, `ypred`, `mupred`, `ylp`, and
#' `log_weights` are supplied automatically.
#'
+#' Custom measures are assumed to be on a utility scale (higher is better) in
+#' [model_compare()]. Declare a custom loss with `loss = TRUE` in
+#' [custom_measure()] so that [model_compare()] converts and ranks it in the
+#' right direction.
+#'
+#' Declare how the standard error of a difference between two models is
+#' computed with `se_diff_fun` in [custom_measure()]. It accepts a function,
+#' `"sum"`, or `"mean"`. For a measure that declares nothing,
+#' [model_compare()] reports an `NA` standard error.
+#'
#' @examples
#' \donttest{
#' if (requireNamespace("brms", quietly = TRUE)) {
@@ -80,7 +94,8 @@
#' pointwise = pw
#' )
#' }
-#' attr(my_abs_err, "measure_name") <- "my_abs_err"
+#' # the estimate is the mean of the pointwise values, so declare "mean"
+#' my_abs_err <- custom_measure(my_abs_err, name = "my_abs_err", se_diff_fun = "mean")
#' # insample_pred_measure(y = y, mupred = mupred, ylp = ylp, measures = my_abs_err)
#' }
#'
@@ -155,8 +170,10 @@ insample_pred_measure <- function(
#'
#' Measure names carry a `_loo` suffix (e.g. `elpd_loo`, `crps_loo`).
#'
+#' @template measure-info-attribute
+#'
#' @details
-#' **Three equivalent input patterns:**
+#' **Three input patterns:**
#'
#' \describe{
#' \item{Precomputed `loo` object}{`loo_pred_measure(loo = loo_fit, ...)`.
@@ -166,6 +183,9 @@ insample_pred_measure <- function(
#' \item{`ylp` only}{PSIS weights are computed internally from `ylp`.}
#' }
#'
+#' If you corrected the `loo` object after PSIS, pass it as `loo`.
+#' For example, `loo_moment_match()` or `brms::reloo()`.
+#'
#' For distributional and point-prediction measures (`crps`, `r2`, etc.),
#' supply `y`, `ypred`, and/or `mupred` as for [insample_pred_measure()]. When
#' adding measures incrementally, call [pred_measure()] with `predperf` set to
@@ -246,6 +266,8 @@ loo_pred_measure <- function(
#' list contains `estimates` and `pointwise`; measure names carry a `_kfold`
#' suffix (e.g. `elpd_kfold`, `crps_kfold`).
#'
+#' @template measure-info-attribute
+#'
#' @details
#' For distributional measures on held-out folds, obtain posterior predictions
#' with `brms::kfold_predict()` and pass the resulting `yrep` matrices as
@@ -328,6 +350,8 @@ kfold_pred_measure <- function(
#' `elpd_test`, `crps_test`). Attribute `dims` reflects the test-set size
#' (from `ylp_test`), not the training data.
#'
+#' @template measure-info-attribute
+#'
#' @details
#' `elpd_test` is computed from `ylp_test` on the holdout
#' observations only.
@@ -486,3 +510,47 @@ pred_measure <- function(
dim.pred_measure <- function(x) {
attr(x, "dims")
}
+
+
+#' Define a custom predictive measure
+#'
+#' Attaches the name, the orientation, and the standard error of the
+#' difference to a measure function. Pass the result to the `measure`
+#' argument of the `*_pred_measure()` functions.
+#'
+#' @param fun A function that returns `estimate`, `se`, and `pointwise`. Only
+#' the arguments `y`, `ypred`, `mupred`, `ylp`, and `log_weights` that are
+#' in its signature are supplied.
+#' @param name A character string. The measure is reported under this name.
+#' @param se_diff_fun How [model_compare()] computes the standard error of a
+#' difference: a function `(ref, cmp)`, `"sum"`, `"mean"`, or `NULL`. With
+#' `NULL` (the default), the standard error of the difference is `NA`.
+#' @param loss `TRUE` if lower values are better. The default `FALSE` treats
+#' the measure as a utility.
+#'
+#' @return `fun` with the attributes `measure_name`, `measure_loss`, and
+#' `measure_se_diff`.
+#'
+#' @examples
+#' my_abs_err <- custom_measure(
+#' function(y, mupred) {
+#' pw <- abs(y - colMeans(mupred))
+#' list(estimate = mean(pw), se = sd(pw) / sqrt(length(pw)), pointwise = pw)
+#' },
+#' name = "my_abs_err", se_diff_fun = "mean", loss = TRUE
+#' )
+#'
+#' @seealso [pred_measure()], [model_compare()]
+#' @export
+custom_measure <- function(
+ fun, name, se_diff_fun = NULL, loss = FALSE
+) {
+ if (!is.function(fun)) {
+ stop("'fun' must be a function.", call. = FALSE)
+ }
+ attr(fun, "measure_name") <- name
+ attr(fun, "measure_loss") <- loss
+ attr(fun, "measure_se_diff") <- se_diff_fun
+ .measure_entry_custom(fun)
+ fun
+}
\ No newline at end of file
diff --git a/R/print.R b/R/print.R
index 24d52446..f8089a3a 100644
--- a/R/print.R
+++ b/R/print.R
@@ -237,10 +237,89 @@ print_mcse_summary <- function(x, digits) {
}
# print and warning helpers
-.fr <- function(x, digits) format(round(x, digits), nsmall = digits)
+.fr <- function(x, digits) {
+ format(round(x, digits), nsmall = digits, scientific = FALSE)
+}
.warn <- function(..., call. = FALSE) warning(..., call. = call.)
.k_help <- function() "See help('pareto-k-diagnostic') for details.\n"
+#' Decimal places for one measure
+#'
+#' A measure on a fixed scale carries `digits` in `.measure_spec`. A measure on
+#' the scale of the data carries none, and takes its places from the standard
+#' error. A custom measure is in the second group.
+#' @noRd
+#' @param measure Bare measure name, without the source suffix.
+#' @param se Standard errors of the column to print. Used only when the measure
+#' sets no `digits`.
+#' @return A single integer.
+.measure_digits <- function(measure, se = NULL) {
+ d <- .measure_spec[[measure]]$digits
+ if (!is.null(d)) {
+ return(d)
+ }
+ .se_digits(se)
+}
+
+#' Decimal places that show two significant digits of the standard error
+#'
+#' @noRd
+#' @param se Numeric vector. `NA`, zero and infinite values are dropped.
+#' @return A single integer between `min_digits` and `max_digits`. Returns 2
+#' when no usable standard error is left.
+.se_digits <- function(se, sig = 2L, min_digits = 1L, max_digits = 4L) {
+ se <- se[is.finite(se) & se > 0]
+ if (!length(se)) {
+ return(2L)
+ }
+ d <- sig - 1L - floor(log10(min(se)))
+ max(min_digits, min(max_digits, d))
+}
+
+#' Resolve the `digits` argument of a print method for one measure
+#'
+#' `NULL` uses the per-measure default. A single number sets one format for
+#' every column, as before.
+#' @noRd
+.resolve_digits <- function(digits, measure, se = NULL) {
+ if (is.null(digits)) {
+ return(.measure_digits(measure, se))
+ }
+ if (is.null(names(digits))) {
+ return(digits[[1L]])
+ }
+ if (measure %in% names(digits)) {
+ return(digits[[measure]])
+ }
+ .measure_digits(measure, se)
+}
+
+#' Format an `estimates` matrix row by row
+#'
+#' @noRd
+#' @param est Matrix with columns `Estimate` and `SE`, one row per measure.
+#' @param digits `NULL`, a single number, or a named vector. See
+#' `.resolve_digits()`.
+#' @param suffix Source suffix to strip from the row names, such as `"_loo"`.
+#' @return A character data frame, ready to print.
+.format_estimates <- function(est, digits, suffix = "") {
+ est <- as.matrix(est)
+ measures <- rownames(est)
+ if (nzchar(suffix)) {
+ measures <- sub(paste0(suffix, "$"), "", measures)
+ }
+ measures[measures == "p"] <- "elpd"
+
+ out <- est
+ storage.mode(out) <- "character"
+ has_se <- "SE" %in% colnames(est)
+ for (i in seq_len(nrow(est))) {
+ se <- if (has_se) est[i, "SE"] else NULL
+ out[i, ] <- .fr(est[i, ], .resolve_digits(digits, measures[i], se))
+ }
+ as.data.frame(out, stringsAsFactors = FALSE)
+}
+
# compatibility with old loo objects
convert_old_object <- function(x, digits = 1, ...) {
z <- x[-grep("pointwise|pareto_k|n_eff", names(x))]
@@ -255,7 +334,7 @@ convert_old_object <- function(x, digits = 1, ...) {
#' @export
-print.pred_measure <- function(x, digits = 1, ...) {
+print.pred_measure <- function(x, digits = NULL, ...) {
dims <- attr(x, "dims")
if (is.null(dims) && !is.null(x$log_weights)) {
dims <- dim(x$log_weights)
@@ -274,14 +353,14 @@ print.pred_measure <- function(x, digits = 1, ...) {
}
cat(sprintf("Data source: %s\n\n", source))
print(
- format(round(as.data.frame(x$estimates), digits), nsmall = digits),
+ .format_estimates(x$estimates, digits, suffix = .compare_suffix(list(x))),
quote = FALSE
)
invisible(x)
}
#' @export
-print.loo_pred_measure <- function(x, digits = 1, plot_k = FALSE, ...) {
+print.loo_pred_measure <- function(x, digits = NULL, plot_k = FALSE, ...) {
print.pred_measure(x, digits = digits, ...)
cat("------\n")
pareto_k <- x$diagnostics$pareto_k
@@ -290,7 +369,7 @@ print.loo_pred_measure <- function(x, digits = 1, plot_k = FALSE, ...) {
return(invisible(x))
}
- print(pareto_k_table(x), digits = digits)
+ print(pareto_k_table(x), digits = 1)
if (plot_k) {
graphics::plot(
@@ -317,7 +396,7 @@ print.loo_pred_measure <- function(x, digits = 1, plot_k = FALSE, ...) {
}
#' @export
-print.measure <- function(x, digits = 2, ...) {
+print.measure <- function(x, digits = NULL, ...) {
dims <- attr(x, "dims")
name <- attr(x, "measure")
@@ -328,7 +407,7 @@ print.measure <- function(x, digits = 2, ...) {
cat("\nComputed from", dims[1], "draws by", dims[2], "observations.\n\n")
}
- print(.fr(x$estimates, digits), quote = FALSE)
+ print(.format_estimates(x$estimates, digits), quote = FALSE)
invisible(x)
}
diff --git a/R/psis.R b/R/psis.R
index 303da755..2ae48526 100644
--- a/R/psis.R
+++ b/R/psis.R
@@ -315,7 +315,7 @@ enough_tail_samples <- function(tail_len, min_len = 5) {
#'
throw_pareto_warnings <- function(k, k_threshold) {
if (isTRUE(any(k > k_threshold))) {
- .warn("Some Pareto k diagnostic values are too high. ", .k_help())
+ .warn("Some Pareto k diagnostic values are too high.\n", .k_help())
}
}
@@ -384,27 +384,3 @@ prepare_psis_r_eff <- function(r_eff, len) {
}
r_eff
}
-
-#' Check if `psis()` was called from one of the loo methods
-#'
-#' @noRd
-#' @return `TRUE` if the `loo()` array, matrix, or function method is found in
-#' the active call list, `FALSE` otherwise.
-#'
-called_from_loo <- function() {
- calls <- sys.calls()
- txt <- unlist(lapply(calls, deparse))
- patts <- "loo.array\\(|loo.matrix\\(|loo.function\\("
- check <- sapply(txt, function(x) grepl(patts, x))
- isTRUE(any(check))
-}
-
-#' Warning message about missing `r_eff` argument
-#' @noRd
-throw_psis_r_eff_warning <- function() {
- warning(
- "Relative effective sample sizes ('r_eff' argument) not specified. ",
- "PSIS ESS (n_eff) will not be adjusted based on MCMC ESS (n_eff).",
- call. = FALSE
- )
-}
diff --git a/R/waic.R b/R/waic.R
index ab15b940..35f5967c 100644
--- a/R/waic.R
+++ b/R/waic.R
@@ -30,7 +30,8 @@
#' * The __loo__ package [vignettes](https://mc-stan.org/loo/articles/) and
#' Vehtari, Gelman, and Gabry (2017) and Vehtari, Simpson, Gelman, Yao,
#' and Gabry (2024) for more details on why we prefer `loo()` to `waic()`.
-#' * [loo_compare()] for comparing models on approximate LOO-CV or WAIC.
+#' * [loo_compare()] and [model_compare()] for comparing models on approximate
+#' LOO-CV or WAIC.
#'
#' @references
#' Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation and
diff --git a/_pkgdown.yml b/_pkgdown.yml
index 90965a73..f1849c70 100644
--- a/_pkgdown.yml
+++ b/_pkgdown.yml
@@ -38,6 +38,7 @@ articles:
contents:
- articles-online-only/pred-measure-workflow
- articles-online-only/overview-measures
+ - articles-online-only/model-comparison
- title: Frequently asked questions
contents:
- faq
@@ -75,6 +76,7 @@ reference:
desc: |
Functions for comparing models and computing model weights via stacking of predictive distributions or pseudo-BMA weighting.
contents:
+ - model_compare
- loo_compare
- loo_model_weights
- stacking_weights
@@ -96,6 +98,7 @@ reference:
- kfold_pred_measure
- test_pred_measure
- pred_measure
+ - custom_measure
- supported_measures_list
- starts_with("measure_")
- ptw_log_pred_density
diff --git a/man-roxygen/measure-info-attribute.R b/man-roxygen/measure-info-attribute.R
new file mode 100644
index 00000000..6d428ef9
--- /dev/null
+++ b/man-roxygen/measure-info-attribute.R
@@ -0,0 +1,14 @@
+#' @section `measure_info` attribute:
+#' All `*_pred_measure()` and [pred_measure()] results include attribute
+#' `measure_info`: a named list, keyed by bare measure name, recording what
+#' [model_compare()] needs to know about each measure — `loss` (whether lower
+#' values are better), `diff_method` (how the standard error of a difference is
+#' obtained), and, where applicable, `se_diff_fun` and `extra`. When measures
+#' are added incrementally with [pred_measure()], the attribute is extended for
+#' the newly computed measures.
+#'
+#' Built-in measures take `loss`, `diff_method`, and `se_diff_fun` from the
+#' package measure registry. Custom measures always get `diff_method = "custom"`
+#' and take `loss` and `se_diff_fun` from [custom_measure()]. Without
+#' `loss = TRUE` a custom measure is treated as a utility, so an undeclared
+#' loss is compared and ranked in the wrong direction. See [loo-glossary].
diff --git a/man/compare.Rd b/man/compare.Rd
index 3d95059f..21b317d5 100644
--- a/man/compare.Rd
+++ b/man/compare.Rd
@@ -21,7 +21,7 @@ standard error of the difference are returned. If more than two objects are
provided then a matrix of summary information is returned (see \strong{Details}).
}
\description{
-\strong{This function is deprecated}. Please use the new \code{\link[=loo_compare]{loo_compare()}} function
+\strong{This function is deprecated}. Please use the new \code{\link[=model_compare]{model_compare()}} function
instead. See \code{vignette("migration-guide", package = "loo")} for details.
\code{compare()} and \code{R/compare.R} are scheduled for removal in a future release.
}
diff --git a/man/custom_measure.Rd b/man/custom_measure.Rd
new file mode 100644
index 00000000..f664c42b
--- /dev/null
+++ b/man/custom_measure.Rd
@@ -0,0 +1,44 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/pred_measure.R
+\name{custom_measure}
+\alias{custom_measure}
+\title{Define a custom predictive measure}
+\usage{
+custom_measure(fun, name, se_diff_fun = NULL, loss = FALSE)
+}
+\arguments{
+\item{fun}{A function that returns \code{estimate}, \code{se}, and \code{pointwise}. Only
+the arguments \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and \code{log_weights} that are
+in its signature are supplied.}
+
+\item{name}{A character string. The measure is reported under this name.}
+
+\item{se_diff_fun}{How \code{\link[=model_compare]{model_compare()}} computes the standard error of a
+difference: a function \verb{(ref, cmp)}, \code{"sum"}, \code{"mean"}, or \code{NULL}. With
+\code{NULL} (the default), the standard error of the difference is \code{NA}.}
+
+\item{loss}{\code{TRUE} if lower values are better. The default \code{FALSE} treats
+the measure as a utility.}
+}
+\value{
+\code{fun} with the attributes \code{measure_name}, \code{measure_loss}, and
+\code{measure_se_diff}.
+}
+\description{
+Attaches the name, the orientation, and the standard error of the
+difference to a measure function. Pass the result to the \code{measure}
+argument of the \verb{*_pred_measure()} functions.
+}
+\examples{
+my_abs_err <- custom_measure(
+ function(y, mupred) {
+ pw <- abs(y - colMeans(mupred))
+ list(estimate = mean(pw), se = sd(pw) / sqrt(length(pw)), pointwise = pw)
+ },
+ name = "my_abs_err", se_diff_fun = "mean", loss = TRUE
+)
+
+}
+\seealso{
+\code{\link[=pred_measure]{pred_measure()}}, \code{\link[=model_compare]{model_compare()}}
+}
diff --git a/man/find_model_names.Rd b/man/find_model_names.Rd
index 70a79d58..7c6a5eaf 100644
--- a/man/find_model_names.Rd
+++ b/man/find_model_names.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/loo_compare.R
+% Please edit documentation in R/model_compare.R
\name{find_model_names}
\alias{find_model_names}
\title{Find the model names associated with \code{"loo"} objects}
diff --git a/man/insample_pred_measure.Rd b/man/insample_pred_measure.Rd
index 9479a6e5..cb7609e9 100644
--- a/man/insample_pred_measure.Rd
+++ b/man/insample_pred_measure.Rd
@@ -36,13 +36,36 @@ summaries (\code{elpd}, \code{mlpd}, \code{ic}).}
\itemize{
\item A \strong{character vector} of built-in names; see
\link{supported_measures_list}.
-\item A \strong{function} with attribute \code{"measure_name"} for one custom measure.
+\item A \strong{function} built with \code{\link[=custom_measure]{custom_measure()}} for one custom
+measure.
\item A \strong{list} mixing character scalars (built-in names) and named
functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}.
}
Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and
\code{log_weights} that appear in their formals, plus arguments from \code{control}.
-They must return a list with \code{estimates} and \code{pointwise}.}
+They must return a list with \code{estimates} and \code{pointwise}.
+
+A custom measure declares whether it is a loss (lower is better) or a
+utility (higher is better) with \code{loss} in \code{\link[=custom_measure]{custom_measure()}}. Without it a
+custom measure is taken to be a utility. \code{\link[=model_compare]{model_compare()}} uses the declaration to
+put all measures on a common utility scale and to rank models, so an
+undeclared loss is compared and ranked in the wrong direction.
+
+A custom measure can declare how the standard error of a difference
+between two models is computed, with \code{se_diff_fun} in \code{\link[=custom_measure]{custom_measure()}}.
+It accepts a function
+\code{function(ref, cmp) ...} or the shorthands \code{"sum"} and \code{"mean"} for the
+paired pointwise formulas. Without a declaration, \code{\link[=model_compare]{model_compare()}}
+reports the difference with an \code{NA} standard error. A function receives one list per model with elements
+\code{estimate}, \code{se}, \code{pointwise}, and \code{extra}, always on the measure's natural
+scale, and must return the standard error of the difference as a numeric
+scalar.
+
+\code{extra} is for anything the standard error needs that the pointwise values
+do not carry. Return it as an additional list element \code{extra} from the
+measure function and it is stored alongside the estimates and passed on to
+its \code{measure_se_diff} function; the built-in \code{r2} uses it for the baseline
+\code{(y_i - mean(y))^2}, which cannot be recovered once \code{y} is out of scope.}
\item{group_ids}{Optional vector of group identifiers for grouped summaries
(reserved; not yet implemented).}
@@ -67,7 +90,9 @@ per measure).}
}
The attribute \code{source} is \code{"insample"}. Attribute \code{dims} gives posterior
-draws × observations. Use \code{\link[=print]{print()}} for a readable summary table.
+draws × observations. Attribute \code{measure_info} records what \code{model_compare()}
+needs to know about each measure; see section below. Use \code{\link[=print]{print()}}
+for a readable summary table.
}
\description{
Compute predictive performance measures on the same data used to fit the
@@ -101,11 +126,38 @@ see \link{supported_measures_list} and the
\href{https://mc-stan.org/loo/articles/articles-online-only/overview-measures.html}{overview of scores and metrics}
article for definitions and orientation (higher vs lower is better).
-\strong{Custom measures.} A function passed to \code{measures} must have attribute
-\code{measure_name} and return \code{estimate}, \code{se}, and \code{pointwise}. Only arguments
+\strong{Custom measures.} Build a custom measure with \code{\link[=custom_measure]{custom_measure()}}. The
+function must return \code{estimate}, \code{se}, and \code{pointwise}. Only arguments
declared in the function signature among \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and
\code{log_weights} are supplied automatically.
+
+Custom measures are assumed to be on a utility scale (higher is better) in
+\code{\link[=model_compare]{model_compare()}}. Declare a custom loss with \code{loss = TRUE} in
+\code{\link[=custom_measure]{custom_measure()}} so that \code{\link[=model_compare]{model_compare()}} converts and ranks it in the
+right direction.
+
+Declare how the standard error of a difference between two models is
+computed with \code{se_diff_fun} in \code{\link[=custom_measure]{custom_measure()}}. It accepts a function,
+\code{"sum"}, or \code{"mean"}. For a measure that declares nothing,
+\code{\link[=model_compare]{model_compare()}} reports an \code{NA} standard error.
}
+\section{\code{measure_info} attribute}{
+
+All \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results include attribute
+\code{measure_info}: a named list, keyed by bare measure name, recording what
+\code{\link[=model_compare]{model_compare()}} needs to know about each measure — \code{loss} (whether lower
+values are better), \code{diff_method} (how the standard error of a difference is
+obtained), and, where applicable, \code{se_diff_fun} and \code{extra}. When measures
+are added incrementally with \code{\link[=pred_measure]{pred_measure()}}, the attribute is extended for
+the newly computed measures.
+
+Built-in measures take \code{loss}, \code{diff_method}, and \code{se_diff_fun} from the
+package measure registry. Custom measures always get \code{diff_method = "custom"}
+and take \code{loss} and \code{se_diff_fun} from \code{\link[=custom_measure]{custom_measure()}}. Without
+\code{loss = TRUE} a custom measure is treated as a utility, so an undeclared
+loss is compared and ranked in the wrong direction. See \link{loo-glossary}.
+}
+
\examples{
\donttest{
if (requireNamespace("brms", quietly = TRUE)) {
@@ -133,7 +185,8 @@ my_abs_err <- function(y, mupred, log_weights = NULL) {
pointwise = pw
)
}
-attr(my_abs_err, "measure_name") <- "my_abs_err"
+# the estimate is the mean of the pointwise values, so declare "mean"
+my_abs_err <- custom_measure(my_abs_err, name = "my_abs_err", se_diff_fun = "mean")
# insample_pred_measure(y = y, mupred = mupred, ylp = ylp, measures = my_abs_err)
}
diff --git a/man/kfold-generic.Rd b/man/kfold-generic.Rd
index bcf3c84b..1901a199 100644
--- a/man/kfold-generic.Rd
+++ b/man/kfold-generic.Rd
@@ -29,7 +29,7 @@ the pointwise contributions for each data point.
It is important for the object to have at least these classes and
components so that it is compatible with other functions like
-\code{\link[=loo_compare]{loo_compare()}} and \code{print()} methods.
+\code{\link[=model_compare]{model_compare()}} and \code{print()} methods.
}
\description{
For developers of Bayesian modeling packages, \strong{loo} includes
@@ -39,5 +39,5 @@ CV without name conflicts between packages. See, for example, the
The \strong{Value} section below describes the objects that \code{kfold()}
methods should return in order to be compatible with
-\code{\link[=loo_compare]{loo_compare()}} and the \strong{loo} package print methods.
+\code{\link[=model_compare]{model_compare()}} and the \strong{loo} package print methods.
}
diff --git a/man/kfold_pred_measure.Rd b/man/kfold_pred_measure.Rd
index 16cc56eb..568f1deb 100644
--- a/man/kfold_pred_measure.Rd
+++ b/man/kfold_pred_measure.Rd
@@ -36,13 +36,36 @@ summaries (\code{elpd}, \code{mlpd}, \code{ic}).}
\itemize{
\item A \strong{character vector} of built-in names; see
\link{supported_measures_list}.
-\item A \strong{function} with attribute \code{"measure_name"} for one custom measure.
+\item A \strong{function} built with \code{\link[=custom_measure]{custom_measure()}} for one custom
+measure.
\item A \strong{list} mixing character scalars (built-in names) and named
functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}.
}
Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and
\code{log_weights} that appear in their formals, plus arguments from \code{control}.
-They must return a list with \code{estimates} and \code{pointwise}.}
+They must return a list with \code{estimates} and \code{pointwise}.
+
+A custom measure declares whether it is a loss (lower is better) or a
+utility (higher is better) with \code{loss} in \code{\link[=custom_measure]{custom_measure()}}. Without it a
+custom measure is taken to be a utility. \code{\link[=model_compare]{model_compare()}} uses the declaration to
+put all measures on a common utility scale and to rank models, so an
+undeclared loss is compared and ranked in the wrong direction.
+
+A custom measure can declare how the standard error of a difference
+between two models is computed, with \code{se_diff_fun} in \code{\link[=custom_measure]{custom_measure()}}.
+It accepts a function
+\code{function(ref, cmp) ...} or the shorthands \code{"sum"} and \code{"mean"} for the
+paired pointwise formulas. Without a declaration, \code{\link[=model_compare]{model_compare()}}
+reports the difference with an \code{NA} standard error. A function receives one list per model with elements
+\code{estimate}, \code{se}, \code{pointwise}, and \code{extra}, always on the measure's natural
+scale, and must return the standard error of the difference as a numeric
+scalar.
+
+\code{extra} is for anything the standard error needs that the pointwise values
+do not carry. Return it as an additional list element \code{extra} from the
+measure function and it is stored alongside the estimates and passed on to
+its \code{measure_se_diff} function; the built-in \code{r2} uses it for the baseline
+\code{(y_i - mean(y))^2}, which cannot be recovered once \code{y} is out of scope.}
\item{kfold}{A \code{kfold} object from \code{\link[brms:kfold]{brms::kfold()}}. Supplies ELPD summaries
and fold structure for \code{\link[=kfold_pred_measure]{kfold_pred_measure()}}; pass \code{y}, \code{ypred}, and/or
@@ -79,6 +102,23 @@ with \code{brms::kfold_predict()} and pass the resulting \code{yrep} matrices as
\code{ypred} and/or \code{mupred}. See the sleep-study workflow in
\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{pred-measure workflow article}.
}
+\section{\code{measure_info} attribute}{
+
+All \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results include attribute
+\code{measure_info}: a named list, keyed by bare measure name, recording what
+\code{\link[=model_compare]{model_compare()}} needs to know about each measure — \code{loss} (whether lower
+values are better), \code{diff_method} (how the standard error of a difference is
+obtained), and, where applicable, \code{se_diff_fun} and \code{extra}. When measures
+are added incrementally with \code{\link[=pred_measure]{pred_measure()}}, the attribute is extended for
+the newly computed measures.
+
+Built-in measures take \code{loss}, \code{diff_method}, and \code{se_diff_fun} from the
+package measure registry. Custom measures always get \code{diff_method = "custom"}
+and take \code{loss} and \code{se_diff_fun} from \code{\link[=custom_measure]{custom_measure()}}. Without
+\code{loss = TRUE} a custom measure is treated as a utility, so an undeclared
+loss is compared and ranked in the wrong direction. See \link{loo-glossary}.
+}
+
\examples{
\donttest{
if (requireNamespace("brms", quietly = TRUE)) {
diff --git a/man/loo-glossary.Rd b/man/loo-glossary.Rd
index 58529429..17d9ca2c 100644
--- a/man/loo-glossary.Rd
+++ b/man/loo-glossary.Rd
@@ -39,7 +39,7 @@ the actual SE can even be twice as large. Even for moderate N, when the SE
estimate is an accurate estimate for the scale, it ignores the skewness. When
making model comparisons, the SE of the component-wise (pairwise) differences
should be used instead (see the \code{se_diff} section below and Eq 24 in
-VGG2017). Sivula et al. (2022) discuss the conditions when the normal
+VGG2017). Sivula et al. (2025) discuss the conditions when the normal
approximation used for SE and \code{se_diff} is good.
}
@@ -145,11 +145,42 @@ detect the problem.
}
}
+\section{Model comparison with \code{model_compare()} and \code{loo_compare()}}{
+
+
+Two functions perform model comparison, and both are available to users:
+\itemize{
+\item \code{\link[=model_compare]{model_compare()}} is the current interface. It compares \code{"loo"}, \code{"waic"},
+and \code{"kfold"} objects on ELPD, and \code{\link{pred_measure}} results
+on every predictive measure the models share.
+\item \code{\link[=loo_compare]{loo_compare()}} is \strong{deprecated} in favor of \code{model_compare()}, but it
+still works and is still an exported generic, so \code{loo_compare} methods
+registered by other packages keep dispatching. It keeps its previous
+behavior: it accepts only \code{"loo"}, \code{"waic"}, and \code{"kfold"} objects and
+compares them on ELPD. Passing \code{\link{pred_measure}} results
+produces an error. The deprecation warning is issued once per session.
+}
+
+\code{loo_compare()} and \code{model_compare()} return the same object: a data frame
+including the \code{p_worse}, \code{diag_diff}, and \code{diag_elpd} columns. The terms
+\code{elpd_diff}, \code{se_diff}, \code{p_worse}, \code{diag_diff}, and \code{diag_elpd} are defined
+below. The remaining sections, on comparisons of several predictive
+measures at once, apply to \code{model_compare()} only, since \code{loo_compare()}
+cannot produce such a comparison. See
+\code{vignette("migration-guide", package = "loo")} for the migration path.
+
+Below, "the comparison output" refers to the object returned by either
+function, and "the reference model" to the model each difference is computed
+against, which is the best model on the measure.
+}
+
\section{elpd_diff}{
\code{elpd_diff} is the difference in \code{elpd_loo} for two models. If more
than two models are compared, the difference is computed relative to the
-model with highest \code{elpd_loo}.
+reference model, which is the model with the highest \code{elpd_loo} in
+\code{loo_compare()} and in \code{model_compare()} the model with the best
+performance on each measure.
}
\section{se_diff}{
@@ -171,7 +202,7 @@ approximation to the uncertainty in \code{elpd_diff}. It is computed as
\if{html}{\out{
}}
-The best-ranked model (the first row in the \code{loo_compare()} output, where
+The reference model (the row of the comparison output where
\code{elpd_diff = 0}) always receives \code{NA}, since the comparison is defined
relative to that model.
@@ -186,20 +217,19 @@ underestimated, \code{p_worse} will be estimated too close to 1, making a model
appear more clearly worse than the data actually support. Conversely, when
\code{elpd_diff} is biased due to an unreliable LOO approximation, \code{p_worse} can
point in the wrong direction entirely. When any of these conditions are
-present, \code{diag_diff} or \code{diag_elpd} will be flagged in the \code{loo_compare()}
-output.
-For further guidance, see the sections below and the case study on
+present, \code{diag_diff} or \code{diag_elpd} will be flagged in the comparison
+output. For further guidance, see the sections below and the case study on
\href{https://users.aalto.fi/~ave/casestudies/LOO_uncertainty/loo_uncertainty.html}{Uncertainty in Bayesian LOO-CV Model Comparison}.
}
\section{\code{diag_diff} (pairwise comparison diagnostics)}{
-\code{diag_diff} is a diagnostic column in the \code{loo_compare()} output for each
-model comparison against the current reference model. It flags conditions
-under which the normal approximation behind \code{se_diff} and \code{p_worse} is likely
-to be poorly calibrated. The column contains a short label when a condition
-is detected, and is empty otherwise.
+\code{diag_diff} is a diagnostic column in the \code{model_compare()} and
+\code{loo_compare()} output for each model comparison against the current
+reference model. It flags conditions under which the normal approximation
+behind \code{se_diff} and \code{p_worse} is likely to be poorly calibrated. The column
+contains a short label when a condition is detected, and is empty otherwise.
The column \code{diag_diff} currently flags two problems:
\subsection{\code{N < 100}}{
@@ -222,7 +252,7 @@ supports treating the models as predictively similar.
The conditions flagged by \code{diag_diff} are not independent: they tend to
co-occur, and when they do, some flags carry more information than others.
-\code{loo_compare()} therefore follows a priority hierarchy and shows only the
+Both functions therefore follow a priority hierarchy and show only the
most critical flag in the table output.
The hierarchy is as follows:
@@ -247,12 +277,12 @@ For further guidance, see the case study on
\section{\code{diag_elpd}}{
-\code{diag_elpd} is a diagnostic column in the \code{loo_compare()} output that flags
-when the PSIS-LOO approximation for an individual model is unreliable. Unlike
-\code{diag_diff}, which concerns the \emph{comparison} between models, \code{diag_elpd}
-concerns the quality of the \code{elpd_loo} estimate for each model individually.
-It contains a short text label when a problem is detected, and is empty
-otherwise.
+\code{diag_elpd} is a diagnostic column in the \code{model_compare()} and
+\code{loo_compare()} output that flags when the PSIS-LOO approximation for an
+individual model is unreliable. Unlike \code{diag_diff}, which concerns the
+\emph{comparison} between models, \code{diag_elpd} concerns the quality of the
+\code{elpd_loo} estimate for each model individually. It contains a short text
+label when a problem is detected, and is empty otherwise.
\subsection{\verb{K k_psis > t} (K observations with Pareto-k values > t)}{
This label indicates that K observations for this model have Pareto-k values
@@ -265,11 +295,127 @@ either model's estimate propagates directly into \code{elpd_diff} and \code{p_wo
This is qualitatively different from the calibration issues flagged by
\code{diag_diff}: here the estimate itself may be wrong, not just uncertain.
+The flag is not specific to ELPD: \code{mae_loo}, \code{mse_loo}, \code{r2_loo} and the
+rest are biased by unreliable importance sampling for the same reason. It is
+a property of one model's approximation, and does not depend on which model
+is used as the comparison reference. In an ELPD-only comparison (i.e., all
+\code{loo_compare()} output, and \code{model_compare()} on \code{"loo"}, \code{"waic"}, or
+\code{"kfold"} objects) \code{print()} shows it as a column of the single difference
+table. In a multi-measure \code{model_compare()} comparison it is instead reported
+once per model above the per-measure difference tables, rather than inside
+any one of them.
+
See for further information on Pareto-k values the "Pareto k estimates"
section.
}
}
+\section{Multi-measure model comparisons}{
+
+
+The remaining sections describe comparisons that only \code{\link[=model_compare]{model_compare()}} can
+produce; the deprecated \code{loo_compare()} rejects
+\code{\link{pred_measure}} inputs.
+
+When comparing \code{\link[=loo_pred_measure]{loo_pred_measure()}} objects with
+\code{model_compare()}, paired differences are computed for every predictive
+measure common to all models. Rows are ordered by \code{"elpd"} when all models
+share it, and otherwise by the first shared measure in alphabetical order. Each measure is compared against the
+model that is best on that measure, so different difference columns may use
+different reference models.
+\subsection{\verb{\{measure\}_diff} and \verb{\{measure\}_se_diff}}{
+
+For each non-ELPD measure \code{m}, \code{model_compare()} adds columns \code{m_diff} and
+\code{m_se_diff}. In all cases \code{m_diff} is the difference between the two overall
+estimates on a utility scale (higher is better; loss measures such as MSE,
+Brier score, and SRPS have their sign flipped from the raw loss orientation).
+Measures already returned on a utility scale (e.g. ELPD, CRPS/RPS) are not
+sign-flipped. Negative \code{m_diff} values then indicate worse performance than
+the reference model, which has \code{m_diff = 0}.
+
+How \code{m_se_diff} is obtained depends on the measure:
+\itemize{
+\item When the overall estimate is a sum or mean of pointwise contributions, it
+is computed from paired pointwise differences using the same approach as
+\code{elpd_diff} and \code{se_diff} (Eq 24 in VGG2017 for sums; the mean analogue for
+means). This covers ELPD, \code{mlpd}, \code{ic}, \code{mae}, \code{mse}, \code{acc}, \code{brier}, and
+the ranked probability scores.
+\item When a built-in measure is a transformation of such quantities, it supplies
+its own delta-method standard error (\code{se_diff_fun}). For \code{rmse} this is the
+first-order bivariate Taylor approximation propagated from the MSE scale,
+which requires the covariance between the two models' pointwise squared
+errors and is therefore not a paired pointwise standard deviation. For
+\code{r2} it is the trivariate analogue, which additionally propagates the
+uncertainty in the baseline \code{MSE(y)} shared by both models.
+\item For custom measures it comes from the measure's own
+\code{attr(my_fun, "measure_se_diff")} declaration, set with
+\code{\link[=custom_measure]{custom_measure()}}. It is \code{NA} when the measure declares nothing.
+}
+
+The reference model has \code{m_se_diff = 0} whenever an \code{m_se_diff} is available.
+Which measures are losses is recorded in the \code{loss} element of the
+\code{measure_info} attribute on each \verb{*_pred_measure()} result. \code{print()} marks
+each flipped loss with "sign flipped" (see \code{\link[=model_compare]{model_compare()}}).
+
+ELPD-family measures use the column names \code{elpd_diff} and \code{se_diff} rather
+than a prefixed form. Only ELPD comparisons include \code{p_worse} and \code{diag_diff};
+these diagnostics do not apply to other predictive measures.
+}
+
+\subsection{\code{measure_info}}{
+
+Attribute on all \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results: a named
+list of per-measure information used by \code{\link[=model_compare]{model_compare()}}. Each entry
+is a list with:
+\itemize{
+\item \code{loss}: whether lower values of the measure are better. Measure values are
+always stored on the measure's own scale, so this describes both the
+measure and the values recorded for it
+\item \code{diff_method}: how the standard error of the difference is obtained:
+\code{"sum"} or \code{"mean"} (paired pointwise differences),
+\code{"measure_specific"} (the built-in measure's own \code{se_diff_fun}), or
+\code{"custom"}. Nothing is inferred from a measure's values. Under \code{"custom"}
+the standard error comes from the measure's \code{se_diff_fun} declaration:
+a function, the \code{"sum"}/\code{"mean"} pointwise formulas, or nothing for an
+\code{NA} standard error. A missing standard error is not an
+error state as the difference itself is still reported.
+\item \code{se_diff_fun}: for built-in measures with
+\code{diff_method = "measure_specific"}, the name of the built-in implementation
+used. For custom measures, whatever the measure declared in
+\code{attr(my_fun, "measure_se_diff")}; absent when it declared nothing.
+\item \code{extra}: optional list of auxiliary data the measure stored for the
+standard error of its difference, present only for measures that need it
+(\code{r2} stores the pointwise baseline \code{(y_i - mean(y))^2}, which \code{y} no
+longer supplies by the time \code{\link[=model_compare]{model_compare()}} runs; \code{bacc} stores the class
+index of each observation, which its pointwise values do not determine).
+Custom measures return it as an \code{extra} element, and it is passed on to
+their \code{se_diff_fun}. It is excluded from the consistency check below, since it
+varies with the data rather than with the measure itself.
+}
+
+Built-in measures take \code{loss}, \code{diff_method}, and \code{se_diff_fun} from the
+package measure registry. Custom measures always get \code{diff_method = "custom"}
+and take \code{loss} and \code{se_diff_fun} from the arguments of the same name in
+\code{\link[=custom_measure]{custom_measure()}}. With \code{loss = TRUE} lower values are better; without it
+they are treated as utilities (see \code{\link[=insample_pred_measure]{insample_pred_measure()}}).
+\code{\link[=model_compare]{model_compare()}} requires all models to provide matching \code{measure_info} for
+each shared measure; a mismatched \code{measure_loss} or \code{measure_se_diff}
+declaration, or missing \code{measure_info} on some models, produces an error.
+}
+
+\subsection{\code{compare_measures} and related attributes}{
+
+Attribute \code{compare_reference} is a named character vector recording the
+reference model used for each measure. Attribute \code{compare_measures} lists all
+measures that were compared, and \code{sign_converted_measures} lists loss
+measures whose sign was flipped onto the utility scale. The print method
+shows the ranking measure by default (the first compared measure); use
+\code{print(x, measures = "all")} or \code{print(x, measures = c("rmse", "r2"))} to
+display additional measure tables. Each printed table is sorted by its own
+measure, best model first, so the same model need not lead every table.
+}
+}
+
\references{
Vehtari, A., Gelman, A., and Gabry, J. (2017). Practical Bayesian model
evaluation using leave-one-out cross-validation and WAIC.
@@ -293,3 +439,6 @@ Gelman, A. (2019), Visualization in Bayesian workflow.
\href{https://arxiv.org/abs/1709.01449}{preprint arXiv:1709.01449},
\href{https://github.com/jgabry/bayes-vis-paper}{code on GitHub})
}
+\seealso{
+\code{\link[=model_compare]{model_compare()}}, \code{\link[=loo_compare]{loo_compare()}}
+}
diff --git a/man/loo.Rd b/man/loo.Rd
index e6b48075..2f972fbe 100644
--- a/man/loo.Rd
+++ b/man/loo.Rd
@@ -329,6 +329,6 @@ the \strong{loo} website for answers to frequently asked questions.
\item \code{\link[=psis]{psis()}} for the underlying Pareto Smoothed Importance Sampling (PSIS)
procedure used in the LOO-CV approximation.
\item \link{pareto-k-diagnostic} for convenience functions for looking at diagnostics.
-\item \code{\link[=loo_compare]{loo_compare()}} for model comparison.
+\item \code{\link[=model_compare]{model_compare()}} for model comparison.
}
}
diff --git a/man/loo_approximate_posterior.Rd b/man/loo_approximate_posterior.Rd
index a17d59a2..e4b66643 100644
--- a/man/loo_approximate_posterior.Rd
+++ b/man/loo_approximate_posterior.Rd
@@ -149,5 +149,5 @@ In \emph{Proceedings of the 23rd International Conference on Artificial
Intelligence and Statistics (AISTATS)}, PMLR 108:341-351.
}
\seealso{
-\code{\link[=loo]{loo()}}, \code{\link[=psis]{psis()}}, \code{\link[=loo_compare]{loo_compare()}}
+\code{\link[=loo]{loo()}}, \code{\link[=psis]{psis()}}, \code{\link[=model_compare]{model_compare()}}
}
diff --git a/man/loo_compare.Rd b/man/loo_compare.Rd
index 11dae77d..c9211fe7 100644
--- a/man/loo_compare.Rd
+++ b/man/loo_compare.Rd
@@ -1,164 +1,53 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/loo_compare.R,
-% R/loo_compare.psis_loo_ss_list.R
+% Please edit documentation in R/loo_compare.R
\name{loo_compare}
\alias{loo_compare}
\alias{loo_compare.default}
-\alias{print.compare.loo}
-\alias{print.compare.loo_ss}
-\title{Model comparison}
+\alias{loo_compare.psis_loo_ss_list}
+\title{Model comparison (deprecated)}
\usage{
loo_compare(x, ...)
\method{loo_compare}{default}(x, ...)
-\method{print}{compare.loo}(x, ..., digits = 1, p_worse = TRUE, simplify = TRUE)
-
-\method{print}{compare.loo_ss}(x, ..., digits = 1)
+\method{loo_compare}{psis_loo_ss_list}(x, ...)
}
\arguments{
\item{x}{An object of class \code{"loo"} or a list of such objects. If a list is
-used then the list names will be used as the model names in the output. See
-\strong{Examples}.}
+used then the list names will be used as the model names in the output.}
\item{...}{Additional objects of class \code{"loo"}, if not passed in as a single
list.}
-
-\item{digits}{For the print method only, the number of digits to use when
-printing.}
-
-\item{p_worse}{For the print method only, should we include the normal
-approximation based probability of each model having worse performance than
-the best model? The default is \code{TRUE}.}
-
-\item{simplify}{For the print method only, should the output be simplified to
-only include the model names, ELPD differences, and (when \code{p_worse = TRUE})
-diagnostic columns? The default is \code{TRUE}. Set to \code{FALSE} to also print the
-available estimate columns (pointwise ELPD, LOOIC/WAIC, and their standard
-errors).}
}
\value{
-A data frame with class \code{"compare.loo"} that has its own
-print method. See the \strong{Details} and \strong{Examples} sections.
+See \code{\link[=model_compare]{model_compare()}}. For the inputs \code{loo_compare()} still accepts,
+the result is identical to what \code{\link[=model_compare]{model_compare()}} returns.
}
\description{
-Compare fitted models based on \link[=loo-glossary]{ELPD}.
-}
-\details{
-When comparing two fitted models, we can estimate the difference in their
-expected predictive accuracy by the difference in
-\code{\link[=loo-glossary]{elpd_loo}} or \code{elpd_waic} (or multiplied by \eqn{-2}, if
-desired, to be on the deviance scale).
-\subsection{\code{elpd_diff} and \code{se_diff}}{
-
-When using \code{loo_compare()}, the returned data frame will have one row per
-model and several columns of estimates. The values of
-\code{\link[=loo-glossary]{elpd_diff}} and \code{\link[=loo-glossary]{se_diff}} are computed by
-making pairwise comparisons between each model and the model with the
-largest ELPD (the model listed first). Therefore, the first \code{elpd_diff}
-value will always be \code{0} (i.e., the difference between the preferred model
-and itself) and the rest of the values will be negative.
-
-To compute the standard error of the difference in \link[=loo-glossary]{ELPD} ---
-which should not be expected to equal the difference of the standard errors
---- we use a paired estimate to take advantage of the fact that the same
-set of \eqn{N} data points was used to fit both models. These calculations
-should be most useful when \eqn{N} is large, because then non-normality of
-the distribution is not such an issue when estimating the uncertainty in
-these sums. These standard errors, for all their flaws, should give a
-better sense of uncertainty than what is obtained using the current
-standard approach of comparing differences of deviances to a Chi-squared
-distribution, a practice derived for Gaussian linear models or
-asymptotically, and which only applies to nested models in any case.
-}
-
-\subsection{\code{p_worse}, \code{diag_diff}, and \code{diag_elpd}}{
-
-The values in the \code{p_worse} column show the probability of each model
-having worse ELPD than the best model. These probabilities are computed
-with a normal approximation using the values from \code{elpd_diff} and
-\code{se_diff}. Sivula et al. (2025) present the conditions when the normal
-approximation used for SE and \code{se_diff} is good, and the column
-\code{diag_diff} contains possible diagnostic messages:
-\itemize{
-\item \code{N < 100} (small data)
-\item \verb{|elpd_diff| < 4} (models make similar predictions)
-}
+\strong{This function is deprecated}. Please use the new \code{\link[=model_compare]{model_compare()}} function
+instead. See \code{vignette("migration-guide", package = "loo")} for details.
-If either of these diagnostic messages is shown, the error distribution is
-skewed or thick tailed and the normal approximation based on \code{elpd_diff}
-and \code{se_diff} is not well calibrated. In that case, the probabilities
-\code{p_worse} are likely to be too large. However, \code{elpd_diff} and \code{se_diff}
-will still be indicative of the differences and uncertainties (for example,
-if \verb{|elpd_diff|} is many times larger than \code{se_diff} the difference is quite
-certain). In addition, if the model is not well specificed and there are
-outliers, the error distribution can also be skewed or thick tailed and the
-normal approximation is not well calibrated. Possible model misspecification
-and outliers can be diagnosed with usual predictive checking methods.
+\code{loo_compare()} remains an exported generic so that \code{loo_compare} methods
+registered by other packages keep dispatching as before, but it is frozen at
+its previous behavior: it compares \code{"loo"}, \code{"waic"}, and \code{"kfold"} objects on
+\link[=loo-glossary]{ELPD} only. Comparing
+\code{\link{pred_measure}} results requires \code{\link[=model_compare]{model_compare()}}.
-The column \code{diag_elpd} shows the PSIS-LOO Pareto k diagnostic for the
-pointwise ELPD computations for each model. If \verb{K k_psis > 0.7} is shown,
-where \code{K} is the number of high Pareto k values in the PSIS
-computation, then there may be significant bias in \code{elpd_diff} favoring
-models with a large number of high Pareto k values.
-}
-
-\subsection{Warnings for many model comparisons}{
-
-If more than \eqn{11} models are compared, we internally recompute the model
-differences using the median model by ELPD as the baseline model. We then
-estimate whether the differences in predictive performance are potentially
-due to chance as described by McLatchie and Vehtari (2023). This will flag
-a warning if it is deemed that there is a risk of over-fitting due to the
-selection process. In that case users are recommended to avoid model
-selection based on LOO-CV, and instead to favor model averaging/stacking or
-projection predictive inference.
-}
+The deprecation warning is issued once per session, so a script that calls
+\code{loo_compare()} repeatedly is not flooded with warnings.
}
\examples{
-# very artificial example, just for demonstration!
LL <- example_loglik_array()
-loo1 <- loo(LL) # should be worst model when compared
-loo2 <- loo(LL + 1) # should be second best model when compared
-loo3 <- loo(LL + 2) # should be best model when compared
-
-comp <- loo_compare(loo1, loo2, loo3)
-print(comp, digits = 2)
-print(comp, simplify = FALSE) # full table
+loo1 <- loo(LL)
+loo2 <- loo(LL + 1)
-# can use a list of objects with custom names
-# the names will be used in the output
-loo_compare(list("apple" = loo1, "banana" = loo2, "cherry" = loo3))
+# deprecated; identical to model_compare(loo1, loo2)
+suppressWarnings(loo_compare(loo1, loo2))
-\dontrun{
-# works for waic (and kfold) too
-loo_compare(waic(LL), waic(LL - 10))
-}
+# use this instead
+model_compare(loo1, loo2)
-}
-\references{
-Vehtari, A., Gelman, A., and Gabry, J. (2017). Practical Bayesian model
-evaluation using leave-one-out cross-validation and WAIC.
-\emph{Statistics and Computing}. 27(5), 1413--1432. doi:10.1007/s11222-016-9696-4
-(\href{https://link.springer.com/article/10.1007/s11222-016-9696-4}{journal version},
-\href{https://arxiv.org/abs/1507.04544}{preprint arXiv:1507.04544}).
-
-Vehtari, A., Simpson, D., Gelman, A., Yao, Y., and Gabry, J. (2024).
-Pareto smoothed importance sampling. \emph{Journal of Machine Learning Research},
-25(72):1-58.
-\href{https://jmlr.org/papers/v25/19-556.html}{PDF}
-
-Sivula, T, Magnusson, M., Matamoros A. A., and Vehtari, A. (2025).
-Uncertainty in Bayesian leave-one-out cross-validation based model
-comparison. \emph{Bayesian Analysis}. \doi{10.1214/25-BA1569}
-
-McLatchie, Y., and Vehtari, A. (2024). Efficient estimation and
-correction of selection-induced bias with order statistics.
-\emph{Statistics and Computing}. 34(132). \doi{10.1007/s11222-024-10442-4}
}
\seealso{
-\itemize{
-\item The \href{https://mc-stan.org/loo/articles/online-only/faq.html}{FAQ page} on
-the \strong{loo} website for answers to frequently asked questions.
-}
+\code{\link[=model_compare]{model_compare()}}
}
diff --git a/man/loo_pred_measure.Rd b/man/loo_pred_measure.Rd
index 251e661a..5a74084f 100644
--- a/man/loo_pred_measure.Rd
+++ b/man/loo_pred_measure.Rd
@@ -38,13 +38,36 @@ summaries (\code{elpd}, \code{mlpd}, \code{ic}).}
\itemize{
\item A \strong{character vector} of built-in names; see
\link{supported_measures_list}.
-\item A \strong{function} with attribute \code{"measure_name"} for one custom measure.
+\item A \strong{function} built with \code{\link[=custom_measure]{custom_measure()}} for one custom
+measure.
\item A \strong{list} mixing character scalars (built-in names) and named
functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}.
}
Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and
\code{log_weights} that appear in their formals, plus arguments from \code{control}.
-They must return a list with \code{estimates} and \code{pointwise}.}
+They must return a list with \code{estimates} and \code{pointwise}.
+
+A custom measure declares whether it is a loss (lower is better) or a
+utility (higher is better) with \code{loss} in \code{\link[=custom_measure]{custom_measure()}}. Without it a
+custom measure is taken to be a utility. \code{\link[=model_compare]{model_compare()}} uses the declaration to
+put all measures on a common utility scale and to rank models, so an
+undeclared loss is compared and ranked in the wrong direction.
+
+A custom measure can declare how the standard error of a difference
+between two models is computed, with \code{se_diff_fun} in \code{\link[=custom_measure]{custom_measure()}}.
+It accepts a function
+\code{function(ref, cmp) ...} or the shorthands \code{"sum"} and \code{"mean"} for the
+paired pointwise formulas. Without a declaration, \code{\link[=model_compare]{model_compare()}}
+reports the difference with an \code{NA} standard error. A function receives one list per model with elements
+\code{estimate}, \code{se}, \code{pointwise}, and \code{extra}, always on the measure's natural
+scale, and must return the standard error of the difference as a numeric
+scalar.
+
+\code{extra} is for anything the standard error needs that the pointwise values
+do not carry. Return it as an additional list element \code{extra} from the
+measure function and it is stored alongside the estimates and passed on to
+its \code{measure_se_diff} function; the built-in \code{r2} uses it for the baseline
+\code{(y_i - mean(y))^2}, which cannot be recovered once \code{y} is out of scope.}
\item{loo}{A \code{\link[=loo]{loo()}} result, computed with
\code{save_psis = TRUE} so that PSIS weights are available for additional
@@ -100,7 +123,7 @@ See \code{\link[=loo]{loo()}} and the
interpretation.
}
\details{
-\strong{Three equivalent input patterns:}
+\strong{Three input patterns:}
\describe{
\item{Precomputed \code{loo} object}{\code{loo_pred_measure(loo = loo_fit, ...)}.
@@ -110,12 +133,32 @@ PSIS weights separately.}
\item{\code{ylp} only}{PSIS weights are computed internally from \code{ylp}.}
}
+If you corrected the \code{loo} object after PSIS, pass it as \code{loo}.
+For example, \code{loo_moment_match()} or \code{brms::reloo()}.
+
For distributional and point-prediction measures (\code{crps}, \code{r2}, etc.),
supply \code{y}, \code{ypred}, and/or \code{mupred} as for \code{\link[=insample_pred_measure]{insample_pred_measure()}}. When
adding measures incrementally, call \code{\link[=pred_measure]{pred_measure()}} with \code{predperf} set to
an existing result; use \code{save_psis = TRUE} on the initial call so weights
are stored.
}
+\section{\code{measure_info} attribute}{
+
+All \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results include attribute
+\code{measure_info}: a named list, keyed by bare measure name, recording what
+\code{\link[=model_compare]{model_compare()}} needs to know about each measure — \code{loss} (whether lower
+values are better), \code{diff_method} (how the standard error of a difference is
+obtained), and, where applicable, \code{se_diff_fun} and \code{extra}. When measures
+are added incrementally with \code{\link[=pred_measure]{pred_measure()}}, the attribute is extended for
+the newly computed measures.
+
+Built-in measures take \code{loss}, \code{diff_method}, and \code{se_diff_fun} from the
+package measure registry. Custom measures always get \code{diff_method = "custom"}
+and take \code{loss} and \code{se_diff_fun} from \code{\link[=custom_measure]{custom_measure()}}. Without
+\code{loss = TRUE} a custom measure is treated as a utility, so an undeclared
+loss is compared and ranked in the wrong direction. See \link{loo-glossary}.
+}
+
\examples{
\donttest{
if (requireNamespace("brms", quietly = TRUE)) {
diff --git a/man/loo_subsample.Rd b/man/loo_subsample.Rd
index 6f381db6..663045e7 100644
--- a/man/loo_subsample.Rd
+++ b/man/loo_subsample.Rd
@@ -196,5 +196,5 @@ In \emph{Proceedings of the 23rd International Conference on Artificial
Intelligence and Statistics (AISTATS)}, PMLR 108:341-351.
}
\seealso{
-\code{\link[=loo]{loo()}}, \code{\link[=psis]{psis()}}, \code{\link[=loo_compare]{loo_compare()}}
+\code{\link[=loo]{loo()}}, \code{\link[=psis]{psis()}}, \code{\link[=loo_compare]{loo_compare()}}, \code{\link[=model_compare]{model_compare()}}
}
diff --git a/man/measure_acc.Rd b/man/measure_acc.Rd
index 024e2763..79b49a23 100644
--- a/man/measure_acc.Rd
+++ b/man/measure_acc.Rd
@@ -4,13 +4,7 @@
\alias{measure_acc}
\title{Classification accuracy (\code{acc})}
\usage{
-measure_acc(
- y,
- mupred,
- log_weights = NULL,
- pointwise = NULL,
- higher_is_better = NULL
-)
+measure_acc(y, mupred, log_weights = NULL, pointwise = NULL)
}
\arguments{
\item{y}{An integer vector of observed class labels.}
@@ -25,12 +19,6 @@ before computing each per-observation contribution.}
\item{pointwise}{Optional numeric vector of precomputed pointwise accuracy
contributions. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\description{
Computes pointwise and average classification accuracy for binary or
diff --git a/man/measure_bacc.Rd b/man/measure_bacc.Rd
index 824fe977..062dec82 100644
--- a/man/measure_bacc.Rd
+++ b/man/measure_bacc.Rd
@@ -4,13 +4,7 @@
\alias{measure_bacc}
\title{Balanced classification accuracy (\code{bacc})}
\usage{
-measure_bacc(
- y,
- mupred,
- log_weights = NULL,
- pointwise = NULL,
- higher_is_better = NULL
-)
+measure_bacc(y, mupred, log_weights = NULL, pointwise = NULL)
}
\arguments{
\item{y}{An integer vector of observed class labels.}
@@ -25,12 +19,6 @@ before computing each per-observation contribution.}
\item{pointwise}{Optional numeric vector of precomputed pointwise accuracy
contributions. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\description{
Computes balanced accuracy by averaging class-specific mean accuracy, giving
diff --git a/man/measure_brier.Rd b/man/measure_brier.Rd
index 3019f357..ede2aa45 100644
--- a/man/measure_brier.Rd
+++ b/man/measure_brier.Rd
@@ -4,13 +4,7 @@
\alias{measure_brier}
\title{Brier score (\code{brier})}
\usage{
-measure_brier(
- y,
- ypred,
- log_weights = NULL,
- pointwise = NULL,
- higher_is_better = NULL
-)
+measure_brier(y, ypred, log_weights = NULL, pointwise = NULL)
}
\arguments{
\item{y}{A numeric vector of binary outcomes coded as 0 or 1.}
@@ -24,12 +18,6 @@ before computing each per-observation contribution.}
\item{pointwise}{Optional numeric vector of precomputed pointwise Brier
scores. If provided, \code{y}, \code{ypred}, and \code{log_weights} are ignored.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\description{
Computes the Brier score for binary outcomes as squared error between the
diff --git a/man/measure_elpd.Rd b/man/measure_elpd.Rd
index a588e577..b9efd035 100644
--- a/man/measure_elpd.Rd
+++ b/man/measure_elpd.Rd
@@ -4,12 +4,7 @@
\alias{measure_elpd}
\title{Expected log pointwise predictive density (\code{elpd})}
\usage{
-measure_elpd(
- ylp,
- log_weights = NULL,
- pointwise = NULL,
- higher_is_better = NULL
-)
+measure_elpd(ylp, log_weights = NULL, pointwise = NULL)
}
\arguments{
\item{ylp}{A numeric matrix or three-dimensional array of log predictive
@@ -28,19 +23,12 @@ before computing each per-observation contribution.}
\item{pointwise}{Optional numeric vector of precomputed \eqn{\mathrm{lppd}_i}
values. When supplied, \code{ylp} and \code{log_weights} are ignored.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\description{
Computes the expected log pointwise predictive density (ELPD) as the sum of
pointwise log predictive density contributions (\eqn{\mathrm{lppd}_i}), using
\code{\link[=ptw_log_pred_density]{ptw_log_pred_density()}}. ELPD is returned on the utility scale (higher is
better), consistent with the sign convention used throughout this package.
-Manual change of sign convention is possible via \code{higher_is_better}.
}
\details{
\deqn{\mathrm{elpd} = \sum_{i=1}^{n} \mathrm{lppd}_i,}
diff --git a/man/measure_ic.Rd b/man/measure_ic.Rd
index b8a64c53..902f5117 100644
--- a/man/measure_ic.Rd
+++ b/man/measure_ic.Rd
@@ -4,7 +4,7 @@
\alias{measure_ic}
\title{Information Criteria (\code{ic})}
\usage{
-measure_ic(ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL)
+measure_ic(ylp, log_weights = NULL, pointwise = NULL)
}
\arguments{
\item{ylp}{A numeric matrix or three-dimensional array of log predictive
@@ -24,12 +24,6 @@ before computing each per-observation contribution.}
\item{pointwise}{Optional numeric vector of precomputed pointwise
contributions \eqn{\mathrm{ic}_i = -2 \cdot \mathrm{lppd}_i}. If provided,
\code{ylp} and \code{log_weights} are ignored.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\description{
Computes the information criteria as -2 x log predictive density (lppd_i)
diff --git a/man/measure_mae.Rd b/man/measure_mae.Rd
index 0b0cfe88..7192a790 100644
--- a/man/measure_mae.Rd
+++ b/man/measure_mae.Rd
@@ -4,13 +4,7 @@
\alias{measure_mae}
\title{Mean absolute error (\code{mae})}
\usage{
-measure_mae(
- y,
- mupred,
- log_weights = NULL,
- pointwise = NULL,
- higher_is_better = NULL
-)
+measure_mae(y, mupred, log_weights = NULL, pointwise = NULL)
}
\arguments{
\item{y}{A numeric vector of observed outcomes.}
@@ -24,12 +18,6 @@ before computing each per-observation contribution.}
\item{pointwise}{Optional numeric vector of precomputed pointwise absolute
errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\description{
Computes MAE between observed outcomes and posterior predictive point
diff --git a/man/measure_mlpd.Rd b/man/measure_mlpd.Rd
index 8017e44c..571217df 100644
--- a/man/measure_mlpd.Rd
+++ b/man/measure_mlpd.Rd
@@ -4,12 +4,7 @@
\alias{measure_mlpd}
\title{Mean log pointwise predictive density (\code{mlpd})}
\usage{
-measure_mlpd(
- ylp,
- log_weights = NULL,
- pointwise = NULL,
- higher_is_better = NULL
-)
+measure_mlpd(ylp, log_weights = NULL, pointwise = NULL)
}
\arguments{
\item{ylp}{A numeric matrix or three-dimensional array of log predictive
@@ -28,12 +23,6 @@ before computing each per-observation contribution.}
\item{pointwise}{Optional numeric vector of precomputed \eqn{\mathrm{lppd}_i}
values. When supplied, \code{ylp} and \code{log_weights} are ignored.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\description{
Computes MLPD as the average of pointwise log predictive density (lppd_i)
diff --git a/man/measure_mse.Rd b/man/measure_mse.Rd
index dc511b36..be0f5b47 100644
--- a/man/measure_mse.Rd
+++ b/man/measure_mse.Rd
@@ -4,13 +4,7 @@
\alias{measure_mse}
\title{Mean squared error (\code{mse})}
\usage{
-measure_mse(
- y,
- mupred,
- log_weights = NULL,
- pointwise = NULL,
- higher_is_better = NULL
-)
+measure_mse(y, mupred, log_weights = NULL, pointwise = NULL)
}
\arguments{
\item{y}{A numeric vector of observed outcomes.}
@@ -24,12 +18,6 @@ before computing each per-observation contribution.}
\item{pointwise}{Optional numeric vector of precomputed pointwise squared
errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\description{
Computes MSE between observed outcomes and posterior predictive point
diff --git a/man/measure_params.Rd b/man/measure_params.Rd
index ad7aa8d7..fd880a57 100644
--- a/man/measure_params.Rd
+++ b/man/measure_params.Rd
@@ -10,12 +10,6 @@ before computing each per-observation contribution.}
\item{pointwise}{Optional numeric vector of precomputed per-observation
contributions. When supplied, \code{ylp} and \code{log_weights} are ignored.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\value{
An object of class \code{"measure"}: a list with:
diff --git a/man/measure_r2.Rd b/man/measure_r2.Rd
index 42a4f71f..f9d6e9bf 100644
--- a/man/measure_r2.Rd
+++ b/man/measure_r2.Rd
@@ -4,13 +4,7 @@
\alias{measure_r2}
\title{Predictive R-squared (\code{r2})}
\usage{
-measure_r2(
- y,
- mupred,
- log_weights = NULL,
- pointwise = NULL,
- higher_is_better = NULL
-)
+measure_r2(y, mupred, log_weights = NULL, pointwise = NULL)
}
\arguments{
\item{y}{A numeric vector of observed outcomes.}
@@ -25,12 +19,6 @@ before computing each per-observation contribution.}
\item{pointwise}{Optional numeric vector of precomputed pointwise squared
errors. If provided, \code{mupred} and \code{log_weights} are ignored. \code{y} is always
required, because \code{r2} needs the variance of \code{y} as its baseline.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\description{
Computes predictive R-squared as one minus the ratio of prediction MSE to
diff --git a/man/measure_rmse.Rd b/man/measure_rmse.Rd
index 95a98e37..ca04c7a1 100644
--- a/man/measure_rmse.Rd
+++ b/man/measure_rmse.Rd
@@ -4,13 +4,7 @@
\alias{measure_rmse}
\title{Root mean squared error (\code{rmse})}
\usage{
-measure_rmse(
- y,
- mupred,
- log_weights = NULL,
- pointwise = NULL,
- higher_is_better = NULL
-)
+measure_rmse(y, mupred, log_weights = NULL, pointwise = NULL)
}
\arguments{
\item{y}{A numeric vector of observed outcomes.}
@@ -24,12 +18,6 @@ before computing each per-observation contribution.}
\item{pointwise}{Optional numeric vector of precomputed pointwise squared
errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\description{
Computes RMSE as the square root of MSE and propagates uncertainty via a
diff --git a/man/measure_rps.Rd b/man/measure_rps.Rd
index 11e9f14c..fd953307 100644
--- a/man/measure_rps.Rd
+++ b/man/measure_rps.Rd
@@ -4,14 +4,7 @@
\alias{measure_rps}
\title{Ranked Probability Score (RPS, SRPS, CRPS, SCRPS)}
\usage{
-measure_rps(
- y,
- ypred,
- log_weights = NULL,
- pointwise = NULL,
- scaled = FALSE,
- higher_is_better = NULL
-)
+measure_rps(y, ypred, log_weights = NULL, pointwise = NULL, scaled = FALSE)
}
\arguments{
\item{y}{A numeric vector of \eqn{n} observed outcomes. May be integer-valued
@@ -24,17 +17,15 @@ measure_rps(
weights with dimensions \eqn{S \times n}. Weights are column-normalized
before computing each per-observation contribution.}
-\item{pointwise}{Optional numeric vector of precomputed pointwise rps values.
-If provided, \code{y}, \code{ypred}, and \code{log_weights} are ignored.}
+\item{pointwise}{Optional numeric vector of precomputed pointwise values, on
+the scale of the measure that is returned: RPS/CRPS when \code{scaled = FALSE}
+and SRPS/SCRPS when \code{scaled = TRUE}. The values are used as they are, with
+no further transformation; in particular, unscaled values are not converted
+to the scaled variant. If provided, \code{y}, \code{ypred}, and \code{log_weights} are
+ignored.}
\item{scaled}{Logical; if \code{TRUE}, computes the scaled variant (SRPS for
discrete outcomes, SCRPS for continuous outcomes). Default is \code{FALSE}.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
}
\description{
Computes proper scoring rules based on the ranked probability score family,
@@ -74,15 +65,28 @@ accurate than single-permutation estimators. The same estimator is used for
both discrete and continuous outcomes; see Hosking (1990, 1996) for
theoretical justification in the discrete case.
-If log-weights (\code{log_weights}) are provided (e.g., PSIS weights
-for LOO cross-validation), a weighted PWM estimator is used instead, which
-accounts for the importance weights when estimating expectations.
+The term \eqn{E[|X - X'|]} is computed as a weighted average over all pairs
+of draws,
+\deqn{E[|X - X'|] = \frac{\sum_i \sum_{j \neq i} w_i w_j |x_i - x_j|}{1 -
+ \sum_i w_i^2},}
+which is evaluated in \eqn{O(S \log S)} using the sorted draws and the
+cumulative sums of their weights. If log-weights (\code{log_weights}) are provided
+(e.g., PSIS weights for LOO cross-validation), the \eqn{w_i} are the
+normalized importance weights and \eqn{E[|X - y|]} is likewise a weighted
+mean. Otherwise the weights are equal, \eqn{w_i = 1/S}, and the expression
+reduces to the usual unbiased PWM estimator with the \eqn{1 / (S (S - 1))}
+normalization. Because the estimate is a convex combination of
+\eqn{|x_i - x_j|}, it is always non-negative and invariant to shifts of
+\code{ypred}.
\strong{Sign convention:}
-Unscaled scores are returned as losses (lower is better). Scaled scores are
-returned as utilities (higher is better), after Bolin & Wallin (2023). Set
-\code{higher_is_better} to select the orientation you want.
+Unscaled scores (RPS, CRPS) are returned on the loss scale of Gneiting &
+Raftery (2007): lower is better. Scaled scores (SRPS, SCRPS) follow Bolin &
+Wallin (2023) and are returned on the utility scale: higher is better.
+\code{\link[=model_compare]{model_compare()}} reports differences for both on the utility scale, so no
+manual conversion is needed there. The deprecated \code{\link[=crps]{crps()}} returned the
+negated unscaled score; \code{-measure_rps(...)$pointwise} reproduces it.
}
\examples{
# Discrete outcomes: RPS
diff --git a/man/measure_srps.Rd b/man/measure_srps.Rd
index 270cf74e..4e472582 100644
--- a/man/measure_srps.Rd
+++ b/man/measure_srps.Rd
@@ -4,13 +4,7 @@
\alias{measure_srps}
\title{Scaled Ranked Probability Score (SRPS, SCRPS)}
\usage{
-measure_srps(
- y,
- ypred,
- log_weights = NULL,
- pointwise = NULL,
- higher_is_better = NULL
-)
+measure_srps(y, ypred, log_weights = NULL, pointwise = NULL)
}
\arguments{
\item{y}{A numeric vector of \eqn{n} observed outcomes. May be integer-valued
@@ -23,14 +17,12 @@ measure_srps(
weights with dimensions \eqn{S \times n}. Weights are column-normalized
before computing each per-observation contribution.}
-\item{pointwise}{Optional numeric vector of precomputed pointwise rps values.
-If provided, \code{y}, \code{ypred}, and \code{log_weights} are ignored.}
-
-\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate
-better predictive performance. \code{NULL} (default) keeps each measure's
-natural convention (e.g. MSE on a loss scale, ELPD on a utility scale).
-Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss
-scale (lower is better).}
+\item{pointwise}{Optional numeric vector of precomputed pointwise values, on
+the scale of the measure that is returned: RPS/CRPS when \code{scaled = FALSE}
+and SRPS/SCRPS when \code{scaled = TRUE}. The values are used as they are, with
+no further transformation; in particular, unscaled values are not converted
+to the scaled variant. If provided, \code{y}, \code{ypred}, and \code{log_weights} are
+ignored.}
}
\description{
A convenience wrapper around \code{\link[=measure_rps]{measure_rps()}} with \code{scaled = TRUE}. Computes the
diff --git a/man/model_compare.Rd b/man/model_compare.Rd
new file mode 100644
index 00000000..4521b1cd
--- /dev/null
+++ b/man/model_compare.Rd
@@ -0,0 +1,338 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/model_compare-print.R, R/model_compare.R
+\name{print.compare.loo}
+\alias{print.compare.loo}
+\alias{model_compare}
+\alias{model_compare.default}
+\title{Model comparison}
+\usage{
+\method{print}{compare.loo}(x, ..., digits = NULL, p_worse = TRUE, simplify = TRUE, measures = NULL)
+
+model_compare(x, ...)
+
+\method{model_compare}{default}(x, ...)
+}
+\arguments{
+\item{x}{An object of class \code{"loo"} or \code{"pred_measure"}, or a list of such
+objects. List names are used as the model names in the output. See
+\strong{Examples}.}
+
+\item{...}{Additional objects of class \code{"loo"} or \code{"pred_measure"}, if not
+passed in as a single list. Naming every model here, as in
+\code{model_compare(A = m1, B = m2)}, names the models in the output, exactly as
+the list form does.}
+
+\item{digits}{For the print method only, the number of decimal places to
+print. The default \code{NULL} gives each measure its own: 1 for \code{elpd} and
+\code{ic}, and 3 for \code{mlpd} and for the bounded measures (\code{r2}, \code{acc}, \code{bacc},
+\code{brier}). A measure on the scale of the data (\code{mae}, \code{rmse}, \code{mse}, \code{rps},
+\code{srps}, and any custom measure) takes the places that show two significant
+digits of its own standard error, at most 4.
+Pass a single number for one format in every column, or a named vector
+such as \code{c(r2 = 2, rmse = 3)} to override single measures. \code{p_worse}
+always prints with 2 places.}
+
+\item{p_worse}{For the print method only, should we include the normal
+approximation based probability of each model having worse performance than
+the reference model? The default is \code{TRUE}.}
+
+\item{simplify}{For the print method only, should the output be simplified to
+only include the model names, differences, and (when \code{p_worse = TRUE})
+diagnostic columns? The default is \code{TRUE}. Set to \code{FALSE} to also print the
+available estimate columns: pointwise ELPD, LOOIC/WAIC and their standard
+errors for classic comparisons. For \code{\link{pred_measure}}
+comparisons each printed table gains the estimate and standard error of
+its own measure, and an ELPD table also gains \code{p} and \code{se_p}. With the
+default \code{measures = NULL} one table is printed, and it gains the estimates
+of every compared measure. The difference columns are never added.}
+
+\item{measures}{For \code{pred_measure} comparisons only, which measures to
+print diff tables for. \code{NULL} (default) prints only the ranking measure
+(the first compared measure, \code{"elpd"} when present);
+\code{"all"} prints all compared measures; or a character vector of measure
+names (e.g. \code{c("elpd", "mse")}). Each table is sorted by its own measure,
+best model first, so the same model need not lead every table.}
+}
+\value{
+A data frame of class \code{"compare.loo"} with one row per model and its
+own print method.
+
+For classic \code{"loo"} / \code{"waic"} / \code{"kfold"} comparisons the columns are
+unchanged from previous versions: \code{model}, \code{elpd_diff}, \code{se_diff},
+\code{p_worse}, \code{diag_diff}, \code{diag_elpd}, and the estimate columns of the input
+objects.
+
+For \code{\link{pred_measure}} comparisons there is a \verb{\{measure\}_diff}
+and a \verb{\{measure\}_se_diff} column for every measure shared by all models
+(e.g. \code{rmse_diff}, \code{rmse_se_diff}). ELPD-family measures use \code{elpd_diff}
+and \code{se_diff} instead. \code{p_worse} and \code{diag_diff} are computed for ELPD
+only. \code{diag_elpd} holds per-model Pareto \eqn{\hat{k}} diagnostics and is
+present only for \code{\link[=loo_pred_measure]{loo_pred_measure()}} comparisons, the
+only source with Pareto \eqn{\hat{k}} values.
+
+The object also carries the following attributes:
+\describe{
+\item{\code{compare_reference}}{
+A named character vector giving, for each measure, the model its
+differences were computed against, which is that measure's own best
+model.
+}
+\item{\code{compare_measures}}{
+Bare names of all measures that were compared.
+}
+\item{\code{sign_converted_measures}}{
+Bare names of the loss measures whose sign was flipped onto the utility
+scale.
+}
+\item{\code{compare_source}}{
+The shared evaluation source: \code{"loo"}, \code{"kfold"}, \code{"test"}, or
+\code{"insample"}.
+}
+}
+\code{compare_reference} is set for every comparison; the last three are set
+for \code{\link{pred_measure}} comparisons only.
+}
+\description{
+Compare fitted models on \link[=loo-glossary]{ELPD} or, for
+\code{\link{pred_measure}} results, on several predictive performance
+measures at once.
+
+\code{model_compare()} accepts two families of input:
+\itemize{
+\item \strong{Classic results} --- \code{"loo"}, \code{"waic"}, and \code{"kfold"} objects, compared
+on ELPD alone.
+\item \strong{Predictive measure results} --- objects from
+\code{\link[=loo_pred_measure]{loo_pred_measure()}},
+\code{\link[=kfold_pred_measure]{kfold_pred_measure()}},
+\code{\link[=test_pred_measure]{test_pred_measure()}}, or
+\code{\link[=insample_pred_measure]{insample_pred_measure()}}, compared on every
+measure the models share.
+}
+
+All models in one call must be evaluated the same way. Differences between,
+say, a LOO and a k-fold result would contrast held-out schemes rather than
+models, so mixed inputs are an error.
+}
+\details{
+\subsection{Differences and their standard errors}{
+
+Differences are pairwise: every model is compared with one reference model,
+whose own \verb{\{measure\}_diff} is therefore \code{0}. The reference is the best
+model on that measure, so \code{mse_diff} may use a different reference than
+\code{elpd_diff}, and the remaining differences for a measure are all negative.
+Rows are ordered by \code{"elpd"} when all models share it. Otherwise, rows are
+ordered by the first shared measure in alphabetical order.
+
+The standard error of a difference is a paired estimate, which uses the
+fact that the same \eqn{N} data points were used for both models. It should
+not be expected to equal the difference of the two models' standard errors.
+}
+
+\subsection{\code{p_worse}, \code{diag_diff}, and \code{diag_elpd}}{
+
+\code{p_worse} is the probability that a model has worse ELPD than the reference
+model, computed with a normal approximation from \code{elpd_diff} and \code{se_diff}.
+Sivula et al. (2025) give the conditions under which that approximation is
+good; \code{diag_diff} reports the two that fail most often:
+\itemize{
+\item \code{N < 100} (small data)
+\item \verb{|elpd_diff| < 4} (models make similar predictions)
+}
+
+Either message means the error distribution is skewed or thick tailed, the
+normal approximation is not well calibrated, and \code{p_worse} is likely too
+large. If \verb{|elpd_diff|} is many times \code{se_diff} the difference is
+quite certain. Model misspecification and outliers also skew the error
+distribution, and can be diagnosed with the usual predictive checks.
+
+\code{diag_elpd} reports the PSIS-LOO Pareto \eqn{\hat{k}} diagnostic for each
+model's pointwise ELPD. An entry \verb{K k_psis > 0.7}, where \code{K} counts the
+high Pareto \eqn{\hat{k}} values, warns of possible bias in \code{elpd_diff}
+favoring models with many such values. Pareto \eqn{\hat{k}} describes a
+model's PSIS-LOO approximation rather than any one measure or pair of
+models, and every LOO measure uses the same importance weights, so for
+\code{pred_measure} comparisons \code{print()} reports it once per model in a block
+above the difference tables instead of as a column inside one of them. The
+\code{diag_elpd} column is still returned on the object.
+}
+
+\subsection{Comparing \code{pred_measure} objects}{
+
+When all inputs are predictive measure results sharing one evaluation
+source, paired differences are computed for every measure present in all
+models. Measures are matched on their bare names, so the source suffix
+(\verb{_loo}, \verb{_kfold}, \verb{_test}, or none for in-sample) is handled
+transparently. When the models were evaluated on different \code{measure} sets,
+only the shared measures are compared and a warning lists the omitted ones.
+
+The data frame carries one row order for all measures, but each \emph{printed}
+measure table is sorted by its own difference, so the best model on that
+measure always leads its table and the differences run in decreasing order.
+Use \code{print(x, measures = "all")} to display a table for every compared
+measure; see \link{loo-glossary} for column definitions.
+}
+
+\subsection{Utility scale and sign conversion}{
+
+Measures differ in orientation in their raw form: ELPD and SRPS/SCRPS are
+utilities (higher is better), while MSE, RPS/CRPS and the Brier score are
+losses (lower is better). All \verb{\{measure\}_diff} values are reported on a
+common utility scale, so loss measures have their sign flipped and a
+negative \verb{\{measure\}_diff} always means worse performance than the
+reference. Which measures are losses is recorded in the \code{loss} element of
+each measure's entry in the \code{measure_info} attribute of an
+\verb{*_pred_measure()} result. The flipped measures are named in the
+\code{sign_converted_measures} attribute. \code{print()} marks them with
+"sign flipped" in the table header and names them below the tables.
+
+A custom measure is treated as a utility unless it declares otherwise with
+\code{loss = TRUE} in \code{\link[=custom_measure]{custom_measure()}}. The declaration also determines the
+ranking direction, so an undeclared loss is both flipped and ranked in the
+wrong direction; see \code{\link[=insample_pred_measure]{insample_pred_measure()}}.
+}
+
+\subsection{Standard error of a measure difference}{
+
+How \verb{\{measure\}_se_diff} is obtained is recorded in the \code{diff_method}
+element of the measure's entry in \code{measure_info}:
+\itemize{
+\item \code{"sum"} or \code{"mean"}: the overall estimate is the sum (\code{elpd}, \code{ic}) or the
+mean (\code{mlpd}, \code{mae}, \code{mse}, \code{acc}, \code{rps}, \code{srps}, \code{brier}) of its
+pointwise contributions, so the standard error is computed from paired
+pointwise differences (the same formula as \code{se_diff}).
+\item \code{"measure_specific"}: the overall estimate is not a sum or mean of
+pointwise contributions (\code{r2}, \code{rmse}, \code{bacc}), so the measure supplies
+its own standard error of the difference.
+\item \code{"custom"}: the standard error comes from the measure's own
+\code{attr(my_fun, "measure_se_diff")} declaration, set with
+\code{\link[=custom_measure]{custom_measure()}}. \verb{\{measure\}_se_diff} is \code{NA} when the measure
+declares nothing.
+}
+}
+
+\subsection{Source-specific behavior}{
+
+Comparisons behave the same way across sources, with three exceptions:
+\itemize{
+\item \strong{\code{diag_elpd}} is produced only for
+\code{\link[=loo_pred_measure]{loo_pred_measure()}} comparisons, since Pareto
+\eqn{\hat{k}} diagnostics exist only for PSIS-LOO.
+\item \strong{K-fold} comparisons warn when the models do not share the same number
+of folds, matching the behavior for plain \code{"kfold"} objects.
+\item \strong{In-sample} comparisons warn that in-sample scores are optimistically
+biased and favor more complex models. They are supported for
+completeness, but out-of-sample sources should be preferred for model
+selection.
+}
+}
+
+\subsection{Warnings for many model comparisons}{
+
+If more than \eqn{11} models are compared, we internally recompute the model
+differences using the median model (by ELPD, or by the ranking measure
+for \code{pred_measure} comparisons) as the baseline, and estimate whether the
+differences in predictive performance are potentially due to chance as
+described by McLatchie and Vehtari (2023). This flags a warning if there is
+a risk of over-fitting due to the selection process. In that case users are
+recommended to avoid model selection based on LOO-CV, and instead to favor
+model averaging/stacking or projection predictive inference.
+}
+}
+\examples{
+# very artificial example, just for demonstration!
+LL <- example_loglik_array()
+loo1 <- loo(LL) # should be worst model when compared
+loo2 <- loo(LL + 1) # should be second best model when compared
+loo3 <- loo(LL + 2) # should be best model when compared
+
+comp <- model_compare(loo1, loo2, loo3)
+print(comp, digits = 2)
+
+# can use a list of objects with custom names
+# the names will be used in the output
+model_compare(list("apple" = loo1, "banana" = loo2, "cherry" = loo3))
+
+\dontrun{
+# works for waic (and kfold) too
+model_compare(waic(LL), waic(LL - 10))
+
+# compare multiple predictive measures from loo_pred_measure()
+if (requireNamespace("brms", quietly = TRUE)) {
+ fit1 <- brms::brm(
+ Reaction ~ Days, data = lme4::sleepstudy,
+ refresh = 0, chains = 2, iter = 1000
+ )
+ fit2 <- brms::brm(
+ Reaction ~ poly(Days, 2), data = lme4::sleepstudy,
+ refresh = 0, chains = 2, iter = 1000
+ )
+ pm1 <- loo_pred_measure(
+ loo = loo(fit1, save_psis = TRUE),
+ y = fit1$data$Reaction,
+ mupred = brms::posterior_epred(fit1),
+ measures = c("rmse", "r2")
+ )
+ pm2 <- loo_pred_measure(
+ loo = loo(fit2, save_psis = TRUE),
+ y = fit2$data$Reaction,
+ mupred = brms::posterior_epred(fit2),
+ measures = c("rmse", "r2")
+ )
+ comp <- model_compare(pm1, pm2)
+ print(comp)
+ print(comp, measures = "all")
+
+ # the same works for k-fold CV
+ folds <- kfold_split_random(K = 5, N = nrow(lme4::sleepstudy))
+ kf1 <- brms::kfold(fit1, folds = folds, save_fits = TRUE)
+ kf2 <- brms::kfold(fit2, folds = folds, save_fits = TRUE)
+ kpm1 <- kfold_pred_measure(
+ y = fit1$data$Reaction,
+ mupred = brms::kfold_predict(kf1, method = "fitted")$yrep,
+ kfold = kf1,
+ measures = "rmse"
+ )
+ kpm2 <- kfold_pred_measure(
+ y = fit2$data$Reaction,
+ mupred = brms::kfold_predict(kf2, method = "fitted")$yrep,
+ kfold = kf2,
+ measures = "rmse"
+ )
+ model_compare(kpm1, kpm2)
+
+ # mixing evaluation sources is an error
+ try(model_compare(pm1, kpm2))
+}
+}
+
+}
+\references{
+Vehtari, A., Gelman, A., and Gabry, J. (2017). Practical Bayesian model
+evaluation using leave-one-out cross-validation and WAIC.
+\emph{Statistics and Computing}. 27(5), 1413--1432. doi:10.1007/s11222-016-9696-4
+(\href{https://link.springer.com/article/10.1007/s11222-016-9696-4}{journal version},
+\href{https://arxiv.org/abs/1507.04544}{preprint arXiv:1507.04544}).
+
+Vehtari, A., Simpson, D., Gelman, A., Yao, Y., and Gabry, J. (2024).
+Pareto smoothed importance sampling. \emph{Journal of Machine Learning Research},
+25(72):1-58.
+\href{https://jmlr.org/papers/v25/19-556.html}{PDF}
+
+Sivula, T, Magnusson, M., Matamoros A. A., and Vehtari, A. (2025).
+Uncertainty in Bayesian leave-one-out cross-validation based model
+comparison. \emph{Bayesian Analysis}. \doi{10.1214/25-BA1569}
+
+McLatchie, Y., and Vehtari, A. (2024). Efficient estimation and
+correction of selection-induced bias with order statistics.
+\emph{Statistics and Computing}. 34(132). \doi{10.1007/s11222-024-10442-4}
+}
+\seealso{
+\itemize{
+\item The \href{https://mc-stan.org/loo/articles/online-only/faq.html}{FAQ page} on
+the \strong{loo} website for answers to frequently asked questions.
+\item The article
+\href{https://mc-stan.org/loo/articles/articles-online-only/model-comparison.html}{Model comparison: Explanation of \code{model_compare()}}
+on the \strong{loo} website, for how the differences and their standard errors
+are computed for each measure.
+}
+}
diff --git a/man/pred_measure.Rd b/man/pred_measure.Rd
index be93bb3f..c68fca14 100644
--- a/man/pred_measure.Rd
+++ b/man/pred_measure.Rd
@@ -38,13 +38,36 @@ summaries (\code{elpd}, \code{mlpd}, \code{ic}).}
\itemize{
\item A \strong{character vector} of built-in names; see
\link{supported_measures_list}.
-\item A \strong{function} with attribute \code{"measure_name"} for one custom measure.
+\item A \strong{function} built with \code{\link[=custom_measure]{custom_measure()}} for one custom
+measure.
\item A \strong{list} mixing character scalars (built-in names) and named
functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}.
}
Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and
\code{log_weights} that appear in their formals, plus arguments from \code{control}.
-They must return a list with \code{estimates} and \code{pointwise}.}
+They must return a list with \code{estimates} and \code{pointwise}.
+
+A custom measure declares whether it is a loss (lower is better) or a
+utility (higher is better) with \code{loss} in \code{\link[=custom_measure]{custom_measure()}}. Without it a
+custom measure is taken to be a utility. \code{\link[=model_compare]{model_compare()}} uses the declaration to
+put all measures on a common utility scale and to rank models, so an
+undeclared loss is compared and ranked in the wrong direction.
+
+A custom measure can declare how the standard error of a difference
+between two models is computed, with \code{se_diff_fun} in \code{\link[=custom_measure]{custom_measure()}}.
+It accepts a function
+\code{function(ref, cmp) ...} or the shorthands \code{"sum"} and \code{"mean"} for the
+paired pointwise formulas. Without a declaration, \code{\link[=model_compare]{model_compare()}}
+reports the difference with an \code{NA} standard error. A function receives one list per model with elements
+\code{estimate}, \code{se}, \code{pointwise}, and \code{extra}, always on the measure's natural
+scale, and must return the standard error of the difference as a numeric
+scalar.
+
+\code{extra} is for anything the standard error needs that the pointwise values
+do not carry. Return it as an additional list element \code{extra} from the
+measure function and it is stored alongside the estimates and passed on to
+its \code{measure_se_diff} function; the built-in \code{r2} uses it for the baseline
+\code{(y_i - mean(y))^2}, which cannot be recovered once \code{y} is out of scope.}
\item{predperf}{An existing predictive measure object (class
\code{"pred_measure"}) to update. When supplied, stored rows and
diff --git a/man/pred_measure_params.Rd b/man/pred_measure_params.Rd
index 323c30ca..80cb33a3 100644
--- a/man/pred_measure_params.Rd
+++ b/man/pred_measure_params.Rd
@@ -48,13 +48,36 @@ training fit) in \code{\link[=test_pred_measure]{test_pred_measure()}} to score
\itemize{
\item A \strong{character vector} of built-in names; see
\link{supported_measures_list}.
-\item A \strong{function} with attribute \code{"measure_name"} for one custom measure.
+\item A \strong{function} built with \code{\link[=custom_measure]{custom_measure()}} for one custom
+measure.
\item A \strong{list} mixing character scalars (built-in names) and named
functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}.
}
Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and
\code{log_weights} that appear in their formals, plus arguments from \code{control}.
-They must return a list with \code{estimates} and \code{pointwise}.}
+They must return a list with \code{estimates} and \code{pointwise}.
+
+A custom measure declares whether it is a loss (lower is better) or a
+utility (higher is better) with \code{loss} in \code{\link[=custom_measure]{custom_measure()}}. Without it a
+custom measure is taken to be a utility. \code{\link[=model_compare]{model_compare()}} uses the declaration to
+put all measures on a common utility scale and to rank models, so an
+undeclared loss is compared and ranked in the wrong direction.
+
+A custom measure can declare how the standard error of a difference
+between two models is computed, with \code{se_diff_fun} in \code{\link[=custom_measure]{custom_measure()}}.
+It accepts a function
+\code{function(ref, cmp) ...} or the shorthands \code{"sum"} and \code{"mean"} for the
+paired pointwise formulas. Without a declaration, \code{\link[=model_compare]{model_compare()}}
+reports the difference with an \code{NA} standard error. A function receives one list per model with elements
+\code{estimate}, \code{se}, \code{pointwise}, and \code{extra}, always on the measure's natural
+scale, and must return the standard error of the difference as a numeric
+scalar.
+
+\code{extra} is for anything the standard error needs that the pointwise values
+do not carry. Return it as an additional list element \code{extra} from the
+measure function and it is stored alongside the estimates and passed on to
+its \code{measure_se_diff} function; the built-in \code{r2} uses it for the baseline
+\code{(y_i - mean(y))^2}, which cannot be recovered once \code{y} is out of scope.}
\item{predperf}{An existing predictive measure object (class
\code{"pred_measure"}) to update. When supplied, stored rows and
@@ -86,10 +109,6 @@ functions; required when calling \code{\link[=do_pred_measure]{do_pred_measure()
\item{control}{Named list of per-measure settings. Each name must match an
element of \code{measures}; the value is a list of arguments passed to that
measure's summary function (e.g. \code{list(new_measure = list(add_arg = 10))}).}
-
-\item{measure_name}{For a single custom function, set
-\code{attr(my_fun, "measure_name") <- "my_metric"} before passing \code{my_fun} to
-\code{measures}.}
}
\description{
Parameter definitions shared by the user-facing entry points and the
diff --git a/man/test_pred_measure.Rd b/man/test_pred_measure.Rd
index 5a8e4d62..3575c5fd 100644
--- a/man/test_pred_measure.Rd
+++ b/man/test_pred_measure.Rd
@@ -41,13 +41,36 @@ training fit) in \code{\link[=test_pred_measure]{test_pred_measure()}} to score
\itemize{
\item A \strong{character vector} of built-in names; see
\link{supported_measures_list}.
-\item A \strong{function} with attribute \code{"measure_name"} for one custom measure.
+\item A \strong{function} built with \code{\link[=custom_measure]{custom_measure()}} for one custom
+measure.
\item A \strong{list} mixing character scalars (built-in names) and named
functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}.
}
Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and
\code{log_weights} that appear in their formals, plus arguments from \code{control}.
-They must return a list with \code{estimates} and \code{pointwise}.}
+They must return a list with \code{estimates} and \code{pointwise}.
+
+A custom measure declares whether it is a loss (lower is better) or a
+utility (higher is better) with \code{loss} in \code{\link[=custom_measure]{custom_measure()}}. Without it a
+custom measure is taken to be a utility. \code{\link[=model_compare]{model_compare()}} uses the declaration to
+put all measures on a common utility scale and to rank models, so an
+undeclared loss is compared and ranked in the wrong direction.
+
+A custom measure can declare how the standard error of a difference
+between two models is computed, with \code{se_diff_fun} in \code{\link[=custom_measure]{custom_measure()}}.
+It accepts a function
+\code{function(ref, cmp) ...} or the shorthands \code{"sum"} and \code{"mean"} for the
+paired pointwise formulas. Without a declaration, \code{\link[=model_compare]{model_compare()}}
+reports the difference with an \code{NA} standard error. A function receives one list per model with elements
+\code{estimate}, \code{se}, \code{pointwise}, and \code{extra}, always on the measure's natural
+scale, and must return the standard error of the difference as a numeric
+scalar.
+
+\code{extra} is for anything the standard error needs that the pointwise values
+do not carry. Return it as an additional list element \code{extra} from the
+measure function and it is stored alongside the estimates and passed on to
+its \code{measure_se_diff} function; the built-in \code{r2} uses it for the baseline
+\code{(y_i - mean(y))^2}, which cannot be recovered once \code{y} is out of scope.}
\item{group_ids}{Optional vector of group identifiers for grouped summaries
(reserved; not yet implemented).}
@@ -79,6 +102,23 @@ predictive densities from the training fit.
\code{elpd_test} is computed from \code{ylp_test} on the holdout
observations only.
}
+\section{\code{measure_info} attribute}{
+
+All \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results include attribute
+\code{measure_info}: a named list, keyed by bare measure name, recording what
+\code{\link[=model_compare]{model_compare()}} needs to know about each measure — \code{loss} (whether lower
+values are better), \code{diff_method} (how the standard error of a difference is
+obtained), and, where applicable, \code{se_diff_fun} and \code{extra}. When measures
+are added incrementally with \code{\link[=pred_measure]{pred_measure()}}, the attribute is extended for
+the newly computed measures.
+
+Built-in measures take \code{loss}, \code{diff_method}, and \code{se_diff_fun} from the
+package measure registry. Custom measures always get \code{diff_method = "custom"}
+and take \code{loss} and \code{se_diff_fun} from \code{\link[=custom_measure]{custom_measure()}}. Without
+\code{loss = TRUE} a custom measure is treated as a utility, so an undeclared
+loss is compared and ranked in the wrong direction. See \link{loo-glossary}.
+}
+
\examples{
\donttest{
if (requireNamespace("brms", quietly = TRUE)) {
diff --git a/man/waic.Rd b/man/waic.Rd
index 345bd638..101b7462 100644
--- a/man/waic.Rd
+++ b/man/waic.Rd
@@ -135,6 +135,7 @@ Pareto smoothed importance sampling. \emph{Journal of Machine Learning Research}
\item The \strong{loo} package \href{https://mc-stan.org/loo/articles/}{vignettes} and
Vehtari, Gelman, and Gabry (2017) and Vehtari, Simpson, Gelman, Yao,
and Gabry (2024) for more details on why we prefer \code{loo()} to \code{waic()}.
-\item \code{\link[=loo_compare]{loo_compare()}} for comparing models on approximate LOO-CV or WAIC.
+\item \code{\link[=loo_compare]{loo_compare()}} and \code{\link[=model_compare]{model_compare()}} for comparing models on approximate
+LOO-CV or WAIC.
}
}
diff --git a/notes/design-discussions/model_compare.md b/notes/design-discussions/model_compare.md
new file mode 100644
index 00000000..166ca71c
--- /dev/null
+++ b/notes/design-discussions/model_compare.md
@@ -0,0 +1,160 @@
+# Design discussion (`model_compare`)
+
+> **Participants:** Florence Bockting, Jonah Gabry
+>
+> **Last update:** 2026-09-28
+
+## Design of the `rank_by` argument
+
+**Scope**
+
+- accepting both **model name** and **measure name** might be confusing
+- `rank_by` might be most reasonable for **measure name**
+- perhaps we want to have two arguments:
+ - `rank_by` = measure name
+ - `reference` = model name
+
+**Behavior**
+
+- Currently:
+ - Best model is always in the first row; followed by second-best, etc.
+ - If reference model is not the "best" model then this will look as follows (reference = m3):
+ ```r
+ #> -- rmse (vs m3) --
+ #> model rmse_diff rmse_se_diff
+ #> m2 0.6 2.1
+ #> m3 0.0 0.0
+ #> m1 -5.5 4.0
+ ```
+
+After discussing this aspect, we realized that it makes a lot of things very complex (what should be the rule for ordering the rows? What does it mean to rank by a measure?, etc.)
+We were also not sure in how far users might really have use cases where they want to
+order according to a specific model or measure. Therefore we decided to remove
+the `rank_by` argument initially. If users say they would like to have such an
+argument we can add it later.
+
+## Sign flipping of losses
+
+> I think it would be helpful to include the sign flipping message a bit more prominently e.g. (-- mse (vs m2) — utility scale, higher is better --) . Right now only model_compare() prints the explanation so I think printing a saved comparison object later loses that info.
+
+Sounds like a good idea. However, providing this information only for losses might look confusing as also utilities are on a "utility scale" but there we would not show the information. Might be obvious for users that know the difference between utility and loss but less clear otherwise.
+
+The following output-snippet shows the behavior of the current proposed
+messaging.
+
+```r
+# -- elpd (vs m2) --
+# model elpd_diff se_diff p_worse diag_diff
+# m2 0.00 0.00 NA
+# m3 -25.47 129.10 0.58
+# m1 -850.29 372.31 0.99
+
+# -- r2 (vs m2) --
+# model r2_diff r2_se_diff
+# m2 0.00 0.00
+# m3 -0.09 0.18
+# m1 -0.10 0.22
+
+# -- mae (vs m3, sign flipped) --
+# model mae_diff mae_se_diff
+# m3 0.00 0.00
+# m2 -0.07 1.24
+# m1 -6.34 3.08
+
+# All differences: 0 = best model, negative = worse.
+# Signs flipped for loss measures: mae.
+```
+
+## Custom measures (incl. difference SE estimate)
+
+> measure_name and measure_loss are attributes of the measure function, but the SE method is an argument to model_compare(). I think (although I could be wrong), that means that if a package author wants to include a custom measure in their package, users would have to remember to set custom_se_fn themselves. In other words, it can’t be fully self contained the way it’s currently designed. Is that right, or am I wrong about this? Should we instead use attr(fn, "measure_se_diff") and allow the custom_se_fn to override it?
+
+Thank you for pointing this out. This is indeed a flaw in the design.
+I refactored the design such that a custom measure can have now the attribute
+`measure_se_diff`. Furthermore, I added an exported wrapper `custom_measure(fun, name, se_diff_fun = NULL, loss = FALSE)` which sets the three attributes `measure_name`, `measure_loss`, and `measure_se_diff`.
+
+With the declaration in place, the `custom_se_fn` argument of `model_compare()`
+was redundant, so it is removed. For a custom measure that declares
+nothing, `model_compare()` reports the difference with an `NA` standard error
+and a message.
+
+```r
+huber_fn <- function(y, mupred) {
+ delta <- 10
+ r <- y - colMeans(mupred)
+ l <- ifelse(abs(r) <= delta, 0.5 * r^2, delta * (abs(r) - 0.5 * delta))
+ list(estimate = mean(l), se = sd(l) / sqrt(length(l)), pointwise = l)
+}
+
+huber_se_fn <- function(ref, cmp) {
+ d <- cmp$pointwise - ref$pointwise
+ sd(d) / sqrt(length(d))
+}
+
+huber_measure <- custom_measure(
+ fun = huber_fn,
+ name = "huber",
+ se_diff_fun = huber_se_fn,
+ loss = TRUE
+)
+
+h1 <- fit_measure(fit_m1, measure = list("rmse", huber_measure))
+h3 <- fit_measure(fit_m3, measure = list("rmse", huber_measure))
+
+comp_h <- model_compare(list(m3 = h3, m1 = h1))
+```
+
+## Using `model_compare` with `kfold`
+
+> I think the brms kfold example has a mistake. It uses brms::kfold(fit, K = 5) separately for each model but I think that means they’re using different folds, which means se_diff is wrong? I think we need to do something like this: folds <- loo::kfold_split_random(K = 5, N = nrow(roaches)) and then pass that to kfold.
+
+Yes, indeed. I changed the corresponding cell in the notebook and added a warning (`throw_kfold_folds_mismatch_warning`) when folds are not equal.
+
+## The helper `add_loo()`
+
+> The add_loo() helper is using moment_match = TRUE and r_eff (since brms does). But loo_pred_measure doesn’t. So the displayed loo_compare and model_compare results don’t actually match for loo objects.
+
+Yes, that's actually a tricky one.
+Currently, we accept for `loo_pred_measure` three input schemes:
+
++ `loo`: able to reproduce loo_moment_match results
++ `ylp` + `psis_object`: the weights are the moment-matched, so it would work for measures where we only use the weights; but for `elpd` is does not work, as it is recomputed from `ylp`
++ `ylp`: nothing from the moment-matching reaches the computation of measures
+
+So, the question is how we want to handle this and pass the diagnostic information to pred_measure
+
+## Printing
+### Diagnostic flags
+
+> Some of the print output says Diagnostic flags present but doesn’t actually show any diagnostic flags in the output
+
+I assume you refer here to the missing p_worse and diag_diff column for measures that are not elpd.
+
+The reason is that I was not sure where the normal approximation is reasonable for these measures as well. We want indeed to include the diagnostic columns here as well but we have to check first whether the normal approximation and thus the diagnostics are valid for all other measures.
+
+I updated the printing method such that the message "diagnostic flags present" is only printed when `elpd` is present.
+
+### Number of digits per measure
+
+> I think the default number of digits to display is tricky. We might need different defaults per measure or use significant digits or something? I’m not sure, but I think it’s going to be annoying/confusing for users. Especially for constrained measures like R2, acc, brier, etc.
+
+Yes, I agree. I updated the digits rule and set different default formatting for the measures:
+
++ 1 digit: elpd, ic
++ 3 digits: mlpd, r2, acc, bacc, brier
++ dependent on SE: mae, rmse, mse, rps, srps, custom_measure
+
+```
+before after
+ model r2_diff model r2_diff r2_se_diff
+ m2 0.0 m2 0.000 0.000
+ m3 -0.1 m3 -0.093 0.178
+ m1 -0.1 m1 -0.105 0.217
+```
+
+## Improving vignette
+
+> There’s a ton of explanation about the computation but not really very much explanation about how to interpret the results
+> We already have this problem in the pre-existing loo vignette I think, but it occurs to me that the example has many bad K values, which means we don’t even recommend trusting it! I wonder how big of a problem it is for a tutorial vignette? Not sure
+
+Is a TODO and refers to [Issue #401](https://github.com/stan-dev/loo/issues/401)
\ No newline at end of file
diff --git a/notes/developer-notes.Rmd b/notes/developer-notes.Rmd
index ae190ae4..6c684061 100644
--- a/notes/developer-notes.Rmd
+++ b/notes/developer-notes.Rmd
@@ -20,10 +20,10 @@ knitr::opts_chunk$set(
> **Status:** In Progress
> **Base branch:** `loo-v3.0.0`
-> **Compare branch:** `pred_measure`
+> **Compare branch:** `pred_measure` (+ `integrate-loo_compare`)
> **Related PR:** [#363](https://github.com/stan-dev/loo/pull/363)
> **Contributors:** @florence-bockting, @avehtari, @VisruthSK, @jgabry
-> **Last updated:** 2026-07-03
+> **Last updated:** 2026-07-07
These notes document internal design decisions and ongoing work for the
`pred_measure` feature. This PR **adds** the new API.
@@ -37,7 +37,7 @@ These notes document internal design decisions and ongoing work for the
| Scoring rules (`measure_rps`) | Done |
| Documentation | In progress |
| `group_ids` grouping | Not started |
-| `loo_compare` integration | Not started |
+| `loo_compare` integration | Done (`integrate-loo_compare`) |
## Scope of this PR (`pred_measure` vs `loo-v3.0.0`)
@@ -52,6 +52,7 @@ These notes document internal design decisions and ongoing work for the
- `vignettes/migration-guide.Rmd`
- Website-only articles: `overview-measures.Rmd`, `pred-measure-workflow.Rmd`
- Test suite + pre-fitted fixtures + `test_data_generation.R`
+- `loo_compare()` multi-measure path for `loo_pred_measure` objects
### Changed on existing code (implementations retained)
@@ -61,6 +62,9 @@ These notes document internal design decisions and ongoing work for the
- `elpd()` — refactored to `.elpd_matrix_impl()` to avoid double deprecation
warnings
- Minor doc cross-references in `compare.R`, `psislw.R`
+- `loo_compare()` — extended for `loo_pred_measure` objects: `rank_by`, multi-measure
+ paired diffs, updated `print.compare.loo(measures = ...)`; classic `loo` path unchanged
+- `R/loo-glossary.R` — multi-measure comparison columns (`{measure}_diff`, `rank_by`, etc.)
- `NEWS.md`, `NAMESPACE`, `_pkgdown.yml`, pkgdown CI workflow
## Design decisions (resolved)
@@ -111,15 +115,41 @@ Design choices **internal to `pred_measure`**:
- [ ] Verify `kfold_pred_measure()` with categorical/multinomial examples
end-to-end (penguins fixture exists; confirm test/doc coverage)
+### D4: `loo_compare()` for `loo_pred_measure` objects
+
+**Decision:** Extend existing `loo_compare()`, not a separate function.
+
+- When all inputs are `loo_pred_measure` objects, compute paired differences for
+ every measure common to all models
+- Rank models by `rank_by` (default `"elpd"`); top-ranked model is the reference
+ for all `{measure}_diff` columns
+- ELPD-family measures keep `elpd_diff` / `se_diff`; other measures use
+ `{measure}_diff` / `{measure}_se_diff`
+- `p_worse` and `diag_diff` apply to ELPD only; `diag_elpd` per model as before
+- Loss measures (MSE, RMSE, MAE, IC) compared on a utility scale (negated) so
+ worse models have negative diffs, consistent with ELPD
+- Pointwise SEs use the same paired formula as ELPD when the overall estimate is
+ a sum or mean of pointwise contributions; otherwise `{measure}_se_diff` is `NA`
+ (e.g. `r2`, `mse`, `rmse`)
+- Reuse `elpd_diffs`, `se_elpd_diff`, `diag_diff`, `diag_elpd`, and many-model
+ order-statistic check (with `rank_by` when applicable)
+- `print.compare.loo(measures = ...)` shows one or all measure diff tables
+
+Implemented on branch `integrate-loo_compare`; tests in `test_compare.R` with
+fixture `test_data_roaches_compare.Rds`.
+
## Open decisions
### D1: Sign convention for pointwise estimates
- **Context:** Measures differ in orientation (`rps`: lower is better;
`srps`: higher is better). Aligning orientations may help comparisons.
-- **Options:** `lower_is_better`, `orientation = "utility" / "loss"`,
- `higher_is_better` (per-measure orientation control on `measure_*()` functions)
-- **Decision:** *pending*
+- **Decision:** *resolved.* Values are always stored on the measure's own
+ scale. A single `loss` flag (`.measure_spec` for built-ins,
+ `attr(fun, "measure_loss")` for custom measures) records the orientation, and
+ `model_compare()` converts to a common utility scale when reporting
+ differences. The per-call `higher_is_better` control has been removed: it only
+ changed the sign of stored values, and comparisons were invariant to it.
### D3: Handling of `r_eff`
@@ -127,6 +157,103 @@ Design choices **internal to `pred_measure`**:
- **Question:** How should `r_eff` be handled in `pred_measure` workflows?
- **Decision:** *pending*
+### D5: Weighted `E|X − X'|` — why the derivation in `crps_pwm.pdf` is not used
+
+- **Decision:** *resolved.* `.exx_pwm()` (`R/pred_measure-helpers.R`) estimates
+ `E|X − X'|` with the bias-corrected weighted Gini mean difference
+
+ ``` r
+ EXX = sum_{i != j} w_i w_j |x_i - x_j| / (1 - sum_i w_i^2)
+ ```
+
+ computed on sorted draws as `2 * sum(w_s * x_s * (2 * C_s - w_s - 1)) / (1 - sum(w^2))`,
+ with `C_s = sum_{k <= s} w_k`. At equal weights this is exactly the unbiased
+ PWM estimator of Taillardat et al. (2016) with the `1 / (S (S - 1))`
+ normalization, so the weighted and unweighted paths agree.
+
+- **Why not `notes/crps_pwm.pdf` (section 0.3).** The note derives a weighted
+ estimator from `E|X − X'| = 2 (E[X] − E[X_{1,1:2}])`, taking the probability
+ that the `s`-th order statistic is the smaller of a random pair to be
+ `2 * w_s * (1 - C_s) / (1 - w_s)`, where the factor 2 is said to handle order
+ invariance. Under weighted sampling *without replacement* the two orderings do
+ not have the same probability:
+
+ ```
+ P(x_s is the pair minimum) = w_s (1 - C_s) / (1 - w_s) # x_s drawn first
+ + sum_{k > s} w_k w_s / (1 - w_k) # x_s drawn second
+ ```
+
+ The two lines coincide only when all weights are equal — which is why the
+ note's section 0.2 (unweighted) is exact and section 0.3 is not. Doubling the
+ first line overweights draws that are both heavy and small, and the implied
+ coefficients no longer sum to zero. `EXX` is then neither shift invariant nor
+ guaranteed non-negative, and `measure_srps()` takes `log()` of a negative
+ number. (Deriving the exact pair probabilities is not a small fix: they are
+ the second-order inclusion probabilities of PPS sampling without replacement,
+ which do not factorize in general.)
+
+ Measured on a toy sample of `S = 10` standard normal draws with weights
+ `(0.02, ..., 0.02, 0.82)`, and on the roaches fixture
+ (`tests/testthat/data-for-tests/test_data_roaches.Rds`, 262 obs × 400 draws):
+
+ | case | note (0.3) | implemented |
+ |---|---|---|
+ | toy `EXX` | 2.647 | 1.547 |
+ | toy `EXX`, draws shifted by +100 | 136.525 | 1.547 |
+ | roaches obs 230 (max weight 0.833) | −44.67 → `NaN` in `srps` | 6.53 |
+ | roaches obs 16 (max weight 0.778) | 392.25 | 22.97 |
+
+ The note's coefficients sum to 1.339 rather than 0 in the toy case. The
+ unweighted path is unaffected — there the note is exact and agrees with the
+ implementation to machine precision.
+
+- **Independent backing (ArviZ).** `arviz-stats` implements the same weighted
+ PWM score in the same PSIS-LOO setting, in
+ [`_loo_score()`](https://github.com/arviz-devs/arviz-stats/blob/main/src/arviz_stats/base/diagnostics.py):
+
+ ``` python
+ f_minus = cumulative_weights - weights_sorted
+ bracket = 2.0 * f_minus + weights_sorted - 1.0
+ gini_mean_difference = 2.0 * np.sum(weights_sorted * values_sorted * bracket)
+ ```
+
+ This is our numerator exactly (`2 * C_s - w_s - 1 = 2 * f_minus + w_s - 1`),
+ and it carries no `1 / (1 - w_s)` factor — i.e. ArviZ independently arrived at
+ the weighted Gini mean difference rather than at the note's estimator. The
+ same double-sum form is the standard survey-weighted Gini estimator,
+ `sum_k sum_l w_k w_l |y_k - y_l| / (2 N̂ Ŷ)`.
+
+- **Why we keep the `1 / (1 - sum w^2)` correction that ArviZ omits.** ArviZ
+ computes the plug-in version; ours divides by `1 - sum_i w_i^2 = 1 - 1/S_eff`,
+ the standard reliability-weights bias correction (the weighted-variance
+ analogue), which at equal weights is the `(S - 1) / S` "fair score" correction
+ of Ferro (2014) discussed by Zamo & Naveau (2018). Two reasons:
+
+ 1. **The bias is per observation, not a constant.** With equal weights the
+ plug-in is low by a fixed `(S - 1) / S`, which cancels everywhere. With PSIS
+ weights the factor is `1 - 1/S_eff`, and on the roaches fixture `S_eff`
+ ranges from 400 (median 368, factor 0.9973) down to 1.4 (factor 0.2973).
+ 27 of 262 observations differ by more than 1%, and in `srps` the omitted
+ correction lands as an additive per-observation shift in `-0.5 * log(EXX)`
+ of up to 0.61 — largest exactly where the importance weights are already
+ concentrated.
+ 2. **Consistency with the unweighted path.** `measure_rps()` uses the unbiased
+ PWM estimator when `log_weights` is `NULL`. Without the correction, uniform
+ `log_weights` would no longer reproduce that result (off by `(S - 1) / S`);
+ the test *"uniform log-weights reproduce the unweighted measure_rps()"*
+ asserts that they do.
+
+ Adopting ArviZ's plug-in form would therefore mean changing the unweighted
+ path as well, which changes published `measure_rps()` output and drops the
+ fair-score correction that `crps()`'s own references argue for.
+
+- **Follow-up:** report the section 0.3 issue to the author of
+ `notes/crps_pwm.pdf`; the note's unweighted result stands, only the weighted
+ generalization needs revising. Note also that the printed code for
+ `EXX_compute_pwm()` in section 0.4 has a typo (`- 2` should be
+ `- 2 * (S + 1) / (S - 1)`); it disagrees with the note's own formula and is
+ not shift invariant. `.exx_pwm()` follows the formula, not that snippet.
+
## Tasks
### Refactoring (within new API)
@@ -138,7 +265,7 @@ Design choices **internal to `pred_measure`**:
- [x] In `*_pred_measure()`, compute `elpd` as base when `ylp` supplied;
require explicit `measure = "ic"` for information criterion
- [x] Document and test deprecated vs new API comparisons *(see appendix)*
-- [ ] Provide an interface to `loo_compare` and verify consistency
+- [x] Provide an interface to `loo_compare` and verify consistency
- [ ] Resolve `r_eff` handling *(see D3)*
### Implementation
@@ -156,7 +283,8 @@ Design choices **internal to `pred_measure`**:
- [x] Online-only articles published via `_pkgdown.yml`
- [ ] Formula derivations article (`pred_measure-formulas.Rmd`)
- [ ] Detailed per-measure descriptions (derivations where appropriate)
-- [ ] Extend glossary (`R/loo-glossary.R`) — measure, metric, score, utility, loss
+- [x] Extend glossary (`R/loo-glossary.R`) — multi-measure `loo_compare` columns
+- [ ] Extend glossary further — measure, metric, score, utility, loss (general terms)
### Grouping via `group_ids`
@@ -170,8 +298,8 @@ Design choices **internal to `pred_measure`**:
- Rename `ic` → `information_criteria` for clarity?
- Should `measure_elpd()` also return `ic`, or keep them separate?
-- What defines class `"loo"` on measure objects? (e.g. deprecated `elpd_generic`
- inherits `"loo"`)
+- What defines class `"loo"` on measure objects? `loo_pred_measure` inherits `"loo"`
+ (see `integrate-loo_compare`); deprecated `elpd_generic` also inherits `"loo"`.
- Should `elpd` always be computed when `ylp` is supplied, or allow
`loo_pred_measure()` for non-ELPD measures only?
@@ -203,17 +331,18 @@ the same scoring rules but use different estimators.
| Deprecated | New workflow | Notes |
|------------|--------------|-------|
-| `crps(x, x2, y)` | `measure_rps(y, ypred = x, higher_is_better = FALSE)` | Loss-scale unscaled score |
+| `crps(x, x2, y)` | `-measure_rps(y, ypred = x)$pointwise` | `crps()` returns the negated unscaled score |
| `scrps(x, x2, y)` | `measure_srps(y, ypred = x)` | Same sign convention |
| `loo_crps(...)` | `loo_pred_measure(..., measure = "rps")` | Additional LOO weighting difference |
| `loo_scrps(...)` | `loo_pred_measure(..., measure = "srps")` | Additional LOO weighting difference |
#### Sources of numerical difference
-1. **Sign convention (unscaled only).** `crps()` returns `0.5·EXX − EXy` (utility:
- higher is better). Default `measure_rps()` negates this; use
- `higher_is_better = FALSE` to match `crps()`. Scaled scores (`scrps` / `measure_srps`)
- already share the formula `−EXy/EXX − 0.5·log(EXX)`.
+1. **Sign convention (unscaled only).** `measure_rps()` returns `EXy − 0.5·EXX`,
+ the Gneiting & Raftery (2007) loss (lower is better); `crps()` returns its
+ negation `0.5·EXX − EXy`. Negate `measure_rps()` to match `crps()`. Scaled
+ scores (`scrps` / `measure_srps`) already share the formula
+ `−EXy/EXX − 0.5·log(EXX)` and are utilities.
2. **EXX estimator (in-sample).** Both estimate `E|X − X'|`, but:
- **Deprecated:** two draw matrices `x`, `x2`; one random shuffle per
@@ -228,6 +357,9 @@ the same scoring rules but use different estimators.
uses weighted PWM on a single `ypred` with PSIS weights from `ylp` only — so
LOO differences combine EXX method and importance-weighting approach.
+ For why the weighted PWM estimator does not follow section 0.3 of
+ `notes/crps_pwm.pdf`, see D5 in *Open decisions*.
+
#### Key results (reference simulation)
@@ -273,7 +405,9 @@ EXX_perm <- colMeans(abs(x1 - x2[sample(S), , drop = FALSE]))
EXX_pwm <- .exx_pwm(x1)
old_crps <- suppressWarnings(crps(x1, x2, y))
-new_rps <- measure_rps(y, x1, higher_is_better = FALSE)
+# `crps()` is the negated unscaled score, so align signs here
+new_rps <- measure_rps(y, x1)
+new_rps$pointwise <- -new_rps$pointwise
old_scrps <- suppressWarnings(scrps(x1, x2, y))
new_srps <- measure_srps(y, x1)
@@ -355,7 +489,7 @@ invisible(dev.off())
*Figure: 200 simulations (S = 100, n = 30). Left — `crps()` vs
-`measure_rps(higher_is_better = FALSE)`; right — `scrps()` vs `measure_srps()`.*
+`-measure_rps()`; right — `scrps()` vs `measure_srps()`.*
```{r crps-rps-outcomes-figure, fig.show = "hide"}
n_repl <- 200L
@@ -369,11 +503,12 @@ for (i in seq_len(n_repl)) {
x1 <- matrix(rnorm(n_obs * n_draws), nrow = n_draws)
x2 <- matrix(rnorm(n_obs * n_draws), nrow = n_draws)
old <- suppressWarnings(crps(x1, x2, y))
- new <- measure_rps(y, x1, higher_is_better = FALSE)
+ new <- measure_rps(y, x1)
old_s <- suppressWarnings(scrps(x1, x2, y))
new_s <- measure_srps(y, x1)
crps_old[i] <- old$estimates["Estimate"]
- rps_new[i] <- new$estimates[1, "Estimate"]
+ # `crps()` is the negated unscaled score, so align signs here
+ rps_new[i] <- -new$estimates[1, "Estimate"]
scrps_old[i] <- old_s$estimates["Estimate"]
srps_new[i] <- new_s$estimates[1, "Estimate"]
}
@@ -383,7 +518,7 @@ par(mfrow = c(1, 2), mar = c(4, 4, 2.5, 1))
.outcome_panel(
crps_old, rps_new,
xlab = "crps() estimate",
- ylab = "measure_rps(higher_is_better = FALSE)",
+ ylab = "-measure_rps()",
main = "Unscaled (CRPS / RPS)"
)
.outcome_panel(
diff --git a/notes/developer-notes.md b/notes/developer-notes.md
index 0dd96f5c..60df3325 100644
--- a/notes/developer-notes.md
+++ b/notes/developer-notes.md
@@ -14,10 +14,10 @@ Developer Notes: `pred_measure` Feature
> **Status:** In Progress
> **Base branch:** `loo-v3.0.0`
-> **Compare branch:** `add-pred-measure`
+> **Compare branch:** `pred_measure` (+ `integrate-loo_compare`)
> **Related PR:** [\#363](https://github.com/stan-dev/loo/pull/363)
> **Contributors:** @florence-bockting, @avehtari, @VisruthSK, @jgabry
-> **Last updated:** 2026-07-03
+> **Last updated:** 2026-07-07
These notes document internal design decisions and ongoing work for the
`pred_measure` feature. This PR **adds** the new API on top of
@@ -39,7 +39,7 @@ For the merge summary, see the PR description
| Scoring rules (`measure_rps`) | Done |
| Documentation | In progress |
| `group_ids` grouping | Not started |
-| `loo_compare` integration | Not started |
+| `loo_compare` integration | Done (`integrate-loo_compare`) |
------------------------------------------------------------------------
@@ -48,7 +48,8 @@ For the merge summary, see the PR description
### Added (did not exist on `loo-v3.0.0`)
- `R/pred_measure.R` — `insample_pred_measure()`, `loo_pred_measure()`,
- `kfold_pred_measure()`, `test_pred_measure()`, `pred_measure()`
+ `kfold_pred_measure()`, `test_pred_measure()`, `pred_measure()`,
+ `custom_measure()`
- `R/pred_measure-compute.R`, `R/pred_measure-helpers.R`,
`R/pred_measure-builtin.R` — orchestration and `measure_*()`
implementations
@@ -59,6 +60,8 @@ For the merge summary, see the PR description
- Website-only articles: `overview-measures.Rmd`,
`pred-measure-workflow.Rmd`
- Test suite + pre-fitted fixtures + `test_data_generation.R`
+- `loo_compare()` multi-measure path for `loo_pred_measure` objects
+ (`integrate-loo_compare`)
### Changed on existing code (implementations retained)
@@ -69,6 +72,11 @@ For the merge summary, see the PR description
- `elpd()` — refactored to `.elpd_matrix_impl()` to avoid double
deprecation warnings
- Minor doc cross-references in `compare.R`, `psislw.R`
+- `loo_compare()` — extended for `loo_pred_measure` objects: `rank_by`,
+ multi-measure paired diffs, updated `print.compare.loo(measures = ...)`;
+ classic `loo` path unchanged
+- `R/loo-glossary.R` — multi-measure comparison columns (`{measure}_diff`,
+ `rank_by`, etc.)
- `NEWS.md`, `NAMESPACE`, `_pkgdown.yml`, pkgdown CI workflow
------------------------------------------------------------------------
@@ -127,17 +135,53 @@ Design choices **internal to `pred_measure`** (not a migration from
examples end-to-end (penguins fixture exists; confirm test/doc
coverage)
+### D4: `loo_compare()` for `loo_pred_measure` objects
+
+**Decision:** Extend existing `loo_compare()`
+
+- When all inputs are `loo_pred_measure` objects, compute paired
+ differences for every measure common to all models
+- Rank models by `rank_by` (default `"elpd"`); top-ranked model is the
+ reference for all `{measure}_diff` columns
+- ELPD-family measures keep `elpd_diff` / `se_diff`; other measures use
+ `{measure}_diff` / `{measure}_se_diff`
+- `p_worse` and `diag_diff` apply to ELPD only; `diag_elpd` per model as
+ before
+- Loss measures (MSE, RMSE, MAE, IC, Brier score, RPS) compared on a common
+ utility scale (higher is better): sign flipped from the raw loss orientation
+ so worse models have negative diffs, consistent with ELPD. Orientation is
+ read from the `loss` element of `measure_info` on each
+ `*_pred_measure()` result; attribute `sign_converted_measures` records
+ affected measures. A short message is emitted at compare time; full
+ interpretation is in `?loo_compare` / `?loo-glossary`.
+- Pointwise SEs use the same paired formula as ELPD when the overall
+ estimate is a sum or mean of pointwise contributions; otherwise
+ `{measure}_se_diff` is `NA` (e.g. `r2`, `mse`, `rmse`)
+- Reuse `elpd_diffs`, `se_elpd_diff`, `diag_diff`, `diag_elpd`, and
+ many-model order-statistic check (with `rank_by` when applicable)
+- `print.compare.loo(measures = ...)` shows one or all measure diff tables
+
+Implemented on branch `integrate-loo_compare`; tests in `test_compare.R`
+with fixture `test_data_roaches_compare.Rds`.
+
------------------------------------------------------------------------
## Open decisions
### D1: Sign convention for pointwise estimates
-- **Context:** Measures differ in orientation (`rps`: lower is better;
- `srps`: higher is better). Aligning orientations may help comparisons.
-- **Options:** `lower_is_better`, `orientation = "utility" / "loss"`,
- `revert_sign` (currently internal on some `measure_*()` functions)
-- **Decision:** *pending*
+- **Context:** Measures differ in orientation (e.g. ELPD/CRPS on a utility
+ scale; MSE and Brier score as losses). `loo_compare()` aligns them for
+ paired differences.
+- **Decision:** Values are always stored on the measure's own scale. A single
+ `loss` flag records the orientation --- `.measure_spec` for built-ins,
+ `attr(fun, "measure_loss")` for custom measures, set by
+ `custom_measure(loss = )` --- and is recorded per
+ measure in the `measure_info` attribute of each `*_pred_measure()` result.
+ `model_compare()` sign-flips measures with `loss = TRUE` for utility-scale
+ `{measure}_diff`. The per-call `higher_is_better` control has been removed:
+ it only changed the sign of stored values, and comparisons were invariant
+ to it.
### D3: Handling of `r_eff`
@@ -147,6 +191,103 @@ Design choices **internal to `pred_measure`** (not a migration from
workflows?
- **Decision:** *pending*
+### D5: Weighted `E|X − X'|` — why the derivation in `crps_pwm.pdf` is not used
+
+- **Decision:** *resolved.* `.exx_pwm()` (`R/pred_measure-helpers.R`) estimates
+ `E|X − X'|` with the bias-corrected weighted Gini mean difference
+
+ ``` r
+ EXX = sum_{i != j} w_i w_j |x_i - x_j| / (1 - sum_i w_i^2)
+ ```
+
+ computed on sorted draws as `2 * sum(w_s * x_s * (2 * C_s - w_s - 1)) / (1 - sum(w^2))`,
+ with `C_s = sum_{k <= s} w_k`. At equal weights this is exactly the unbiased
+ PWM estimator of Taillardat et al. (2016) with the `1 / (S (S - 1))`
+ normalization, so the weighted and unweighted paths agree.
+
+- **Why not `notes/crps_pwm.pdf` (section 0.3).** The note derives a weighted
+ estimator from `E|X − X'| = 2 (E[X] − E[X_{1,1:2}])`, taking the probability
+ that the `s`-th order statistic is the smaller of a random pair to be
+ `2 * w_s * (1 - C_s) / (1 - w_s)`, where the factor 2 is said to handle order
+ invariance. Under weighted sampling *without replacement* the two orderings do
+ not have the same probability:
+
+ ```
+ P(x_s is the pair minimum) = w_s (1 - C_s) / (1 - w_s) # x_s drawn first
+ + sum_{k > s} w_k w_s / (1 - w_k) # x_s drawn second
+ ```
+
+ The two lines coincide only when all weights are equal — which is why the
+ note's section 0.2 (unweighted) is exact and section 0.3 is not. Doubling the
+ first line overweights draws that are both heavy and small, and the implied
+ coefficients no longer sum to zero. `EXX` is then neither shift invariant nor
+ guaranteed non-negative, and `measure_srps()` takes `log()` of a negative
+ number. (Deriving the exact pair probabilities is not a small fix: they are
+ the second-order inclusion probabilities of PPS sampling without replacement,
+ which do not factorize in general.)
+
+ Measured on a toy sample of `S = 10` standard normal draws with weights
+ `(0.02, ..., 0.02, 0.82)`, and on the roaches fixture
+ (`tests/testthat/data-for-tests/test_data_roaches.Rds`, 262 obs × 400 draws):
+
+ | case | note (0.3) | implemented |
+ |---|---|---|
+ | toy `EXX` | 2.647 | 1.547 |
+ | toy `EXX`, draws shifted by +100 | 136.525 | 1.547 |
+ | roaches obs 230 (max weight 0.833) | −44.67 → `NaN` in `srps` | 6.53 |
+ | roaches obs 16 (max weight 0.778) | 392.25 | 22.97 |
+
+ The note's coefficients sum to 1.339 rather than 0 in the toy case. The
+ unweighted path is unaffected — there the note is exact and agrees with the
+ implementation to machine precision.
+
+- **Independent backing (ArviZ).** `arviz-stats` implements the same weighted
+ PWM score in the same PSIS-LOO setting, in
+ [`_loo_score()`](https://github.com/arviz-devs/arviz-stats/blob/main/src/arviz_stats/base/diagnostics.py):
+
+ ``` python
+ f_minus = cumulative_weights - weights_sorted
+ bracket = 2.0 * f_minus + weights_sorted - 1.0
+ gini_mean_difference = 2.0 * np.sum(weights_sorted * values_sorted * bracket)
+ ```
+
+ This is our numerator exactly (`2 * C_s - w_s - 1 = 2 * f_minus + w_s - 1`),
+ and it carries no `1 / (1 - w_s)` factor — i.e. ArviZ independently arrived at
+ the weighted Gini mean difference rather than at the note's estimator. The
+ same double-sum form is the standard survey-weighted Gini estimator,
+ `sum_k sum_l w_k w_l |y_k - y_l| / (2 N̂ Ŷ)`.
+
+- **Why we keep the `1 / (1 - sum w^2)` correction that ArviZ omits.** ArviZ
+ computes the plug-in version; ours divides by `1 - sum_i w_i^2 = 1 - 1/S_eff`,
+ the standard reliability-weights bias correction (the weighted-variance
+ analogue), which at equal weights is the `(S - 1) / S` "fair score" correction
+ of Ferro (2014) discussed by Zamo & Naveau (2018). Two reasons:
+
+ 1. **The bias is per observation, not a constant.** With equal weights the
+ plug-in is low by a fixed `(S - 1) / S`, which cancels everywhere. With PSIS
+ weights the factor is `1 - 1/S_eff`, and on the roaches fixture `S_eff`
+ ranges from 400 (median 368, factor 0.9973) down to 1.4 (factor 0.2973).
+ 27 of 262 observations differ by more than 1%, and in `srps` the omitted
+ correction lands as an additive per-observation shift in `-0.5 * log(EXX)`
+ of up to 0.61 — largest exactly where the importance weights are already
+ concentrated.
+ 2. **Consistency with the unweighted path.** `measure_rps()` uses the unbiased
+ PWM estimator when `log_weights` is `NULL`. Without the correction, uniform
+ `log_weights` would no longer reproduce that result (off by `(S - 1) / S`);
+ the test *"uniform log-weights reproduce the unweighted measure_rps()"*
+ asserts that they do.
+
+ Adopting ArviZ's plug-in form would therefore mean changing the unweighted
+ path as well, which changes published `measure_rps()` output and drops the
+ fair-score correction that `crps()`'s own references argue for.
+
+- **Follow-up:** report the section 0.3 issue to the author of
+ `notes/crps_pwm.pdf`; the note's unweighted result stands, only the weighted
+ generalization needs revising. Note also that the printed code for
+ `EXX_compute_pwm()` in section 0.4 has a typo (`- 2` should be
+ `- 2 * (S + 1) / (S - 1)`); it disagrees with the note's own formula and is
+ not shift invariant. `.exx_pwm()` follows the formula, not that snippet.
+
------------------------------------------------------------------------
## Tasks
@@ -163,7 +304,13 @@ Design choices **internal to `pred_measure`** (not a migration from
require explicit `measure = "ic"` for information criterion
- [x] Document and test deprecated vs new API comparisons *(see
appendix)*
-- [ ] Provide an interface to `loo_compare` and verify consistency
+- [x] Provide an interface to `loo_compare` and verify consistency
+- [ ] Decide whether the `loo_compare` S3 tree stays. `loo_compare.default`
+ (`R/loo_compare.R:34`) and `loo_compare.psis_loo_ss_list`
+ (`R/loo_compare.R:46`) are now two-line pass-throughs to their
+ `model_compare` counterparts, so the whole tree may be a thin back-compat
+ shim. Either keep it deliberately, as with `old_nms` / `convert_old_object()`,
+ or drop it as a set — not one method at a time.
- [ ] Resolve `r_eff` handling *(see D3)*
### Implementation
@@ -181,8 +328,9 @@ Design choices **internal to `pred_measure`** (not a migration from
- [x] Online-only articles published via `_pkgdown.yml`
- [ ] Formula derivations article (`pred_measure-formulas.Rmd`)
- [ ] Detailed per-measure descriptions (derivations where appropriate)
-- [ ] Extend glossary (`R/loo-glossary.R`) — measure, metric, score,
- utility, loss
+- [x] Extend glossary (`R/loo-glossary.R`) — multi-measure `loo_compare` columns
+- [ ] Extend glossary further — measure, metric, score, utility, loss
+ (general terms)
### Grouping via `group_ids`
@@ -200,8 +348,9 @@ Design choices **internal to `pred_measure`** (not a migration from
- Rename `ic` → `information_criteria` for clarity?
- Should `measure_elpd()` also return `ic`, or keep them separate?
-- What defines class `"loo"` on measure objects? (e.g. deprecated
- `elpd_generic` inherits `"loo"`)
+- What defines class `"loo"` on measure objects? `loo_pred_measure` inherits
+ `"loo"` (see `integrate-loo_compare`); deprecated `elpd_generic` also
+ inherits `"loo"`.
- Should `elpd` always be computed when `ylp` is supplied, or allow
`loo_pred_measure()` for non-ELPD measures only?
@@ -236,18 +385,18 @@ estimators.
| Deprecated | New workflow | Notes |
|-------------------|-------------------------------------------------|-------------------------------------|
-| `crps(x, x2, y)` | `measure_rps(y, ypred = x, revert_sign = TRUE)` | Sign flip on unscaled score |
+| `crps(x, x2, y)` | `-measure_rps(y, ypred = x)$pointwise` | `crps()` returns the negated unscaled score |
| `scrps(x, x2, y)` | `measure_srps(y, ypred = x)` | Same sign convention |
| `loo_crps(...)` | `loo_pred_measure(..., measure = "rps")` | Additional LOO weighting difference |
| `loo_scrps(...)` | `loo_pred_measure(..., measure = "srps")` | Additional LOO weighting difference |
#### Sources of numerical difference
-1. **Sign convention (unscaled only).** `crps()` returns
- `0.5·EXX − EXy` (utility: higher is better). Default `measure_rps()`
- negates this; use `revert_sign = TRUE` to match `crps()`. Scaled
- scores (`scrps` / `measure_srps`) already share the formula
- `−EXy/EXX − 0.5·log(EXX)`.
+1. **Sign convention (unscaled only).** `measure_rps()` returns
+ `EXy − 0.5·EXX`, the Gneiting & Raftery (2007) loss (lower is better);
+ `crps()` returns its negation `0.5·EXX − EXy`. Negate `measure_rps()`
+ to match `crps()`. Scaled scores (`scrps` / `measure_srps`) already
+ share the formula `−EXy/EXX − 0.5·log(EXX)` and are utilities.
2. **EXX estimator (in-sample).** Both estimate `E|X − X'|`, but:
@@ -265,6 +414,9 @@ estimators.
single `ypred` with PSIS weights from `ylp` only — so LOO
differences combine EXX method and importance-weighting approach.
+ For why the weighted PWM estimator does not follow section 0.3 of
+ `notes/crps_pwm.pdf`, see D5 in *Open decisions*.
+
#### Key results (reference simulation)
@@ -295,7 +447,7 @@ replications
*Figure: 200 simulations (S = 100, n = 30). Left — `crps()` vs
-`measure_rps(revert_sign = TRUE)`; right — `scrps()` vs
+`-measure_rps()`; right — `scrps()` vs
`measure_srps()`.*
#### LOO outcome comparison
@@ -344,3 +496,4 @@ replications
**ELPD/IC takeaway:** In-sample estimates match between deprecated and
new APIs. Migration is about return type and `*_pred_measure()` workflow
integration, not numerical differences.
+
diff --git a/notes/internal-notes.md b/notes/internal-notes.md
new file mode 100644
index 00000000..0bbea083
--- /dev/null
+++ b/notes/internal-notes.md
@@ -0,0 +1,22 @@
+loo_compare accepts as input the outputs of:
+- loo()
+- kfold()
+- waic()
+
+They all produce outputs that inherit the "loo" class.
+
+Deprectation
+============
+- remove "compare()" which is already deprecated for a while.
+- deprecate "loo_compare()"
+- introduce "model_compare()"
+
+New implementation
+==================
+model_compare(type = "kfold"/"loo"/"test"/"insample") -> consistent with _pred_measure
+
+
+
+Trivia
+======
+
diff --git a/tests/testthat/_snaps/compare.md b/tests/testthat/_snaps/compare.md
index c7b40534..1bb9939f 100644
--- a/tests/testthat/_snaps/compare.md
+++ b/tests/testthat/_snaps/compare.md
@@ -1,6 +1,265 @@
-# loo_compare returns expected results (2 models)
+# model_compare works with three loo_pred_measure models
- WAoAAAACAAQEAgACAwAAAAMTAAAADAAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v
+ Code
+ print(comp)
+ Output
+ Each measure compared against its own best model (elpd: B, mae: C, r2: B).
+ PSIS-LOO unreliable for all 3 models (k_psis > 0.5); measures may be biased.
+ model bad_k
+ B 6
+ C 4
+ A 4
+
+ model elpd_diff se_diff p_worse diag_diff
+ B 0.0 0.0 NA
+ C -22.4 129.6 0.57
+ A -841.5 373.2 0.99
+ Message
+
+ Diagnostic flags present.
+ See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)
+ or https://mc-stan.org/loo/reference/loo-glossary.html.
+
+ Use print(x, measures = "all") to see all measures.
+
+# print marks and explains flipped measure signs
+
+ Code
+ print(comp, measures = "all")
+ Output
+ Each measure compared against its own best model (mse: m2, r2: m2).
+ PSIS-LOO unreliable for both models (k_psis > 0.5); measures may be biased.
+ model bad_k
+ m2 6
+ m1 4
+
+ -- mse (vs m2, sign flipped) --
+ model mse_diff mse_se_diff
+ m2 0.0 0.0
+ m1 -199.6 460.2
+
+ -- r2 (vs m2) --
+ model r2_diff r2_se_diff
+ m2 0.000 0.000
+ m1 -0.098 0.223
+
+ All differences: 0 = best model, negative = worse.
+ Signs flipped for loss measures: mse.
+
+# print.compare.loo works for loo_pred_measure comparisons
+
+ Code
+ print(comp)
+ Output
+ Each measure compared against its own best model (elpd: m2, mae: m3, r2: m2).
+ PSIS-LOO unreliable for all 3 models (k_psis > 0.5); measures may be biased.
+ model bad_k
+ m2 6
+ m3 4
+ m1 4
+
+ model elpd_diff se_diff p_worse diag_diff
+ m2 0.0 0.0 NA
+ m3 -22.4 129.6 0.57
+ m1 -841.5 373.2 0.99
+ Message
+
+ Diagnostic flags present.
+ See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)
+ or https://mc-stan.org/loo/reference/loo-glossary.html.
+
+ Use print(x, measures = "all") to see all measures.
+
+---
+
+ Code
+ print(comp, measures = "all", digits = 2)
+ Output
+ Each measure compared against its own best model (elpd: m2, mae: m3, r2: m2).
+ PSIS-LOO unreliable for all 3 models (k_psis > 0.5); measures may be biased.
+ model bad_k
+ m2 6
+ m3 4
+ m1 4
+
+ -- elpd (vs m2) --
+ model elpd_diff se_diff p_worse diag_diff
+ m2 0.00 0.00 NA
+ m3 -22.44 129.62 0.57
+ m1 -841.47 373.24 0.99
+
+ -- mae (vs m3, sign flipped) --
+ model mae_diff mae_se_diff
+ m3 0.00 0.00
+ m2 -0.15 1.17
+ m1 -6.35 3.07
+
+ -- r2 (vs m2) --
+ model r2_diff r2_se_diff
+ m2 0.00 0.00
+ m3 -0.07 0.16
+ m1 -0.10 0.22
+
+ All differences: 0 = best model, negative = worse.
+ Signs flipped for loss measures: mae.
+ Message
+
+ Diagnostic flags present.
+ See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)
+ or https://mc-stan.org/loo/reference/loo-glossary.html.
+
+---
+
+ Code
+ print(comp, measures = "all", digits = c(r2 = 1))
+ Output
+ Each measure compared against its own best model (elpd: m2, mae: m3, r2: m2).
+ PSIS-LOO unreliable for all 3 models (k_psis > 0.5); measures may be biased.
+ model bad_k
+ m2 6
+ m3 4
+ m1 4
+
+ -- elpd (vs m2) --
+ model elpd_diff se_diff p_worse diag_diff
+ m2 0.0 0.0 NA
+ m3 -22.4 129.6 0.57
+ m1 -841.5 373.2 0.99
+
+ -- mae (vs m3, sign flipped) --
+ model mae_diff mae_se_diff
+ m3 0.0 0.0
+ m2 -0.2 1.2
+ m1 -6.3 3.1
+
+ -- r2 (vs m2) --
+ model r2_diff r2_se_diff
+ m2 0.0 0.0
+ m3 -0.1 0.2
+ m1 -0.1 0.2
+
+ All differences: 0 = best model, negative = worse.
+ Signs flipped for loss measures: mae.
+ Message
+
+ Diagnostic flags present.
+ See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)
+ or https://mc-stan.org/loo/reference/loo-glossary.html.
+
+---
+
+ Code
+ print(comp, measures = c("r2", "mae"))
+ Output
+ Each measure compared against its own best model (elpd: m2, mae: m3, r2: m2).
+ PSIS-LOO unreliable for all 3 models (k_psis > 0.5); measures may be biased.
+ model bad_k
+ m2 6
+ m3 4
+ m1 4
+
+ -- r2 (vs m2) --
+ model r2_diff r2_se_diff
+ m2 0.000 0.000
+ m3 -0.073 0.160
+ m1 -0.098 0.223
+
+ -- mae (vs m3, sign flipped) --
+ model mae_diff mae_se_diff
+ m3 0.0 0.0
+ m2 -0.2 1.2
+ m1 -6.3 3.1
+
+ All differences: 0 = best model, negative = worse.
+ Signs flipped for loss measures: mae.
+
+---
+
+ Code
+ print(comp, simplify = FALSE)
+ Output
+ Each measure compared against its own best model (elpd: m2, mae: m3, r2: m2).
+ PSIS-LOO unreliable for all 3 models (k_psis > 0.5); measures may be biased.
+ model bad_k
+ m2 6
+ m3 4
+ m1 4
+
+ model elpd_diff se_diff p_worse diag_diff elpd se_elpd p se_p mae
+ m2 0.0 0.0 NA -2074.2 469.5 67.9 22.5 22.0
+ m3 -22.4 129.6 0.57 -2096.7 438.5 89.9 41.0 21.9
+ m1 -841.5 373.2 0.99 -2915.7 448.1 68.8 19.5 28.2
+ se_mae r2 se_r2
+ 3.4 0.144 0.221
+ 3.6 0.071 0.290
+ 3.2 0.046 0.040
+ Message
+
+ Diagnostic flags present.
+ See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)
+ or https://mc-stan.org/loo/reference/loo-glossary.html.
+
+ Use print(x, measures = "all") to see all measures.
+
+---
+
+ Code
+ print(comp, measures = "all", simplify = FALSE)
+ Output
+ Each measure compared against its own best model (elpd: m2, mae: m3, r2: m2).
+ PSIS-LOO unreliable for all 3 models (k_psis > 0.5); measures may be biased.
+ model bad_k
+ m2 6
+ m3 4
+ m1 4
+
+ -- elpd (vs m2) --
+ model elpd_diff se_diff p_worse diag_diff elpd se_elpd p se_p
+ m2 0.0 0.0 NA -2074.2 469.5 67.9 22.5
+ m3 -22.4 129.6 0.57 -2096.7 438.5 89.9 41.0
+ m1 -841.5 373.2 0.99 -2915.7 448.1 68.8 19.5
+
+ -- mae (vs m3, sign flipped) --
+ model mae_diff mae_se_diff mae se_mae
+ m3 0.0 0.0 21.9 3.6
+ m2 -0.2 1.2 22.0 3.4
+ m1 -6.3 3.1 28.2 3.2
+
+ -- r2 (vs m2) --
+ model r2_diff r2_se_diff r2 se_r2
+ m2 0.000 0.000 0.144 0.221
+ m3 -0.073 0.160 0.071 0.290
+ m1 -0.098 0.223 0.046 0.040
+
+ All differences: 0 = best model, negative = worse.
+ Signs flipped for loss measures: mae.
+ Message
+
+ Diagnostic flags present.
+ See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)
+ or https://mc-stan.org/loo/reference/loo-glossary.html.
+
+---
+
+ Code
+ print(comp, measures = "r2", simplify = FALSE)
+ Output
+ Each measure compared against its own best model (elpd: m2, mae: m3, r2: m2).
+ PSIS-LOO unreliable for all 3 models (k_psis > 0.5); measures may be biased.
+ model bad_k
+ m2 6
+ m3 4
+ m1 4
+
+ -- r2 (vs m2) --
+ model r2_diff r2_se_diff r2 se_r2
+ m2 0.000 0.000 0.144 0.221
+ m3 -0.073 0.160 0.071 0.290
+ m1 -0.098 0.223 0.046 0.040
+
+# model_compare returns expected results (2 models)
+
+ WAoAAAACAAQGAQACAwAAAAMTAAAADAAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v
ZGVsMgAAAA4AAAACAAAAAAAAAAAAAAAAAAAAAAAAAA4AAAACAAAAAAAAAAAAAAAAAAAAAAAA
AA4AAAACf/AAAAAAB6J/8AAAAAAHogAAABAAAAACAAQACQAAAAAABAAJAAAAAAAAABAAAAAC
AAQACQAAAAAABAAJAAAAAAAAAA4AAAACwFTh8N3JQljAVOHw3clCWAAAAA4AAAACQBEIPbMR
@@ -12,7 +271,8 @@
AAAABnBfd2FpYwAEAAkAAAAJc2VfcF93YWljAAQACQAAAAR3YWljAAQACQAAAAdzZV93YWlj
AAAEAgAAAAEABAAJAAAABWNsYXNzAAAAEAAAAAIABAAJAAAAC2NvbXBhcmUubG9vAAQACQAA
AApkYXRhLmZyYW1lAAAEAgAAAAEABAAJAAAACXJvdy5uYW1lcwAAAA0AAAACgAAAAP////4A
- AAD+
+ AAQCAAAAAQAEAAkAAAARY29tcGFyZV9yZWZlcmVuY2UAAAIQAAAAAQAEAAkAAAAGbW9kZWwx
+ AAAEAgAAAf8AAAAQAAAAAQAEAAkAAAAEZWxwZAAAAP4AAAD+
---
@@ -25,7 +285,7 @@
---
- WAoAAAACAAQEAgACAwAAAAMTAAAADAAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v
+ WAoAAAACAAQGAQACAwAAAAMTAAAADAAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v
ZGVsMgAAAA4AAAACAAAAAAAAAADAEDpTX5xF7gAAAA4AAAACAAAAAAAAAAA/tmpHtC8TAQAA
AA4AAAACf/AAAAAAB6I/8AAAAAAAAAAAABAAAAACAAQACQAAAAAABAAJAAAAB04gPCAxMDAA
AAAQAAAAAgAEAAkAAAAAAAQACQAAAAAAAAAOAAAAAsBU4fDdyUJYwFXllhPDBrkAAAAOAAAA
@@ -37,7 +297,8 @@
YWljAAQACQAAAAZwX3dhaWMABAAJAAAACXNlX3Bfd2FpYwAEAAkAAAAEd2FpYwAEAAkAAAAH
c2Vfd2FpYwAABAIAAAABAAQACQAAAAVjbGFzcwAAABAAAAACAAQACQAAAAtjb21wYXJlLmxv
bwAEAAkAAAAKZGF0YS5mcmFtZQAABAIAAAABAAQACQAAAAlyb3cubmFtZXMAAAANAAAAAoAA
- AAD////+AAAA/g==
+ AAD////+AAAEAgAAAAEABAAJAAAAEWNvbXBhcmVfcmVmZXJlbmNlAAACEAAAAAEABAAJAAAA
+ Bm1vZGVsMQAABAIAAAH/AAAAEAAAAAEABAAJAAAABGVscGQAAAD+AAAA/g==
---
@@ -88,11 +349,11 @@
model1 0.0 0.0 -83.5 4.3 3.3 1.1 167.1 8.5
model2 -4.1 0.1 -87.6 4.3 11.2 1.1 175.2 8.6
-# loo_compare returns expected result (3 models)
+# model_compare returns expected result (3 models)
- WAoAAAACAAQEAgACAwAAAAMTAAAADAAAABAAAAADAAQACQAAAAZtb2RlbDEABAAJAAAABm1v
+ WAoAAAACAAQGAQACAwAAAAMTAAAADAAAABAAAAADAAQACQAAAAZtb2RlbDEABAAJAAAABm1v
ZGVsMgAEAAkAAAAGbW9kZWwzAAAADgAAAAMAAAAAAAAAAMAQOlNfnEXuwDANypG2BBgAAAAO
- AAAAAwAAAAAAAAAAP7ZqR7QvEwE/y6/t4TTtXgAAAA4AAAADf/AAAAAAB6I/8AAAAAAAAD/w
+ AAAAAwAAAAAAAAAAP7ZqR7QvEwE/y6/t4TTtYAAAAA4AAAADf/AAAAAAB6I/8AAAAAAAAD/w
AAAAAAAAAAAAEAAAAAMABAAJAAAAAAAEAAkAAAAHTiA8IDEwMAAEAAkAAAAHTiA8IDEwMAAA
ABAAAAADAAQACQAAAAAABAAJAAAAAAAEAAkAAAAAAAAADgAAAAPAVOHw3clCWMBV5ZYTwwa5
wFjlY4I2w2IAAAAOAAAAA0ARCD2zEXBfQBEalRIN2T9AEPIF3GigEwAAAA4AAAADQAoowGHV
@@ -104,7 +365,8 @@
d2FpYwAEAAkAAAAGcF93YWljAAQACQAAAAlzZV9wX3dhaWMABAAJAAAABHdhaWMABAAJAAAA
B3NlX3dhaWMAAAQCAAAAAQAEAAkAAAAFY2xhc3MAAAAQAAAAAgAEAAkAAAALY29tcGFyZS5s
b28ABAAJAAAACmRhdGEuZnJhbWUAAAQCAAAAAQAEAAkAAAAJcm93Lm5hbWVzAAAADQAAAAKA
- AAAA/////QAAAP4=
+ AAAA/////QAABAIAAAABAAQACQAAABFjb21wYXJlX3JlZmVyZW5jZQAAAhAAAAABAAQACQAA
+ AAZtb2RlbDEAAAQCAAAB/wAAABAAAAABAAQACQAAAARlbHBkAAAA/gAAAP4=
---
@@ -121,7 +383,7 @@
See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)
or https://mc-stan.org/loo/reference/loo-glossary.html.
-# loo_compare with simplify=FALSE returns expected result
+# model_compare with simplify=FALSE returns expected result
Code
print(comp, simplify = FALSE)
@@ -154,3 +416,27 @@
CQAAAAtjb21wYXJlLmxvbwAEAAkAAAAGbWF0cml4AAQACQAAAAVhcnJheQAEAAkAAAAPb2xk
X2NvbXBhcmUubG9vAAAA/g==
+# print names only the ranking reference with more than four measures
+
+ Code
+ print(comp)
+ Output
+ Each measure compared against its own best model (elpd: m2, ...).
+ PSIS-LOO unreliable for all 3 models (k_psis > 0.5); measures may be biased.
+ model bad_k
+ m2 6
+ m3 4
+ m1 4
+
+ model elpd_diff se_diff p_worse diag_diff
+ m2 0.0 0.0 NA
+ m3 -22.4 129.6 0.57
+ m1 -841.5 373.2 0.99
+ Message
+
+ Diagnostic flags present.
+ See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)
+ or https://mc-stan.org/loo/reference/loo-glossary.html.
+
+ Use print(x, measures = "all") to see all measures.
+
diff --git a/tests/testthat/_snaps/loo_moment_matching.md b/tests/testthat/_snaps/loo_moment_matching.md
index 1a1d41dc..5c8da4a8 100644
--- a/tests/testthat/_snaps/loo_moment_matching.md
+++ b/tests/testthat/_snaps/loo_moment_matching.md
@@ -10,7 +10,8 @@
was reached.
Increasing the value may improve accuracy.
Warning:
- Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.
+ Some Pareto k diagnostic values are too high.
+ See help('pareto-k-diagnostic') for details.
Output
Computed from 4000 posterior draws and 30 log-likelihood terms.
@@ -41,11 +42,11 @@
qq1wTGC/+x8Kh2qj0L/7JFoKTeIwv/soK3EUBUC//KBEQBPCGMAAKtiBefwUv/s4omTXOVjA
A0qKEEuTGL/7hlp0sBHYv/xVS8d60LC//yJy272SKL/7oVoD6+JIv/7iRaQt0cC//VaEo30D
QL/85OxxwadowAHqd1LUWNi/+9Uw/+PdoL/7IYmDCMJQv/+TLUcS2KC//UsYUnCS0D/IX47y
- Iyd4P2Gfcpi2o14/Y+tB1l8doj9hmK3v3TkPP2GaKR7pqDc/ZQkD2NQ5Jj9hp3Fk+g3LP2Wd
- 0KgLB8I/Yjujzb/pcj9hx0KNqzrIP2J1vTd0O6A/YaMJLQunTj9hpM5D/xQmP2GZy1TTNTQ/
- YfB+8HkBPD9lqO+CzYUVP2GpxXMcLEE/cGE1wkkqlD9hvBsU75ARP2HQSdm5R3s/Y/zERK8H
- xD9hni0KCRVhP2O2kFJNSG8/Ylo+R/BQoj9iFB/Wf65IP2s9ryP57Cc/YdKJGMftEz9hmtGw
- bW4sP2SA235BWtA/YotQDpT7XkAkqqbkVm+fP5IXf6UkPQA/lrxpW1EOAD+SDmssqA4AP5IS
+ IyeFP2Gfcpi2o2M/Y+tB1l8doD9hmK3v3TkQP2GaKR7pqEM/ZQkD2NQ5Gz9hp3Fk+g3FP2Wd
+ 0KgLB8s/Yjujzb/pdz9hx0KNqzrJP2J1vTd0O6Y/YaMJLQunTT9hpM5D/xQnP2GZy1TTNTE/
+ YfB+8HkBMj9lqO+CzYUXP2GpxXMcLEM/cGE1wkkqkD9hvBsU75ASP2HQSdm5R3g/Y/zERK8H
+ vT9hni0KCRVhP2O2kFJNSGY/Ylo+R/BQpz9iFB/Wf65DP2s9ryP57Cg/YdKJGMftCz9hmtGw
+ bW4sP2SA235BWtI/YotQDpT7WEAkqqbkVm+fP5IXf6UkPQA/lrxpW1EOAD+SDmssqA4AP5IS
8YLzxAA/mQEBdV99AD+SOdWCpaAAP5otz1Wr6wA/k0U02BITAD+SYx8kcE4AP5PhNpO18QA/
ki0P3eyCAD+SMjlDn5oAP5IR1Ro8TgA/krLjpKmXAD+aTlBMoagAP5JAN/f7OgA/qwiqhKrz
AD+SbOl4OJEAP5J03K3aUAA/lsJL+aFkAD+SFPC7p4gAP5Y04S7O5wA/k4CJvuH6AD+S+DEh
@@ -84,7 +85,8 @@
CQAAAAtzZV9lbHBkX2xvbwAEAAkAAAAIc2VfcF9sb28ABAAJAAAACHNlX2xvb2ljAAAEAgAA
AAEABAAJAAAABGRpbXMAAAANAAAAAgAAD6AAAAAeAAAEAgAAAAEABAAJAAAABWNsYXNzAAAA
EAAAAAMABAAJAAAACHBzaXNfbG9vAAQACQAAABdpbXBvcnRhbmNlX3NhbXBsaW5nX2xvbwAE
- AAkAAAADbG9vAAAA/g==
+ AAkAAAADbG9vAAAEAgAAAAEABAAJAAAAB3Bvc3Rob2MAAAAQAAAAAQAEAAkAAAAMbW9tZW50
+ X21hdGNoAAAA/g==
---
@@ -97,11 +99,11 @@
qq1wTGC/+x8Kh2qj0L/7JFoKTeIwv/soK3EUBUC//KBEQBPCGMAAKtiBefwUv/s4omTXOVjA
A0qKEEuTGL/7hlp0sBHYv/xVS8d60LC//yJy272SKL/7oVoD6+JIv/7iRaQt0cC//VaEo30D
QL/85OxxwadowAHqd1LUWNi/+9Uw/+PdoL/7IYmDCMJQv/+TLUcS2KC//UsYUnCS0D/Zw5bt
- Aw0/P2Gfcpi2o14/Y+tB1l8doj9hmK3v3TkPP2GaKR7pqDc/ZQkD2NQ5Jj9hp3Fk+g3LP2Wd
- 0KgLB8I/Yjujzb/pcj9hx0KNqzrIP2J1vTd0O6A/YaMJLQunTj9hpM5D/xQmP2GZy1TTNTQ/
- YfB+8HkBPD9lqO+CzYUVP2GpxXMcLEE/cGE1wkkqlD9hvBsU75ARP2HQSdm5R3s/Y/zERK8H
- xD9hni0KCRVhP2O2kFJNSG8/Ylo+R/BQoj9iFB/Wf65IP2s9ryP57Cc/YdKJGMftEz9hmtGw
- bW4sP2SA235BWtA/YotQDpT7XkAl8epM1HkfP5IXf6UkPQA/lrxpW1EOAD+SDmssqA4AP5IS
+ Aw05P2Gfcpi2o2M/Y+tB1l8doD9hmK3v3TkQP2GaKR7pqEM/ZQkD2NQ5Gz9hp3Fk+g3FP2Wd
+ 0KgLB8s/Yjujzb/pdz9hx0KNqzrJP2J1vTd0O6Y/YaMJLQunTT9hpM5D/xQnP2GZy1TTNTE/
+ YfB+8HkBMj9lqO+CzYUXP2GpxXMcLEM/cGE1wkkqkD9hvBsU75ASP2HQSdm5R3g/Y/zERK8H
+ vT9hni0KCRVhP2O2kFJNSGY/Ylo+R/BQpz9iFB/Wf65DP2s9ryP57Cg/YdKJGMftCz9hmtGw
+ bW4sP2SA235BWtI/YotQDpT7WEAl8epM1HkfP5IXf6UkPQA/lrxpW1EOAD+SDmssqA4AP5IS
8YLzxAA/mQEBdV99AD+SOdWCpaAAP5otz1Wr6wA/k0U02BITAD+SYx8kcE4AP5PhNpO18QA/
ki0P3eyCAD+SMjlDn5oAP5IR1Ro8TgA/krLjpKmXAD+aTlBMoagAP5JAN/f7OgA/qwiqhKrz
AD+SbOl4OJEAP5J03K3aUAA/lsJL+aFkAD+SFPC7p4gAP5Y04S7O5wA/k4CJvuH6AD+S+DEh
@@ -140,7 +142,8 @@
CQAAAAtzZV9lbHBkX2xvbwAEAAkAAAAIc2VfcF9sb28ABAAJAAAACHNlX2xvb2ljAAAEAgAA
AAEABAAJAAAABGRpbXMAAAANAAAAAgAAD6AAAAAeAAAEAgAAAAEABAAJAAAABWNsYXNzAAAA
EAAAAAMABAAJAAAACHBzaXNfbG9vAAQACQAAABdpbXBvcnRhbmNlX3NhbXBsaW5nX2xvbwAE
- AAkAAAADbG9vAAAA/g==
+ AAkAAAADbG9vAAAEAgAAAAEABAAJAAAAB3Bvc3Rob2MAAAAQAAAAAQAEAAkAAAAMbW9tZW50
+ X21hdGNoAAAA/g==
---
@@ -153,11 +156,11 @@
qq1wTGC/+x8Kh2qj0L/7JFoKTeIwv/soK3EUBUC//KBEQBPCGMAAKtiBefwUv/s4omTXOVjA
A0qKEEuTGL/7hlp0sBHYv/xVS8d60LC//yJy272SKL/7oVoD6+JIv/7iRaQt0cC//VaEo30D
QL/85OxxwadowAHqd1LUWNi/+9Uw/+PdoL/7IYmDCMJQv/+TLUcS2KC//UsYUnCS0D+iQ4TC
- EOOrP2Gfcpi2o14/Y+tB1l8doj9hmK3v3TkPP2GaKR7pqDc/ZQkD2NQ5Jj9hp3Fk+g3LP2Wd
- 0KgLB8I/Yjujzb/pcj9hx0KNqzrIP2J1vTd0O6A/YaMJLQunTj9hpM5D/xQmP2GZy1TTNTQ/
- YfB+8HkBPD9lqO+CzYUVP2GpxXMcLEE/cGE1wkkqlD9hvBsU75ARP2HQSdm5R3s/Y/zERK8H
- xD9hni0KCRVhP2O2kFJNSG8/Ylo+R/BQoj9iFB/Wf65IP2s9ryP57Cc/YdKJGMftEz9hmtGw
- bW4sP2SA235BWtA/YotQDpT7XkAnmU+zLgn7P5IXf6UkPQA/lrxpW1EOAD+SDmssqA4AP5IS
+ EOOrP2Gfcpi2o2M/Y+tB1l8doD9hmK3v3TkQP2GaKR7pqEM/ZQkD2NQ5Gz9hp3Fk+g3FP2Wd
+ 0KgLB8s/Yjujzb/pdz9hx0KNqzrJP2J1vTd0O6Y/YaMJLQunTT9hpM5D/xQnP2GZy1TTNTE/
+ YfB+8HkBMj9lqO+CzYUXP2GpxXMcLEM/cGE1wkkqkD9hvBsU75ASP2HQSdm5R3g/Y/zERK8H
+ vT9hni0KCRVhP2O2kFJNSGY/Ylo+R/BQpz9iFB/Wf65DP2s9ryP57Cg/YdKJGMftCz9hmtGw
+ bW4sP2SA235BWtI/YotQDpT7WEAnmU+zLgn7P5IXf6UkPQA/lrxpW1EOAD+SDmssqA4AP5IS
8YLzxAA/mQEBdV99AD+SOdWCpaAAP5otz1Wr6wA/k0U02BITAD+SYx8kcE4AP5PhNpO18QA/
ki0P3eyCAD+SMjlDn5oAP5IR1Ro8TgA/krLjpKmXAD+aTlBMoagAP5JAN/f7OgA/qwiqhKrz
AD+SbOl4OJEAP5J03K3aUAA/lsJL+aFkAD+SFPC7p4gAP5Y04S7O5wA/k4CJvuH6AD+S+DEh
@@ -196,7 +199,8 @@
CQAAAAtzZV9lbHBkX2xvbwAEAAkAAAAIc2VfcF9sb28ABAAJAAAACHNlX2xvb2ljAAAEAgAA
AAEABAAJAAAABGRpbXMAAAANAAAAAgAAD6AAAAAeAAAEAgAAAAEABAAJAAAABWNsYXNzAAAA
EAAAAAMABAAJAAAACHBzaXNfbG9vAAQACQAAABdpbXBvcnRhbmNlX3NhbXBsaW5nX2xvbwAE
- AAkAAAADbG9vAAAA/g==
+ AAkAAAADbG9vAAAEAgAAAAEABAAJAAAAB3Bvc3Rob2MAAAAQAAAAAQAEAAkAAAAMbW9tZW50
+ X21hdGNoAAAA/g==
# variance and covariance transformations work
@@ -206,39 +210,39 @@
bHBkX2xvbwAEAAkAAAAFcF9sb28ABAAJAAAABWxvb2ljAAAAEAAAAAIABAAJAAAACEVzdGlt
YXRlAAQACQAAAAJTRQAAAP4AAAIOAAAAlsA00hUKopC7v/uiIMLHLvi//ssyhve2vL/7Jr8K
SbT4v/sa1cItPgi//8POqw85FL/7JoUvY15YwAA7D8sD/c6//SUayysMjL/8O2Quh638v/0W
- mUgAlIC/+xKZXXIQkL/7F40nuPLQv/seLsVhXbC//J23rmyzkMAAIARDWDzAv/srA2aD7NTA
+ mUgAlIS/+xKZXXIQkL/7F40nuPLQv/seLsVhXbC//J23rmyzkMAAIARDWDzAv/srA2aD7NTA
A1R95vJwGL/7djZ68aYcv/xSR/sGCki//yevfroaIL/7mxSAeStQv/7m3aUwM2i//VTP19jb
- WL/84rONukOMwAHx9fU/2Fa/+8QvunAEmL/7Fx4TRHXQv/+ZdSn1rci//Tf3NN2neD/nAgcM
- Ar3hP2mZjSnOPhE/ayNFdQtNbz9qIjO8mlf2P2onEdowf9Y/bFTXaJqRrD9rK1dC1mI/P2w9
- mmBlEWQ/aT33KWgVMz9pDE2N/9UDP2pdJT4k8hE/aouFsw7Gnz9qlz3OrlTAP2oc4HHNYSc/
- aRVFdDl95D9tDHOUskvNP2qrErFFyQA/dMRV+0sb3z9qnM+HJMU3P2kMYnIPPmQ/apILe568
- Iz9pniYJ+vRZP2pRL+B2abs/aVODDQyKDj9pJSlA+y+/P3Gae7w4vXo/aoHzLWAumD9qNLl+
- 2CDgP2sSjLsR9GA/al5k0IGIuEAmg6Qr+gHCP5I5hg6ABgA/lTqBKHTFAD+SIcNl86EAP5If
- omEDfwA/lvi9WmUhAD+THZI/2f4AP5mPg19ObgA/ktItKsZkAD+SjsiR3esAP5KkmoaHBgA/
+ WL/84rONukOMwAHx9fU/2Fa/+8QvunAEiL/7Fx4TRHXQv/+ZdSn1rci//Tf3NN2nfD/nAgcM
+ Ar3fP2mZjSnOPhU/ayNFdQtNdT9qIjO8mlf9P2onEdowf9Y/bFTXaJqRqj9rK1dC1mI6P2w9
+ mmBlEVs/aT33KWgVPT9pDE2N/9T/P2pdJT4k8hs/aouFsw7GmD9qlz3OrlTAP2oc4HHNYTQ/
+ aRVFdDl96z9tDHOUskvUP2qrErFFyQQ/dMRV+0sb2T9qnM+HJMU5P2kMYnIPPl8/apILe568
+ Iz9pniYJ+vRkP2pRL+B2ack/aVODDQyKDj9pJSlA+y/EP3Gae7w4vXg/aoHzLWAufT9qNLl+
+ 2CDVP2sSjLsR9GE/al5k0IGIsEAmg6Qr+gHCP5I5hg6ABgA/lTqBKHTFAD+SIcNl86EAP5If
+ omEDfwA/lvi9WmUhAD+THZI/2f4AP5mPg19ObgA/ktItKsZkAD+SjsiR3esAP5KkmoaHBwA/
khZKaRjvAD+SFGHT2/UAP5Ig3ZVNFAA/kpwrkaAFAD+YCFgsLCIAP5IPS9yztQA/qlFcWiEQ
gD+RznOE6nQAP5KPYOKjMwA/lmRIfQIoAD+SN2h/dggAP5Xg9zNtrgA/ku5c/6I+AD+SsXhR
- IusAP6MUf55iiAA/kd0sR7uFAD+SH4L0gRQAP5dfNWv49wA/kshKi4uHAEBE0hUKopC7QAui
+ IusAP6MUf55iiAA/kd0sR7uBAD+SH4L0gRQAP5dfNWv49wA/kshKi4uIAEBE0hUKopC7QAui
IMLHLvhADssyhve2vEALJr8KSbT4QAsa1cItPghAD8POqw85FEALJoUvY15YQBA7D8sD/c5A
- DSUayysMjEAMO2Quh638QA0WmUgAlIBACxKZXXIQkEALF40nuPLQQAseLsVhXbBADJ23rmyz
+ DSUayysMjEAMO2Quh638QA0WmUgAlIRACxKZXXIQkEALF40nuPLQQAseLsVhXbBADJ23rmyz
kEAQIARDWDzAQAsrA2aD7NRAE1R95vJwGEALdjZ68aYcQAxSR/sGCkhADyevfroaIEALmxSA
- eStQQA7m3aUwM2hADVTP19jbWEAM4rONukOMQBHx9fU/2FZAC8QvunAEmEALFx4TRHXQQA+Z
- dSn1rchADTf3NN2neD/5Fjgy7IhNP7bHI1nATNu/p51R7PmvmD+sHH7uZvExP6/qoVFauie/
+ eStQQA7m3aUwM2hADVTP19jbWEAM4rONukOMQBHx9fU/2FZAC8QvunAEiEALFx4TRHXQQA+Z
+ dSn1rchADTf3NN2nfD/5Fjgy7IhNP7bHI1nATNu/p51R7PmvmD+sHH7uZvExP6/qoVFauie/
qA5Hs2wLOD+VYzdWUCoGP7mzNB+LFPm/vdDQDBpFTr+VFeEkxR0uP7F7m5KVOH4/pVACJbjE
- sz+jdMHsaW26P65HVhP0fb2/s2b06ISpO7+kQJCWKzeLP6COIa9BZf0/zvjmbLoMHD9TIc+d
+ sz+jdMHsaW26P65HVhP0fb2/s2b06ISpkL+kQJCWKzeLP6COIa9BZf0/zvjmbLoMHD9TIc+d
D90iv5o1IjVvGpE/s1oN2T4Ezj+3OGyWxNxQP7EIIW+h0Zu/uyMfiLLHPL+0y/cCrI2fP8sJ
wPl6FPE/o6KWFvbGlj+0vX2EvGOhP7O2T6sntYs/qCNltsfv5AAABAIAAAH/AAAADQAAAAIA
AAAeAAAABQAABAIAAAL/AAAAEwAAAAIAAAD+AAAAEAAAAAUABAAJAAAACGVscGRfbG9vAAQA
CQAAAA1tY3NlX2VscGRfbG9vAAQACQAAAAVwX2xvbwAEAAkAAAAFbG9vaWMABAAJAAAAEmlu
Zmx1ZW5jZV9wYXJldG9fawAAAP4AAAITAAAAAwAAAA4AAAAev+M6GYBUtuK/vGuV8SEFY7+n
nVHs+a+Yv6TW5Y0ItKu/kWww4vIr3r+oDkezbAs4P5VjN1ZQKgY/lNht5+Gb3L+90NAMGkVO
- v5UV4STFHS6/oHuKtB6H+79jFZ1pm6peP3lA+cM1Zw2/nu9VSy318r+zZvTohKk7v6RAkJYr
- N4s/myfZhKlCvz+5EKUE8jDyv4E3FDJY90a/mjUiNW8akb8zDtdIUiGLv7tWWF8w/Zo/hs8u
- D/kEfb+7Ix+Issc8v7TL9wKsjZ8/sGq450lfLL+1y0lRJZaqv6J/sQ9lzDo/n+DuBoWlbD9T
- FE1Ilwn2AAAADgAAAB5AA4tpeQZbA0CdJ778gk1OQJ6TSnvdXnBAnD6Pn+iHVkCcPOYri39h
- QJ6D/vF10JpAmzztybeSzECefRV6RtsvQJ6p/nbR4JNAnqxBiqhjm0Cb0Jv6ZpKMQJtvTMQm
+ v5UV4STFHS6/oHuKtB6N6r9jFZ1pm6peP3lA+cM1Zw2/nu9VSy318r+zZvTohKmQv6RAkJYr
+ N4s/myfZhKlCvz+5EKUE8jDyv4E3FDJbDJy/mjUiNW8akb8zDtdIUiGLv7tWWF8w/Zo/hs8u
+ D/kEfb+7Ix+Issc8v7TL9wKsjZ8/sGq450lfLL+1y0lRJKGCv6J/sQ9lzDo/n+DuBoWlbD9T
+ FE1Ik8nAAAAADgAAAB5AA4tpeQZbA0CdJ778gk1OQJ6TSnvdXnBAnD6Pn+iHVkCcPOYri39h
+ QJ6D/vF10JpAmzztybeSzECefRV6RtsvQJ6p/nbR4JNAnqxBiqhjm0Cb0Jv6ZpKSQJtvTMQm
L0pAm1O/s5Mn4kCcUUc/BUoAQJ6ryQO6wvNAnnp5yf77kUCbHdP+dPZRQJxwFCHevvJAmt1+
- OmGOCECerENzxOK5QJ6kbKmimNNAnSAFYnwMPECepBjV4PmnQJ6pF6rZX3pAnqslCMgZy0Cd
- UOL9AXOaQJr484ME1q1AnCOQo84P8UCendeyiBCHQJvx7is3eLQAAAAOAAAAHj/wAAAAAAAA
+ OmGOCkCerENzxOK5QJ6kbKmimNNAnSAFYnwMPECepBjV4PmnQJ6pF6rZX3pAnqslCMgZy0Cd
+ UOL9AXOaQJr484ME1tpAnCOQo84P8UCendeyiBCHQJvx7is3eLkAAAAOAAAAHj/wAAAAAAAA
P/AAAAAAAAA/8AAAAAAAAD/wAAAAAAAAP/AAAAAAAAA/8AAAAAAAAD/wAAAAAAAAP/AAAAAA
AAA/8AAAAAAAAD/wAAAAAAAAP/AAAAAAAAA/8AAAAAAAAD/wAAAAAAAAP/AAAAAAAAA/8AAA
AAAAAD/wAAAAAAAAP/AAAAAAAAA/8AAAAAAAAD/wAAAAAAAAP/AAAAAAAAA/8AAAAAAAAD/w
@@ -252,7 +256,8 @@
CQAAAAtzZV9lbHBkX2xvbwAEAAkAAAAIc2VfcF9sb28ABAAJAAAACHNlX2xvb2ljAAAEAgAA
AAEABAAJAAAABGRpbXMAAAANAAAAAgAAB9AAAAAeAAAEAgAAAAEABAAJAAAABWNsYXNzAAAA
EAAAAAMABAAJAAAACHBzaXNfbG9vAAQACQAAABdpbXBvcnRhbmNlX3NhbXBsaW5nX2xvbwAE
- AAkAAAADbG9vAAAA/g==
+ AAkAAAADbG9vAAAEAgAAAAEABAAJAAAAB3Bvc3Rob2MAAAAQAAAAAQAEAAkAAAAMbW9tZW50
+ X21hdGNoAAAA/g==
# loo_moment_match_split works
diff --git a/tests/testthat/_snaps/loo_subsampling.md b/tests/testthat/_snaps/loo_subsampling.md
index cfaf8025..a22191ee 100644
--- a/tests/testthat/_snaps/loo_subsampling.md
+++ b/tests/testthat/_snaps/loo_subsampling.md
@@ -1,7 +1,7 @@
-# loo_compare_subsample
+# model_compare_subsample
Code
- lcss <- loo:::loo_compare.psis_loo_ss_list(x = list(lss1, lss2, lss3))
+ lcss <- loo:::model_compare.psis_loo_ss_list(x = list(lss1, lss2, lss3))
Condition
Warning:
Different subsamples in 'model3' and 'model2'. Naive diff SE is used.
@@ -11,7 +11,7 @@
---
Code
- lcssapi <- loo_compare(lss1, lss2, lss3)
+ lcssapi <- model_compare(lss1, lss2, lss3)
Condition
Warning:
Different subsamples in 'model3' and 'model2'. Naive diff SE is used.
diff --git a/tests/testthat/_snaps/loo_subsampling_cases.md b/tests/testthat/_snaps/loo_subsampling_cases.md
index 4cff4eb9..1c458653 100644
--- a/tests/testthat/_snaps/loo_subsampling_cases.md
+++ b/tests/testthat/_snaps/loo_subsampling_cases.md
@@ -104,34 +104,34 @@
Code
print(comp)
Output
- elpd_diff se_diff subsampling_se_diff
- model2 0.0 0.0 0.0
- model1 -16.5 22.5 0.4
+ model elpd_diff se_diff subsampling_se_diff
+ model2 0.0 0.0 0.0
+ model1 -16.5 22.5 0.4
---
Code
print(comp)
Output
- elpd_diff se_diff subsampling_se_diff
- model2 0.0 0.0 0.0
- model1 -16.1 4.4 0.1
+ model elpd_diff se_diff subsampling_se_diff
+ model2 0.0 0.0 0.0
+ model1 -16.1 4.4 0.1
---
Code
print(comp2)
Output
- elpd_diff se_diff subsampling_se_diff
- model2 0.0 0.0 0.0
- model1 -16.3 4.4 0.1
+ model elpd_diff se_diff subsampling_se_diff
+ model2 0.0 0.0 0.0
+ model1 -16.3 4.4 0.1
---
Code
print(comp3)
Output
- elpd_diff se_diff subsampling_se_diff
- model2 0.0 0.0 0.0
- model1 -16.5 4.4 0.3
+ model elpd_diff se_diff subsampling_se_diff
+ model2 0.0 0.0 0.0
+ model1 -16.5 4.4 0.3
diff --git a/tests/testthat/_snaps/pred_measure_builtin.md b/tests/testthat/_snaps/pred_measure_builtin.md
index 67ff3633..4204568d 100644
--- a/tests/testthat/_snaps/pred_measure_builtin.md
+++ b/tests/testthat/_snaps/pred_measure_builtin.md
@@ -3,110 +3,110 @@
Computed from 400 draws by 53 observations.
- Estimate SE
- elpd -706.65 146.52
+ Estimate SE
+ elpd -706.7 146.5
# measure_ic() works as expected
Computed from 400 draws by 53 observations.
- Estimate SE
- ic 1413.31 293.04
+ Estimate SE
+ ic 1413.3 293.0
# measure_mlpd() works as expected
Computed from 400 draws by 53 observations.
- Estimate SE
- mlpd -13.33 2.76
+ Estimate SE
+ mlpd -13.333 2.765
# measure_mlpd() with pointwise works as expected
Computed from 53 pointwise terms.
- Estimate SE
- mlpd -13.33 2.76
+ Estimate SE
+ mlpd -13.333 2.765
# measure_rps() with ordered categorial data works as expected
Computed from 400 draws by 50 observations.
- Estimate SE
- rps 0.88 0.09
+ Estimate SE
+ rps 0.877 0.087
# measure_rps() scaled version with categorical data works as expected
Computed from 400 draws by 50 observations.
- Estimate SE
- srps -1.28 0.05
+ Estimate SE
+ srps -1.281 0.051
# measure_rps() with continuous data works as expected
Computed from 400 draws by 29 observations.
- Estimate SE
- rps 24.61 3.29
+ Estimate SE
+ rps 24.6 3.3
# measure_brier() works as expected
Computed from 400 draws by 50 observations.
- Estimate SE
- brier 0.24 0.01
+ Estimate SE
+ brier 0.241 0.009
# measure_mae() works as expected
Computed from 400 draws by 53 observations.
- Estimate SE
- mae 17.21 2.65
+ Estimate SE
+ mae 17.2 2.6
# measure_mse() and measure_rmse() work as expected
Computed from 400 draws by 53 observations.
- Estimate SE
- mse 661.01 224.17
+ Estimate SE
+ mse 661.0 224.2
---
Computed from 400 draws by 53 observations.
- Estimate SE
- rmse 25.71 4.36
+ Estimate SE
+ rmse 25.7 4.4
# measure_r2() works as expected
Computed from 400 draws by 53 observations.
- Estimate SE
- r2 0.58 0.17
+ Estimate SE
+ r2 0.583 0.166
# measure_acc() works as expected
Computed from 400 draws by 67 observations.
- Estimate SE
- acc 0.97 0.02
+ Estimate SE
+ acc 0.970 0.021
# measure_bacc() works as expected
Computed from 400 draws by 67 observations.
- Estimate SE
- bacc 0.95 0.03
+ Estimate SE
+ bacc 0.952 0.031
diff --git a/tests/testthat/_snaps/print.md b/tests/testthat/_snaps/print.md
index 1842d604..4aab75f4 100644
--- a/tests/testthat/_snaps/print.md
+++ b/tests/testthat/_snaps/print.md
@@ -4,8 +4,8 @@
Computed from 400 posterior draws and 53 observations.
Data source: loo
- Estimate SE
- r2_loo 0.6 0.2
+ Estimate SE
+ r2_loo 0.564 0.167
------
Pareto k diagnostic values:
Count Pct. Min. ESS
@@ -19,9 +19,9 @@
Computed from 400 posterior draws and 53 observations.
Data source: loo
- Estimate SE
- r2_loo 0.6 0.2
- rmse_loo 26.3 4.4
+ Estimate SE
+ r2_loo 0.564 0.167
+ rmse_loo 26.3 4.4
------
Pareto k diagnostic values:
Count Pct. Min. ESS
@@ -36,7 +36,7 @@
Data source: loo
Estimate SE
- r2_loo 0.6 0.2
+ r2_loo 0.564 0.167
rmse_loo 26.3 4.4
mse_loo 691.9 230.5
------
@@ -53,7 +53,7 @@
Data source: loo
Estimate SE
- r2_loo 0.6 0.2
+ r2_loo 0.564 0.167
rmse_loo 26.3 4.4
mse_loo 691.9 230.5
mae_loo 17.6 2.7
@@ -71,7 +71,7 @@
Data source: loo
Estimate SE
- r2_loo 0.6 0.2
+ r2_loo 0.564 0.167
rmse_loo 26.3 4.4
mse_loo 691.9 230.5
mae_loo 17.6 2.7
@@ -90,12 +90,12 @@
Data source: loo
Estimate SE
- r2_loo 0.6 0.2
+ r2_loo 0.564 0.167
rmse_loo 26.3 4.4
mse_loo 691.9 230.5
mae_loo 17.6 2.7
rps_loo 15.2 2.6
- srps_loo -4.1 0.5
+ srps_loo -4.10 0.46
------
Pareto k diagnostic values:
Count Pct. Min. ESS
@@ -109,14 +109,14 @@
Computed from 400 posterior draws and 53 observations.
Data source: loo
- Estimate SE
- r2_loo 0.6 0.2
- rmse_loo 26.3 4.4
- mse_loo 691.9 230.5
- mae_loo 17.6 2.7
- rps_loo 15.2 2.6
- srps_loo -4.1 0.5
- mlpd_loo -13.7 2.9
+ Estimate SE
+ r2_loo 0.564 0.167
+ rmse_loo 26.3 4.4
+ mse_loo 691.9 230.5
+ mae_loo 17.6 2.7
+ rps_loo 15.2 2.6
+ srps_loo -4.10 0.46
+ mlpd_loo -13.680 2.855
------
Pareto k diagnostic values:
Count Pct. Min. ESS
@@ -130,8 +130,8 @@
Computed from 400 posterior draws and 53 observations.
Data source: loo
- Estimate SE
- srps_loo -4.1 0.5
+ Estimate SE
+ srps_loo -4.10 0.46
------
Pareto k diagnostic values:
Count Pct. Min. ESS
@@ -145,9 +145,9 @@
Computed from 400 posterior draws and 53 observations.
Data source: loo
- Estimate SE
- srps_loo -4.1 0.5
- r2_loo 0.6 0.2
+ Estimate SE
+ srps_loo -4.10 0.46
+ r2_loo 0.564 0.167
------
Pareto k diagnostic values:
Count Pct. Min. ESS
@@ -161,10 +161,10 @@
Computed from 400 posterior draws and 53 observations.
Data source: loo
- Estimate SE
- srps_loo -4.1 0.5
- r2_loo 0.6 0.2
- mae_loo 17.6 2.7
+ Estimate SE
+ srps_loo -4.10 0.46
+ r2_loo 0.564 0.167
+ mae_loo 17.6 2.7
------
Pareto k diagnostic values:
Count Pct. Min. ESS
@@ -179,8 +179,8 @@
Data source: loo
Estimate SE
- srps_loo -4.1 0.5
- r2_loo 0.6 0.2
+ srps_loo -4.10 0.46
+ r2_loo 0.564 0.167
mae_loo 17.6 2.7
mse_loo 691.9 230.5
------
@@ -196,12 +196,12 @@
Computed from 400 posterior draws and 53 observations.
Data source: loo
- Estimate SE
- srps_loo -4.1 0.5
- r2_loo 0.6 0.2
- mae_loo 17.6 2.7
- mse_loo 691.9 230.5
- mlpd_loo -13.7 2.9
+ Estimate SE
+ srps_loo -4.10 0.46
+ r2_loo 0.564 0.167
+ mae_loo 17.6 2.7
+ mse_loo 691.9 230.5
+ mlpd_loo -13.680 2.855
------
Pareto k diagnostic values:
Count Pct. Min. ESS
@@ -215,13 +215,13 @@
Computed from 400 posterior draws and 53 observations.
Data source: loo
- Estimate SE
- srps_loo -4.1 0.5
- r2_loo 0.6 0.2
- mae_loo 17.6 2.7
- mse_loo 691.9 230.5
- mlpd_loo -13.7 2.9
- rmse_loo 26.3 4.4
+ Estimate SE
+ srps_loo -4.10 0.46
+ r2_loo 0.564 0.167
+ mae_loo 17.6 2.7
+ mse_loo 691.9 230.5
+ mlpd_loo -13.680 2.855
+ rmse_loo 26.3 4.4
------
Pareto k diagnostic values:
Count Pct. Min. ESS
@@ -235,14 +235,14 @@
Computed from 400 posterior draws and 53 observations.
Data source: loo
- Estimate SE
- srps_loo -4.1 0.5
- r2_loo 0.6 0.2
- mae_loo 17.6 2.7
- mse_loo 691.9 230.5
- mlpd_loo -13.7 2.9
- rmse_loo 26.3 4.4
- rps_loo 15.2 2.6
+ Estimate SE
+ srps_loo -4.10 0.46
+ r2_loo 0.564 0.167
+ mae_loo 17.6 2.7
+ mse_loo 691.9 230.5
+ mlpd_loo -13.680 2.855
+ rmse_loo 26.3 4.4
+ rps_loo 15.2 2.6
------
Pareto k diagnostic values:
Count Pct. Min. ESS
@@ -256,10 +256,10 @@
Computed from 400 posterior draws and 53 observations.
Data source: loo
- Estimate SE
- elpd_loo -725.0 151.3
- p_loo 18.4 5.6
- r2_loo 0.6 0.2
+ Estimate SE
+ elpd_loo -725.0 151.3
+ p_loo 18.4 5.6
+ r2_loo 0.564 0.167
------
Pareto k diagnostic values:
Count Pct. Min. ESS
@@ -273,7 +273,7 @@
Computed from 400 posterior draws and 20 observations.
Data source: test
- Estimate SE
- rmse_test 58.7 6.6
- r2_test 0.0 0.2
+ Estimate SE
+ rmse_test 58.7 6.6
+ r2_test 0.007 0.167
diff --git a/tests/testthat/_snaps/psis.md b/tests/testthat/_snaps/psis.md
index d902046d..0ce38ccc 100644
--- a/tests/testthat/_snaps/psis.md
+++ b/tests/testthat/_snaps/psis.md
@@ -4801,7 +4801,8 @@
Warning:
Not enough tail samples to fit the generalized Pareto distribution in some or all columns of matrix of log importance ratios. Skipping the following columns: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, ... [22 more not printed].
Warning:
- Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.
+ Some Pareto k diagnostic values are too high.
+ See help('pareto-k-diagnostic') for details.
Output
Computed from 10 posterior draws and 32 log-weight terms.
MCSE and ESS estimates assume independent draws (r_eff=1).
diff --git a/tests/testthat/data-for-tests/test_data_binary.Rds b/tests/testthat/data-for-tests/test_data_binary.Rds
index 0f55a5ed..a6f147c8 100644
Binary files a/tests/testthat/data-for-tests/test_data_binary.Rds and b/tests/testthat/data-for-tests/test_data_binary.Rds differ
diff --git a/tests/testthat/data-for-tests/test_data_binomial.Rds b/tests/testthat/data-for-tests/test_data_binomial.Rds
index d90c6c81..2cd404cd 100644
Binary files a/tests/testthat/data-for-tests/test_data_binomial.Rds and b/tests/testthat/data-for-tests/test_data_binomial.Rds differ
diff --git a/tests/testthat/data-for-tests/test_data_generation.R b/tests/testthat/data-for-tests/test_data_generation.R
index 1e1c50be..26389920 100644
--- a/tests/testthat/data-for-tests/test_data_generation.R
+++ b/tests/testthat/data-for-tests/test_data_generation.R
@@ -85,9 +85,11 @@ postprocess_res <- function(model, fit, chains = 2, draws = 200) {
# ---- fixture shrinking ------------------------------------------------------
# These fixtures ship in the source tarball, which CRAN limits to 5 MB. Keep
# only a subset of the observations. The draws stay at 400, so the Pareto k
-# threshold ps_khat_threshold(400) does not move.
+# threshold ps_khat_threshold(400) does not move. The exception is
+# `test_data_roaches_compare.Rds`: its fit uses `thin = 4`, so it holds only
+# 100 draws.
N_KEEP <- c(
- roaches = 53, categorical = 67, sleep = 29,
+ roaches = 53, roaches_compare = 110, categorical = 67, sleep = 29,
sleep_test = 20
)
@@ -192,6 +194,22 @@ shrink_res <- function(model, res) {
res
}
+# The model-comparison fixture holds four `psis_loo` objects and four sets of
+# draws. `.keep_index()` reseeds, so this keeps the same 53 observations as
+# `test_data_roaches.Rds`.
+shrink_roaches_compare <- function(res) {
+ keep <- .keep_index(length(res$y), N_KEEP[["roaches_compare"]])
+ res$y <- res$y[keep]
+ for (nm in grep("^(ypred|mupred|ylp)(_m[0-9]+)?$", names(res), value = TRUE)) {
+ res[[nm]] <- res[[nm]][, keep, drop = FALSE]
+ }
+ for (nm in grep("^loo_p(_m[0-9]+)?$", names(res), value = TRUE)) {
+ res[[nm]] <- .shrink_psis_loo(res[[nm]], keep)
+ }
+ res
+}
+
+
get_binary_res <- function() {
set.seed(SEED)
df_binary <- data.frame(y = rbinom(50, 1, 0.3))
@@ -230,6 +248,61 @@ get_roaches_res <- function() {
)
}
+get_roaches_compare_res <- function() {
+ data(roaches, package = "rstanarm")
+ roaches$sqrt_roach1 <- sqrt(roaches$roach1)
+
+ fit_p <- brm(
+ y ~ sqrt_roach1 + treatment + senior + offset(log(exposure2)),
+ data = roaches,
+ family = poisson,
+ prior = prior(normal(0, 1), class = b),
+ chains = 2,
+ iter = 400,
+ thin = 4,
+ refresh = 0,
+ seed = SEED
+ )
+
+ fit_p <- add_criterion(
+ fit_p,
+ criterion = "loo",
+ moment_match = TRUE,
+ save_psis = TRUE,
+ overwrite = TRUE
+ )
+
+ fit_p_m1 <- update(fit_p, formula = y ~ treatment + senior) |>
+ add_criterion(criterion = "loo", moment_match = TRUE, save_psis = TRUE)
+ fit_p_m2 <- update(fit_p, formula = y ~ sqrt_roach1 + senior) |>
+ add_criterion(criterion = "loo", moment_match = TRUE, save_psis = TRUE)
+ fit_p_m3 <- update(fit_p, formula = y ~ sqrt_roach1 + treatment) |>
+ add_criterion(criterion = "loo", moment_match = TRUE, save_psis = TRUE)
+
+ # `ypred` (posterior predictive draws) is needed by the sampling-based scores
+ # such as `rps`/`srps`; `mupred` (posterior_epred) is not enough for those.
+ set.seed(SEED)
+ return(list(
+ y = fit_p$data$y,
+ loo_p = fit_p$criteria$loo,
+ ypred = brms::posterior_predict(fit_p),
+ mupred = brms::posterior_epred(fit_p),
+ ylp = brms::log_lik(fit_p),
+ loo_p_m1 = fit_p_m1$criteria$loo,
+ ypred_m1 = brms::posterior_predict(fit_p_m1),
+ mupred_m1 = brms::posterior_epred(fit_p_m1),
+ ylp_m1 = brms::log_lik(fit_p_m1),
+ loo_p_m2 = fit_p_m2$criteria$loo,
+ ypred_m2 = brms::posterior_predict(fit_p_m2),
+ mupred_m2 = brms::posterior_epred(fit_p_m2),
+ ylp_m2 = brms::log_lik(fit_p_m2),
+ loo_p_m3 = fit_p_m3$criteria$loo,
+ ypred_m3 = brms::posterior_predict(fit_p_m3),
+ mupred_m3 = brms::posterior_epred(fit_p_m3),
+ ylp_m3 = brms::log_lik(fit_p_m3)
+ ))
+}
+
get_sleep_test_train_res <- function() {
# specifically for testing test_pred_measure
data("sleepstudy", package = "lme4")
@@ -350,14 +423,16 @@ generate_test_data <- function() {
full_binomial <- get_binomial_res()
full_sleep <- get_sleep_res()
full_sleep_test <- get_sleep_test_train_res()
+ full_roaches_compare <- get_roaches_compare_res()
test_path <- "tests/testthat/data-for-tests/"
- saveRDS(shrink_res("roaches", full_roaches$res), paste0(test_path, "test_data_roaches.Rds"))
- saveRDS(shrink_res("binary", full_binary$res), paste0(test_path, "test_data_binary.Rds"))
- saveRDS(shrink_res("categorical", full_penguins$res), paste0(test_path, "test_data_penguins.Rds"))
- saveRDS(shrink_res("binomial", full_binomial$res), paste0(test_path, "test_data_binomial.Rds"))
- saveRDS(shrink_res("sleep", full_sleep$res), paste0(test_path, "test_data_sleep.Rds"))
- saveRDS(shrink_res("sleep_test", full_sleep_test$res), paste0(test_path, "test_data_sleep_cv.Rds"))
+ saveRDS(shrink_res("roaches", full_roaches$res), paste0(test_path, "test_data_roaches.Rds"), compress = "xz")
+ saveRDS(shrink_roaches_compare(full_roaches_compare), paste0(test_path, "test_data_roaches_compare.Rds"), compress = "xz")
+ saveRDS(shrink_res("binary", full_binary$res), paste0(test_path, "test_data_binary.Rds"), compress = "xz")
+ saveRDS(shrink_res("categorical", full_penguins$res), paste0(test_path, "test_data_penguins.Rds"), compress = "xz")
+ saveRDS(shrink_res("binomial", full_binomial$res), paste0(test_path, "test_data_binomial.Rds"), compress = "xz")
+ saveRDS(shrink_res("sleep", full_sleep$res), paste0(test_path, "test_data_sleep.Rds"), compress = "xz")
+ saveRDS(shrink_res("sleep_test", full_sleep_test$res), paste0(test_path, "test_data_sleep_cv.Rds"), compress = "xz")
message("Saved test fixtures to ", test_path)
elapsed_min <- round((proc.time() - t0)[3] / 60, 1)
diff --git a/tests/testthat/data-for-tests/test_data_penguins.Rds b/tests/testthat/data-for-tests/test_data_penguins.Rds
index 7e8d7e63..9e054297 100644
Binary files a/tests/testthat/data-for-tests/test_data_penguins.Rds and b/tests/testthat/data-for-tests/test_data_penguins.Rds differ
diff --git a/tests/testthat/data-for-tests/test_data_roaches.Rds b/tests/testthat/data-for-tests/test_data_roaches.Rds
index e4da781e..0323291f 100644
Binary files a/tests/testthat/data-for-tests/test_data_roaches.Rds and b/tests/testthat/data-for-tests/test_data_roaches.Rds differ
diff --git a/tests/testthat/data-for-tests/test_data_roaches_compare.Rds b/tests/testthat/data-for-tests/test_data_roaches_compare.Rds
new file mode 100644
index 00000000..537f97bd
Binary files /dev/null and b/tests/testthat/data-for-tests/test_data_roaches_compare.Rds differ
diff --git a/tests/testthat/data-for-tests/test_data_sleep.Rds b/tests/testthat/data-for-tests/test_data_sleep.Rds
index a2a9324f..221b9da7 100644
Binary files a/tests/testthat/data-for-tests/test_data_sleep.Rds and b/tests/testthat/data-for-tests/test_data_sleep.Rds differ
diff --git a/tests/testthat/data-for-tests/test_data_sleep_cv.Rds b/tests/testthat/data-for-tests/test_data_sleep_cv.Rds
index 65920506..14a7f7a2 100644
Binary files a/tests/testthat/data-for-tests/test_data_sleep_cv.Rds and b/tests/testthat/data-for-tests/test_data_sleep_cv.Rds differ
diff --git a/tests/testthat/test_compare.R b/tests/testthat/test_compare.R
index e672ef07..b40889c3 100644
--- a/tests/testthat/test_compare.R
+++ b/tests/testthat/test_compare.R
@@ -6,62 +6,1365 @@ LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr))
w1 <- suppressWarnings(waic(LLarr))
w2 <- suppressWarnings(waic(LLarr2))
-test_that("loo_compare throws appropriate errors", {
+test_that("model_compare accepts named models in `...`", {
+ named <- suppressWarnings(model_compare(A = w1, B = w2))
+ listed <- suppressWarnings(model_compare(list(A = w1, B = w2)))
+
+ expect_equal(named, listed)
+ expect_setequal(named$model, c("A", "B"))
+ expect_error(model_compare(), "No models supplied")
+})
+
+test_that("model_compare throws appropriate errors", {
w3 <- suppressWarnings(waic(LLarr[,, -1]))
w4 <- suppressWarnings(waic(LLarr[,, -(1:2)]))
- expect_error(loo_compare(2, 3), "must be a list if not a 'loo' object")
+ expect_error(model_compare(2, 3), "must be a list if not a 'loo' or 'pred_measure' object")
expect_error(
- loo_compare(w1, w2, x = list(w1, w2)),
+ model_compare(w1, w2, x = list(w1, w2)),
"If 'x' is a list then '...' should not be specified"
)
- expect_error(loo_compare(w1, list(1, 2, 3)), "class 'loo'")
- expect_error(loo_compare(w1), "requires at least two models")
- expect_error(loo_compare(x = list(w1)), "requires at least two models")
+ expect_error(model_compare(w1, list(1, 2, 3)), "class 'loo'")
+ expect_error(model_compare(w1), "At least two models are required for comparison")
+ expect_error(model_compare(x = list(w1)), "At least two models are required for comparison")
expect_error(
- loo_compare(w1, w3),
+ model_compare(w1, w3),
"All models must have the same number of observations, but models have inconsistent observation counts: 'model1' (32), 'model2' (31)",
fixed = TRUE
)
expect_error(
- loo_compare(w1, w2, w3),
+ model_compare(w1, w2, w3),
"All models must have the same number of observations, but models have inconsistent observation counts: 'model1' (32), 'model2' (32), 'model3' (31)",
fixed = TRUE
)
expect_error(
- loo_compare(x = list("Model A" = w1, "Model B" = w2, "Model C" = w3)),
+ model_compare(x = list("Model A" = w1, "Model B" = w2, "Model C" = w3)),
"All models must have the same number of observations, but models have inconsistent observation counts: 'Model A' (32), 'Model B' (32), 'Model C' (31)",
fixed = TRUE
)
})
-test_that("loo_compare throws appropriate warnings", {
+test_that("model_compare dispatches loo_pred_measure inputs", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ pm1 <- loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ mupred = res$mupred_m1,
+ ylp = res$ylp_m1,
+ measures = c("elpd", "r2", "mse")
+ )
+ pm2 <- loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ mupred = res$mupred_m1,
+ ylp = res$ylp_m1,
+ measures = c("elpd", "r2", "mse")
+ )
+
+ comp <- suppressMessages(model_compare(pm1, pm2))
+ expect_s3_class(comp, "compare.loo")
+ expect_equal(attr(comp, "compare_measures")[[1L]], "elpd")
+ expect_true(all(c("elpd_diff", "se_diff", "p_worse", "diag_diff") %in% colnames(comp)))
+ expect_true(all(c("r2_diff", "r2_se_diff", "mse_diff", "mse_se_diff") %in% colnames(comp)))
+ expect_false(anyNA(comp$r2_se_diff))
+ expect_false(anyNA(comp$mse_se_diff))
+ expect_false("r2_loo_diff" %in% colnames(comp))
+ expect_false("mse_p_worse" %in% colnames(comp))
+
+ expect_error(
+ model_compare(w1, pm1),
+ "Cannot mix 'pred_measure' objects with plain 'loo' objects",
+ fixed = TRUE
+ )
+ expect_error(
+ model_compare(pm1),
+ "At least two models are required for comparison",
+ fixed = TRUE
+ )
+ comp_loo <- model_compare(w1, w2)
+ expect_equal(attr(comp_loo, "compare_reference"), c(elpd = comp_loo$model[[1L]]))
+})
+
+test_that("model_compare warns when predictive measures differ across models", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ pm1 <- loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ mupred = res$mupred_m1,
+ ylp = res$ylp_m1,
+ measures = c("elpd", "r2", "mse")
+ )
+ pm2 <- loo_pred_measure(
+ loo = res$loo_p_m2,
+ y = res$y,
+ mupred = res$mupred_m2,
+ ylp = res$ylp_m2,
+ measures = c("elpd", "r2", "mae")
+ )
+
+ expect_warning(
+ comp <- suppressMessages(model_compare(list(m1 = pm1, m2 = pm2))),
+ "Omitted measures: mae \\(m2\\), mse \\(m1\\)"
+ )
+ expect_equal(attr(comp, "compare_measures"), c("elpd", "r2"))
+ expect_false("mse_diff" %in% colnames(comp))
+ expect_false("mae_diff" %in% colnames(comp))
+})
+
+test_that("model_compare works with three loo_pred_measure models", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ pm1 <- loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ mupred = res$mupred_m1,
+ ylp = res$ylp_m1,
+ measures = c("elpd", "r2", "mae")
+ )
+ pm2 <- loo_pred_measure(
+ loo = res$loo_p_m2,
+ y = res$y,
+ mupred = res$mupred_m2,
+ ylp = res$ylp_m2,
+ measures = c("elpd", "r2", "mae")
+ )
+ pm3 <- loo_pred_measure(
+ loo = res$loo_p_m3,
+ y = res$y,
+ mupred = res$mupred_m3,
+ ylp = res$ylp_m3,
+ measures = c("elpd", "r2", "mae")
+ )
+
+ comp <- model_compare(list("A" = pm1, "B" = pm2, "C" = pm3))
+ expect_snapshot(print(comp))
+ expect_equal(nrow(comp), 3L)
+ expect_equal(attr(comp, "compare_measures"), c("elpd", "mae", "r2"))
+ # rows are ordered by elpd, so the elpd reference is the first row
+ expect_equal(comp$elpd_diff[1L], 0)
+ expect_true(all(comp$elpd_diff[-1L] < 0))
+ # every other measure is compared against its own best model
+ refs <- attr(comp, "compare_reference")
+ for (measure in c("r2", "mae")) {
+ diff_col <- comp[[paste0(measure, "_diff")]]
+ expect_equal(comp$model[[which.max(diff_col)]], refs[[measure]])
+ expect_true(all(diff_col <= 0))
+ }
+ expect_equal(attr(comp, "sign_converted_measures"), c("mae"))
+})
+
+test_that("print marks and explains flipped measure signs", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ pm1 <- loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ mupred = res$mupred_m1,
+ ylp = res$ylp_m1,
+ measures = c("r2", "mse")
+ )
+ pm2 <- loo_pred_measure(
+ loo = res$loo_p_m2,
+ y = res$y,
+ mupred = res$mupred_m2,
+ ylp = res$ylp_m2,
+ measures = c("r2", "mse")
+ )
+
+ comp <- model_compare(list(m1 = pm1, m2 = pm2))
+ expect_equal(attr(comp, "sign_converted_measures"), "mse")
+ expect_snapshot(print(comp, measures = "all"))
+
+ pm_elpd <- loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ mupred = res$mupred_m1,
+ ylp = res$ylp_m1
+ )
+ expect_no_message(model_compare(pm_elpd, pm_elpd))
+})
+
+test_that("each measure uses its own best model as reference", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ mk <- function(m) {
+ loo_pred_measure(
+ loo = res[[paste0("loo_p_m", m)]],
+ y = res$y,
+ mupred = res[[paste0("mupred_m", m)]],
+ ylp = res[[paste0("ylp_m", m)]],
+ measures = c("elpd", "r2", "mse", "mae")
+ )
+ }
+ pms <- list(m1 = mk(1), m2 = mk(2), m3 = mk(3))
+
+ comp <- suppressMessages(model_compare(pms))
+ refs <- attr(comp, "compare_reference")
+ expect_named(refs, c("elpd", "r2", "mse", "mae"), ignore.order = TRUE)
+
+ # rows are ordered by elpd, so the elpd reference is the first row
+ expect_equal(refs[["elpd"]], comp$model[[1L]])
+ expect_equal(comp$elpd_diff[[1L]], 0)
+
+ for (measure in c("r2", "mse", "mae")) {
+ diff_col <- comp[[paste0(measure, "_diff")]]
+ # exactly one zero difference, at that measure's own best model
+ expect_equal(sum(diff_col == 0), 1L)
+ expect_equal(comp$model[[which(diff_col == 0)]], refs[[measure]])
+ expect_true(all(diff_col <= 0))
+ }
+})
+
+test_that("each printed measure table is sorted best model first", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ mk <- function(m) {
+ loo_pred_measure(
+ loo = res[[paste0("loo_p_m", m)]],
+ y = res$y,
+ mupred = res[[paste0("mupred_m", m)]],
+ ylp = res[[paste0("ylp_m", m)]],
+ measures = c("elpd", "r2", "mse", "mae")
+ )
+ }
+ pms <- list(m1 = mk(1), m2 = mk(2), m3 = mk(3))
+
+ printed_order <- function(comp, measure) {
+ out <- utils::capture.output(
+ suppressMessages(print(comp, measures = measure))
+ )
+ # Drop everything above the measure's own table: the PSIS-LOO diagnostics
+ # block lists model names too, but says nothing about measure ordering.
+ header <- grep(paste0("^-- ", measure, " "), out)
+ out <- out[seq.int(header[[1L]] + 1L, length(out))]
+ rows <- out[grepl("^\\s+m[0-9]", out)]
+ sub("^\\s*(\\S+).*$", "\\1", rows)
+ }
+
+ comp <- suppressMessages(model_compare(pms))
+ for (measure in c("elpd", "r2", "mse", "mae")) {
+ diff_col <- if (measure == "elpd") "elpd_diff" else paste0(measure, "_diff")
+ ord <- order(comp[[diff_col]], decreasing = TRUE)
+ expect_equal(printed_order(comp, measure), comp$model[ord])
+ # the best model on the measure leads, and the table runs downhill
+ expect_equal(ord[[1L]], which.max(comp[[diff_col]]))
+ expect_false(is.unsorted(rev(comp[[diff_col]][ord])))
+ }
+})
+
+test_that("print.compare.loo works for loo_pred_measure comparisons", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ pm1 <- loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ mupred = res$mupred_m1,
+ ylp = res$ylp_m1,
+ measures = c("elpd", "r2", "mae")
+ )
+ pm2 <- loo_pred_measure(
+ loo = res$loo_p_m2,
+ y = res$y,
+ mupred = res$mupred_m2,
+ ylp = res$ylp_m2,
+ measures = c("elpd", "r2", "mae")
+ )
+ pm3 <- loo_pred_measure(
+ loo = res$loo_p_m3,
+ y = res$y,
+ mupred = res$mupred_m3,
+ ylp = res$ylp_m3,
+ measures = c("elpd", "r2", "mae")
+ )
+
+ comp <- suppressMessages(model_compare(list(m1 = pm1, m2 = pm2, m3 = pm3)))
+ expect_snapshot(print(comp))
+ expect_snapshot(print(comp, measures = "all", digits = 2))
+ expect_snapshot(print(comp, measures = "all", digits = c(r2 = 1)))
+ expect_snapshot(print(comp, measures = c("r2", "mae")))
+ expect_snapshot(print(comp, simplify = FALSE))
+ expect_snapshot(print(comp, measures = "all", simplify = FALSE))
+ # A named measure restricts the estimates to that measure alone.
+ expect_snapshot(print(comp, measures = "r2", simplify = FALSE))
+
+ expect_error(
+ print(comp, measures = "foo"),
+ "Unknown measure\\(s\\) in `measures`"
+ )
+})
+
+test_that("print names only the ranking reference with more than four measures", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ measures <- c("elpd", "mae", "mse", "rmse", "r2")
+ pms <- lapply(1:3, function(i) {
+ loo_pred_measure(
+ loo = res[[paste0("loo_p_m", i)]],
+ y = res$y,
+ mupred = res[[paste0("mupred_m", i)]],
+ ylp = res[[paste0("ylp_m", i)]],
+ measures = measures
+ )
+ })
+ names(pms) <- c("m1", "m2", "m3")
+
+ comp <- suppressMessages(model_compare(pms))
+ expect_snapshot(print(comp))
+})
+
+test_that("without `elpd` the default ranking measure is the first alphabetical one", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ mk <- function(sfx) {
+ loo_pred_measure(
+ loo = res[[paste0("loo_p_", sfx)]],
+ y = res$y,
+ mupred = res[[paste0("mupred_", sfx)]],
+ ylp = res[[paste0("ylp_", sfx)]],
+ measures = c("r2", "mse")
+ )
+ }
+ pms <- list(m1 = mk("m1"), m2 = mk("m2"))
+
+ comp <- suppressMessages(model_compare(pms))
+ expect_false("elpd" %in% attr(comp, "compare_measures"))
+ expect_false("elpd_diff" %in% colnames(comp))
+ expect_equal(attr(comp, "compare_measures")[[1L]], "mse")
+ expect_equal(comp$mse_diff[[1L]], 0)
+ expect_equal(sum(comp$mse_diff == 0), 1L)
+})
+
+test_that("the ranking measure does not depend on the model order", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ mk <- function(sfx, measures) {
+ loo_pred_measure(
+ loo = res[[paste0("loo_p_", sfx)]],
+ y = res$y,
+ mupred = res[[paste0("mupred_", sfx)]],
+ ylp = res[[paste0("ylp_", sfx)]],
+ measures = measures
+ )
+ }
+ m1 <- mk("m1", c("r2", "mse"))
+ m2 <- mk("m2", c("mse", "r2"))
+
+ comp12 <- suppressMessages(model_compare(list(m1 = m1, m2 = m2)))
+ comp21 <- suppressMessages(model_compare(list(m2 = m2, m1 = m1)))
+ expect_equal(attr(comp12, "compare_measures"), c("mse", "r2"))
+ expect_equal(attr(comp21, "compare_measures"), c("mse", "r2"))
+})
+
+test_that("model_compare measure helpers work as expected", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ pm1 <- loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ mupred = res$mupred_m1,
+ ylp = res$ylp_m1,
+ measures = c("elpd", "r2", "mse")
+ )
+ pm2 <- loo_pred_measure(
+ loo = res$loo_p_m2,
+ y = res$y,
+ mupred = res$mupred_m2,
+ ylp = res$ylp_m2,
+ measures = c("elpd", "r2", "mse")
+ )
+ loos <- list(pm1, pm2)
+ cols <- loo:::.compare_pointwise_cols(loos)
+
+ expect_equal(cols, c("elpd_loo", "mse_loo", "r2_loo"))
+ expect_equal(loo:::.compare_measures(loos), c("elpd", "mse", "r2"))
+ expect_equal(loo:::.display_name("rmse_loo"), "rmse")
+ expect_equal(loo:::.resolve_rank_measure(loos)$bare, "elpd")
+ expect_equal(loo:::.resolve_rank_measure(loos)$internal, "elpd_loo")
+ expect_true(loo:::.is_elpd_measure("elpd_loo"))
+ expect_false(loo:::.is_elpd_measure("mse_loo"))
+ expect_equal(attr(pm1, "measure_info")$elpd$diff_method, "sum")
+ expect_false(attr(pm1, "measure_info")$elpd$loss)
+ expect_false(attr(pm1, "measure_info")$r2$loss)
+ expect_equal(attr(pm1, "measure_info")$mse$loss, TRUE)
+ expect_equal(attr(pm1, "measure_info")$mse$diff_method, "mean")
+ expect_equal(attr(pm1, "measure_info")$r2$diff_method, "measure_specific")
+ expect_equal(attr(pm1, "measure_info")$r2$se_diff_fun, "r2")
+ expect_equal(
+ attr(pm1, "measure_info")$r2$extra$mse_y_i,
+ (res$y - mean(res$y))^2
+ )
+ # only measures that need it carry `extra`
+ expect_null(attr(pm1, "measure_info")$mse$extra)
+ expect_true(loo:::.measure_is_loss("mse_loo", loos))
+ expect_false(loo:::.measure_is_loss("r2_loo", loos))
+ expect_true(loo:::.measure_is_loss("mse_loo"))
+ expect_false(loo:::.measure_is_loss("r2_loo"))
+ expect_equal(
+ loo:::.compare_sign_converted_measures(c("elpd_loo", "mse_loo", "r2_loo"), loos),
+ c("mse")
+ )
+
+ pair_stats_elpd <- loo:::.pair_measure_stats(
+ pm2, pm1, "elpd_loo", "sum", loos = loos
+ )
+ expect_equal(unname(pair_stats_elpd["se"]), loo:::se_elpd_diff(
+ pm2$pointwise[, "elpd_loo"] - pm1$pointwise[, "elpd_loo"]
+ ))
+ expect_equal(
+ unname(loo:::.pair_measure_stats(pm1, pm1, "elpd_loo", "sum", loos = loos)["diff"]),
+ 0
+ )
+
+ pair_mse <- loo:::.pair_measure_stats(
+ pm2, pm1, "mse_loo", "mean", loos = loos
+ )
+ expect_equal(
+ unname(pair_mse["diff"]),
+ pm1$estimates["mse_loo", "Estimate"] - pm2$estimates["mse_loo", "Estimate"]
+ )
+ pair_r2 <- loo:::.pair_measure_stats(
+ pm2, pm1, "r2_loo", "measure_specific", loos = loos
+ )
+ expect_equal(
+ unname(pair_r2["diff"]),
+ pm2$estimates["r2_loo", "Estimate"] - pm1$estimates["r2_loo", "Estimate"]
+ )
+ expect_equal(loo:::.measure_pointwise_diff_method(loos, "mse_loo"), "mean")
+ expect_equal(loo:::.measure_pointwise_diff_method(loos, "r2_loo"), "measure_specific")
+ expect_equal(loo:::.measure_pointwise_diff_method(loos, "elpd_loo"), "sum")
+ expect_equal(
+ unname(pair_mse["se"]),
+ stats::sd(
+ pm2$pointwise[, "mse_loo"] - pm1$pointwise[, "mse_loo"]
+ ) / sqrt(nrow(pm1$pointwise))
+ )
+})
+
+test_that("rmse differences use the delta-method standard error", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ pm1 <- loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ mupred = res$mupred_m1,
+ ylp = res$ylp_m1,
+ measures = "rmse"
+ )
+ pm2 <- loo_pred_measure(
+ loo = res$loo_p_m2,
+ y = res$y,
+ mupred = res$mupred_m2,
+ ylp = res$ylp_m2,
+ measures = "rmse"
+ )
+ loos <- list(pm1, pm2)
+
+ expect_equal(loo:::.measure_pointwise_diff_method(loos, "rmse_loo"), "measure_specific")
+
+ pair <- loo:::.pair_measure_stats(pm2, pm1, "rmse_loo", loos = loos)
+
+ # rmse is a loss, so the reported difference is on the utility scale
+ expect_equal(
+ unname(pair["diff"]),
+ pm1$estimates["rmse_loo", "Estimate"] - pm2$estimates["rmse_loo", "Estimate"]
+ )
+
+ # first-order bivariate Taylor approximation propagated from the MSE scale,
+ # using the covariance between the two models' pointwise squared errors
+ sqe1 <- pm1$pointwise[, "rmse_loo"]
+ sqe2 <- pm2$pointwise[, "rmse_loo"]
+ n <- length(sqe1)
+ mse1 <- mean(sqe1)
+ mse2 <- mean(sqe2)
+ cov_mse <- sum((sqe2 - mse2) * (sqe1 - mse1)) / (n * (n - 1))
+ expected_se <- 0.5 * sqrt(
+ (var(sqe2) / n) / mse2 +
+ (var(sqe1) / n) / mse1 -
+ 2 * cov_mse / sqrt(mse2 * mse1)
+ )
+ expect_equal(unname(pair["se"]), expected_se)
+
+ # the standard error is a proper paired quantity, not a sum of the two
+ # per-model standard errors
+ expect_lt(
+ unname(pair["se"]),
+ pm1$estimates["rmse_loo", "SE"] + pm2$estimates["rmse_loo", "SE"]
+ )
+
+ # a model compared against itself has zero difference and zero uncertainty
+ self <- loo:::.pair_measure_stats(pm1, pm1, "rmse_loo", loos = loos)
+ expect_equal(unname(self["diff"]), 0)
+ expect_equal(unname(self["se"]), 0)
+
+ comp <- suppressMessages(model_compare(pm1, pm2))
+ expect_false(anyNA(comp$rmse_se_diff))
+ expect_equal(comp$rmse_se_diff[1], 0)
+})
+
+test_that("r2 differences use the delta-method standard error", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ make <- function(loo, mupred, ylp) {
+ loo_pred_measure(
+ loo = loo, y = res$y, mupred = mupred, ylp = ylp, measures = "r2"
+ )
+ }
+ pm1 <- make(res$loo_p_m1, res$mupred_m1, res$ylp_m1)
+ pm2 <- make(res$loo_p_m2, res$mupred_m2, res$ylp_m2)
+ loos <- list(pm1, pm2)
+
+ expect_equal(loo:::.measure_pointwise_diff_method(loos, "r2_loo"), "measure_specific")
+
+ pair <- loo:::.pair_measure_stats(pm2, pm1, "r2_loo", loos = loos)
+
+ # r2 is already a utility, so the difference is reported as stored
+ expect_equal(
+ unname(pair["diff"]),
+ pm2$estimates["r2_loo", "Estimate"] - pm1$estimates["r2_loo", "Estimate"]
+ )
+
+ # first-order trivariate Taylor approximation, written out term by term as in
+ # the derivation rather than in the collapsed single-variance form the
+ # implementation uses
+ sqe1 <- pm1$pointwise[, "r2_loo"]
+ sqe2 <- pm2$pointwise[, "r2_loo"]
+ d <- sqe2 - sqe1
+ n <- length(d)
+ mse_diff <- mean(d)
+ msey_i <- (res$y - mean(res$y))^2
+ mse_y <- mean(msey_i)
+ t1 <- var(d) / n
+ t2 <- -2 * (mse_diff / mse_y) *
+ (sum((d - mse_diff) * (msey_i - mse_y)) / (n * (n - 1)))
+ t3 <- (mse_diff^2 / mse_y^2) * (var(msey_i) / n)
+ expect_equal(unname(pair["se"]), sqrt(t1 + t2 + t3) / mse_y)
+
+ # the difference is also the negative MSE difference over the baseline
+ expect_equal(unname(pair["diff"]), -mse_diff / mse_y)
+
+ # the uncertainty in a difference does not depend on which model is the
+ # reference, even though the difference itself changes sign
+ swapped <- loo:::.pair_measure_stats(pm1, pm2, "r2_loo", loos = loos)
+ expect_equal(unname(swapped["se"]), unname(pair["se"]))
+ expect_equal(unname(swapped["diff"]), -unname(pair["diff"]))
+
+ # a model compared against itself has zero difference and zero uncertainty
+ self <- loo:::.pair_measure_stats(pm1, pm1, "r2_loo", loos = loos)
+ expect_equal(unname(self["diff"]), 0)
+ expect_equal(unname(self["se"]), 0)
+
+ comp <- suppressMessages(model_compare(pm1, pm2))
+ expect_false(anyNA(comp$r2_se_diff))
+ expect_equal(comp$r2_se_diff[1], 0)
+
+ # the single-model standard error is the same expansion evaluated at one
+ # model's squared errors
+ t1 <- var(sqe1) / n
+ t2 <- -2 * (mean(sqe1) / mse_y) *
+ (sum((sqe1 - mean(sqe1)) * (msey_i - mse_y)) / (n * (n - 1)))
+ t3 <- (mean(sqe1)^2 / mse_y^2) * (var(msey_i) / n)
+ expect_equal(
+ unname(pm1$estimates["r2_loo", "SE"]),
+ sqrt(t1 + t2 + t3) / mse_y
+ )
+})
+
+test_that("r2 reports the difference without an se when the baseline is gone", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ make <- function(loo, mupred, ylp) {
+ loo_pred_measure(
+ loo = loo, y = res$y, mupred = mupred, ylp = ylp, measures = "r2"
+ )
+ }
+ pm1 <- make(res$loo_p_m1, res$mupred_m1, res$ylp_m1)
+ pm2 <- make(res$loo_p_m2, res$mupred_m2, res$ylp_m2)
+
+ # objects computed before the baseline was stored
+ drop_baseline <- function(x) {
+ meta <- attr(x, "measure_info")
+ meta$r2$extra <- NULL
+ attr(x, "measure_info") <- meta
+ x
+ }
+ stale1 <- drop_baseline(pm1)
+ stale2 <- drop_baseline(pm2)
+
+ pair <- loo:::.pair_measure_stats(
+ stale2, stale1, "r2_loo", loos = list(stale1, stale2)
+ )
+ expect_equal(
+ unname(pair["diff"]),
+ pm2$estimates["r2_loo", "Estimate"] - pm1$estimates["r2_loo", "Estimate"]
+ )
+ expect_true(is.na(pair["se"]))
+
+ comp <- suppressMessages(model_compare(stale1, stale2))
+ expect_false(anyNA(comp$r2_diff))
+ expect_true(all(is.na(comp$r2_se_diff)))
+
+ # one stale model does not cost the others their standard error: the
+ # baseline is shared, so the other model's copy is used, and the metadata
+ # check ignores `extra` rather than reporting it as a disagreement
+ mixed <- suppressMessages(model_compare(stale1, pm2))
+ expect_false(anyNA(mixed$r2_se_diff))
+})
+
+# two balanced-accuracy measures over the same three-class outcome: the second
+# model has probability mass shifted towards the first (and largest) class, so
+# the two disagree on a subset of observations and the class strata are
+# unbalanced, which is where balanced accuracy differs from plain accuracy
+.make_bacc_pms <- function(bias = 0.6) {
+ res <- readRDS("data-for-tests/test_data_penguins.Rds")
+ y <- as.integer(res$y)
+ set.seed(4321)
+ ylp <- matrix(
+ rnorm(nrow(res$mupred) * ncol(res$mupred)),
+ nrow = nrow(res$mupred)
+ )
+ biased <- res$mupred
+ biased[, , 1L] <- biased[, , 1L] + bias
+ biased <- sweep(biased, c(1, 2), apply(biased, c(1, 2), sum), "/")
+
+ make <- function(mupred) {
+ suppressWarnings(loo_pred_measure(
+ ylp = ylp,
+ y = y,
+ mupred = mupred,
+ measures = "bacc"
+ ))
+ }
+ list(pm1 = make(res$mupred), pm2 = make(biased), y = y)
+}
+
+test_that("bacc differences use the stratified paired standard error", {
+ fx <- .make_bacc_pms()
+ pm1 <- fx$pm1
+ pm2 <- fx$pm2
+ loos <- list(pm1, pm2)
+
+ expect_equal(loo:::.measure_pointwise_diff_method(loos, "bacc_loo"), "measure_specific")
+ expect_equal(
+ attr(pm1, "measure_info")$bacc$se_diff_fun,
+ "bacc"
+ )
+
+ pair <- loo:::.pair_measure_stats(pm2, pm1, "bacc_loo", loos = loos)
+
+ # bacc is already a utility, so the difference is reported as stored
+ expect_equal(
+ unname(pair["diff"]),
+ pm2$estimates["bacc_loo", "Estimate"] - pm1$estimates["bacc_loo", "Estimate"]
+ )
+
+ # recover the 0/1 accuracies and check the standard error against the
+ # McNemar discordant-count form of the paired difference of proportions,
+ # written out per stratum rather than in the pointwise-variance form the
+ # implementation uses
+ class_id <- attr(pm1, "measure_info")$bacc$extra$class_id
+ n_c <- tabulate(class_id)
+ K <- length(n_c)
+ acc1 <- round(pm1$pointwise[, "bacc_loo"] * K * n_c[class_id])
+ acc2 <- round(pm2$pointwise[, "bacc_loo"] * K * n_c[class_id])
+ expect_true(all(acc1 %in% c(0, 1)) && all(acc2 %in% c(0, 1)))
+
+ v <- 0
+ for (k in seq_len(K)) {
+ in_k <- class_id == k
+ b <- sum(acc2[in_k] == 1 & acc1[in_k] == 0)
+ cc <- sum(acc2[in_k] == 0 & acc1[in_k] == 1)
+ nk <- n_c[k]
+ # the Wald paired-proportion variance, scaled by nk / (nk - 1) to match the
+ # sample variance the implementation takes
+ v <- v + ((b + cc) / nk^2 - (b - cc)^2 / nk^3) * (nk / (nk - 1))
+ }
+ expect_equal(unname(pair["se"]), sqrt(v) / K)
+
+ # the strata carry information the pointwise vector alone does not: pooling
+ # them would give a different answer, so this is not the `"mean"` path
+ d <- (pm2$pointwise[, "bacc_loo"] - pm1$pointwise[, "bacc_loo"])
+ expect_false(isTRUE(all.equal(
+ unname(pair["se"]),
+ sd(d) / sqrt(length(d))
+ )))
+
+ # the uncertainty in a difference does not depend on which model is the
+ # reference, even though the difference itself changes sign
+ swapped <- loo:::.pair_measure_stats(pm1, pm2, "bacc_loo", loos = loos)
+ expect_equal(unname(swapped["se"]), unname(pair["se"]))
+ expect_equal(unname(swapped["diff"]), -unname(pair["diff"]))
+
+ # a model compared against itself has zero difference and zero uncertainty
+ self <- loo:::.pair_measure_stats(pm1, pm1, "bacc_loo", loos = loos)
+ expect_equal(unname(self["diff"]), 0)
+ expect_equal(unname(self["se"]), 0)
+
+ comp <- suppressMessages(model_compare(pm1, pm2))
+ expect_false(anyNA(comp$bacc_se_diff))
+ expect_equal(comp$bacc_se_diff[1], 0)
+})
+
+test_that("bacc reports the difference without an se when the strata are gone", {
+ fx <- .make_bacc_pms()
+
+ # objects computed before the class strata were stored
+ drop_strata <- function(x) {
+ meta <- attr(x, "measure_info")
+ meta$bacc$extra <- NULL
+ attr(x, "measure_info") <- meta
+ x
+ }
+ stale1 <- drop_strata(fx$pm1)
+ stale2 <- drop_strata(fx$pm2)
+
+ pair <- loo:::.pair_measure_stats(
+ stale2, stale1, "bacc_loo", loos = list(stale1, stale2)
+ )
+ expect_equal(
+ unname(pair["diff"]),
+ fx$pm2$estimates["bacc_loo", "Estimate"] -
+ fx$pm1$estimates["bacc_loo", "Estimate"]
+ )
+ expect_true(is.na(pair["se"]))
+
+ # the strata are shared, so a stale model paired with a current one still
+ # gets a standard error, from whichever copy survives. `pm1` is the better
+ # model and so heads the table; staleness in `pm2` costs nothing at all
+ mixed <- suppressMessages(model_compare(fx$pm1, stale2))
+ expect_false(anyNA(mixed$bacc_se_diff))
+
+ # but a stale model at the head of the table has no second copy to fall back
+ # on for its own row, which is a comparison against itself
+ mixed_stale_first <- suppressMessages(model_compare(stale1, fx$pm2))
+ expect_true(is.na(mixed_stale_first$bacc_se_diff[1L]))
+ expect_false(is.na(mixed_stale_first$bacc_se_diff[2L]))
+})
+
+test_that("custom measures take their se_diff from their declaration", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+
+ # a custom rmse, whose estimate is neither a sum nor a mean of `pointwise`
+ my_rmse <- function(y, mupred) {
+ sqe_i <- (y - colMeans(mupred))^2
+ list(
+ estimate = sqrt(mean(sqe_i)),
+ se = sqrt(var(sqe_i) / length(sqe_i)) / (2 * sqrt(mean(sqe_i))),
+ pointwise = sqe_i
+ )
+ }
+ attr(my_rmse, "measure_name") <- "my_rmse"
+
+ make <- function(loo, mupred, ylp, fun) {
+ loo_pred_measure(
+ loo = loo, y = res$y, mupred = mupred, ylp = ylp, measures = fun
+ )
+ }
+
+ pms <- list(
+ m1 = make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, my_rmse),
+ m2 = make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, my_rmse)
+ )
+
+ # custom measures declare nothing about their standard error
+ expect_equal(
+ attr(pms[[1L]], "measure_info")$my_rmse$diff_method,
+ "custom"
+ )
+ expect_null(attr(pms[[1L]], "measure_info")$my_rmse$se_diff_fun)
+ expect_equal(
+ loo:::.measure_pointwise_diff_method(pms, "my_rmse_loo"),
+ "custom"
+ )
+
+ # the measure declares nothing, so the difference is reported with an NA
+ # standard error and a message that names the measure
+ expect_message(
+ comp_null <- model_compare(pms),
+ "my_rmse declares no `se_diff_fun`"
+ )
+ expect_false(is.na(comp_null$my_rmse_diff[[2L]]))
+ expect_true(all(is.na(comp_null$my_rmse_se_diff)))
+ expect_true(is.na(
+ loo:::.pair_measure_stats(pms[[2L]], pms[[1L]], "my_rmse_loo", loos = pms)["se"]
+ ))
+
+ # a declared function gets the delta-method standard error
+ pms_fn <- list(
+ m1 = make(res$loo_p_m1, res$mupred_m1, res$ylp_m1,
+ custom_measure(my_rmse, name = "my_rmse",
+ se_diff_fun = loo:::.se_diff_rmse)),
+ m2 = make(res$loo_p_m2, res$mupred_m2, res$ylp_m2,
+ custom_measure(my_rmse, name = "my_rmse",
+ se_diff_fun = loo:::.se_diff_rmse))
+ )
+ comp_fn <- suppressMessages(model_compare(pms_fn))
+ expect_false(any(is.na(comp_fn$my_rmse_se_diff)))
+ # `my_rmse` is compared against its own best model, which
+ # is the row with a zero difference and a zero standard error
+ ref_name <- attr(comp_fn, "compare_reference")[["my_rmse"]]
+ cmp_name <- setdiff(names(pms), ref_name)
+ ref_row <- match(ref_name, comp_fn$model)
+ cmp_row <- match(cmp_name, comp_fn$model)
+ expect_equal(comp_fn$my_rmse_se_diff[[ref_row]], 0)
+ expect_gt(comp_fn$my_rmse_se_diff[[cmp_row]], 0)
+ # the difference itself does not depend on how the SE was obtained
+ expect_equal(comp_fn$my_rmse_diff, comp_null$my_rmse_diff)
+
+ pair_ref <- loo:::.pair_measure_stats(
+ pms[[cmp_name]], pms[[ref_name]], "my_rmse_loo",
+ loos = pms, se_fn = loo:::.se_diff_rmse
+ )
+ expect_equal(unname(pair_ref["se"]), comp_fn$my_rmse_se_diff[[cmp_row]])
+
+ pair <- loo:::.pair_measure_stats(
+ pms[[2L]], pms[[1L]], "my_rmse_loo",
+ loos = pms, se_fn = loo:::.se_diff_rmse
+ )
+
+ # a custom measure can carry its own auxiliary data through to its
+ # `se_diff_fun`,
+ # and each model receives its own copy
+ my_scaled <- function(y, mupred) {
+ sqe_i <- (y - colMeans(mupred))^2
+ list(
+ estimate = sqrt(mean(sqe_i)),
+ se = sqrt(var(sqe_i) / length(sqe_i)) / (2 * sqrt(mean(sqe_i))),
+ pointwise = sqe_i,
+ extra = list(scale = stats::sd(y), n_used = length(y))
+ )
+ }
+ attr(my_scaled, "measure_name") <- "my_scaled"
+ scaled_se_fn <- function(ref, cmp) {
+ stopifnot(
+ identical(ref$extra$n_used, length(ref$pointwise)),
+ identical(cmp$extra$scale, ref$extra$scale)
+ )
+ loo:::.se_diff_rmse(ref, cmp) / ref$extra$scale
+ }
+ scaled <- list(
+ make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, my_scaled),
+ make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, my_scaled)
+ )
+ expect_equal(
+ attr(scaled[[1L]], "measure_info")$my_scaled$extra,
+ list(scale = stats::sd(res$y), n_used = length(res$y))
+ )
+ pair_scaled <- loo:::.pair_measure_stats(
+ scaled[[2L]], scaled[[1L]], "my_scaled_loo",
+ loos = scaled, se_fn = scaled_se_fn
+ )
+ expect_equal(
+ unname(pair_scaled["se"]),
+ unname(pair["se"]) / stats::sd(res$y)
+ )
+
+ # `extra` that is not a list is rejected at compute time
+ my_bad_extra <- function(y, mupred) {
+ sqe_i <- (y - colMeans(mupred))^2
+ list(
+ estimate = mean(sqe_i),
+ se = sqrt(var(sqe_i) / length(sqe_i)),
+ pointwise = sqe_i,
+ extra = 1
+ )
+ }
+ attr(my_bad_extra, "measure_name") <- "my_bad_extra"
+ expect_error(
+ make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, my_bad_extra),
+ "must be a list"
+ )
+
+ # a declared `se_diff_fun` that returns nonsense is caught
+ bad_rmse <- custom_measure(my_rmse, name = "my_rmse",
+ se_diff_fun = function(ref, cmp) c(1, 2))
+ pms_bad <- list(
+ m1 = make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, bad_rmse),
+ m2 = make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, bad_rmse)
+ )
+ expect_error(
+ suppressMessages(model_compare(pms_bad)),
+ "must return a numeric scalar"
+ )
+})
+
+test_that("a declared custom loss is compared and ranked as a loss", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+
+ # squared error, whose estimate is the mean of its pointwise values
+ make_fun <- function(declare_loss) {
+ f <- function(y, mupred) {
+ sqe <- (y - colMeans(mupred))^2
+ list(
+ estimate = mean(sqe),
+ se = sqrt(var(sqe) / length(sqe)),
+ pointwise = sqe
+ )
+ }
+ attr(f, "measure_name") <- "my_mse"
+ attr(f, "measure_se_diff") <- "mean"
+ if (declare_loss) attr(f, "measure_loss") <- TRUE
+ f
+ }
+
+ make <- function(m, fun) {
+ loo_pred_measure(
+ loo = res[[paste0("loo_p_m", m)]],
+ y = res$y,
+ mupred = res[[paste0("mupred_m", m)]],
+ ylp = res[[paste0("ylp_m", m)]],
+ measures = list("elpd", fun)
+ )
+ }
+
+ declared <- list(m1 = make(1, make_fun(TRUE)), m2 = make(2, make_fun(TRUE)))
+ plain <- list(m1 = make(1, make_fun(FALSE)), m2 = make(2, make_fun(FALSE)))
+
+ expect_true(attr(declared$m1, "measure_info")$my_mse$loss)
+ expect_true(loo:::.measure_is_loss("my_mse_loo", declared))
+ expect_false(loo:::.measure_is_loss("my_mse_loo", plain))
+
+ comp <- suppressMessages(model_compare(declared))
+ comp_plain <- suppressMessages(model_compare(plain))
+ expect_output(
+ print(comp, measures = "all"),
+ "my_mse \\(vs m[12], sign flipped\\)"
+ )
+
+ expect_equal(attr(comp, "sign_converted_measures"), "my_mse")
+ expect_length(attr(comp_plain, "sign_converted_measures"), 0L)
+
+ # same models, same measure: the declared loss and the undeclared utility
+ # disagree about which model is best, so each picks the other's reference
+ expect_false(identical(
+ attr(comp, "compare_reference")[["my_mse"]],
+ attr(comp_plain, "compare_reference")[["my_mse"]]
+ ))
+ # ... and the declared version agrees with the built-in `mse` on which model
+ # is worse
+ builtin <- list(m1 = make(1, "mse"), m2 = make(2, "mse"))
+ comp_builtin <- suppressMessages(model_compare(builtin))
+ expect_equal(comp$model, comp_builtin$model)
+ expect_equal(sign(comp$my_mse_diff), sign(comp_builtin$mse_diff))
+
+ # the declared loss takes the lowest loss as its reference
+ est <- vapply(
+ declared,
+ function(x) x$estimates["my_mse_loo", "Estimate"],
+ numeric(1)
+ )
+ expect_equal(
+ attr(comp, "compare_reference")[["my_mse"]],
+ names(which.min(est))
+ )
+
+ # models must agree on the declaration
+ expect_error(
+ suppressMessages(
+ model_compare(list(declared$m1, plain$m2))
+ ),
+ "disagree on `measure_info`"
+ )
+})
+
+test_that("`measure_se_diff` accepts the \"sum\" and \"mean\" shorthands", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+
+ # a custom measure reproducing the built-in `mae` on the utility scale. It
+ # declares `log_weights` so that it gets the same PSIS-weighted point
+ # predictions the built-in uses, and negates so that it is a genuine utility
+ # (a custom measure that does not declare `measure_loss` is one).
+ my_mae <- function(y, mupred, log_weights) {
+ w <- exp(loo:::.normalize_and_validate_log_weights(
+ log_weights = log_weights,
+ n_draws = nrow(mupred),
+ n_obs = ncol(mupred)
+ ))
+ ae_i <- -abs(y - colSums(w * mupred))
+ list(
+ estimate = mean(ae_i),
+ se = sqrt(var(ae_i) / length(ae_i)),
+ pointwise = ae_i
+ )
+ }
+ attr(my_mae, "measure_name") <- "my_mae"
+ attr(my_mae, "measure_se_diff") <- "mean"
+
+ make <- function(loo, mupred, ylp, measure) {
+ loo_pred_measure(
+ loo = loo, y = res$y, mupred = mupred, ylp = ylp, measures = measure
+ )
+ }
+
+ custom <- list(
+ make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, my_mae),
+ make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, my_mae)
+ )
+ builtin <- list(
+ make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, "mae"),
+ make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, "mae")
+ )
+
+ comp_custom <- suppressMessages(model_compare(custom))
+ comp_builtin <- suppressMessages(model_compare(builtin))
+
+ # "mean" reuses the built-in branch, so results must match `mae` exactly
+ expect_equal(comp_custom$my_mae_diff, comp_builtin$mae_diff)
+ expect_equal(comp_custom$my_mae_se_diff, comp_builtin$mae_se_diff)
+
+ # "sum" against a custom measure whose estimate is a sum of pointwise values
+ my_sum <- function(y, mupred) {
+ ae_i <- -abs(y - colMeans(mupred))
+ list(estimate = sum(ae_i), se = sqrt(length(ae_i) * var(ae_i)),
+ pointwise = ae_i)
+ }
+ attr(my_sum, "measure_name") <- "my_sum"
+ attr(my_sum, "measure_se_diff") <- "sum"
+ # named so that the comparison's row order can be mapped back to the inputs
+ summed <- list(
+ a = make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, my_sum),
+ b = make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, my_sum)
+ )
+ comp_sum <- suppressMessages(model_compare(summed))
+ expect_false(any(is.na(comp_sum$my_sum_se_diff)))
+
+ # matches `sqrt(N) * sd(d_i)` computed by hand from the pointwise columns
+ ref_pw <- summed[[comp_sum$model[[1L]]]]$pointwise[, "my_sum_loo"]
+ cmp_pw <- summed[[comp_sum$model[[2L]]]]$pointwise[, "my_sum_loo"]
+ d <- cmp_pw - ref_pw
+ expect_equal(comp_sum$my_sum_se_diff[[2L]], sqrt(length(d)) * sd(d))
+ expect_equal(comp_sum$my_sum_diff[[2L]], sum(d))
+
+ # a declared aggregation that does not reproduce the estimate warns
+ my_rmse <- function(y, mupred) {
+ sqe_i <- (y - colMeans(mupred))^2
+ list(
+ estimate = sqrt(mean(sqe_i)),
+ se = sqrt(var(sqe_i) / length(sqe_i)) / (2 * sqrt(mean(sqe_i))),
+ pointwise = sqe_i
+ )
+ }
+ attr(my_rmse, "measure_name") <- "my_rmse"
+ attr(my_rmse, "measure_se_diff") <- "mean"
+ mismatched <- list(
+ make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, my_rmse),
+ make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, my_rmse)
+ )
+ expect_warning(
+ suppressMessages(model_compare(mismatched)),
+ "does not reproduce its estimate"
+ )
+
+ # any other string is rejected when the measure is defined
+ expect_error(
+ custom_measure(my_mae, name = "my_mae", se_diff_fun = "median"),
+ "must be a function"
+ )
+})
+
+test_that("a custom measure can declare `measure_se_diff` itself", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+
+ make_fun <- function(name, se_diff = NULL) {
+ f <- function(y, mupred) {
+ ae_i <- abs(y - colMeans(mupred))
+ list(estimate = mean(ae_i), se = sqrt(var(ae_i) / length(ae_i)),
+ pointwise = ae_i)
+ }
+ attr(f, "measure_name") <- name
+ if (!is.null(se_diff)) attr(f, "measure_se_diff") <- se_diff
+ f
+ }
+ make <- function(loo, mupred, ylp, measure) {
+ loo_pred_measure(
+ loo = loo, y = res$y, mupred = mupred, ylp = ylp, measures = measure
+ )
+ }
+ pms <- function(measure) {
+ list(
+ make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, measure),
+ make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, measure)
+ )
+ }
+
+ declared <- pms(make_fun("m_a", se_diff = "mean"))
+ plain <- pms(make_fun("m_a"))
+
+ # the declaration is recorded on the result object
+ expect_equal(attr(declared[[1L]], "measure_info")$m_a$se_diff_fun, "mean")
+
+ # so the comparison needs no argument
+ comp <- suppressMessages(model_compare(declared))
+ expect_false(any(is.na(comp$m_a_se_diff)))
+
+ # a measure that declares nothing gets an NA standard error and a message,
+ # but its difference is still reported
+ expect_message(
+ comp_plain <- model_compare(plain),
+ "m_a declares no `se_diff_fun`"
+ )
+ expect_true(all(is.na(comp_plain$m_a_se_diff)))
+ expect_equal(comp_plain$m_a_diff, comp$m_a_diff)
+
+ # declared and undeclared measures can be compared together; the message
+ # names only the undeclared one
+ mixed <- pms(list(m_a = make_fun("m_a", se_diff = "mean"),
+ m_b = make_fun("m_b")))
+ expect_message(
+ comp_mixed <- model_compare(mixed),
+ "Custom measure m_b declares"
+ )
+ expect_false(any(is.na(comp_mixed$m_a_se_diff)))
+ expect_true(all(is.na(comp_mixed$m_b_se_diff)))
+
+ # `custom_measure()` records the same declaration as the attribute
+ wrapped <- pms(custom_measure(
+ function(y, mupred) {
+ ae_i <- abs(y - colMeans(mupred))
+ list(estimate = mean(ae_i), se = sqrt(var(ae_i) / length(ae_i)),
+ pointwise = ae_i)
+ },
+ name = "m_a",
+ se_diff_fun = "mean"
+ ))
+ expect_equal(
+ suppressMessages(model_compare(wrapped))$m_a_se_diff,
+ comp$m_a_se_diff
+ )
+
+ # an invalid declaration points to `custom_measure()`
+ expect_error(
+ make(res$loo_p_m1, res$mupred_m1, res$ylp_m1,
+ make_fun("m_a", se_diff = "median")),
+ "se_diff_fun.*custom_measure"
+ )
+
+ # the models must agree on the declaration
+ expect_error(
+ suppressMessages(model_compare(list(declared[[1L]], plain[[2L]]))),
+ "disagree on .measure_info"
+ )
+})
+
+test_that("a custom measure whose name starts with `p_` is compared", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+
+ p_hit <- custom_measure(
+ function(y, mupred) {
+ ae_i <- abs(y - colMeans(mupred))
+ list(estimate = mean(ae_i), se = sqrt(var(ae_i) / length(ae_i)),
+ pointwise = ae_i)
+ },
+ name = "p_hit",
+ se_diff_fun = "mean"
+ )
+ make <- function(loo, mupred, ylp) {
+ loo_pred_measure(
+ loo = loo, y = res$y, mupred = mupred, ylp = ylp, measures = p_hit
+ )
+ }
+ pms <- list(
+ make(res$loo_p_m1, res$mupred_m1, res$ylp_m1),
+ make(res$loo_p_m2, res$mupred_m2, res$ylp_m2)
+ )
+
+ comp <- suppressMessages(model_compare(pms))
+ expect_true("p_hit_diff" %in% colnames(comp))
+ expect_false(any(grepl("^p_loo", colnames(comp))))
+})
+
+test_that("model_compare errors on inconsistent measure metadata", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ # the same custom measure, but only one model declares it a loss
+ make_fun <- function(loss) {
+ fun <- function(y, mupred) {
+ e <- (y - colMeans(mupred))^2
+ list(estimate = mean(e), se = sd(e) / sqrt(length(e)), pointwise = e)
+ }
+ attr(fun, "measure_loss") <- loss
+ fun
+ }
+ make <- function(loo, mupred, ylp, fun) {
+ loo_pred_measure(
+ loo = loo,
+ y = res$y,
+ mupred = mupred,
+ ylp = ylp,
+ measures = list(my_mse = fun)
+ )
+ }
+ pm1 <- make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, make_fun(TRUE))
+ pm2 <- make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, make_fun(FALSE))
+
+ expect_error(
+ suppressMessages(model_compare(pm1, pm2)),
+ "disagree on `measure_info` for measure 'my_mse'"
+ )
+})
+
+test_that("model_compare errors when compare metadata is missing on some models", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ pm1 <- loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ mupred = res$mupred_m1,
+ ylp = res$ylp_m1,
+ measures = "mse"
+ )
+ pm2 <- loo_pred_measure(
+ loo = res$loo_p_m2,
+ y = res$y,
+ mupred = res$mupred_m2,
+ ylp = res$ylp_m2,
+ measures = "mse"
+ )
+ measure_info <- attr(pm2, "measure_info")
+ measure_info$mse <- NULL
+ attr(pm2, "measure_info") <- measure_info
+
+ expect_error(
+ suppressMessages(model_compare(pm1, pm2)),
+ "Not all models provide `measure_info` for measure 'mse'"
+ )
+})
+
+.make_compare_pm <- function(res, model = 1L, measure, extra_args = list()) {
+ suffix <- model
+ args <- c(
+ list(
+ loo = res[[paste0("loo_p_m", suffix)]],
+ y = res$y,
+ mupred = res[[paste0("mupred_m", suffix)]],
+ ylp = res[[paste0("ylp_m", suffix)]],
+ measures = c("elpd", measure)
+ ),
+ extra_args
+ )
+ do.call(loo_pred_measure, args)
+}
+
+.make_compare_pm_synthetic <- function(measure) {
+ if (measure == "brier") {
+ res_binary <- readRDS("data-for-tests/test_data_binary.Rds")
+ ylp <- matrix(
+ rnorm(nrow(res_binary$ypred) * ncol(res_binary$ypred)),
+ nrow = nrow(res_binary$ypred)
+ )
+ return(loo_pred_measure(
+ ylp = ylp,
+ y = res_binary$y,
+ ypred = res_binary$ypred,
+ measures = c("elpd", measure)
+ ))
+ }
+ if (measure %in% c("acc", "bacc")) {
+ res_cat <- readRDS("data-for-tests/test_data_penguins.Rds")
+ ylp <- matrix(
+ rnorm(nrow(res_cat$mupred) * ncol(res_cat$mupred)),
+ nrow = nrow(res_cat$mupred)
+ )
+ return(loo_pred_measure(
+ ylp = ylp,
+ y = as.integer(res_cat$y),
+ mupred = res_cat$mupred,
+ measures = c("elpd", measure)
+ ))
+ }
+ stop("Unsupported synthetic measure: ", measure)
+}
+
+test_that("model_compare works for all built-in measures", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ roaches_measures <- c(
+ "ic", "mlpd", "mae", "r2", "rmse", "mse"
+ )
+ for (measure in roaches_measures) {
+ pm1 <- .make_compare_pm(res, 1L, measure)
+ pm2 <- .make_compare_pm(res, 2L, measure)
+ comp <- suppressMessages(model_compare(pm1, pm2))
+ expect_true(paste0(measure, "_diff") %in% colnames(comp), info = measure)
+ expect_equal(attr(comp, "compare_measures"), c("elpd", measure), info = measure)
+ }
+
+ for (measure in c("rps", "srps")) {
+ pm1 <- loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ ypred = res$ypred_m1,
+ ylp = res$ylp_m1,
+ measures = c("elpd", measure)
+ )
+ pm2 <- loo_pred_measure(
+ loo = res$loo_p_m2,
+ y = res$y,
+ ypred = res$ypred_m2,
+ ylp = res$ylp_m2,
+ measures = c("elpd", measure)
+ )
+ comp <- suppressMessages(model_compare(pm1, pm2))
+ expect_true(paste0(measure, "_diff") %in% colnames(comp), info = measure)
+ expect_equal(attr(comp, "compare_measures"), c("elpd", measure), info = measure)
+ }
+
+ for (measure in c("brier", "acc", "bacc")) {
+ pm1 <- .make_compare_pm_synthetic(measure)
+ pm2 <- .make_compare_pm_synthetic(measure)
+ comp <- suppressMessages(model_compare(pm1, pm2))
+ expect_true(paste0(measure, "_diff") %in% colnames(comp), info = measure)
+ expect_equal(attr(comp, "compare_measures"), c("elpd", measure), info = measure)
+ }
+})
+
+.make_many_compare_pms <- function(res, n, noise_scale = 0.01) {
+ lapply(seq_len(n), function(i) {
+ loo_pred_measure(
+ loo = res$loo_p_m1,
+ y = res$y,
+ mupred = res$mupred_m1 + rnorm(length(res$y), 0, noise_scale * i),
+ ylp = res$ylp_m1,
+ measures = c("elpd", "mae")
+ )
+ })
+}
+
+test_that("model_compare warns for many loo_pred_measure models", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ set.seed(123)
+ pm_list <- .make_many_compare_pms(res, 25L)
+ expect_warning(
+ suppressMessages(model_compare(pm_list)),
+ "Difference in performance potentially due to chance. See McLatchie and Vehtari (2023) for details.",
+ fixed = TRUE
+ )
+
+ pm_list_short <- .make_many_compare_pms(res, 4L)
+ expect_no_warning(suppressMessages(model_compare(pm_list_short)))
+})
+
+test_that("model_compare throws appropriate warnings", {
w3 <- w1
w4 <- w2
class(w3) <- class(w4) <- c("kfold", "loo")
attr(w3, "K") <- 2
attr(w4, "K") <- 3
expect_warning(
- loo_compare(w3, w4),
+ model_compare(w3, w4),
"Not all kfold objects have the same K value"
)
+test_that("print warns that `measures` is ignored for 'loo' comparisons", {
+ comp <- model_compare(w1, w2)
+ expect_warning(
+ capture.output(print(comp, measures = "mse")),
+ "`measures` is ignored"
+ )
+ expect_no_warning(capture.output(print(comp, measures = "all")))
+ expect_no_warning(capture.output(print(comp, measures = "elpd")))
+})
+
class(w4) <- c("psis_loo", "loo")
attr(w4, "K") <- NULL
- expect_warning(loo_compare(w3, w4), "Comparing LOO-CV to K-fold-CV")
+ expect_warning(model_compare(w3, w4), "Comparing LOO-CV to K-fold-CV")
w3 <- w1
w4 <- w2
attr(w3, "yhash") <- "a"
attr(w4, "yhash") <- "b"
- expect_warning(loo_compare(w3, w4), "Not all models have the same y variable")
+ expect_warning(model_compare(w3, w4), "Not all models have the same y variable")
set.seed(123)
w_list <- lapply(1:25, function(x) {
suppressWarnings(waic(LLarr + rnorm(1, 0, 0.1)))
})
expect_warning(
- loo_compare(w_list),
+ model_compare(w_list),
"Difference in performance potentially due to chance. See McLatchie and Vehtari (2023) for details.",
fixed = TRUE
)
@@ -69,7 +1372,7 @@ test_that("loo_compare throws appropriate warnings", {
w_list_short <- lapply(1:4, function(x) {
suppressWarnings(waic(LLarr + rnorm(1, 0, 0.1)))
})
- expect_no_warning(loo_compare(w_list_short))
+ expect_no_warning(model_compare(w_list_short))
})
@@ -88,8 +1391,8 @@ comp_colnames <- c(
"se_waic"
)
-test_that("loo_compare returns expected results (2 models)", {
- comp1 <- loo_compare(w1, w1)
+test_that("model_compare returns expected results (2 models)", {
+ comp1 <- model_compare(w1, w1)
expect_s3_class(comp1, "compare.loo")
expect_s3_class(comp1, "data.frame")
expect_equal(colnames(comp1), comp_colnames)
@@ -100,7 +1403,7 @@ test_that("loo_compare returns expected results (2 models)", {
expect_snapshot_value(comp1, style = "serialize")
expect_snapshot(print(comp1))
- comp2 <- loo_compare(w1, w2)
+ comp2 <- model_compare(w1, w2)
expect_s3_class(comp2, "compare.loo")
expect_equal(colnames(comp2), comp_colnames)
expect_equal(comp2$p_worse, c(NA, 1))
@@ -113,16 +1416,16 @@ test_that("loo_compare returns expected results (2 models)", {
expect_snapshot(print(comp2, simplify = FALSE, p_worse = FALSE))
# specifying objects via ... and via arg x gives equal results
- expect_equal(comp2, loo_compare(x = list(w1, w2)))
+ expect_equal(comp2, model_compare(x = list(w1, w2)))
# custom naming works
- comp3 <- loo_compare(x = list("A" = w2, "B" = w1))
+ comp3 <- model_compare(x = list("A" = w2, "B" = w1))
expect_equal(comp3$model, c("B", "A"))
})
-test_that("loo_compare returns expected result (3 models)", {
+test_that("model_compare returns expected result (3 models)", {
w3 <- suppressWarnings(waic(LLarr3))
- comp1 <- loo_compare(w1, w2, w3)
+ comp1 <- model_compare(w1, w2, w3)
expect_equal(colnames(comp1), comp_colnames)
expect_equal(comp1$model, c("model1", "model2", "model3"))
@@ -135,15 +1438,15 @@ test_that("loo_compare returns expected result (3 models)", {
# specifying objects via '...' gives equivalent results (equal
# except rownames) to using 'x' argument
- expect_equal(comp1, loo_compare(x = list(w1, w2, w3)), ignore_attr = TRUE)
+ expect_equal(comp1, model_compare(x = list(w1, w2, w3)), ignore_attr = TRUE)
})
-test_that("loo_compare with simplify=FALSE returns expected result", {
+test_that("model_compare with simplify=FALSE returns expected result", {
LL <- example_loglik_array()
loo1 <- loo(LL)
loo2 <- loo(LL + 1)
loo3 <- loo(LL + 2)
- comp <- loo_compare(loo1, loo2, loo3)
+ comp <- model_compare(loo1, loo2, loo3)
expect_snapshot(print(comp, simplify = FALSE))
})
@@ -224,3 +1527,338 @@ test_that("compare throws appropriate errors", {
"same number of data points"
)
})
+
+# model_compare across evaluation sources -----------------------------------
+
+.compare_src_res <- function() readRDS("data-for-tests/test_data_roaches.Rds")
+
+.jitter_mupred <- function(mupred, sd) {
+ mupred + stats::rnorm(length(mupred), 0, sd)
+}
+
+test_that("model_compare compares kfold_pred_measure objects", {
+ res <- .compare_src_res()
+ set.seed(4321)
+ k1 <- kfold_pred_measure(
+ y = res$y, mupred = res$mupred, kfold = res$kfold,
+ measures = c("elpd", "rmse", "mse")
+ )
+ k2 <- kfold_pred_measure(
+ y = res$y, mupred = .jitter_mupred(res$mupred, 3), kfold = res$kfold,
+ measures = c("elpd", "rmse", "mse")
+ )
+
+ comp <- suppressMessages(model_compare(list(m1 = k1, m2 = k2)))
+ expect_s3_class(comp, "compare.loo")
+ expect_equal(attr(comp, "compare_source"), "kfold")
+ expect_equal(attr(comp, "compare_measures"), c("elpd", "mse", "rmse"))
+
+ # measures are matched on bare names, with the `_kfold` suffix stripped
+ expect_true(all(c("rmse_diff", "rmse_se_diff", "mse_diff", "mse_se_diff") %in%
+ colnames(comp)))
+ expect_false(any(grepl("_kfold_diff$", colnames(comp))))
+ expect_false(anyNA(comp$rmse_se_diff))
+
+ # Pareto k diagnostics do not exist outside PSIS-LOO
+ expect_false("diag_elpd" %in% colnames(comp))
+ # ELPD-only columns are still produced
+ expect_true(all(c("elpd_diff", "se_diff", "p_worse", "diag_diff") %in%
+ colnames(comp)))
+})
+
+test_that("model_compare compares test_pred_measure objects", {
+ res_cv <- readRDS("data-for-tests/test_data_sleep_cv.Rds")
+ set.seed(4321)
+ t1 <- test_pred_measure(
+ y = res_cv$y_test, mupred = res_cv$mupred_test,
+ ylp_test = res_cv$ylp_test, measures = c("elpd", "rmse")
+ )
+ t2 <- test_pred_measure(
+ y = res_cv$y_test, mupred = .jitter_mupred(res_cv$mupred_test, 5),
+ ylp_test = res_cv$ylp_test, measures = c("elpd", "rmse")
+ )
+
+ comp <- suppressMessages(model_compare(list(m1 = t1, m2 = t2)))
+ expect_equal(attr(comp, "compare_source"), "test")
+ expect_equal(attr(comp, "compare_measures"), c("elpd", "rmse"))
+ expect_true(all(c("rmse_diff", "rmse_se_diff") %in% colnames(comp)))
+ expect_false("diag_elpd" %in% colnames(comp))
+})
+
+test_that("model_compare warns that insample_pred_measure comparisons are biased", {
+ res <- .compare_src_res()
+ set.seed(4321)
+ i1 <- insample_pred_measure(
+ y = res$y, mupred = res$mupred, ylp = res$ylp, measures = c("elpd", "rmse")
+ )
+ i2 <- insample_pred_measure(
+ y = res$y, mupred = .jitter_mupred(res$mupred, 3), ylp = res$ylp,
+ measures = c("elpd", "rmse")
+ )
+
+ expect_warning(
+ comp <- suppressMessages(model_compare(list(m1 = i1, m2 = i2))),
+ "optimistically biased"
+ )
+ expect_equal(attr(comp, "compare_source"), "insample")
+ # in-sample measures carry no suffix at all
+ expect_equal(attr(comp, "compare_measures"), c("elpd", "rmse"))
+ expect_true(all(c("rmse_diff", "rmse_se_diff") %in% colnames(comp)))
+})
+
+test_that("model_compare errors when evaluation sources are mixed", {
+ res <- .compare_src_res()
+ k1 <- kfold_pred_measure(y = res$y, mupred = res$mupred, kfold = res$kfold,
+ measures = "rmse")
+ l1 <- loo_pred_measure(loo = res$loo, y = res$y, mupred = res$mupred,
+ measures = "rmse")
+ i1 <- insample_pred_measure(y = res$y, mupred = res$mupred, ylp = res$ylp,
+ measures = "rmse")
+
+ # all three have the same number of observations, so this is genuinely the
+ # source check firing rather than the observation-count check
+ expect_equal(nrow(k1$pointwise), nrow(l1$pointwise))
+ expect_error(
+ model_compare(k1, l1),
+ "All models must be evaluated on the same source",
+ fixed = TRUE
+ )
+ expect_error(
+ model_compare(l1, i1),
+ "All models must be evaluated on the same source",
+ fixed = TRUE
+ )
+})
+
+test_that("model_compare warns when kfold results use different K", {
+ res <- .compare_src_res()
+ set.seed(4321)
+ k1 <- kfold_pred_measure(y = res$y, mupred = res$mupred, kfold = res$kfold,
+ measures = "rmse")
+ k2 <- kfold_pred_measure(y = res$y, mupred = .jitter_mupred(res$mupred, 3),
+ kfold = res$kfold, measures = "rmse")
+ attr(k2, "K") <- 5L
+
+ expect_warning(
+ suppressMessages(model_compare(list(m1 = k1, m2 = k2))),
+ "Not all kfold objects have the same K value"
+ )
+})
+
+test_that("model_compare warns when kfold results use different folds", {
+ res <- .compare_src_res()
+ set.seed(4321)
+ kf2 <- res$kfold
+ attr(kf2, "folds") <- sample(attr(res$kfold, "folds"))
+
+ k1 <- kfold_pred_measure(y = res$y, mupred = res$mupred, kfold = res$kfold,
+ measures = "rmse")
+ k2 <- kfold_pred_measure(y = res$y, mupred = .jitter_mupred(res$mupred, 3),
+ kfold = kf2, measures = "rmse")
+
+ expect_warning(
+ suppressMessages(model_compare(list(m1 = k1, m2 = k2))),
+ "Not all kfold objects use the same fold assignment"
+ )
+})
+
+test_that("diag_diff flags the magnitude of elpd_diff, not its sign", {
+ expect_equal(diag_diff(500, c(0, -2, 2, -10, 10)),
+ c("", "|elpd_diff| < 4", "|elpd_diff| < 4", "", ""))
+ # small N takes priority over the difference itself, for every non-reference
+ expect_equal(diag_diff(50, c(0, -2, 10)), c("", "N < 100", "N < 100"))
+})
+
+test_that("printed comparison output stays within 80 columns", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ mk <- function(m) {
+ loo_pred_measure(
+ loo = res[[paste0("loo_p_m", m)]],
+ y = res$y,
+ mupred = res[[paste0("mupred_m", m)]],
+ ylp = res[[paste0("ylp_m", m)]],
+ measures = c("r2", "mse", "mae")
+ )
+ }
+ # long names stress both the wrapped sentences and the table layout
+ nms <- c(
+ "poisson_baseline_model",
+ "negbin_pretreatment_model",
+ "poisson_full_interaction_model"
+ )
+ pms <- stats::setNames(lapply(1:3, mk), nms)
+ comp <- suppressMessages(model_compare(pms))
+
+ for (measures in list(NULL, "all", c("r2", "mae"))) {
+ out <- utils::capture.output(
+ suppressMessages(print(comp, measures = measures))
+ )
+ expect_true(all(nchar(out) <= 80))
+ }
+})
+
+# Tests for deprecated loo_compare() --------------------------------------
+
+test_that("loo_compare throws a deprecation warning once per session", {
+ # forget that the warning was already issued earlier in this session
+ forget_warning <- function() {
+ assign("loo_compare", FALSE, envir = environment(loo:::.deprecate_once)$state)
+ }
+ forget_warning()
+ on.exit(forget_warning(), add = TRUE)
+
+ expect_warning(loo_compare(w1, w2), "deprecated")
+ # already warned in this session, so these are silent
+ expect_no_warning(loo_compare(w1, w2))
+ expect_no_warning(loo_compare(x = list(w1, w2)))
+
+ forget_warning()
+ expect_warning(loo_compare(x = list(w1, w2)), "deprecated")
+})
+
+test_that("loo_compare still returns what model_compare returns", {
+ expect_identical(suppressWarnings(loo_compare(w1, w2)), model_compare(w1, w2))
+ expect_identical(
+ suppressWarnings(loo_compare(x = list("A" = w1, "B" = w2))),
+ model_compare(x = list("A" = w1, "B" = w2))
+ )
+})
+
+test_that("loo_compare is frozen to classic elpd comparison", {
+ res <- .compare_src_res()
+ set.seed(4321)
+ k1 <- kfold_pred_measure(y = res$y, mupred = res$mupred, kfold = res$kfold,
+ measures = "rmse")
+ k2 <- kfold_pred_measure(y = res$y, mupred = .jitter_mupred(res$mupred, 3),
+ kfold = res$kfold, measures = "rmse")
+
+ expect_error(
+ suppressWarnings(loo_compare(k1, k2)),
+ "Use `model_compare()` to compare 'pred_measure' results",
+ fixed = TRUE
+ )
+})
+
+test_that("loo_compare is still a generic", {
+ # methods registered elsewhere (e.g. brms, rstanarm) keep dispatching
+ assign("loo_compare.fake_fit", function(x, ...) "dispatched", envir = globalenv())
+ on.exit(rm("loo_compare.fake_fit", envir = globalenv()), add = TRUE)
+ expect_identical(loo_compare(structure(list(), class = "fake_fit")), "dispatched")
+})
+
+test_that("print.compare.loo names the source for non-loo comparisons", {
+ res <- .compare_src_res()
+ set.seed(4321)
+ k1 <- kfold_pred_measure(y = res$y, mupred = res$mupred, kfold = res$kfold,
+ measures = "rmse")
+ k2 <- kfold_pred_measure(y = res$y, mupred = .jitter_mupred(res$mupred, 3),
+ kfold = res$kfold, measures = "rmse")
+ comp <- suppressMessages(model_compare(list(m1 = k1, m2 = k2)))
+
+ # the fold count qualifies a k-fold comparison
+ expect_output(print(comp), "10-fold cross-validation", fixed = TRUE)
+ expect_equal(attr(comp, "compare_K"), 10)
+
+ # the held-out size qualifies a test comparison
+ res_cv <- readRDS("data-for-tests/test_data_sleep_cv.Rds")
+ t1 <- test_pred_measure(
+ y = res_cv$y_test, mupred = res_cv$mupred_test,
+ ylp_test = res_cv$ylp_test, measures = "rmse"
+ )
+ t2 <- test_pred_measure(
+ y = res_cv$y_test, mupred = .jitter_mupred(res_cv$mupred_test, 5),
+ ylp_test = res_cv$ylp_test, measures = "rmse"
+ )
+ comp_test <- suppressMessages(model_compare(list(m1 = t1, m2 = t2)))
+ expect_output(
+ print(comp_test),
+ paste0("held-out test data (N = ", length(res_cv$y_test), ")"),
+ fixed = TRUE
+ )
+
+ # LOO is the default and stays unlabelled
+ l1 <- loo_pred_measure(loo = res$loo, y = res$y, mupred = res$mupred,
+ measures = "rmse")
+ l2 <- loo_pred_measure(loo = res$loo, y = res$y,
+ mupred = .jitter_mupred(res$mupred, 3),
+ measures = "rmse")
+ comp_loo <- suppressMessages(model_compare(list(m1 = l1, m2 = l2)))
+ expect_no_match(
+ paste(capture.output(print(comp_loo)), collapse = "\n"),
+ "evaluated on",
+ fixed = TRUE
+ )
+})
+
+test_that("rps is sign-converted for comparison but srps is not", {
+ set.seed(20250826)
+ S <- 400L
+ n <- 60L
+ y <- rnorm(n)
+ # the second model is the misspecified one under both scores
+ good <- matrix(rnorm(S * n), nrow = S)
+ bad <- matrix(rnorm(S * n, mean = 2, sd = 3), nrow = S)
+ make <- function(ypred) {
+ insample_pred_measure(
+ y = y,
+ ypred = ypred,
+ ylp = matrix(dnorm(rep(y, each = S), log = TRUE), nrow = S),
+ measures = c("rps", "srps")
+ )
+ }
+ pm1 <- make(good)
+ pm2 <- make(bad)
+ expect_false(anyNA(pm1$estimates))
+ expect_false(anyNA(pm2$estimates))
+
+ comp <- suppressMessages(model_compare(list(m1 = pm1, m2 = pm2)))
+
+ # the unscaled score is a loss, so it is flipped onto the utility scale; the
+ # scaled score already is a utility
+ expect_equal(attr(comp, "sign_converted_measures"), "rps")
+
+ # both differences are then on a utility scale: the best model has 0 and the
+ # other a non-positive difference
+ expect_true(all(comp$rps_diff <= 0))
+ expect_true(all(comp$srps_diff <= 0))
+
+ # the reference follows the same orientation: the well-specified model must
+ # be the reference under both scores
+ expect_equal(
+ unname(attr(comp, "compare_reference")[c("rps", "srps")]),
+ c("m1", "m1")
+ )
+})
+
+test_that("control scaled = TRUE does not invert the srps ranking", {
+ res <- readRDS("data-for-tests/test_data_roaches_compare.Rds")
+ mk <- function(sfx, measure, control = list()) {
+ loo_pred_measure(
+ loo = res[[paste0("loo_p_", sfx)]],
+ y = res$y,
+ ypred = res[[paste0("ypred_", sfx)]],
+ ylp = res[[paste0("ylp_", sfx)]],
+ measures = c("elpd", measure),
+ control = control
+ )
+ }
+ scaled <- list(rps = list(scaled = TRUE))
+ by_name <- list(m1 = mk("m1", "srps"), m2 = mk("m2", "srps"))
+ by_ctrl <- list(
+ m1 = mk("m1", "rps", scaled),
+ m2 = mk("m2", "rps", scaled)
+ )
+
+ # the scaled result renames itself to `srps`, so it must carry the `srps`
+ # orientation and not the `rps` one
+ expect_equal(rownames(by_ctrl$m1$estimates), c("elpd_loo", "p_loo", "srps_loo"))
+ expect_false(attr(by_ctrl$m1, "measure_info")$srps$loss)
+
+ cmp_name <- suppressMessages(model_compare(by_name))
+ cmp_ctrl <- suppressMessages(model_compare(by_ctrl))
+
+ # a utility is never sign-converted, whichever route requested it
+ expect_equal(attr(cmp_ctrl, "sign_converted_measures"), character(0))
+ expect_equal(cmp_ctrl$model, cmp_name$model)
+ expect_equal(cmp_ctrl$srps_diff, cmp_name$srps_diff)
+})
diff --git a/tests/testthat/test_crps.R b/tests/testthat/test_crps.R
index a0e24d04..0e9c4cdb 100644
--- a/tests/testthat/test_crps.R
+++ b/tests/testthat/test_crps.R
@@ -74,10 +74,10 @@ test_that("methods for single data point don't error", {
# See notes/developer-notes.Rmd ("CRPS / RPS numerical comparison") for details.
# -------------------------------------------------------------------------
+# Deliberately calls the package's own estimator rather than restating the
+# formula, so the two cannot drift apart.
.exx_pwm <- function(ypred) {
- n_draws <- nrow(ypred)
- ypred_sorted <- apply(ypred, 2, sort)
- colMeans(ypred_sorted * ((seq_len(n_draws) * (4 / (n_draws - 1))) - 2))
+ loo:::.exx_pwm(ypred)
}
.exy_crps <- function(ypred, y) {
@@ -92,19 +92,18 @@ test_that("methods for single data point don't error", {
list(y = y, x1 = x1, x2 = x2)
}
-test_that("measure_rps(higher_is_better = FALSE) matches deprecated crps() sign convention", {
+test_that("the deprecated crps() is the negated measure_rps()", {
d <- .crps_draws()
old <- suppressWarnings(crps(d$x1, d$x2, d$y))
- new_rev <- measure_rps(d$y, d$x1, higher_is_better = TRUE)
+ # `measure_rps()` returns the Gneiting & Raftery (2007) loss; `crps()`
+ # returned its negation. The two use different estimators, so they agree in
+ # direction and closely, but not exactly.
+ negated <- -as.vector(measure_rps(d$y, d$x1)$pointwise)
- expect_equal(
- as.vector(new_rev$pointwise),
- -as.vector(measure_rps(d$y, d$x1)$pointwise)
- )
- expect_gt(cor(old$pointwise, as.vector(new_rev$pointwise)), 0.98)
+ expect_gt(cor(old$pointwise, negated), 0.98)
expect_false(isTRUE(all.equal(
old$pointwise,
- as.vector(new_rev$pointwise),
+ negated,
tolerance = 1e-6
)))
})
diff --git a/tests/testthat/test_loo_moment_matching.R b/tests/testthat/test_loo_moment_matching.R
index 58325a29..2e7a5ae0 100644
--- a/tests/testthat/test_loo_moment_matching.R
+++ b/tests/testthat/test_loo_moment_matching.R
@@ -273,6 +273,8 @@ test_that("loo_moment_match.default works", {
cores = 1
))
+ expect_identical(attr(loo_moment_match_object, "posthoc"), "moment_match")
+
# diagnostic Pareto k decreases but influence pareto k stays the same
expect_lt(
loo_moment_match_object$diagnostics$pareto_k[1],
diff --git a/tests/testthat/test_loo_subsampling.R b/tests/testthat/test_loo_subsampling.R
index b3029f27..795cbf73 100644
--- a/tests/testthat/test_loo_subsampling.R
+++ b/tests/testthat/test_loo_subsampling.R
@@ -892,7 +892,7 @@ test_that("update.psis_loo_ss works as expected (compared with loo)", {
))
})
-test_that("loo_compare_subsample", {
+test_that("model_compare_subsample", {
skip_on_cran() # to get under cran check time limit
set.seed(123)
@@ -1019,26 +1019,26 @@ test_that("loo_compare_subsample", {
)
expect_snapshot(
- lcss <- loo:::loo_compare.psis_loo_ss_list(x = list(lss1, lss2, lss3))
+ lcss <- loo:::model_compare.psis_loo_ss_list(x = list(lss1, lss2, lss3))
)
expect_warning(
- lcss2 <- loo:::loo_compare.psis_loo_ss_list(x = list(lss1, lss2, lss3o1))
+ lcss2 <- loo:::model_compare.psis_loo_ss_list(x = list(lss1, lss2, lss3o1))
)
expect_silent(
- lcsso <- loo:::loo_compare.psis_loo_ss_list(x = list(lss1, lss2o1, lss3o1))
+ lcsso <- loo:::model_compare.psis_loo_ss_list(x = list(lss1, lss2o1, lss3o1))
)
expect_warning(
- lcssohh <- loo:::loo_compare.psis_loo_ss_list(
+ lcssohh <- loo:::model_compare.psis_loo_ss_list(
x = list(lss1, lss2hh, lss3o1)
)
)
expect_message(
- lcssf1 <- loo:::loo_compare.psis_loo_ss_list(
+ lcssf1 <- loo:::model_compare.psis_loo_ss_list(
x = list(loo:::as.psis_loo_ss.psis_loo(l1), lss2o1, lss3o1)
)
)
expect_message(
- lcssf2 <- loo:::loo_compare.psis_loo_ss_list(
+ lcssf2 <- loo:::model_compare.psis_loo_ss_list(
x = list(
loo:::as.psis_loo_ss.psis_loo(l1),
lss2o1,
@@ -1047,29 +1047,32 @@ test_that("loo_compare_subsample", {
)
)
- expect_equal(lcss[, 1], lcsso[, 1], tolerance = 1)
- expect_equal(lcss2[, 1], lcsso[, 1], tolerance = 1)
- expect_equal(lcssohh[, 1], lcsso[, 1], tolerance = 1)
- expect_equal(lcssf1[, 1], lcsso[, 1], tolerance = 1)
- expect_equal(lcssf2[, 1], lcsso[, 1], tolerance = 1)
+ expect_equal(lcss$elpd_diff, lcsso$elpd_diff, tolerance = 1)
+ expect_equal(lcss2$elpd_diff, lcsso$elpd_diff, tolerance = 1)
+ expect_equal(lcssohh$elpd_diff, lcsso$elpd_diff, tolerance = 1)
+ expect_equal(lcssf1$elpd_diff, lcsso$elpd_diff, tolerance = 1)
+ expect_equal(lcssf2$elpd_diff, lcsso$elpd_diff, tolerance = 1)
- expect_gt(lcss[, 2][2], lcsso[, 2][2])
- expect_gt(lcss[, 2][3], lcsso[, 2][3])
- expect_gt(lcss2[, 2][2], lcsso[, 2][2])
- expect_equal(lcss2[, 2][3], lcsso[, 2][3])
- expect_gt(lcssohh[, 2][2], lcsso[, 2][2])
- expect_equal(lcssohh[, 2][3], lcsso[, 2][3])
+ expect_gt(lcss$se_diff[2], lcsso$se_diff[2])
+ expect_gt(lcss$se_diff[3], lcsso$se_diff[3])
+ expect_gt(lcss2$se_diff[2], lcsso$se_diff[2])
+ expect_equal(lcss2$se_diff[3], lcsso$se_diff[3])
+ expect_gt(lcssohh$se_diff[2], lcsso$se_diff[2])
+ expect_equal(lcssohh$se_diff[3], lcsso$se_diff[3])
expect_silent(
- lcss2m <- loo:::loo_compare.psis_loo_ss_list(x = list(lss2o1, lss3o1))
+ lcss2m <- loo:::model_compare.psis_loo_ss_list(x = list(lss2o1, lss3o1))
+ )
+ expect_equal(
+ unname(as.matrix(lcss2m[, -1])),
+ unname(as.matrix(lcsso[1:2, -1]))
)
- expect_equal(unname(lcss2m[,]), unname(lcsso[1:2, ]))
- expect_snapshot(lcssapi <- loo_compare(lss1, lss2, lss3))
+ expect_snapshot(lcssapi <- model_compare(lss1, lss2, lss3))
expect_equal(lcssapi, lcss)
- expect_warning(lcssohhapi <- loo_compare(lss1, lss2hh, lss3o1))
+ expect_warning(lcssohhapi <- model_compare(lss1, lss2hh, lss3o1))
expect_equal(lcssohhapi, lcssohh)
- expect_silent(lcss2mapi <- loo_compare(lss2o1, lss3o1))
+ expect_silent(lcss2mapi <- model_compare(lss2o1, lss3o1))
expect_equal(lcss2mapi, lcss2m)
# check that comparison is comp - ref model (i.e., elpd_diff is neg.)
for (m in list(lcss, lcss2, lcssohh)) {
diff --git a/tests/testthat/test_loo_subsampling_cases.R b/tests/testthat/test_loo_subsampling_cases.R
index 532d5830..6bb1fe69 100644
--- a/tests/testthat/test_loo_subsampling_cases.R
+++ b/tests/testthat/test_loo_subsampling_cases.R
@@ -430,7 +430,7 @@ test_that("Test the vignette", {
expect_snapshot(print(looss_2))
expect_warning(
- comp <- loo_compare(looss_1, looss_2),
+ comp <- model_compare(looss_1, looss_2),
"Different subsamples in 'model2' and 'model1'. Naive diff SE is used."
)
expect_snapshot(print(comp))
@@ -454,7 +454,7 @@ test_that("Test the vignette", {
"Simple random sampling with replacement assumed."
)
- expect_silent(comp <- loo_compare(looss_1, looss_2_m))
+ expect_silent(comp <- model_compare(looss_1, looss_2_m))
expect_snapshot(print(comp))
set.seed(4712)
@@ -474,7 +474,7 @@ test_that("Test the vignette", {
observations = looss_1
)
)
- expect_silent(comp2 <- loo_compare(looss_1, looss_2_m))
+ expect_silent(comp2 <- model_compare(looss_1, looss_2_m))
expect_snapshot(print(comp2))
expect_no_warning(
@@ -485,7 +485,7 @@ test_that("Test the vignette", {
)
)
expect_message(
- comp3 <- loo_compare(x = list(looss_1, looss_2_full)),
+ comp3 <- model_compare(x = list(looss_1, looss_2_full)),
"Estimated elpd_diff using observations included in loo calculations for all models."
)
expect_snapshot(print(comp3))
diff --git a/tests/testthat/test_pred_measure.R b/tests/testthat/test_pred_measure.R
index d786df8d..2b1b4a7f 100644
--- a/tests/testthat/test_pred_measure.R
+++ b/tests/testthat/test_pred_measure.R
@@ -239,6 +239,38 @@ test_that("pred_measure() updates loo results as expected", {
expect_equal(dim(updated_predperf$estimates), c(5, 2))
})
+test_that("loo_pred_measure() warns for non-elpd measures after moment matching", {
+ loo_mm <- res$loo
+ attr(loo_mm, "posthoc") <- "moment_match"
+ expect_warning(
+ loo_pred_measure(
+ loo = loo_mm, y = res$y, mupred = res$mupred, ylp = res$ylp,
+ measures = c("elpd", "r2")
+ ),
+ regexp = "moment_match"
+ )
+ expect_no_warning(
+ loo_pred_measure(loo = loo_mm, ylp = res$ylp, measures = c("elpd", "mlpd"))
+ )
+})
+
+test_that("loo_pred_measure() warns for non-elpd measures after reloo", {
+ loo_reloo <- res$loo
+ obs <- which.max(loo_reloo$diagnostics$pareto_k)
+ loo_reloo$diagnostics$pareto_k[obs] <- 0
+ expect_warning(
+ loo_pred_measure(
+ loo = loo_reloo, y = res$y, mupred = res$mupred, measures = "r2"
+ ),
+ regexp = "reloo"
+ )
+ expect_no_warning(
+ loo_pred_measure(
+ loo = res$loo, y = res$y, mupred = res$mupred, measures = "r2"
+ )
+ )
+})
+
test_that("pred_measure() keeps dims when the update has no matrix input", {
predperf_loo <- loo_pred_measure(
loo = res$loo, y = res$y, mupred = res$mupred, ylp = res$ylp,
diff --git a/tests/testthat/test_pred_measure_builtin.R b/tests/testthat/test_pred_measure_builtin.R
index 4856bee4..0c13b63f 100644
--- a/tests/testthat/test_pred_measure_builtin.R
+++ b/tests/testthat/test_pred_measure_builtin.R
@@ -207,6 +207,133 @@ testthat::test_that("measure_rps() with continuous data and scaled version works
expect_true(all(res$pointwise < 0))
})
+# Properties of the E|X - X'| estimator behind RPS/CRPS. The estimator is a
+# weighted average over all pairs of draws, so it must reproduce the
+# brute-force pairwise computation exactly, stay non-negative, and be invariant
+# to shifting `y` and `ypred` by the same constant.
+
+# brute-force reference for E|X - X'|, over all pairs of draws
+.exx_brute <- function(ypred, w = NULL) {
+ n_draws <- nrow(ypred)
+ if (is.null(w)) {
+ w <- matrix(1 / n_draws, n_draws, ncol(ypred))
+ }
+ vapply(
+ seq_len(ncol(ypred)),
+ function(j) {
+ x <- ypred[, j]
+ wj <- w[, j]
+ sum(outer(wj, wj) * abs(outer(x, x, "-"))) / (1 - sum(wj^2))
+ },
+ numeric(1)
+ )
+}
+
+testthat::test_that(".exx_pwm() matches the brute-force pairwise estimator", {
+ set.seed(4321)
+ for (n_draws in c(2L, 5L, 50L)) {
+ # a location far from zero: a biased estimator of E|X - X'| shows up here
+ ypred <- matrix(rnorm(n_draws * 4L, mean = 250, sd = 30), nrow = n_draws)
+ expect_equal(.exx_pwm(ypred), .exx_brute(ypred))
+
+ w <- exp(.normalize_log_weights(matrix(rnorm(n_draws * 4L), nrow = n_draws)))
+ expect_equal(.exx_pwm(ypred, w), .exx_brute(ypred, w))
+ }
+})
+
+testthat::test_that(".exx_pwm() errors with fewer than two draws", {
+ expect_error(
+ .exx_pwm(matrix(1, nrow = 1L, ncol = 3L)),
+ "at least 2 draws"
+ )
+ expect_error(
+ measure_rps(y = 1, ypred = matrix(1, nrow = 1L, ncol = 1L)),
+ "at least 2 draws"
+ )
+})
+
+testthat::test_that("measure_rps() errors when `ypred` is missing or misshaped", {
+ expect_error(
+ measure_rps(y = res_sleep$y, ypred = NULL),
+ "`ypred` must be a numeric matrix or array"
+ )
+ expect_error(
+ measure_rps(y = res_sleep$y, ypred = res_sleep$ypred[, -1L, drop = FALSE]),
+ "`ypred` must have"
+ )
+})
+
+testthat::test_that("measure_rps() is invariant to shifting y and ypred", {
+ shift <- 1e4
+ for (scaled in c(FALSE, TRUE)) {
+ expect_equal(
+ measure_rps(res_sleep$y + shift, res_sleep$ypred + shift, scaled = scaled)$pointwise,
+ measure_rps(res_sleep$y, res_sleep$ypred, scaled = scaled)$pointwise
+ )
+ expect_equal(
+ measure_rps(
+ res_sleep$y + shift,
+ res_sleep$ypred + shift,
+ log_weights = res_sleep$log_weights,
+ scaled = scaled
+ )$pointwise,
+ measure_rps(
+ res_sleep$y,
+ res_sleep$ypred,
+ log_weights = res_sleep$log_weights,
+ scaled = scaled
+ )$pointwise
+ )
+ }
+})
+
+testthat::test_that("measure_rps() is non-negative as an unscaled loss", {
+ expect_true(all(measure_rps(res_sleep$y, res_sleep$ypred)$pointwise >= 0))
+ expect_true(all(measure_rps(res_binom$y, res_binom$ypred)$pointwise >= 0))
+ expect_true(all(
+ measure_rps(
+ res_roaches$y,
+ res_roaches$ypred,
+ log_weights = res_roaches$log_weights
+ )$pointwise >= 0
+ ))
+})
+
+testthat::test_that("measure_srps() is finite under concentrated weights", {
+ # Regression test: the roaches fit has an observation whose PSIS weight is
+ # >0.8, which used to drive the E|X - X'| estimate negative and made
+ # `log(EXX)` return NaN.
+ res <- measure_srps(
+ res_roaches$y,
+ res_roaches$ypred,
+ log_weights = res_roaches$log_weights
+ )
+
+ expect_true(all(is.finite(res$pointwise)))
+ expect_true(all(is.finite(res$estimates)))
+})
+
+testthat::test_that("uniform log-weights reproduce the unweighted measure_rps()", {
+ uniform_lw <- matrix(0, nrow(res_sleep$ypred), ncol(res_sleep$ypred))
+
+ for (scaled in c(FALSE, TRUE)) {
+ expect_equal(
+ measure_rps(res_sleep$y, res_sleep$ypred, log_weights = uniform_lw,
+ scaled = scaled)$pointwise,
+ measure_rps(res_sleep$y, res_sleep$ypred, scaled = scaled)$pointwise
+ )
+ }
+})
+
+testthat::test_that("measure_srps() passes precomputed pointwise values through", {
+ pw <- c(-1.5, -2.5, -3.5)
+ res <- measure_srps(pointwise = pw)
+
+ expect_equal(as.vector(res$pointwise), pw)
+ expect_equal(rownames(res$estimates), "srps")
+ expect_equal(res$estimates[1L, "Estimate"], mean(pw), ignore_attr = TRUE)
+})
+
# measure_brier() ---------------------------------------
@@ -302,30 +429,30 @@ testthat::test_that("measure_mse() and measure_rmse() work as expected", {
expect_snapshot_output(measure_rmse(y = res_roaches$y, mupred = res_roaches$mupred))
})
-testthat::test_that("higher_is_better reorients loss measures to utility scale", {
- res_mse <- measure_mse(y = res_roaches$y, mupred = res_roaches$mupred)
- res_mse_utility <- measure_mse(
- y = res_roaches$y,
- mupred = res_roaches$mupred,
- higher_is_better = TRUE
+testthat::test_that("rps is a loss and srps a utility", {
+ set.seed(1)
+ y <- rnorm(50)
+ good <- matrix(rnorm(50 * 400), nrow = 400)
+ bad <- matrix(rnorm(50 * 400, mean = 3, sd = 4), nrow = 400)
+
+ # unscaled RPS/CRPS follows Gneiting & Raftery (2007): lower is better
+ expect_true(loo:::.measure_is_loss("rps"))
+ expect_lt(
+ measure_rps(y, good)$estimates[1L, "Estimate"],
+ measure_rps(y, bad)$estimates[1L, "Estimate"]
)
- expect_equal(
- unname(res_mse_utility$estimates["Estimate"]),
- -unname(res_mse$estimates["Estimate"])
+ # the scaled variant follows Bolin & Wallin (2023): higher is better
+ expect_false(loo:::.measure_is_loss("srps"))
+ expect_gt(
+ measure_srps(y, good)$estimates[1L, "Estimate"],
+ measure_srps(y, bad)$estimates[1L, "Estimate"]
)
- expect_equal(res_mse_utility$pointwise, -res_mse$pointwise)
})
-testthat::test_that("higher_is_better reorients rps and srps", {
+testthat::test_that("the raw rps score is a non-negative loss", {
raw <- measure_rps(res_sleep$y, res_sleep$ypred)
expect_true(all(raw$pointwise >= 0))
- up <- measure_rps(res_sleep$y, res_sleep$ypred, higher_is_better = TRUE)
- expect_equal(up$pointwise, -raw$pointwise)
-
- s_raw <- measure_srps(res_sleep$y, res_sleep$ypred)
- s_dn <- measure_srps(res_sleep$y, res_sleep$ypred, higher_is_better = FALSE)
- expect_equal(s_dn$pointwise, -s_raw$pointwise)
})
testthat::test_that("measure_rmse() works with se=0", {
@@ -344,7 +471,7 @@ testthat::test_that("measure_rmse() works with se=0", {
testthat::test_that("measure_r2() works as expected", {
res <- measure_r2(y = res_roaches$y, mupred = res_roaches$mupred, log_weights = NULL)
- expect_equal(names(res), c("estimates", "pointwise"))
+ expect_equal(names(res), c("estimates", "pointwise", "extra"))
expect_equal(length(res$estimates), 2)
expect_equal(length(res$pointwise), length(res_roaches$y))
expect_true(all(res$estimates[1] >= 0 & res$estimates[1] <= 1))
@@ -356,7 +483,7 @@ testthat::test_that("measure_r2() with log_weights works as expected", {
res <- measure_r2(y = res_roaches$y, mupred = res_roaches$mupred,
log_weights = res_roaches$log_weights)
- expect_equal(names(res), c("estimates", "pointwise"))
+ expect_equal(names(res), c("estimates", "pointwise", "extra"))
expect_equal(length(res$estimates), 2)
expect_equal(length(res$pointwise), length(res_roaches$y))
expect_true(all(res$estimates[1] >= 0 & res$estimates[1] <= 1))
@@ -443,7 +570,7 @@ testthat::test_that("measure_bacc() pointwise contributions sum to estimate", {
testthat::test_that("measure_bacc() works as expected", {
res <- measure_bacc(y = as.integer(res_cat$y), mupred = res_cat$mupred, log_weights = NULL)
- expect_equal(names(res), c("estimates", "pointwise"))
+ expect_equal(names(res), c("estimates", "pointwise", "extra"))
expect_equal(length(res$estimates), 2)
expect_equal(length(res$pointwise), length(res_cat$y))
expect_true(!all(res$pointwise < 0 | res$pointwise > 1))
@@ -487,7 +614,7 @@ testthat::test_that("measure_bacc() with log-weights works as expected", {
log_weights = res_cat$log_weights
)
- expect_equal(names(res), c("estimates", "pointwise"))
+ expect_equal(names(res), c("estimates", "pointwise", "extra"))
expect_equal(length(res$estimates), 2)
expect_equal(length(res$pointwise), length(res_cat$y))
expect_true(!all(res$pointwise < 0 | res$pointwise > 1))
diff --git a/tests/testthat/test_pred_measure_helpers.R b/tests/testthat/test_pred_measure_helpers.R
index 5be36b3b..3b7f81d8 100644
--- a/tests/testthat/test_pred_measure_helpers.R
+++ b/tests/testthat/test_pred_measure_helpers.R
@@ -35,6 +35,28 @@ test_that(".normalize_measure() handles a mixed list", {
expect_equal(entries[[2]]$name, "custom_mae")
})
+test_that(".normalize_measure() reads the `measure_loss` declaration", {
+ f <- function(y, mupred) list(estimate = 1, se = 0, pointwise = y)
+ attr(f, "measure_name") <- "custom_mae"
+
+ # a custom measure is a utility unless it says otherwise
+ expect_false(.normalize_measure(f)[[1]]$loss)
+
+ attr(f, "measure_loss") <- TRUE
+ expect_true(.normalize_measure(f)[[1]]$loss)
+ # the list form takes its name from the element, but the same declaration
+ expect_true(.normalize_measure(list(custom_mae = f))[[1]]$loss)
+
+ attr(f, "measure_loss") <- "yes"
+ expect_error(.normalize_measure(f), regexp = "declare loss")
+ attr(f, "measure_loss") <- c(TRUE, FALSE)
+ expect_error(
+ .normalize_measure(list(custom_mae = f)), regexp = "declare loss"
+ )
+ attr(f, "measure_loss") <- NA
+ expect_error(.normalize_measure(f), regexp = "declare loss")
+})
+
test_that(".normalize_measure() errors on duplicate names", {
expect_error(
.normalize_measure(c("mse", "mse")),
@@ -42,12 +64,32 @@ test_that(".normalize_measure() errors on duplicate names", {
)
})
-test_that(".normalize_measure() errors on unnamed list function", {
+test_that(".normalize_measure() errors on an unnamed list function without `measure_name`", {
f <- function(y, mupred) list(estimate = 1, se = 0, pointwise = y)
- expect_error(
- .normalize_measure(list(f)),
- regexp = "must be named"
- )
+ expect_error(.normalize_measure(list(f)), regexp = "needs a name")
+})
+
+test_that(".normalize_measure() takes the name of an unnamed list function from `measure_name`", {
+ f <- custom_measure(function(y, mupred) list(estimate = 1, se = 0, pointwise = y),
+ name = "my_metric")
+ entries <- .normalize_measure(list("rmse", f))
+ expect_identical(vapply(entries, `[[`, "", "name"), c("rmse", "my_metric"))
+})
+
+test_that("custom_measure() sets the attributes", {
+ f <- custom_measure(function(y, mupred) NULL, name = "m", se_diff_fun = "mean", loss = TRUE)
+ expect_identical(attr(f, "measure_name"), "m")
+ expect_true(attr(f, "measure_loss"))
+ expect_identical(attr(f, "measure_se_diff"), "mean")
+})
+
+test_that("custom_measure() errors on invalid input", {
+ expect_error(custom_measure("x", name = "m"), regexp = "'fun' must be a function")
+ expect_error(custom_measure(function(y) NULL, name = "m", loss = NA), regexp = "declare loss")
+ expect_error(custom_measure(function(y) NULL, name = "m", se_diff_fun = "median"), regexp = "Invalid")
+ for (bad in list("", NULL, c("a", "b"))) {
+ expect_error(custom_measure(function(y) NULL, name = bad), regexp = "needs a name")
+ }
})
# .prepare_measures() -----------------------------------------------
@@ -145,7 +187,7 @@ test_that(".validate_control() accepts valid control silently", {
expect_invisible(.validate_control(list(rps = list(scaled = TRUE))))
expect_invisible(.validate_control(list(
rps = list(scaled = TRUE),
- srps = list(higher_is_better = TRUE)
+ srps = list(pointwise = NULL)
)))
})
@@ -187,9 +229,44 @@ test_that(".validate_control() errors on malformed control", {
.validate_control(list(rps = c(scaled = TRUE))),
regexp = "must be a named list of named lists."
)
- expect_error(
- .validate_control(list(not_a_function = list(x = 1))),
- regexp = "not_a_function"
+})
+
+test_that(".validate_control() warns on a control entry naming no measure", {
+ expect_warning(
+ .validate_control(list(not_a_measure = list(x = 1))),
+ regexp = "not_a_measure.*matches no"
+ )
+ # the same when the requested measures are known
+ expect_warning(
+ .validate_control(
+ list(mse = list(pointwise = NULL)),
+ measures = .normalize_measure("rps")
+ ),
+ regexp = "mse.*matches no"
+ )
+})
+
+test_that(".validate_control() validates custom measures against their formals", {
+ f <- function(y, mupred, delta = 1) {
+ list(estimate = 1, se = 0, pointwise = y)
+ }
+ attr(f, "measure_name") <- "custom_huber"
+ entries <- .normalize_measure(f)
+
+ # only the custom function's own formals are accepted
+ expect_silent(
+ .validate_control(list(custom_huber = list(delta = 2)), entries)
+ )
+ expect_warning(
+ .validate_control(
+ list(custom_huber = list(higher_is_better = TRUE)),
+ entries
+ ),
+ regexp = "Ignoring `higher_is_better` as it is not a valid argument"
+ )
+ expect_warning(
+ .validate_control(list(custom_huber = list(nope = 1)), entries),
+ regexp = "Ignoring `nope` as it is not a valid argument"
)
})
diff --git a/tests/testthat/test_print.R b/tests/testthat/test_print.R
index 9d7502ec..e3a58fc0 100644
--- a/tests/testthat/test_print.R
+++ b/tests/testthat/test_print.R
@@ -95,4 +95,42 @@ test_that("test_pred_measure print output", {
)
expect_s3_class(x, "test_pred_measure")
expect_snapshot_output(print(x))
-})
\ No newline at end of file
+})
+
+test_that(".se_digits takes the places from the standard error", {
+ expect_equal(loo:::.se_digits(0.0003), 4)
+ expect_equal(loo:::.se_digits(0.045), 3)
+ expect_equal(loo:::.se_digits(1.4), 1)
+ # a large SE still gets `min_digits`
+ expect_equal(loo:::.se_digits(45), 1)
+ # nothing usable is left
+ expect_equal(loo:::.se_digits(c(0, NA, Inf)), 2)
+ expect_equal(loo:::.se_digits(NULL), 2)
+})
+
+test_that(".measure_digits is fixed for a measure on a fixed scale", {
+ expect_equal(loo:::.measure_digits("elpd"), 1)
+ expect_equal(loo:::.measure_digits("ic"), 1)
+ expect_equal(loo:::.measure_digits("mlpd"), 3)
+ for (m in c("r2", "acc", "bacc", "brier")) {
+ expect_equal(loo:::.measure_digits(m), 3)
+ }
+ # on the scale of the data the standard error decides
+ expect_equal(loo:::.measure_digits("rmse", 0.00031), 4)
+ expect_equal(loo:::.measure_digits("mae", 0.45), 2)
+ # a custom measure has no entry, so it follows the standard error too
+ expect_equal(loo:::.measure_digits("my_measure", 2.3), 1)
+})
+
+test_that(".resolve_digits honours the user's `digits`", {
+ expect_equal(loo:::.resolve_digits(NULL, "r2", 0.006), 3)
+ expect_equal(loo:::.resolve_digits(2, "r2", 0.006), 2)
+ expect_equal(loo:::.resolve_digits(c(r2 = 5), "r2", 0.006), 5)
+ # a measure the vector does not name keeps its default
+ expect_equal(loo:::.resolve_digits(c(r2 = 5), "elpd", 1.4), 1)
+})
+
+test_that(".fr keeps a small value out of scientific notation", {
+ expect_equal(loo:::.fr(0.00031, 4), "0.0003")
+ expect_equal(loo:::.fr(c(0.00031, 0), 4), c("0.0003", "0.0000"))
+})
diff --git a/vignettes/articles-online-only/model-comparison.Rmd b/vignettes/articles-online-only/model-comparison.Rmd
new file mode 100644
index 00000000..39150d9a
--- /dev/null
+++ b/vignettes/articles-online-only/model-comparison.Rmd
@@ -0,0 +1,726 @@
+---
+title: "Model comparison: Explanation of `model_compare()`"
+author: "Florence Bockting"
+date: "`r Sys.Date()`"
+output:
+ rmarkdown::html_vignette:
+ css:
+ - !expr system.file("rmarkdown/templates/html_vignette/resources/vignette.css", package = "rmarkdown")
+ - styles.css
+ toc: true
+ toc_depth: 3
+params:
+ EVAL: TRUE
+vignette: >
+ %\VignetteIndexEntry{Model comparison: Explanation of `model_compare()`}
+ %\VignetteEngine{knitr::rmarkdown}
+ %\VignetteEncoding{UTF-8}
+---
+
+```{r, child="../children/SEE-ONLINE.txt", eval = if (isTRUE(exists("params"))) !params$EVAL else TRUE}
+```
+
+```{r setup, include=FALSE}
+knitr::opts_chunk$set(
+ collapse = TRUE,
+ comment = "#>",
+ message = TRUE,
+ warning = TRUE,
+ eval = params$EVAL,
+ fig.width = 7,
+ fig.height = 4,
+ fig.align = "center"
+)
+
+# brms::kfold() exports the fits to future.apply, which caps globals at 500 MiB
+options(future.globals.maxSize = 4 * 1024^3)
+```
+
+```{r, child="../children/LOAD-BRMS-GITHUB.txt", eval=params$EVAL}
+```
+
+## Introduction
+This vignette introduces the `loo::model_compare()` function.
+Use `model_compare()` instead of the deprecated `loo::loo_compare()` (see the
+note below).
+
+This vignette shows how to use the function. It does not explain how to
+interpret the results. It also does not explain what to do in the Bayesian
+workflow when you get diagnostic warnings, for example high Pareto-k values.
+For these topics, see the "TODO-case study-model_compare vignette" [Link-TODO].
+
+This vignette does not derive the formulas behind `_diff` and
+`_se_diff` (introduced below). For the derivations, see the supplement
+(TODO-Vehtari et al., 2026).
+
+`model_compare()` accepts the output of these functions:
+
++ `loo()`, `kfold()`, and `waic()`
++ `_pred_measure()`, where `` is `loo`, `kfold`, `test`, or `insample`
+
+`model_compare()` is new in loo v3.0.0. It compares models on several
+predictive performance measures, for example `elpd`, `mae`, `rmse`, and `acc`.
+For the full list, see the [Overview of scores and metrics](overview-measures.html)
+vignette. You can also define custom measures.
+
+This vignette uses the output of `_pred_measure()`. It also briefly
+shows how it compares to the deprecated `loo_compare()` output.
+The vignette explains:
+
+1. The arguments and output of `model_compare()`.
+1. Which standard error `model_compare()` uses for each built-in measure.
+1. How to compute the difference and its standard error for a **custom**
+ measure.
+
+::: {.callout .callout-note}
+**Relation between `model_compare` and `loo_compare`**
+
+The `loo_compare` function has traditionally been used for model comparison in
+loo, accepting any object that inherits from the `loo` class (such as those
+produced by `loo()`, `kfold()`, and `waic()`).
+
+With the introduction of the *`pred_measure` family*, we have deprecated
+`loo_compare` and introduced `model_compare`. While `model_compare` retains full
+backward compatibility, it also expands functionality to handle outputs from
+the `pred_measure` family.
+
+`loo_compare` still works and is still a generic, so methods registered by other
+packages keep dispatching, but it now warns and is frozen at its previous
+behavior: `loo` objects compared on ELPD only. The `pred_measure` sources and
+custom measures described in this article require `model_compare`.
+`loo_compare` will be removed in a future release. For more details, see
+`vignette("migration-guide", package = "loo")`.
+:::
+
+## Running example (count data)
+
+To illustrate the functionality of `model_compare()` we first introduce a
+*running example*. In this example, we compare three Poisson regression
+models fitted to the **`roaches` data** from `rstanarm` (Gelman and Hill, 2007).
+This data set records a pest-management trial in 262 apartment buildings.
+The outcome `y` is the number of roaches caught in traps after treatment and
+ranges from 0 to 357. The predictors are:
+
++ `roach1`: pre-treatment roach count (used as `sqrt_roach1 = sqrt(roach1)`)
++ `treatment`: whether the building received pest management
++ `senior`: whether the building is restricted to elderly residents
+
+The **three models** used in the following comparison tasks are defined as
+follows:
+
+```
+ m1: y ~ treatment + senior
+ m2: y ~ sqrt_roach1 + senior
+ m3: y ~ sqrt_roach1 + treatment
+```
+
+As **performance criteria** we select six predictive performance measures:
+`elpd`, `mae`, `mse`, `rmse`, `r2`, and `rps` computed by `loo_pred_measure`.
+
+Note that `rps` is the only one of these that needs the posterior *predictive*
+draws `ypred`; the error measures are computed from the posterior expectation
+`mupred` (see the input requirements table in `?loo_pred_measure`).
+
+::: {.callout .callout-note}
+**Running example**
+
+The running example shows how to call `model_compare()`. It does not show
+how to interpret the results. For that, see [TODO-LINK]. We therefore do not
+discuss diagnostic flags or interpretation of the output here.
+
+:::
+
+```{r load-libraries}
+library(loo)
+```
+
+```{r setup-example}
+measures <- c("elpd", "mae", "mse", "rmse", "r2", "rps")
+```
+
+## The classical `loo_compare` output
+
+As the actual model building workflow is not the focus of this tutorial, we fit
+the three models here without further comment. `add_criterion()` attaches a
+`loo` object (as returned by `loo::loo()`) to each fit.
+
+```{r fit-models, results="hide", warning=FALSE, message=FALSE}
+SEED <- 42
+
+data(roaches, package = "rstanarm")
+roaches$sqrt_roach1 <- sqrt(roaches$roach1)
+
+fit_m1 <- brms::brm(
+ y ~ treatment + senior,
+ data = roaches,
+ family = poisson,
+ prior = brms::prior(normal(0, 1), class = b),
+ chains = 2, iter = 400, seed = SEED, refresh = 0
+)
+fit_m2 <- update(fit_m1, formula = y ~ sqrt_roach1 + senior,
+ newdata = roaches, refresh = 0)
+fit_m3 <- update(fit_m1, formula = y ~ sqrt_roach1 + treatment,
+ newdata = roaches, refresh = 0)
+
+add_loo <- function(fit) {
+ brms::add_criterion(fit, criterion = "loo", moment_match = TRUE,
+ save_psis = TRUE)
+}
+fit_m1 <- add_loo(fit_m1)
+fit_m2 <- add_loo(fit_m2)
+fit_m3 <- add_loo(fit_m3)
+
+loos <- list(m1 = fit_m1$criteria$loo, m2 = fit_m2$criteria$loo,
+ m3 = fit_m3$criteria$loo)
+```
+
+Passing these `loo` objects to the classical `loo_compare()` reproduces the
+familiar ELPD-only comparison, and warns once per session that `model_compare()`
+is now the preferred function:
+
+```{r loo_compare}
+loo_compare(loos)
+```
+
+When we use `model_compare` instead, we get the same output for `loo` objects:
+
+```{r model_compare_wloo}
+model_compare(loos)
+```
+
+It also supports the `simplify` argument in the print method:
+
+```{r model_compare_wloo_simplify}
+print(model_compare(loos), simplify = FALSE)
+```
+
+## Basic usage
+
+We now use `loo_pred_measure()` to compute the predictive performance for
+each model (`m1, m2, m3`) and measure (see list above).
+Finally, we compare the performance of the three models using `model_compare()`.
+By default, only the ranking measure is shown. The ranking measure is `elpd`
+when all models share it. Otherwise, it is the first shared measure in
+alphabetical order.
+
+
+```{r pred-measure}
+fit_measure <- function(fit, measure) {
+ loo_pred_measure(
+ loo = fit$criteria$loo,
+ y = fit$data$y,
+ ypred = brms::posterior_predict(fit),
+ mupred = brms::posterior_epred(fit),
+ measures = measure
+ )
+}
+
+set.seed(SEED)
+m1 <- fit_measure(fit_m1, measures)
+m2 <- fit_measure(fit_m2, measures)
+m3 <- fit_measure(fit_m3, measures)
+
+(comp <- model_compare(list(m1 = m1, m2 = m2, m3 = m3)))
+```
+
+When we want to see a **specific measure**, we can change this by passing the
+information to the `print` method:
+
+```{r pred-measure-r2}
+print(comp, measures = "r2")
+```
+
+If you want to see **all columns related to a measure** specified in
+`measures` use `simplify = FALSE`:
+
+```{r pred-measure-r2-simplify}
+print(comp, measures = "r2", simplify = FALSE)
+```
+
+If you want to see **all measures** use `measures = "all"`:
+
+```{r pred-measure-all}
+print(comp, measures = "all")
+```
+
+### Output of `model_compare()`
+
+Using `print(., measures = "all")` returns a subsection for each measure.
+The *rows* represent the different models, with the best model always in the
+first row, followed by the second best, and so on.
+The *columns*:
+
+ + `model`: Name of each model
+ + `_diff`: The point estimate representing the difference in the measure between the current model and the reference model (calculated as model - reference). For the reference model itself, this value is always zero.
+ + `_se_diff`$^{(1)}$: The standard error of the difference
+ + `p_worse`: (only for `elpd`) Estimated probability that a model has worse predictive performance than the reference model
+ + `diag_diff`: (only for `elpd`) Diagnostic column flagging miscalibration of the normal approximation behind `p_worse` and `se_diff`
+
+Above the measure subsections, `print()` names the reference model each set of
+differences was computed against, and, for `loo_pred_measure()` inputs, reports
+the PSIS-LOO diagnostic once per model:
+
+ + `bad_k`: Number of observations whose Pareto $\hat{k}$ exceeds the PSIS
+ reliability threshold. Pareto $\hat{k}$ describes a model's PSIS-LOO
+ approximation.
+
+This block is omitted when no model is flagged, and for `kfold`, `test`, and
+`insample` sources, which have no Pareto $\hat{k}$ diagnostic.
+
+$^{(1)}$ The only measure that deviates from this naming convention is `elpd`,
+where the column is called `se_diff` instead of `elpd_se_diff` for backwards
+compatibility.
+
+### The `measure_info` attribute
+
+Each model has a `measure_info` attribute, which provides meta information for
+each performance measure.
+
+```{r meta-attribute, class.output="scroll-output"}
+meta <- attr(m1, "measure_info")
+
+# measure info for each single measure (e.g., R2)
+names(meta$r2)
+```
+
+The information is stored in different *slots*:
+
+| slot | description | functionality |
+| :--- | :---- | :----- |
+| `loss` | Whether the measure is a *loss* (`TRUE`; lower values of the measure are better) or a *utility* (`FALSE`, higher values are better) | During model comparison, loss measures have their sign flipped so that all differences are reported on a utility scale (higher is better) |
+| `diff_method` | How paired pointwise differences are aggregated within model comparison: `"sum"`, `"mean"`, `"measure_specific"`, or `"custom"` | Selects the formula for `_se_diff` (see the table in Section [Computation of the standard error](#computation-of-the-standard-error-measure_se_diff)) |
+| `se_diff_fun` | Name of the measure's own standard-error function for computing `_se_diff`, only set when `diff_method = "measure_specific"` (`"rmse"`, `"r2"`, `"bacc"`) | Points to the built-in function that computes `_se_diff` for measures whose estimate is not a plain sum or mean of pointwise values |
+| `extra` | Optional auxiliary data the measure stored for its `se_diff_fun`, on the measure's natural scale (e.g., `mse_y_i` for `r2`, `class_id` for `bacc`); `NULL` for measures that need none | Carries the quantities the standard error needs but the pointwise values do not contain; passed to `se_diff_fun()` as part of each model's input |
+
+## How `model_compare()` computes the output
+
+This section relates `_diff` and `_se_diff` to the model
+objects. All measures use the same point estimate. The standard error depends
+on the measure. For the formulas, see the supplement
+(TODO-Vehtari et al., 2026, Section TODO-ARXIV-SECTION).
+
+### Computation of the point estimate `_diff`
+The estimates `elpd_diff`, `mae_diff`, `rmse_diff`, and `r2_diff` in the
+output of the running example represent the point estimates of the pairwise
+model comparisons.
+They are computed as the measure-specific difference between two model
+estimates (comparison model - reference model).
+
+For example, the difference in `elpd` between model `m1` (comparison) and model
+`m3` (reference) is computed as follows:
+
+```{r, eval=FALSE}
+m1_elpd <- m1$estimates["elpd_loo", "Estimate"]
+m3_elpd <- m3$estimates["elpd_loo", "Estimate"]
+
+m1_elpd - m3_elpd
+```
+
+This computation is done for each measure and each pairwise model comparison.
+
+By default, however, the reference model is chosen *per measure* as the best
+model for that measure.
+The reference used for each measure is recorded in the `compare_reference`
+attribute:
+
+```{r reference-models}
+models <- list(m1 = m1, m2 = m2, m3 = m3)
+ref <- attr(comp, "compare_reference")
+ref
+```
+
+The following code block shows, for model `m1`, the hand-computed differences
+against each measure's own reference model and the differences reported in the
+`comp` object:
+
+```{r point-estimate}
+est <- function(x, measure) x$estimates[measure, "Estimate"]
+measures_all <- c("elpd", "mse", "mae", "rmse", "r2")
+
+data.frame(
+ reference = ref[measures_all],
+ by_hand = sapply(measures_all, function(m) {
+ est(m1, paste0(m, "_loo")) - est(models[[ref[[m]]]], paste0(m, "_loo"))
+ }),
+ reported = sapply(measures_all, function(m) {
+ comp[[paste0(m, "_diff")]][comp$model == "m1"]
+ })
+)
+```
+
+Note that in the above output, the sign for some measures is flipped between
+the `by_hand` and `reported` column, specifically for `mse`, `mae`, and `rmse`.
+These measures are *losses* (see callout box below).
+
+However, when we compare all measures together, we want them all to be
+on the same scale, which in our case is the **utility scale**. Therefore, losses
+are converted to the utility scale. As such, higher values are always better.
+Consequently, the best model has the highest value, and when the best model is
+also the reference model, the estimated difference `_diff`
+(computed as comp - reference) is always non-positive.
+
+When a measure is converted to the utility scale, `print()` marks it with
+"sign flipped" in the table header. It also names it below the tables:
+
+```{r sign-note}
+comp <- model_compare(list(m1 = m1, m2 = m2, m3 = m3))
+print(comp, measures = c("r2", "mae"))
+```
+
+::: {.callout .callout-note}
+**Utility vs. loss scale**
+
+We call a measure a **loss** when it has, by default, the orientation
+*lower is better*.
+
+By contrast, we call a measure a **utility** if it has, by default, the
+orientation *higher is better*.
+
+Which orientation a measure has can be inspected from the `loss` slot of the
+`measure_info` attribute of the model object:
+```{r measure-meta}
+sapply(meta, function(x) x$loss)
+```
+
+:::
+
+### Computation of the standard error `_se_diff`
+
+The standard error summarizes the uncertainty in the estimated difference.
+Depending on the measure, different approaches for computing the standard error
+are used. We summarize them in four different categories:
+
+| `diff_method` | SE of the difference | Measures | Supplement |
+| :--- | :--- | :--- |:--- |
+| `"sum"` | `sqrt(N) * sd(d_i)` | `elpd`, `ic` | Eq. TODO-ARXIV |
+| `"mean"` | `sd(d_i) / sqrt(N)` | `mlpd`, `mae`, `mse`, `acc`, `brier`, `rps`, `srps` | Eq. TODO-ARXIV |
+| `"measure_specific"` | the measure's own `se_diff_fun` | `rmse`, `r2`, `bacc` | Eq. TODO-ARXIV |
+| `"custom"` | declared via `custom_measure(se_diff_fun = )` | custom measures | -- |
+
+where `N` is the number of observations and `d_i` the paired difference of
+the pointwise estimates of the two models (`comparison - reference`).
+
+The user can check which approach is used for each measure via the
+`diff_method` slot in the `measure_info` attribute of the model object:
+
+```{r diff-method}
+sapply(meta, function(x) x$diff_method)
+```
+
+## Custom measures
+
+A custom measure is any function returning a list with `estimate`, `se`, and
+`pointwise`. Define it with `custom_measure()`, which attaches three
+declarations to the function:
+
+| argument of `custom_measure()` | attribute | meaning |
+| :--- | :--- | :--- |
+| `name` | `measure_name` | the name under which the measure is reported |
+| `loss` | `measure_loss` | `TRUE` if lower values are better (default `FALSE`) |
+| `se_diff_fun` | `measure_se_diff` | how `model_compare()` computes the SE of a difference |
+
+A custom measure always gets `diff_method = "custom"`. Setting the attributes
+directly with `attr()` gives the same result.
+
+The argument `se_diff_fun` accepts one of three things:
+
+| value | meaning |
+| :--- | :--- |
+| `"mean"` | estimate is the mean of the pointwise values. SE is computed as `sd(d_i) / sqrt(N)` |
+| `"sum"` | estimate is the sum of the pointwise values. SE is computed as `sqrt(N) * sd(d_i)` |
+| a function | custom function for computing the SE, called as `fn(ref, cmp)` |
+
+With `se_diff_fun = NULL` (the default), the measure declares nothing.
+`model_compare()` then reports the difference with an `NA` standard error and
+a message. `model_compare()` needs no further argument in either case.
+
+We elaborate on these points in the following examples.
+
+### Example (one custom measure)
+
+In the following, we provide a custom measure that is not part of the built-in
+measures. The Huber loss is quadratic for small residuals and linear for
+large residuals. We define it as follows:
+
+```{r huber-measure}
+huber_fn <- function(y, mupred) {
+ delta <- 10
+ r <- y - colMeans(mupred)
+ l <- ifelse(abs(r) <= delta, 0.5 * r^2, delta * (abs(r) - 0.5 * delta))
+ list(estimate = mean(l), se = sd(l) / sqrt(length(l)), pointwise = l)
+}
+huber_se_fn <- function(ref, cmp) {
+ d <- cmp$pointwise - ref$pointwise
+ sd(d) / sqrt(length(d))
+}
+
+huber_measure <- custom_measure(
+ fun = huber_fn,
+ name = "huber",
+ se_diff_fun = huber_se_fn,
+ loss = TRUE
+)
+```
+
+With `name`, we report the measure as "huber". With `loss = TRUE`, we declare
+that it is a loss rather than a utility (i.e., lower values are better). Note
+that a custom measure is by default considered to be a utility. The argument
+`se_diff_fun` declares the standard error of the difference. It is called as
+`huber_se_fn(ref, cmp)`, where each argument is
+a list describing **one** model with elements `estimate`, `se`, `pointwise`, and
+`extra`. This is the general form. The shorthands `"mean"` and `"sum"` cover
+the two common cases.
+
+::: {.callout .callout-warning}
+A custom measure is by default considered to be a utility (i.e., higher values
+are better).
+
+This can be changed with `custom_measure(loss = TRUE)` (see example above).
+:::
+
+First, we compute the predictive performance measures for two different models
+using `"rmse"` and the custom Huber loss as performance criteria.
+
+```{r custom-measure}
+h1 <- fit_measure(fit_m1, measure = list("rmse", huber_measure))
+h3 <- fit_measure(fit_m3, measure = list("rmse", huber_measure))
+```
+
+(Remember that we have created the `fit_measure` helper at the [beginning of
+this tutorial](#example). It simply wraps `loo_pred_measure()`.)
+
+Inspecting the attribute `measure_info` shows that the Huber loss uses
+`diff_method = "custom"`, and that our declaration is recorded as
+`se_diff_fun`.
+
+```{r custom-diff-method}
+str(attr(h1, "measure_info"))
+```
+
+`model_compare()` reads the declaration from the objects, so the comparison
+needs no further argument:
+
+```{r custom-declared-se}
+comp_h <- model_compare(list(m3 = h3, m1 = h1))
+print(comp_h, measures = "huber")
+```
+
+As discussed above, the difference estimates are always reported on the utility
+scale. Therefore `huber_diff` for `m1` is negative.
+
+### Extended example (multiple custom measures)
+
+In the following, we extend the example above by adding one further custom
+measure and show how this is implemented. As an additional custom measure we
+use RMSE normalized by the standard deviation of the outcome:
+
+```{r extended-example-def}
+nrmse_fn <- function(y, mupred) {
+ sqe <- (y - colMeans(mupred))^2
+ list(
+ estimate = sqrt(mean(sqe)) / sd(y),
+ se = sqrt(var(sqe) / length(sqe)) / (2 * sqrt(mean(sqe))) / sd(y),
+ pointwise = sqe,
+ extra = list(sd_y = sd(y))
+ )
+}
+
+nrmse_se_fn <- function(ref, cmp) {
+ n <- length(ref$pointwise)
+ mse_ref <- mean(ref$pointwise)
+ mse_cmp <- mean(cmp$pointwise)
+ se_ref <- sqrt(var(ref$pointwise) / n)
+ se_cmp <- sqrt(var(cmp$pointwise) / n)
+ cov_rc <- sum((cmp$pointwise - mse_cmp) * (ref$pointwise - mse_ref)) /
+ (n * (n - 1))
+
+ rel_ref <- se_ref / sqrt(mse_ref)
+ rel_cmp <- se_cmp / sqrt(mse_cmp)
+ rho <- cov_rc / (se_ref * se_cmp)
+
+ # the RMSE formula of the supplement (Eq. TODO-ARXIV), written so
+ # that a model compared against itself cancels to exactly zero
+ se_rmse <- 0.5 * sqrt(
+ (rel_cmp - rel_ref)^2 + 2 * rel_cmp * rel_ref * max(1 - rho, 0)
+ )
+
+ se_rmse / ref$extra$sd_y
+}
+
+nrmse_measure <- custom_measure(
+ fun = nrmse_fn,
+ name = "nrmse",
+ se_diff_fun = nrmse_se_fn,
+ loss = TRUE
+)
+```
+
+Subsequently, we compute the predictive performance measures for two different
+models using `"rmse"`, the custom Huber loss, and the custom normalized RMSE
+(`"nrmse"`) as performance criteria.
+
+```{r extended-example-fit}
+n1 <- fit_measure(fit_m1, list("rmse", huber_measure, nrmse_measure))
+n3 <- fit_measure(fit_m3, list("rmse", huber_measure, nrmse_measure))
+```
+
+Finally, we perform model comparison with multiple custom measures. Both
+measures declare their own `se_diff_fun`, so no argument is needed:
+
+```{r extend-example-fit}
+comp_n <- model_compare(list(m3 = n3, m1 = n1))
+print(comp_n, measures = "all")
+```
+
+## Comparing other predictive sources
+
+`model_compare()` treats every `*_pred_measure()` result the same way. Only the
+constructor changes. All models in one call must share one source. A mixed call
+is an error.
+
+### K-fold cross-validation
+
+`brms::kfold()` refits each model `K` times, so this is the most expensive step
+in this article.
+
+```{r kfold-compare, message=FALSE}
+set.seed(SEED)
+folds <- kfold_split_random(K = 5, N = nrow(roaches))
+
+kfold_measure <- function(fit, measure) {
+ kf <- brms::kfold(fit, folds = folds, save_fits = TRUE)
+
+ kfold_pred_measure(
+ y = fit$data$y,
+ ypred = brms::kfold_predict(kf, method = "predict")$yrep,
+ mupred = brms::kfold_predict(kf, method = "fitted")$yrep,
+ kfold = kf,
+ measures = measure
+ )
+}
+
+k1 <- kfold_measure(fit_m1, measures)
+k2 <- kfold_measure(fit_m2, measures)
+k3 <- kfold_measure(fit_m3, measures)
+
+model_compare(list(m1 = k1, m2 = k2, m3 = k3))
+```
+
+`print()` names the source above the table.
+The PSIS-LOO block is gone, because Pareto $\hat{k}$ describes the LOO
+approximation only.
+
+### Held-out test data
+
+Here we hold out 60 buildings, refit each model on the rest, and score the
+held-out ones. `ylp_test` supplies `elpd_test`; `ylp` stays the training
+log-likelihood.
+
+```{r test-compare}
+set.seed(SEED)
+test_id <- sample(nrow(roaches), 60)
+roaches_train <- roaches[-test_id, ]
+roaches_test <- roaches[test_id, ]
+
+test_measure <- function(fit, measure) {
+ fit_train <- update(fit, newdata = roaches_train, refresh = 0)
+ test_pred_measure(
+ y = roaches_test$y,
+ ypred = brms::posterior_predict(fit_train, newdata = roaches_test),
+ mupred = brms::posterior_epred(fit_train, newdata = roaches_test),
+ ylp = brms::log_lik(fit_train),
+ ylp_test = brms::log_lik(fit_train, newdata = roaches_test),
+ measures = measure
+ )
+}
+
+t1 <- test_measure(fit_m1, measures)
+t2 <- test_measure(fit_m2, measures)
+t3 <- test_measure(fit_m3, measures)
+
+model_compare(list(m1 = t1, m2 = t2, m3 = t3))
+```
+
+### In-sample
+
+In-sample scores need no refit. They are optimistically biased and favor the
+more complex model, so `model_compare()` warns:
+
+```{r insample-compare}
+insample_measure <- function(fit, measure) {
+ insample_pred_measure(
+ y = fit$data$y,
+ ypred = brms::posterior_predict(fit),
+ mupred = brms::posterior_epred(fit),
+ ylp = brms::log_lik(fit),
+ measures = measure
+ )
+}
+
+i1 <- insample_measure(fit_m1, measures)
+i2 <- insample_measure(fit_m2, measures)
+i3 <- insample_measure(fit_m3, measures)
+
+model_compare(list(m1 = i1, m2 = i2, m3 = i3))
+```
+
+Everything else in this article, custom measures, the `print`
+arguments `measures` and `simplify`, works unchanged for all four sources.
+
+## Summary
+
+```{r summary-table, echo=FALSE}
+knitr::kable(
+ data.frame(
+ Measure = c("elpd, ic", "mlpd, mae, mse, acc, brier, rps, srps",
+ "rmse", "r2", "bacc", "custom"),
+ `diff_method` = c("sum", "mean", "measure_specific",
+ "measure_specific", "measure_specific",
+ "custom"),
+ `Standard error` = c(
+ "sqrt(N) * sd(d_i)",
+ "sd(d_i) / sqrt(N)",
+ "delta method on the MSE scale",
+ "delta method, including baseline uncertainty",
+ "stratified by class, paired within class",
+ "from se_diff_fun: your function, \"sum\", \"mean\", or NA"
+ ),
+ check.names = FALSE
+ )
+)
+```
+
+The things worth remembering:
+
+1. The difference is always `estimate_cmp - estimate_ref`, reported so that
+ negative means worse.
+2. The standard error is always paired, because the models are evaluated on the
+ same observations.
+3. `NA` in a standard error column means "not available", not "zero" and not
+ "an error occurred".
+4. A custom measure is assumed to be a utility. If yours is a loss, say so with
+ `custom_measure(loss = TRUE)`, or its differences and its ranking will
+ come out reversed.
+
+## References
+
+Sivula, T., Magnusson, M., Matamoros, A. A., and Vehtari, A. (2025).
+Uncertainty in Bayesian leave-one-out cross-validation based model comparison.
+*Bayesian Analysis*. doi:10.1214/25-BA1569
+
+Vehtari, A., Gelman, A., and Gabry, J. (2017). Practical Bayesian model
+evaluation using leave-one-out cross-validation and WAIC. *Statistics and
+Computing*, 27(5):1413–1432. doi:10.1007/s11222-016-9696-4
+
+
+Vehtari, A., Bockting, F., Axen, S., and Weber, F. (2026).
+*TODO-ARXIV-TITLE*. arXiv preprint arXiv:TODO-ARXIV-ID.
+
+## See also
+
+- [Computing predictive performance measures](pred-measure-workflow.html) — how
+ to produce the objects compared here.
+- [Overview of scores and metrics](overview-measures.html) — definitions and
+ formulas for each measure.
+- `?"loo-glossary"` — the `measure_info` attribute in full.
+- Vehtari et al. (2026), *TODO-ARXIV-TITLE*: the supplement with the formulas for every measure and standard error in this article.
\ No newline at end of file
diff --git a/vignettes/loo2-elpd.Rmd b/vignettes/loo2-elpd.Rmd
index cd205d49..df37f9e6 100644
--- a/vignettes/loo2-elpd.Rmd
+++ b/vignettes/loo2-elpd.Rmd
@@ -148,7 +148,7 @@ Now we evaluate the predictive performance of the model on the test data using `
(elpd_holdout <- elpd(log_pd))
```
-When one wants to compare different models, the function `loo_compare()` can be used to assess the difference in performance.
+When one wants to compare different models, the function `model_compare()` can be used to assess the difference in performance.
# K-fold cross validation
@@ -205,7 +205,7 @@ Now we evaluate the predictive performance of the model on the 10 folds using `e
(elpd_kfold <- elpd(log_pd_kfold))
```
-If one wants to compare several models (with `loo_compare`), one should use the same folds for all the different models.
+If one wants to compare several models (with `model_compare`), one should use the same folds for all the different models.
# References
diff --git a/vignettes/loo2-example.Rmd b/vignettes/loo2-example.Rmd
index 2a5037a7..44a6000d 100644
--- a/vignettes/loo2-example.Rmd
+++ b/vignettes/loo2-example.Rmd
@@ -263,11 +263,11 @@ the data.
## Comparing the models on expected log predictive density
-We can use the `loo_compare` function to compare our two models on
+We can use the `model_compare` function to compare our two models on
expected log predictive density (ELPD) for new data:
-```{r loo_compare}
-loo_compare(loo1, loo2)
+```{r model_compare}
+model_compare(loo1, loo2)
```
The difference in ELPD is much larger than several times the estimated standard
diff --git a/vignettes/loo2-large-data.Rmd b/vignettes/loo2-large-data.Rmd
index 7f7083f0..e1f17a74 100644
--- a/vignettes/loo2-large-data.Rmd
+++ b/vignettes/loo2-large-data.Rmd
@@ -398,7 +398,7 @@ The object created is of class `psis_loo_ss`, which inherits from the
## Comparing models
To compare this model to an alternative model for the same data we can use the
-`loo_compare()` function just as we would if using `loo()` instead of
+`model_compare()` function just as we would if using `loo()` instead of
`loo_subsample()` or `loo_approximate_posterior()`. First we'll fit a second
model to the well-switching data, using `log(arsenic)` instead of `arsenic` as a
predictor:
@@ -470,11 +470,11 @@ All Pareto k estimates are good (k < 0.7).
See help('pareto-k-diagnostic') for details.
```
-We can now compare the models on LOO using the `loo_compare` function:
+We can now compare the models on LOO using the `model_compare` function:
```{r, eval=FALSE}
# Compare
-comp <- loo_compare(loo_ss_1, loo_ss_2)
+comp <- model_compare(loo_ss_1, loo_ss_2)
print(comp)
```
@@ -567,7 +567,7 @@ loo_full_2 <- loo(
data = stan_df_2,
cores = 2
)
-loo_compare(loo_ss_1, loo_full_2)
+model_compare(loo_ss_1, loo_full_2)
```
```
diff --git a/vignettes/loo2-with-rstan.Rmd b/vignettes/loo2-with-rstan.Rmd
index 9c1fcd05..5089b1b6 100644
--- a/vignettes/loo2-with-rstan.Rmd
+++ b/vignettes/loo2-with-rstan.Rmd
@@ -168,7 +168,7 @@ all of the estimates for $k$ are fine.
## Comparing models
To compare this model to an alternative model for the same data we can use the
-`loo_compare` function in the **loo** package. First we'll fit a second model to the
+`model_compare` function in the **loo** package. First we'll fit a second model to the
well-switching data, using `log(arsenic)` instead of `arsenic` as a predictor:
```{r, eval=FALSE}
@@ -196,11 +196,11 @@ All Pareto k estimates are good (k < 0.7).
See help('pareto-k-diagnostic') for details.
```
-We can now compare the models on LOO using the `loo_compare` function:
+We can now compare the models on LOO using the `model_compare` function:
```{r, eval=FALSE}
# Compare
-comp <- loo_compare(loo_1, loo_2)
+comp <- model_compare(loo_1, loo_2)
```
This new object, `comp`, contains the estimated difference of expected
diff --git a/vignettes/migration-guide.Rmd b/vignettes/migration-guide.Rmd
index f02a047d..1186e44a 100644
--- a/vignettes/migration-guide.Rmd
+++ b/vignettes/migration-guide.Rmd
@@ -54,9 +54,10 @@ branch and will extend this guide when merged into `loo-v3.0.0`.
| `R/pred_measure-compute.R` | **Current** | Internal orchestration |
| `R/pred_measure-helpers.R` | **Current** | Validation and helpers |
| `R/pred_measure-builtin.R` | **Current** | `measure_*()` implementations |
-| `R/compare.R` | Deprecated (removal in 3.0.0) | `loo_compare()` in `R/loo_compare.R` |
+| `R/compare.R` | Deprecated (removal in 3.0.0) | `model_compare()` in `R/model_compare.R` |
| `R/psislw.R` | Deprecated (removal in 3.0.0) | `psis()` in `R/psis.R` (since 2.0.0) |
-| `R/loo_compare.R` | **Current** | Model comparison |
+| `R/loo_compare.R` | Deprecated | `model_compare()` in `R/model_compare.R` |
+| `R/model_compare.R` | **Current** | Model comparison |
| `R/loo.R`, `R/psis.R`, `R/waic.R` | **Current** | Core LOO / PSIS / WAIC |
---
@@ -168,18 +169,47 @@ supported_measures_list()
| Deprecated | Replacement | Since | Planned removal |
|------------|-------------|-------|-----------------|
-| `compare()` | `loo_compare()` | 2.0.0 | 3.0.0 |
+| `compare()` | `model_compare()` | 2.0.0 | 3.0.0 |
+| `loo_compare()` | `model_compare()` | 3.0.0 | TBD |
`compare()` returns a vector or matrix with class `"compare.loo"`.
-`loo_compare()` returns a `data.frame` with additional diagnostic columns.
-See `?loo_compare` for the current output format.
+`model_compare()` returns a `data.frame` with additional diagnostic columns.
+See `?model_compare` for the current output format.
```r
# Deprecated
compare(loo1, loo2)
# Current
+model_compare(loo1, loo2)
+```
+
+### `loo_compare()` is now `model_compare()`
+
+`loo_compare()` has been renamed to `model_compare()`, which better reflects
+that it compares models evaluated by leave-one-out CV, k-fold CV, a held-out
+test set, or in-sample scores.
+
+`loo_compare()` is **deprecated** but still works, and is still an exported
+generic, so `loo_compare` methods registered by other packages (for example
+`loo_compare.brmsfit` in **brms** and `loo_compare.stanreg` in **rstanarm**)
+keep dispatching. It is frozen at its previous behavior: it compares `"loo"`,
+`"waic"`, and `"kfold"` objects on ELPD only, and returns exactly what
+`model_compare()` returns for those inputs. Everything added in 3.0.0 --- the
+`pred_measure` sources and `custom_measure()` --- is available only
+through `model_compare()`.
+
+```r
+# Deprecated, but still returns the same table
loo_compare(loo1, loo2)
+
+# Current
+model_compare(loo1, loo2)
+
+# Only available via model_compare()
+model_compare(kfold_pm1, kfold_pm2)
+model_compare(test_pm1, test_pm2)
+model_compare(loo_pm1, loo_pm2)
```
## PSIS importance sampling