diff --git a/.Rbuildignore b/.Rbuildignore index 3f30776b..2fcf2e3c 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -18,6 +18,7 @@ vignettes/loo2-non-factorized_cache/* .github/* .vscode/* ^\.github$ +^vignettes/articles-online-only$ ^vignettes/online-only$ ^\.git-blame-ignore-revs$ ^CRAN-SUBMISSION$ @@ -26,3 +27,11 @@ vignettes/loo2-non-factorized_cache/* ^pkgdown$ ^touchstone$ ^notes-release.md +^notes$ +^\.agents$ +^agent$ +^\.claude$ +^\.refactor-review$ +^internal-notes$ +^scratch-files$ +^skills-lock\.json$ diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index c0238134..135c6453 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -36,6 +36,9 @@ jobs: - uses: r-lib/actions/setup-r@v2 with: use-public-rspm: true + extra-repositories: | + https://community.r-multiverse.org + https://stan-dev.r-universe.dev - uses: r-lib/actions/setup-r-dependencies@v2 with: @@ -45,7 +48,8 @@ jobs: local::. any::bayesplot any::BH - any::brms + paul-buerkner/brms + any::cmdstanr any::ggplot2 any::rmarkdown any::Rcpp @@ -58,6 +62,7 @@ jobs: any::StanHeaders any::knitr any::withr + any::lme4 stan-dev/pkgdown-config - name: Build site diff --git a/.gitignore b/.gitignore index 27e4ea74..e52fad9c 100644 --- a/.gitignore +++ b/.gitignore @@ -19,6 +19,7 @@ vignettes/loo2-non-factorizable_cache/* vignettes/*.html vignettes/*.pdf inst/doc +*.html revdep/* tests/testthat/Rplots.pdf @@ -26,4 +27,9 @@ tests/testthat/Rplots.pdf cran-comments.md CRAN-RELEASE 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/DESCRIPTION b/DESCRIPTION index 4b15bd82..1f472cd9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,6 +36,7 @@ Depends: R (>= 3.5) Imports: checkmate, + cli (>= 3.4.0), matrixStats (>= 0.52), parallel, posterior (>= 1.7.0), @@ -46,6 +47,7 @@ Suggests: ggplot2, graphics, knitr, + lme4, rmarkdown, rstan, rstanarm (>= 2.19.0), diff --git a/NAMESPACE b/NAMESPACE index c9c5383d..a343cfc8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,7 @@ S3method(crps,numeric) S3method(dim,importance_sampling) S3method(dim,kfold) S3method(dim,loo) +S3method(dim,pred_measure) S3method(dim,psis_loo) S3method(dim,waic) S3method(elpd,array) @@ -47,18 +48,22 @@ 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) S3method(print,loo) +S3method(print,loo_pred_measure) +S3method(print,measure) S3method(print,pareto_k_table) +S3method(print,pred_measure) S3method(print,pseudobma_bb_weights) S3method(print,pseudobma_weights) S3method(print,psis) @@ -102,12 +107,14 @@ export(.thin_draws) export(E_loo) export(compare) export(crps) +export(custom_measure) export(elpd) export(example_loglik_array) export(example_loglik_matrix) export(extract_log_lik) export(find_model_names) export(gpdfit) +export(insample_pred_measure) export(is.kfold) export(is.loo) export(is.psis) @@ -116,6 +123,7 @@ export(is.sis) export(is.tis) export(is.waic) export(kfold) +export(kfold_pred_measure) export(kfold_split_grouped) export(kfold_split_random) export(kfold_split_stratified) @@ -134,11 +142,25 @@ export(loo_model_weights) export(loo_model_weights.default) export(loo_moment_match) export(loo_moment_match.default) +export(loo_pred_measure) export(loo_predictive_metric) export(loo_scrps) export(loo_subsample) export(loo_subsample.function) export(mcse_loo) +export(measure_acc) +export(measure_bacc) +export(measure_brier) +export(measure_elpd) +export(measure_ic) +export(measure_mae) +export(measure_mlpd) +export(measure_mse) +export(measure_r2) +export(measure_rmse) +export(measure_rps) +export(measure_srps) +export(model_compare) export(nlist) export(obs_idx) export(pareto_k_ids) @@ -146,15 +168,19 @@ export(pareto_k_influence_values) export(pareto_k_table) export(pareto_k_values) export(pointwise) +export(pred_measure) export(print_dims) export(pseudobma_weights) export(psis) export(psis_n_eff_values) export(psislw) +export(ptw_log_pred_density) export(relative_eff) export(scrps) export(sis) export(stacking_weights) +export(supported_measures_list) +export(test_pred_measure) export(tis) export(waic) export(waic.array) diff --git a/NEWS.md b/NEWS.md index bcc1e16c..0c157557 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,25 @@ # loo (development version) +* Add a predictive performance API by @florence-bockting in #363: + - new functions `insample_pred_measure()`, `loo_pred_measure()`, + `kfold_pred_measure()`, `test_pred_measure()`, and `pred_measure()` + - new built-in measures `measure_*()`, listed in `supported_measures_list` +* Deprecate `elpd()`, `crps()`, `scrps()`, `loo_crps()`, `loo_scrps()`, and + `loo_predictive_metric()`. Use `measure_*()` and `*_pred_measure()`. See + `vignette("migration-guide")`. By @florence-bockting in #363 +* Add `model_compare()` by @florence-bockting in #380: + - compares models on each measure of `*_pred_measure()` results + - compares each measure against its own best model + - shows loss measures on the utility scale + - ranks models by `elpd`, else by the first shared measure (alphabetical) + - new `print()` argument `measures` +* Deprecate `loo_compare()`. Use `model_compare()`. Methods in other packages + (e.g. **brms**) still work. By @florence-bockting in #380 +* Add `custom_measure()` to set the name, loss flag, and SE of the difference + for a custom measure by @florence-bockting in #380 +* `loo_pred_measure()` warns when `loo_moment_match()` or `reloo()` changed the + `loo` object and the measure is not `elpd`, `mlpd`, or `ic`, by + @florence-bockting in #380 * Handle errors of the user functions in `loo_moment_match()` by @avehtari in #410 * Allow different numbers of draws in `loo_model_weights()` by @avehtari in #409 * Improve numerical stability in `loo()`, `psis()`, model weighting, subsampling, diff --git a/R/compare.R b/R/compare.R index a6081d2f..c7826d44 100644 --- a/R/compare.R +++ b/R/compare.R @@ -1,7 +1,8 @@ #' Model comparison (deprecated, old version) #' -#' **This function is deprecated**. Please use the new [loo_compare()] function -#' instead. +#' **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. #' #' @export #' @param ... At least two objects returned by [loo()] (or [waic()]). @@ -59,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/crps.R b/R/crps.R index fd7de69d..9844e079 100644 --- a/R/crps.R +++ b/R/crps.R @@ -1,4 +1,15 @@ -#' Continuously ranked probability score +#' Continuously ranked probability score (deprecated) +#' +#' As of loo 3.0.0, `crps()`, `scrps()`, `loo_crps()`, and `loo_scrps()` are +#' **deprecated**. Please use [measure_rps()] and [measure_srps()] instead, +#' or [loo_pred_measure()] for leave-one-out predictive performance. +#' See `vignette("migration-guide", package = "loo")` for a full mapping table. +#' +#' @details +#' The new functions use a single matrix of posterior predictive draws +#' (`ypred`) and a PWM estimator. The deprecated functions require two +#' independent draw matrices (`x` and `x2`) and use a permutation-based +#' estimator. See [measure_rps()] for migration details. #' #' The `crps()` and `scrps()` functions and their `loo_*()` counterparts can be #' used to compute the continuously ranked probability score (CRPS) and scaled @@ -34,16 +45,19 @@ #' The former reports estimator and standard error and latter the pointwise #' values. Following Bolin & Wallin (2023), a larger value is better. #' +#' @seealso [measure_rps()], [measure_srps()], [loo_pred_measure()] +#' #' @examples #' \dontrun{ -#' # An example using rstanarm +#' # Deprecated: #' library(rstanarm) #' data("kidiq") #' fit <- stan_glm(kid_score ~ mom_hs + mom_iq, data = kidiq) #' ypred1 <- posterior_predict(fit) #' ypred2 <- posterior_predict(fit) #' crps(ypred1, ypred2, y = fit$y) -#' loo_crps(ypred1, ypred2, y = fit$y, log_lik = log_lik(fit)) +#' # -> +#' measure_rps(y = fit$y, ypred = ypred1) #' } #' #' @references @@ -80,6 +94,7 @@ loo_scrps <- function(x, ...) { #' @rdname crps #' @export crps.matrix <- function(x, x2, y, ..., permutations = 1) { + .Deprecated("measure_rps") validate_crps_input(x, x2, y) repeats <- replicate(permutations, EXX_compute(x, x2), simplify = F) EXX <- Reduce(`+`, repeats) / permutations @@ -114,6 +129,7 @@ loo_crps.matrix <- permutations = 1, r_eff = 1, cores = getOption("mc.cores", 1)) { + .Deprecated("loo_pred_measure") validate_crps_input(x, x2, y, log_lik) repeats <- replicate(permutations, EXX_loo_compute(x, x2, log_lik, r_eff = r_eff, ...), @@ -128,6 +144,7 @@ loo_crps.matrix <- #' @rdname crps #' @export scrps.matrix <- function(x, x2, y, ..., permutations = 1) { + .Deprecated("measure_srps") validate_crps_input(x, x2, y) repeats <- replicate(permutations, EXX_compute(x, x2), simplify = F) EXX <- Reduce(`+`, repeats) / permutations @@ -156,6 +173,7 @@ loo_scrps.matrix <- permutations = 1, r_eff = 1, cores = getOption("mc.cores", 1)) { + .Deprecated("loo_pred_measure") validate_crps_input(x, x2, y, log_lik) repeats <- replicate(permutations, EXX_loo_compute(x, x2, log_lik, r_eff = r_eff, ...), diff --git a/R/diagnostics.R b/R/diagnostics.R index 3d12bdb4..f9f27d04 100644 --- a/R/diagnostics.R +++ b/R/diagnostics.R @@ -69,16 +69,15 @@ #' the MCMC draws from the posterior distribution to obtain more #' reliable importance sampling estimates. This results in a smaller #' shape parameter \eqn{k}. See [loo_moment_match()] and the -#' vignette *Avoiding model refits in leave-one-out cross-validation -#' with moment matching* for an example of this. +#' vignette *Avoiding model refits with moment matching* for an +#' example of this. #' #' * Sampling from a leave-one-out mixture distribution (see the -#' vignette *Mixture IS leave-one-out cross-validation for -#' high-dimensional Bayesian models*), directly from \eqn{p(\theta^s -#' | y_{-i})} for the problematic observations \eqn{i}, or using -#' \eqn{K}-fold cross-validation (see the vignette *Holdout -#' validation and K-fold cross-validation of Stan programs with the -#' loo package*) will generally be more stable. +#' vignette *Mixture IS leave-one-out cross-validation*), +#' directly from \eqn{p(\theta^s | y_{-i})} for the problematic +#' observations \eqn{i}, or using \eqn{K}-fold cross-validation +#' (see the vignette *Holdout validation and K-fold cross-validation*) +#' will generally be more stable. #' #' * Using a model that is more robust to anomalous observations will #' generally make approximate LOO-CV more stable. diff --git a/R/elpd.R b/R/elpd.R index b6736fb4..2e1557bf 100644 --- a/R/elpd.R +++ b/R/elpd.R @@ -1,8 +1,19 @@ -#' Generic (expected) log-predictive density +#' Generic (expected) log-predictive density (deprecated) +#' +#' As of loo 3.0.0, `elpd()` is **deprecated**. Please use [measure_elpd()] +#' instead. For full predictive performance workflows, see +#' [insample_pred_measure()] and [loo_pred_measure()]. +#' See `vignette("migration-guide", package = "loo")` for a full mapping table. +#' +#' @details +#' The return type differs: `elpd()` returns class `"elpd_generic"` with +#' `elpd` and `ic` in `pointwise`; `measure_elpd()` returns class `"measure"`. #' #' The `elpd()` methods for arrays and matrices can compute the expected log #' pointwise predictive density for a new dataset or the log pointwise #' predictive density of the observed data (an overestimate of the elpd). +#' The `elpd()` function is an S3 generic and methods are provided for +#' 3-D pointwise log-likelihood arrays and matrices. #' #' @export #' @param x A log-likelihood array or matrix. The **Methods (by class)** @@ -10,17 +21,17 @@ #' each method. #' @param ... Currently ignored. #' -#' @details The `elpd()` function is an S3 generic and methods are provided for -#' 3-D pointwise log-likelihood arrays and matrices. -#' -#' @seealso The vignette *Holdout validation and K-fold cross-validation of Stan -#' programs with the loo package* for demonstrations of using the `elpd()` -#' methods. +#' @seealso [measure_elpd()], [insample_pred_measure()], [loo_pred_measure()], +#' and the vignette *Holdout validation and K-fold cross-validation*. #' #' @examples -#' # Calculate the lpd of the observed data +#' \dontrun{ +#' # Deprecated: #' LLarr <- example_loglik_array() #' elpd(LLarr) +#' # -> +#' measure_elpd(LLarr) +#' } #' elpd <- function(x, ...) { UseMethod("elpd") @@ -31,8 +42,9 @@ elpd <- function(x, ...) { #' @template array #' elpd.array <- function(x, ...) { + .Deprecated("measure_elpd") ll <- llarray_to_matrix(x) - elpd.matrix(ll) + .elpd_matrix_impl(ll) } #' @export @@ -40,13 +52,18 @@ elpd.array <- function(x, ...) { #' @template matrix #' elpd.matrix <- function(x, ...) { - pointwise <- pointwise_elpd_calcs(x) - elpd_object(pointwise, dim(x)) + .Deprecated("measure_elpd") + .elpd_matrix_impl(x) } - # internal ---------------------------------------------------------------- +# used to avoid duplicated deprecation warning messages +.elpd_matrix_impl <- function(x) { + pointwise <- pointwise_elpd_calcs(x) + elpd_object(pointwise, dim(x)) +} + pointwise_elpd_calcs <- function(ll){ elpd <- colLogSumExps(ll) - log(nrow(ll)) ic <- -2 * elpd 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..eae973e6 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,115 @@ #' 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 what the user passes to +#' [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, what the user passed to [custom_measure()]; +#' 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 [custom_measure()] 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_model_weights.R b/R/loo_model_weights.R index 603a4890..6cd93887 100644 --- a/R/loo_model_weights.R +++ b/R/loo_model_weights.R @@ -80,8 +80,8 @@ #' while pseudo-BMA+ can serve as a computationally easier alternative. #' #' @seealso -#' * The __loo__ package [vignettes](https://mc-stan.org/loo/articles/), particularly -#' [Bayesian Stacking and Pseudo-BMA weights using the __loo__ package](https://mc-stan.org/loo/articles/loo2-weights.html). +#' * The __loo__ package [vignettes](https://mc-stan.org/loo/articles/index.html), particularly +#' [Bayesian Stacking and Pseudo-BMA weights](https://mc-stan.org/loo/articles/loo2-weights.html). #' * [loo()] for details on leave-one-out ELPD estimation. #' * [constrOptim()] for the choice of optimization methods and control-parameters. #' * [relative_eff()] for computing `r_eff`. diff --git a/R/loo_moment_matching.R b/R/loo_moment_matching.R index 08d6ced6..02e96d9a 100644 --- a/R/loo_moment_matching.R +++ b/R/loo_moment_matching.R @@ -196,6 +196,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_predictive_metric.R b/R/loo_predictive_metric.R index 8ee18bd2..67ca3280 100644 --- a/R/loo_predictive_metric.R +++ b/R/loo_predictive_metric.R @@ -1,4 +1,15 @@ -#' Estimate leave-one-out predictive performance.. +#' Estimate leave-one-out predictive performance (deprecated) +#' +#' As of loo 3.0.0, `loo_predictive_metric()` is **deprecated**. Please use +#' [loo_pred_measure()] instead, or the standalone [measure_mae()], +#' [measure_rmse()], [measure_mse()], [measure_acc()], and [measure_bacc()] +#' functions with PSIS log-weights. +#' See `vignette("migration-guide", package = "loo")` for a full mapping table. +#' +#' @details +#' The replacement API uses `mupred` (posterior expected values) rather than +#' pre-computed LOO expectations passed as `x`. Metric names also differ: +#' `"balanced_acc"` maps to `"bacc"` in [supported_measures_list]. #' #' The `loo_predictive_metric()` function computes estimates of leave-one-out #' predictive metrics given a set of predictions and observations. Currently @@ -49,6 +60,7 @@ #' Standard error of the estimate. #' } #' } +#' @seealso [loo_pred_measure()], [measure_mae()], [supported_measures_list] #' @export #' #' @examples @@ -93,6 +105,7 @@ loo_predictive_metric.matrix <- metric = c("mae", "rmse", "mse", "acc", "balanced_acc"), r_eff = 1, cores = getOption("mc.cores", 1)) { + .Deprecated("loo_pred_measure") stopifnot( is.numeric(x), is.numeric(y), diff --git a/R/loo_subsample.R b/R/loo_subsample.R index f109751f..e1227322 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..ca753b80 --- /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 pass the same ", + "arguments to `custom_measure()`.", + 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 `"sum"` or `"mean"` in +#' [custom_measure()]. 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 '", .display_name(col, loos), "' was declared with \"", + method, "\" in `custom_measure()`, 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..99ffc806 --- /dev/null +++ b/R/model_compare.R @@ -0,0 +1,714 @@ +#' 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 with different `measures`, +#' 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 what the user passes to +#' [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 new file mode 100644 index 00000000..835e51d8 --- /dev/null +++ b/R/pred_measure-builtin.R @@ -0,0 +1,1135 @@ +#' Shared parameters for all measures +#' +#' @param log_weights Optional numeric matrix of unnormalized log-importance +#' weights with dimensions \eqn{S \times n}. Weights are column-normalized +#' before computing each per-observation contribution. +#' @param pointwise Optional numeric vector of precomputed per-observation +#' contributions. When supplied, `ylp` and `log_weights` are ignored. +#' +#' @return An object of class `"measure"`: a list with: +#' \describe{ +#' \item{`estimates`}{A 1 \eqn{\times} 2 matrix. The row is named after +#' the measure, the columns are `Estimate` and `SE` (standard error).} +#' \item{`pointwise`}{An \eqn{n \times 1} matrix of per-observation values. +#' The column is named after the measure.} +#' \item{`extra`}{Optional. Auxiliary data for the standard error of a +#' difference. Most measures do not set it.} +#' } +#' Attributes `measure` (i.e., measure name) and `dims` (draws \eqn{\times} +#' observations) are also set. Use [print()] for a readable summary. +#' +#' @keywords internal +#' @name measure_params +NULL + +#' Shared parameters for density scores +#' +#' @param ylp A numeric matrix or three-dimensional array of log predictive +#' densities or probabilities: +#' \itemize{ +#' \item **Matrix** (\eqn{S \times n}): \eqn{S} posterior draws (chains +#' merged) by \eqn{n} observations. +#' \item **Array** (\eqn{I \times C \times n}): \eqn{I} MCMC iterations per +#' chain, \eqn{C} chains, and \eqn{n} observations. Converted to an +#' \eqn{S \times n} matrix internally. +#' } +#' +#' @keywords internal +#' @name measure_density_params +NULL + +#' Shared parameters for scores +#' +#' @param y A vector of observed values. +#' @param mupred A numeric array of posterior predictive means. For binary +#' outcomes use a draws x observations matrix. For multiclass outcomes use a +#' draws x observations x categories array. +#' +#' @keywords internal +#' @name measure_score_params +NULL + +#' Pointwise log predictive density (`lppd_i`) +#' +#' Computes pointwise log predictive density contributions from a matrix of +#' log predictive densities/probabilities for posterior draws. When PSIS +#' log-weights are supplied, they are used to form a weighted log-sum-exp per +#' observation. +#' +#' @param ylp A numeric matrix of log predictive densities/probabilities with +#' dimensions draws x observations. +#' @param psis_log_weights Optional numeric matrix of normalized PSIS log +#' weights with the same dimensions as `ylp`. Each column must sum to 1 on +#' the probability scale. +#' +#' @returns A numeric vector of length `ncol(ylp)` with pointwise log +#' predictive density values. +#' +#' @examples +#' ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +#' ptw_log_pred_density(ylp) +#' +#' lw <- matrix(log(c(0.7, 0.3, 0.6, 0.4)), nrow = 2) +#' ptw_log_pred_density(ylp, lw) +#' @export +ptw_log_pred_density <- function(ylp, psis_log_weights = NULL) { + .validate_numeric_matrix(ylp, arg = "ylp") + n_draws <- dim(ylp)[1] + + if (is.null(psis_log_weights)) { + return(matrixStats::colLogSumExps(ylp) - log(n_draws)) + } + .validate_numeric_matrix( + psis_log_weights, + arg = "psis_log_weights", + nrow = n_draws, + ncol = ncol(ylp) + ) + + col_sums <- colSums(exp(psis_log_weights)) + if (!isTRUE(all.equal(col_sums, rep(1, ncol(psis_log_weights))))) { + cli::cli_abort(c( + "'psis_log_weights' must be normalized (column sums equal to 1).", + "i" = "Range of current column sums: [{min(col_sums)}, {max(col_sums)}]." + )) + } + + matrixStats::colLogSumExps(ylp + psis_log_weights) +} + +#' Expected log pointwise predictive density (`elpd`) +#' +#' Computes the expected log pointwise predictive density (ELPD) as the sum of +#' 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. +#' +#' @inheritParams measure_density_params +#' @inheritParams measure_params +#' @param pointwise Optional numeric vector of precomputed \eqn{\mathrm{lppd}_i} +#' values. When supplied, `ylp` and `log_weights` are ignored. +#' +#' @details +#' \deqn{\mathrm{elpd} = \sum_{i=1}^{n} \mathrm{lppd}_i,} +#' where each \eqn{\mathrm{lppd}_i} is computed by [ptw_log_pred_density()]. +#' The standard error is \eqn{\sqrt{n}\,\mathrm{sd}(\mathrm{lppd}_i)}. +#' +#' @seealso [ptw_log_pred_density()], [measure_mlpd()], [measure_ic()] +#' +#' @examples +#' ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +#' measure_elpd(ylp) +#' +#' # With unnormalized importance weights (e.g., PSIS-LOO) +#' lw <- matrix(log(c(0.7, 0.3, 0.6, 0.4)), nrow = 2) +#' measure_elpd(ylp, log_weights = lw) +#' +#' # From a draws x chains x observations array +#' LLarr <- example_loglik_array() +#' measure_elpd(LLarr) +#' @inherit measure_params return +#' @export +measure_elpd <- function( + ylp, log_weights = NULL, pointwise = NULL +) { + inputs <- .lppd_from_inputs(ylp, log_weights, pointwise, "measure_elpd") + lppd_i <- inputs$lppd_i + + if (length(lppd_i) == 1L) { + cli::cli_warn("Only one pointwise value supplied; standard error is set to 0.") + } + + res <- list( + estimate = sum(lppd_i), + se = if (length(lppd_i) == 1L) 0 else sqrt(length(lppd_i) * var(lppd_i)), + pointwise = lppd_i + ) + + .create_measure_structure( + res, "elpd", n_draws = inputs$n_draws, n_obs = inputs$n_obs + ) +} + +#' Mean log pointwise predictive density (`mlpd`) +#' +#' Computes MLPD as the average of pointwise log predictive density (lppd_i) +#' values. Inputs follow the same conventions as [measure_elpd()]. +#' +#' @inheritParams measure_density_params +#' @inheritParams measure_params +#' @param pointwise Optional numeric vector of precomputed \eqn{\mathrm{lppd}_i} +#' values. When supplied, `ylp` and `log_weights` are ignored. +#' +#' @examples +#' ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +#' measure_mlpd(ylp) +#' @inherit measure_params return +#' @export +measure_mlpd <- function( + ylp, log_weights = NULL, pointwise = NULL +) { + inputs <- .lppd_from_inputs(ylp, log_weights, pointwise, "measure_mlpd") + lppd_i <- inputs$lppd_i + n_obs <- inputs$n_obs + + if (n_obs == 1L) { + cli::cli_warn("Only one pointwise value supplied; standard error is set to 0.") + } + + res <- list( + estimate = sum(lppd_i) / n_obs, + se = if (n_obs == 1L) 0 else sqrt(n_obs * var(lppd_i)) / n_obs, + pointwise = lppd_i + ) + .create_measure_structure( + res, "mlpd", n_draws = inputs$n_draws, n_obs = n_obs + ) +} + +#' Information Criteria (`ic`) +#' +#' Computes the information criteria as -2 x log predictive density (lppd_i) +#' values. Inputs follow the same conventions as [measure_elpd()] and +#' [measure_mlpd()]. +#' +#' @inheritParams measure_density_params +#' @inheritParams measure_params +#' @param pointwise Optional numeric vector of precomputed pointwise +#' contributions \eqn{\mathrm{ic}_i = -2 \cdot \mathrm{lppd}_i}. If provided, +#' `ylp` and `log_weights` are ignored. +#' +#' @examples +#' ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +#' measure_ic(ylp) +#' @inherit measure_params return +#' @export +measure_ic <- function( + 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 + n_obs <- inputs$n_obs + + if (n_obs == 1L) { + cli::cli_warn("Only one pointwise value supplied; standard error is set to 0.") + } + + res <- list( + estimate = sum(ic_i), + se = if (n_obs == 1L) 0 else 2 * sqrt(n_obs * var(ic_i / (-2))), + pointwise = ic_i + ) + .create_measure_structure( + res, "ic", n_draws = inputs$n_draws, n_obs = n_obs + ) +} + +#' Classification accuracy (`acc`) +#' +#' Computes pointwise and average classification accuracy for binary or +#' multiclass outcomes. The class probabilities are first averaged over the +#' draws, using `log_weights` if given. For binary outcomes, the averaged +#' probability is thresholded at 0.5. For multiclass outcomes, the predicted +#' class is the most likely category of the averaged probabilities, via +#' `which.max()`. +#' +#' @inheritParams measure_score_params +#' @inheritParams measure_params +#' @param y An integer vector of observed class labels. Code it 0 or 1 when +#' `mupred` is a matrix, and 1 to K when `mupred` is a 3-D array. +#' @param pointwise Optional numeric vector of precomputed pointwise accuracy +#' contributions. If provided, `y`, `mupred`, and `log_weights` are ignored. +#' +#' @examples +#' y <- c(1L, 0L, 1L) +#' mupred <- matrix(c(0.8, 0.3, 0.7, 0.6, 0.4, 0.9), nrow = 2) +#' measure_acc(y, mupred) +#' @inherit measure_params return +#' @export +measure_acc <- function( + y, mupred, log_weights = NULL, pointwise = NULL +) { + if (!is.null(pointwise)) { + .inform_ignored_inputs( + pointwise, + ignored_args = list(y = y, mupred = mupred, log_weights = log_weights), + fun_name = "acc" + ) + acc_i <- pointwise + n_draws <- NULL + n_obs <- length(pointwise) + } else { + n_draws <- nrow(mupred) + n_obs <- dim(mupred)[2] + .validate_numeric_vector(y, arg = "y") + acc_i <- .acc_pointwise(y, mupred, log_weights) + } + + res <- list( + estimate = mean(acc_i), + se = sqrt(mean(acc_i) * (1 - mean(acc_i)) / n_obs), + pointwise = acc_i + ) + .create_measure_structure( + res, "acc", n_draws = n_draws, n_obs = n_obs + ) +} + +#' Balanced classification accuracy (`bacc`) +#' +#' Computes balanced accuracy by averaging class-specific mean accuracy, giving +#' each observed class equal weight regardless of class frequency. +#' +#' @inheritParams measure_acc +#' @param pointwise Optional numeric vector of precomputed pointwise +#' contributions \eqn{acc_i / (K n_{y_i})}, as stored by `measure_bacc()`. +#' If provided, `mupred` and `log_weights` are ignored. `y` is always +#' required, because it defines the classes. +#' +#' @examples +#' y <- c(1L, 1L, 2L, 2L) +#' mupred <- array( +#' c(0.8, 0.2, 0.7, 0.3, 0.3, 0.7, 0.2, 0.8), +#' dim = c(1, 4, 2) +#' ) +#' measure_bacc(y, mupred) +#' @inherit measure_params return +#' @export +measure_bacc <- function( + y, mupred, log_weights = NULL, pointwise = NULL +) { + if (is.null(pointwise)) { + .validate_numeric_vector(y, arg = "y") + } + + classes <- sort(unique(y)) + K <- length(classes) + 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.") + } + .inform_ignored_inputs( + pointwise, + ignored_args = list(mupred = mupred, log_weights = log_weights), + fun_name = "bacc" + ) + acc_i <- pointwise * K * n_c[class_id] + n_draws <- NULL + n_obs <- length(pointwise) + } else { + n_draws <- nrow(mupred) + 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)) + 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, + # 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, "bacc", n_draws = n_draws, n_obs = n_obs + ) +} + +#' Brier score (`brier`) +#' +#' Computes the Brier score for binary outcomes as squared error between the +#' observed label and predicted event probability. +#' +#' @param y A numeric vector of binary outcomes coded as 0 or 1. +#' @param ypred A numeric matrix of posterior predictive probabilities with +#' dimensions draws x observations. +#' @inheritParams measure_params +#' @param pointwise Optional numeric vector of precomputed pointwise Brier +#' scores. If provided, `y`, `ypred`, and `log_weights` are ignored. +#' +#' @examples +#' y <- c(1, 0, 1) +#' ypred <- matrix(c(0.8, 0.2, 0.7, 0.9, 0.4, 0.6), nrow = 2) +#' measure_brier(y, ypred) +#' @inherit measure_params return +#' @export +measure_brier <- function( + y, ypred, log_weights = NULL, pointwise = NULL +) { + if (!is.null(pointwise)) { + .inform_ignored_inputs( + pointwise, + ignored_args = list(y = y, ypred = ypred, log_weights = log_weights), + fun_name = "brier" + ) + bs_i <- pointwise + n_draws <- NULL + n_obs <- length(pointwise) + } else { + n_draws <- nrow(ypred) + n_obs <- ncol(ypred) + .validate_numeric_vector(y, arg = "y") + if (any(y != 0 & y != 1)) { + cli::cli_abort(c( + "The brier score expects binary data 'y'.", + "i" = "Observed range: [{min(y)}, {max(y)}]", + "x" = "All elements of {.arg y} must be 0 or 1." + )) + } + .validate_numeric_matrix(ypred, arg = "ypred", ncol = length(y)) + .validate_probs(ypred, arg = "ypred") + if (!is.null(log_weights)) { + weights <- exp(.normalize_and_validate_log_weights( + log_weights = log_weights, + n_draws = n_draws, + n_obs = n_obs + )) + prob_i <- colSums(ypred * weights) + } else { + prob_i <- colMeans(ypred) + } + bs_i <- (prob_i - y)^2 + } + + res <- list( + estimate = mean(bs_i), + se = sqrt(var(bs_i) / length(bs_i)), + pointwise = bs_i + ) + .create_measure_structure( + res, "brier", n_draws = n_draws, n_obs = n_obs + ) +} + +#' Mean absolute error (`mae`) +#' +#' Computes MAE between observed outcomes and posterior predictive point +#' predictions. Point predictions are obtained by averaging `mupred` draws, or +#' by PSIS-weighted averaging when `log_weights` is provided. +#' +#' @param y A numeric vector of observed outcomes. +#' @param mupred A numeric matrix of posterior expected predictions with +#' dimensions draws x observations. A length-`n` vector is also accepted. +#' @param pointwise Optional numeric vector of precomputed pointwise absolute +#' errors. If provided, `y`, `mupred`, and `log_weights` are ignored. +#' @inheritParams measure_params +#' +#' @examples +#' y <- c(1, 2, 3) +#' mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +#' measure_mae(y, mupred) +#' @inherit measure_params return +#' @export +measure_mae <- function( + y, mupred, log_weights = NULL, pointwise = NULL +) { + inputs <- .point_error_from_inputs( + y, mupred, log_weights, pointwise, "mae", abs + ) + mae_i <- inputs$err_i + + res <- list( + estimate = mean(mae_i), + se = sqrt(var(mae_i) / length(mae_i)), + pointwise = mae_i + ) + .create_measure_structure( + res, "mae", n_draws = inputs$n_draws, n_obs = inputs$n_obs + ) +} + +#' Mean squared error (`mse`) +#' +#' Computes MSE between observed outcomes and posterior predictive point +#' predictions. Point predictions are obtained by averaging `mupred` draws, or +#' by PSIS-weighted averaging when `log_weights` is provided. +#' +#' @param pointwise Optional numeric vector of precomputed pointwise squared +#' errors. If provided, `y`, `mupred`, and `log_weights` are ignored. +#' @inheritParams measure_mae +#' +#' @examples +#' y <- c(1, 2, 3) +#' mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +#' measure_mse(y, mupred) +#' @inherit measure_params return +#' @export +measure_mse <- function( + y, mupred, log_weights = NULL, pointwise = NULL +) { + inputs <- .point_error_from_inputs( + y, mupred, log_weights, pointwise, "mse", function(e) e^2 + ) + sqe_i <- inputs$err_i + + res <- list( + estimate = mean(sqe_i), + se = sqrt(var(sqe_i) / length(sqe_i)), + pointwise = sqe_i + ) + .create_measure_structure( + res, "mse", n_draws = inputs$n_draws, n_obs = inputs$n_obs + ) +} + +#' Root mean squared error (`rmse`) +#' +#' Computes RMSE as the square root of MSE and propagates uncertainty via a +#' first-order delta-method approximation. +#' +#' @param pointwise Optional numeric vector of precomputed pointwise squared +#' errors. If provided, `y`, `mupred`, and `log_weights` are ignored. +#' @inheritParams measure_mae +#' +#' @examples +#' y <- c(1, 2, 3) +#' mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +#' measure_rmse(y, mupred) +#' @inherit measure_params return +#' @export +measure_rmse <- function( + y, mupred, log_weights = NULL, pointwise = NULL +) { + mse_res <- measure_mse( + y = y, mupred = mupred, log_weights = log_weights, + pointwise = pointwise + ) + n_draws <- if (is.null(pointwise)) nrow(mupred) else NULL + n_obs <- length(mse_res$pointwise) + + sqe_i <- mse_res$pointwise + rmse_est <- sqrt(mse_res$estimates[1]) + if (rmse_est == 0) { + rmse_se <- 0 + } else { + rmse_se <- mse_res$estimates[2] / (2 * rmse_est) + } + + res <- list( + estimate = rmse_est, + se = rmse_se, + pointwise = sqe_i + ) + .create_measure_structure( + 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 +#' the empirical variance of `y`. The standard error is computed with a +#' first-order delta-method approximation. +#' +#' @param pointwise Optional numeric vector of precomputed pointwise squared +#' errors. If provided, `mupred` and `log_weights` are ignored. `y` is always +#' required, because `r2` needs the variance of `y` as its baseline. +#' @inheritParams measure_mae +#' +#' @examples +#' y <- c(1, 2, 3) +#' mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +#' measure_r2(y, mupred) +#' @inherit measure_params return +#' @export +measure_r2 <- function( + y, mupred, log_weights = NULL, pointwise = NULL +) { + .validate_numeric_vector(y, arg = "y") + if (var(y) == 0) { + cli::cli_abort( + "{.fn r2} is undefined when {.arg y} has zero variance." + ) + } + + mse_res <- measure_mse( + y = y, + mupred = mupred, + log_weights = log_weights, + pointwise = pointwise + ) + mse_hat <- mse_res$estimates[1] + sqe_i <- mse_res$pointwise + n_obs <- length(sqe_i) + n_draws <- if (is.null(pointwise)) nrow(mupred) else NULL + + mse_y_i <- (y - mean(y))^2 + mse_y_hat <- mean(mse_y_i) + + 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, + # `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, "r2", n_draws = n_draws, n_obs = n_obs + ) +} + +#' Ranked Probability Score (RPS, SRPS, CRPS, SCRPS) +#' +#' Computes proper scoring rules based on the ranked probability score family, +#' covering both discrete and continuous outcomes, with optional scaling. +#' The specific score computed depends on the type of `y` and `ypred` and the +#' value of `scaled`: +#' +#' | `y`/`ypred` type | `scaled = FALSE` | `scaled = TRUE` | +#' |------------------|-----------------|-----------------| +#' | Discrete | RPS | SRPS | +#' | Continuous | CRPS | SCRPS | +#' +#' **Scoring rules:** +#' +#' - **RPS** (Epstein, 1969): Compares predictive and observed cumulative +#' distributions for ordered discrete outcomes. +#' - **CRPS** (Matheson & Winkler, 1976; Gneiting & Raftery, 2007): Generalizes +#' RPS to continuous outcomes. Defined as +#' \deqn{\mathrm{CRPS}(X; y) = E[|X - y|] - \frac{1}{2} E[|X - X'|],} +#' where \eqn{X, X'} are independent draws from the predictive distribution. +#' - **SRPS/SCRPS** (Bolin & Wallin, 2023): Scaled variants that are invariant +#' to the scale of the predictive distribution. Defined as +#' \deqn{\mathrm{SCRPS}(X; y) = -\frac{E[|X - y|]}{E[|X - X'|]} - +#' \frac{1}{2} \log E[|X - X'|].} +#' +#' **Estimation:** +#' +#' Scores are estimated using the probability-weighted moment (PWM) estimator +#' (Taillardat et al., 2016; Zamo & Naveau, 2018), which requires only a single +#' set of predictive draws unlike permutation-based estimators, which require +#' two independent draw sets. The PWM estimator is unbiased and generally more +#' 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. +#' +#' 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 (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 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 +#' +#' @examples +#' # Discrete outcomes: RPS +#' y <- c(2L, 1L, 3L) +#' ypred <- matrix(c(2, 1, 2, 3, 1, 3), nrow = 2) +#' measure_rps(y, ypred) +#' +#' # Discrete outcomes: SRPS (scaled) +#' measure_rps(y, ypred, scaled = TRUE) +#' +#' # Continuous outcomes: CRPS +#' y_cont <- c(0.5, -1.2, 2.3) +#' ypred_cont <- matrix(rnorm(200), nrow = 100, ncol = 3) +#' measure_rps(y_cont, ypred_cont) +#' +#' # With importance weights: LOO-CRPS +#' log_weights <- matrix(rnorm(200), nrow = 100, ncol = 3) +#' measure_rps(y_cont, ypred_cont, log_weights = log_weights) +#' +#' @references +#' Bolin, D. and Wallin, J. (2023). Local scale invariance and robustness of +#' proper scoring rules. *Statistical Science*, 38(1):140–159. +#' +#' Epstein, E. S. (1969). A scoring system for probability forecasts of ranked +#' categories. *Journal of Applied Meteorology*, 8(6):985–987. +#' +#' Gneiting, T. and Raftery, A. E. (2007). Strictly proper scoring rules, +#' prediction, and estimation. *Journal of the American Statistical +#' Association*, 102(477):359–378. +#' +#' Hosking, J. R. M. (1990). L-moments: Analysis and estimation of +#' distributions using linear combinations of order statistics. *Journal of +#' the Royal Statistical Society Series B*, 52(1):105–124. +#' +#' Hosking, J. R. M. (1996). Some theoretical results concerning L-moments. +#' Research report RC 14492. IBM Thomas J. Watson Research Division. +#' +#' Matheson, J. E. and Winkler, R. L. (1976). Scoring rules for continuous +#' probability distributions. *Management Science*, 22(10):1087–1096. +#' +#' Taillardat, M., Mestre, O., Zamo, M., and Naveau, P. (2016). Calibrated +#' ensemble forecasts using quantile regression forests and ensemble model +#' output statistics. *Monthly Weather Review*, 144(6):2375–2393. +#' +#' Zamo, M. and Naveau, P. (2018). Estimation of the continuous ranked +#' probability score with limited information and applications to ensemble +#' weather forecasts. *Mathematical Geosciences*, 50:209–234. +#' +#' @inherit measure_params return +#' @export +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 { + exp(.normalize_and_validate_log_weights( + log_weights = log_weights, + n_draws = n_draws, + n_obs = n_obs + )) + } + + EXX <- .exx_pwm(ypred, w) + EXy <- if (is.null(w)) { + colMeans(abs(sweep(ypred, 2, y))) + } else { + colSums(w * abs(sweep(ypred, 2, y))) + } + + rps_i <- if (scaled) { + # Scaled version by Bolin & Wallin (2023). The scaling divides by + # E|X - X'| and takes its logarithm, so a point-mass predictive + # distribution leaves the score undefined. + degenerate <- which(EXX == 0) + if (length(degenerate) > 0L) { + cli::cli_abort(c( + "The scaled rps score is undefined for {cli::qty(length(degenerate))} + observation{?s} {.val {degenerate}}.", + "i" = "{.code E|X - X'|} is 0 there: all the weight sits on a single + draw, so the predictive distribution is a point mass.", + "i" = "Check the PSIS diagnostics, or use the unscaled score + {.code scaled = FALSE}." + )) + } + -EXy / EXX - 0.5 * log(EXX) + } else { + # Gneiting & Raftery (2007) + EXy - 0.5 * EXX + } + } else { + rps_i <- pointwise + n_draws <- NULL + n_obs <- length(pointwise) + } + + res <- list( + estimate = mean(rps_i), + se = sqrt(var(rps_i) / n_obs), + pointwise = rps_i + ) + name <- if(isTRUE(scaled)) "srps" else "rps" + .create_measure_structure( + res, name, n_draws = n_draws, n_obs = n_obs + ) +} + +#' Scaled Ranked Probability Score (SRPS, SCRPS) +#' +#' A convenience wrapper around [measure_rps()] with `scaled = TRUE`. Computes the +#' scaled ranked probability score (SRPS) for discrete outcomes or the scaled +#' continuously ranked probability score (SCRPS) for continuous outcomes. +#' Scaling makes the score invariant to the spread of the predictive +#' distribution, which can be useful when comparing models across observations +#' with very different predictive uncertainties. +#' +#' See [measure_rps()] for full details on arguments, estimation, and references. +#' +#' @inheritParams measure_rps +#' +#' @examples +#' y <- c(2L, 1L, 3L) +#' ypred <- matrix(c(2, 1, 2, 3, 1, 3), nrow = 2) +#' measure_srps(y, ypred) +#' +#' @inherit measure_params return +#' @export +measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL) { + measure_rps( + y = y, ypred = ypred, log_weights = log_weights, pointwise = pointwise, + scaled = TRUE + ) +} + +# measure overview ----------------------------- +# +# Built-in measures are registered in `.measure_spec`. Users can also pass +# custom functions to `measures` in the pred_measure family; those functions +# must set `attr(fun, "measure_name")` and return `estimate`, `se`, and +# `pointwise` (see `?insample_pred_measure`). + +# internal function to get the measure specification +# @noRd +# @param measure The measure used. +# @return The measure specification. +# +# `needs_elpd = TRUE` marks a measure derived from the pointwise ELPD (`elpd`, +# `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, + diff_method = "sum", + needs_elpd = TRUE, + digits = 1 + ), + ic = list( + 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, + 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 [custom_measure()], 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 `custom_measure()`. 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. + 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` +#' argument of [insample_pred_measure()], [loo_pred_measure()], +#' [kfold_pred_measure()], [test_pred_measure()], and [pred_measure()]. +#' +#' @export +supported_measures_list <- names(.measure_spec) + +# internal function that produces output format for measures +.create_measure_structure <- function(res, measure_name, n_draws, n_obs) { + out <- list() + out$estimates <- matrix( + c(res$estimate, res$se), + nrow = 1, + dimnames = list(measure_name, c("Estimate", "SE")) + ) + out$pointwise <- matrix( + res$pointwise, + 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, + class = c("measure", "loo"), + measure = measure_name, + dims = c(n_draws, n_obs) + ) +} diff --git a/R/pred_measure-compute.R b/R/pred_measure-compute.R new file mode 100644 index 00000000..7479533e --- /dev/null +++ b/R/pred_measure-compute.R @@ -0,0 +1,890 @@ +#' Shared parameters for predictive measure wrappers +#' +#' @description +#' Parameter definitions shared by the user-facing entry points and the +#' internal engine [do_pred_measure()]. +#' +#' @param y Vector of observed values (`n`). Required for every measure except +#' `elpd`, `mlpd`, and `ic`. +#' @param ypred Matrix of posterior predictive draws (`S` draws × `n` +#' observations), typically from [brms::posterior_predict()]. Required for +#' `rps`, `srps`, and `brier`. +#' @param mupred Matrix of posterior expected values (`S` × `n`), typically from +#' [brms::posterior_epred()]. Required for `mae`, `mse`, +#' `rmse`, `r2`, `acc`, and `bacc`. +#' @param ylp Matrix of pointwise log predictive densities or probabilities +#' (`S` × `n`), typically from [brms::log_lik()], or a 3-D array +#' (`I` × `C` × `n`: iterations, chains, observations). Required for +#' density-based summaries (`elpd`, `mlpd`, `ic`). +#' @param ylp_test Matrix of pointwise log predictive densities for holdout +#' observations (`S` × `n_test`), or a 3-D array (`I` × `C` × `n_test`), +#' typically from +#' `brms::log_lik(fit, newdata = test_data)`. Used with `ylp` (from the +#' training fit) in [test_pred_measure()] to score genuinely new data. +#' @param predperf An existing predictive measure object (class +#' `"pred_measure"`) to update. When supplied, stored rows and +#' (for LOO) PSIS weights are reused instead of recomputed. +#' @param measures Measures to compute. `NULL` (default) gives `elpd` (with +#' `p_loo` / `p_kfold` for LOO and k-fold). Can be: +#' \itemize{ +#' \item A **character vector** of built-in names; see +#' [supported_measures_list]. +#' \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 `estimate`, `se`, and `pointwise`. A +#' length-2 `estimates` (estimate and SE) can replace `estimate` and `se`. +#' +#' 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 +#' `save_psis = TRUE` so that PSIS weights are available for additional +#' measures. See [loo_pred_measure()]. +#' @param kfold A `kfold` object from [brms::kfold()]. Supplies ELPD summaries +#' and fold structure for [kfold_pred_measure()]; pass `y`, `ypred`, and/or +#' `mupred` when requesting additional measures. +#' @param psis_object A `psis` object with LOO importance weights. An +#' alternative to passing a full `loo` object; must be supplied together with +#' `ylp` when computing `elpd`. +#' @param save_psis Logical. If `TRUE`, store the `psis` object in the result +#' so that additional measures can be added later with [pred_measure()] without +#' recomputing PSIS weights. +#' @param control Named list of per-measure settings. Each name must match an +#' element of `measures`; the value is a list of arguments passed to that +#' measure's summary function (e.g. `list(new_measure = list(add_arg = 10))`). +#' @param source Character string indicating the evaluation mode: `"insample"`, +#' `"loo"`, `"kfold"`, or `"test"`. Set automatically by the wrapper +#' functions; required when calling [do_pred_measure()] directly. +#' +#' @keywords internal +#' @name pred_measure_params +do_pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + ylp_test = NULL, + measures = NULL, + predperf = NULL, + loo = NULL, + kfold = NULL, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + source = NULL, + control = list() +) { + # input validation --------------------------------------------------- + if (!is.null(group_ids)) { + cli::cli_abort( + "`group_ids` is reserved for future feature but is not yet implemented." + ) + } + if (length(dim(ylp)) == 3) { + ylp <- llarray_to_matrix(ylp) + } + if (length(dim(ylp_test)) == 3) { + ylp_test <- llarray_to_matrix(ylp_test) + } + + measures <- .prepare_measures( + measures, predperf, supported_measures_list, source + ) + .validate_control(control, measures) + needs_elpd <- .any_needs_elpd(measures) + if (source == "loo") { + if (is.null(predperf)) { + if (!is.null(loo) && is.null(loo$psis_object)) { + cli::cli_abort(c( + "No {.field psis_object} found in {.arg loo}.", + "i" = "Did you run {.code 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`") + psis_object <- predperf$psis_object + } + } + checkmate::assert_null(ylp_test) + } else if (source == "insample") { + checkmate::assert_null(ylp_test) + checkmate::assert_null(psis_object) + } else if (source == "test") { + checkmate::assert_null(psis_object) + } else { # kfold + checkmate::assert_null(psis_object) + if (is.null(predperf) && is.null(kfold)) { + cli::cli_abort(c( + "{.arg kfold} is required for {.fn kfold_pred_measure}.", + "i" = "Pass a {.cls kfold} object from {.fn brms::kfold}." + )) + } + } + + # core logic --------------------------------------------------- + if (source == "loo") { + psis_object <- .get_psis_object( + loo = loo, + predperf = predperf, + psis_object = psis_object, + ylp = ylp, + r_eff = 1 + ) + } + + log_weights <- if (!is.null(psis_object)) psis_object$log_weights else NULL + + lppd_i <- if (needs_elpd) { + .elpd_pointwise( + source = source, ylp = ylp, ylp_test = ylp_test, + log_weights = log_weights, loo = loo, kfold = kfold, predperf = predperf + ) + } else NULL + + # an update adds rows to predperf; a new result starts empty + estimates <- predperf$estimates + pointwise <- predperf$pointwise + diagnostics <- if (!is.null(predperf)) { + predperf$diagnostics + } else if (source == "kfold") { + kfold$diagnostics + } else { + psis_object$diagnostics + } + + for (entry in measures) { + sel_measure <- .compute_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + measure_entry = entry, + log_weights = log_weights, + control = control, + lppd_i = lppd_i + ) + result_name <- attr(sel_measure, "measure") + 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)) { + cli::cli_warn(c( + "{.field {name_updated}} already present in results. Skipping the update." + )) + next + } + estimates <- .merge_matrix( + source = source, + mat = estimates, + name = result_name, + values = .measure_estimate_se(sel_measure), + margin = 1, + measure_entry = info_entry, + extra = sel_measure$extra + ) + pointwise <- .merge_matrix( + source = source, + mat = pointwise, + name = result_name, + values = sel_measure$pointwise, + margin = 2 + ) + + if (identical(entry$key, "elpd")) { + p_eff <- .effective_param(source, ylp, lppd_i, loo, kfold, predperf) + if (!is.null(p_eff)) { + estimates <- .merge_matrix( + source = source, mat = estimates, name = "p", + values = .measure_estimate_se(p_eff), margin = 1 + ) + pointwise <- .merge_matrix( + source = source, mat = pointwise, name = "p", + values = p_eff$pointwise, margin = 2 + ) + } + } + } + + predperf_res <- .build_pred_measure( + estimates = estimates, + pointwise = pointwise, + diagnostics = diagnostics, + psis_object = psis_object, + save_psis = save_psis + ) + + .add_attributes( + save_psis, + predperf_res, + y, + ypred, + mupred, + ylp, + ylp_test, + kfold, + loo, + predperf, + source + ) +} + +# 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 +#' Selects a PSIS object from the available inputs, or computes one from `ylp` +#' when no precomputed weights are supplied (assuming `r_eff = 1`). +#' +#' Resolution order: +#' \enumerate{ +#' \item If both `psis_object` and `loo` are provided, return `psis_object` +#' after verifying it matches `loo$psis_object`. +#' \item Extract from `loo$psis_object` when `loo` is provided. +#' \item Use the supplied `psis_object`. +#' \item Reuse `predperf$psis_object` when accumulating measures. +#' \item Reuse `predperf$log_weights` when only the weights were stored +#' (`save_psis = FALSE`); the result carries no `diagnostics`. +#' \item Compute from `ylp` via [loo::psis()] on `-ylp` log ratios. +#' } +#' +#' @param ylp Matrix of pointwise log predictive densities (`S` × `n`). +#' @param loo Optional [loo::loo()] result containing a `psis_object`. +#' @param predperf Optional existing measure object with a stored `psis_object`. +#' @param psis_object Optional precomputed PSIS object. +#' @param r_eff Relative effective sample size passed to [loo::psis()]; +#' default `1`. +#' +#' @return A `psis` object with `log_weights` and `diagnostics`. +#' +#' @note See developer notes on computation of the `psis_object` for details. +#' @noRd +.get_psis_object <- function( + ylp, + loo, + predperf, + psis_object, + r_eff = 1 +) { + # psis_object + loo are both provided -> return psis_object + if (!is.null(psis_object) && !is.null(loo)) { + psis_equal_loo <- isTRUE(all.equal( + psis_object$log_weights, + loo$psis_object$log_weights + )) + if (!psis_equal_loo) { + cli::cli_abort( + "Provided `psis_object` and `loo$psis_object` are not identical." + ) + } + return(psis_object) + # loo is provided + } else if (!is.null(loo)) { + return(loo$psis_object) + # psis_object is provided + } else if (!is.null(psis_object)) { + return(psis_object) + # predperf with psis_object is provided + } else if (!is.null(predperf$psis_object)) { + return(predperf$psis_object) + # predperf carries log_weights only (save_psis = FALSE) + } else if (!is.null(predperf$log_weights)) { + return(list(log_weights = predperf$log_weights)) + # ylp is provided + } else if (is.null(loo) && is.null(psis_object) && !is.null(ylp)) { + cli::cli_inform( + "Compute `psis_object` internally from `ylp` assuming `r_eff = 1`." + ) + log_ratios <- -1 * ylp + return(psis(log_ratios, r_eff = r_eff)) + # nothing is provided + } else { + cli::cli_abort(c( + "psis_object can not be computed, either of `psis_object`, `loo`, or", + "`ylp` needs to be provided." + )) + }} + +#' Extract estimate and SE from a measure result +#' +#' `.create_measure_structure()` gives every builtin measure an `estimates` +#' matrix. A custom measure returns either `estimates` or `estimate` and `se`. +#' +#' @noRd +.measure_estimate_se <- function(res) { + if (!is.null(res$estimates)) { + return(res$estimates) + } + c(res$estimate, res$se) +} + +#' Pointwise ELPD for the evaluation source +#' +#' @description +#' Gives the pointwise ELPD that `elpd`, `mlpd` and `ic` use. Resolution order: +#' \enumerate{ +#' \item Reuse the `elpd` column of `predperf`. +#' \item `kfold`: take `elpd_kfold` from the `kfold` object. +#' \item `loo` with a `loo` object: take `elpd_loo` from it. +#' \item Otherwise compute from `ylp` (`insample`, `loo` with `log_weights`) +#' or from `ylp_test` (`test`). +#' } +#' +#' @return Numeric vector of length `n`. +#' +#' @noRd +.elpd_pointwise <- function( + source, ylp, ylp_test, log_weights, loo, kfold, predperf +) { + col <- .measure_result_name(source, "elpd") + if (!is.null(predperf) && col %in% colnames(predperf$pointwise)) { + return(predperf$pointwise[, col]) + } + if (source == "kfold") { + if (is.null(kfold)) { + cli::cli_abort(c( + "{.field {col}} is not stored in {.arg predperf}.", + "i" = "Call {.fn kfold_pred_measure} with the {.cls kfold} object." + )) + } + return(kfold$pointwise[, col]) + } + if (source == "loo" && !is.null(loo)) { + return(loo$pointwise[, col]) + } + arg <- if (source == "test") "ylp_test" else "ylp" + input <- if (source == "test") ylp_test else ylp + if (is.null(input)) { + cli::cli_abort(c( + "{.arg {arg}} is required to compute {.field {col}}.", + "i" = "{.val elpd}, {.val mlpd} and {.val ic} are derived from {.field {col}}." + )) + } + weights <- if (source == "loo") log_weights else NULL + .lppd_from_inputs(input, weights, NULL, ".elpd_pointwise")$lppd_i +} + +#' Compute a single predictive measure +#' +#' @description +#' Dispatches one requested predictive measure to the appropriate summary +#' function. No measure has a fixed input list. The function builds a pool of +#' candidate arguments, then keeps only the ones the measure function declares: +#' +#' `args <- pool[intersect(names(formals(measure_fun)), names(pool))]` +#' +#' The pool holds `y`, `ypred`, `mupred`, `ylp` and `log_weights`, plus the +#' measure's slice of `control`. A measure that sets `needs_elpd` in +#' `.measure_spec` gets a different pool: `pointwise` holds the ELPD column +#' taken from `lppd_i`, and `ylp` and `log_weights` are `NULL`. +#' +#' @param y Vector of observed values (n). +#' @param ypred Matrix of posterior predictive draws (S × n). +#' @param mupred Matrix of posterior point predictions (S × n). +#' @param ylp Matrix of pointwise log predictive densities (S × n). +#' @param measure_entry A normalized measure entry with elements +#' `name`, `type` (`"builtin"` or `"custom"`), and `key`. +#' @param log_weights Matrix of log-weights (S × n), taken from the +#' `psis_object` of `.get_psis_object()`; `NULL` for every source but LOO. +#' @param control Named list of per-measure settings passed from +#' [pred_measure()]; the active slice is `control[[measure_entry$name]]`. +#' @param lppd_i Numeric vector from `.elpd_pointwise()`; read only when the +#' measure sets `needs_elpd`. +#' +#' @return The result of the measure function, in one of two shapes. +#' \describe{ +#' \item{builtin}{A `"measure"` object from `.create_measure_structure()`: +#' `estimates`, a 1 by 2 matrix with columns `Estimate` and `SE`, and +#' `pointwise`, an n by 1 matrix.} +#' \item{custom}{Either `estimates`, a length-2 numeric vector, or +#' `estimate` and `se` as scalars. `pointwise` is a numeric vector. +#' `.validate_measure_result()` accepts both.} +#' } +#' +#' @noRd +.compute_measure <- function( + y, + ypred, + mupred, + ylp, + measure_entry, + log_weights, + control = list(), + lppd_i +) { + if (measure_entry$type == "builtin") { + spec <- .measure_spec[[measure_entry$key]] + 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 + } + + measure_control <- control[[measure_entry$name]] + if (is.null(measure_control)) { + measure_control <- list() + } + + pool <- if (isTRUE(spec$needs_elpd)) { + if (is.function(spec$elpd_transform)) { + lppd_i <- spec$elpd_transform(lppd_i) + } + # `ylp` has no default, and `.inform_ignored_inputs()` forces it. Pass it as + # NULL rather than leaving it out. + list(ylp = NULL, log_weights = NULL, pointwise = lppd_i) + } else { + list( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + log_weights = log_weights + ) + } + + pool <- c(pool, measure_control) + args <- pool[intersect(names(formals(measure_fun)), names(pool))] + res <- do.call(measure_fun, args) + if (measure_entry$type == "custom") { + n_obs <- .measure_n_obs(y, ypred, mupred, ylp) + res <- .validate_measure_result(res, measure_entry$name, n_obs = n_obs) + } + res +} + +#' Effective number of parameters for the evaluation source +#' +#' @description +#' Gives `p_loo` or `p_kfold`, which follow the `elpd` row. It reuses a stored +#' row from `predperf`, `loo` or `kfold`. Otherwise, for `loo`, it computes +#' from `ylp` with `.compute_effective_param()`. +#' +#' @return A list with `estimate`, `se` and `pointwise`, or `NULL` for +#' `insample` and `test`, or when nothing is available. +#' +#' @noRd +.effective_param <- function(source, ylp, lppd_i, loo, kfold, predperf) { + if (!source %in% c("loo", "kfold")) { + return(NULL) + } + col <- .measure_result_name(source, "p") + stored <- if (!is.null(predperf)) predperf else if (source == "kfold") kfold else loo + if (col %in% rownames(stored$estimates)) { + return(list( + estimate = unname(stored$estimates[col, "Estimate"]), + se = unname(stored$estimates[col, "SE"]), + pointwise = stored$pointwise[, col] + )) + } + if (source == "loo" && !is.null(ylp)) { + return(.compute_effective_param(ylp, lppd_i)) + } + NULL +} + +#' Compute effective number of parameters (`p_loo`) +#' +#' @description +#' Per-observation effective number of parameters as the difference between +#' the log posterior predictive density (`lpd`) and the cross-validated log +#' predictive density (`elpd`). Summed across observations, this matches +#' `p_loo` from the **loo** package: it describes how much harder it is to +#' predict held-out data than the data used to fit the model. +#' +#' @param ylp Matrix of pointwise log predictive densities (`S` × `n`). +#' @param elpd_cv_i Numeric vector of length `n` with LOO pointwise ELPD +#' contributions. +#' +#' @return A named list with `estimate` (total `p_loo`), `se`, and `pointwise` +#' (`p_loo` per observation). +#' +#' @references See the **loo** package glossary ([loo-glossary]) +#' and \url{https://users.aalto.fi/~ave/CV-FAQ.html#p_loo}. +#' +#' @noRd +.compute_effective_param <- function(ylp, elpd_cv_i) { + lpd_i <- matrixStats::colLogSumExps(ylp) - log(nrow(ylp)) + p_eff_i <- lpd_i - elpd_cv_i + + list( + estimate = sum(p_eff_i), + se = sqrt(ncol(ylp) * var(p_eff_i)), + pointwise = p_eff_i + ) +} + +#' Append the source suffix to a measure name +#' @noRd +.measure_result_name <- function(source, name) { + switch( + source, + kfold = paste0(name, "_kfold"), + loo = paste0(name, "_loo"), + test = paste0(name, "_test"), + insample = name + ) +} + +#' Add or update a row or column in a summary matrix +#' +#' @description +#' Builds the `estimates` and `pointwise` matrices used in +#' [pred_measure()] results. When `margin = 1`, appends or updates a **row** +#' (for estimates). When `margin = 2`, appends or updates a **column** +#' (for pointwise). +#' +#' If `mat` is `NULL`, returns a new one-row or one-column matrix for `name`. +#' If `name` is already present along that margin, the update is skipped with a +#' warning. Otherwise the new slice is bound with [rbind()] or [cbind()]. +#' +#' @param source Character string; one of `"loo"`, `"insample"`, `"kfold"`, or +#' `"test"`. +#' @param mat Existing matrix, or `NULL` when adding the first measure. +#' @param name Character label for the row (`margin = 1`) or column +#' (`margin = 2`). +#' @param values Numeric vector to store. For `margin = 1`, length-2 vector +#' `(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. +#' +#' @noRd +.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) + + new_slice <- if (is_row) { + matrix(values, nrow = 1, dimnames = list(name_updated, c("Estimate", "SE"))) + } else { + matrix(values, ncol = 1, dimnames = list(NULL, name_updated)) + } + + 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 +#' +#' @description +#' Wraps computed summaries into the list structure returned by the +#' [pred_measure()] pipeline. S3 classes and attributes are attached later by +#' \code{.add_attributes()}. +#' +#' When `save_psis = TRUE`, the `psis_object` is stored in the result; otherwise +#' that slot is omitted. When a `psis_object` is available, its `log_weights` are +#' copied to the result. +#' +#' @param estimates Matrix of overall estimates and standard errors (rows = +#' measures, columns = `Estimate` and `SE`). +#' @param pointwise Matrix of observation-level contributions (columns = +#' measures). +#' @param diagnostics Optional PSIS or other diagnostic information, or `NULL`. +#' @param psis_object PSIS object with LOO weights and diagnostics, or `NULL`. +#' @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`. 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( + estimates, + pointwise, + diagnostics = NULL, + 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 + ) + if (!is.null(diagnostics)) { + output_list$diagnostics <- diagnostics + } + if (isTRUE(save_psis)) { + output_list$psis_object <- psis_object + } + if (!is.null(psis_object)) { + output_list$log_weights <- psis_object$log_weights + } + + structure( + output_list, + measure_info = measure_info + ) +} + +#' Attach S3 classes and metadata attributes to a result +#' +#' @description +#' 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.). Sets +#' `measure_info`, seeding the `elpd` entry. +#' +#' @param save_psis Logical; when `FALSE` and accumulating, clears stored +#' `psis_object` from the prior result. +#' @param predperf_res List returned by \code{.build_pred_measure()}. +#' @param y Vector of observed values; used indirectly via matrix `dims`. +#' @param ypred Matrix of posterior predictive draws; used to set `dims`. +#' @param mupred Matrix of posterior expected values; used to set `dims`. +#' @param ylp Matrix of pointwise log predictive densities; used to set `dims`. +#' @param ylp_test Matrix of holdout log predictive densities; sets `dims` for +#' `source = "test"`. +#' @param kfold Optional `kfold` object whose attributes are inherited. +#' @param loo Optional [loo::loo()] object whose attributes are inherited. +#' @param predperf Existing object when accumulating measures, or `NULL`. +#' @param source Character evaluation mode (`"insample"`, `"loo"`, `"kfold"`, +#' or `"test"`). +#' +#' @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 +) { + new_info <- attr(predperf_res, "measure_info") + if (is.null(new_info)) { + new_info <- list() + } + + if (!is.null(predperf)) { + predperf_res <- .copy_attrs( + predperf_res, + predperf, + setdiff(names(attributes(predperf)), "names") + ) + + dims <- if (!is.null(ypred)) { + dim(ypred) + } else if (!is.null(mupred)) { + dim(mupred) + } else if (!is.null(ylp)) { + dim(ylp) + } else { + 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( + predperf_res, + kfold, + setdiff(names(attributes(kfold)), "names") + ), + loo = .copy_attrs( + predperf_res, + loo, + setdiff(names(attributes(loo)), "names") + ), + test = , # fall through (same as insample) + insample = predperf_res + ) + + if (source %in% c("insample", "test") || + (is.null(attr(predperf_res, "dims")) && !is.null(ylp))){ + # make attribute names consistent between pred_measure classes + if (source == "test") { + attr(predperf_res, "dims") <- attr(ylp_test, "dim") + } else { + attr(predperf_res, "dims") <- attr(ylp, "dim") + } + } + + classes <- c( + switch( + source, + loo = "loo_pred_measure", + insample = "insample_pred_measure", + kfold = "kfold_pred_measure", + test = "test_pred_measure", + "pred_measure" + ), + "pred_measure", + attr(predperf_res, "class") + ) + if (source == "loo" && !"loo" %in% classes) { + classes <- c(classes, "loo") + } + attr(predperf_res, "class") <- classes + attr(predperf_res, "source") <- source + 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 new file mode 100644 index 00000000..25778fa8 --- /dev/null +++ b/R/pred_measure-helpers.R @@ -0,0 +1,840 @@ +#' Normalize the `measure` argument to an internal list +#' +#' @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). Custom entries also carry `loss`, taken from +#' `attr(fun, "measure_loss")`. +#' +#' @param measure User-supplied `measure` argument. +#' +#' @return A list of normalized measure entries, or an empty list when +#' `measure` is `NULL`. +#' +#' @noRd +.normalize_measure <- function(measure) { + if (is.null(measure)) { + return(list()) + } + + if (is.function(measure)) { + entries <- list(.measure_entry_custom(measure)) + .check_measure_entry_names(entries) + return(entries) + } + + if (is.character(measure)) { + entries <- lapply(measure, function(nm) { + list(name = nm, type = "builtin", key = nm) + }) + .check_measure_entry_names(entries) + return(entries) + } + + if (is.list(measure)) { + if (length(measure) == 0L) { + return(list()) + } + entries <- lapply(seq_along(measure), function(i) { + el <- measure[[i]] + nm <- names(measure)[i] + if (is.character(el) && length(el) == 1L) { + list(name = el, type = "builtin", key = el) + } else if (is.function(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 measures} must be a character scalar (built-in", + "name) or a function (custom measure).", + "i" = "Element {i} has type {.cls {class(el)[1]}}." + )) + } + }) + .check_measure_entry_names(entries) + return(entries) + } + + cli::cli_abort(c( + "{.arg measures} must be a character vector, a function, a list, or", + "{.code NULL}.", + "i" = "Got an object of class {.cls {class(measure)[1]}}." + )) +} + +#' 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 = 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 {.val {name}} in {.arg measures} was named", + "{.val {attr_name}} in {.fn custom_measure}.", + "i" = "Using the list name {.val {name}}; the {.fn custom_measure} name 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, loss = loss, + se_diff = se_diff) +} + +#' Check duplicate measure names +#' +#' @param entries List of normalized measure entries from `.normalize_measure()`. +#' @noRd +.check_measure_entry_names <- function(entries) { + names <- vapply(entries, `[[`, "", "name") + dups <- names[duplicated(names)] + if (length(dups) > 0L) { + cli::cli_abort(c( + "Duplicate measure names in {.arg measures}: {.val {unique(dups)}}", + "i" = "Each measure may appear only once." + )) + } + invisible(NULL) +} + +#' Normalize, validate, and filter the `measure` argument +#' +#' @description +#' Converts `measure` via `.normalize_measure()`, validates built-in names and +#' custom functions, and drops entries already present in `predperf`. An empty +#' measure gives `"elpd"` for a new result. +#' +#' @param measure User-supplied `measure` argument (see `.normalize_measure()`). +#' @param predperf Existing pred_measure object used when accumulating measures. +#' @param supported_measures_list Character vector of allowed built-in names. +#' @param source Character evaluation mode (`"insample"`, `"loo"`, `"kfold"`, +#' or `"test"`); selects the row-name suffix used to match `predperf`. +#' +#' @return A list of normalized measure entries ready for computation. +#' +#' @noRd +.prepare_measures <- function( + measure, predperf, supported_measures_list, source +) { + if (length(measure) == 0L) { + if (!is.null(predperf)) return(list()) + measure <- "elpd" + } + entries <- .normalize_measure(measure) + + is_builtin <- vapply(entries, function(e) e$type == "builtin", logical(1L)) + builtin_keys <- vapply(entries[is_builtin], function(e) e$key, character(1L)) + invalid <- setdiff(builtin_keys, supported_measures_list) + if (length(invalid) > 0L) { + cli::cli_abort(c( + "Invalid measure{?s}: {paste(shQuote(invalid), collapse = ', ')}", + "i" = "Built-in measures must be one of:", + " " = "{paste(shQuote(supported_measures_list), collapse = ', ')}" + )) + } + + is_custom <- !is_builtin + if (any(is_custom)) { + for (entry in entries[is_custom]) { + checkmate::assert_function(entry$key, .var.name = "measures") + } + } + + if (!is.null(predperf)) { + existing_measures <- rownames(predperf$estimates) + entry_names <- vapply( + entries, + function(e) .measure_result_name(source, e$name), + character(1L) + ) + dups <- intersect(entry_names, existing_measures) + if (length(dups) > 0L) { + cli::cli_warn(c( + "!" = "{cli::qty(length(dups))} Measure{?s} {.val {dups}} {?is/are}", + "already present in {.arg predperf} and will be skipped." + )) + } + keep <- !(entry_names %in% existing_measures) + entries <- entries[keep] + } + + entries +} + +#' Check whether any measure needs the pointwise `elpd` +#' +#' @description +#' Returns `TRUE` if a built-in entry sets `needs_elpd` in `.measure_spec` +#' (`elpd`, `mlpd`, `ic`). Custom entries never need it. +#' +#' @param entries Normalized measure entries from `.prepare_measures()`. +#' +#' @return A single logical. +#' +#' @noRd +.any_needs_elpd <- function(entries) { + any(vapply(entries, function(e) { + e$type == "builtin" && isTRUE(.measure_spec[[e$key]]$needs_elpd) + }, logical(1L))) +} + +#' Infer number of observations from measure inputs +#' +#' @noRd +.measure_n_obs <- function(y, ypred, mupred, ylp) { + if (!is.null(y)) { + return(length(y)) + } + if (!is.null(ypred)) { + return(ncol(ypred)) + } + if (!is.null(mupred)) { + return(if (length(dim(mupred)) == 3L) dim(mupred)[2L] else ncol(mupred)) + } + if (!is.null(ylp)) { + return(ncol(ylp)) + } + NULL +} + +#' Validate the return value of a custom measure function +#' +#' @param res Object returned by a custom measure function. +#' @param measure_name Label used in error messages. +#' @param n_obs Expected length of `pointwise`, or `NULL` to skip. +#' +#' @return `res`, invisibly. +#' +#' @noRd +.validate_measure_result <- function(res, measure_name, n_obs = NULL) { + if (!is.list(res)) { + cli::cli_abort(c( + "Custom measure {.val {measure_name}} must return a list.", + "i" = "Got an object of class {.cls {class(res)[1]}}." + )) + } + + if (!is.null(res$estimates)) { + if (!is.numeric(res$estimates) || length(res$estimates) != 2L) { + cli::cli_abort(c( + "{.field estimates} from custom measure {.val {measure_name}} must be", + "a numeric vector of length 2 (estimate and SE)." + )) + } + } else { + missing <- setdiff(c("estimate", "se", "pointwise"), names(res)) + if (length(missing) > 0L) { + cli::cli_abort(c( + "Custom measure {.val {measure_name}} must return a list with", + "{.field estimate}, {.field se}, and {.field pointwise}.", + "x" = "Missing: {.field {missing}}" + )) + } + if (!is.numeric(res$estimate) || length(res$estimate) != 1L) { + cli::cli_abort( + "{.field estimate} from custom measure {.val {measure_name}} must be a numeric scalar." + ) + } + if (!is.numeric(res$se) || length(res$se) != 1L) { + cli::cli_abort( + "{.field se} from custom measure {.val {measure_name}} must be a numeric scalar." + ) + } + } + + if (is.null(res$pointwise)) { + cli::cli_abort( + "Custom measure {.val {measure_name}} must return {.field pointwise}." + ) + } + if (!is.numeric(res$pointwise) || length(res$pointwise) < 1L) { + cli::cli_abort( + "{.field pointwise} from custom measure {.val {measure_name}} must be a numeric vector." + ) + } + if (!is.null(n_obs) && length(res$pointwise) != n_obs) { + cli::cli_abort(c( + "{.field pointwise} from custom measure {.val {measure_name}} must have", + "length {.val {n_obs}}, not {.val {length(res$pointwise)}}." + )) + } + # 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) +} + +#' Validate a numeric matrix argument +#' +#' @description +#' Checks that `x` is a numeric matrix with at least one row and column. +#' Optionally enforces expected `nrow` and/or `ncol`. Aborts via +#' [cli::cli_abort()] when validation fails. +#' +#' @param x Object to validate. +#' @param arg Name of the argument (used in error messages). +#' @param nrow Expected number of rows, or `NULL` to skip this check. +#' @param ncol Expected number of columns, or `NULL` to skip this check. +#' +#' @return `NULL`, invisibly, on success. +#' +#' @noRd +.validate_numeric_matrix <- function(x, arg, nrow = NULL, ncol = NULL) { + if (!is.numeric(x) || (!is.matrix(x) && !is.array(x))) { + cli::cli_abort( + "{.arg {arg}} must be a numeric matrix or array, not {.obj_type_friendly {x}}." + ) + } + if (!is.null(nrow) && nrow(x) != nrow) { + cli::cli_abort( + "{.arg {arg}} must have {.val {nrow}} row{?s}, not {.val {nrow(x)}}." + ) + } + if (!is.null(ncol) && ncol(x) != ncol) { + cli::cli_abort( + "{.arg {arg}} must have {.val {ncol}} column{?s}, not {.val {ncol(x)}}." + ) + } + if (nrow(x) < 1 || ncol(x) < 1) { + cli::cli_abort("{.arg {arg}} must have at least 1 row and 1 column.") + } +} + +#' Validate a numeric vector argument +#' +#' @description +#' Checks that `x` is a numeric atomic vector (not a matrix or array) with +#' length at least one. Optionally enforces an expected `len`. Aborts via +#' [cli::cli_abort()] when validation fails. +#' +#' @param x Object to validate. +#' @param arg Name of the argument (used in error messages). +#' @param len Expected length, or `NULL` to skip this check. +#' +#' @return `NULL`, invisibly, on success. +#' +#' @noRd +.validate_numeric_vector <- function(x, arg, len = NULL) { + if (!is.atomic(x) || !is.numeric(x) || is.matrix(x) || is.array(x)) { + cli::cli_abort("{.arg {arg}} must be a numeric vector.") + } + if (!is.null(len) && length(x) != len) { + cli::cli_abort( + "{.arg {arg}} must have length {.val {len}}, not {.val {length(x)}}." + ) + } + if (length(x) < 1) { + cli::cli_abort("{.arg {arg}} must not be empty.") + } +} + +#' Validate and normalize log weights +#' +#' @description +#' Validates that `log_weights` is a numeric matrix of size `n_draws` by +#' `n_obs`, then column-normalizes it via `.normalize_log_weights()`. +#' +#' @param log_weights Numeric matrix of log weights (`n_draws` \eqn{\times} +#' `n_obs`). +#' @param n_draws Expected number of rows (posterior draws). +#' @param n_obs Expected number of columns (observations). +#' +#' @return Numeric matrix of the same dimensions as `log_weights` with +#' column-normalized log weights. +#' +#' @noRd +.normalize_and_validate_log_weights <- function(log_weights, n_draws, n_obs) { + .validate_numeric_matrix( + log_weights, + arg = "log_weights", + nrow = n_draws, + ncol = n_obs + ) + .normalize_log_weights(log_weights) +} + +#' Inform about ignored inputs when pointwise is supplied +#' +#' @description +#' When `pointwise` is not `NULL`, emits an informative message via +#' [cli::cli_inform()] listing non-`NULL` entries in `ignored_args` that are +#' not used. +#' +#' @param pointwise Optional precomputed pointwise contributions. When +#' `NULL`, no message is emitted. +#' @param ignored_args Named list of arguments that may be ignored (e.g. +#' `ylp`, `log_weights`). +#' @param fun_name Name of the calling function (shown in the message). +#' +#' @return `NULL`, invisibly. +#' +#' @noRd +.inform_ignored_inputs <- function(pointwise, ignored_args, fun_name) { + if (is.null(pointwise)) { + return(invisible(NULL)) + } + supplied <- names(ignored_args)[vapply(ignored_args, Negate(is.null), logical(1))] + if (length(supplied) > 0L) { + cli::cli_inform( + "In {.fn {fun_name}}, {.arg pointwise} is provided; ignoring {.arg {supplied}}." + ) + } + invisible(NULL) +} + +#' Validate probability values +#' +#' @description +#' Checks that all elements of `x` lie in the closed interval \eqn{[0, 1]}. +#' Aborts via [cli::cli_abort()] when any value is out of range. +#' +#' @param x Numeric vector or matrix of probabilities. +#' @param arg Name of the argument (used in error messages). +#' +#' @return `NULL`, invisibly, on success. +#' +#' @noRd +.validate_probs <- function(x, arg) { + if (!all(x >= 0 & x <= 1)) { + cli::cli_abort("{.arg {arg}} must contain values in [0, 1].") + } +} + +#' Pointwise log predictive density from measure inputs +#' +#' @description +#' `measure_elpd()`, `measure_mlpd()` and `measure_ic()` take the same inputs: +#' precomputed `pointwise` values, or an `ylp` matrix with optional +#' `log_weights`. This helper holds their shared validation. +#' +#' @param ylp A draws x observations matrix of log predictive densities, or a +#' 3-D array. +#' @param log_weights Optional log weights, normalized before use. +#' @param pointwise Optional numeric vector of precomputed pointwise values. +#' @param fun_name Name of the calling measure. Used in the message that +#' reports ignored inputs. +#' +#' @return A list with `lppd_i`, `n_draws` (`NULL` when `pointwise` is +#' supplied) and `n_obs`. +#' +#' @noRd +.lppd_from_inputs <- function(ylp, log_weights, pointwise, fun_name) { + if (!is.null(pointwise)) { + .validate_numeric_vector(pointwise, arg = "pointwise") + .inform_ignored_inputs( + pointwise, + ignored_args = list(ylp = ylp, log_weights = log_weights), + fun_name = fun_name + ) + return(list(lppd_i = pointwise, n_draws = NULL, n_obs = length(pointwise))) + } + + .validate_numeric_matrix(ylp, arg = "ylp") + ylp <- if (is.array(ylp) && length(dim(ylp)) == 3) { + llarray_to_matrix(ylp) + } else { + ylp + } + n_draws <- nrow(ylp) + n_obs <- ncol(ylp) + if (!is.null(log_weights)) { + log_weights <- .normalize_and_validate_log_weights( + log_weights = log_weights, n_draws = n_draws, n_obs = n_obs + ) + } + list( + lppd_i = ptw_log_pred_density(ylp, log_weights), + n_draws = n_draws, + n_obs = n_obs + ) +} + +#' Weighted pointwise classification accuracy +#' +#' @description +#' Shared by `measure_acc()` and `measure_bacc()`. Maps each observation to a +#' predicted class, then compares it with `y`. Binary `mupred` is thresholded +#' at 0.5. A 3-D `mupred` takes the argmax over categories. +#' +#' @param y An integer vector of observed class labels. +#' @param mupred A draws x observations matrix, or a draws x observations x +#' categories array, of predicted probabilities. +#' @param log_weights Optional log weights. Draws are equally weighted when +#' `NULL`. +#' +#' @return An integer vector of 0/1 accuracy contributions. +#' +#' @noRd +.acc_pointwise <- function(y, mupred, log_weights) { + if (!is.numeric(mupred) || (length(dim(mupred)) != 2 && length(dim(mupred)) != 3)) { + cli::cli_abort( + "{.arg mupred} must be a numeric matrix or 3D numeric array." + ) + } + .validate_probs(mupred, arg = "mupred") + + valid_y_labels <- if (length(dim(mupred)) == 3) seq_len(dim(mupred)[3]) else c(0, 1) + if (!all(y %in% valid_y_labels)) { + cli::cli_abort(c( + "{.arg y} does not match the coding of {.arg mupred}.", + "i" = "Observed values: {.val {sort(unique(y))}}", + "x" = "All elements of {.arg y} must be in {.val {valid_y_labels}}." + )) + } + + if (!is.null(log_weights)) { + weights <- exp(.normalize_and_validate_log_weights( + log_weights = log_weights, + n_draws = nrow(mupred), + n_obs = dim(mupred)[2] + )) + } else { + weights <- rep(1 / nrow(mupred), nrow(mupred)) + } + + if (length(dim(mupred)) == 3) { + # Multiclass: (draws × obs × categories) > argmax over categories + weighted_mupred <- apply(array(weights, dim(mupred)) * mupred, c(2, 3), sum) + mupred_hat <- apply(weighted_mupred, 1, which.max) + } else { + .validate_numeric_matrix(mupred, arg = "mupred") + weighted_mupred <- colSums(mupred * weights) + mupred_hat <- (weighted_mupred > 0.5) * 1L + } + + (mupred_hat == y) * 1L +} + +#' Pointwise prediction error from measure inputs +#' +#' @description +#' Shared by `measure_mae()` and `measure_mse()`. Forms a point prediction for +#' each observation, then applies `transform` to the residual. The point +#' prediction is the mean of the `mupred` draws, or their weighted mean when +#' `log_weights` is supplied. +#' +#' @param y A numeric vector of observed outcomes. +#' @param mupred A draws x observations matrix of point predictions. A vector +#' is coerced to a 1 x n matrix. +#' @param log_weights Optional log weights, normalized before use. +#' @param pointwise Optional numeric vector of precomputed pointwise errors. +#' @param fun_name Name of the calling measure. Used in the messages that +#' report ignored inputs and the coercion of `mupred`. +#' @param transform Function applied to the residual `y - yhat`. +#' +#' @return A list with `err_i`, `n_draws` (`NULL` when `pointwise` is +#' supplied) and `n_obs`. +#' +#' @noRd +.point_error_from_inputs <- function(y, mupred, log_weights, pointwise, + fun_name, transform) { + if (!is.null(pointwise)) { + .inform_ignored_inputs( + pointwise, + ignored_args = list(mupred = mupred, log_weights = log_weights), + fun_name = fun_name + ) + return(list(err_i = pointwise, n_draws = NULL, n_obs = length(pointwise))) + } + + .validate_numeric_vector(y, arg = "y") + if (!is.null(mupred) && !is.matrix(mupred)) { + .validate_numeric_vector(mupred, arg = "mupred", len = length(y)) + cli::cli_inform( + "Coercing {.arg mupred} from vector to 1 x n matrix for {.fn {fun_name}}." + ) + mupred <- matrix(mupred, nrow = 1, ncol = length(mupred)) + } + .validate_numeric_matrix(mupred, arg = "mupred", ncol = length(y)) + n_draws <- nrow(mupred) + n_obs <- ncol(mupred) + if (is.null(log_weights)) { + yhat <- colMeans(mupred) + } else { + weights <- exp(.normalize_and_validate_log_weights( + log_weights = log_weights, n_draws = n_draws, n_obs = n_obs + )) + yhat <- colSums(weights * mupred) + } + list(err_i = transform(y - yhat), n_draws = n_draws, n_obs = n_obs) +} + +#' Copy selected attributes between objects +#' +#' @description +#' Copies attributes named in `which` from `from` onto `to`, overwriting any +#' existing attributes with the same names. +#' +#' @param to Object receiving attributes. +#' @param from Object supplying attributes. +#' @param which Character vector of attribute names to copy. +#' +#' @return `to`, with updated attributes. +#' +#' @noRd +.copy_attrs <- function(to, from, which) { + for (nm in which) { + attr(to, nm) <- attr(from, nm) + } + to +} + +#' Normalize log weights +#' +#' @description +#' Normalizes a matrix of log weights column-wise so that the weights in each +#' column sum to one on the probability scale. Normalization is performed by +#' subtracting the log-sum-exp of each column from its elements, equivalent to +#' dividing each column's weights by their sum on the probability scale. +#' +#' @param log_weights Numeric matrix of log weights (`n_draws` \eqn{\times} +#' `n_obs`), where rows are draws and columns are observations. +#' +#' @return Numeric matrix of the same dimensions as `log_weights` with +#' column-normalized log weights. +#' +#' @noRd +.normalize_log_weights <- function(log_weights) { + sweep( + log_weights, + 2, + matrixStats::colLogSumExps(log_weights), + FUN = "-", + check.margin = FALSE + ) +} + + +#' Probability-weighted moment estimator of E|X - X'| +#' +#' @description +#' Estimates \eqn{E[|X - X'|]}, the expected absolute difference between two +#' independent draws from the predictive distribution, which is the term the +#' (S)RPS and (S)CRPS scores in [measure_rps()] are built from. Written as a +#' weighted U-statistic over draw pairs, the estimator is +#' \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} = \frac{2 \sum_s w_{(s)} x_{(s)} (C_s + C_{s-1} - 1)}{1 - +#' \sum_s w_{(s)}^2},} +#' where \eqn{x_{(s)}} are the draws sorted in ascending order, \eqn{w_{(s)}} +#' their weights, and \eqn{C_s = \sum_{k \le s} w_{(k)}}. The second form is the +#' one computed here and needs only a single sort and cumulative sum per column. +#' +#' With equal weights \eqn{w_{(s)} = 1/S} this reduces exactly to the classic +#' unbiased pairwise estimator with the \eqn{1 / (S (S - 1))} normalization, +#' i.e. `colMeans(x_sorted * 2 * (2 * (1:S) - S - 1) / (S - 1))`, which is the +#' probability-weighted moment estimator of Taillardat et al. (2016). Because +#' the estimate is a convex combination of \eqn{|x_i - x_j|} it is always +#' 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 +#' probability scale, of the same dimensions as `ypred`. `NULL` (the default) +#' uses equal weights and takes the faster unweighted path. +#' +#' @return Numeric vector of length `ncol(ypred)` with one estimate of +#' \eqn{E[|X - X'|]} per observation. +#' +#' @noRd +.exx_pwm <- function(ypred, w = NULL) { + n_draws <- nrow(ypred) + if (n_draws < 2) { + stop( + "`ypred` must have at least 2 draws (rows) to estimate E|X - X'|, ", + "which the RPS/CRPS measures require.", + call. = FALSE + ) + } + + if (is.null(w)) { + ypred_sorted <- apply(ypred, 2, sort) + coefs <- 2 * (2 * seq_len(n_draws) - n_draws - 1) / (n_draws - 1) + return(colMeans(ypred_sorted * coefs)) + } + + vapply( + seq_len(ncol(ypred)), + function(j) { + ord <- order(ypred[, j]) + x_sorted <- ypred[ord, j] + w_sorted <- w[ord, j] + denominator <- 1 - sum(w_sorted^2) + # All the weight sits on a single draw: the pair (X, X') is degenerate + # and E|X - X'| is 0. + if (denominator <= 0) { + return(0) + } + # C_s + C_{s-1} = 2 * C_s - w_(s) + coefs <- 2 * cumsum(w_sorted) - w_sorted - 1 + 2 * sum(w_sorted * x_sorted * coefs) / denominator + }, + numeric(1) + ) +} + +#' 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 +#' 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, measures = NULL) { + res <- checkmate::check_list(control, types = "list", names = "named") + if (!isTRUE(res)) { + cli::cli_abort(c( + "{.arg control} must be a named list of named lists.", + "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)) { + 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 +#' +#' @description +#' Subsets the measure results to the specified measures and components. +#' +#' @param x Measure results object. +#' @param measures Character vector of measures to subset. +#' @param components Character vector of components to subset. +#' +#' @return Subsetted measure results object. +#' +#' @noRd +subset_measures <- function(x, measures, components) { + invalid_components <- setdiff(components, names(x)) + if (length(invalid_components) > 0) { + cli::cli_abort(c( + "{.arg components} contains invalid value{?s}: {.val {invalid_components}}.", + "i" = "Valid components: {.val {names(x)}}." + )) + } + components <- intersect(components, names(x)) + + available_measures <- if ("estimates" %in% components) { + rownames(x$estimates) + } else if ("pointwise" %in% components) { + colnames(x$pointwise) + } + + if (!is.null(available_measures)) { + invalid_measures <- setdiff(measures, available_measures) + if (length(invalid_measures) > 0) { + cli::cli_abort(c( + "{.arg measures} contains invalid value{?s}: {.val {invalid_measures}}.", + "i" = "Valid measures: {.val {available_measures}}." + )) + } + } + + result <- x[components] + + if ("estimates" %in% components) { + rows <- intersect(measures, rownames(result$estimates)) + result$estimates <- result$estimates[rows, , drop = FALSE] + } + + if ("pointwise" %in% components) { + cols <- intersect(measures, colnames(result$pointwise)) + result$pointwise <- result$pointwise[, cols, drop = FALSE] + } + + result +} diff --git a/R/pred_measure.R b/R/pred_measure.R new file mode 100644 index 00000000..f4cfeaa8 --- /dev/null +++ b/R/pred_measure.R @@ -0,0 +1,563 @@ +#' In-sample predictive performance measures +#' +#' @description +#' Compute predictive performance measures on the same data used to fit the +#' model. This is the simplest entry point when you want density scores +#' (`elpd`) and optional distributional or point-prediction metrics in +#' one call. +#' +#' In-sample `elpd` sums the expected log pointwise predictive density (ELPD) +#' over the training observations. Because the model has already seen these +#' data, in-sample scores are **optimistically biased** for predicting future +#' or otherwise unseen observations. For out-of-sample performance, use +#' [loo_pred_measure()], [kfold_pred_measure()], or [test_pred_measure()] +#' instead; see Vehtari's +#' [Cross-validation FAQ](https://users.aalto.fi/~ave/CV-FAQ.html) (Section 4). +#' +#' @inheritParams pred_measure_params +#' +#' @return +#' An object of class `"insample_pred_measure"` and `"pred_measure"`: a list +#' with: +#' \describe{ +#' \item{`estimates`}{Matrix of summary estimates and standard errors (rows +#' are measures, columns are `Estimate` and `SE`). The row `elpd` is +#' present when `measures` is `NULL` (default) or names "elpd".} +#' \item{`pointwise`}{Matrix of observation-level contributions (one column +#' per measure).} +#' } +#' +#' The attribute `source` is `"insample"`. Attribute `dims` gives posterior +#' 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 +#' needs: +#' +#' | Measure | `ylp` | `y` | `ypred` | `mupred` | +#' |:---|:---:|:---:|:---:|:---:| +#' | `elpd`, `mlpd`, `ic` | ✓ | | | | +#' | `rps`, `srps`, `brier` | | ✓ | ✓ | | +#' | `acc`, `bacc` | | ✓ | | ✓ | +#' | `mae`, `mse`, `rmse`, `r2` | | ✓ | | ✓ | +#' +#' "elpd" is the default measure. `mlpd` and `ic` are derived from `elpd`, but +#' requesting them does not add an `elpd` row. Request `ic`, `mlpd`, or other +#' density scores via `measures`, or supply a custom function; +#' see [supported_measures_list] and the +#' [Predictive model performance: Overview of measures](https://mc-stan.org/loo/articles/articles-online-only/overview-measures.html) +#' article for definitions and orientation (higher vs lower is better). +#' +#' **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)) { +#' fit <- brms::brm( +#' Reaction ~ Days, data = lme4::sleepstudy, +#' refresh = 0, chains = 2, iter = 1000 +#' ) +#' insample_pred_measure( +#' ylp = brms::log_lik(fit), +#' y = fit$data$Reaction, +#' ypred = brms::posterior_predict(fit), +#' mupred = brms::posterior_epred(fit), +#' measures = c("rmse", "r2") +#' ) +#' } +#' } +#' \dontrun{ +#' # Custom measure (same contract as built-in point-prediction metrics) +#' my_abs_err <- function(y, mupred, log_weights = NULL) { +#' mu <- colMeans(mupred) +#' pw <- abs(y - mu) +#' list( +#' estimate = mean(pw), +#' se = sd(pw) / sqrt(length(pw)), +#' pointwise = pw +#' ) +#' } +#' # 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) +#' } +#' +#' @seealso [pred_measure()] to add measures incrementally, +#' [loo_pred_measure()], [kfold_pred_measure()], [test_pred_measure()], +#' [supported_measures_list], +#' [Predictive model performance: Predictive schemes with `pred_measure()`](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html) +#' +#' @export +insample_pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measures = NULL, + group_ids = NULL, + save_psis = FALSE, + control = list() +) { + do_pred_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + measures = measures, + predperf = NULL, + loo = NULL, + kfold = NULL, + group_ids = group_ids, + psis_object = NULL, + save_psis = save_psis, + source = "insample", + control = control + ) +} + +#' PSIS-LOO predictive performance measures +#' +#' @description +#' Estimate out-of-sample predictive performance with **PSIS-LOO** +#' (Pareto-smoothed importance sampling leave-one-out cross-validation). +#' PSIS-LOO approximates exact LOO-CV without refitting the model once per +#' observation: each held-out point is scored by reweighting the full-data +#' posterior draws. +#' +#' With the default `measures = NULL`, the result holds `elpd_loo`, the LOO +#' estimate of expected log pointwise predictive density (ELPD), and `p_loo` +#' (effective number of parameters, the difference between in-sample and LOO +#' log predictive density). `p_loo` is reported together with `elpd_loo`. +#' See [loo::loo()] and the +#' [Cross-validation FAQ](https://users.aalto.fi/~ave/CV-FAQ.html) for +#' interpretation. +#' +#' @inheritParams pred_measure_params +#' +#' @return +#' An object of class `"loo_pred_measure"`, `"pred_measure"`, and `"loo"`. +#' When a `loo` object is supplied, additional classes from that object are +#' inherited (e.g. `"psis_loo"`). In addition to `estimates` and +#' `pointwise`, the list may contain: +#' \describe{ +#' \item{`diagnostics`}{PSIS diagnostics, including Pareto \eqn{\hat{k}} in +#' `diagnostics$pareto_k`. A value above the sample-size dependent +#' threshold \eqn{\min(1 - 1 / \log_{10}(S), 0.7)}, where \eqn{S} is the +#' number of draws, suggests an unreliable LOO estimate for that +#' observation. The `print()` method reports the threshold it used.} +#' \item{`log_weights`}{Normalized log importance weights used for LOO +#' scoring.} +#' \item{`psis_object`}{Stored when `save_psis = TRUE`; needed to add +#' further measures with [pred_measure()] without recomputing weights.} +#' } +#' +#' Measure names carry a `_loo` suffix (e.g. `elpd_loo`, `rps_loo`). +#' +#' @template measure-info-attribute +#' +#' @details +#' **Three input patterns:** +#' +#' \describe{ +#' \item{Precomputed `loo` object}{`loo_pred_measure(loo = loo_fit, ...)`. +#' Run [loo::loo()] with `save_psis = TRUE`.} +#' \item{`ylp` + `psis_object`}{Pass both when you have already computed +#' PSIS weights separately.} +#' \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 (`rps`, `r2`, etc.), +#' supply `y`, `ypred`, and/or `mupred` as for [insample_pred_measure()]. When +#' adding measures incrementally, call [pred_measure()] with `predperf` set to +#' an existing result; use `save_psis = TRUE` on the initial call so weights +#' are stored. +#' +#' @examples +#' \donttest{ +#' if (requireNamespace("brms", quietly = TRUE)) { +#' fit <- brms::brm( +#' Reaction ~ Days, data = lme4::sleepstudy, +#' refresh = 0, chains = 2, iter = 1000 +#' ) +#' loo_fit <- loo::loo(fit, save_psis = TRUE) +#' loo_pred_measure( +#' loo = loo_fit, +#' y = fit$data$Reaction, +#' ypred = brms::posterior_predict(fit), +#' measures = c("rmse", "r2") +#' ) +#' } +#' } +#' +#' @seealso [insample_pred_measure()], [pred_measure()], [loo::loo()], +#' [supported_measures_list], +#' [Predictive model performance: Predictive schemes with `pred_measure()`](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html) +#' +#' @export +loo_pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measures = NULL, + loo = NULL, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + control = list() +) { + do_pred_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + ylp_test = NULL, + measures = measures, + predperf = NULL, + loo = loo, + kfold = NULL, + group_ids = group_ids, + psis_object = psis_object, + save_psis = save_psis, + source = "loo", + control = control + ) +} + +#' K-fold cross-validation predictive performance measures +#' +#' @description +#' Compute predictive performance measures under **k-fold cross-validation**. +#' K-fold CV holds out groups of observations, refits (or reuses stored fits), +#' and scores the held-out folds. +#' +#' Pass a `kfold` object from [brms::kfold()] (with `save_fits = TRUE` when +#' you need posterior predictions on held-out folds). `elpd_kfold` and +#' `p_kfold` come from the `kfold` object and are reported by default or when +#' `measures` names "elpd"; +#' additional measures require the same optional inputs as +#' [insample_pred_measure()]. +#' +#' @inheritParams pred_measure_params +#' +#' @return +#' An object of class `"kfold_pred_measure"` and `"pred_measure"`, inheriting +#' attributes from the `kfold` object (`K`, `folds`, `fold_type`, etc.). The +#' list contains `estimates` and `pointwise`; measure names carry a `_kfold` +#' suffix (e.g. `elpd_kfold`, `rps_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 +#' `ypred` and/or `mupred`. See the sleep-study workflow in +#' [Predictive model performance: Predictive schemes with `pred_measure()`](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html). +#' +#' @examples +#' \donttest{ +#' if (requireNamespace("brms", quietly = TRUE)) { +#' fit <- brms::brm( +#' Reaction ~ Days, data = lme4::sleepstudy, +#' refresh = 0, chains = 2, iter = 1000 +#' ) +#' kf <- brms::kfold(fit, K = 5, save_fits = TRUE) +#' ypred_kf <- brms::kfold_predict(kf, method = "predict")$yrep +#' mupred_kf <- brms::kfold_predict(kf, method = "fitted")$yrep +#' kfold_pred_measure( +#' y = fit$data$Reaction, +#' ypred = ypred_kf, +#' mupred = mupred_kf, +#' kfold = kf, +#' measures = "rmse" +#' ) +#' } +#' } +#' +#' @seealso [loo_pred_measure()], [insample_pred_measure()], [pred_measure()], +#' [brms::kfold()], [supported_measures_list], +#' [Predictive model performance: Predictive schemes with `pred_measure()`](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html) +#' +#' @export +kfold_pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measures = NULL, + kfold = NULL, + group_ids = NULL, + control = list() +) { + do_pred_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + ylp_test = NULL, + measures = measures, + predperf = NULL, + loo = NULL, + kfold = kfold, + group_ids = group_ids, + psis_object = NULL, + save_psis = FALSE, + source = "kfold", + control = control + ) +} + +#' Holdout predictive performance measures +#' +#' @description +#' Score predictive performance on **genuinely new (holdout) data** that was +#' not used to fit the model. This mirrors the cross-validation goal of +#' assessing how well a model predicts unseen observations, but with an +#' explicit train/test split rather than LOO or k-fold reweighting. +#' +#' Supply `ylp_test` from log predictive densities evaluated on the holdout set +#' (e.g. `brms::log_lik(fit, newdata = test_data)`). This is required for +#' `elpd_test`, `mlpd_test` and `ic_test`. Optional distributional and +#' point-prediction measures use observed and predicted values on the test set +#' only. Pass training `ylp` only when an additional measure needs log +#' predictive densities from the training fit. +#' +#' @inheritParams pred_measure_params +#' +#' @return +#' An object of class `"test_pred_measure"` and `"pred_measure"` with +#' `estimates` and `pointwise`. Measure names carry a `_test` suffix (e.g. +#' `elpd_test`, `rps_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. +#' +#' @examples +#' \donttest{ +#' if (requireNamespace("brms", quietly = TRUE)) { +#' data <- lme4::sleepstudy +#' train <- data[1:150, ] +#' test <- data[151:nrow(data), ] +#' fit <- brms::brm( +#' Reaction ~ Days, data = train, +#' refresh = 0, chains = 2, iter = 1000 +#' ) +#' test_pred_measure( +#' y = test$Reaction, +#' ypred = brms::posterior_predict(fit, newdata = test), +#' mupred = brms::posterior_epred(fit, newdata = test), +#' ylp = brms::log_lik(fit), +#' ylp_test = brms::log_lik(fit, newdata = test), +#' measures = c("rmse", "r2") +#' ) +#' } +#' } +#' +#' @seealso [insample_pred_measure()], [loo_pred_measure()], +#' [kfold_pred_measure()], [pred_measure()], [supported_measures_list], +#' [Predictive model performance: Predictive schemes with `pred_measure()`](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html) +#' +#' @export +test_pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + ylp_test = NULL, + measures = NULL, + group_ids = NULL, + control = list() +) { + do_pred_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + ylp_test = ylp_test, + measures = measures, + predperf = NULL, + loo = NULL, + kfold = NULL, + group_ids = group_ids, + psis_object = NULL, + save_psis = FALSE, + source = "test", + control = control + ) +} + +#' Add predictive performance measures to an existing result +#' +#' @description +#' Extend a `"pred_measure"` object with additional measures **without +#' recomputing** what is already stored. Use this for interactive exploration +#' or when you first compute `elpd` and later add distributional +#' or point-prediction metrics. +#' +#' Pass the existing object as `predperf` and supply any inputs newly required +#' by the requested measures (see the input table in +#' [insample_pred_measure()]). The evaluation mode (`"insample"`, `"loo"`, +#' `"kfold"`, or `"test"`) is taken from `predperf`; LOO paths reuse stored +#' PSIS weights when available. +#' +#' @inheritParams pred_measure_params +#' +#' @return +#' An updated object of the same class as `predperf`, with new rows in +#' `estimates` and columns in `pointwise` for each requested measure. Rows +#' already in `predperf` are not recomputed. If `mlpd` or `ic` needs `elpd` and +#' `predperf` has no `elpd` column, `elpd` is recomputed from `ylp` for +#' insample and LOO results. For k-fold and test results this is an error. +#' +#' @details +#' **Typical workflow:** +#' +#' \preformatted{ +#' result <- loo_pred_measure(loo = loo_fit, save_psis = TRUE) +#' pred_measure( +#' y = y, +#' mupred = mupred, +#' predperf = result, +#' measures = c("rmse", "r2") +#' ) +#' } +#' +#' When extending a LOO result, ensure the initial call used `save_psis = TRUE` +#' (or that `predperf` already contains a `psis_object`) so LOO weights are +#' available for additional measures. +#' +#' @examples +#' \donttest{ +#' if (requireNamespace("brms", quietly = TRUE)) { +#' fit <- brms::brm( +#' Reaction ~ Days, data = lme4::sleepstudy, +#' refresh = 0, chains = 2, iter = 1000 +#' ) +#' result <- insample_pred_measure( +#' ylp = brms::log_lik(fit), +#' y = fit$data$Reaction, +#' ypred = brms::posterior_predict(fit) +#' ) +#' pred_measure( +#' y = fit$data$Reaction, +#' mupred = brms::posterior_epred(fit), +#' predperf = result, +#' measures = c("rmse", "r2") +#' ) +#' } +#' } +#' +#' @seealso [insample_pred_measure()], [loo_pred_measure()], +#' [kfold_pred_measure()], [test_pred_measure()], [supported_measures_list], +#' [Predictive model performance: Predictive schemes with `pred_measure()`](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html) +#' +#' @export +pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measures = NULL, + predperf, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + control = list() +) { + if (!inherits(predperf, "pred_measure")) { + cli::cli_abort(c( + "{.arg predperf} must be a {.cls pred_measure} object.", + "i" = "Got an object of class {.cls {class(predperf)[1]}}." + )) + } + + do_pred_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + ylp_test = NULL, + measures = measures, + predperf = predperf, + loo = NULL, + kfold = NULL, + group_ids = group_ids, + psis_object = psis_object, + save_psis = save_psis, + source = attr(predperf, "source"), + control = control + ) +} + +#' @export +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 `measures` +#' 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 1f4030b8..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))] @@ -249,3 +328,86 @@ convert_old_object <- function(x, digits = 1, ...) { ses <- grepl("se", nms) list(estimates = data.frame(Estimate = uz[!ses], SE = uz[ses])) } + +# print.R: S3 print methods for predictive measure objects and source +# labeling helpers. + + +#' @export +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) + } + source <- .pred_measure_source_label(x) + + cat("\n") + if (!is.null(dims) && length(dims) == 2) { + cat( + sprintf( + "Computed from %s posterior draws and %s observations.\n", + dims[1], + dims[2] + ) + ) + } + cat(sprintf("Data source: %s\n\n", source)) + print( + .format_estimates(x$estimates, digits, suffix = .compare_suffix(list(x))), + quote = FALSE + ) + invisible(x) +} + +#' @export +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 + if (is.null(pareto_k)) { + cat("No Pareto-k diagnostics available.\n") + return(invisible(x)) + } + + print(pareto_k_table(x), digits = 1) + + if (plot_k) { + graphics::plot( + pareto_k, + ylab = "Pareto-k", + xlab = "Observation", + main = "Pareto-k diagnostics", + pch = 16 + ) + } + invisible(x) +} + +.pred_measure_source_label <- function(x) { + labels <- c(loo = "loo", insample = "in-sample", kfold = "k-fold", test = "test") + source <- attr(x, "source") + if (!is.null(source) && source %in% names(labels)) { + return(unname(labels[source])) + } + # fall back to the class, for objects that lost their attributes + cls <- class(x) + hit <- names(labels)[paste0(names(labels), "_pred_measure") %in% cls] + if (length(hit)) unname(labels[hit[1]]) else "unknown" +} + +#' @export +print.measure <- function(x, digits = NULL, ...) { + dims <- attr(x, "dims") + name <- attr(x, "measure") + + if (length(dims) < 2) { + # number of draws are NULL + cat("\nComputed from", dims[1], "pointwise terms.\n\n") + } else { + cat("\nComputed from", dims[1], "draws by", dims[2], "observations.\n\n") + } + + print(.format_estimates(x$estimates, digits), quote = FALSE) + + invisible(x) +} diff --git a/R/psis.R b/R/psis.R index 85f8883c..fcda5ad3 100644 --- a/R/psis.R +++ b/R/psis.R @@ -320,7 +320,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()) } } @@ -389,27 +389,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/psislw.R b/R/psislw.R index 808e657f..7b9176e1 100644 --- a/R/psislw.R +++ b/R/psislw.R @@ -2,6 +2,8 @@ #' #' As of version `2.0.0` this function is **deprecated**. Please use the #' [psis()] function for the new PSIS algorithm. +#' `psislw()` and `R/psislw.R` are scheduled for removal in a future release. +#' See `vignette("migration-guide", package = "loo")` for details. #' #' @export #' @param lw A matrix or vector of log weights. For computing LOO, `lw = diff --git a/R/waic.R b/R/waic.R index 507d8b7b..cc907884 100644 --- a/R/waic.R +++ b/R/waic.R @@ -27,10 +27,11 @@ #' } #' #' @seealso -#' * The __loo__ package [vignettes](https://mc-stan.org/loo/articles/) and +#' * The __loo__ package [vignettes](https://mc-stan.org/loo/articles/index.html) 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 e5f24649..98a01188 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -26,6 +26,19 @@ articles: - loo2-large-data - loo2-moment-matching - loo2-mixis + - title: Migration + desc: | + Guides for updating code when APIs change. + contents: + - migration-guide + - title: Predictive performance measures + desc: | + Reference and workflow articles for the `*_pred_measure()` API (website + only; not included in the CRAN package). + contents: + - articles-online-only/pred-measure-workflow + - articles-online-only/overview-measures + - articles-online-only/model-comparison - title: Frequently asked questions contents: - faq @@ -63,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 @@ -73,12 +87,23 @@ reference: - kfold_split_stratified - kfold_split_grouped - kfold - - elpd + - title: Predictive performance measures + desc: | + Unified API for predictive performance measures (density scores, scoring + rules, and point-prediction metrics) with in-sample, LOO, K-fold, and + holdout evaluation modes. + contents: + - insample_pred_measure + - loo_pred_measure + - kfold_pred_measure + - test_pred_measure + - pred_measure + - custom_measure + - supported_measures_list + - starts_with("measure_") + - ptw_log_pred_density - title: Other functions contents: - - loo_predictive_metric - - crps - - elpd - waic - extract_log_lik - pointwise @@ -92,5 +117,8 @@ reference: - update.psis_loo_ss - title: Deprecated functions contents: + - elpd + - crps + - loo_predictive_metric - compare - psislw 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 11412fe4..21b317d5 100644 --- a/man/compare.Rd +++ b/man/compare.Rd @@ -21,8 +21,9 @@ 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 -instead. +\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. } \details{ When comparing two fitted models, we can estimate the difference in their diff --git a/man/crps.Rd b/man/crps.Rd index 72f848df..4fe7a885 100644 --- a/man/crps.Rd +++ b/man/crps.Rd @@ -11,7 +11,7 @@ \alias{scrps.matrix} \alias{scrps.numeric} \alias{loo_scrps.matrix} -\title{Continuously ranked probability score} +\title{Continuously ranked probability score (deprecated)} \usage{ crps(x, ...) @@ -85,6 +85,17 @@ The former reports estimator and standard error and latter the pointwise values. Following Bolin & Wallin (2023), a larger value is better. } \description{ +As of loo 3.0.0, \code{crps()}, \code{scrps()}, \code{loo_crps()}, and \code{loo_scrps()} are +\strong{deprecated}. Please use \code{\link[=measure_rps]{measure_rps()}} and \code{\link[=measure_srps]{measure_srps()}} instead, +or \code{\link[=loo_pred_measure]{loo_pred_measure()}} for leave-one-out predictive performance. +See \code{vignette("migration-guide", package = "loo")} for a full mapping table. +} +\details{ +The new functions use a single matrix of posterior predictive draws +(\code{ypred}) and a PWM estimator. The deprecated functions require two +independent draw matrices (\code{x} and \code{x2}) and use a permutation-based +estimator. See \code{\link[=measure_rps]{measure_rps()}} for migration details. + The \code{crps()} and \code{scrps()} functions and their \verb{loo_*()} counterparts can be used to compute the continuously ranked probability score (CRPS) and scaled CRPS (SCRPS) (as defined by Bolin and Wallin, 2023). CRPS is a proper scoring rule, and @@ -92,8 +103,7 @@ strictly proper when the first moment of the predictive distribution is finite. Both can be expressed in terms of samples form the predictive distribution. See, for example, a paper by Gneiting and Raftery (2007) for a comprehensive discussion on CRPS. -} -\details{ + To compute (S)CRPS, the user needs to provide two sets of draws, \code{x} and \code{x2}, from the predictive distribution. This is due to the fact that formulas used to compute CRPS involve an expectation of the absolute difference of \code{x} @@ -102,14 +112,15 @@ as well as Gneiting and Raftery (2007) for details. } \examples{ \dontrun{ -# An example using rstanarm +# Deprecated: library(rstanarm) data("kidiq") fit <- stan_glm(kid_score ~ mom_hs + mom_iq, data = kidiq) ypred1 <- posterior_predict(fit) ypred2 <- posterior_predict(fit) crps(ypred1, ypred2, y = fit$y) -loo_crps(ypred1, ypred2, y = fit$y, log_lik = log_lik(fit)) +# -> +measure_rps(y = fit$y, ypred = ypred1) } } @@ -121,3 +132,6 @@ Gneiting, T., & Raftery, A. E. (2007). Strictly Proper Scoring Rules, Prediction, and Estimation. Journal of the American Statistical Association, 102(477), 359–378. } +\seealso{ +\code{\link[=measure_rps]{measure_rps()}}, \code{\link[=measure_srps]{measure_srps()}}, \code{\link[=loo_pred_measure]{loo_pred_measure()}} +} diff --git a/man/custom_measure.Rd b/man/custom_measure.Rd new file mode 100644 index 00000000..af7c4655 --- /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{measures} +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/elpd.Rd b/man/elpd.Rd index 35bde6eb..c1016dcb 100644 --- a/man/elpd.Rd +++ b/man/elpd.Rd @@ -4,7 +4,7 @@ \alias{elpd} \alias{elpd.array} \alias{elpd.matrix} -\title{Generic (expected) log-predictive density} +\title{Generic (expected) log-predictive density (deprecated)} \usage{ elpd(x, ...) @@ -20,11 +20,18 @@ each method.} \item{...}{Currently ignored.} } \description{ +As of loo 3.0.0, \code{elpd()} is \strong{deprecated}. Please use \code{\link[=measure_elpd]{measure_elpd()}} +instead. For full predictive performance workflows, see +\code{\link[=insample_pred_measure]{insample_pred_measure()}} and \code{\link[=loo_pred_measure]{loo_pred_measure()}}. +See \code{vignette("migration-guide", package = "loo")} for a full mapping table. +} +\details{ +The return type differs: \code{elpd()} returns class \code{"elpd_generic"} with +\code{elpd} and \code{ic} in \code{pointwise}; \code{measure_elpd()} returns class \code{"measure"}. + The \code{elpd()} methods for arrays and matrices can compute the expected log pointwise predictive density for a new dataset or the log pointwise predictive density of the observed data (an overestimate of the elpd). -} -\details{ The \code{elpd()} function is an S3 generic and methods are provided for 3-D pointwise log-likelihood arrays and matrices. } @@ -40,13 +47,16 @@ of data points. }} \examples{ -# Calculate the lpd of the observed data +\dontrun{ +# Deprecated: LLarr <- example_loglik_array() elpd(LLarr) +# -> +measure_elpd(LLarr) +} } \seealso{ -The vignette \emph{Holdout validation and K-fold cross-validation of Stan -programs with the loo package} for demonstrations of using the \code{elpd()} -methods. +\code{\link[=measure_elpd]{measure_elpd()}}, \code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=loo_pred_measure]{loo_pred_measure()}}, +and the vignette \emph{Holdout validation and K-fold cross-validation}. } 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 new file mode 100644 index 00000000..96dccd06 --- /dev/null +++ b/man/insample_pred_measure.Rd @@ -0,0 +1,201 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure.R +\name{insample_pred_measure} +\alias{insample_pred_measure} +\title{In-sample predictive performance measures} +\usage{ +insample_pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measures = NULL, + group_ids = NULL, + save_psis = FALSE, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for every measure except +\code{elpd}, \code{mlpd}, and \code{ic}.} + +\item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} +observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +\code{rps}, \code{srps}, and \code{brier}.} + +\item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from +\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for \code{mae}, \code{mse}, +\code{rmse}, \code{r2}, \code{acc}, and \code{bacc}.} + +\item{ylp}{Matrix of pointwise log predictive densities or probabilities +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}, or a 3-D array +(\code{I} × \code{C} × \code{n}: iterations, chains, observations). Required for +density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{measures}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\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{estimate}, \code{se}, and \code{pointwise}. A +length-2 \code{estimates} (estimate and SE) can replace \code{estimate} and \code{se}. + +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).} + +\item{save_psis}{Logical. If \code{TRUE}, store the \code{psis} object in the result +so that additional measures can be added later with \code{\link[=pred_measure]{pred_measure()}} without +recomputing PSIS weights.} + +\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))}).} +} +\value{ +An object of class \code{"insample_pred_measure"} and \code{"pred_measure"}: a list +with: +\describe{ +\item{\code{estimates}}{Matrix of summary estimates and standard errors (rows +are measures, columns are \code{Estimate} and \code{SE}). The row \code{elpd} is +present when \code{measures} is \code{NULL} (default) or names "elpd".} +\item{\code{pointwise}}{Matrix of observation-level contributions (one column +per measure).} +} + +The attribute \code{source} is \code{"insample"}. Attribute \code{dims} gives posterior +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 +model. This is the simplest entry point when you want density scores +(\code{elpd}) and optional distributional or point-prediction metrics in +one call. + +In-sample \code{elpd} sums the expected log pointwise predictive density (ELPD) +over the training observations. Because the model has already seen these +data, in-sample scores are \strong{optimistically biased} for predicting future +or otherwise unseen observations. For out-of-sample performance, use +\code{\link[=loo_pred_measure]{loo_pred_measure()}}, \code{\link[=kfold_pred_measure]{kfold_pred_measure()}}, or \code{\link[=test_pred_measure]{test_pred_measure()}} +instead; see Vehtari's +\href{https://users.aalto.fi/~ave/CV-FAQ.html}{Cross-validation FAQ} (Section 4). +} +\details{ +\strong{Input requirements by measure.} Supply only the inputs each measure +needs:\tabular{lcccc}{ + Measure \tab \code{ylp} \tab \code{y} \tab \code{ypred} \tab \code{mupred} \cr + \code{elpd}, \code{mlpd}, \code{ic} \tab ✓ \tab \tab \tab \cr + \code{rps}, \code{srps}, \code{brier} \tab \tab ✓ \tab ✓ \tab \cr + \code{acc}, \code{bacc} \tab \tab ✓ \tab \tab ✓ \cr + \code{mae}, \code{mse}, \code{rmse}, \code{r2} \tab \tab ✓ \tab \tab ✓ \cr +} + + +"elpd" is the default measure. \code{mlpd} and \code{ic} are derived from \code{elpd}, but +requesting them does not add an \code{elpd} row. Request \code{ic}, \code{mlpd}, or other +density scores via \code{measures}, or supply a custom function; +see \link{supported_measures_list} and the +\href{https://mc-stan.org/loo/articles/articles-online-only/overview-measures.html}{Predictive model performance: Overview of measures} +article for definitions and orientation (higher vs lower is better). + +\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)) { + fit <- brms::brm( + Reaction ~ Days, data = lme4::sleepstudy, + refresh = 0, chains = 2, iter = 1000 + ) + insample_pred_measure( + ylp = brms::log_lik(fit), + y = fit$data$Reaction, + ypred = brms::posterior_predict(fit), + mupred = brms::posterior_epred(fit), + measures = c("rmse", "r2") + ) +} +} +\dontrun{ +# Custom measure (same contract as built-in point-prediction metrics) +my_abs_err <- function(y, mupred, log_weights = NULL) { + mu <- colMeans(mupred) + pw <- abs(y - mu) + list( + estimate = mean(pw), + se = sd(pw) / sqrt(length(pw)), + pointwise = pw + ) +} +# 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) +} + +} +\seealso{ +\code{\link[=pred_measure]{pred_measure()}} to add measures incrementally, +\code{\link[=loo_pred_measure]{loo_pred_measure()}}, \code{\link[=kfold_pred_measure]{kfold_pred_measure()}}, \code{\link[=test_pred_measure]{test_pred_measure()}}, +\link{supported_measures_list}, +\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{Predictive model performance: Predictive schemes with \code{pred_measure()}} +} 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 new file mode 100644 index 00000000..c5efeb0d --- /dev/null +++ b/man/kfold_pred_measure.Rd @@ -0,0 +1,149 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure.R +\name{kfold_pred_measure} +\alias{kfold_pred_measure} +\title{K-fold cross-validation predictive performance measures} +\usage{ +kfold_pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measures = NULL, + kfold = NULL, + group_ids = NULL, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for every measure except +\code{elpd}, \code{mlpd}, and \code{ic}.} + +\item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} +observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +\code{rps}, \code{srps}, and \code{brier}.} + +\item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from +\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for \code{mae}, \code{mse}, +\code{rmse}, \code{r2}, \code{acc}, and \code{bacc}.} + +\item{ylp}{Matrix of pointwise log predictive densities or probabilities +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}, or a 3-D array +(\code{I} × \code{C} × \code{n}: iterations, chains, observations). Required for +density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{measures}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\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{estimate}, \code{se}, and \code{pointwise}. A +length-2 \code{estimates} (estimate and SE) can replace \code{estimate} and \code{se}. + +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 +\code{mupred} when requesting additional measures.} + +\item{group_ids}{Optional vector of group identifiers for grouped summaries +(reserved; not yet implemented).} + +\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))}).} +} +\value{ +An object of class \code{"kfold_pred_measure"} and \code{"pred_measure"}, inheriting +attributes from the \code{kfold} object (\code{K}, \code{folds}, \code{fold_type}, etc.). The +list contains \code{estimates} and \code{pointwise}; measure names carry a \verb{_kfold} +suffix (e.g. \code{elpd_kfold}, \code{rps_kfold}). +} +\description{ +Compute predictive performance measures under \strong{k-fold cross-validation}. +K-fold CV holds out groups of observations, refits (or reuses stored fits), +and scores the held-out folds. + +Pass a \code{kfold} object from \code{\link[brms:kfold]{brms::kfold()}} (with \code{save_fits = TRUE} when +you need posterior predictions on held-out folds). \code{elpd_kfold} and +\code{p_kfold} come from the \code{kfold} object and are reported by default or when +\code{measures} names "elpd"; +additional measures require the same optional inputs as +\code{\link[=insample_pred_measure]{insample_pred_measure()}}. +} +\details{ +For distributional measures on held-out folds, obtain posterior predictions +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}{Predictive model performance: Predictive schemes with \code{pred_measure()}}. +} +\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)) { + fit <- brms::brm( + Reaction ~ Days, data = lme4::sleepstudy, + refresh = 0, chains = 2, iter = 1000 + ) + kf <- brms::kfold(fit, K = 5, save_fits = TRUE) + ypred_kf <- brms::kfold_predict(kf, method = "predict")$yrep + mupred_kf <- brms::kfold_predict(kf, method = "fitted")$yrep + kfold_pred_measure( + y = fit$data$Reaction, + ypred = ypred_kf, + mupred = mupred_kf, + kfold = kf, + measures = "rmse" + ) +} +} + +} +\seealso{ +\code{\link[=loo_pred_measure]{loo_pred_measure()}}, \code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=pred_measure]{pred_measure()}}, +\code{\link[brms:kfold]{brms::kfold()}}, \link{supported_measures_list}, +\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{Predictive model performance: Predictive schemes with \code{pred_measure()}} +} diff --git a/man/loo-glossary.Rd b/man/loo-glossary.Rd index 58529429..3fc67a9f 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{
}}\preformatted{p_worse = pnorm(0, elpd_diff, se_diff). }\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,126 @@ 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 what the user passes to +\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, what the user passed to \code{\link[=custom_measure]{custom_measure()}}; +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{\link[=custom_measure]{custom_measure()}} 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 +438,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_model_weights.Rd b/man/loo_model_weights.Rd index 4a74d5fd..2d4af65a 100644 --- a/man/loo_model_weights.Rd +++ b/man/loo_model_weights.Rd @@ -238,8 +238,8 @@ stacking to average Bayesian predictive distributions. } \seealso{ \itemize{ -\item The \strong{loo} package \href{https://mc-stan.org/loo/articles/}{vignettes}, particularly -\href{https://mc-stan.org/loo/articles/loo2-weights.html}{Bayesian Stacking and Pseudo-BMA weights using the \strong{loo} package}. +\item The \strong{loo} package \href{https://mc-stan.org/loo/articles/index.html}{vignettes}, particularly +\href{https://mc-stan.org/loo/articles/loo2-weights.html}{Bayesian Stacking and Pseudo-BMA weights}. \item \code{\link[=loo]{loo()}} for details on leave-one-out ELPD estimation. \item \code{\link[=constrOptim]{constrOptim()}} for the choice of optimization methods and control-parameters. \item \code{\link[=relative_eff]{relative_eff()}} for computing \code{r_eff}. diff --git a/man/loo_pred_measure.Rd b/man/loo_pred_measure.Rd new file mode 100644 index 00000000..5314159b --- /dev/null +++ b/man/loo_pred_measure.Rd @@ -0,0 +1,186 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure.R +\name{loo_pred_measure} +\alias{loo_pred_measure} +\title{PSIS-LOO predictive performance measures} +\usage{ +loo_pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measures = NULL, + loo = NULL, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for every measure except +\code{elpd}, \code{mlpd}, and \code{ic}.} + +\item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} +observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +\code{rps}, \code{srps}, and \code{brier}.} + +\item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from +\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for \code{mae}, \code{mse}, +\code{rmse}, \code{r2}, \code{acc}, and \code{bacc}.} + +\item{ylp}{Matrix of pointwise log predictive densities or probabilities +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}, or a 3-D array +(\code{I} × \code{C} × \code{n}: iterations, chains, observations). Required for +density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{measures}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\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{estimate}, \code{se}, and \code{pointwise}. A +length-2 \code{estimates} (estimate and SE) can replace \code{estimate} and \code{se}. + +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 +measures. See \code{\link[=loo_pred_measure]{loo_pred_measure()}}.} + +\item{group_ids}{Optional vector of group identifiers for grouped summaries +(reserved; not yet implemented).} + +\item{psis_object}{A \code{psis} object with LOO importance weights. An +alternative to passing a full \code{loo} object; must be supplied together with +\code{ylp} when computing \code{elpd}.} + +\item{save_psis}{Logical. If \code{TRUE}, store the \code{psis} object in the result +so that additional measures can be added later with \code{\link[=pred_measure]{pred_measure()}} without +recomputing PSIS weights.} + +\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))}).} +} +\value{ +An object of class \code{"loo_pred_measure"}, \code{"pred_measure"}, and \code{"loo"}. +When a \code{loo} object is supplied, additional classes from that object are +inherited (e.g. \code{"psis_loo"}). In addition to \code{estimates} and +\code{pointwise}, the list may contain: +\describe{ +\item{\code{diagnostics}}{PSIS diagnostics, including Pareto \eqn{\hat{k}} in +\code{diagnostics$pareto_k}. A value above the sample-size dependent +threshold \eqn{\min(1 - 1 / \log_{10}(S), 0.7)}, where \eqn{S} is the +number of draws, suggests an unreliable LOO estimate for that +observation. The \code{print()} method reports the threshold it used.} +\item{\code{log_weights}}{Normalized log importance weights used for LOO +scoring.} +\item{\code{psis_object}}{Stored when \code{save_psis = TRUE}; needed to add +further measures with \code{\link[=pred_measure]{pred_measure()}} without recomputing weights.} +} + +Measure names carry a \verb{_loo} suffix (e.g. \code{elpd_loo}, \code{rps_loo}). +} +\description{ +Estimate out-of-sample predictive performance with \strong{PSIS-LOO} +(Pareto-smoothed importance sampling leave-one-out cross-validation). +PSIS-LOO approximates exact LOO-CV without refitting the model once per +observation: each held-out point is scored by reweighting the full-data +posterior draws. + +With the default \code{measures = NULL}, the result holds \code{elpd_loo}, the LOO +estimate of expected log pointwise predictive density (ELPD), and \code{p_loo} +(effective number of parameters, the difference between in-sample and LOO +log predictive density). \code{p_loo} is reported together with \code{elpd_loo}. +See \code{\link[=loo]{loo()}} and the +\href{https://users.aalto.fi/~ave/CV-FAQ.html}{Cross-validation FAQ} for +interpretation. +} +\details{ +\strong{Three input patterns:} + +\describe{ +\item{Precomputed \code{loo} object}{\code{loo_pred_measure(loo = loo_fit, ...)}. +Run \code{\link[=loo]{loo()}} with \code{save_psis = TRUE}.} +\item{\code{ylp} + \code{psis_object}}{Pass both when you have already computed +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{rps}, \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)) { + fit <- brms::brm( + Reaction ~ Days, data = lme4::sleepstudy, + refresh = 0, chains = 2, iter = 1000 + ) + loo_fit <- loo::loo(fit, save_psis = TRUE) + loo_pred_measure( + loo = loo_fit, + y = fit$data$Reaction, + ypred = brms::posterior_predict(fit), + measures = c("rmse", "r2") + ) +} +} + +} +\seealso{ +\code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=pred_measure]{pred_measure()}}, \code{\link[=loo]{loo()}}, +\link{supported_measures_list}, +\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{Predictive model performance: Predictive schemes with \code{pred_measure()}} +} diff --git a/man/loo_predictive_metric.Rd b/man/loo_predictive_metric.Rd index b82f7e30..f6588a51 100644 --- a/man/loo_predictive_metric.Rd +++ b/man/loo_predictive_metric.Rd @@ -3,7 +3,7 @@ \name{loo_predictive_metric} \alias{loo_predictive_metric} \alias{loo_predictive_metric.matrix} -\title{Estimate leave-one-out predictive performance..} +\title{Estimate leave-one-out predictive performance (deprecated)} \usage{ loo_predictive_metric(x, ...) @@ -68,6 +68,17 @@ Standard error of the estimate. } } \description{ +As of loo 3.0.0, \code{loo_predictive_metric()} is \strong{deprecated}. Please use +\code{\link[=loo_pred_measure]{loo_pred_measure()}} instead, or the standalone \code{\link[=measure_mae]{measure_mae()}}, +\code{\link[=measure_rmse]{measure_rmse()}}, \code{\link[=measure_mse]{measure_mse()}}, \code{\link[=measure_acc]{measure_acc()}}, and \code{\link[=measure_bacc]{measure_bacc()}} +functions with PSIS log-weights. +See \code{vignette("migration-guide", package = "loo")} for a full mapping table. +} +\details{ +The replacement API uses \code{mupred} (posterior expected values) rather than +pre-computed LOO expectations passed as \code{x}. Metric names also differ: +\code{"balanced_acc"} maps to \code{"bacc"} in \link{supported_measures_list}. + The \code{loo_predictive_metric()} function computes estimates of leave-one-out predictive metrics given a set of predictions and observations. Currently supported metrics are mean absolute error, mean squared error and root mean @@ -105,3 +116,6 @@ mae_90q <- loo_predictive_metric(x = mu_pred, y = d$weight, log_lik = ll, } } } +\seealso{ +\code{\link[=loo_pred_measure]{loo_pred_measure()}}, \code{\link[=measure_mae]{measure_mae()}}, \link{supported_measures_list} +} 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 new file mode 100644 index 00000000..59f81ecf --- /dev/null +++ b/man/measure_acc.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_acc} +\alias{measure_acc} +\title{Classification accuracy (\code{acc})} +\usage{ +measure_acc(y, mupred, log_weights = NULL, pointwise = NULL) +} +\arguments{ +\item{y}{An integer vector of observed class labels. Code it 0 or 1 when +\code{mupred} is a matrix, and 1 to K when \code{mupred} is a 3-D array.} + +\item{mupred}{A numeric array of posterior predictive means. For binary +outcomes use a draws x observations matrix. For multiclass outcomes use a +draws x observations x categories array.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +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 accuracy +contributions. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Computes pointwise and average classification accuracy for binary or +multiclass outcomes. The class probabilities are first averaged over the +draws, using \code{log_weights} if given. For binary outcomes, the averaged +probability is thresholded at 0.5. For multiclass outcomes, the predicted +class is the most likely category of the averaged probabilities, via +\code{which.max()}. +} +\examples{ +y <- c(1L, 0L, 1L) +mupred <- matrix(c(0.8, 0.3, 0.7, 0.6, 0.4, 0.9), nrow = 2) +measure_acc(y, mupred) +} diff --git a/man/measure_bacc.Rd b/man/measure_bacc.Rd new file mode 100644 index 00000000..a23f29ef --- /dev/null +++ b/man/measure_bacc.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_bacc} +\alias{measure_bacc} +\title{Balanced classification accuracy (\code{bacc})} +\usage{ +measure_bacc(y, mupred, log_weights = NULL, pointwise = NULL) +} +\arguments{ +\item{y}{An integer vector of observed class labels. Code it 0 or 1 when +\code{mupred} is a matrix, and 1 to K when \code{mupred} is a 3-D array.} + +\item{mupred}{A numeric array of posterior predictive means. For binary +outcomes use a draws x observations matrix. For multiclass outcomes use a +draws x observations x categories array.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +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 +contributions \eqn{acc_i / (K n_{y_i})}, as stored by \code{measure_bacc()}. +If provided, \code{mupred} and \code{log_weights} are ignored. \code{y} is always +required, because it defines the classes.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Computes balanced accuracy by averaging class-specific mean accuracy, giving +each observed class equal weight regardless of class frequency. +} +\examples{ +y <- c(1L, 1L, 2L, 2L) +mupred <- array( + c(0.8, 0.2, 0.7, 0.3, 0.3, 0.7, 0.2, 0.8), + dim = c(1, 4, 2) +) +measure_bacc(y, mupred) +} diff --git a/man/measure_brier.Rd b/man/measure_brier.Rd new file mode 100644 index 00000000..b8494f10 --- /dev/null +++ b/man/measure_brier.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_brier} +\alias{measure_brier} +\title{Brier score (\code{brier})} +\usage{ +measure_brier(y, ypred, log_weights = NULL, pointwise = NULL) +} +\arguments{ +\item{y}{A numeric vector of binary outcomes coded as 0 or 1.} + +\item{ypred}{A numeric matrix of posterior predictive probabilities with +dimensions draws x observations.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +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 Brier +scores. If provided, \code{y}, \code{ypred}, and \code{log_weights} are ignored.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Computes the Brier score for binary outcomes as squared error between the +observed label and predicted event probability. +} +\examples{ +y <- c(1, 0, 1) +ypred <- matrix(c(0.8, 0.2, 0.7, 0.9, 0.4, 0.6), nrow = 2) +measure_brier(y, ypred) +} diff --git a/man/measure_density_params.Rd b/man/measure_density_params.Rd new file mode 100644 index 00000000..04af3655 --- /dev/null +++ b/man/measure_density_params.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_density_params} +\alias{measure_density_params} +\title{Shared parameters for density scores} +\arguments{ +\item{ylp}{A numeric matrix or three-dimensional array of log predictive +densities or probabilities: +\itemize{ +\item \strong{Matrix} (\eqn{S \times n}): \eqn{S} posterior draws (chains +merged) by \eqn{n} observations. +\item \strong{Array} (\eqn{I \times C \times n}): \eqn{I} MCMC iterations per +chain, \eqn{C} chains, and \eqn{n} observations. Converted to an +\eqn{S \times n} matrix internally. +}} +} +\description{ +Shared parameters for density scores +} +\keyword{internal} diff --git a/man/measure_elpd.Rd b/man/measure_elpd.Rd new file mode 100644 index 00000000..0e3f3bc4 --- /dev/null +++ b/man/measure_elpd.Rd @@ -0,0 +1,65 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_elpd} +\alias{measure_elpd} +\title{Expected log pointwise predictive density (\code{elpd})} +\usage{ +measure_elpd(ylp, log_weights = NULL, pointwise = NULL) +} +\arguments{ +\item{ylp}{A numeric matrix or three-dimensional array of log predictive +densities or probabilities: +\itemize{ +\item \strong{Matrix} (\eqn{S \times n}): \eqn{S} posterior draws (chains +merged) by \eqn{n} observations. +\item \strong{Array} (\eqn{I \times C \times n}): \eqn{I} MCMC iterations per +chain, \eqn{C} chains, and \eqn{n} observations. Converted to an +\eqn{S \times n} matrix internally. +}} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +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.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\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. +} +\details{ +\deqn{\mathrm{elpd} = \sum_{i=1}^{n} \mathrm{lppd}_i,} +where each \eqn{\mathrm{lppd}_i} is computed by \code{\link[=ptw_log_pred_density]{ptw_log_pred_density()}}. +The standard error is \eqn{\sqrt{n}\,\mathrm{sd}(\mathrm{lppd}_i)}. +} +\examples{ +ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +measure_elpd(ylp) + +# With unnormalized importance weights (e.g., PSIS-LOO) +lw <- matrix(log(c(0.7, 0.3, 0.6, 0.4)), nrow = 2) +measure_elpd(ylp, log_weights = lw) + +# From a draws x chains x observations array +LLarr <- example_loglik_array() +measure_elpd(LLarr) +} +\seealso{ +\code{\link[=ptw_log_pred_density]{ptw_log_pred_density()}}, \code{\link[=measure_mlpd]{measure_mlpd()}}, \code{\link[=measure_ic]{measure_ic()}} +} diff --git a/man/measure_ic.Rd b/man/measure_ic.Rd new file mode 100644 index 00000000..671f276e --- /dev/null +++ b/man/measure_ic.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_ic} +\alias{measure_ic} +\title{Information Criteria (\code{ic})} +\usage{ +measure_ic(ylp, log_weights = NULL, pointwise = NULL) +} +\arguments{ +\item{ylp}{A numeric matrix or three-dimensional array of log predictive +densities or probabilities: +\itemize{ +\item \strong{Matrix} (\eqn{S \times n}): \eqn{S} posterior draws (chains +merged) by \eqn{n} observations. +\item \strong{Array} (\eqn{I \times C \times n}): \eqn{I} MCMC iterations per +chain, \eqn{C} chains, and \eqn{n} observations. Converted to an +\eqn{S \times n} matrix internally. +}} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +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 +contributions \eqn{\mathrm{ic}_i = -2 \cdot \mathrm{lppd}_i}. If provided, +\code{ylp} and \code{log_weights} are ignored.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Computes the information criteria as -2 x log predictive density (lppd_i) +values. Inputs follow the same conventions as \code{\link[=measure_elpd]{measure_elpd()}} and +\code{\link[=measure_mlpd]{measure_mlpd()}}. +} +\examples{ +ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +measure_ic(ylp) +} diff --git a/man/measure_mae.Rd b/man/measure_mae.Rd new file mode 100644 index 00000000..99b564fe --- /dev/null +++ b/man/measure_mae.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_mae} +\alias{measure_mae} +\title{Mean absolute error (\code{mae})} +\usage{ +measure_mae(y, mupred, log_weights = NULL, pointwise = NULL) +} +\arguments{ +\item{y}{A numeric vector of observed outcomes.} + +\item{mupred}{A numeric matrix of posterior expected predictions with +dimensions draws x observations. A length-\code{n} vector is also accepted.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +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 absolute +errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Computes MAE between observed outcomes and posterior predictive point +predictions. Point predictions are obtained by averaging \code{mupred} draws, or +by PSIS-weighted averaging when \code{log_weights} is provided. +} +\examples{ +y <- c(1, 2, 3) +mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +measure_mae(y, mupred) +} diff --git a/man/measure_mlpd.Rd b/man/measure_mlpd.Rd new file mode 100644 index 00000000..4cb5ae71 --- /dev/null +++ b/man/measure_mlpd.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_mlpd} +\alias{measure_mlpd} +\title{Mean log pointwise predictive density (\code{mlpd})} +\usage{ +measure_mlpd(ylp, log_weights = NULL, pointwise = NULL) +} +\arguments{ +\item{ylp}{A numeric matrix or three-dimensional array of log predictive +densities or probabilities: +\itemize{ +\item \strong{Matrix} (\eqn{S \times n}): \eqn{S} posterior draws (chains +merged) by \eqn{n} observations. +\item \strong{Array} (\eqn{I \times C \times n}): \eqn{I} MCMC iterations per +chain, \eqn{C} chains, and \eqn{n} observations. Converted to an +\eqn{S \times n} matrix internally. +}} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +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.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Computes MLPD as the average of pointwise log predictive density (lppd_i) +values. Inputs follow the same conventions as \code{\link[=measure_elpd]{measure_elpd()}}. +} +\examples{ +ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +measure_mlpd(ylp) +} diff --git a/man/measure_mse.Rd b/man/measure_mse.Rd new file mode 100644 index 00000000..9efa6edd --- /dev/null +++ b/man/measure_mse.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_mse} +\alias{measure_mse} +\title{Mean squared error (\code{mse})} +\usage{ +measure_mse(y, mupred, log_weights = NULL, pointwise = NULL) +} +\arguments{ +\item{y}{A numeric vector of observed outcomes.} + +\item{mupred}{A numeric matrix of posterior expected predictions with +dimensions draws x observations. A length-\code{n} vector is also accepted.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +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 squared +errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Computes MSE between observed outcomes and posterior predictive point +predictions. Point predictions are obtained by averaging \code{mupred} draws, or +by PSIS-weighted averaging when \code{log_weights} is provided. +} +\examples{ +y <- c(1, 2, 3) +mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +measure_mse(y, mupred) +} diff --git a/man/measure_params.Rd b/man/measure_params.Rd new file mode 100644 index 00000000..75d07d91 --- /dev/null +++ b/man/measure_params.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_params} +\alias{measure_params} +\title{Shared parameters for all measures} +\arguments{ +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +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.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Shared parameters for all measures +} +\keyword{internal} diff --git a/man/measure_r2.Rd b/man/measure_r2.Rd new file mode 100644 index 00000000..25efdbf9 --- /dev/null +++ b/man/measure_r2.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_r2} +\alias{measure_r2} +\title{Predictive R-squared (\code{r2})} +\usage{ +measure_r2(y, mupred, log_weights = NULL, pointwise = NULL) +} +\arguments{ +\item{y}{A numeric vector of observed outcomes.} + +\item{mupred}{A numeric matrix of posterior expected predictions with +dimensions draws x observations. A length-\code{n} vector is also accepted.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +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 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.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Computes predictive R-squared as one minus the ratio of prediction MSE to +the empirical variance of \code{y}. The standard error is computed with a +first-order delta-method approximation. +} +\examples{ +y <- c(1, 2, 3) +mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +measure_r2(y, mupred) +} diff --git a/man/measure_rmse.Rd b/man/measure_rmse.Rd new file mode 100644 index 00000000..287bd527 --- /dev/null +++ b/man/measure_rmse.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_rmse} +\alias{measure_rmse} +\title{Root mean squared error (\code{rmse})} +\usage{ +measure_rmse(y, mupred, log_weights = NULL, pointwise = NULL) +} +\arguments{ +\item{y}{A numeric vector of observed outcomes.} + +\item{mupred}{A numeric matrix of posterior expected predictions with +dimensions draws x observations. A length-\code{n} vector is also accepted.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +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 squared +errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Computes RMSE as the square root of MSE and propagates uncertainty via a +first-order delta-method approximation. +} +\examples{ +y <- c(1, 2, 3) +mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +measure_rmse(y, mupred) +} diff --git a/man/measure_rps.Rd b/man/measure_rps.Rd new file mode 100644 index 00000000..5583d8fc --- /dev/null +++ b/man/measure_rps.Rd @@ -0,0 +1,151 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_rps} +\alias{measure_rps} +\title{Ranked Probability Score (RPS, SRPS, CRPS, SCRPS)} +\usage{ +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 +(for RPS/SRPS) or continuous (for CRPS/SCRPS).} + +\item{ypred}{A numeric matrix of posterior predictive draws with dimensions +\eqn{S \times n} (draws × observations).} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +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 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}.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Computes proper scoring rules based on the ranked probability score family, +covering both discrete and continuous outcomes, with optional scaling. +The specific score computed depends on the type of \code{y} and \code{ypred} and the +value of \code{scaled}: +} +\details{ +\tabular{lll}{ + \code{y}/\code{ypred} type \tab \code{scaled = FALSE} \tab \code{scaled = TRUE} \cr + Discrete \tab RPS \tab SRPS \cr + Continuous \tab CRPS \tab SCRPS \cr +} + + +\strong{Scoring rules:} +\itemize{ +\item \strong{RPS} (Epstein, 1969): Compares predictive and observed cumulative +distributions for ordered discrete outcomes. +\item \strong{CRPS} (Matheson & Winkler, 1976; Gneiting & Raftery, 2007): Generalizes +RPS to continuous outcomes. Defined as +\deqn{\mathrm{CRPS}(X; y) = E[|X - y|] - \frac{1}{2} E[|X - X'|],} +where \eqn{X, X'} are independent draws from the predictive distribution. +\item \strong{SRPS/SCRPS} (Bolin & Wallin, 2023): Scaled variants that are invariant +to the scale of the predictive distribution. Defined as +\deqn{\mathrm{SCRPS}(X; y) = -\frac{E[|X - y|]}{E[|X - X'|]} - + \frac{1}{2} \log E[|X - X'|].} +} + +\strong{Estimation:} + +Scores are estimated using the probability-weighted moment (PWM) estimator +(Taillardat et al., 2016; Zamo & Naveau, 2018), which requires only a single +set of predictive draws unlike permutation-based estimators, which require +two independent draw sets. The PWM estimator is unbiased and generally more +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. + +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 (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 +y <- c(2L, 1L, 3L) +ypred <- matrix(c(2, 1, 2, 3, 1, 3), nrow = 2) +measure_rps(y, ypred) + +# Discrete outcomes: SRPS (scaled) +measure_rps(y, ypred, scaled = TRUE) + +# Continuous outcomes: CRPS +y_cont <- c(0.5, -1.2, 2.3) +ypred_cont <- matrix(rnorm(200), nrow = 100, ncol = 3) +measure_rps(y_cont, ypred_cont) + +# With importance weights: LOO-CRPS +log_weights <- matrix(rnorm(200), nrow = 100, ncol = 3) +measure_rps(y_cont, ypred_cont, log_weights = log_weights) + +} +\references{ +Bolin, D. and Wallin, J. (2023). Local scale invariance and robustness of +proper scoring rules. \emph{Statistical Science}, 38(1):140–159. + +Epstein, E. S. (1969). A scoring system for probability forecasts of ranked +categories. \emph{Journal of Applied Meteorology}, 8(6):985–987. + +Gneiting, T. and Raftery, A. E. (2007). Strictly proper scoring rules, +prediction, and estimation. \emph{Journal of the American Statistical +Association}, 102(477):359–378. + +Hosking, J. R. M. (1990). L-moments: Analysis and estimation of +distributions using linear combinations of order statistics. \emph{Journal of +the Royal Statistical Society Series B}, 52(1):105–124. + +Hosking, J. R. M. (1996). Some theoretical results concerning L-moments. +Research report RC 14492. IBM Thomas J. Watson Research Division. + +Matheson, J. E. and Winkler, R. L. (1976). Scoring rules for continuous +probability distributions. \emph{Management Science}, 22(10):1087–1096. + +Taillardat, M., Mestre, O., Zamo, M., and Naveau, P. (2016). Calibrated +ensemble forecasts using quantile regression forests and ensemble model +output statistics. \emph{Monthly Weather Review}, 144(6):2375–2393. + +Zamo, M. and Naveau, P. (2018). Estimation of the continuous ranked +probability score with limited information and applications to ensemble +weather forecasts. \emph{Mathematical Geosciences}, 50:209–234. +} diff --git a/man/measure_score_params.Rd b/man/measure_score_params.Rd new file mode 100644 index 00000000..244a8a0f --- /dev/null +++ b/man/measure_score_params.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_score_params} +\alias{measure_score_params} +\title{Shared parameters for scores} +\arguments{ +\item{y}{A vector of observed values.} + +\item{mupred}{A numeric array of posterior predictive means. For binary +outcomes use a draws x observations matrix. For multiclass outcomes use a +draws x observations x categories array.} +} +\description{ +Shared parameters for scores +} +\keyword{internal} diff --git a/man/measure_srps.Rd b/man/measure_srps.Rd new file mode 100644 index 00000000..352a0b5b --- /dev/null +++ b/man/measure_srps.Rd @@ -0,0 +1,56 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_srps} +\alias{measure_srps} +\title{Scaled Ranked Probability Score (SRPS, SCRPS)} +\usage{ +measure_srps(y, ypred, log_weights = NULL, pointwise = NULL) +} +\arguments{ +\item{y}{A numeric vector of \eqn{n} observed outcomes. May be integer-valued +(for RPS/SRPS) or continuous (for CRPS/SCRPS).} + +\item{ypred}{A numeric matrix of posterior predictive draws with dimensions +\eqn{S \times n} (draws × observations).} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +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 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.} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{A 1 \eqn{\times} 2 matrix. The row is named after +the measure, the columns are \code{Estimate} and \code{SE} (standard error).} +\item{\code{pointwise}}{An \eqn{n \times 1} matrix of per-observation values. +The column is named after the measure.} +\item{\code{extra}}{Optional. Auxiliary data for the standard error of a +difference. Most measures do not set it.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +A convenience wrapper around \code{\link[=measure_rps]{measure_rps()}} with \code{scaled = TRUE}. Computes the +scaled ranked probability score (SRPS) for discrete outcomes or the scaled +continuously ranked probability score (SCRPS) for continuous outcomes. +Scaling makes the score invariant to the spread of the predictive +distribution, which can be useful when comparing models across observations +with very different predictive uncertainties. +} +\details{ +See \code{\link[=measure_rps]{measure_rps()}} for full details on arguments, estimation, and references. +} +\examples{ +y <- c(2L, 1L, 3L) +ypred <- matrix(c(2, 1, 2, 3, 1, 3), nrow = 2) +measure_srps(y, ypred) + +} diff --git a/man/model_compare.Rd b/man/model_compare.Rd new file mode 100644 index 00000000..0de3b94f --- /dev/null +++ b/man/model_compare.Rd @@ -0,0 +1,337 @@ +% 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 with different \code{measures}, +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 what the user passes to +\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/pareto-k-diagnostic.Rd b/man/pareto-k-diagnostic.Rd index fcb2db6f..efc73477 100644 --- a/man/pareto-k-diagnostic.Rd +++ b/man/pareto-k-diagnostic.Rd @@ -149,15 +149,14 @@ we recommend one of the following actions: the MCMC draws from the posterior distribution to obtain more reliable importance sampling estimates. This results in a smaller shape parameter \eqn{k}. See \code{\link[=loo_moment_match]{loo_moment_match()}} and the -vignette \emph{Avoiding model refits in leave-one-out cross-validation -with moment matching} for an example of this. +vignette \emph{Avoiding model refits with moment matching} for an +example of this. \item Sampling from a leave-one-out mixture distribution (see the -vignette \emph{Mixture IS leave-one-out cross-validation for -high-dimensional Bayesian models}), directly from \eqn{p(\theta^s - | y_{-i})} for the problematic observations \eqn{i}, or using -\eqn{K}-fold cross-validation (see the vignette \emph{Holdout -validation and K-fold cross-validation of Stan programs with the -loo package}) will generally be more stable. +vignette \emph{Mixture IS leave-one-out cross-validation}), +directly from \eqn{p(\theta^s | y_{-i})} for the problematic +observations \eqn{i}, or using \eqn{K}-fold cross-validation +(see the vignette \emph{Holdout validation and K-fold cross-validation}) +will generally be more stable. \item Using a model that is more robust to anomalous observations will generally make approximate LOO-CV more stable. } diff --git a/man/pred_measure.Rd b/man/pred_measure.Rd new file mode 100644 index 00000000..7475108a --- /dev/null +++ b/man/pred_measure.Rd @@ -0,0 +1,155 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure.R +\name{pred_measure} +\alias{pred_measure} +\title{Add predictive performance measures to an existing result} +\usage{ +pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measures = NULL, + predperf, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for every measure except +\code{elpd}, \code{mlpd}, and \code{ic}.} + +\item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} +observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +\code{rps}, \code{srps}, and \code{brier}.} + +\item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from +\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for \code{mae}, \code{mse}, +\code{rmse}, \code{r2}, \code{acc}, and \code{bacc}.} + +\item{ylp}{Matrix of pointwise log predictive densities or probabilities +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}, or a 3-D array +(\code{I} × \code{C} × \code{n}: iterations, chains, observations). Required for +density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{measures}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\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{estimate}, \code{se}, and \code{pointwise}. A +length-2 \code{estimates} (estimate and SE) can replace \code{estimate} and \code{se}. + +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 +(for LOO) PSIS weights are reused instead of recomputed.} + +\item{group_ids}{Optional vector of group identifiers for grouped summaries +(reserved; not yet implemented).} + +\item{psis_object}{A \code{psis} object with LOO importance weights. An +alternative to passing a full \code{loo} object; must be supplied together with +\code{ylp} when computing \code{elpd}.} + +\item{save_psis}{Logical. If \code{TRUE}, store the \code{psis} object in the result +so that additional measures can be added later with \code{\link[=pred_measure]{pred_measure()}} without +recomputing PSIS weights.} + +\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))}).} +} +\value{ +An updated object of the same class as \code{predperf}, with new rows in +\code{estimates} and columns in \code{pointwise} for each requested measure. Rows +already in \code{predperf} are not recomputed. If \code{mlpd} or \code{ic} needs \code{elpd} and +\code{predperf} has no \code{elpd} column, \code{elpd} is recomputed from \code{ylp} for +insample and LOO results. For k-fold and test results this is an error. +} +\description{ +Extend a \code{"pred_measure"} object with additional measures \strong{without +recomputing} what is already stored. Use this for interactive exploration +or when you first compute \code{elpd} and later add distributional +or point-prediction metrics. + +Pass the existing object as \code{predperf} and supply any inputs newly required +by the requested measures (see the input table in +\code{\link[=insample_pred_measure]{insample_pred_measure()}}). The evaluation mode (\code{"insample"}, \code{"loo"}, +\code{"kfold"}, or \code{"test"}) is taken from \code{predperf}; LOO paths reuse stored +PSIS weights when available. +} +\details{ +\strong{Typical workflow:} + +\preformatted{ +result <- loo_pred_measure(loo = loo_fit, save_psis = TRUE) +pred_measure( + y = y, + mupred = mupred, + predperf = result, + measures = c("rmse", "r2") +) +} + +When extending a LOO result, ensure the initial call used \code{save_psis = TRUE} +(or that \code{predperf} already contains a \code{psis_object}) so LOO weights are +available for additional measures. +} +\examples{ +\donttest{ +if (requireNamespace("brms", quietly = TRUE)) { + fit <- brms::brm( + Reaction ~ Days, data = lme4::sleepstudy, + refresh = 0, chains = 2, iter = 1000 + ) + result <- insample_pred_measure( + ylp = brms::log_lik(fit), + y = fit$data$Reaction, + ypred = brms::posterior_predict(fit) + ) + pred_measure( + y = fit$data$Reaction, + mupred = brms::posterior_epred(fit), + predperf = result, + measures = c("rmse", "r2") + ) +} +} + +} +\seealso{ +\code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=loo_pred_measure]{loo_pred_measure()}}, +\code{\link[=kfold_pred_measure]{kfold_pred_measure()}}, \code{\link[=test_pred_measure]{test_pred_measure()}}, \link{supported_measures_list}, +\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{Predictive model performance: Predictive schemes with \code{pred_measure()}} +} diff --git a/man/pred_measure_params.Rd b/man/pred_measure_params.Rd new file mode 100644 index 00000000..80c24021 --- /dev/null +++ b/man/pred_measure_params.Rd @@ -0,0 +1,120 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-compute.R +\name{pred_measure_params} +\alias{pred_measure_params} +\alias{do_pred_measure} +\title{Shared parameters for predictive measure wrappers} +\usage{ +do_pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + ylp_test = NULL, + measures = NULL, + predperf = NULL, + loo = NULL, + kfold = NULL, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + source = NULL, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for every measure except +\code{elpd}, \code{mlpd}, and \code{ic}.} + +\item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} +observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +\code{rps}, \code{srps}, and \code{brier}.} + +\item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from +\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for \code{mae}, \code{mse}, +\code{rmse}, \code{r2}, \code{acc}, and \code{bacc}.} + +\item{ylp}{Matrix of pointwise log predictive densities or probabilities +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}, or a 3-D array +(\code{I} × \code{C} × \code{n}: iterations, chains, observations). Required for +density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{ylp_test}{Matrix of pointwise log predictive densities for holdout +observations (\code{S} × \code{n_test}), or a 3-D array (\code{I} × \code{C} × \code{n_test}), +typically from +\code{brms::log_lik(fit, newdata = test_data)}. Used with \code{ylp} (from the +training fit) in \code{\link[=test_pred_measure]{test_pred_measure()}} to score genuinely new data.} + +\item{measures}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\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{estimate}, \code{se}, and \code{pointwise}. A +length-2 \code{estimates} (estimate and SE) can replace \code{estimate} and \code{se}. + +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 +(for LOO) PSIS weights are reused instead of recomputed.} + +\item{loo}{A \code{\link[=loo]{loo()}} result, computed with +\code{save_psis = TRUE} so that PSIS weights are available for additional +measures. See \code{\link[=loo_pred_measure]{loo_pred_measure()}}.} + +\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 +\code{mupred} when requesting additional measures.} + +\item{group_ids}{Optional vector of group identifiers for grouped summaries +(reserved; not yet implemented).} + +\item{psis_object}{A \code{psis} object with LOO importance weights. An +alternative to passing a full \code{loo} object; must be supplied together with +\code{ylp} when computing \code{elpd}.} + +\item{save_psis}{Logical. If \code{TRUE}, store the \code{psis} object in the result +so that additional measures can be added later with \code{\link[=pred_measure]{pred_measure()}} without +recomputing PSIS weights.} + +\item{source}{Character string indicating the evaluation mode: \code{"insample"}, +\code{"loo"}, \code{"kfold"}, or \code{"test"}. Set automatically by the wrapper +functions; required when calling \code{\link[=do_pred_measure]{do_pred_measure()}} directly.} + +\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))}).} +} +\description{ +Parameter definitions shared by the user-facing entry points and the +internal engine \code{\link[=do_pred_measure]{do_pred_measure()}}. +} +\keyword{internal} diff --git a/man/psislw.Rd b/man/psislw.Rd index 96371ba5..c49bbf8f 100644 --- a/man/psislw.Rd +++ b/man/psislw.Rd @@ -47,6 +47,8 @@ A named list with components \code{lw_smooth} (modified log weights) and \description{ As of version \verb{2.0.0} this function is \strong{deprecated}. Please use the \code{\link[=psis]{psis()}} function for the new PSIS algorithm. +\code{psislw()} and \code{R/psislw.R} are scheduled for removal in a future release. +See \code{vignette("migration-guide", package = "loo")} for details. } \references{ Vehtari, A., Gelman, A., and Gabry, J. (2017). Practical Bayesian model diff --git a/man/ptw_log_pred_density.Rd b/man/ptw_log_pred_density.Rd new file mode 100644 index 00000000..342c2669 --- /dev/null +++ b/man/ptw_log_pred_density.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{ptw_log_pred_density} +\alias{ptw_log_pred_density} +\title{Pointwise log predictive density (\code{lppd_i})} +\usage{ +ptw_log_pred_density(ylp, psis_log_weights = NULL) +} +\arguments{ +\item{ylp}{A numeric matrix of log predictive densities/probabilities with +dimensions draws x observations.} + +\item{psis_log_weights}{Optional numeric matrix of normalized PSIS log +weights with the same dimensions as \code{ylp}. Each column must sum to 1 on +the probability scale.} +} +\value{ +A numeric vector of length \code{ncol(ylp)} with pointwise log +predictive density values. +} +\description{ +Computes pointwise log predictive density contributions from a matrix of +log predictive densities/probabilities for posterior draws. When PSIS +log-weights are supplied, they are used to form a weighted log-sum-exp per +observation. +} +\examples{ +ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +ptw_log_pred_density(ylp) + +lw <- matrix(log(c(0.7, 0.3, 0.6, 0.4)), nrow = 2) +ptw_log_pred_density(ylp, lw) +} diff --git a/man/supported_measures_list.Rd b/man/supported_measures_list.Rd new file mode 100644 index 00000000..37d2afd3 --- /dev/null +++ b/man/supported_measures_list.Rd @@ -0,0 +1,13 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{supported_measures_list} +\alias{supported_measures_list} +\title{Supported predictive measure names} +\usage{ +supported_measures_list +} +\description{ +A character vector of measure names that can be passed to the \code{measures} +argument of \code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=loo_pred_measure]{loo_pred_measure()}}, +\code{\link[=kfold_pred_measure]{kfold_pred_measure()}}, \code{\link[=test_pred_measure]{test_pred_measure()}}, and \code{\link[=pred_measure]{pred_measure()}}. +} diff --git a/man/test_pred_measure.Rd b/man/test_pred_measure.Rd new file mode 100644 index 00000000..09626fec --- /dev/null +++ b/man/test_pred_measure.Rd @@ -0,0 +1,151 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure.R +\name{test_pred_measure} +\alias{test_pred_measure} +\title{Holdout predictive performance measures} +\usage{ +test_pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + ylp_test = NULL, + measures = NULL, + group_ids = NULL, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for every measure except +\code{elpd}, \code{mlpd}, and \code{ic}.} + +\item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} +observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +\code{rps}, \code{srps}, and \code{brier}.} + +\item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from +\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for \code{mae}, \code{mse}, +\code{rmse}, \code{r2}, \code{acc}, and \code{bacc}.} + +\item{ylp}{Matrix of pointwise log predictive densities or probabilities +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}, or a 3-D array +(\code{I} × \code{C} × \code{n}: iterations, chains, observations). Required for +density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{ylp_test}{Matrix of pointwise log predictive densities for holdout +observations (\code{S} × \code{n_test}), or a 3-D array (\code{I} × \code{C} × \code{n_test}), +typically from +\code{brms::log_lik(fit, newdata = test_data)}. Used with \code{ylp} (from the +training fit) in \code{\link[=test_pred_measure]{test_pred_measure()}} to score genuinely new data.} + +\item{measures}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\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{estimate}, \code{se}, and \code{pointwise}. A +length-2 \code{estimates} (estimate and SE) can replace \code{estimate} and \code{se}. + +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).} + +\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))}).} +} +\value{ +An object of class \code{"test_pred_measure"} and \code{"pred_measure"} with +\code{estimates} and \code{pointwise}. Measure names carry a \verb{_test} suffix (e.g. +\code{elpd_test}, \code{rps_test}). Attribute \code{dims} reflects the test-set size +(from \code{ylp_test}), not the training data. +} +\description{ +Score predictive performance on \strong{genuinely new (holdout) data} that was +not used to fit the model. This mirrors the cross-validation goal of +assessing how well a model predicts unseen observations, but with an +explicit train/test split rather than LOO or k-fold reweighting. + +Supply \code{ylp_test} from log predictive densities evaluated on the holdout set +(e.g. \code{brms::log_lik(fit, newdata = test_data)}). This is required for +\code{elpd_test}, \code{mlpd_test} and \code{ic_test}. Optional distributional and +point-prediction measures use observed and predicted values on the test set +only. Pass training \code{ylp} only when an additional measure needs log +predictive densities from the training fit. +} +\details{ +\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)) { + data <- lme4::sleepstudy + train <- data[1:150, ] + test <- data[151:nrow(data), ] + fit <- brms::brm( + Reaction ~ Days, data = train, + refresh = 0, chains = 2, iter = 1000 + ) + test_pred_measure( + y = test$Reaction, + ypred = brms::posterior_predict(fit, newdata = test), + mupred = brms::posterior_epred(fit, newdata = test), + ylp = brms::log_lik(fit), + ylp_test = brms::log_lik(fit, newdata = test), + measures = c("rmse", "r2") + ) +} +} + +} +\seealso{ +\code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=loo_pred_measure]{loo_pred_measure()}}, +\code{\link[=kfold_pred_measure]{kfold_pred_measure()}}, \code{\link[=pred_measure]{pred_measure()}}, \link{supported_measures_list}, +\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{Predictive model performance: Predictive schemes with \code{pred_measure()}} +} diff --git a/man/waic.Rd b/man/waic.Rd index cb72da0d..2f8281aa 100644 --- a/man/waic.Rd +++ b/man/waic.Rd @@ -146,9 +146,10 @@ Pareto smoothed importance sampling. \emph{Journal of Machine Learning Research} } \seealso{ \itemize{ -\item The \strong{loo} package \href{https://mc-stan.org/loo/articles/}{vignettes} and +\item The \strong{loo} package \href{https://mc-stan.org/loo/articles/index.html}{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 new file mode 100644 index 00000000..8681740a --- /dev/null +++ b/notes/developer-notes.Rmd @@ -0,0 +1,663 @@ +--- +title: "Developer Notes: `pred_measure` Feature" +output: + github_document: + toc: true + toc_depth: 2 +--- + +```{r setup, include = FALSE} +knitr::opts_chunk$set( + echo = FALSE, + message = FALSE, + warning = FALSE, + fig.path = "figures/", + fig.width = 8, + fig.height = 4.5, + dpi = 150 +) +``` + +> **Status:** In Progress +> **Base branch:** `loo-v3.0.0` +> **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-07 + +These notes document internal design decisions and ongoing work for the +`pred_measure` feature. This PR **adds** the new API. + +## Status at a Glance + +| Area | Status | +|------|--------| +| `pred_measure` API | Done | +| `measure_*()` built-ins | Done | +| Scoring rules (`measure_rps`) | Done | +| Documentation | In progress | +| `group_ids` grouping | Not started | +| `loo_compare` integration | Done (`integrate-loo_compare`) | + +## Scope of this PR (`pred_measure` vs `loo-v3.0.0`) + +### 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()` +- `R/pred_measure-compute.R`, `R/pred_measure-helpers.R`, + `R/pred_measure-builtin.R` — orchestration and `measure_*()` implementations +- `supported_measures_list()`, `ptw_log_pred_density()` +- S3 print methods for `pred_measure`, `loo_pred_measure`, `kfold_pred_measure`, `test_pred_measure` +- `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) + +- `elpd()`, `crps()`, `scrps()`, `loo_crps()`, `loo_scrps()`, + `loo_predictive_metric()` — deprecated with migration docs; **same APIs and + implementations** (e.g. `crps(x, x2, y)` permutation estimator unchanged) +- `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) + +### D2: Scaled RPS — separate function vs. argument + +**Decision:** Both. `measure_rps(..., scaled = TRUE)` is the implementation; +`measure_srps()` is a convenience wrapper. An explicit `srps` built-in name is +required so users can request both in one call: + +```r +pred_measure(y = y, ypred = ypred, measure = c("rps", "srps"), ...) +``` + +Without a separate `srps` name, duplicate measure names would require custom +functions. + +### Unified scoring rule in the new API + +`measure_rps()` subsumes CRPS, RPS, SCRPS, and SRPS for the **new** workflow: + +- Single `ypred` matrix (not two independent draw matrices) +- PWM/ECDF estimator (Aki's implementation; verified against Seth's derivations) +- Works for continuous and ordered categorical outcomes +- `measure_srps()` = scaled variant + +Deprecated `crps()` / `scrps()` remain for backward compatibility with the +`x`, `x2` permutation-based API. + +### ELPD and `ic` in the new API + +Design choices **internal to `pred_measure`**: + +- When `ylp` is supplied, `elpd` is computed as the base summary +- `ic` is **not** included automatically; request via `measure = "ic"` +- `measure_elpd()` is separate from deprecated `elpd()` (different return type: `"measure"` vs `"elpd_generic"`) + +### K-fold + categorical / multinomial models (brms) + +- [x] Upstream fix for 3D `brms::kfold_predict()` output + ([brms#1889](https://github.com/paul-buerkner/brms/issues/1889), + fixed in [brms#1890](https://github.com/paul-buerkner/brms/pull/1890), + merged to `main`) +- [x] Vignettes and pkgdown CI install brms from GitHub `master` + (`vignettes/children/LOAD-BRMS-GITHUB.txt`, `.github/workflows/pkgdown.yaml`, + `tests/testthat/data-for-tests/test_data_generation.R`) +- [ ] Drop GitHub brms pin once a CRAN release includes the #1890 fix +- [ ] 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. +- **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` + +- **Context:** [stan-dev/posterior#446](https://github.com/stan-dev/posterior/issues/446) +- **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) + +- [x] Add `measure_elpd()` for the new API +- [x] Refactor deprecated `elpd()` to `.elpd_matrix_impl()` (no double warnings) +- [x] Add `measure_rps()` as unified scoring-rule implementation (single `ypred`) +- [x] Keep deprecated `crps()` / `scrps()` with `x`, `x2` API unchanged +- [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)* +- [x] Provide an interface to `loo_compare` and verify consistency +- [ ] Resolve `r_eff` handling *(see D3)* + +### Implementation + +- [x] Consolidate CRPS/RPS/SCRPS/SRPS in `measure_rps()` for new API +- [x] Resolve `srps` naming *(see D2)* +- [x] brms k-fold categorical support unblocked upstream *(see above)* +- [ ] Drop GitHub brms pin after CRAN release + +### Documentation + +- [x] Migration guide (`vignettes/migration-guide.Rmd`) +- [x] Overview of measures (`overview-measures.Rmd`) +- [x] Workflow article (`pred-measure-workflow.Rmd`) +- [x] Online-only articles published via `_pkgdown.yml` +- [ ] Formula derivations article (`pred_measure-formulas.Rmd`) +- [ ] Detailed per-measure descriptions (derivations where appropriate) +- [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` + +- [ ] Work out grouping scenarios for LOO and k-fold +- [ ] Implement in `kfold_pred_measure()`, `loo_pred_measure()`, `pred_measure()` + + > **Blocker:** Implementation approach uncertain; grouping scenarios must be + > understood before coding begins. + +## General questions + +- Rename `ic` → `information_criteria` for clarity? +- Should `measure_elpd()` also return `ic`, or keep them separate? +- 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? + +## Deprecation checklist + +When deprecating or removing a function: + +1. Add `.Deprecated("replacement")` in each exported method (only if the + replacement is exported). +2. Document deprecation in roxygen (`**deprecated**`, links to replacement). +3. Add a bullet to `NEWS.md`. +4. Update `vignettes/migration-guide.Rmd`. +5. Add or update tests in `tests/testthat/test_deprecated_*.R`. +6. List the topic under **Deprecated functions** in `_pkgdown.yml`. +7. Keep the old implementation until the planned removal release. +8. On removal: delete the source file, remove from `NAMESPACE`, update the + migration guide. + +When a feature adds new replacements, extend the **Function migration tables** +in `vignettes/migration-guide.Rmd`. + +## References & resources + +| Resource | Link / contact | +|----------|----------------| +| Cross-validation FAQ | | +| `r_eff` in posterior (Aki) | | +| brms k-fold 3D fix | [brms#1889](https://github.com/paul-buerkner/brms/issues/1889), [brms#1890](https://github.com/paul-buerkner/brms/pull/1890) | +| `rps` derivation (Seth) | @florence-bockting, @avehtari | +| `rps` implementation (Aki) | @florence-bockting, @avehtari | +| K-fold vignette | | +| Broader loo 3.0.0 migration | `loo-v3.0.0` branch, `dev/migration-guide-loo-v3.Rmd` | + +--- + +## Appendix: Numerical comparisons (deprecated vs new API) + +Simulations and tests that validate design choices in this PR. Automated +comparisons live in `tests/testthat/test_crps.R` (CRPS/RPS section). + +### CRPS / RPS + +Deprecated `crps()` / `scrps()` and new `measure_rps()` / `measure_srps()` target +the same scoring rules but use different estimators. + +#### API mapping + +| Deprecated | New workflow | Notes | +|------------|--------------|-------| +| `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).** `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 + permutation (`EXX_compute()` in `R/crps.R`). + - **New:** single `ypred` matrix; PWM on sorted draws (Zamo & Naveau, 2018). + + `EXy = E|X − y|` is **identical** between APIs. After sign alignment, all + pointwise differences come from EXX. + +3. **LOO weighting.** `loo_crps()` shuffles a second draw matrix and applies + joint PSIS weights to `|x − x2|`. `loo_pred_measure(..., measure = "rps")` + 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) + +![CRPS/RPS comparison: PWM vs permutation EXX estimators](figures/crps-rps-comparison.png) + +*Figure: left — per-observation EXX estimates at the brms default draw count +(S = 4000 post-warmup draws: 4 chains × 1000); right — mean relative EXX error +decreases with more posterior draws.* + +```{r crps-rps-comparison} +devtools::load_all(quiet = TRUE) + +.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)) +} + +.outcome_panel <- function(old_est, new_est, xlab, ylab, main, pad_frac = 0.2) { + lim <- range(c(old_est, new_est)) + pad <- diff(lim) * pad_frac + if (pad == 0) pad <- abs(lim[1]) * pad_frac + lim <- lim + c(-pad, pad) + plot( + old_est, new_est, + xlab = xlab, ylab = ylab, main = main, + xlim = lim, ylim = lim, + pch = 16, col = adjustcolor("steelblue", 0.55) + ) + abline(0, 1, lty = 2, col = "gray40") + r <- cor(old_est, new_est) + mtext(sprintf("r = %.3f", r), side = 3, line = 0.2, cex = 0.85, adj = 0) +} + +set.seed(123456789) +n <- 30 +S <- 100 +y <- rnorm(n) +x1 <- matrix(rnorm(n * S), nrow = S) +x2 <- matrix(rnorm(n * S), nrow = S) + +EXy <- colMeans(abs(sweep(x1, 2, y))) +EXX_perm <- colMeans(abs(x1 - x2[sample(S), , drop = FALSE])) +EXX_pwm <- .exx_pwm(x1) + +old_crps <- suppressWarnings(crps(x1, x2, y)) +# `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) + +comparison <- data.frame( + metric = c( + "Mean rel. |EXX_perm - EXX_pwm| / EXX_pwm", + "cor(pointwise CRPS, sign-aligned)", + "Mean |pointwise CRPS diff|", + "cor(pointwise SCRPS, SRPS)" + ), + value = c( + mean(abs(EXX_perm - EXX_pwm) / EXX_pwm), + cor(old_crps$pointwise, as.vector(new_rps$pointwise)), + mean(abs(old_crps$pointwise - as.vector(new_rps$pointwise))), + cor(old_scrps$pointwise, as.vector(new_srps$pointwise)) + ) +) +knitr::kable( + comparison, + col.names = c("Metric (S = 100, n = 30)", "Value"), + digits = 4 +) +``` + +```{r crps-rps-figure, fig.show = "hide"} +S_brms <- 4L * (getOption("brms.iter", 2000L) %/% 2L) + +set.seed(123456789) +n_obs_exx <- 30L +y_exx <- rnorm(n_obs_exx) +x1_exx <- matrix(rnorm(n_obs_exx * S_brms), nrow = S_brms) +x2_exx <- matrix(rnorm(n_obs_exx * S_brms), nrow = S_brms) +EXX_perm_brms <- colMeans(abs(x1_exx - x2_exx[sample(S_brms), , drop = FALSE])) +EXX_pwm_brms <- .exx_pwm(x1_exx) + +.exx_axis_lim <- function(x, y, pad_frac = 0.2) { + lim <- range(c(x, y)) + pad <- diff(lim) * pad_frac + if (pad == 0) pad <- abs(lim[1]) * pad_frac + c(max(0, lim[1] - pad), lim[2] + pad) +} +exx_lim <- .exx_axis_lim(EXX_perm_brms, EXX_pwm_brms) + +png("figures/crps-rps-comparison.png", width = 8, height = 4.5, units = "in", res = 150) +par(mfrow = c(1, 2), mar = c(4, 4, 2, 1)) + +plot( + EXX_perm_brms, EXX_pwm_brms, + xlab = "EXX (permutation, 1 shuffle)", + ylab = "EXX (PWM)", + xlim = exx_lim, ylim = exx_lim, + pch = 16, col = adjustcolor("steelblue", 0.7), + main = sprintf("EXX per observation (S = %d)", S_brms) +) +abline(0, 1, lty = 2, col = "gray40") + +draw_sizes <- c(50, 100, 250, 500, 1000, 2500, 5000) +rel_err <- vapply(draw_sizes, function(S) { + set.seed(99) + x1s <- matrix(rnorm(20 * S), nrow = S) + x2s <- matrix(rnorm(20 * S), nrow = S) + EXX_p <- colMeans(abs(x1s - x2s[sample(S), , drop = FALSE])) + EXX_w <- .exx_pwm(x1s) + mean(abs(EXX_p - EXX_w) / EXX_w) +}, numeric(1)) + +plot( + draw_sizes, rel_err, type = "b", pch = 16, + log = "x", + xlab = "Number of posterior draws (S)", + ylab = "Mean relative |EXX_perm - EXX_pwm| / EXX_pwm", + main = "EXX convergence with more draws" +) +invisible(dev.off()) +``` + +#### In-sample outcome comparison + +![CRPS/RPS outcome comparison across replications](figures/crps-rps-outcomes.png) + +*Figure: 200 simulations (S = 100, n = 30). Left — `crps()` vs +`-measure_rps()`; right — `scrps()` vs `measure_srps()`.* + +```{r crps-rps-outcomes-figure, fig.show = "hide"} +n_repl <- 200L +n_obs <- 30L +n_draws <- 100L +crps_old <- rps_new <- scrps_old <- srps_new <- numeric(n_repl) + +for (i in seq_len(n_repl)) { + set.seed(i) + y <- rnorm(n_obs) + 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) + old_s <- suppressWarnings(scrps(x1, x2, y)) + new_s <- measure_srps(y, x1) + crps_old[i] <- old$estimates["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"] +} + +png("figures/crps-rps-outcomes.png", width = 8, height = 4.5, units = "in", res = 150) +par(mfrow = c(1, 2), mar = c(4, 4, 2.5, 1)) +.outcome_panel( + crps_old, rps_new, + xlab = "crps() estimate", + ylab = "-measure_rps()", + main = "Unscaled (CRPS / RPS)" +) +.outcome_panel( + scrps_old, srps_new, + xlab = "scrps() estimate", + ylab = "measure_srps()", + main = "Scaled (SCRPS / SRPS)" +) +invisible(dev.off()) +``` + +#### LOO outcome comparison + +![LOO CRPS/RPS outcome comparison across replications](figures/loo-crps-rps-outcomes.png) + +*Figure: 200 LOO simulations (S = 100, n = 30). Left — `loo_crps()` vs +sign-aligned `loo_pred_measure(..., measure = "rps")`; right — `loo_scrps()` +vs `loo_pred_measure(..., measure = "srps")`.* + +```{r loo-crps-outcomes-figure, fig.show = "hide"} +n_repl <- 200L +n_obs <- 30L +n_draws <- 100L +loo_crps_old <- loo_rps_new <- loo_scrps_old <- loo_srps_new <- numeric(n_repl) + +for (i in seq_len(n_repl)) { + set.seed(i) + y <- rnorm(n_obs) + x1 <- matrix(rnorm(n_obs * n_draws), nrow = n_draws) + x2 <- matrix(rnorm(n_obs * n_draws), nrow = n_draws) + ll <- matrix(rnorm(n_obs * n_draws) * 0.1 - 1, nrow = n_draws) + old <- suppressWarnings(loo_crps(x1, x2, y, ll)) + old_s <- suppressWarnings(loo_scrps(x1, x2, y, ll)) + psis_obj <- psis(-ll, r_eff = 1) + new <- loo_pred_measure( + y = y, ypred = x1, ylp = ll, measure = "rps", psis_object = psis_obj + ) + new_s <- loo_pred_measure( + y = y, ypred = x1, ylp = ll, measure = "srps", psis_object = psis_obj + ) + loo_crps_old[i] <- old$estimates["Estimate"] + loo_rps_new[i] <- -new$estimates["rps_loo", "Estimate"] + loo_scrps_old[i] <- old_s$estimates["Estimate"] + loo_srps_new[i] <- new_s$estimates["srps_loo", "Estimate"] +} + +png("figures/loo-crps-rps-outcomes.png", width = 8, height = 4.5, units = "in", res = 150) +par(mfrow = c(1, 2), mar = c(4, 4, 2.5, 1)) +.outcome_panel( + loo_crps_old, loo_rps_new, + xlab = "loo_crps() estimate", + ylab = "-loo_pred_measure(..., measure = 'rps')", + main = "LOO unscaled (CRPS / RPS)" +) +.outcome_panel( + loo_scrps_old, loo_srps_new, + xlab = "loo_scrps() estimate", + ylab = "loo_pred_measure(..., measure = 'srps')", + main = "LOO scaled (SCRPS / SRPS)" +) +invisible(dev.off()) +``` + +**CRPS/RPS takeaway:** Results are highly correlated but not interchangeable. The +PWM estimator is lower-variance and requires only one draw matrix. For migration, +compare trends and rankings rather than expecting pointwise equality. + +### ELPD / IC + +Deprecated `elpd()` and new `measure_elpd()` / `measure_ic()` compute the same +in-sample pointwise log predictive density and information criterion from a +log-likelihood matrix. The difference is return structure (`elpd_generic` with +both columns vs separate `"measure"` objects), not the underlying formula. + +| Deprecated | New workflow | Notes | +|------------|--------------|-------| +| `elpd(ylp)$estimates["elpd", ]` | `measure_elpd(ylp)` | Same `lppd_i` computation | +| `elpd(ylp)$estimates["ic", ]` | `measure_ic(ylp)` | `ic_i = -2 * lppd_i` in both APIs | + +#### Outcome comparison + +![ELPD / IC outcome comparison across replications](figures/elpd-ic-outcomes.png) + +*Figure: 200 simulations (S = 100, n = 30). Left — `elpd()` vs `measure_elpd()`; +right — `ic` from `elpd()` vs `measure_ic()`.* + +```{r elpd-ic-outcomes-figure, fig.show = "hide"} +n_repl <- 200L +n_obs <- 30L +n_draws <- 100L +elpd_old <- elpd_new <- ic_old <- ic_new <- numeric(n_repl) + +for (i in seq_len(n_repl)) { + set.seed(i) + ll <- matrix(rnorm(n_obs * n_draws) - 2, nrow = n_draws) + old <- suppressWarnings(elpd(ll)) + new_e <- measure_elpd(ll) + new_i <- measure_ic(ll) + elpd_old[i] <- old$estimates["elpd", "Estimate"] + elpd_new[i] <- new_e$estimates[1, "Estimate"] + ic_old[i] <- old$estimates["ic", "Estimate"] + ic_new[i] <- new_i$estimates[1, "Estimate"] +} + +png("figures/elpd-ic-outcomes.png", width = 8, height = 4.5, units = "in", res = 150) +par(mfrow = c(1, 2), mar = c(4, 4, 2.5, 1)) +.outcome_panel( + elpd_old, elpd_new, + xlab = "elpd() estimate", + ylab = "measure_elpd()", + main = "ELPD" +) +.outcome_panel( + ic_old, ic_new, + xlab = "elpd() ic estimate", + ylab = "measure_ic()", + main = "IC" +) +invisible(dev.off()) +``` + +**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/developer-notes.md b/notes/developer-notes.md new file mode 100644 index 00000000..f7ba792e --- /dev/null +++ b/notes/developer-notes.md @@ -0,0 +1,518 @@ +Developer Notes: `pred_measure` Feature +================ + +- [Status at a Glance](#status-at-a-glance) +- [Scope of this PR (`add-pred-measure` vs + `loo-v3.0.0`)](#scope-of-this-pr-add-pred-measure-vs-loo-v300) +- [Design decisions (resolved)](#design-decisions-resolved) +- [Open decisions](#open-decisions) +- [Tasks](#tasks) +- [General questions](#general-questions) +- [Deprecation checklist](#deprecation-checklist) +- [References & resources](#references--resources) +- [Appendix: Numerical comparisons (deprecated vs new + API)](#appendix-numerical-comparisons-deprecated-vs-new-api) + +> **Status:** In Progress +> **Base branch:** `loo-v3.0.0` +> **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-07 + +These notes document internal design decisions and ongoing work for the +`pred_measure` feature. This PR **adds** the new API on top of +`loo-v3.0.0`; it does not include other planned 3.0.0 changes +(e.g. broader `compare()` / `psislw()` removals) documented on the +`loo-v3.0.0` branch. + +For the merge summary, see the PR description +([`internal-notes/pr-pred_measure.md`](../internal-notes/pr-pred_measure.md)). + +------------------------------------------------------------------------ + +## Status at a Glance + +| Area | Status | +|-------------------------------|------------------------| +| `pred_measure` API | Done (initial release) | +| `measure_*()` built-ins | Done | +| Scoring rules (`measure_rps`) | Done | +| Documentation | In progress | +| `group_ids` grouping | Not started | +| `loo_compare` integration | Done (`integrate-loo_compare`) | + +------------------------------------------------------------------------ + +## Scope of this PR (`add-pred-measure` vs `loo-v3.0.0`) + +### 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()`, + `custom_measure()` +- `R/pred_measure-compute.R`, `R/pred_measure-helpers.R`, + `R/pred_measure-builtin.R` — orchestration and `measure_*()` + implementations +- `supported_measures_list()`, `ptw_log_pred_density()` +- S3 print methods for `pred_measure`, `loo_pred_measure`, + `kfold_pred_measure` +- `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 + (`integrate-loo_compare`) + +### Changed on existing code (implementations retained) + +- `elpd()`, `crps()`, `scrps()`, `loo_crps()`, `loo_scrps()`, + `loo_predictive_metric()` — deprecated with migration docs; **same + APIs and implementations** (e.g. `crps(x, x2, y)` permutation + estimator unchanged) +- `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) + +### D2: Scaled RPS — separate function vs. argument + +**Decision:** Both. `measure_rps(..., scaled = TRUE)` is the +implementation; `measure_srps()` is a convenience wrapper. An explicit +`srps` built-in name is required so users can request both in one call: + +``` r +pred_measure(y = y, ypred = ypred, measure = c("rps", "srps"), ...) +``` + +Without a separate `srps` name, duplicate measure names would require +custom functions. + +### Unified scoring rule in the new API + +`measure_rps()` subsumes CRPS, RPS, SCRPS, and SRPS for the **new** +workflow: + +- Single `ypred` matrix (not two independent draw matrices) +- PWM/ECDF estimator (Aki’s implementation; verified against Seth’s + derivations) +- Works for continuous and ordered categorical outcomes +- `measure_srps()` = scaled variant + +Deprecated `crps()` / `scrps()` remain for backward compatibility with +the `x`, `x2` permutation-based API. + +### ELPD and `ic` in the new API + +Design choices **internal to `pred_measure`** (not a migration from +`loo-v3.0.0`, which has no `pred_measure`): + +- When `ylp` is supplied, `elpd` is computed as the base summary +- `ic` is **not** included automatically; request via `measure = "ic"` +- `measure_elpd()` is separate from deprecated `elpd()` (different + return type: `"measure"` vs `"elpd_generic"`) + +### K-fold + categorical / multinomial models (brms) + +- [x] Upstream fix for 3D `brms::kfold_predict()` output + ([brms#1889](https://github.com/paul-buerkner/brms/issues/1889), fixed + in [brms#1890](https://github.com/paul-buerkner/brms/pull/1890), + merged to `main`) +- [x] Vignettes and pkgdown CI install brms from GitHub `master` + (`vignettes/children/LOAD-BRMS-GITHUB.txt`, + `.github/workflows/pkgdown.yaml`, + `tests/testthat/data-for-tests/test_data_generation.R`) +- [ ] Drop GitHub brms pin once a CRAN release includes the \#1890 fix +- [ ] 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()` + +- 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 (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` + +- **Context:** + [stan-dev/posterior#446](https://github.com/stan-dev/posterior/issues/446) +- **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) + +- [x] Add `measure_elpd()` for the new API +- [x] Refactor deprecated `elpd()` to `.elpd_matrix_impl()` (no double + warnings) +- [x] Add `measure_rps()` as unified scoring-rule implementation (single + `ypred`) +- [x] Keep deprecated `crps()` / `scrps()` with `x`, `x2` API unchanged +- [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)* +- [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 + +- [x] Consolidate CRPS/RPS/SCRPS/SRPS in `measure_rps()` for new API +- [x] Resolve `srps` naming *(see D2)* +- [x] brms k-fold categorical support unblocked upstream *(see above)* +- [ ] Drop GitHub brms pin after CRAN release + +### Documentation + +- [x] Migration guide (`vignettes/migration-guide.Rmd`) +- [x] Overview of measures (`overview-measures.Rmd`) +- [x] Workflow article (`pred-measure-workflow.Rmd`) +- [x] Online-only articles published via `_pkgdown.yml` +- [ ] Formula derivations article (`pred_measure-formulas.Rmd`) +- [ ] Detailed per-measure descriptions (derivations where appropriate) +- [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` + +- [ ] Work out grouping scenarios for LOO and k-fold + +- [ ] Implement in `kfold_pred_measure()`, `loo_pred_measure()`, + `pred_measure()` + + > **Blocker:** Implementation approach uncertain; grouping scenarios + > must be understood before coding begins. + +------------------------------------------------------------------------ + +## General questions + +- Rename `ic` → `information_criteria` for clarity? +- Should `measure_elpd()` also return `ic`, or keep them separate? +- 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? + +------------------------------------------------------------------------ + +## Deprecation checklist + +When deprecating or removing a function: + +1. Add `.Deprecated("replacement")` in each exported method (only if the + replacement is exported). +2. Document deprecation in roxygen (`**deprecated**`, links to replacement). +3. Add a bullet to `NEWS.md`. +4. Update `vignettes/migration-guide.Rmd`. +5. Add or update tests in `tests/testthat/test_deprecated_*.R`. +6. List the topic under **Deprecated functions** in `_pkgdown.yml`. +7. Keep the old implementation until the planned removal release. +8. On removal: delete the source file, remove from `NAMESPACE`, update the + migration guide. + +When a feature adds new replacements, extend the **Function migration tables** +in `vignettes/migration-guide.Rmd`. + +## References & resources + +| Resource | Link / contact | +|-----------------------------|------------------------------------------------------------------------------------------------------------------------------| +| Cross-validation FAQ | | +| `r_eff` in posterior (Aki) | | +| brms k-fold 3D fix | [brms#1889](https://github.com/paul-buerkner/brms/issues/1889), [brms#1890](https://github.com/paul-buerkner/brms/pull/1890) | +| `rps` derivation (Seth) | @florence-bockting, @avehtari | +| `rps` implementation (Aki) | @florence-bockting, @avehtari | +| K-fold vignette | | +| Broader loo 3.0.0 migration | `loo-v3.0.0` branch, `dev/migration-guide-loo-v3.Rmd` | + +------------------------------------------------------------------------ + +## Appendix: Numerical comparisons (deprecated vs new API) + +Simulations and tests that validate design choices in this PR. Automated +comparisons live in `tests/testthat/test_crps.R` (CRPS/RPS section). + +### CRPS / RPS + +Deprecated `crps()` / `scrps()` and new `measure_rps()` / +`measure_srps()` target the same scoring rules but use different +estimators. + +#### API mapping + +| Deprecated | New workflow | Notes | +|-------------------|-------------------------------------------------|-------------------------------------| +| `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).** `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 permutation (`EXX_compute()` in `R/crps.R`). + - **New:** single `ypred` matrix; PWM on sorted draws (Zamo & + Naveau, 2018). + + `EXy = E|X − y|` is **identical** between APIs. After sign + alignment, all pointwise differences come from EXX. + +3. **LOO weighting.** `loo_crps()` shuffles a second draw matrix and + applies joint PSIS weights to `|x − x2|`. + `loo_pred_measure(..., measure = "rps")` 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) + +
+ + +
+ +*Figure: left — per-observation EXX estimates at the brms default draw +count (S = 4000 post-warmup draws: 4 chains × 1000); right — mean +relative EXX error decreases with more posterior draws.* + +| Metric (S = 100, n = 30) | Value | +|:-------------------------------------------|-------:| +| Mean rel. \|EXX_perm - EXX_pwm\| / EXX_pwm | 0.0688 | +| cor(pointwise CRPS, sign-aligned) | 0.9923 | +| Mean \|pointwise CRPS diff\| | 0.0339 | +| cor(pointwise SCRPS, SRPS) | 0.9911 | + +#### In-sample outcome comparison + +
+ + +
+ +*Figure: 200 simulations (S = 100, n = 30). Left — `crps()` vs +`-measure_rps()`; right — `scrps()` vs +`measure_srps()`.* + +#### LOO outcome comparison + +
+ + +
+ +*Figure: 200 LOO simulations (S = 100, n = 30). Left — `loo_crps()` vs +sign-aligned `loo_pred_measure(..., measure = "rps")`; right — +`loo_scrps()` vs `loo_pred_measure(..., measure = "srps")`.* + +**CRPS/RPS takeaway:** Results are highly correlated but not +interchangeable. The PWM estimator is lower-variance and requires only +one draw matrix. For migration, compare trends and rankings rather than +expecting pointwise equality. + +### ELPD / IC + +Deprecated `elpd()` and new `measure_elpd()` / `measure_ic()` compute +the same in-sample pointwise log predictive density and information +criterion from a log-likelihood matrix. The difference is return +structure (`elpd_generic` with both columns vs separate `"measure"` +objects), not the underlying formula. + +| Deprecated | New workflow | Notes | +|---------------------------------|---------------------|-----------------------------------| +| `elpd(ylp)$estimates["elpd", ]` | `measure_elpd(ylp)` | Same `lppd_i` computation | +| `elpd(ylp)$estimates["ic", ]` | `measure_ic(ylp)` | `ic_i = -2 * lppd_i` in both APIs | + +#### Outcome comparison + +
+ + +
+ +*Figure: 200 simulations (S = 100, n = 30). Left — `elpd()` vs +`measure_elpd()`; right — `ic` from `elpd()` vs `measure_ic()`.* + +**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/figures/crps-rps-comparison.png b/notes/figures/crps-rps-comparison.png new file mode 100644 index 00000000..b035d900 Binary files /dev/null and b/notes/figures/crps-rps-comparison.png differ diff --git a/notes/figures/crps-rps-outcomes.png b/notes/figures/crps-rps-outcomes.png new file mode 100644 index 00000000..b1f6d751 Binary files /dev/null and b/notes/figures/crps-rps-outcomes.png differ diff --git a/notes/figures/elpd-ic-outcomes.png b/notes/figures/elpd-ic-outcomes.png new file mode 100644 index 00000000..5d1e2cff Binary files /dev/null and b/notes/figures/elpd-ic-outcomes.png differ diff --git a/notes/figures/loo-crps-rps-outcomes.png b/notes/figures/loo-crps-rps-outcomes.png new file mode 100644 index 00000000..6bff6c65 Binary files /dev/null and b/notes/figures/loo-crps-rps-outcomes.png differ 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..ca571fb2 100644 --- a/tests/testthat/_snaps/compare.md +++ b/tests/testthat/_snaps/compare.md @@ -1,6 +1,289 @@ -# 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 + +# 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. + +# model_compare returns expected results (2 models) + + WAoAAAACAAQGAQACAwAAAAMTAAAADAAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v ZGVsMgAAAA4AAAACAAAAAAAAAAAAAAAAAAAAAAAAAA4AAAACAAAAAAAAAAAAAAAAAAAAAAAA AA4AAAACf/AAAAAAB6J/8AAAAAAHogAAABAAAAACAAQACQAAAAAABAAJAAAAAAAAABAAAAAC AAQACQAAAAAABAAJAAAAAAAAAA4AAAACwFTh8N3JQljAVOHw3clCWAAAAA4AAAACQBEIPbMR @@ -12,7 +295,8 @@ AAAABnBfd2FpYwAEAAkAAAAJc2VfcF93YWljAAQACQAAAAR3YWljAAQACQAAAAdzZV93YWlj AAAEAgAAAAEABAAJAAAABWNsYXNzAAAAEAAAAAIABAAJAAAAC2NvbXBhcmUubG9vAAQACQAA AApkYXRhLmZyYW1lAAAEAgAAAAEABAAJAAAACXJvdy5uYW1lcwAAAA0AAAACgAAAAP////4A - AAD+ + AAQCAAAAAQAEAAkAAAARY29tcGFyZV9yZWZlcmVuY2UAAAIQAAAAAQAEAAkAAAAGbW9kZWwx + AAAEAgAAAf8AAAAQAAAAAQAEAAkAAAAEZWxwZAAAAP4AAAD+ --- @@ -25,7 +309,7 @@ --- - WAoAAAACAAQEAgACAwAAAAMTAAAADAAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v + WAoAAAACAAQGAQACAwAAAAMTAAAADAAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v ZGVsMgAAAA4AAAACAAAAAAAAAADAEDpTX5xF7gAAAA4AAAACAAAAAAAAAAA/tmpHtC8TAQAA AA4AAAACf/AAAAAAB6I/8AAAAAAAAAAAABAAAAACAAQACQAAAAAABAAJAAAAB04gPCAxMDAA AAAQAAAAAgAEAAkAAAAAAAQACQAAAAAAAAAOAAAAAsBU4fDdyUJYwFXllhPDBrkAAAAOAAAA @@ -37,7 +321,8 @@ YWljAAQACQAAAAZwX3dhaWMABAAJAAAACXNlX3Bfd2FpYwAEAAkAAAAEd2FpYwAEAAkAAAAH c2Vfd2FpYwAABAIAAAABAAQACQAAAAVjbGFzcwAAABAAAAACAAQACQAAAAtjb21wYXJlLmxv bwAEAAkAAAAKZGF0YS5mcmFtZQAABAIAAAABAAQACQAAAAlyb3cubmFtZXMAAAANAAAAAoAA - AAD////+AAAA/g== + AAD////+AAAEAgAAAAEABAAJAAAAEWNvbXBhcmVfcmVmZXJlbmNlAAACEAAAAAEABAAJAAAA + Bm1vZGVsMQAABAIAAAH/AAAAEAAAAAEABAAJAAAABGVscGQAAAD+AAAA/g== --- @@ -88,11 +373,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 +389,8 @@ d2FpYwAEAAkAAAAGcF93YWljAAQACQAAAAlzZV9wX3dhaWMABAAJAAAABHdhaWMABAAJAAAA B3NlX3dhaWMAAAQCAAAAAQAEAAkAAAAFY2xhc3MAAAAQAAAAAgAEAAkAAAALY29tcGFyZS5s b28ABAAJAAAACmRhdGEuZnJhbWUAAAQCAAAAAQAEAAkAAAAJcm93Lm5hbWVzAAAADQAAAAKA - AAAA/////QAAAP4= + AAAA/////QAABAIAAAABAAQACQAAABFjb21wYXJlX3JlZmVyZW5jZQAAAhAAAAABAAQACQAA + AAZtb2RlbDEAAAQCAAAB/wAAABAAAAABAAQACQAAAARlbHBkAAAA/gAAAP4= --- @@ -121,7 +407,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) diff --git a/tests/testthat/_snaps/loo_moment_matching.md b/tests/testthat/_snaps/loo_moment_matching.md index 6d381b25..9cf16d9f 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 new file mode 100644 index 00000000..4204568d --- /dev/null +++ b/tests/testthat/_snaps/pred_measure_builtin.md @@ -0,0 +1,112 @@ +# measure_elpd() works as expected + + + Computed from 400 draws by 53 observations. + + Estimate SE + elpd -706.7 146.5 + +# measure_ic() works as expected + + + Computed from 400 draws by 53 observations. + + Estimate SE + ic 1413.3 293.0 + +# measure_mlpd() works as expected + + + Computed from 400 draws by 53 observations. + + Estimate SE + mlpd -13.333 2.765 + +# measure_mlpd() with pointwise works as expected + + + Computed from 53 pointwise terms. + + 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.877 0.087 + +# measure_rps() scaled version with categorical data works as expected + + + Computed from 400 draws by 50 observations. + + 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.6 3.3 + +# measure_brier() works as expected + + + Computed from 400 draws by 50 observations. + + Estimate SE + brier 0.241 0.009 + +# measure_mae() works as expected + + + Computed from 400 draws by 53 observations. + + 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.0 224.2 + +--- + + + Computed from 400 draws by 53 observations. + + Estimate SE + rmse 25.7 4.4 + +# measure_r2() works as expected + + + Computed from 400 draws by 53 observations. + + Estimate SE + r2 0.583 0.166 + +# measure_acc() works as expected + + + Computed from 400 draws by 67 observations. + + Estimate SE + acc 0.970 0.021 + +# measure_bacc() works as expected + + + Computed from 400 draws by 67 observations. + + Estimate SE + bacc 0.952 0.031 + diff --git a/tests/testthat/_snaps/print.md b/tests/testthat/_snaps/print.md new file mode 100644 index 00000000..4aab75f4 --- /dev/null +++ b/tests/testthat/_snaps/print.md @@ -0,0 +1,279 @@ +# loo_pred_measure print snapshots + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + r2_loo 0.564 0.167 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + r2_loo 0.564 0.167 + rmse_loo 26.3 4.4 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + r2_loo 0.564 0.167 + rmse_loo 26.3 4.4 + mse_loo 691.9 230.5 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + 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 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + 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 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + 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 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + 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 + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + srps_loo -4.10 0.46 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + srps_loo -4.10 0.46 + r2_loo 0.564 0.167 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + 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 + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + 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 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + 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 + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + 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 + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + 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 + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +# loo_pred_measure print output with elpd + + + 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.564 0.167 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +# test_pred_measure print output + + + Computed from 400 posterior draws and 20 observations. + Data source: test + + 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 new file mode 100644 index 00000000..a6f147c8 Binary files /dev/null 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 new file mode 100644 index 00000000..2cd404cd Binary files /dev/null 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 new file mode 100644 index 00000000..26389920 --- /dev/null +++ b/tests/testthat/data-for-tests/test_data_generation.R @@ -0,0 +1,443 @@ +# Data-generation pipeline for the pred_measure test fixtures. +# +# Slow: fits ~6 brms models with k-fold / LOO postprocessing (~10-20 min). +# Run from package root: +# Rscript tests/testthat/data-for-tests/test_data_generation.R +# +# Outputs: +# tests/testthat/data-for-tests/test_data_*.Rds +library(rstanarm) +# brms features used here require GitHub master (not yet on CRAN) +if (!requireNamespace("remotes", quietly = TRUE)) { + install.packages("remotes") +} +if (!requireNamespace("brms", quietly = TRUE)) { + remotes::install_github("paul-buerkner/brms", ref = "master", upgrade = "never") +} +suppressPackageStartupMessages({ + library(brms) + library(dplyr) + library(loo) +}) + +SEED <- 42 + +postprocess_res <- function(model, fit, chains = 2, draws = 200) { + ypred <- brms::posterior_predict(fit) + mupred <- brms::posterior_epred(fit) + ylp <- log_lik(fit) + log_ratios <- -1 * ylp + r_eff <- relative_eff(exp(-log_ratios), chain_id = rep(1:chains, each = draws)) + psis_object <- psis(log_ratios, r_eff = r_eff, cores = 2) + kfold2 <- brms::kfold(fit, save_fits = FALSE) + if (model %in% c("roaches", "binary", "binomial", "sleep")) { + kfold <- brms::kfold(fit, save_fits = TRUE) + mupred_kfold <- brms::kfold_predict(kfold, method = "fitted")$yrep + ypred_kfold <- brms::kfold_predict(kfold, method = "predict")$yrep + loo <- brms::loo(fit, save_psis = TRUE) + predperf <- insample_pred_measure(y = fit$data$y, mupred = mupred, + measures = "r2", ylp = ylp) + } + + if (model == "roaches") { + list( + y = fit$data$y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + log_weights = psis_object$log_weights, + kfold = kfold2, + loo = loo, + predperf = predperf + ) + } else if (model == "binomial") { + list( + y = fit$data$y, + ypred = ypred, + log_weights = psis_object$log_weights, + ypred_kfold = ypred_kfold + ) + } else if (model == "binary") { + list( + y = fit$data$y, + ypred = ypred, + log_weights = psis_object$log_weights, + ypred_kfold = ypred_kfold + ) + } else if (model == "categorical") { + list( + y = fit$data$y, + mupred = mupred, + log_weights = psis_object$log_weights + ) + } else if (model == "sleep") { + list( + y = fit$data$y, + ypred = ypred, + log_weights = psis_object$log_weights, + ypred_kfold = ypred_kfold, + mupred = mupred, + mupred_kfold = mupred_kfold + ) + } +} + +# ---- 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. The exception is +# `test_data_roaches_compare.Rds`: its fit uses `thin = 4`, so it holds only +# 100 draws. +N_KEEP <- c( + roaches = 53, roaches_compare = 110, categorical = 67, sleep = 29, + sleep_test = 20 +) + +# Estimate and SE of a summed pointwise column, in loo's convention. +.estimates_from_pointwise <- function(pointwise, cols) { + pw <- pointwise[, cols, drop = FALSE] + cbind(Estimate = colSums(pw), SE = sqrt(nrow(pw) * apply(pw, 2, var))) +} + +# Index of the observations to keep. `strata` allocates proportionally, so +# every level of a categorical outcome survives. +.keep_index <- function(n, n_keep, strata = NULL) { + set.seed(SEED) + if (is.null(strata)) { + return(sort(sample.int(n, n_keep))) + } + strata <- as.factor(strata) + per <- pmax(1L, round(n_keep * as.vector(table(strata)) / n)) + idx <- unlist(Map( + function(lev, k) sample(which(strata == lev), k), + levels(strata), per + )) + sort(as.integer(idx)) +} + +# PSIS smoothing is per observation, so subsetting columns is exact. Only the +# aggregates need recomputing. +.shrink_psis_loo <- function(x, keep) { + x$pointwise <- x$pointwise[keep, , drop = FALSE] + x$diagnostics <- lapply(x$diagnostics, function(d) d[keep]) + + po <- x$psis_object + po$log_weights <- po$log_weights[, keep, drop = FALSE] + po$diagnostics <- lapply(po$diagnostics, function(d) d[keep]) + for (a in c("norm_const_log", "tail_len", "r_eff")) { + attr(po, a) <- attr(po, a)[keep] + } + attr(po, "dims") <- c(attr(po, "dims")[1], length(keep)) + x$psis_object <- po + + est <- .estimates_from_pointwise(x$pointwise, c("elpd_loo", "p_loo", "looic")) + x$estimates <- est + x$elpd_loo <- est["elpd_loo", "Estimate"] + x$p_loo <- est["p_loo", "Estimate"] + x$looic <- est["looic", "Estimate"] + x$se_elpd_loo <- est["elpd_loo", "SE"] + x$se_p_loo <- est["p_loo", "SE"] + x$se_looic <- est["looic", "SE"] + attr(x, "dims") <- c(attr(x, "dims")[1], length(keep)) + x +} + +.shrink_kfold <- function(x, keep) { + x$pointwise <- x$pointwise[keep, , drop = FALSE] + x$estimates <- .estimates_from_pointwise(x$pointwise, colnames(x$pointwise)) + attr(x, "folds") <- attr(x, "folds")[keep] + x +} + +shrink_res <- function(model, res) { + # binary and binomial hold 50 observations and 86 KB in total. Leave them. + if (model %in% c("binary", "binomial")) { + return(res) + } + if (model == "sleep_test") { + keep_test <- .keep_index(length(res$y_test), N_KEEP[["sleep_test"]]) + res$y_test <- res$y_test[keep_test] + for (nm in c("ypred_test", "mupred_test", "ylp_test")) { + res[[nm]] <- res[[nm]][, keep_test, drop = FALSE] + } + return(res) + } + + keep <- if (model == "categorical") { + .keep_index(length(res$y), N_KEEP[["categorical"]], strata = res$y) + } else { + .keep_index(length(res$y), N_KEEP[[model]]) + } + + res$y <- res$y[keep] + for (nm in c("ypred", "mupred", "ylp", "log_weights", + "ypred_kfold", "mupred_kfold")) { + if (!is.null(res[[nm]]) && length(dim(res[[nm]])) == 2L) { + res[[nm]] <- res[[nm]][, keep, drop = FALSE] + } + } + # A categorical mupred is draws x observations x categories. + if (!is.null(res$mupred) && length(dim(res$mupred)) == 3L) { + res$mupred <- res$mupred[, keep, , drop = FALSE] + } + if (!is.null(res$loo)) { + res$loo <- .shrink_psis_loo(res$loo, keep) + } + if (!is.null(res$kfold)) { + res$kfold <- .shrink_kfold(res$kfold, keep) + } + if (!is.null(res$predperf)) { + res$predperf <- insample_pred_measure( + y = res$y, mupred = res$mupred, measures = "r2", ylp = res$ylp + ) + } + 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)) + + fit_binary <- brms::brm(formula = "y ~ 1", + data = df_binary, + family = bernoulli, + chains = 2, + iter = 400, + seed = SEED, + refresh = 0 + ) + list( + fit = fit_binary, + res = postprocess_res("binary", fit_binary) + ) +} + +get_roaches_res <- function() { + data(roaches, package = "rstanarm") + roaches$sqrt_roach1 <- sqrt(roaches$roach1) + + fit_roaches <- brm( + y ~ sqrt_roach1 + treatment + senior + offset(log(exposure2)), + data = roaches, + family = poisson, + prior = prior(normal(0, 1), class = b), + chains = 2, + iter = 400, + refresh = 0, + seed = SEED + ) + list( + fit = fit_roaches, + res = postprocess_res("roaches", fit_roaches) + ) +} + +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") + conditions <- brms::make_conditions(sleepstudy, "Subject", incl_vars = FALSE) + sleepstudy <- sleepstudy |> + dplyr::filter(Days >= 2) |> + dplyr::mutate( + Days = Days - 2, + y = Reaction + ) + + test_subjects <- sample(unique(sleepstudy$Subject), size = 5) + train_data <- sleepstudy |> + dplyr::filter(!Subject %in% test_subjects) + test_data <- sleepstudy |> + dplyr::filter(Subject %in% test_subjects) + + prior_lin_base <- brms::prior(normal(200, 100), class = b, coef = "Intercept") + + brms::prior(normal(0, 20), class = b, coef = "Days") + + brms::prior(exponential(0.02), class = sigma) + + fit_sleep_train <- brm( + y ~ 0 + Intercept + Days, + data = train_data, + family = gaussian(), + prior = prior_lin_base, + chains = 2, + iter = 400, + seed = SEED + ) + + list( + fit = fit_sleep_train, + res = list( + y_test = test_data$y, + ypred_test = brms::posterior_predict(fit_sleep_train, newdata = test_data), + mupred_test = brms::posterior_epred(fit_sleep_train, newdata = test_data), + ylp_test = brms::log_lik(fit_sleep_train, newdata = test_data) + ) + ) +} + +get_sleep_res <- function() { + data("sleepstudy", package = "lme4") + conditions <- brms::make_conditions(sleepstudy, "Subject", incl_vars = FALSE) + sleepstudy <- sleepstudy |> + dplyr::filter(Days >= 2) |> + dplyr::mutate(Days = Days - 2, y = Reaction) + + prior_lin_base <- brms::prior(normal(200, 100), class = b, coef = "Intercept") + + brms::prior(normal(0, 20), class = b, coef = "Days") + + brms::prior(exponential(0.02), class = sigma) + + fit_sleepstudy <- brms::brm( + y ~ 0 + Intercept + Days, + data = sleepstudy, + family = gaussian(), + prior = prior_lin_base, + chains = 2, + iter = 400, + refresh = 0, + seed = SEED + ) + list( + fit = fit_sleepstudy, + res = postprocess_res("sleep", fit_sleepstudy) + ) +} + +get_penguins_res <- function() { + data("penguins", package = "palmerpenguins") + penguins <- subset(penguins, complete.cases(penguins)) + penguins$y <- penguins$species + + fit <- brm( + y ~ bill_length_mm + bill_depth_mm, + data = penguins, + family = categorical(), + chains = 2, + iter = 400, + cores = 2, + seed = SEED + ) + list( + fit = fit, + res = postprocess_res("categorical", fit) + ) +} + +get_binomial_res <- function() { + set.seed(SEED) + df <- data.frame( + y = rbinom(50, 10, 0.3), + n = 10 + ) + + fit <- brms::brm(formula = "y | trials(n) ~ 1", + data = df, + family = binomial, + chains = 2, + iter = 400, + seed = SEED, + refresh = 0 + ) + list( + fit = fit, + res = postprocess_res("binomial", fit) + ) +} + +generate_test_data <- function() { + message("Generating test fixtures. This may take 10-20 minutes.") + t0 <- proc.time() + + full_roaches <- get_roaches_res() + full_binary <- get_binary_res() + full_penguins <- get_penguins_res() + 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"), 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) + message("Data generation finished in ", elapsed_min, " minutes.") + invisible(NULL) +} + +generate_test_data() diff --git a/tests/testthat/data-for-tests/test_data_penguins.Rds b/tests/testthat/data-for-tests/test_data_penguins.Rds new file mode 100644 index 00000000..9e054297 Binary files /dev/null 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 new file mode 100644 index 00000000..0323291f Binary files /dev/null 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 new file mode 100644 index 00000000..221b9da7 Binary files /dev/null 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 new file mode 100644 index 00000000..14a7f7a2 Binary files /dev/null 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..266a436c 100644 --- a/tests/testthat/test_compare.R +++ b/tests/testthat/test_compare.R @@ -6,62 +6,1355 @@ 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" ) 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,9 +1362,18 @@ 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)) }) +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"))) +}) comp_colnames <- c( "model", @@ -88,8 +1390,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 +1402,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 +1415,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 +1437,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 +1526,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 0738ec7c..a19b655e 100644 --- a/tests/testthat/test_crps.R +++ b/tests/testthat/test_crps.R @@ -25,10 +25,22 @@ test_that("crps computation is correct", { }) test_that("crps matches snapshots", { - expect_snapshot_value(with_seed(1, crps(x1, x2, y)), style = "serialize") - expect_snapshot_value(with_seed(1, scrps(x1, x2, y)), style = "serialize") - expect_snapshot_value(with_seed(1, loo_crps(x1, x2, y, ll)), style = "serialize") - expect_snapshot_value(with_seed(1, loo_scrps(x1, x2, y, ll)), style = "serialize") + expect_snapshot_value( + with_seed(1, suppressWarnings(crps(x1, x2, y))), + style = "serialize" + ) + expect_snapshot_value( + with_seed(1, suppressWarnings(scrps(x1, x2, y))), + style = "serialize" + ) + expect_snapshot_value( + with_seed(1, suppressWarnings(loo_crps(x1, x2, y, ll))), + style = "serialize" + ) + expect_snapshot_value( + with_seed(1, suppressWarnings(loo_scrps(x1, x2, y, ll))), + style = "serialize" + ) }) test_that("input validation throws correct errors", { @@ -53,8 +65,149 @@ test_that("input validation throws correct errors", { }) test_that("methods for single data point don't error", { - expect_silent(crps(x1[,1], x2[,1], y[1])) - expect_silent(scrps(x1[,1], x2[,1], y[1])) + expect_silent(suppressWarnings(crps(x1[, 1], x2[, 1], y[1]))) + expect_silent(suppressWarnings(scrps(x1[, 1], x2[, 1], y[1]))) +}) + +# ------------------------------------------------------------------------- +# Comparison with measure_rps() / measure_srps() (PWM vs permutation EXX) +# 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) { + loo:::.exx_pwm(ypred) +} + +.exy_crps <- function(ypred, y) { + colMeans(abs(sweep(ypred, 2, y))) +} + +.crps_draws <- function(seed = 123456789L, n = 10L, S = 100L) { + set.seed(seed) + y <- rnorm(n) + x1 <- matrix(rnorm(n * S), nrow = S) + x2 <- matrix(rnorm(n * S), nrow = S) + list(y = y, x1 = x1, x2 = x2) +} + +test_that("the deprecated crps() is the negated measure_rps()", { + d <- .crps_draws() + old <- suppressWarnings(crps(d$x1, d$x2, d$y)) + # `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_gt(cor(old$pointwise, negated), 0.98) + expect_false(isTRUE(all.equal( + old$pointwise, + negated, + tolerance = 1e-6 + ))) +}) + +test_that("crps() and measure_rps() share EXy; differences come from EXX estimator", { + d <- .crps_draws() + EXy <- .exy_crps(d$x1, d$y) + EXX_perm <- suppressWarnings({ + set.seed(1) + colMeans(abs(d$x1 - d$x2[sample(nrow(d$x1)), , drop = FALSE])) + }) + EXX_pwm <- .exx_pwm(d$x1) + + expect_equal(EXy, colMeans(abs(sweep(d$x1, 2, d$y)))) + + pw_perm <- 0.5 * EXX_perm - EXy + pw_pwm <- 0.5 * EXX_pwm - EXy + expect_false(isTRUE(all.equal(EXX_perm, EXX_pwm, tolerance = 1e-6))) + expect_gt(cor(pw_perm, pw_pwm), 0.98) + expect_equal( + max(abs(pw_perm - pw_pwm)), + max(abs((0.5 * EXX_perm - EXy) - (0.5 * EXX_pwm - EXy))) + ) +}) + +test_that("scrps() and measure_srps() share sign convention but differ numerically", { + d <- .crps_draws() + old <- suppressWarnings(scrps(d$x1, d$x2, d$y)) + new <- measure_srps(d$y, d$x1) + + expect_gt(cor(old$pointwise, as.vector(new$pointwise)), 0.98) + expect_false(isTRUE(all.equal( + old$pointwise, + as.vector(new$pointwise), + tolerance = 1e-6 + ))) +}) + +test_that("PWM and permutation EXX estimates converge with more draws", { + set.seed(42) + n <- 20L + results <- vapply( + c(100L, 1000L, 5000L), + function(S) { + d <- .crps_draws(seed = 99L, n = n, S = S) + EXX_perm <- colMeans(abs(d$x1 - d$x2[sample(S), , drop = FALSE])) + EXX_pwm <- .exx_pwm(d$x1) + mean(abs(EXX_perm - EXX_pwm) / EXX_pwm) + }, + numeric(1) + ) + expect_lt(results[3], results[1]) +}) + +test_that("loo_crps() and loo_pred_measure(..., measures = 'rps') differ like in-sample APIs", { + set.seed(1) + d <- .crps_draws(seed = 1L, n = 10L, S = 100L) + ll <- matrix(rnorm(10 * 100) * 0.1 - 1, nrow = 100) + + old <- suppressWarnings(loo_crps(d$x1, d$x2, d$y, ll)) + psis_obj <- psis(-ll, r_eff = 1) + new <- loo_pred_measure( + y = d$y, + ypred = d$x1, + ylp = ll, + measures = "rps", + psis_object = psis_obj + ) + + expect_gt( + cor(old$pointwise, -new$pointwise[, "rps_loo"]), + 0.98 + ) + expect_false(isTRUE(all.equal( + old$pointwise, + -new$pointwise[, "rps_loo"], + tolerance = 1e-6 + ))) +}) + +test_that("loo_scrps() and loo_pred_measure(..., measures = 'srps') differ like in-sample APIs", { + set.seed(1) + d <- .crps_draws(seed = 1L, n = 10L, S = 100L) + ll <- matrix(rnorm(10 * 100) * 0.1 - 1, nrow = 100) + + old <- suppressWarnings(loo_scrps(d$x1, d$x2, d$y, ll)) + psis_obj <- psis(-ll, r_eff = 1) + new <- loo_pred_measure( + y = d$y, + ypred = d$x1, + ylp = ll, + measures = "srps", + psis_object = psis_obj + ) + + expect_gt( + cor(old$pointwise, new$pointwise[, "srps_loo"]), + 0.98 + ) + expect_false(isTRUE(all.equal( + old$pointwise, + new$pointwise[, "srps_loo"], + tolerance = 1e-6 + ))) }) test_that("methods for single data point pass permutations to matrix methods", { diff --git a/tests/testthat/test_deprecated_measures.R b/tests/testthat/test_deprecated_measures.R new file mode 100644 index 00000000..92c081a0 --- /dev/null +++ b/tests/testthat/test_deprecated_measures.R @@ -0,0 +1,72 @@ +expect_deprecated <- function(object) { + testthat::expect_warning(object, "deprecated", ignore.case = TRUE) +} + +test_that("elpd() is deprecated", { + ll <- example_loglik_matrix() + expect_deprecated(elpd(ll)) +}) + +test_that("elpd() still returns elpd_generic", { + ll <- example_loglik_matrix() + out <- suppressWarnings(elpd(ll)) + expect_s3_class(out, "elpd_generic") +}) + +test_that("elpd(array) warns only once", { + ll <- example_loglik_array() + msgs <- character() + withCallingHandlers( + elpd(ll), + warning = function(w) { + msgs <<- c(msgs, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ) + expect_length(msgs, 1L) + expect_match(msgs[[1]], "deprecated", ignore.case = TRUE) +}) + +test_that("crps() is deprecated", { + set.seed(1) + y <- rnorm(5) + x1 <- matrix(rnorm(50), nrow = 10) + x2 <- matrix(rnorm(50), nrow = 10) + expect_deprecated(crps(x1, x2, y)) + expect_deprecated(scrps(x1, x2, y)) +}) + +test_that("loo_crps() is deprecated", { + set.seed(1) + y <- rnorm(5) + x1 <- matrix(rnorm(50), nrow = 10) + x2 <- matrix(rnorm(50), nrow = 10) + ll <- matrix(rnorm(50) * 0.1 - 1, nrow = 10) + expect_warning( + tryCatch( + loo_crps(x1, x2, y, ll), + error = function(e) invisible(NULL) + ), + "deprecated", + ignore.case = TRUE + ) + expect_warning( + tryCatch( + loo_scrps(x1, x2, y, ll), + error = function(e) invisible(NULL) + ), + "deprecated", + ignore.case = TRUE + ) +}) + +test_that("loo_predictive_metric() is deprecated", { + LL <- example_loglik_matrix() + chain_id <- rep(1:2, each = nrow(LL) / 2) + r_eff <- relative_eff(exp(LL), chain_id) + x <- matrix(rnorm(length(LL)), nrow = nrow(LL), ncol = ncol(LL)) + y <- rnorm(ncol(LL)) + expect_deprecated( + loo_predictive_metric(x, y, LL, metric = "mae", r_eff = r_eff) + ) +}) diff --git a/tests/testthat/test_loo_moment_matching.R b/tests/testthat/test_loo_moment_matching.R index 1ea822ff..924d7f94 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_predictive_metric.R b/tests/testthat/test_loo_predictive_metric.R index d4f44d59..b17c99d1 100644 --- a/tests/testthat/test_loo_predictive_metric.R +++ b/tests/testthat/test_loo_predictive_metric.R @@ -11,6 +11,7 @@ x_prob <- 1 / (1 + exp(-x)) y <- rnorm(ncol(LL)) y_binary <- rbinom(ncol(LL), 1, 0.5) +suppressWarnings({ mae_mean <- loo_predictive_metric(x, y, LL, metric = 'mae', r_eff = r_eff) mae_quant <- loo_predictive_metric(x, y, LL, metric = 'mae', r_eff = r_eff, type = 'quantile', probs = 0.9) @@ -30,23 +31,24 @@ acc_quant <- loo_predictive_metric(x_prob, y_binary, LL, metric = 'acc', r_eff = bacc_mean <- loo_predictive_metric(x_prob, y_binary, LL, metric = 'balanced_acc', r_eff = r_eff) bacc_quant <- loo_predictive_metric(x_prob, y_binary, LL, metric = 'balanced_acc', r_eff = r_eff, type = 'quantile', probs = 0.9) +}) test_that('loo_predictive_metric stops with incorrect inputs', { - expect_error(loo_predictive_metric(as.character(x), y, LL, r_eff = r_eff), + expect_error(suppressWarnings(loo_predictive_metric(as.character(x), y, LL, r_eff = r_eff)), 'no applicable method', fixed = TRUE) - expect_error(loo_predictive_metric(x, as.character(y), LL, r_eff = r_eff), + expect_error(suppressWarnings(loo_predictive_metric(x, as.character(y), LL, r_eff = r_eff)), 'is.numeric(y) is not TRUE', fixed = TRUE) x_invalid <- matrix(rnorm(9), nrow = 3) - expect_error(loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff), + expect_error(suppressWarnings(loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff)), 'identical(ncol(x), length(y)) is not TRUE', fixed = TRUE) x_invalid <- matrix(rnorm(64), nrow = 2) - expect_error(loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff), + expect_error(suppressWarnings(loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff)), 'identical(dim(x), dim(log_lik)) is not TRUE', fixed = TRUE) }) 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 new file mode 100644 index 00000000..218424dc --- /dev/null +++ b/tests/testthat/test_pred_measure.R @@ -0,0 +1,625 @@ +# load data ----------------------------- +res <- readRDS("data-for-tests/test_data_roaches.Rds") +res_sleep_test <- readRDS("data-for-tests/test_data_sleep_cv.Rds") +n_test <- length(res_sleep_test$y_test) + +# unit tests ---------------------- +test_that("group_ids errors as not yet implemented", { + expect_error( + insample_pred_measure( + ylp = res$ylp, measures = "elpd", group_ids = rep(1:2, 131) + ), + "not yet implemented" + ) +}) + +## .compute_measure() -------------------- + +.builtin_entry <- function(name) { + list(name = name, type = "builtin", key = name) +} + +test_that(".compute_measure() with elpd works as expected", { + lppd_i <- .elpd_pointwise( + source = "insample", ylp = res$ylp, ylp_test = NULL, + log_weights = NULL, loo = NULL, kfold = NULL, predperf = NULL + ) + measure_res <- .compute_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = res$ylp, + measure_entry = .builtin_entry("elpd"), + log_weights = NULL, + lppd_i = lppd_i + ) + + expect_equal(names(measure_res), c("estimates", "pointwise")) + expect_equal(measure_res$estimates, measure_elpd(res$ylp)$estimates) +}) + +test_that(".compute_measure() with rps works as expected", { + measure_res <- .compute_measure( + y = res$y, + ypred = res$ypred, + mupred = NULL, + ylp = res$ylp, + measure_entry = .builtin_entry("rps"), + log_weights = NULL + ) + + expect_equal(names(measure_res), c("estimates", "pointwise")) + expect_equal(colnames(measure_res$estimates), c("Estimate", "SE")) +}) + +test_that(".compute_measure() fails if insufficient input is provided", { + expect_error( + .compute_measure( + y = res$y, + ypred = res$ypred, + mupred = NULL, + ylp = res$ylp, + measure_entry = .builtin_entry("r2"), + log_weights = NULL + ), + regexp = "`mupred` must be a numeric matrix." + ) +}) + +## .elpd_pointwise() ------------------------- + +.elpd_pw <- function(source, ylp = NULL, ylp_test = NULL, log_weights = NULL, + loo = NULL, kfold = NULL, predperf = NULL) { + .elpd_pointwise(source, ylp, ylp_test, log_weights, loo, kfold, predperf) +} + +test_that(".elpd_pointwise() reuses the elpd column of predperf", { + expect_equal( + .elpd_pw("insample", predperf = res$predperf), + res$predperf$pointwise[, "elpd"] + ) +}) + +test_that(".elpd_pointwise() takes elpd from loo and kfold objects", { + expect_equal( + .elpd_pw("loo", loo = res$loo), res$loo$pointwise[, "elpd_loo"] + ) + expect_equal( + .elpd_pw("kfold", kfold = res$kfold), res$kfold$pointwise[, "elpd_kfold"] + ) +}) + +test_that(".elpd_pointwise() computes elpd from ylp and ylp_test", { + expect_equal( + .elpd_pw("loo", ylp = res$ylp, + log_weights = res$loo$psis_object$log_weights), + res$loo$pointwise[, "elpd_loo"], + ignore_attr = TRUE + ) + expect_length( + .elpd_pw("test", ylp_test = res_sleep_test$ylp_test), n_test + ) +}) + +test_that(".elpd_pointwise() errors if the input is missing", { + expect_error(.elpd_pw("insample"), regexp = "`ylp` is required") + expect_error(.elpd_pw("test"), regexp = "`ylp_test` is required") + expect_error(.elpd_pw("kfold"), regexp = "not stored in") +}) + +## .get_psis_object() ------------------------- + +test_that(".get_psis_object() accepts loo and psis_object together", { + expect_identical( + .get_psis_object( + ylp = res$ylp, + loo = res$loo, + predperf = NULL, + psis_object = res$loo$psis_object + ), + res$loo$psis_object + ) +}) + +## .merge_matrix() --------------------------- + +test_that(".merge_matrix() works as expected", { + mat <- matrix(c(1, 2, 3, 4), ncol = 2, nrow = 2) + val <- c(5, 6) + expected_name <- "test" + + res <- .merge_matrix( + source = "insample", mat = mat, name = expected_name, + values = val, margin = 1 + ) + + expect_equal(rownames(res)[[3]], "test") + expect_equal(dim(res), c(3, 2)) + expect_equal(colnames(res), c("Estimate", "SE")) + + res <- .merge_matrix( + source = "insample", mat = mat, name = expected_name, + values = val, margin = 2 + ) + + expect_equal(dim(res), c(2, 3)) + expect_equal(colnames(res)[3], "test") +}) + +test_that(".merge_matrix() with mat = NULL works as expected", { + res <- .merge_matrix( + source = "insample", mat = NULL, name = "test", + values = c(1, 2), margin = 1 + ) + + expect_equal(rownames(res), "test") + expect_equal(colnames(res), c("Estimate", "SE")) + expect_equal(dim(res), c(1, 2)) +}) + +test_that(".merge_matrix() with loo showes correct names", { + res <- .merge_matrix( + source = "loo", mat = NULL, name = "test", + values = c(1, 2), margin = 1 + ) + + expect_equal(rownames(res), "test_loo") + expect_equal(colnames(res), c("Estimate", "SE")) + expect_equal(dim(res), c(1, 2)) +}) + +test_that(".merge_matrix() with kfold showes correct names", { + res <- .merge_matrix( + source = "kfold", mat = NULL, name = "test", + values = c(1, 2), margin = 1 + ) + + expect_equal(rownames(res), "test_kfold") + expect_equal(colnames(res), c("Estimate", "SE")) + expect_equal(dim(res), c(1, 2)) +}) + +test_that("duplicate measure on update warns once and keeps the results", { + predperf <- insample_pred_measure(ylp = res$ylp) + warnings <- character() + withCallingHandlers( + updated <- pred_measure( + ylp = res$ylp, predperf = predperf, measures = "elpd" + ), + warning = function(w) { + warnings <<- c(warnings, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ) + + expect_length(warnings, 1L) + expect_match(warnings[[1]], "already present in") + expect_equal(rownames(updated$estimates), "elpd") + expect_equal(colnames(updated$pointwise), "elpd") +}) + +# integration tests ------------------------------ +## loo_pred_measure() / pred_measure() / kfold_pred_measure() --------- + +test_that("control scaled = TRUE stores the result as srps, not rps", { + out <- insample_pred_measure( + y = res$y, + ypred = res$ypred, + ylp = res$ylp, + measures = "rps", + control = list(rps = list(scaled = TRUE)) + ) + + expect_true("srps" %in% rownames(out$estimates)) + expect_false("rps" %in% rownames(out$estimates)) + expect_true("srps" %in% colnames(out$pointwise)) +}) + +test_that("pred_measure() updates loo results as expected", { + predperf_loo <- loo_pred_measure( + loo = res$loo, + y = res$y, + mupred = res$mupred, + ylp = res$ylp, + measures = c("elpd", "r2", "mse"), + save_psis = TRUE + ) + + updated_predperf <- pred_measure( + y = res$y, + mupred = res$mupred, + predperf = predperf_loo, + measures = "mae" + ) + + expect_equal( + rownames(updated_predperf$estimates), + c("elpd_loo", "p_loo", "r2_loo", "mse_loo", "mae_loo") + ) + expect_equal(dim(updated_predperf$estimates), c(5, 2)) +}) + +test_that("loo_pred_measure() gives the same result for a 3-D ylp", { + LLarr <- example_loglik_array() + LLmat <- llarray_to_matrix(LLarr) + from_array <- suppressMessages(loo_pred_measure(ylp = LLarr, measures = "elpd")) + from_matrix <- suppressMessages(loo_pred_measure(ylp = LLmat, measures = "elpd")) + + expect_equal(from_array$estimates, from_matrix$estimates) + expect_equal(attr(from_array, "dims"), dim(LLmat)) +}) + +test_that("loo_pred_measure() warns once for a renamed custom measure", { + LLmat <- example_loglik_matrix() + f <- custom_measure(function(y, mupred) list(estimate = 1, se = 0, pointwise = y), + name = "my_metric") + warns <- capture_warnings(suppressMessages(loo_pred_measure( + y = rep(0, ncol(LLmat)), mupred = LLmat, ylp = LLmat, + measures = list(other = f) + ))) + expect_length(grep("was named", warns), 1) +}) + +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, + measures = c("elpd", "r2"), save_psis = TRUE + ) + updated <- pred_measure(predperf = predperf_loo, measures = "mlpd") + + expect_false(is.null(attr(updated, "dims"))) + expect_equal(attr(updated, "dims"), attr(predperf_loo, "dims")) +}) + +test_that("pred_measure() reuses stored log_weights when save_psis = FALSE", { + predperf_loo <- loo_pred_measure( + loo = res$loo, y = res$y, mupred = res$mupred, ylp = res$ylp, + measures = "r2" + ) + expect_null(predperf_loo$psis_object) + expect_false(is.null(predperf_loo$log_weights)) + + updated <- pred_measure( + y = res$y, mupred = res$mupred, predperf = predperf_loo, measures = "mae" + ) + expect_true("mae_loo" %in% rownames(updated$estimates)) +}) + +test_that("pred_measure() keeps element names when save_psis changes", { + predperf_loo <- loo_pred_measure( + loo = res$loo, y = res$y, mupred = res$mupred, measures = "r2" + ) + updated <- pred_measure( + y = res$y, mupred = res$mupred, predperf = predperf_loo, + measures = "mae", save_psis = TRUE + ) + expect_false(anyNA(names(updated))) + expect_true(is.matrix(updated$log_weights)) + expect_false(is.null(updated$psis_object)) +}) + +test_that("pred_measure() provides warning for duplicate measure", { + predperf_loo <- loo_pred_measure( + loo = res$loo, + y = res$y, + mupred = res$mupred, + ylp = res$ylp, + measures = "r2", + save_psis = TRUE + ) + + expect_warning( + pred_measure( + y = res$y, + mupred = res$mupred, + predperf = predperf_loo, + measures = "r2" + ), + regexp = "already present in .* and will be skipped" + ) + + expect_error( + loo_pred_measure( + y = res$y, + mupred = res$mupred, + ylp = res$ylp, + loo = res$loo, + measures = c("mse", "r2", "r2") + ), + regexp = "Duplicate measure" + ) +}) + +test_that("pred_measure() errors when predperf is not a pred_measure object", { + expect_error( + pred_measure(y = res$y, mupred = res$mupred, predperf = list()), + regexp = "must be a .*pred_measure.* object" + ) + expect_error( + pred_measure(y = res$y, mupred = res$mupred, predperf = 1), + regexp = "must be a .*pred_measure.* object" + ) +}) + +test_that("loo_pred_measure() computes expected measures", { + predperf1 <- loo_pred_measure( + loo = res$loo, + y = res$y, + mupred = res$mupred, + ylp = res$ylp, + measures = c("r2", "mse") + ) + + expect_equal( + rownames(predperf1$estimates), + c("r2_loo", "mse_loo") + ) + expect_equal(dim(predperf1$estimates), c(2, 2)) + expect_true(is.loo(predperf1)) +}) + +test_that("loo_pred_measure() has class 'loo' for all input patterns", { + predperf_loo <- loo_pred_measure( + loo = res$loo, + y = res$y, + ylp = res$ylp + ) + predperf_ylp_psis <- suppressMessages(loo_pred_measure( + ylp = res$ylp, + psis_object = res$loo$psis_object + )) + predperf_ylp <- suppressMessages(loo_pred_measure(ylp = res$ylp)) + + expect_true(is.loo(predperf_loo)) + expect_true(is.loo(predperf_ylp_psis)) + expect_true(is.loo(predperf_ylp)) + expect_true(is.psis_loo(predperf_loo)) + expect_false(is.psis_loo(predperf_ylp_psis)) + expect_false(is.psis_loo(predperf_ylp)) +}) + +test_that("do_pred_measure() warns if control args are invalid", { + expect_warning( + kfold_pred_measure( + y = res$y, + ypred = res$ypred, + mupred = res$mupred, + ylp = res$ylp, + measures = c("rps", "srps"), + kfold = res$kfold, + control = list( + rps = list(size = 10) + ) + ), + regexp = "Ignoring `size` as it is not a valid argument" + ) +}) + +test_that("kfold_pred_measure() requires kfold argument", { + expect_error( + kfold_pred_measure( + y = res$y, + mupred = res$mupred, + measures = "rmse" + ), + regexp = "`kfold` is required" + ) +}) + +test_that("kfold_pred_measure() works with rps as expected", { + kfold_res <- kfold_pred_measure( + y = res$y, + ypred = res$ypred, + mupred = res$mupred, + ylp = res$ylp, + measures = c("mlpd", "ic", "rps", "srps"), + kfold = res$kfold + ) + + expect_equal( + rownames(kfold_res$estimates), + c("mlpd_kfold", "ic_kfold", "rps_kfold", "srps_kfold") + ) +}) + +## test_pred_measure() ------------------------------------------------- + +test_that("test_pred_measure() computes holdout measures as expected", { + test_res <- test_pred_measure( + y = res_sleep_test$y_test, + ypred = res_sleep_test$ypred_test, + mupred = res_sleep_test$mupred_test, + ylp_test = res_sleep_test$ylp_test, + measures = c("elpd", "rmse", "r2") + ) + + expect_s3_class(test_res, "test_pred_measure") + expect_s3_class(test_res, "pred_measure") + expect_equal(attr(test_res, "source"), "test") + expect_equal( + rownames(test_res$estimates), + c("elpd_test", "rmse_test", "r2_test") + ) + expect_equal(dim(test_res$estimates), c(3, 2)) + expect_equal(attr(test_res, "dims"), c(400L, n_test)) + expect_equal(dim(test_res$pointwise), c(n_test, 3L)) +}) + +test_that("test_pred_measure() works with ylp_test only for base summary", { + test_res <- test_pred_measure( + y = res_sleep_test$y_test, + mupred = res_sleep_test$mupred_test, + ylp_test = res_sleep_test$ylp_test, + measures = c("elpd", "mae") + ) + + expect_equal(rownames(test_res$estimates), c("elpd_test", "mae_test")) + expect_equal(nrow(test_res$pointwise), length(res_sleep_test$y_test)) +}) + +test_that("pred_measure() updates test_pred_measure results as expected", { + test_res <- test_pred_measure( + y = res_sleep_test$y_test, + ypred = res_sleep_test$ypred_test, + mupred = res_sleep_test$mupred_test, + ylp_test = res_sleep_test$ylp_test, + measures = "rmse" + ) + + updated <- pred_measure( + y = res_sleep_test$y_test, + mupred = res_sleep_test$mupred_test, + predperf = test_res, + measures = "mae" + ) + + expect_equal(rownames(updated$estimates), c("rmse_test", "mae_test")) + expect_equal(attr(updated, "source"), "test") + expect_equal(dim(updated$pointwise), c(n_test, 2L)) +}) + +# pred_measure() with custom function ------------------------------ +test_that("insample_pred_measure() accepts a custom measure function", { + set.seed(42) + S <- 4L + n <- 8L + y <- rnorm(n) + mupred <- matrix(rnorm(S * n), nrow = S, ncol = n) + ylp <- matrix(rnorm(S * n), nrow = S, ncol = n) + + custom_rmse <- function(y, mupred, log_weights = NULL) { + measure_rmse(y, mupred, log_weights = log_weights) + } + attr(custom_rmse, "measure_name") <- "custom_rmse" + + res <- insample_pred_measure( + y = y, + mupred = mupred, + ylp = ylp, + measures = custom_rmse + ) + + expect_true("custom_rmse" %in% rownames(res$estimates)) + expect_true("custom_rmse" %in% colnames(res$pointwise)) +}) + +test_that("insample_pred_measure() accepts mixed built-in and custom measures", { + set.seed(1) + S <- 4L + n <- 8L + y <- rnorm(n) + mupred <- matrix(rnorm(S * n), nrow = S, ncol = n) + ylp <- matrix(rnorm(S * n), nrow = S, ncol = n) + + custom_rmse <- function(y, mupred, log_weights = NULL) { + measure_rmse(y, mupred, log_weights = log_weights) + } + attr(custom_rmse, "measure_name") <- "custom_rmse" + + res <- insample_pred_measure( + y = y, + mupred = mupred, + ylp = ylp, + measures = list("r2", custom_rmse = custom_rmse) + ) + + expect_true(all(c("r2", "custom_rmse") %in% rownames(res$estimates))) +}) + +## elpd on demand ------------------------------------------------------- + +test_that("measures = NULL reports elpd and p for every source", { + expect_equal(rownames(insample_pred_measure(ylp = res$ylp)$estimates), "elpd") + expect_equal( + rownames(loo_pred_measure(loo = res$loo)$estimates), c("elpd_loo", "p_loo") + ) + expect_equal( + rownames(kfold_pred_measure(kfold = res$kfold)$estimates), + c("elpd_kfold", "p_kfold") + ) + expect_equal( + rownames(test_pred_measure(ylp_test = res_sleep_test$ylp_test)$estimates), + "elpd_test" + ) +}) + +test_that("elpd and p from loo and kfold objects equal the object estimates", { + expect_equal( + loo_pred_measure(loo = res$loo)$estimates, + res$loo$estimates[c("elpd_loo", "p_loo"), ], + ignore_attr = TRUE + ) + expect_equal( + kfold_pred_measure(kfold = res$kfold)$estimates, + res$kfold$estimates[c("elpd_kfold", "p_kfold"), ], + ignore_attr = TRUE + ) +}) + +test_that("insample_pred_measure() does not need ylp without elpd", { + x <- insample_pred_measure(y = res$y, mupred = res$mupred, measures = "rmse") + expect_equal(rownames(x$estimates), "rmse") +}) + +test_that("loo_pred_measure() keeps diagnostics without elpd", { + x <- loo_pred_measure( + loo = res$loo, y = res$y, mupred = res$mupred, measures = "rmse" + ) + expect_equal(x$diagnostics$pareto_k, res$loo$diagnostics$pareto_k) +}) + +test_that("pred_measure() recomputes elpd for loo but aborts for kfold", { + loo_res <- loo_pred_measure( + loo = res$loo, y = res$y, mupred = res$mupred, measures = "r2", + save_psis = TRUE + ) + updated <- suppressMessages( + pred_measure(ylp = res$ylp, predperf = loo_res, measures = "ic") + ) + expect_equal(rownames(updated$estimates), c("r2_loo", "ic_loo")) + expect_equal( + updated$estimates["ic_loo", "Estimate"], + -2 * res$loo$estimates["elpd_loo", "Estimate"], + ignore_attr = TRUE + ) + + kfold_res <- kfold_pred_measure( + y = res$y, mupred = res$mupred, kfold = res$kfold, measures = "r2" + ) + expect_error( + pred_measure(ylp = res$ylp, predperf = kfold_res, measures = "ic"), + regexp = "not stored in" + ) +}) diff --git a/tests/testthat/test_pred_measure_builtin.R b/tests/testthat/test_pred_measure_builtin.R new file mode 100644 index 00000000..22c5ec4e --- /dev/null +++ b/tests/testthat/test_pred_measure_builtin.R @@ -0,0 +1,756 @@ +# load test data -------------------------------------- +path <- ""#"tests/testthat/" +res_roaches <- readRDS(paste0(path, "data-for-tests/test_data_roaches.Rds")) +res_sleep <- readRDS(paste0(path, "data-for-tests/test_data_sleep.Rds")) +res_binom <- readRDS(paste0(path, "data-for-tests/test_data_binomial.Rds")) +res_binary <- readRDS(paste0(path, "data-for-tests/test_data_binary.Rds")) +res_cat <- readRDS(paste0(path, "data-for-tests/test_data_penguins.Rds")) + +# ptw_log_pred_density ------------------------ +testthat::test_that("ptw_log_pred_density() works as expected", { + res <- ptw_log_pred_density(ylp = res_roaches$ylp, psis_log_weights = NULL) + + expect_equal(length(res), dim(res_roaches$ylp)[2]) + expect_equal(res, matrixStats::colLogSumExps(res_roaches$ylp) - log(dim(res_roaches$ylp)[1])) +}) + +testthat::test_that("ptw_log_pred_density() with psis_log_weights works as expected", { + norm_log_weights <- .normalize_log_weights(res_roaches$log_weights) + res <- ptw_log_pred_density( + ylp = res_roaches$ylp, + psis_log_weights = norm_log_weights + ) + + expect_equal(length(res), dim(res_roaches$ylp)[2]) + expect_equal(res, matrixStats::colLogSumExps(res_roaches$ylp + norm_log_weights) + ) +}) + +testthat::test_that("ptw_log_pred_density() returns error when weights are not normalized", { + expect_error( + ptw_log_pred_density( + ylp = res_roaches$ylp, + psis_log_weights = res_roaches$log_weights + ), + regexp = "Range of current column sums" + ) +}) + +# measure_elpd() ----------------------------------- + +testthat::test_that("measure_elpd() works as expected", { + res <- measure_elpd(ylp = res_roaches$ylp, log_weights = NULL) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates[1]), 1) + expect_equal(length(res$estimates[2]), 1) + expect_equal(length(res$pointwise), dim(res_roaches$ylp)[2]) + + expect_snapshot_output( + measure_elpd(ylp = res_roaches$ylp, log_weights = NULL) + ) +}) + +testthat::test_that("measure_elpd() with unnormalized log-weights works as expected", { + log_weights <- res_roaches$log_weights + res <- measure_elpd(ylp = res_roaches$ylp, log_weights = log_weights) + + expect_false(all(.normalize_log_weights(log_weights) == log_weights)) + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates[1]), 1) + expect_equal(length(res$estimates[2]), 1) + expect_equal(length(res$pointwise), dim(res_roaches$ylp)[2]) +}) + +testthat::test_that("measure_elpd() with normalized log-weights works as expected", { + log_weights <- .normalize_log_weights(res_roaches$log_weights) + res <- measure_elpd(ylp = res_roaches$ylp, log_weights = log_weights) + + expect_equal(.normalize_log_weights(log_weights), log_weights) + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates[1]), 1) + expect_equal(length(res$estimates[2]), 1) + expect_equal(length(res$pointwise), dim(res_roaches$ylp)[2]) + # measure_elpd() normalizes internally, so the result must not change + expect_equal( + res, + measure_elpd(ylp = res_roaches$ylp, log_weights = res_roaches$log_weights) + ) +}) + +# measure_ic() ----------------------------------- + +testthat::test_that("measure_ic() works as expected", { + res <- measure_ic(ylp = res_roaches$ylp) + n_obs <- dim(res_roaches$ylp)[2] + + expect_equal(names(res), c("estimates", "pointwise")) + expect_snapshot_output(measure_ic(ylp = res_roaches$ylp)) +}) + +# measure_mlpd() ----------------------------------- + +testthat::test_that("measure_mlpd() works as expected", { + res <- measure_mlpd(ylp = res_roaches$ylp, log_weights = NULL) + res_elpd <- measure_elpd(ylp = res_roaches$ylp, log_weights = NULL) + n_obs <- dim(res_roaches$ylp)[2] + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates[1]), 1) + expect_equal(length(res$estimates[2]), 1) + expect_equal(length(res$pointwise), n_obs) + expect_equal(unname(res$estimates), unname(res_elpd$estimates) / n_obs) + expect_equal(unname(res$pointwise), unname(res_elpd$pointwise)) + + expect_snapshot_output(measure_mlpd(ylp = res_roaches$ylp, log_weights = NULL)) +}) + +testthat::test_that("measure_mlpd() with pointwise works as expected", { + res_elpd <- measure_elpd(ylp = res_roaches$ylp, log_weights = NULL) + res <- measure_mlpd(ylp = NULL, pointwise = res_elpd$pointwise[ ,"elpd"]) + + n_obs <- dim(res_roaches$ylp)[2] + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates[1]), 1) + expect_equal(length(res$estimates[2]), 1) + expect_equal(length(res$pointwise), n_obs) + expect_equal(unname(res$estimates), unname(res_elpd$estimates) / n_obs) + expect_equal(unname(res$pointwise), unname(res_elpd$pointwise)) + + expect_snapshot_output(measure_mlpd(ylp = NULL, pointwise = res_elpd$pointwise[ ,"elpd"])) +}) + +# measure_rps() ------------------------------------- + +testthat::test_that("measure_rps() with ordered categorial data works as expected", { + res <- measure_rps( + y = res_binom$y, + ypred = res_binom$ypred + ) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_binom$y)) + + expect_snapshot_output(measure_rps(y = res_binom$y, ypred = res_binom$ypred)) +}) + +testthat::test_that("measure_rps() scaled version with categorical data works as expected", { + res <- measure_rps( + y = res_binom$y, + ypred = res_binom$ypred, + scaled = TRUE + ) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_binom$y)) + expect_true(all(res$pointwise < 0)) + + expect_snapshot_output(measure_srps(y = res_binom$y, ypred = res_binom$ypred)) +}) + +testthat::test_that("measure_rps() for categorical data with log-weights works as expected", { + res <- measure_rps( + y = res_binom$y, + ypred = res_binom$ypred, + log_weights = res_binom$log_weights + ) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_binary$y)) + expect_true(all(res$pointwise >= 0)) +}) + +testthat::test_that("measure_rps() validates the shape of log_weights", { + bad_log_weights <- res_binom$log_weights[, -1, drop = FALSE] + expect_error( + measure_rps( + y = res_binom$y, + ypred = res_binom$ypred, + log_weights = bad_log_weights + ), + regexp = "`log_weights` must have" + ) +}) + +testthat::test_that("measure_rps() with continuous data works as expected", { + res <- measure_rps(res_sleep$y, res_sleep$ypred) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_sleep$y)) + + expect_snapshot_output(measure_rps(res_sleep$y, res_sleep$ypred)) +}) + +testthat::test_that("measure_rps() with continuous data and log-weights works as expected", { + res <- measure_rps( + res_sleep$y, + res_sleep$ypred, + log_weights = res_sleep$log_weights + ) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_sleep$y)) +}) + +testthat::test_that("measure_rps() with continuous data and scaled version works as expected", { + res <- measure_rps(res_sleep$y, res_sleep$ypred, scaled = TRUE) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_sleep$y)) + 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() --------------------------------------- + +testthat::test_that("measure_brier() works as expected", { + res_brier <- measure_brier(y = res_binary$y, ypred = res_binary$ypred, log_weights = NULL) + + expect_equal(names(res_brier), c("estimates", "pointwise")) + expect_equal(length(res_brier$estimates), 2) + expect_equal(length(res_brier$pointwise), length(res_binary$y)) + expect_true(all(res_brier$pointwise >= 0 & res_brier$pointwise <= 1)) + + expect_snapshot_output(measure_brier(y = res_binary$y, ypred = res_binary$ypred)) +}) + +testthat::test_that("measure_brier() rejects out-of-range ypred", { + bad_ypred <- res_binary$ypred + bad_ypred[1, 1] <- 1.5 + expect_error( + measure_brier(y = res_binary$y, ypred = bad_ypred), + regexp = "`ypred` must contain values in \\[0, 1\\]" + ) +}) + +testthat::test_that("measure_brier() with log-weights works as expected", { + res_brier <- measure_brier( + y = res_binary$y, + ypred = res_binary$ypred, + log_weights = res_binary$log_weights + ) + + expect_equal(names(res_brier), c("estimates", "pointwise")) + expect_equal(length(res_brier$estimates), 2) + expect_equal(length(res_brier$pointwise), length(res_binary$y)) + expect_true(all(res_brier$pointwise >= 0 & res_brier$pointwise <= 1)) + + res_brier2 <- measure_brier( + y = res_binary$y, + ypred = res_binary$ypred, + log_weights = .normalize_log_weights(res_binary$log_weights) + ) + expect_equal(res_brier2$pointwise, res_brier$pointwise) +}) + +testthat::test_that("measure_brier() errors when y not binary", { + expect_error( + measure_brier( + y = res_binom$y, + ypred = res_binary$ypred, + log_weights = res_binary$log_weights + ), + regexp = "The brier score expects binary data 'y'." + ) +}) + +# measure_mae() ------------------------------------------------ +testthat::test_that("measure_mae() works as expected", { + res <- measure_mae(y = res_roaches$y, mupred = res_roaches$mupred, + log_weights = NULL) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_roaches$y)) + + expect_snapshot_output(measure_mae(y = res_roaches$y, mupred = res_roaches$mupred)) +}) + +testthat::test_that("measure_mae() with log_weights works as expected", { + res <- measure_mae(y = res_roaches$y, mupred = res_roaches$mupred, + log_weights = res_roaches$log_weights) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_roaches$y)) +}) + +testthat::test_that("measure_mae() checks log_weights size for vector mupred", { + expect_error( + suppressMessages(measure_mae( + y = res_roaches$y, + mupred = colMeans(res_roaches$mupred), + log_weights = res_roaches$log_weights + )), + "must have 1 row" + ) +}) + +# measure_rmse() / measure_mse() ----------------------------------------- +testthat::test_that("measure_mse() and measure_rmse() work as expected", { + res_mse <- measure_mse(y = res_roaches$y, mupred = res_roaches$mupred, + log_weights = NULL) + + res_rmse <- measure_rmse(y = res_roaches$y, mupred = res_roaches$mupred, + log_weights = NULL) + + expect_equal(names(res_mse), c("estimates", "pointwise")) + expect_equal(length(res_mse$estimates), 2) + expect_equal(length(res_mse$pointwise), length(res_roaches$y)) + + expect_equal(sqrt(abs(res_mse$estimates[1])), res_rmse$estimates[1]) + expect_equal(res_mse$estimates[2]/(2*sqrt(abs(res_mse$estimates[1]))), + res_rmse$estimates[2]) + + expect_snapshot_output(measure_mse(y = res_roaches$y, mupred = res_roaches$mupred)) + expect_snapshot_output(measure_rmse(y = res_roaches$y, mupred = res_roaches$mupred)) +}) + +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"] + ) + + # 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"] + ) +}) + +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)) +}) + +testthat::test_that("measure_rmse() works with se=0", { + mupred0 <- t(replicate(4000, res_roaches$y)) + + res_rmse <- measure_rmse(y = res_roaches$y, mupred = mupred0, + log_weights = NULL) + + expect_equal(names(res_rmse), c("estimates", "pointwise")) + expect_equal(length(res_rmse$estimates), 2) + expect_equal(length(res_rmse$pointwise), length(res_roaches$y)) + expect_equal(unname(res_rmse$estimates[2]), 0) +}) + +# measure_r2() --------------------------------------------------- +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", "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)) + + expect_snapshot_output(measure_r2(y = res_roaches$y, mupred = res_roaches$mupred)) +}) + +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", "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)) +}) + +# measure_acc() / measure_bacc() ----------------------------------------------------- +testthat::skip_if_not_installed("brms") + +testthat::test_that("measure_acc() works as expected", { + res <- measure_acc(y = as.integer(res_cat$y), mupred = res_cat$mupred, log_weights = NULL) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_cat$y)) + expect_true(all(res$pointwise >= 0 & res$pointwise <= 1)) + + expect_snapshot_output(measure_acc(y = as.integer(res_cat$y), mupred = res_cat$mupred)) +}) + +testthat::test_that("measure_acc() rejects out-of-range mupred", { + bad_mupred <- res_cat$mupred + bad_mupred[1, 1, 1] <- -0.1 + expect_error( + measure_acc(y = as.integer(res_cat$y), mupred = bad_mupred), + regexp = "`mupred` must contain values in \\[0, 1\\]" + ) +}) + +testthat::test_that("measure_acc() and measure_bacc() reject y coded unlike mupred", { + mupred <- matrix(c(0.8, 0.3, 0.7, 0.6, 0.4, 0.9), nrow = 2) + expect_error( + measure_acc(y = c(2L, 1L, 2L), mupred = mupred), + regexp = "does not match the coding" + ) + y0 <- as.integer(res_cat$y) - 1L + expect_error( + measure_acc(y = y0, mupred = res_cat$mupred), + regexp = "does not match the coding" + ) + expect_error( + measure_bacc(y = y0, mupred = res_cat$mupred), + regexp = "does not match the coding" + ) +}) + + +testthat::test_that("measure_acc() with log-weights works as expected", { + res <- measure_acc( + y = as.integer(res_cat$y), + mupred = res_cat$mupred, + log_weights = res_cat$log_weights + ) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_cat$y)) + expect_true(!all(res$pointwise < 0 | res$pointwise > 1)) +}) + +testthat::test_that("measure_acc() broadcasts weights over categories without warning", { + y <- as.integer(res_cat$y) + lw <- res_cat$log_weights + + expect_no_warning(res <- measure_acc( + y = y, mupred = res_cat$mupred, log_weights = lw + )) + expect_no_warning(measure_bacc( + y = y, mupred = res_cat$mupred, log_weights = lw + )) + + w <- exp(.normalize_log_weights(lw)) + n_cat <- dim(res_cat$mupred)[3] + manual <- vapply( + seq_len(n_cat), + function(k) colSums(w * res_cat$mupred[, , k]), + numeric(length(y)) + ) + expect_equal(as.numeric(res$pointwise), (apply(manual, 1, which.max) == y) * 1) +}) + +testthat::test_that("measure_bacc() pointwise contributions sum to estimate", { + y <- c(1L, 1L, 2L, 2L) + mupred <- array( + c(0.8, 0.2, 0.7, 0.3, 0.3, 0.7, 0.2, 0.8), + dim = c(1, 4, 2) + ) + res <- measure_bacc(y, mupred) + + classes <- sort(unique(y)) + K <- length(classes) + weights <- rep(1 / nrow(mupred), nrow(mupred)) + weighted_mupred <- apply(sweep(mupred, 1, weights, `*`), c(2, 3), sum) + mupred_hat <- apply(weighted_mupred, 1, which.max) + acc_i <- (mupred_hat == y) * 1L + n_c <- tabulate(match(y, classes)) + expected_bacc_i <- acc_i / (K * n_c[match(y, classes)]) + + expect_equal(as.numeric(res$pointwise), expected_bacc_i) + expect_equal(sum(as.numeric(res$pointwise)), unname(res$estimates[1, "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", "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)) + + expect_snapshot_output(measure_bacc(y = as.integer(res_cat$y), mupred = res_cat$mupred)) +}) + +testthat::test_that("measure_bacc() accepts precomputed pointwise values", { + y <- c(1L, 1L, 2L, 2L) + acc_i <- c(1L, 0L, 1L, 1L) + res <- measure_bacc(y = y, mupred = NULL, pointwise = acc_i / 4) + + expect_equal(unname(res$estimates[1, "Estimate"]), 0.75) + expect_equal(as.numeric(res$pointwise), acc_i / 4) + expect_error( + measure_bacc(y = y, mupred = NULL, pointwise = acc_i[-1]), + regexp = "must have the same length" + ) +}) + +testthat::test_that("mlpd and ic count draws after the 3-D conversion", { + LLarr <- example_loglik_array() + dims_elpd <- attr(measure_elpd(LLarr), "dims") + + expect_equal(attr(measure_mlpd(LLarr), "dims"), dims_elpd) + expect_equal(attr(measure_ic(LLarr), "dims"), dims_elpd) +}) + +testthat::test_that("measure_bacc() rejects out-of-range mupred", { + bad_mupred <- res_cat$mupred + bad_mupred[1, 1, 1] <- 1.2 + expect_error( + measure_bacc(y = as.integer(res_cat$y), mupred = bad_mupred), + regexp = "`mupred` must contain values in \\[0, 1\\]" + ) +}) + +testthat::test_that("measure_bacc() with log-weights works as expected", { + res <- measure_bacc( + y = as.integer(res_cat$y), + mupred = res_cat$mupred, + log_weights = res_cat$log_weights + ) + + 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)) +}) + +# mlpd / ic derived from elpd ------------------------ +testthat::test_that("mlpd and ic keep the sign of a positive pointwise lppd", { + # lppd_i is a log density and is positive for concentrated predictions. + set.seed(1) + S <- 200 + n <- 30 + y <- rnorm(n, 0, 0.05) + mu <- matrix(rnorm(S * n, 0, 0.01), S, n) + ylp <- t(sapply(1:S, function(s) dnorm(y, mu[s, ], 0.05, log = TRUE))) + lppd <- matrixStats::colLogSumExps(ylp) - log(S) + + # the removed heuristic negated every entry as soon as one was positive + expect_true(any(lppd > 0)) + expect_true(any(lppd < 0)) + + res <- insample_pred_measure(ylp = ylp, measures = c("elpd", "mlpd", "ic")) + + expect_equal(unname(res$estimates["mlpd", 1]), mean(lppd)) + expect_equal(unname(res$estimates["ic", 1]), sum(-2 * lppd)) + expect_equal(unname(res$pointwise[, "mlpd"]), unname(lppd)) + expect_equal(unname(res$pointwise[, "ic"]), unname(-2 * lppd)) + expect_equal(cor(res$pointwise[, "elpd"], res$pointwise[, "mlpd"]), 1) +}) + +testthat::test_that("mlpd on the test source uses ylp_test, not ylp", { + set.seed(2) + S <- 100 + ylp <- matrix(rnorm(S * 20, -1, 0.1), S, 20) + ylp_test <- matrix(rnorm(S * 8, -5, 0.1), S, 8) + lppd_test <- matrixStats::colLogSumExps(ylp_test) - log(S) + + res <- test_pred_measure(ylp = ylp, ylp_test = ylp_test, measures = "mlpd") + + expect_equal(unname(res$estimates["mlpd_test", 1]), mean(lppd_test)) + expect_equal(unname(res$pointwise[, "mlpd_test"]), unname(lppd_test)) +}) + +testthat::test_that("mlpd and ic work when only a loo object is given", { + LL <- example_loglik_matrix() + lo <- suppressWarnings( + loo(LL, save_psis = TRUE, r_eff = rep(1, ncol(LL))) + ) + + res <- loo_pred_measure(loo = lo, measures = c("mlpd", "ic")) + + elpd_loo_i <- lo$pointwise[, "elpd_loo"] + expect_equal(unname(res$estimates["mlpd_loo", 1]), mean(elpd_loo_i)) + expect_equal(unname(res$estimates["ic_loo", 1]), sum(-2 * elpd_loo_i)) +}) + +# .exx_pwm ------------------------ +testthat::test_that(".exx_pwm() reduces to the classic unbiased PWM estimator", { + set.seed(3) + S <- 500 + x <- matrix(rnorm(S * 6), S, 6) + ref <- colMeans(apply(x, 2, sort) * (2 * (2 * seq_len(S) - S - 1) / (S - 1))) + + expect_equal(.exx_pwm(x), ref) + expect_equal(.exx_pwm(x, matrix(1 / S, S, 6)), .exx_pwm(x)) +}) + +testthat::test_that(".exx_pwm() stays non-negative under concentrated weights", { + # E|X - X'| is non-negative by definition. The previous inline estimator + # divided by (1 - w) and drove the estimate negative when one draw dominated, + # which made log(EXX) in srps NaN. + set.seed(4) + S <- 200 + x <- matrix(rgamma(S * 4, 2, 1), S, 4) + lw <- matrix(0, S, 4) + lw[1, ] <- 8 # one draw carries most, but not all, of the weight + w <- exp(.normalize_log_weights(lw)) + expect_gt(max(w), 0.9) + + EXX <- .exx_pwm(x, w) + expect_true(all(EXX > 0)) + expect_true(all(is.finite(EXX))) + + srps <- measure_rps(y = colMeans(x), ypred = x, log_weights = lw, scaled = TRUE) + expect_true(all(is.finite(srps$pointwise))) +}) + +testthat::test_that("the scaled score aborts on a point-mass predictive", { + # All the weight on one draw makes E|X - X'| exactly 0, so the scaling term + # log(E|X - X'|) is undefined. The unscaled score stays well defined. + set.seed(5) + S <- 100 + x <- matrix(rgamma(S * 3, 2, 1), S, 3) + lw <- matrix(0, S, 3) + lw[1, ] <- 60 + y <- colMeans(x) + + expect_equal(.exx_pwm(x, exp(.normalize_log_weights(lw))), rep(0, 3)) + expect_error( + measure_rps(y = y, ypred = x, log_weights = lw, scaled = TRUE), + "point mass" + ) + expect_true(all(is.finite( + measure_rps(y = y, ypred = x, log_weights = lw)$pointwise + ))) +}) + +testthat::test_that(".exx_pwm() requires at least two draws", { + expect_error(.exx_pwm(matrix(1, 1, 3)), "at least 2 draws") +}) diff --git a/tests/testthat/test_pred_measure_helpers.R b/tests/testthat/test_pred_measure_helpers.R new file mode 100644 index 00000000..3b7f81d8 --- /dev/null +++ b/tests/testthat/test_pred_measure_helpers.R @@ -0,0 +1,386 @@ +# load data ----------------------------- +res <- readRDS("data-for-tests/test_data_roaches.Rds") + +supported_measures_list <- getFromNamespace("supported_measures_list", "loo") + +# helpers for tests ------------------------------------------------ +.builtin_entry <- function(name) { + list(name = name, type = "builtin", key = name) +} + +# .normalize_measure() ---------------------------------------------- + +test_that(".normalize_measure() handles NULL and character input", { + expect_equal(.normalize_measure(NULL), list()) + entries <- .normalize_measure(c("mse", "rps")) + expect_length(entries, 2) + expect_equal(entries[[1]], .builtin_entry("mse")) +}) + +test_that(".normalize_measure() handles a custom function", { + f <- function(y, mupred) list(estimate = 1, se = 0, pointwise = y) + attr(f, "measure_name") <- "custom_mae" + entries <- .normalize_measure(f) + expect_length(entries, 1) + expect_equal(entries[[1]]$type, "custom") + expect_equal(entries[[1]]$name, "custom_mae") +}) + +test_that(".normalize_measure() handles a mixed list", { + f <- function(y, mupred) list(estimate = 1, se = 0, pointwise = y) + attr(f, "measure_name") <- "custom_mae" + entries <- .normalize_measure(list("r2", custom_mae = f)) + expect_length(entries, 2) + expect_equal(entries[[1]]$name, "r2") + 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")), + regexp = "Duplicate measure" + ) +}) + +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 = "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() ----------------------------------------------- + +test_that(".prepare_measures() errors on invalid built-in names", { + expect_error( + .prepare_measures( + "pps", res$predperf, supported_measures_list, source = "insample" + ), + regexp = "Invalid measure" + ) +}) + +test_that(".prepare_measures() filters measures already in predperf", { + expect_warning( + .prepare_measures( + c("mse", "elpd"), predperf = res$predperf, + supported_measures_list, source = "insample" + ), + regexp = "already present in" + ) + + expect_warning( + .prepare_measures( + c("mse", "elpd", "r2"), predperf = res$predperf, + supported_measures_list, source = "insample" + ), + regexp = "already present in" + ) + + entries <- .prepare_measures( + c("mse", "rps"), predperf = res$predperf, + supported_measures_list, source = "insample" + ) + expect_equal(vapply(entries, `[[`, "", "name"), c("mse", "rps")) + + entries <- .prepare_measures( + c("mse"), predperf = res$predperf, + supported_measures_list, source = "insample" + ) + expect_equal(vapply(entries, `[[`, "", "name"), "mse") +}) + +test_that(".prepare_measures() defaults to elpd for a new result only", { + entries <- .prepare_measures(NULL, NULL, supported_measures_list, "insample") + expect_equal(vapply(entries, `[[`, "", "key"), "elpd") + expect_length( + .prepare_measures(NULL, res$predperf, supported_measures_list, "insample"), + 0L + ) +}) + +# .any_needs_elpd() ------------------------------------------------- + +test_that(".any_needs_elpd() detects measures derived from elpd", { + entry <- function(k) list(name = k, type = "builtin", key = k) + custom <- list(name = "my_fun", type = "custom", key = function(...) NULL) + + expect_true(.any_needs_elpd(list(entry("rmse"), entry("mlpd")))) + expect_true(.any_needs_elpd(list(entry("elpd")))) + expect_false(.any_needs_elpd(list(entry("rmse"), custom))) + expect_false(.any_needs_elpd(list())) +}) + +# .validate_measure_result() ---------------------------------------- + +test_that(".validate_measure_result() accepts standard and CRPS-style output", { + res_std <- list(estimate = 1, se = 0.1, pointwise = c(1, 2)) + expect_invisible(.validate_measure_result(res_std, "m", n_obs = 2)) + + res_crps <- list(estimates = c(1, 0.1), pointwise = c(1, 2)) + expect_invisible(.validate_measure_result(res_crps, "m", n_obs = 2)) +}) + +test_that(".validate_measure_result() errors on invalid output", { + expect_error( + .validate_measure_result(list(estimate = 1), "m"), + regexp = "Missing" + ) + expect_error( + .validate_measure_result( + list(estimate = 1, se = 0.1, pointwise = c(1, 2, 3)), + "m", + n_obs = 2 + ), + regexp = "length 2, not 3" + ) +}) + +# .validate_control() --------------------------------------- + +test_that(".validate_control() accepts valid control silently", { + expect_invisible(.validate_control(list())) + expect_invisible(.validate_control(list(rps = list()))) + expect_invisible(.validate_control(list(rps = list(scaled = TRUE)))) + expect_invisible(.validate_control(list( + rps = list(scaled = TRUE), + srps = list(pointwise = NULL) + ))) +}) + +test_that(".validate_control() warns on invalid measure args", { + expect_warning( + .validate_control(list(rps = list(size = 10))), + regexp = "Ignoring `size` as it is not a valid argument" + ) + + expect_warning( + .validate_control(list(rps = list(foo = 1, bar = 2))), + regexp = "Ignoring `foo` and `bar` as it is not a valid argument" + ) + + expect_warning( + .validate_control(list(rps = list(scaled = TRUE, bad = 1))), + regexp = "Ignoring `bad` as it is not a valid argument" + ) + + expect_warning( + expect_warning( + .validate_control(list(rps = list(foo = 1), mse = list(bar = 2))), + regexp = "Ignoring `foo` as it is not a valid argument" + ), + regexp = "Ignoring `bar` as it is not a valid argument" + ) +}) + +test_that(".validate_control() errors on malformed control", { + expect_error( + .validate_control("rps"), + regexp = "must be a named list of named lists." + ) + expect_error( + .validate_control(list(list(scaled = TRUE))), + regexp = "must be a named list of named lists." + ) + expect_error( + .validate_control(list(rps = c(scaled = TRUE))), + regexp = "must be a named list of named lists." + ) +}) + +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" + ) +}) + +# .validate_probs() ----------------------------------------- + +test_that(".validate_probs() accepts values in [0, 1]", { + expect_invisible(.validate_probs(c(0, 0.5, 1), "x")) + expect_invisible(.validate_probs(matrix(c(0.2, 0.8), nrow = 1), "x")) +}) + +test_that(".validate_probs() rejects out-of-range values", { + expect_error( + .validate_probs(c(-0.1, 0.5), "mupred"), + regexp = "`mupred` must contain values in \\[0, 1\\]" + ) + expect_error( + .validate_probs(c(0.5, 1.1), "ypred"), + regexp = "`ypred` must contain values in \\[0, 1\\]" + ) +}) + +# subset_measures() ----------------------------------------- + +.make_measure_result <- function() { + list( + estimates = matrix( + 1:4, 2, 2, + dimnames = list(c("a", "b"), c("Estimate", "SE")) + ), + pointwise = matrix( + 1:6, 3, 2, + dimnames = list(NULL, c("a", "b")) + ), + diagnostics = list(pareto_k = c(0.1, 0.2, 0.3)), + psis_object = list(foo = 1) + ) +} + +test_that("subset_measures() subsets kfold and loo base measures", { + kfold_sub <- subset_measures( + res$kfold, + measures = c("elpd_kfold", "p_kfold"), + components = c("estimates", "pointwise") + ) + expect_equal(names(kfold_sub), c("estimates", "pointwise")) + expect_equal(rownames(kfold_sub$estimates), c("elpd_kfold", "p_kfold")) + expect_equal(colnames(kfold_sub$pointwise), c("elpd_kfold", "p_kfold")) + + loo_sub <- subset_measures( + res$loo, + measures = c("elpd_loo", "p_loo"), + components = c("estimates", "pointwise", "diagnostics") + ) + expect_equal(names(loo_sub), c("estimates", "pointwise", "diagnostics")) + expect_equal(rownames(loo_sub$estimates), c("elpd_loo", "p_loo")) + expect_equal(colnames(loo_sub$pointwise), c("elpd_loo", "p_loo")) + expect_identical(loo_sub$diagnostics, res$loo$diagnostics) +}) + +test_that("subset_measures() respects components argument", { + x <- .make_measure_result() + + estimates_only <- subset_measures(x, measures = c("a", "b"), components = "estimates") + expect_equal(names(estimates_only), "estimates") + expect_equal(rownames(estimates_only$estimates), c("a", "b")) + + pointwise_only <- subset_measures(x, measures = "a", components = "pointwise") + expect_equal(names(pointwise_only), "pointwise") + expect_equal(colnames(pointwise_only$pointwise), "a") + + diagnostics_only <- subset_measures(x, measures = "a", components = "diagnostics") + expect_equal(names(diagnostics_only), "diagnostics") + expect_identical(diagnostics_only$diagnostics, x$diagnostics) +}) + +test_that("subset_measures() drops unknown measures and components", { + x <- .make_measure_result() + + expect_error( + subset_measures( + x, + measures = c("a", "missing", "b"), + components = c("estimates", "pointwise") + ), + regexp = "contains invalid value:" + ) + + expect_error( + subset_measures( + x, + measures = c("a", "b"), + components = c("estimates", "pointwise", "measure") + ), + regexp = "contains invalid value:" + ) + + empty_measures <- subset_measures( + x, + measures = character(0), + components = c("estimates", "pointwise") + ) + expect_equal(dim(empty_measures$estimates), c(0, 2)) + expect_equal(dim(empty_measures$pointwise), c(3, 0)) +}) + +test_that("subset_measures() preserves requested measure order", { + x <- .make_measure_result() + + sub <- subset_measures( + x, + measures = c("b", "a"), + components = c("estimates", "pointwise") + ) + + expect_equal(rownames(sub$estimates), c("b", "a")) + expect_equal(colnames(sub$pointwise), c("b", "a")) +}) \ No newline at end of file diff --git a/tests/testthat/test_print.R b/tests/testthat/test_print.R new file mode 100644 index 00000000..e3a58fc0 --- /dev/null +++ b/tests/testthat/test_print.R @@ -0,0 +1,136 @@ +# load data +temp <- readRDS("data-for-tests/test_data_roaches.Rds") + +measure_specs <- function(temp) { + list( + list(measure = "r2", args = list(y = temp$y, mupred = temp$mupred)), + list(measure = "rmse", args = list(y = temp$y, mupred = temp$mupred)), + list(measure = "mse", args = list(y = temp$y, mupred = temp$mupred)), + list(measure = "mae", args = list(y = temp$y, mupred = temp$mupred)), + list(measure = "rps", args = list(y = temp$y, ypred = temp$ypred)), + list(measure = "srps", args = list(y = temp$y, ypred = temp$ypred)), + list(measure = "mlpd", args = list(ylp = temp$ylp)) + ) +} + +run_measure_snapshots <- function(loo_start, measures) { + loo_iter <- loo_start + for (i in seq_along(measures)) { + measure <- measures[[i]] + loo_prev <- loo_iter + call_args <- c( + measure$args, + list( + measures = measure$measure, + save_psis = TRUE + ) + ) + if (!is.null(measure$control)) { + call_args$control <- measure$control + } + if (i == 1L) { + call_args$loo <- loo_iter + loo_iter <- do.call(loo_pred_measure, call_args) + } else { + call_args$predperf <- loo_iter + loo_iter <- do.call(pred_measure, call_args) + } + common_rows <- intersect( + rownames(loo_prev$estimates), + rownames(loo_iter$estimates) + ) + common_cols <- intersect( + colnames(loo_prev$pointwise), + colnames(loo_iter$pointwise) + ) + expect_equal( + loo_iter$estimates[common_rows, , drop = FALSE], + loo_prev$estimates[common_rows, , drop = FALSE], + info = measure$measure + ) + expect_equal( + loo_iter$pointwise[, common_cols, drop = FALSE], + loo_prev$pointwise[, common_cols, drop = FALSE], + info = measure$measure + ) + expect_snapshot_output(print(loo_iter)) + } + loo_iter +} + +test_that("loo_pred_measure print snapshots", { + loo_ordered <- run_measure_snapshots(temp$loo, measure_specs(temp)) + loo_shuffled <- run_measure_snapshots( + temp$loo, + with(set.seed(0), sample(measure_specs(temp))) + ) + expect_setequal( + rownames(loo_ordered$estimates), + rownames(loo_shuffled$estimates) + ) + expect_equal( + loo_ordered$estimates[rownames(loo_shuffled$estimates), , drop = FALSE], + loo_shuffled$estimates + ) +}) + +test_that("loo_pred_measure print output with elpd", { + x <- loo_pred_measure( + loo = temp$loo, + y = temp$y, + mupred = temp$mupred, + measures = c("elpd", "r2") + ) + expect_snapshot_output(print(x)) +}) + +test_that("test_pred_measure print output", { + res <- readRDS("data-for-tests/test_data_sleep_cv.Rds") + x <- test_pred_measure( + y = res$y_test, + ypred = res$ypred_test, + mupred = res$mupred_test, + ylp_test = res$ylp_test, + measures = c("rmse", "r2") + ) + expect_s3_class(x, "test_pred_measure") + expect_snapshot_output(print(x)) +}) + +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..08f7c146 --- /dev/null +++ b/vignettes/articles-online-only/model-comparison.Rmd @@ -0,0 +1,724 @@ +--- +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 [Predictive model performance: Overview of measures](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 + +- [Predictive model performance: Predictive schemes with `pred_measure()`](pred-measure-workflow.html) +- [Predictive model performance: Overview of measures](overview-measures.html) +- `?"loo-glossary"` +- [Predictive measures: A formula reference]() \ No newline at end of file diff --git a/vignettes/articles-online-only/overview-measures.Rmd b/vignettes/articles-online-only/overview-measures.Rmd new file mode 100644 index 00000000..3ab3b0c0 --- /dev/null +++ b/vignettes/articles-online-only/overview-measures.Rmd @@ -0,0 +1,898 @@ +--- +title: "Predictive model performance: Overview of measures" +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{Predictive model performance: Overview of measures} + %\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 = FALSE, + warning = FALSE, + eval = params$EVAL, + fig.width = 7, + fig.height = 4, + fig.align = "center" +) +``` + +```{r, child="../children/LOAD-BRMS-GITHUB.txt", eval=params$EVAL} +``` + +## Introduction + +A *predictive measure* summarizes how well a model predicts data. **loo** +provides twelve built-in measures and the possibility to create a custom +measure. Each built-in measure has its own `measure_*()` function. + +This vignette introduces each built-in measure. For each measure it gives: + +1. the motivation, +2. when to use it, +3. the key formula, +4. the standard error, +5. the implementation in **loo**, and +6. a plot and its interpretation, comparing a model with predictors to an intercept-only model. + +This vignette states only the key formulas. The full definitions, the +estimators, and the standard errors are in our supplement +(Vehtari et al., 2026). + +This vignette hides the code for the plots. The full source code is in the +[`loo` GitHub repository](https://github.com/stan-dev/loo/blob/master/vignettes/articles-online-only/overview-measures.Rmd). + +::: {.callout .callout-note} +**What this vignette does not cover** + ++ **Predictive schemes** + + Examples in this vignette use in-sample predictions. + + All measures can be used with leave-one-out, K-fold, or test-data predictions; see [Predictive model performance: Predictive schemes with `pred_measure()`](pred-measure-workflow.html). ++ **Model comparison** + + Using the `model_compare()` function; see [Model comparison: Explanation of `model_compare()`](model-comparison.html). + + A tutorial on using model comparison within the Bayesian workflow; see [Model comparison: Case Study with `model_compare()`]() +::: + +## Overview of built-in measures + +| Keyword | Measure | Family | Input | Outcome | Natural scale | Aggregation | +| :--- | :--- | :--- | :--- | :--- | :--- | :--- | +| `elpd` | expected log pointwise predictive density | [log score](#log-score) | `ylp` | any | utility | sum | +| `mlpd` | mean log predictive density | [log score](#log-score) | `ylp` | any | utility | mean | +| `ic` | information criterion, $-2\,\text{elpd}$ | [log score](#log-score) | `ylp` | any | loss | sum | +| `rps` | (continuous) ranked probability score | [ranked probability score](#ranked-probability-score) | `ypred` | continuous or ordered | loss | mean | +| `srps` | scaled (continuous) ranked probability score | [ranked probability score](#ranked-probability-score) | `ypred` | continuous or ordered | utility | mean | +| `brier` | Brier score | [Brier score](#brier-score) | `ypred` | binary | loss | mean | +| `mae` | mean absolute error | [point error](#point-error) | `mupred` | continuous | loss | mean | +| `mse` | mean squared error | [point error](#point-error) | `mupred` | continuous | loss | mean | +| `rmse` | root mean squared error | [point error](#point-error) | `mupred` | continuous | loss | function of means | +| `r2` | predictive $R^2$ | [predictive $R^2$](#predictive-r2) | `mupred` | continuous | utility | function of means | +| `acc` | classification accuracy | [classification accuracy](#classification-accuracy) | `mupred` | binary or nominal | utility | mean | +| `bacc` | balanced accuracy | [classification accuracy](#classification-accuracy) | `mupred` | binary or nominal | utility | weighted sum | + +The columns mean: + ++ **Natural scale:** A *loss* is better when it is lower. A *utility* is better + when it is higher. `measure_*()` reports each measure on its natural scale. ++ **Aggregation:** Most measures are a sum or a mean of pointwise terms. RMSE + and $R^2$ have no pointwise terms that add up to the estimate. Balanced + accuracy weights each pointwise term by its class, so that the terms sum to + the estimate. For more details see Vehtari et al. (2026). + +## Notation + +This vignette uses one notation for all measures. The table maps each symbol to an +argument of `measure_*()` or to a field of its result. + +| Symbol | Meaning | In **loo** | +| :--- | :--- | :--- | +| $y_i$ | observed outcome $i$ | `y` | +| $\theta^s$ | posterior draw $s$, $s = 1, \ldots, S$ | rows of the input matrices | +| $\ell_i^s = \log p(y_i \mid \theta^s)$ | log density of $y_i$ under draw $s$ | `ylp`, an $S \times n$ matrix | +| $\tilde y_i^s$ | posterior predictive draw | `ypred`, an $S \times n$ matrix; for `brier`, the event probabilities $p(\tilde y_i = 1 \mid \theta^s)$ | +| $\mathbb{E}[\tilde y_i \mid \theta^s]$ | predictive mean under draw $s$ | `mupred`, an $S \times n$ matrix, or $S \times n \times C$ for $C$ classes | +| $w_i^s$ | normalized weight of draw $s$ (Vehtari et al., 2026, Eq. 2.5) | `log_weights`, on the log scale and unnormalized; **loo** normalizes them. `NULL` gives $w_i^s = 1/S$ | +| $\text{elpd}_i$, $\text{rps}_i$, $\text{ae}_i$, … | pointwise term of a measure, on its natural scale | `$pointwise` | +| $\widehat{\text{elpd}}$, $\widehat{\text{rps}}$, $\widehat{\text{mae}}$, … | estimate of a measure | `$estimates[, "Estimate"]` | +| $\widehat{\text{SE}}$ | standard error of the estimate | `$estimates[, "SE"]` | +| $\widehat{\text{Var}}$ | sample variance over the observations | | + +::: {.callout .callout-note} +**Weights** + +Every estimator in this vignette uses weights $w_i^s$. With +`log_weights = NULL`, all draws get the weight $1/S$. This gives in-sample +predictions. Other weights give other predictive schemes, for example PSIS-LOO. +::: + +## Data and models + +```{r load-libraries} +library(loo) +library(ggplot2) +theme_set(theme_minimal()) +``` + +For each outcome type we fit two `brms` models: + ++ **with predictors**: a model that uses the predictors of the data, ++ **intercept only**: a model that predicts the same distribution for every + observation. + +The intercept-only model is a baseline. It shows how a measure changes when a +model uses no information from the predictors. The model with predictors is +better, but not necessarily good. Fitting is not the topic of this vignette. The +model code is in the [appendix](#appendix-model-code). + +| Object | Data | Outcome | Predictors | Used for | +| :--- | :--- | :--- | :--- | :--- | +| `fits_cont` | `faithful` (`datasets`) | continuous, normal | `waiting` | log score, CRPS, point error*, $R^2$ | +| `fits_bin` | `Pima.te` (`MASS`) | binary, Bernoulli | `glu`, `bmi`, `age` | Brier score | +| `fits_ord` | `wine` (`ordinal`) | ordered, 5 categories | `temp`, `contact` | RPS | +| `fits_cat` | `penguins` (`datasets`) | nominal, 3 unbalanced classes | `bill_len` | accuracy | + +*point error measures include MAE, MSE, and RMSE. + +Each `fits_*` object is a list with the elements `"with predictors"` and +`"intercept only"`. + +**Prediction tasks.** The models predict the following outcomes: + +| Model | Outcome | Predictors | N | +|:--|:--|:--|:--| +| Eruption duration (`fits_cont`) | `eruptions`: duration of the eruption, in minutes | `waiting`: waiting time to the eruption, in minutes | 272 eruptions | +| Diabetes (`fits_bin`) | `diabetes`: 1 if the woman has diabetes (no: 223, yes: 109) | `glu`: plasma glucose concentration; `bmi`: body mass index; `age`: age in years | 332 women | +| Wine bitterness (`fits_ord`) | `rating`: bitterness of the wine, on an ordered scale from 1 to 5 (1: 5, 2: 22, 3: 26, 4: 12, 5: 7) | `temp`: temperature during the crushing of the grapes, cold or warm; `contact`: contact between juice and skins, no or yes | 72 ratings from 9 judges | +| Penguin species (`fits_cat`) | `species`: Adelie (151), Chinstrap (68), or Gentoo (123) | `bill_len`: bill length, in mm | 342 penguins | + +```{r fit-models, echo=FALSE, results="hide"} +SEED <- 42 + +fit_pair <- function(formula, data, family) { + fit <- brms::brm(formula, data = data, family = family, + chains = 2, iter = 1000, seed = SEED, refresh = 0) + list( + "with predictors" = fit, + "intercept only" = update(fit, formula. = . ~ 1, seed = SEED, refresh = 0) + ) +} + +# continuous +fits_cont <- fit_pair(eruptions ~ waiting, faithful, gaussian()) + +# binary +data(Pima.te, package = "MASS") +Pima.te$diabetes <- as.integer(Pima.te$type == "Yes") +fits_bin <- fit_pair(diabetes ~ glu + bmi + age, Pima.te, brms::bernoulli()) + +# ordered +data(wine, package = "ordinal") +fits_ord <- fit_pair(rating ~ temp + contact, wine, brms::cumulative("logit")) + +# nominal: Adelie is the most frequent species +penguins_cc <- datasets::penguins[!is.na(datasets::penguins$bill_len), ] +fits_cat <- fit_pair(species ~ bill_len, penguins_cc, brms::categorical()) +``` + +## Log score {#log-score} + +**Motivation.** The log score evaluates the predictive density at the observed +value. A model gets a high score when it puts much probability near the +observation. It uses the whole predictive distribution, and it strongly +penalizes observations the model considers very unlikely. + +**When to use.** The log score works for any outcome type. It is the default +measure in **loo**. It needs the log-likelihood draws `ylp`. + +**Key formula.** The pointwise term and the estimate are +(Vehtari et al., 2026, Eqs. 2.16–2.18) + +$$ +\text{elpd}_i = \log \sum_{s=1}^S \exp\!\left(\log w_i^s + \ell_i^s\right), +\qquad +\widehat{\text{elpd}} = \sum_{i=1}^n \text{elpd}_i . +$$ + +**loo** reports two rescaled versions: + ++ $\widehat{\text{mlpd}} = +\widehat{\text{elpd}} / n$ on the mean scale, and ++ the information criterion +$\widehat{\text{ic}} = -2\,\widehat{\text{elpd}}$. + +**Standard error.** The elpd is a sum, the mlpd is a mean +(Vehtari et al., 2026, Eqs. 2.8, 2.9): + +$$ +\widehat{\text{SE}}(\widehat{\text{elpd}}) = + \sqrt{n\,\widehat{\text{Var}}(\text{elpd}_i)}, +\qquad +\widehat{\text{SE}}(\widehat{\text{mlpd}}) = + \sqrt{\widehat{\text{Var}}(\text{elpd}_i) / n}, +\qquad +\widehat{\text{SE}}(\widehat{\text{ic}}) = + 2\,\widehat{\text{SE}}(\widehat{\text{elpd}}) . +$$ + +**Implementation.** + +```{r log-score} +ylp_cont <- lapply(fits_cont, brms::log_lik) +elpd_cont <- lapply(ylp_cont, function(ylp) measure_elpd(ylp = ylp)) +mlpd_cont <- lapply(ylp_cont, function(ylp) measure_mlpd(ylp = ylp)) +ic_cont <- lapply(ylp_cont, function(ylp) measure_ic(ylp = ylp)) + +# output structure of elpd measure for model with predictors +str(elpd_cont$`with predictors`) +``` + +**Plot.** The models `fits_cont` predict `eruptions`, the duration of each of +272 eruptions of the Old Faithful geyser (`faithful` data). Each point is one +eruption. The x-axis shows the distance of the observed duration from the +predictive mean. The y-axis shows the pointwise log score $\text{elpd}_i$. +The dashed line is the mlpd, the mean of the points. Higher is better. + +```{r log-score-plot, echo = FALSE} +mu_hat_cont <- lapply(fits_cont, function(fit) colMeans(brms::posterior_epred(fit))) +y_cont <- fits_cont[[1]]$data$eruptions +df_elpd <- do.call(rbind, lapply(names(ylp_cont), function(m) { + data.frame( + model = m, + d = y_cont - mu_hat_cont[[m]], + elpd_i = as.vector(elpd_cont[[m]]$pointwise) + ) +})) +df_lines <- data.frame( + model = names(ylp_cont), + elpd = sapply(elpd_cont, function(r) r$estimates[, "Estimate"]), + mlpd = sapply(mlpd_cont, function(r) r$estimates[, "Estimate"]), + ic = sapply(ic_cont, function(r) r$estimates[, "Estimate"]) +) + +ggplot(df_elpd, aes(d, elpd_i)) + + geom_point(alpha = 0.5) + + geom_hline(data = df_lines, aes(yintercept = mlpd), linetype = "dashed") + + geom_text(data = df_lines, + aes(x = -Inf, y = -Inf, + label = sprintf("elpd = %.0f\nic = %.0f\nmlpd = %.2f", elpd, ic, mlpd)), + hjust = -0.1, vjust = -0.3, size = 3) + + facet_wrap(~model) + + labs(x = "observed duration minus predictive mean", y = "pointwise log score") + +``` + +**Interpretation.** Both models predict a normal distribution, so the points +lie on a parabola. The intercept-only model predicts the same wide +distribution for every eruption. Its parabola is flat: no eruption gets a very +high or a very low score. The predictor `waiting` makes the predictive +distribution narrower. Eruptions close to the predictive mean then get a +higher score, and eruptions far from it get a lower score. The log score +drops with the square of the distance, so these few eruptions pull the +estimate down. The mlpd is +`r round(mlpd_cont[["with predictors"]]$estimates[, "Estimate"], 2)` against +`r round(mlpd_cont[["intercept only"]]$estimates[, "Estimate"], 2)`. + +## Ranked probability score {#ranked-probability-score} + +**Motivation.** The ranked probability score compares the predictive +distribution with the observed value through absolute distances. Unlike the +log score, it rewards predictions that are *close* to the observation, not only +predictions that hit it. It penalizes outlying observations less than the log +score, but it is not robust to them (Bolin and Wallin, 2023). + +**When to use.** Use `rps` for ordered categorical outcomes (RPS) and for +continuous outcomes (CRPS). It is on the scale of $y$, so a value can be +read in the units of the outcome. Use `srps` when outcomes differ strongly in +their predictive spread. Both need the posterior predictive draws `ypred`. + +**Key formula.** Let $X$ and $X'$ be independent draws from the predictive +distribution of observation $i$ (Vehtari et al., 2026, Eqs. 2.20-2.22): + +$$ +\text{rps}_i = \mathbb{E}|X - y_i| - \tfrac{1}{2}\,\mathbb{E}|X - X'|, \qquad +\text{srps}_i = -\frac{\mathbb{E}|X - y_i|}{\mathbb{E}|X - X'|} + - \tfrac{1}{2}\log \mathbb{E}|X - X'| . +$$ + +The estimates are the means $\widehat{\text{rps}} = \frac{1}{n}\sum_i +\text{rps}_i$ and $\widehat{\text{srps}} = \frac{1}{n}\sum_i \text{srps}_i$. +**loo** estimates both expectations from one set of draws. The estimator of +$\mathbb{E}|X - X'|$ is a probability-weighted moment estimator +(Vehtari et al., 2026, Eq. 2.25). +`rps` is a loss (lower is better), and `srps` is a utility (higher is better). + +For ordered outcomes, code the categories $1, \ldots, K$. Let $F_i$ be the +predictive CDF of observation $i$. Then +$\text{rps}_i = \sum_{k=1}^{K-1} \left(F_i(k) - \mathbb{1}\{y_i \le k\}\right)^2$. +This is the RPS of Epstein (1969) without the factor $1/(K-1)$. Divide by $K-1$ +to get values between 0 and 1. + +**Standard error.** Both are means (Vehtari et al., 2026, Eq. 2.8): + +$$ +\widehat{\text{SE}}(\widehat{\text{rps}}) = + \sqrt{\widehat{\text{Var}}(\text{rps}_i) / n}, +\qquad +\widehat{\text{SE}}(\widehat{\text{srps}}) = + \sqrt{\widehat{\text{Var}}(\text{srps}_i) / n} . +$$ + +**Implementation.** For the continuous outcome, `measure_rps()` gives the CRPS +and the SCRPS: + +```{r crps} +y_cont <- fits_cont[[1]]$data$eruptions +ypred_cont <- lapply(fits_cont, brms::posterior_predict) + +crps_cont <- lapply(ypred_cont, function(yp) measure_rps(y = y_cont, ypred = yp)) +scrps_cont <- lapply(ypred_cont, function(yp) measure_srps(y = y_cont, ypred = yp)) + +# output structure of crps measure for model with predictors +str(crps_cont$`with predictors`) +``` + +For the ordered outcome, the same functions give the RPS and the SRPS: + +```{r rps} +y_ord <- as.integer(fits_ord[[1]]$data$rating) +ypred_ord <- lapply(fits_ord, brms::posterior_predict) + +rps_ord <- lapply(ypred_ord, function(yp) measure_rps(y = y_ord, ypred = yp)) +srps_ord <- lapply(ypred_ord, function(yp) measure_srps(y = y_ord, ypred = yp)) + +# output structure of srps measure for model with predictors +str(srps_ord$`with predictors`) +``` + +**Plot.** The models `fits_cont` predict `eruptions`, the duration of each of +272 eruptions of the Old Faithful geyser (`faithful` data). Each point is one +eruption. The x-axis shows the distance of the observed duration from the +predictive mean, as in the log score plot. +The y-axis shows the pointwise CRPS $\text{rps}_i$, in minutes. +The dashed line is the estimate, the mean of the points. Lower is better. + +```{r crps-plot, echo = FALSE} +df_crps <- do.call(rbind, lapply(names(ypred_cont), function(m) { + data.frame( + model = m, + d = y_cont - mu_hat_cont[[m]], + crps_i = as.vector(crps_cont[[m]]$pointwise) + ) +})) +df_lines <- data.frame( + model = names(crps_cont), + crps = sapply(crps_cont, function(r) r$estimates[, "Estimate"]) +) + +ggplot(df_crps, aes(d, crps_i)) + + geom_point(alpha = 0.5) + + geom_hline(data = df_lines, aes(yintercept = crps), linetype = "dashed") + + facet_wrap(~model) + + labs(x = "observed duration minus predictive mean", y = "pointwise CRPS") +``` + +**Interpretation.** In both panels the points form a V with a round bottom. +Far from the predictive mean, the CRPS grows about linearly with the distance, +like an absolute error. The log score, by contrast, drops with the square of +the distance. The narrower distribution of the model with predictors moves the +whole V down: even an exact hit gets a lower CRPS. Its estimate is +`r round(crps_cont[["with predictors"]]$estimates[, "Estimate"], 2)` against +`r round(crps_cont[["intercept only"]]$estimates[, "Estimate"], 2)`. + +**Plot for the ordered outcome.** +The models `fits_ord` predict `rating`, the bitterness of a wine on a scale +from 1 to 5. There are 72 ratings from 9 judges (`wine` data). Each point is one +rating. The x-axis shows the distance of the observed rating from the +predictive mean. The y-axis shows the pointwise RPS $\text{rps}_i$. +The color shows the observed rating. The dashed line is the estimate. +Lower is better. + +```{r rps-plot, echo = FALSE} +df_rps <- do.call(rbind, lapply(names(ypred_ord), function(m) { + data.frame( + model = m, + d = y_ord - colMeans(ypred_ord[[m]]), + rps_i = as.vector(rps_ord[[m]]$pointwise), + rating = factor(y_ord) + ) +})) +df_lines <- data.frame( + model = names(rps_ord), + rps = sapply(rps_ord, function(r) r$estimates[, "Estimate"]) +) + +ggplot(df_rps, aes(d, rps_i)) + + geom_point(aes(color = rating), alpha = 0.5) + + geom_hline(data = df_lines, aes(yintercept = rps), linetype = "dashed") + + scale_color_viridis_d(end = 0.9) + + facet_wrap(~model) + + labs(x = "observed rating minus predictive mean", y = "pointwise RPS", + color = "observed rating") +``` + +**Interpretation.** The intercept-only model gives every wine the same +predictive distribution. Its points therefore form five tight clusters, one for +each observed rating. The RPS uses the order of the categories: a rating far from +the predictive mean gets a higher RPS. The model with predictors gives each +combination of `temp` and `contact` its own predictive distribution. Each spot +therefore splits into smaller groups. Most points move closer to zero +distance, and together they form a V, as for the CRPS. Its estimate is lower: +`r round(rps_ord[["with predictors"]]$estimates[, "Estimate"], 2)` against +`r round(rps_ord[["intercept only"]]$estimates[, "Estimate"], 2)`. + +## Brier score {#brier-score} + +**Motivation.** The Brier score is the squared distance between the predicted +probability of an event and the observed outcome, 0 or 1. It rewards +probabilities that are both calibrated and sharp, that is, close to 0 or 1. + +**When to use.** Use it for binary outcomes. **loo** implements the binary +Brier score only. `measure_brier()` needs the event probabilities of the +draws, passed as `ypred`. + +**Key formula.** With the predicted event probability +$\hat p_i = \sum_s w_i^s\, p(\tilde y_i = 1 \mid \theta^s)$ +(Vehtari et al., 2026, Eqs. 2.26–2.28), + +$$ +\text{bs}_i = \left(\hat p_i - y_i\right)^2, \qquad +\widehat{\text{bs}} = \frac{1}{n}\sum_{i=1}^n \text{bs}_i . +$$ + +The Brier score is a loss (lower is better). It ranges from 0 to 1. + +**Standard error.** The Brier score is a mean (Vehtari et al., 2026, Eq. 2.8): + +$$ +\widehat{\text{SE}}(\widehat{\text{bs}}) = + \sqrt{\widehat{\text{Var}}(\text{bs}_i) / n} . +$$ + +**Implementation.** + +```{r brier} +y_bin <- fits_bin[[1]]$data$diabetes +p_bin <- lapply(fits_bin, brms::posterior_epred) +brier_bin <- lapply(p_bin, function(p) measure_brier(y = y_bin, ypred = p)) + +str(brier_bin$`with predictors`) +``` + +**Plot.** The models `fits_bin` predict `diabetes`, 1 if the woman has +diabetes, for 332 women (`Pima.te` data). Each point is one woman. +The x-axis shows the predicted probability $\hat p_i$ of diabetes. +Every point lies on one of two curves: $\hat p_i^2$ if the woman has no +diabetes, and $(1 - \hat p_i)^2$ if she has diabetes. Lower is better. + +```{r brier-plot, echo = FALSE} +df_brier <- do.call(rbind, lapply(names(p_bin), function(m) { + data.frame( + model = m, + p = colMeans(p_bin[[m]]), + bs_i = as.vector(brier_bin[[m]]$pointwise), + diabetes = factor(y_bin, levels = 0:1, labels = c("no", "yes")) + ) +})) + +max_bs_yes <- max(df_brier$bs_i[df_brier$model == "with predictors" & + df_brier$diabetes == "yes"]) + +ggplot(df_brier, aes(p, bs_i, color = diabetes)) + + geom_function(fun = function(p) p^2, color = "grey70", linetype = "dotted") + + geom_function(fun = function(p) (1 - p)^2, color = "grey70", linetype = "dotted") + + geom_point(alpha = 0.5) + + facet_wrap(~model) + + labs(x = "predicted probability of diabetes", + y = "pointwise Brier score", color = "diabetes") +``` + +**Interpretation.** The intercept-only model gives every woman the same +probability, the proportion of women with diabetes. All its points fall on two +spots, one on each curve. The model with predictors spreads the probabilities. +A woman moves down her curve when the model is confident and right. She moves +up her curve when the model is confident and wrong. Most women without +diabetes get a low probability and a score near 0. A few women with diabetes +get a low probability and a score up to `r round(max_bs_yes, 1)`. +Its estimate is lower: +`r round(brier_bin[["with predictors"]]$estimates[, "Estimate"], 2)` against +`r round(brier_bin[["intercept only"]]$estimates[, "Estimate"], 2)`. + +## Point error {#point-error} + +**Motivation.** The point-error measures reduce the predictive distribution to +one point prediction, the predictive mean. They then measure the distance +between that prediction and the observed value. They are easy to interpret, +but they ignore the predictive uncertainty. + +**When to use.** Use them for continuous outcomes when the quality of the point +prediction matters. MAE is less sensitive to large errors than MSE and RMSE. +MAE and RMSE are on the scale of $y$. All three need the predictive means +`mupred`. + +**Which point prediction.** Each loss rewards a different point prediction. +The squared error is smallest in expectation for the predictive mean. The +absolute error is smallest for the predictive median (Gneiting, 2011). +**loo** uses the predictive mean for all three measures. MSE and RMSE +therefore evaluate the prediction they reward. MAE evaluates the mean, not +the median. In the normal model here, the predictive distribution is close to +symmetric. Its mean and its median are then about equal. + +**MAE or RMSE.** Neither is better in general. RMSE fits normal errors, and +MAE fits Laplace errors with heavier tails (Hodson, 2022). RMSE is never +smaller than MAE. They are equal only when all absolute errors are equal. + +**Key formula.** With the point prediction +$\hat y_i = \sum_s w_i^s\, \mathbb{E}[\tilde y_i \mid \theta^s]$, the pointwise +errors are $\text{ae}_i = |y_i - \hat y_i|$ and +$\text{sqe}_i = (y_i - \hat y_i)^2$ (Vehtari et al., 2026, Eqs. 2.29-2.34): + +$$ +\widehat{\text{mae}} = \frac{1}{n}\sum_{i=1}^n \text{ae}_i, \qquad +\widehat{\text{mse}} = \frac{1}{n}\sum_{i=1}^n \text{sqe}_i, \qquad +\widehat{\text{rmse}} = \sqrt{\widehat{\text{mse}}} . +$$ + +All three are losses. + +**Standard error.** MAE and MSE are means (Vehtari et al., 2026, Eq. 2.8). +RMSE is a function of a mean, so its standard error uses the delta method +(Vehtari et al., 2026, Eq. 2.33): + +$$ +\widehat{\text{SE}}(\widehat{\text{mae}}) = + \sqrt{\widehat{\text{Var}}(\text{ae}_i) / n}, +\qquad +\widehat{\text{SE}}(\widehat{\text{mse}}) = + \sqrt{\widehat{\text{Var}}(\text{sqe}_i) / n}, +\qquad +\widehat{\text{SE}}(\widehat{\text{rmse}}) = + \frac{\widehat{\text{SE}}(\widehat{\text{mse}})}{2\,\widehat{\text{rmse}}} . +$$ + +**Pointwise terms.** `measure_rmse()` has no pointwise terms of its own. Its +`$pointwise` field holds the squared errors $\text{sqe}_i$, the same as +`measure_mse()`. + +**Implementation.** + +```{r point-error} +mu_cont <- lapply(fits_cont, brms::posterior_epred) + +m_mae <- lapply(mu_cont, function(mu) measure_mae(y = y_cont, mupred = mu)) +m_mse <- lapply(mu_cont, function(mu) measure_mse(y = y_cont, mupred = mu)) +m_rmse <- lapply(mu_cont, function(mu) measure_rmse(y = y_cont, mupred = mu)) + +str(m_mse$`with predictors`) +``` + +**Plot.** The models `fits_cont` predict `eruptions`, the duration of each of +272 eruptions of the Old Faithful geyser (`faithful` data). +Each point is one eruption. The x-axis shows the error of +the point prediction, $y_i - \hat y_i$. The y-axis shows the pointwise squared +error $\text{sqe}_i$. The dashed line is the MSE, the mean of the points. Lower +is better. + +```{r point-error-plot, echo = FALSE} +df_pe <- do.call(rbind, lapply(names(mu_cont), function(m) { + data.frame( + model = m, + e = y_cont - colMeans(mu_cont[[m]]), + sqe_i = as.vector(m_mse[[m]]$pointwise) + ) +})) +df_lines <- data.frame( + model = names(mu_cont), + mae = sapply(m_mae, function(r) r$estimates[, "Estimate"]), + mse = sapply(m_mse, function(r) r$estimates[, "Estimate"]), + rmse = sapply(m_rmse, function(r) r$estimates[, "Estimate"]) +) +top_share <- sapply(m_mse, function(r) { + sqe <- sort(r$pointwise, decreasing = TRUE) + sum(sqe[seq_len(ceiling(0.1 * length(sqe)))]) / sum(sqe) +}) + +ggplot(df_pe, aes(e, sqe_i)) + + geom_point(alpha = 0.5) + + geom_hline(data = df_lines, aes(yintercept = mse), linetype = "dashed") + + geom_text(data = df_lines, + aes(x = -Inf, y = Inf, + label = sprintf("MSE = %.2f\nRMSE = %.2f", mse, rmse)), + hjust = -0.1, vjust = 1.2, size = 3) + + facet_wrap(~model) + + labs(x = "observed duration minus point prediction", + y = "pointwise squared error") +``` + +**Interpretation.** The points lie on a parabola. Compare this with the V of +the CRPS: the squared error grows with the square of the distance. The +intercept-only model predicts the mean duration for every eruption. Most +eruptions are either short or long, so few points lie near zero error. The +predictor `waiting` separates short and long eruptions. Its MSE is +`r round(m_mse[["with predictors"]]$estimates[, "Estimate"], 2)` against +`r round(m_mse[["intercept only"]]$estimates[, "Estimate"], 2)`. +For the model with predictors, the 10% largest errors make up +`r round(100 * top_share[["with predictors"]])`% of the MSE. The MSE is in +squared minutes. The RMSE, its square root, is back in minutes. + +**Plot for MAE and RMSE.** The data are the same as in the plot above: the +duration of 272 eruptions. The histogram shows the pointwise absolute errors +$\text{ae}_i$. The dashed line is the MAE. The dotted line is the RMSE. Both +are in minutes. + +```{r point-error-mae-rmse-plot, echo = FALSE} +df_ae <- do.call(rbind, lapply(names(mu_cont), function(m) { + data.frame(model = m, ae_i = as.vector(m_mae[[m]]$pointwise)) +})) +df_ref <- rbind( + data.frame(model = df_lines$model, measure = "MAE", value = df_lines$mae), + data.frame(model = df_lines$model, measure = "RMSE", value = df_lines$rmse) +) + +ggplot(df_ae, aes(ae_i)) + + geom_histogram(binwidth = 0.1, boundary = 0, fill = "grey70", color = "white") + + geom_vline(data = df_ref, aes(xintercept = value, linetype = measure)) + + geom_text(data = df_ref, aes(x = value, y = Inf, label = measure), + angle = 90, vjust = -0.4, hjust = 1.1, size = 3) + + scale_linetype_manual(values = c(MAE = "dashed", RMSE = "dotted")) + + facet_wrap(~model) + + labs(x = "pointwise absolute error (minutes)", + y = "number of eruptions", linetype = NULL) +``` + +**Interpretation.** In both models the RMSE lies to the right of the MAE. The +squared error gives more weight to the large errors. The +model with predictors moves the histogram to the left, so both measures +decrease. Its MAE is +`r round(m_mae[["with predictors"]]$estimates[, "Estimate"], 2)` and its RMSE +is `r round(m_rmse[["with predictors"]]$estimates[, "Estimate"], 2)`. + +## Predictive $R^2$ {#predictive-r2} + +**Motivation.** The predictive $R^2$ compares the squared error of the model +with the squared error of the simplest prediction, the mean of the +observations. A value of 0 means the model predicts no better than the mean. + +**When to use.** Use it for continuous outcomes, when a unitless summary of the +point prediction is needed. It is a predictive version of the classical $R^2$, +not the Bayesian $R^2$ of Gelman et al. (2019). It needs `mupred`. + +**Key formula.** With $\text{sqe}_i$ and $\widehat{\text{mse}}$ from the +[point error](#point-error) section (Vehtari et al., 2026, Eqs. 2.35, 2.36), + +$$ +\widehat{R^2} = 1 - \frac{\widehat{\text{mse}}}{\widehat{\text{mse}}_y}, +\qquad +\widehat{\text{mse}}_y = \frac{1}{n}\sum_{i=1}^n (y_i - \bar y)^2 . +$$ + +$R^2$ is a utility. + +**Standard error.** $R^2$ is a function of two means, so its standard error +uses the delta method. With $c = \widehat{\text{mse}} / +\widehat{\text{mse}}_y$ (Vehtari et al., 2026, Eq. 2.39), + +$$ +\widehat{\text{SE}}(\widehat{R^2}) = \frac{1}{\widehat{\text{mse}}_y} + \sqrt{\widehat{\text{Var}}\!\left(\text{sqe}_i - c\,(y_i - \bar y)^2\right) / n} . +$$ + +**Pointwise terms.** $R^2$ has no pointwise terms of its own. The +`$pointwise` field of `measure_r2()` holds the squared errors +$\text{sqe}_i$ of the model. + +**Implementation.** + +```{r r2} +m_r2 <- lapply(mu_cont, function(mu) measure_r2(y = y_cont, mupred = mu)) + +str(m_r2$`with predictors`) +``` + +**Plot.** The models `fits_cont` predict `eruptions`, the duration of each of +272 eruptions of the Old Faithful geyser (`faithful` data). +Each point is one eruption. The x-axis shows the distance +of the observed duration from the mean duration. The y-axis shows the +contribution of the eruption to $R^2$, + +$$ +r_i = \frac{(y_i - \bar y)^2 - \text{sqe}_i}{\widehat{\text{mse}}_y}, +\qquad +\frac{1}{n}\sum_{i=1}^n r_i = \widehat{R^2} . +$$ + +A point above zero is an eruption for which the model predicts better than +the mean. The dashed line is $\widehat{R^2}$, the mean of the points. Higher is +better. + +```{r r2-plot, echo = FALSE} +mse_y <- mean((y_cont - mean(y_cont))^2) +df_r2 <- do.call(rbind, lapply(names(m_r2), function(m) { + data.frame( + model = m, + d = y_cont - mean(y_cont), + r_i = ((y_cont - mean(y_cont))^2 - as.vector(m_mse[[m]]$pointwise)) / mse_y + ) +})) +df_lines <- data.frame( + model = names(m_r2), + r2 = sapply(m_r2, function(r) r$estimates[, "Estimate"]) +) + +ggplot(df_r2, aes(d, r_i)) + + geom_hline(yintercept = 0, color = "grey70") + + geom_point(alpha = 0.5) + + geom_hline(data = df_lines, aes(yintercept = r2), linetype = "dashed") + + geom_text(data = df_lines, + aes(x = -Inf, y = Inf, label = sprintf("R2 = %.2f", r2)), + hjust = -0.1, vjust = 1.2, size = 3) + + facet_wrap(~model) + + labs(x = "observed duration minus mean duration", + y = "contribution to R2") +``` + +**Interpretation.** The intercept-only model predicts about the mean duration +for every eruption. All its contributions are close to zero, and so is its +$R^2$. For the model with predictors, the points form a U. +An eruption close to the mean duration contributes about zero or less: +the mean already predicts it well, and the model cannot do much better. +Most of the $R^2$ comes from the short and the long eruptions, which `waiting` +separates well. + +## Classification accuracy {#classification-accuracy} + +**Motivation.** Accuracy is the proportion of observations whose predicted class +is the observed class. It is easy to interpret, but it uses only the predicted +class, not the predictive probabilities. Balanced accuracy gives each class the +same weight. It prevents a model from scoring well by predicting only the most +frequent class. + +**When to use.** Use them for binary or nominal outcomes. Prefer `bacc` when the +classes are unbalanced. Both need the class probabilities `mupred`: an +$S \times n$ matrix for binary outcomes, or an $S \times n \times C$ array for +$C$ classes. + +**Key formula.** +Let $\hat p_{ic} = \sum_s w_i^s\, p(\tilde y_i = c \mid \theta^s)$ be the +predicted probability of class $c$. For binary outcomes, the predicted class is +$\hat c_i = \mathbb{1}\{\hat p_{i1} > 0.5\}$. For $C$ classes, it is +$\hat c_i = \arg\max_c \hat p_{ic}$. The pointwise accuracy is +$\text{acc}_i = \mathbb{1}\{\hat c_i = y_i\}$. With $n_c$ observations in +class $c$ (Vehtari et al., 2026, Eqs. 2.40-2.44), + +$$ +\widehat{\text{acc}} = \frac{1}{n}\sum_{i=1}^n \text{acc}_i, +\qquad +\widehat{\text{bacc}} = \frac{1}{C}\sum_{c=1}^C \widehat{\text{acc}}_c, +\qquad +\widehat{\text{acc}}_c = \frac{1}{n_c}\sum_{i:\, y_i = c} \text{acc}_i . +$$ + +Both are utilities. + +**Standard error.** Both use the binomial standard error, for balanced accuracy +within each class (Vehtari et al., 2026, Eqs. 2.43, 2.45): + +$$ +\widehat{\text{SE}}(\widehat{\text{acc}}) = + \sqrt{\frac{\widehat{\text{acc}}\,(1 - \widehat{\text{acc}})}{n}}, +\qquad +\widehat{\text{SE}}(\widehat{\text{bacc}}) = \frac{1}{C} + \sqrt{\sum_{c=1}^C \frac{\widehat{\text{acc}}_c\,(1 - \widehat{\text{acc}}_c)}{n_c}} . +$$ + +**Implementation.** + +```{r accuracy} +species <- levels(fits_cat[[1]]$data$species) +y_cat <- as.integer(fits_cat[[1]]$data$species) +mu_cat <- lapply(fits_cat, brms::posterior_epred) + +acc_cat <- lapply(mu_cat, function(mu) measure_acc(y = y_cat, mupred = mu)) +bacc_cat <- lapply(mu_cat, function(mu) measure_bacc(y = y_cat, mupred = mu)) + +str(acc_cat$`with predictors`) +``` + +**Plot.** The models `fits_cat` predict `species`, the species of each of 342 +penguins (`penguins` data). The plot shows the confusion matrix of each model. +Each row is an observed class, and each column is a predicted class. +Each cell gives the number of observations and their percentage of the row. +The cells on the diagonal are the correct classifications. +The other cells are the false classifications. + +The two measures read the diagonal in different ways: + ++ **Accuracy** is the sum of the diagonal counts divided by $n$. Each + observation has the same weight, so a large class dominates. ++ **Balanced accuracy** is the mean of the diagonal percentages. Each class + has the same weight, so a small class counts as much as a large class. + +```{r accuracy-plot, echo = FALSE} +df_cm <- do.call(rbind, lapply(names(mu_cat), function(m) { + pred <- max.col(apply(mu_cat[[m]], c(2, 3), mean)) + tab <- table(observed = factor(species[y_cat], species), + predicted = factor(species[pred], species)) + data.frame(model = m, as.data.frame(tab), prop = as.vector(prop.table(tab, 1))) +})) +chin_gentoo <- with(df_cm, prop[model == "with predictors" & + observed == "Chinstrap" & predicted == "Gentoo"]) +est_acc <- sapply(acc_cat, function(r) r$estimates[, "Estimate"]) +est_bacc <- sapply(bacc_cat, function(r) r$estimates[, "Estimate"]) + +ggplot(df_cm, aes(predicted, observed, fill = prop)) + + geom_tile(color = "white", linewidth = 1) + + geom_text(aes(label = sprintf("%d\n(%.0f%%)", Freq, 100 * prop)), size = 3) + + scale_fill_gradient(low = "grey95", high = "steelblue", + limits = c(0, 1), labels = scales::percent) + + scale_y_discrete(limits = rev) + + coord_equal() + + facet_wrap(~model) + + labs(x = "predicted species", y = "observed species", + fill = "share of the\nobserved class") +``` + +**Interpretation.** The intercept-only model predicts Adelie, the most +frequent species, for every penguin. All its observations are in the first +column. Its diagonal percentages are 100%, 0%, and 0%. Its accuracy is +`r round(est_acc[["intercept only"]], 2)`, the share of Adelie. Its balanced +accuracy is `r round(est_bacc[["intercept only"]], 2)`, the mean of the three +percentages. This is the value of a random guess among three classes. + +The model with predictors classifies most Adelie and Gentoo penguins +correctly. It predicts Gentoo for `r round(100 * chin_gentoo)`% of the +Chinstrap penguins, because their bills are about as long. Its accuracy is +`r round(est_acc[["with predictors"]], 2)`, and its balanced accuracy is +`r round(est_bacc[["with predictors"]], 2)`. Chinstrap has only 68 of 342 +penguins, so the accuracy hides this failure. The balanced accuracy gives +Chinstrap the same weight as the other species, so it is lower. + +## References + +Bolin, D., and Wallin, J. (2023). Local scale invariance and robustness of +proper scoring rules. *Statistical Science*, 38(1):140–159. + +Epstein, E. S. (1969). A scoring system for probability forecasts of ranked +categories. *Journal of Applied Meteorology*, 8, 985–987. + +Gelman, A., Goodrich, B., Gabry, J., and Vehtari, A. (2019). R-squared for +Bayesian regression models. *The American Statistician*, 73(3):307–309. +doi:10.1080/00031305.2018.1549100 + +Gneiting, T. (2011). Making and evaluating point forecasts. *Journal of the +American Statistical Association*, 106(494):746–762. +doi:10.1198/jasa.2011.r10138 + +Hodson, T. O. (2022). Root-mean-square error (RMSE) or mean absolute error +(MAE): when to use them or not. *Geoscientific Model Development*, +15(14):5481–5487. doi:10.5194/gmd-15-5481-2022 + +Vehtari, A., Axen, S., Weber, F., and Bockting, F. (2026). Predictive measures +and model comparison in the loo package: A formula reference. + +## See also + +- [Model comparison: Explanation of `model_compare()`](model-comparison.html) +- [Model comparison: Case Study with `model_compare()`]() +- [Predictive model performance: Predictive schemes with `pred_measure()`](pred-measure-workflow.html) +- [Predictive measures and model comparison in the loo package: A formula reference]() + +## Appendix: model code {#appendix-model-code} + +```{r fit-models-code, ref.label="fit-models", eval=FALSE} +``` diff --git a/vignettes/articles-online-only/pred-measure-workflow.Rmd b/vignettes/articles-online-only/pred-measure-workflow.Rmd new file mode 100644 index 00000000..12f67b45 --- /dev/null +++ b/vignettes/articles-online-only/pred-measure-workflow.Rmd @@ -0,0 +1,658 @@ +--- +title: "Predictive model performance: Predictive schemes with `pred_measure()`" +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{Predictive model performance: Predictive schemes with `pred_measure()`} + %\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 = FALSE, + warning = FALSE, + eval = params$EVAL, + fig.width = 7, + fig.height = 4, + fig.align = "center" +) +``` + +```{r, child="../children/LOAD-BRMS-GITHUB.txt", eval=params$EVAL} +``` + +## Introduction + +How well does a fitted model predict data that were not used to fit it? The +formula reference (Vehtari et al., 2026) divides this into three questions: + + +1. **What counts as a good prediction?** This is the *predictive measure*, for + example the log score or the RMSE. + + Discussed in the vignette [Predictive model performance: Overview of measures](overview-measures.html) +2. **Which predictions are evaluated?** This is the *predictive scheme*. It + sets the observations that train the model before observation $i$ is + evaluated. + + Focus of this vignette. +3. **How are the predictions computed?** From posterior draws, from refits, or + with importance weights. + +::: {.callout .callout-note} +**What this article does not cover** + ++ **Measure definitions** + + See the [Predictive model performance: Overview of measures](overview-measures.html). ++ **Model comparison** + + See the [Model comparison: Explanation of `model_compare()`](model-comparison.html) + vignette and + + the [Model comparison case study: Uncertainty, scores, and predictive schemes](pred-measure-case-study.html) ++ **Leave-one-group-out and leave-future-out schemes.** + + Any reference? +::: + +### Training data and evaluation data {#data-sets} + +This vignette focuses on the predictive scheme. A predictive scheme is a rule +that splits the observed data $y = (y_1, \ldots, y_n)$ into a training set +$\mathcal{T}$ used to fit the model and an evaluation set $\mathcal{E}$ (i.e., +the observations whose predictive performance is evaluated). + +Predictive schemes include: + ++ the special case of *in-sample* evaluation, where the training and test set + are the same, consisting of the full data set. ++ *hold-out* evaluation, where the data set is split into two disjoint sets: + one for training and one for evaluation. ++ *cross-validation* schemes, where the training set is a subset of the data, + and the evaluation set is the remaining data. For example, in leave-one-out + cross-validation, the training set is the full data set minus one observation. + In K-fold cross-validation, the training set is the full data set minus one + of $K$ disjoint subsets of the data (i.e., the folds). + +### Overview of the predictive schemes + +The predictive measure API in the **loo** package has one entry point for +each predictive scheme: + +| Scheme | Training data $\mathcal{T}(i)$ | Evaluation data $\mathcal{E}$ | Predictive distribution $p^q(y_i)$ | Weights $w_i^s$ | Entry point | +| :--- | :--- | :--- | :--- | :--- | :--- | +| [in-sample](#in-sample) | $\{1, \ldots, n\}$ | $\{1, \ldots, n\}$ | $p(y_i \mid y)$ | $1/S$ | `insample_pred_measure()` | +| [PSIS-LOO](#psis-loo)* | $\{1, \ldots, n\} \setminus \{i\}$ | $\{1, \ldots, n\}$ | $p(y_i \mid y_{-i})$ | PSIS weights | `loo_pred_measure()` | +| [K-fold](#k-fold) | $\{1, \ldots, n\} \setminus \mathcal{I}_{k(i)}$ | $\{1, \ldots, n\}$ | $p(y_i \mid y_{-\mathcal{I}_{k(i)}})$ | $1/S$ | `kfold_pred_measure()` | +| [test data](#test-data) | $\mathcal{R}$ | $\mathcal{S}$ | $p(y_i \mid y_{\mathcal{R}})$ | $1/S$ | `test_pred_measure()` | + +For further discussion, see the paper [Predictive measures: A formula reference]() . + +## Running example + +**Prediction task.** The `sleepstudy` data (**lme4**) come from a study of sleep +restriction (Belenky et al., 2003). Eighteen subjects slept at most three hours +each night. The outcome `y` is the average reaction time (ms) of a subject on +one day. Days 0 and 1 were adaptation and training, so this vignette keeps days +2 to 9. The predictor `Days` counts the days of sleep restriction, from 0 to 7. +This gives 144 observations. + +```{r load-libraries-internal, echo=FALSE} +devtools::load_all("../..", quiet = TRUE) +devtools::load_all("../../../../GitHub/brms", quiet = TRUE) +library(ggplot2) + +theme_set(theme_minimal()) +SEED <- 42 +``` + +```{r load-libraries, eval=FALSE} +library(loo) # for evaluating the predictive performance +library(brms) # for model fitting +library(lme4) # for the sleepstudy data +library(ggplot2) # for plotting + +theme_set(theme_minimal()) +SEED <- 42 +``` + +To model the data, we use a normal regression of `y` on `Days` with no subject +effects. As fitting is not the focus of this vignette, we do not discuss the +modelling step in depth but show the code in the [appendix](#appendix-model-code). + +For discussing the different predictive schemes, we fit the model once to the +full data set and once to a subset of the data (i.e., the training data). For +the test data we holdout the observations of 5 subjects. + +| Object | Data | Description | +| :--- | :--- | :--- | +| `fit_full` | all 18 subjects, 144 observations | fit to full data| +| `fit_train` | 13 subjects, 104 observations | fit to training data | +| `test_data` | the other 5 subjects, 40 observations | test data set | + +Each fit uses the `brms` default of 4 chains and 2000 iterations. + +```{r fit-models, echo=FALSE, results="hide"} +set.seed(SEED) + +data("sleepstudy", package = "lme4") +sleepstudy <- subset(sleepstudy, Days >= 2) +sleepstudy$Days <- sleepstudy$Days - 2 +sleepstudy$y <- sleepstudy$Reaction + +prior_sleep <- brms::prior(normal(200, 100), class = b, coef = "Intercept") + + brms::prior(normal(0, 20), class = b, coef = "Days") + + brms::prior(exponential(0.02), class = sigma) + +# all subjects +fit_full <- brms::brm( + y ~ 0 + Intercept + Days, + data = sleepstudy, + family = gaussian(), + prior = prior_sleep, + seed = SEED, + refresh = 0 +) + +# five subjects held out as test data +test_subjects <- sample(unique(sleepstudy$Subject), size = 5) +train_data <- subset(sleepstudy, !Subject %in% test_subjects) +test_data <- subset(sleepstudy, Subject %in% test_subjects) + +fit_train <- update( + fit_full, newdata = train_data, seed = SEED, refresh = 0 +) +``` + +### Measures + +To mesaure predictive performance of the model, we will use the following +measures: `elpd`, `mlpd`, `rps`, `rmse`, and `r2`. +See the vignette [Predictive model performance: Overview of measures](overview-measures.html) +for a discussion of the measures. + +Each measure requires one or more of the following inputs: the observed +values (`y`), the pointwise log predictive densities (`ylp`), the predicted +means (`mupred`), or draws from the predictive distribution (`ypred`). The +following table shows the required inputs for each measure. + +| Measure | `y` | `ylp` | `mupred` | `ypred` | +| :--- | :---: | :---: | :---: | :---: | +| `elpd` | | ✓ | | | +| `mlpd` | | ✓ | | | +| `rps` | ✓ | | | ✓ | +| `rmse` | ✓ | | ✓ | | +| `r2` | ✓ | | ✓ | | + +To compute the corresponding inputs we use functions from `brms`. + +```{r inputs} +measures <- c("elpd", "mlpd", "rps", "rmse", "r2") + +y <- fit_full$data$y +ylp <- brms::log_lik(fit_full) +ypred <- brms::posterior_predict(fit_full) +mupred <- brms::posterior_epred(fit_full) +``` + +## Predictive schemes +### In-sample {#in-sample} +We start the discussion with the special case of using in-sample evaluations. +In-sample performance evaluates the fitted model on the same data used for +fitting. It should not be used to estimate predictive performance. +Nevertheless, it can be useful as a reference point, and the amount of optimism +relative to a cross-validation or test-data estimate can itself be informative. + +**Implementation** + +```{r insample} +insample_sleep <- insample_pred_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + measures = measures +) +str(insample_sleep) +``` + +**Result** +The returned structure of the `pred_measure` class includes the +`$estimates` and `$pointwise` components per selected measure. Furthermore, the +following attributes are included in the result: + ++ `measure_info`: a list with entries for each measure with respective additional information ++ `dims`: provides the dimensions of the data used for evaluation. ++ `class`: indicates the class of the result, here `"pred_measure"` and `"insample_pred_measure"`. ++ `source`: indicates the predictive scheme used, here `"insample"`. + +The corresponding print method shows the estimates and standard errors for +each measure, as well as the number of observations used for evaluation. + +```{r insample-print} +insample_sleep +``` + +### PSIS-LOO {#psis-loo} +Next, we focus on the leave-one-out cross-validation (LOO) scheme, specifically +using Pareto-smoothed importance sampling (PSIS) to approximate the LOO +predictive performance. While exact leave-one-out cross-validation needs one +refit for each observation, PSIS-LOO uses the draws of the full-data fit instead. +PSIS-LOO then weights the draws with Pareto-smoothed importance weights, so +that each $y_i$ is scored as if it was left out (Vehtari et al., 2024). + +**Implementation** +We first compute the PSIS-LOO object using `brms::loo()` and then pass it to +`loo_pred_measure()`. Otherwise, the input structure is the same as for the +in-sample evaluation. + +```{r loo} +loo_sleep <- brms::loo(fit_full, save_psis = TRUE) + +loo_sleep_measure <- loo_pred_measure( + loo = loo_sleep, + y = y, + ypred = ypred, + mupred = mupred, + measures = measures +) +loo_sleep_measure +``` + +**Result** +Compared to the in-sample evaluation, the rows now have the suffix `_loo`. +The measure `elpd` also adds automatically `p_loo`, the difference between the +in-sample and the LOO log score (Vehtari et al., 2026). + +The output structure of the `loo_pred_measure` class includes two additional +components compared to the `insample_pred_measure` class: + ++ `$diagnostics`: including `pareto_k`, the Pareto $\hat k$ values for each +observation, and (relative) effective sample size, `n_eff` and `r_eff`. ++ `$log_weights`: the log PSIS weights. + +```{r} +names(loo_sleep_measure) +``` + +**Plot** +The following plot compares the in-sample and LOO scores for +three measures: the log score, the RPS, and the squared error. Each point +is one observation. The x-axis shows the in-sample value, and the y-axis +the LOO value. The color shows the Pareto $\hat k$. We do not show `mlpd` +and `r2` as their pointwise values are the same as those of `elpd` and `rmse`. + +```{r loo-plot, echo=FALSE} +pw_measures <- c( + elpd = "log score (higher is better)", + rps = "RPS (lower is better)", + rmse = "squared error (lower is better)" +) + +df_all <- do.call(rbind, lapply(names(pw_measures), function(m) data.frame( + measure = pw_measures[[m]], + insample = insample_sleep$pointwise[, m], + loo = loo_sleep_measure$pointwise[, paste0(m, "_loo")], + pareto_k = loo_sleep_measure$diagnostics$pareto_k +))) + +ggplot(df_all, aes(insample, loo, color = pareto_k)) + + geom_abline(linetype = "dashed") + + geom_point() + + scale_color_viridis_c() + + facet_wrap(~measure, scales = "free") + + labs(x = "pointwise in-sample value", + y = "pointwise LOO value", + color = "Pareto k") + + geom_blank(aes(x = loo, y = insample)) +``` + +The log score is a utility (higher is better). The RPS and the squared error +are losses (lower is better). Thus, an observation that is harder to predict +when it is left out lies below the diagonal for the log score, but above the +diagonal for the RPS and the squared error. The farther a point lies from the +diagonal, the more the observation influences the posterior. Such +observations often have a high Pareto $\hat k$. The color lets you check +whether an influential observation moves away from the diagonal for all +measures or only for some. + +### K-fold {#k-fold} +Next, we focus on K-fold cross-validation. The data are split into $K$ folds. +The model is fit once for each fold, without the observations in that fold. +This needs $K$ fits, not $n$. + +**Implementation** +The **loo** package does not refit the model but this can be done with +`brms::kfold()`. Set `save_fits = TRUE`. Without the fits, +`brms::kfold_predict()` cannot compute the held-out draws: +`method = "predict"` gives `ypred`, and `method = "fitted"` gives `mupred`. + +```{r kfold, results="hide"} +set.seed(SEED) +kfold_sleep <- brms::kfold(fit_full, K = 5, save_fits = TRUE) +ypred_kfold <- brms::kfold_predict(kfold_sleep, method = "predict")$yrep +mupred_kfold <- brms::kfold_predict(kfold_sleep, method = "fitted")$yrep +``` + +We then pass the K-fold object to `kfold_pred_measure()`. Otherwise, the input +structure is the same as for the previous examples. + +```{r kfold-measures} +kfold_sleep_measure <- kfold_pred_measure( + y = y, + ypred = ypred_kfold, + mupred = mupred_kfold, + kfold = kfold_sleep, + measures = measures +) +kfold_sleep_measure +``` + +**Result** +The rows in the result object now have the suffix `_kfold`. +The measure `elpd` also adds `p_kfold`, the difference between the in-sample +and the K-fold log score. + +The output structure of the `kfold_pred_measure` class copies the attributes +`K`, `folds`, `fold_type`, `joint`, `yhash`, and `model_name` from the `kfold` +object. It has `$diagnostics` only when the `kfold` object has them. +K-fold uses no importance weights, so there is no `$log_weights` component as +in the case of PSIS-LOO. + +```{r} +names(kfold_sleep_measure) +``` + +**Plot** +The following plot compares the in-sample and K-fold values for the three +measures. Each point is one observation. The color shows the fold of each +observation. + +```{r kfold-plot, echo=FALSE} +df_kfold <- do.call(rbind, lapply(names(pw_measures), function(m) data.frame( + measure = pw_measures[[m]], + insample = insample_sleep$pointwise[, m], + kfold = kfold_sleep_measure$pointwise[, paste0(m, "_kfold")], + fold = factor(attr(kfold_sleep_measure, "folds")) +))) + +ggplot(df_kfold, aes(insample, kfold, color = fold)) + + geom_abline(linetype = "dashed") + + geom_point() + + facet_wrap(~measure, scales = "free") + + labs(x = "pointwise in-sample value", + y = "pointwise K-fold value", + color = "fold") + + geom_blank(aes(x = kfold, y = insample)) +``` + +The direction of the diagonal is the same as in the PSIS-LOO plot. With +$K = 5$, each fit uses about 80% of the data. Thus K-fold and PSIS-LOO answer a +similar question. Each K-fold fit has less data than a LOO fit, so the K-fold +estimates are often slightly worse. + +`brms::kfold()` also accepts `folds = "grouped"` with `group = "Subject"`. Then +each fold holds out whole subjects, and the predictive question changes to new +subjects. + +### Test data {#test-data} +Finally, we focus on the test data scheme, where the data is split into two +disjoint sets, a training and a test set. The model is fit only to the +training set. It then predicts the test set, which it did not see. For the +current example, we hold out five subjects. This gives 40 test observations. + +**Implementation** +We compute the draws of `fit_train` at `test_data` with `newdata`. Pass the log +densities of the test observations as `ylp_test`, not as `ylp`. The measures +`elpd`, `mlpd`, and `ic` need `ylp_test`. + +```{r test} +ypred_test <- brms::posterior_predict(fit_train, newdata = test_data) +mupred_test <- brms::posterior_epred(fit_train, newdata = test_data) +ylp_test <- brms::log_lik(fit_train, newdata = test_data) + +test_sleep_measure <- test_pred_measure( + y = test_data$y, + ypred = ypred_test, + mupred = mupred_test, + ylp_test = ylp_test, + measures = measures +) +test_sleep_measure +``` + +**Result** +The rows in the result object now have the suffix `_test`. The attribute +`dims` gives the size of the test set, 40 observations, not the size of the +training set. The output has only `$estimates` and `$pointwise`. + +```{r} +names(test_sleep_measure) +``` + +**Plot** +The test observations are not in the training data. Thus there is no in-sample +value. The following plot shows the pointwise test values on the y-axis for +each of the five test subjects on the x-axis. + +```{r test-plot, echo=FALSE} +df_test <- do.call(rbind, lapply(names(pw_measures), function(m) data.frame( + measure = pw_measures[[m]], + subject = test_data$Subject, + test = test_sleep_measure$pointwise[, paste0(m, "_test")] +))) + +ggplot(df_test, aes(subject, test, color = subject)) + + geom_point(position = position_jitter(width = 0.1, seed = SEED)) + + facet_wrap(~measure, scales = "free") + + labs(x = "test subject", y = "pointwise test value") + + theme(legend.position = "none") +``` + +The test set holds five subjects that the model did not see. The plot shows whether +one subject controls the estimate. The test set is small, so the standard errors +are larger than in the other schemes. A different split can give +a different estimate. + +## Comparison of predictive schemes {#compare-predictive-schemes} +All four schemes use the same model and the same measures. They differ in the +predictive question. The plot shows the estimate and $\pm 1$ standard error +for each scheme and measure. + +`elpd` is a sum over the evaluation data (Vehtari et al., 2026, Eq. 2.7). The +test set has 40 observations, and the other schemes have 144. Thus do not +compare the `elpd` of the test data with the other schemes. Use `mlpd` for +this comparison. + +```{r scheme-overview, echo=FALSE} +results <- list( + "in-sample" = insample_sleep$estimates, + "PSIS-LOO" = loo_sleep_measure$estimates, + "K-fold" = kfold_sleep_measure$estimates, + "test data" = test_sleep_measure$estimates +) +suffix <- c("in-sample" = "", "PSIS-LOO" = "_loo", "K-fold" = "_kfold", + "test data" = "_test") +direction <- c(elpd = "higher", mlpd = "higher", rps = "lower", + rmse = "lower", r2 = "higher") + +df_est <- do.call(rbind, lapply(names(results), function(s) { + est <- results[[s]][paste0(measures, suffix[[s]]), , drop = FALSE] + data.frame( + scheme = s, + measure = paste0(measures, " (", direction[measures], " is better)"), + estimate = est[, "Estimate"], + se = est[, "SE"] + ) +})) + +df_est$scheme <- factor(df_est$scheme, levels = rev(names(results))) +df_est$measure <- factor(df_est$measure, levels = unique(df_est$measure)) + +ggplot(df_est, aes(estimate, scheme, color = scheme)) + + geom_linerange(aes(xmin = estimate - se, xmax = estimate + se), + linewidth = 0.8) + + geom_point(size = 2.5) + + scale_color_manual( + values = c("in-sample" = "grey50", "PSIS-LOO" = "#0072B2", + "K-fold" = "#009E73", "test data" = "#D55E00"), + guide = "none" + ) + + facet_wrap(~measure, ncol = 3, nrow = 2, scales = "free_x") + + labs(x = "estimate ± 1 SE", y = NULL) + + theme_minimal() + + theme(panel.grid.major.y = element_blank(), + panel.grid.minor = element_blank(), + panel.border = element_rect(color = "grey70", fill = NA), + panel.spacing.y = unit(1, "lines"), + strip.background = element_rect(fill = "grey92", color = "grey70"), + strip.text = element_text(hjust = 0.5, face = "bold")) +``` + +In-sample, PSIS-LOO, and K-fold score the same 144 observations. The +in-sample estimate is the most optimistic, because the model has seen each +$y_i$. PSIS-LOO and K-fold ask a similar question, so their estimates are +close. The test data score five new subjects. The interval of the test data is +wider, because the test set has only 40 observations. One split is noisy. A +different split can move the estimate to the other side of PSIS-LOO. + +## Add measures to an existing result {#add-measures} + +Besides the four scheme functions, the `pred_measure()` function adds measures +to an object of class `pred_measure`. It takes the predictive scheme from the +result, for example `kfold`, and adds new measures to +the result object. If a requested measure is already stored, `pred_measure()` +warns and skips it. + +For example, we first compute only `elpd` with PSIS-LOO. + +```{r} +loo_elpd <- loo_pred_measure( + loo = loo_sleep, measures = "elpd", save_psis = TRUE +) +loo_elpd +``` + +And decide then that we want to add further measures to the output. +We can do that using `pred_measure()` and provide the additional measures with +their required input: + +```{r add-measures} +pred_measure( + y = y, + mupred = mupred, + predperf = loo_elpd, + measures = c("mae", "rmse") +) +``` + +## Custom measures {#custom-measures} + +The argument `measures` also accepts functions. Use them to define custom +measures. A custom function must follow three rules: + ++ **Arguments.** Name the arguments from `y`, `ypred`, `mupred`, `ylp`, and + `log_weights`. **loo** maps the inputs by these names. ++ **Weights.** `log_weights` holds the PSIS weights for PSIS-LOO. In the other + schemes it is `NULL`. A function that ignores `log_weights` gives in-sample + values under PSIS-LOO. ++ **Return value.** Return a list with `estimate`, `se`, and `pointwise`. + +After you construct the custom function, wrap it in +`custom_measure()`, which sets the name, whether the measure is a loss (lower is +better) or a utility, and how `model_compare()` computes the standard error of a +difference (`se_diff_fun`). The default is a utility (higher is better). If you do not give +`se_diff_fun`, `model_compare()` reports an `NA` standard error. + +**Example.** The coverage of the central 90% predictive interval is the +proportion of observations inside that interval. For a calibrated model, it is +close to 0.9. Observation $i$ is inside the interval when its probability +integral transform lies between 0.05 and 0.95: + +$$ +\text{pit}_i = \sum_{s=1}^S w_i^s\, \mathbb{1}\{\tilde y_i^s \le y_i\}, +\qquad +\text{cover}_i = \mathbb{1}\{0.05 < \text{pit}_i \le 0.95\} . +$$ + +```{r custom-function} +coverage <- function(y, ypred, log_weights = NULL, prob = 0.9) { + if (is.null(log_weights)) { + log_weights <- matrix(-log(nrow(ypred)), nrow(ypred), ncol(ypred)) + } + w <- exp(sweep(log_weights, 2, matrixStats::colLogSumExps(log_weights))) + pit <- colSums(w * sweep(ypred, 2, y, "<=")) + alpha <- 1 - prob + cover_i <- as.numeric(pit > alpha / 2 & pit <= 1 - alpha / 2) + list( + estimate = mean(cover_i), + se = sqrt(var(cover_i) / length(cover_i)), + pointwise = cover_i + ) +} +``` + +The same function works in every scheme: + +```{r custom-measures} +cover90 <- custom_measure(coverage, name = "cover90", se_diff_fun = "mean") + +insample_pred_measure( + y = y, + ypred = ypred, + measures = list("rps", cover90 = cover90) +) + +loo_pred_measure( + loo = loo_sleep, + y = y, + ypred = ypred, + measures = list("rps", cover90 = cover90) +) +``` + +## References + +Belenky, G., Wesensten, N. J., Thorne, D. R., et al. (2003). Patterns of +performance degradation and restoration during sleep restriction and subsequent +recovery: A sleep dose-response study. *Journal of Sleep Research*, +12(1):1–12. + +Paananen, T., Piironen, J., Bürkner, P.-C., and Vehtari, A. (2021). Implicitly +adaptive importance sampling. *Statistics and Computing*, 31(2):16. + +Silva, L. and Zanella, G. (2022). Robust leave-one-out cross-validation for +high-dimensional Bayesian models. Preprint at +[arXiv:2209.09190](https://arxiv.org/abs/2209.09190). + +Vehtari, A., Axen, S., Weber, F., and Bockting, F. (2026). Predictive measures +and model comparison in the loo package: A formula reference. [TODO: arXiv ID] + +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., Simpson, D., Gelman, A., Yao, Y., and Gabry, J. (2024). Pareto +smoothed importance sampling. *Journal of Machine Learning Research*, +25(72):1–58. + +## See also + +- [Predictive model performance: Overview of measures](overview-measures.html) +- [Model comparison: Explanation of `model_compare()`](model-comparison.html) +- [Cross-validation FAQ](https://users.aalto.fi/~ave/CV-FAQ.html) + +## Appendix: model code {#appendix-model-code} + +```{r fit-models-code, ref.label="fit-models", eval=FALSE} +``` diff --git a/vignettes/articles-online-only/styles.css b/vignettes/articles-online-only/styles.css new file mode 100644 index 00000000..7afc3951 --- /dev/null +++ b/vignettes/articles-online-only/styles.css @@ -0,0 +1,41 @@ +/* Base Callout Styling */ +.callout { + padding: 1rem 1rem 1rem 1.2rem; + margin: 1.5rem 0; + border-left: 5px solid #ccc; + background-color: #f8f9fa; + border-radius: 0.25rem; +} + +/* Callout Variations */ +.callout-note { + border-left-color: #0d6efd; /* Blue */ + background-color: #cfe2ff22; +} + +.callout-warning { + border-left-color: #ffc107; /* Yellow/Amber */ + background-color: #fff3cd22; +} + +.callout-tip { + border-left-color: #198754; /* Green */ + background-color: #d1e7dd22; +} + +.callout-message { + border-left-color: #bec0bf; /* Grey */ + background-color: #d1e7dd22; +} + +/* Optional: Style headings inside callouts to match */ +.callout p:first-child { + font-weight: bold; + margin-top: 0; +} + +/* Make output scrollable +.scroll-output { + max-height: 300px; + overflow-y: auto; +} \ No newline at end of file diff --git a/vignettes/children/LOAD-BRMS-GITHUB.txt b/vignettes/children/LOAD-BRMS-GITHUB.txt new file mode 100644 index 00000000..d4ca5078 --- /dev/null +++ b/vignettes/children/LOAD-BRMS-GITHUB.txt @@ -0,0 +1,8 @@ +```{r load-brms-github, include=FALSE} +# Features used in these vignettes require brms from GitHub master (not yet on CRAN). +if (!requireNamespace("remotes", quietly = TRUE)) { + install.packages("remotes") +} +remotes::install_github("paul-buerkner/brms", ref = "master", upgrade = "never") +suppressPackageStartupMessages(library(brms)) +``` diff --git a/vignettes/loo2-elpd.Rmd b/vignettes/loo2-elpd.Rmd index cd205d49..491ab636 100644 --- a/vignettes/loo2-elpd.Rmd +++ b/vignettes/loo2-elpd.Rmd @@ -26,7 +26,7 @@ This vignette demonstrates how to do holdout validation and K-fold cross-validat # Example: Eradication of Roaches using holdout validation approach This vignette uses the same example as in the vignettes -[_Using the loo package (version >= 2.0.0)_](http://mc-stan.org/loo/articles/loo2-example.html) and [_Avoiding model refits in leave-one-out cross-validation with moment matching_](https://mc-stan.org/loo/articles/loo2-moment-matching.html). +[_Using the loo package_](https://mc-stan.org/loo/articles/loo2-example.html) and [_Avoiding model refits with moment matching_](https://mc-stan.org/loo/articles/loo2-moment-matching.html). @@ -66,7 +66,7 @@ generated quantities { ``` Following the usual approach recommended in -[_Writing Stan programs for use with the loo package_](http://mc-stan.org/loo/articles/loo2-with-rstan.html), +[_Writing Stan programs for use with the loo package_](https://mc-stan.org/loo/articles/loo2-with-rstan.html), we compute the log-likelihood for each observation in the `generated quantities` block of the Stan program. @@ -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..ba8e958c 100644 --- a/vignettes/loo2-example.Rmd +++ b/vignettes/loo2-example.Rmd @@ -54,7 +54,7 @@ library("loo") The Poisson and negative binomial regression models used below in our example, as well as the `stan_glm` function used to fit the models, are covered in more depth in the __rstanarm__ vignette -[_Estimating Generalized Linear Models for Count Data with rstanarm_](http://mc-stan.org/rstanarm/articles/count.html). In the rest of +[_Estimating Generalized Linear Models for Count Data with rstanarm_](https://mc-stan.org/rstanarm/articles/count.html). In the rest of this vignette we will assume the reader is already familiar with these kinds of models. @@ -105,7 +105,7 @@ fit1 <- Usually we would also run posterior predictive checks as shown in the __rstanarm__ vignette -[Estimating Generalized Linear Models for Count Data with rstanarm](http://mc-stan.org/rstanarm/articles/count.html), but +[Estimating Generalized Linear Models for Count Data with rstanarm](https://mc-stan.org/rstanarm/articles/count.html), but here we focus only on methods provided by the __loo__ package.
@@ -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..21cb5ae9 100644 --- a/vignettes/loo2-large-data.Rmd +++ b/vignettes/loo2-large-data.Rmd @@ -56,7 +56,7 @@ set.seed(4711) # Example: Well water in Bangladesh We will use the same example as in the vignette [_Writing Stan programs for use -with the loo package_](http://mc-stan.org/loo/articles/loo2-with-rstan.html). +with the loo package_](https://mc-stan.org/loo/articles/loo2-with-rstan.html). See that vignette for a description of the problem and data. The sample size in this example is only $N=3020$, which is not large enough to @@ -88,7 +88,7 @@ model { ``` Importantly, unlike the general approach recommended in -[_Writing Stan programs for use with the loo package_](http://mc-stan.org/loo/articles/loo2-with-rstan.html), +[_Writing Stan programs for use with the loo package_](https://mc-stan.org/loo/articles/loo2-with-rstan.html), we do _not_ compute the log-likelihood for each observation in the `generated quantities` block of the Stan program. Here we are assuming we have a large data set (larger than the one we're actually using in this demonstration) @@ -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-moment-matching.Rmd b/vignettes/loo2-moment-matching.Rmd index e4b99e91..6c9ec7ad 100644 --- a/vignettes/loo2-moment-matching.Rmd +++ b/vignettes/loo2-moment-matching.Rmd @@ -50,7 +50,7 @@ Pareto smoothed importance sampling. *Journal of Machine Learning Research*, # Example: Eradication of Roaches We will use the same example as in the vignette -[_Using the loo package (version >= 2.0.0)_](https://mc-stan.org/loo/articles/loo2-example.html). +[_Using the loo package_](https://mc-stan.org/loo/articles/loo2-example.html). See the demo for a description of the problem and data. We will use the same Poisson regression model as in the case study. @@ -92,7 +92,7 @@ generated quantities { ``` Following the usual approach recommended in -[_Writing Stan programs for use with the loo package_](http://mc-stan.org/loo/articles/loo2-with-rstan.html), +[_Writing Stan programs for use with the loo package_](https://mc-stan.org/loo/articles/loo2-with-rstan.html), we compute the log-likelihood for each observation in the `generated quantities` block of the Stan program. @@ -152,7 +152,7 @@ The `loo()` function output warnings that there are some observations which are highly influential, and thus the accuracy of importance sampling is compromised as indicated by the large Pareto $k$ diagnostic values (> 0.7). As discussed in the vignette -[_Using the loo package (version >= 2.0.0)_](https://mc-stan.org/loo/articles/loo2-example.html), +[_Using the loo package_](https://mc-stan.org/loo/articles/loo2-example.html), this may be an indication of model misspecification. Despite that, it is still beneficial to be able to evaluate the predictive performance of the model accurately. 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 8b265380..ec1056ba 100644 --- a/vignettes/migration-guide.Rmd +++ b/vignettes/migration-guide.Rmd @@ -34,44 +34,175 @@ release. Release notes appear in `NEWS.md`. Deprecated functions are listed under **Deprecated functions** on the package website. -## Scope of this guide (loo 3.0.0 branch) - -This version of the guide covers deprecations whose **replacements already exist** -in the package. Work on a unified predictive performance API (`pred_measure`, -`measure_*()`, and related deprecations) is developed on a separate feature -branch and will extend this guide when merged into `loo-v3.0.0`. - --- # Deprecated source files | File | Status | Replacement / notes | |------|--------|---------------------| -| `R/compare.R` | Deprecated (removal in 3.0.0) | `loo_compare()` in `R/loo_compare.R` | +| `R/elpd.R` | Deprecated | `measure_elpd()` in `R/pred_measure-builtin.R` | +| `R/crps.R` | Deprecated | `measure_rps()`, `measure_srps()`, `loo_pred_measure()` | +| `R/loo_predictive_metric.R` | Deprecated | `loo_pred_measure()`, `measure_*()` | +| `R/pred_measure.R` | **Current** | `*_pred_measure()` entry points | +| `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) | `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 | --- # Function migration tables +## Expected log predictive density + +| Deprecated | Replacement | Since | Planned removal | +|------------|-------------|-------|-----------------| +| `elpd()` | `measure_elpd()` | 3.0.0 | | + +**Return type change:** `elpd()` returns class `"elpd_generic"` with `elpd` and +`ic` columns in `pointwise`. `measure_elpd()` returns class `"measure"`. + +```r +# Deprecated +elpd(log_lik_matrix) + +# Current +measure_elpd(log_lik_matrix) +``` + +## Scoring rules (CRPS / SCRPS) + +| Deprecated | Replacement | Since | Planned removal | +|------------|-------------|-------|-----------------| +| `crps(x, x2, y)` | `measure_rps(y, ypred = x)` | 3.0.0 | | +| `scrps(x, x2, y)` | `measure_srps(y, ypred = x)` | 3.0.0 | | +| `loo_crps(...)` | `loo_pred_measure(..., measures = "rps")` | 3.0.0 | | +| `loo_scrps(...)` | `loo_pred_measure(..., measures = "srps")` | 3.0.0 | | + +**API change:** deprecated functions require **two** draw matrices (`x`, `x2`) +and use a permutation-based estimator. The replacement uses **one** draw +matrix (`ypred`) and a PWM estimator. Results are not identical. + +```r +# Deprecated +crps(ypred1, ypred2, y = y) + +# Current +measure_rps(y = y, ypred = ypred1) +``` + +## Leave-one-out predictive metrics + +| Deprecated | Replacement | Since | Planned removal | +|------------|-------------|-------|-----------------| +| `loo_predictive_metric()` | `loo_pred_measure()` | 3.0.0 | | + +**Argument mapping:** + +| Old (`loo_predictive_metric`) | New (`loo_pred_measure`) | +|-------------------------------|--------------------------| +| `x` (predictions) | `mupred` | +| `log_lik` | via `loo(..., save_psis = TRUE)` or `ylp` + `psis_object` | +| `metric = "mae"` | `measures = "mae"` | +| `metric = "balanced_acc"` | `measures = "bacc"` | + +```r +# Deprecated +loo_predictive_metric(x = mupred, y = y, log_lik = ll, metric = "mae") + +# Current +loo_fit <- loo(ll, save_psis = TRUE) +loo_pred_measure(loo = loo_fit, y = y, mupred = mupred, measures = "mae") +``` + +--- + +# Current predictive performance API (3.0.0) + +## Workflow entry points + +| Function | Evaluation mode | Source file | +|----------|-----------------|-------------| +| `insample_pred_measure()` | In-sample | `pred_measure.R` | +| `loo_pred_measure()` | PSIS-LOO | `pred_measure.R` | +| `kfold_pred_measure()` | K-fold CV | `pred_measure.R` | +| `test_pred_measure()` | Holdout test set | `pred_measure.R` | +| `pred_measure()` | Add measures incrementally | `pred_measure.R` | + +## Built-in measures + +Pass short names to the `measures` argument, or call standalone functions: + +| `measures =` | Function | Source file | +|-------------|----------|-------------| +| `"elpd"` | `measure_elpd()` | `pred_measure-builtin.R` | +| `"mlpd"` | `measure_mlpd()` | `pred_measure-builtin.R` | +| `"ic"` | `measure_ic()` | `pred_measure-builtin.R` | +| `"mae"` | `measure_mae()` | `pred_measure-builtin.R` | +| `"mse"` | `measure_mse()` | `pred_measure-builtin.R` | +| `"rmse"` | `measure_rmse()` | `pred_measure-builtin.R` | +| `"r2"` | `measure_r2()` | `pred_measure-builtin.R` | +| `"acc"` | `measure_acc()` | `pred_measure-builtin.R` | +| `"bacc"` | `measure_bacc()` | `pred_measure-builtin.R` | +| `"rps"` | `measure_rps()` | `pred_measure-builtin.R` | +| `"srps"` | `measure_srps()` | `pred_measure-builtin.R` | + +List all registered built-in names: + +```r +supported_measures_list() +``` + +`measure_brier()` is exported but not yet registered in `supported_measures_list()`. ## Model comparison | 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 @@ -118,65 +249,3 @@ The following are targeted for **removal** in loo 3.0.0: The deprecated option `options(loo.cores = ...)` remains for backward compatibility until a separate removal decision is made. - ---- - -# Upcoming (not yet in this branch) - -The following deprecations and migrations are **not** covered by this version -of the guide. They will be added when the predictive performance feature branch -is merged into `loo-v3.0.0`: - -- `elpd()` → `measure_elpd()` -- `crps()`, `scrps()`, `loo_crps()`, `loo_scrps()` → `measure_rps()`, `measure_srps()`, `loo_pred_measure()` -- `loo_predictive_metric()` → `loo_pred_measure()` and `measure_*()` -- New workflow entry points: `insample_pred_measure()`, `loo_pred_measure()`, - `kfold_pred_measure()`, `test_pred_measure()`, `pred_measure()` - -Until that merge, do **not** add `.Deprecated("measure_*")` or -`.Deprecated("loo_pred_measure")` warnings on this branch, because those -replacements are not yet exported here. - ---- - -# Maintainer checklist - -When deprecating or removing a function: - -1. Add `.Deprecated("replacement")` in each exported method (only if the - replacement exists in the same branch). -2. Document deprecation in roxygen (`**deprecated**`, links to replacement). -3. Add a bullet to `NEWS.md`. -4. Update this migration guide. -5. Add or update tests in `tests/testthat/test_deprecated_*.R`. -6. List the topic under **Deprecated functions** in `_pkgdown.yml`. -7. Keep the old implementation until the planned removal release. -8. On removal: delete the source file, remove from `NAMESPACE`, update this guide. - -When merging feature branches that introduce new replacements, extend the -**Function migration tables** and remove items from **Upcoming**. - ---- - -# `_pkgdown.yml` reference (this branch) - -Suggested `_pkgdown.yml` entries for this branch: - -```yaml -articles: - - title: Migration - desc: | - Guides for updating code when APIs change. - contents: - - migration-guide - -reference: - - title: Deprecated functions - contents: - - compare - - psislw -``` - -After the predictive performance feature merges, add `elpd`, `crps`, and -`loo_predictive_metric` to **Deprecated functions**, and add a **Predictive -performance measures** reference section for the new API.