diff --git a/.gitignore b/.gitignore index bc23df9e..e52fad9c 100644 --- a/.gitignore +++ b/.gitignore @@ -30,4 +30,6 @@ release-prep.R # personal maintainer scratch (not shared) internal-notes/ +notes/loo_se.pdf +notes/loo-compare-se-diff.md CRAN-SUBMISSION diff --git a/DESCRIPTION b/DESCRIPTION index 025042db..1f472cd9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -64,4 +64,3 @@ LazyData: TRUE Roxygen: list(markdown = TRUE) SystemRequirements: pandoc (>= 1.12.3), pandoc-citeproc Config/roxygen2/version: 8.0.0 -RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index 6f0be7f6..73501609 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -48,6 +48,8 @@ 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) @@ -158,6 +160,7 @@ export(measure_r2) export(measure_rmse) export(measure_rps) export(measure_srps) +export(model_compare) export(nlist) export(obs_idx) export(pareto_k_ids) diff --git a/NEWS.md b/NEWS.md index 086196b5..521ad0c4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,8 +7,111 @@ * New predictive performance API: `insample_pred_measure()`, `loo_pred_measure()`, `kfold_pred_measure()`, `test_pred_measure()`, and `pred_measure()` with built-in measures via `measure_*()` and [supported_measures_list()]. -* Update user messages in `print()` by @ishaan-arora-1, @florence-bockting in -#328. +* `loo_compare()` is now called `model_compare()`, and `loo_compare()` is + deprecated. It still works and is still a generic, so `loo_compare` methods + registered by other packages (e.g. `loo_compare.brmsfit` in **brms**, + `loo_compare.stanreg` in **rstanarm**) keep dispatching, but it now warns + (once per session) and is frozen at its previous behaviour: `"loo"`, `"waic"`, and `"kfold"` objects + compared on ELPD only, returning exactly what `model_compare()` returns for + those inputs. Comparing `pred_measure` results, or using `rank_by` or + `custom_se_fn`, requires `model_compare()`. +* `model_compare()` supports every `pred_measure` result --- from + `loo_pred_measure()`, `kfold_pred_measure()`, `test_pred_measure()`, and + `insample_pred_measure()` --- with paired differences for all measures common + to the compared models, optional `rank_by` ranking, utility-scale sign + conversion for loss measures, and `print(compare, measures = ...)` for + multi-measure tables by @florence-bockting in #380. + Measures are matched on bare names, so the source suffix (`_loo`, `_kfold`, + `_test`, or none for in-sample) is handled transparently. All models in one + call must share an evaluation source; mixing them is an error. `diag_elpd` is + reported only for `loo_pred_measure()` comparisons, k-fold comparisons warn on + differing `K`, and in-sample comparisons warn that they are optimistically + biased. +* In `model_compare()`, when `rank_by` is not supplied each measure is now + compared against *its own* best model, so e.g. `mse_diff` can be relative to a + different model than `elpd_diff`. Rows are still ordered by `"elpd"`, and each + `{measure}_diff` column has exactly one `0` entry, at that measure's best + model. Supplying `rank_by` keeps the previous behaviour of pinning the + top-ranked model as the single reference for every measure. The reference used + per measure is recorded in the `compare_reference` attribute and shown by + `print(x, measures = "all")`. Each printed measure table is now sorted by its + own difference, so the best model on that measure is always the first row and + the differences run in decreasing order. +* `print()` on a `pred_measure` comparison now always names the reference model + each set of differences was computed against, including the default case where + every measure keeps its own best model. The line is written to standard output + rather than emitted as a message, so it survives `suppressMessages()` and + knitr chunks with `message = FALSE`. For `loo_pred_measure()` comparisons the + PSIS-LOO Pareto k diagnostic moved out of the per-measure difference tables + into a block above them: it describes a model's LOO approximation, not any one + measure or pair of models, so it is now reported once per model. The + `diag_elpd` column on the returned object is unchanged, and `print()` for + plain `"loo"` comparisons is unchanged. Printed sentences are wrapped so that + no line of output exceeds 80 characters. +* Bug fix: the `diag_diff` column tested `elpd_diff > -4` rather than + `|elpd_diff| < 4`, so every positive difference was flagged as a small one. + This was only reachable with `rank_by` set to a model that is not the best + model, where differences against the reference can be positive. +* In `model_compare()`, `rank_by` now also accepts a **model name** (as shown in + the `model` column). The named model then becomes the single reference model + for every measure, whether or not it is the best one, while rows stay ordered + by `"elpd"`. This form also works for plain `"loo"` comparisons, where + `elpd_diff` is then relative to the named model. The pinned model is recorded + in the `rank_by` attribute; a name matching both a measure and a model is + treated as the measure, with a warning. +* The `diff_method` value `"pairwise"` is now called `"measure_specific"`. Every + model comparison is pairwise, and the `"sum"`/`"mean"` methods are the ones + built from paired pointwise differences, so the old name described the one + category that is *not* a paired pointwise standard deviation. `diff_method` is + read-only metadata in `measure_info`, so no user code that passes + arguments is affected; `custom_se_fn` still accepts only `"sum"` and `"mean"`. +* Bug fix: in `model_compare()`, `mlpd` was registered with + `diff_method = "sum"` although its estimate is the *mean* of the pointwise log + predictive densities. `mlpd_diff` was therefore reported as the sum of the + pointwise differences (a factor of `N` too large, and inconsistent with the + difference of the reported `mlpd` estimates), with a matching `mlpd_se_diff`. + `mlpd` now uses `diff_method = "mean"`. +* `model_compare()` gains a `custom_se_fn` argument controlling how the standard + error of a difference is computed for a **custom** measure. It accepts a + function called as `custom_se_fn(ref, cmp)`, the shorthands `"sum"` and + `"mean"` for the paired pointwise formulas, or `NULL` to report the difference + with an `NA` standard error; with two or more custom measures, pass a list + named by measure. It is required whenever a custom measure is compared --- + nothing is inferred from a measure's values any more, and custom measures now + carry `diff_method = "custom"` instead of `"auto"`. The previous + `attr(my_fun, "se_diff_fun")` route has been removed. +* A custom measure can declare that it is a loss with + `attr(my_fun, "measure_loss") <- TRUE`, alongside `attr(my_fun, + "measure_name")`. `model_compare()` then flips its differences onto the + utility scale and orders `rank_by` by the lowest loss, as it does for built-in + loss measures; without the declaration a custom measure is still treated as a + utility. The declaration is recorded as `loss` in the `measure_info` + attribute, and models that disagree on it cannot be compared. +* Measure values are always stored on the measure's own scale; `loss` is the + single setting describing a measure's orientation. Measures no longer take a + `higher_is_better` argument, `control` no longer accepts one, and results no + longer carry a `measure_higher_is_better` attribute. Comparisons were already + invariant to the setting --- `model_compare()` reports every measure on the + utility scale regardless --- so no comparison output changes. Negate the + values yourself if you want a loss stored as a utility. +* Bug fix: `rps` was registered as a utility and `srps` as a loss, but + `measure_rps()` returns the Gneiting & Raftery (2007) unscaled score, where + lower is better, and `measure_srps()` the Bolin & Wallin (2023) scaled score, + where higher is better. `model_compare()` therefore flipped `srps_diff` and + left `rps_diff` unflipped, and `rank_by = "rps"` ordered models backwards. + The registry now records `rps` as a loss and `srps` as a utility. +* The per-measure metadata attribute `measure_compare_meta` is now called + `measure_info`. +* `control` entries now work for custom measures instead of failing with + `object 'measure_' of mode 'function' was not found`. A `control` entry + naming no measure being computed now warns instead of aborting. +* `print()` on a multi-measure comparison now labels each measure's standard + error column `{measure}_se_diff`, matching the column name on the returned + data frame, instead of relabelling it `se_diff`. ELPD tables are unchanged. +* `print()` on a `pred_measure` comparison now accepts `simplify`. With + `simplify = FALSE` each measure table also shows that measure's per-model estimate and standard error, and an ELPD table also shows `p` and `se_p`. +* `model_compare(A = m1, B = m2)` now works. +* Update user messages in `print()` by @ishaan-arora-1, @florence-bockting in #328. # loo 2.10.1 diff --git a/R/compare.R b/R/compare.R index a0c7819d..c7826d44 100644 --- a/R/compare.R +++ b/R/compare.R @@ -1,6 +1,6 @@ #' Model comparison (deprecated, old version) #' -#' **This function is deprecated**. Please use the new [loo_compare()] function +#' **This function is deprecated**. Please use the new [model_compare()] function #' instead. See `vignette("migration-guide", package = "loo")` for details. #' `compare()` and `R/compare.R` are scheduled for removal in a future release. #' @@ -60,7 +60,7 @@ #' } #' compare <- function(..., x = list()) { - .Deprecated("loo_compare") + .Deprecated("model_compare") dots <- list(...) if (length(dots)) { if (length(x)) { diff --git a/R/helpers.R b/R/helpers.R index 38b401dd..7dd8156c 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -182,18 +182,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( + "\n'", old, "' is deprecated. Use '", new, "' instead.\n", + call. = TRUE, 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..4887309c 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,42 @@ #' 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. The `rank_by` and +#' `custom_se_fn` arguments are available here only. +#' +#' * [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, +#' `rank_by`, or `custom_se_fn` arguments 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 by default the best model on the measure unless +#' `model_compare()` was given `rank_by`. +#' #' @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()` by default the model with the best +#' performance per measure unless stated otherwise via `rank_by`. #' #' @section se_diff: #' @@ -161,34 +195,36 @@ #' #' 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. #' #' Because models are ordered by `elpd_loo` before computing `p_worse`, all -#' reported values are at least 0.5 by construction. A value close to 0.5 -#' indicates that the models are nearly indistinguishable in predictive -#' performance and that the ranking could easily be reversed with different -#' data. A value close to 1 indicates that the lower-ranked model is almost +#' reported values are at least 0.5 by construction. This always holds for +#' `loo_compare()`, and for `model_compare()` unless `rank_by` pins a reference +#' model that is not the best one; models better than a pinned reference then +#' have `p_worse < 0.5`. A value close to 0.5 indicates that the models are +#' nearly indistinguishable in predictive performance and that the ranking could +#' easily be reversed with different data. A value close to 1 indicates that the +#' lower-ranked model is almost #' certainly worse. `p_worse` inherits all the limitations of `se_diff` and the #' normal approximation on which it is based. In particular, when `se_diff` is #' underestimated, `p_worse` will be estimated too close to 1, making a model #' 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 +246,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 +269,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 +288,129 @@ #' 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 and the `rank_by` and `custom_se_fn` +#' arguments. +#' +#' 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 the `rank_by` argument +#' (default `"elpd"`). By default each measure is compared against the model +#' that is best on that measure, so different difference columns may use +#' different reference models. Supplying `rank_by` pins the top-ranked model as +#' the single reference for all difference columns. +#' +#' ### `{measure}_diff` and `{measure}_se_diff` +#' +#' For each non-ELPD measure `m`, `model_compare()` adds columns `m_diff` and +#' `m_se_diff`. In all cases `m_diff` is the difference between the two overall +#' estimates on a utility scale (higher is better; loss measures such as MSE, +#' Brier score, and SRPS have their sign flipped from the raw loss orientation). +#' Measures already returned on a utility scale (e.g. ELPD, CRPS/RPS) are not +#' sign-flipped. Negative `m_diff` values then indicate worse performance than +#' the reference model, which has `m_diff = 0`. +#' +#' How `m_se_diff` is obtained depends on the measure: +#' +#' * When the overall estimate is a sum or mean of pointwise contributions, it +#' is computed from paired pointwise differences using the same approach as +#' `elpd_diff` and `se_diff` (Eq 24 in VGG2017 for sums; the mean analogue for +#' means). This covers ELPD, `mlpd`, `ic`, `mae`, `mse`, `acc`, `brier`, and +#' the ranked probability scores. +#' * When a built-in measure is a transformation of such quantities, it supplies +#' its own delta-method standard error (`se_diff_fun`). For `rmse` this is the +#' first-order bivariate Taylor approximation propagated from the MSE scale, +#' which requires the covariance between the two models' pointwise squared +#' errors and is therefore not a paired pointwise standard deviation. For +#' `r2` it is the trivariate analogue, which additionally propagates the +#' uncertainty in the baseline `MSE(y)` shared by both models. +#' * For custom measures it comes from the `custom_se_fn` argument of +#' [model_compare()], which must be supplied whenever a custom measure is +#' compared. It is `NA` when `custom_se_fn` is `NULL` for that measure. +#' +#' 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; when a loss is +#' compared on a utility scale, `model_compare()` emits a short message naming +#' those measures (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 is resolved at +#' comparison time from the `custom_se_fn` argument of [model_compare()], +#' which supplies either a function, the `"sum"`/`"mean"` pointwise formulas, +#' or `NULL` 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. Custom measures never store a function here. +#' * `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 +#' `custom_se_fn`. 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` from `attr(my_fun, "measure_loss") <- TRUE`, which declares +#' that lower values are better; without it they are treated as utilities (see +#' [insample_pred_measure()]). +#' [model_compare()] requires all models to provide matching `measure_info` for +#' each shared measure; a mismatched `measure_loss` declaration, or missing +#' `measure_info` on some models, produces an error. +#' +#' ### `rank_by`, `compare_measures`, and related attributes +#' +#' The `rank_by` argument takes either a measure name or a model name. A +#' measure name selects which measure determines model ordering, and pins the +#' top-ranked model as the single reference model for all pairwise differences. +#' A model name keeps the `"elpd"` ordering but pins that model as the single +#' reference model, whether or not it is the best one. When `rank_by` is +#' omitted, models are ordered by `"elpd"` and each measure is compared against +#' its own best model. Attribute `rank_by` records which of these three cases +#' applied, as a list with elements `kind` (`"default"`, `"measure"`, or +#' `"model"`), `measure` (the measure the rows are ordered by, always set) and +#' `model` (the pinned reference model, or `NULL`). 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 +#' (`"elpd"` when `rank_by` was not set); 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 10b1bdc7..89a34227 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 #' @@ -511,18 +511,6 @@ mcse_elpd <- function(ll, lw, E_elpd, r_eff, n_samples = NULL) { sqrt(var_elpd) } - -#' 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..09613148 100644 --- a/R/loo_compare.R +++ b/R/loo_compare.R @@ -1,106 +1,39 @@ -#' 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, or using the `rank_by` and +#' `custom_se_fn` arguments, 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 -#' -#' 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) #' loo_compare <- function(x, ...) { UseMethod("loo_compare") @@ -109,355 +42,34 @@ 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) + .deprecate_once("loo_compare", new = "model_compare") - 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." + # `loo_compare()` keeps its old signature, so the arguments added to + # `model_compare()` would arrive through `...` and be mistaken for models. + new_args <- intersect(names(list(...)), c("rank_by", "custom_se_fn")) + if (length(new_args)) { + stop( + "`", new_args[1L], "` is not supported by the deprecated `loo_compare()`. ", + "Use `model_compare()` instead.", + call. = FALSE ) } - 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] -} - -#' 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_subsample.R b/R/loo_subsample.R index bcac4b17..87e8c4fd 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..fc78585b --- /dev/null +++ b/R/model_compare-pred_measure.R @@ -0,0 +1,856 @@ +#' 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 + ) + } + # `loos` may be a named list, which would make `vapply()` return a named + # vector and break the `identical()` checks against a bare string. + 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. +#' @param rank_by Bare measure name used to order models. +#' @param custom_se_fn How to compute the standard error of the difference for +#' custom measures, see `.resolve_custom_se_fns()`. +#' @param custom_se_fn_supplied Whether `custom_se_fn` was given at all, as +#' opposed to being an explicit `NULL`. +compare_pred_measure <- function(loos, rank_by = NULL, custom_se_fn = NULL, + custom_se_fn_supplied = FALSE) { + # Resolve the source before the generic checks: mixed sources usually also + # differ in their number of observations, and "you mixed LOO with k-fold" is + # far more actionable than "your models have different N". + 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) + } + .compare_metadata_check(loos) + throw_omitted_compare_measures_warning(loos) + + rank_spec <- .resolve_rank_by(loos, rank_by) + rank_measure <- rank_spec$measure + compare_cols <- .compare_pointwise_cols(loos) + custom_se_fns <- .resolve_custom_se_fns( + loos, + compare_cols, + custom_se_fn, + custom_se_fn_supplied + ) + inform_compare_sign_conversion(compare_cols, loos) + ord <- model_compare_order(loos, rank_measure$internal) + loos_ord <- loos[ord] + # With an explicit `rank_by` a single model is the reference for every + # measure: the top-ranked one when `rank_by` names a measure, the named one + # when it names a model. Without `rank_by`, each measure gets its own best + # model as reference, so e.g. `mse_diff` may be relative to a different model + # than `elpd_diff`. + per_measure_ref <- identical(rank_spec$kind, "default") + + comp <- model_compare_matrix( + loos_ord, + bare_names = TRUE, + ord = seq_along(loos_ord) + ) + rnms <- rownames(comp) + n_obs <- nrow(loos_ord[[1L]]$pointwise) + pinned_ref_idx <- if (identical(rank_spec$kind, "model")) { + match(rank_spec$model, rnms) + } else { + 1L + } + + diff_cols <- list() + ref_models <- character(0) + for (col in compare_cols) { + bare <- .display_name(col, loos_ord) + ref_idx <- if (per_measure_ref) { + model_compare_order(loos_ord, col)[[1L]] + } else { + pinned_ref_idx + } + 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_fns[[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 + } + } + + # `diag_elpd` reports PSIS Pareto k, which only exists for the LOO source; + # for the others it would be an all-blank column. + 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 + ) + + # `rank_by` records how the reference was chosen, as a tagged record: `kind` + # is the branch taken, `measure` is the measure rows are ordered by (always + # set), and `model` is the pinned reference model, or `NULL`. `kind` is kept + # because a name can match both a measure and a model. + attr(comp, "rank_by") <- list( + kind = rank_spec$kind, + measure = rank_measure$bare, + model = rank_spec$model + ) + attr(comp, "compare_reference") <- ref_models + attr(comp, "compare_source") <- source + 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 +} + +#' Map bare measure name to `pointwise` column name +#' @noRd +.pointwise_col <- function(name, cols, loos = NULL) { + if (name %in% cols) { + return(name) + } + internal <- paste0(name, .compare_suffix(loos)) + if (internal %in% cols) { + return(internal) + } + stop( + paste0( + "Measure '", name, "' not found in all models. ", + "Available measures: ", + paste(vapply(cols, .display_name, character(1), loos = loos), collapse = ", ") + ), + call. = FALSE + ) +} + +#' 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[!grepl("^p_", cols)] +} + +#' 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 + ) + } + # `extra` holds per-measure auxiliary data (for `r2`, the pointwise + # baseline derived from `y`), which legitimately differs when models are + # fitted to different data. That case is already reported by the `yhash` + # warning, so comparing `extra` here would only mislabel it as a + # disagreement about the measure itself. + non_null <- lapply(infos[has_info], function(info) { + info$extra <- NULL + info + }) + if (length(non_null) > 1L) { + ref <- non_null[[1L]] + inconsistent <- vapply( + non_null[-1L], + function(info) !identical(info, ref), + logical(1) + ) + if (any(inconsistent)) { + stop( + "Models disagree on `measure_info` for measure '", + bare, + "'. For a custom measure, ensure all models use the same ", + "`measure_loss` declaration.", + 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[!grepl("^p_", cols)] + 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)) +} + +#' Resolve `rank_by` to bare and internal `pointwise` column names +#' @noRd +.resolve_rank_measure <- function(loos, rank_by = NULL) { + cols <- .compare_pointwise_cols(loos) + bare <- if (is.null(rank_by)) "elpd" else rank_by + internal <- .pointwise_col(bare, cols, loos) + list( + bare = .display_name(internal, loos), + internal = internal + ) +} + +#' Match `rank_by` against the measures shared by all models +#' +#' Like `.pointwise_col()` but returns `NULL` instead of erroring, so callers +#' can fall back to interpreting `rank_by` as a model name. +#' @noRd +.match_rank_measure <- function(loos, rank_by, cols) { + if (rank_by %in% cols) { + return(rank_by) + } + internal <- paste0(rank_by, .compare_suffix(loos)) + if (internal %in% cols) { + return(internal) + } + NULL +} + +#' Resolve `rank_by` to either a measure or a reference model +#' +#' `rank_by` accepts a bare measure name (rank models by that measure and use +#' the top-ranked model as reference) or a model name (keep the default `elpd` +#' ordering but pin that model as the reference for every measure). +#' @noRd +#' @return A list with `kind` (`"default"`, `"measure"`, or `"model"`), +#' `measure` (the resolved ranking measure, as `.resolve_rank_measure()` +#' returns it) and `model` (the pinned reference model name, or `NULL`). +.resolve_rank_by <- function(loos, rank_by = NULL) { + if (is.null(rank_by)) { + return(list( + kind = "default", + measure = .resolve_rank_measure(loos), + model = NULL + )) + } + + if (!is.character(rank_by) || length(rank_by) != 1L || is.na(rank_by)) { + stop( + "`rank_by` must be a single measure name or model name.", + call. = FALSE + ) + } + + cols <- .compare_pointwise_cols(loos) + internal <- .match_rank_measure(loos, rank_by, cols) + model_names <- find_model_names(loos) + + if (!is.null(internal) && rank_by %in% model_names) { + warning( + "`rank_by = \"", rank_by, "\"` matches both a measure and a model name; ", + "ranking by the measure. Rename the model to rank by the model instead.", + call. = FALSE + ) + } + + if (!is.null(internal)) { + return(list( + kind = "measure", + measure = list( + bare = .display_name(internal, loos), + internal = internal + ), + model = NULL + )) + } + + if (rank_by %in% model_names) { + return(list( + kind = "model", + measure = .resolve_rank_measure(loos), + model = rank_by + )) + } + + stop( + paste0( + "`rank_by` value '", rank_by, "' is neither a measure nor a model name. ", + "Available measures: ", + paste(vapply(cols, .display_name, character(1), loos = loos), collapse = ", "), + ". Available models: ", + paste(model_names, collapse = ", "), + "." + ), + call. = FALSE + ) +} + +#' 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) + )]) +} + +#' Inform when measure signs are flipped for comparison +#' @noRd +inform_compare_sign_conversion <- function(cols, loos) { + converted <- .compare_sign_converted_measures(cols, loos) + if (!length(converted)) { + return(invisible(NULL)) + } + message( + "For model comparison, differences for ", + paste(converted, collapse = ", "), + " ", + if (length(converted) == 1L) "is" else "are", + "\nreported on a utility scale (higher is better)." + ) + invisible(NULL) +} + +#' 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 is +#' supplied at comparison time through `model_compare(custom_se_fn = )`. +#' 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 the user declares `custom_se_fn = "sum"` or `"mean"` for a +#' 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( + "`custom_se_fn = \"", method, "\"` was declared for measure '", + .display_name(col, loos), "', but ", method, + "(pointwise) does not reproduce its estimate.\n", + "The reported standard error may be wrong.", + call. = FALSE + ) + } + invisible(NULL) +} + +#' Resolve a built-in measure's `se_diff_fun` +#' +#' Built-in measures with `diff_method = "measure_specific"` name an entry of +#' `.se_diff_funs`. Custom measures never reach this; their standard error comes +#' from `model_compare(custom_se_fn = )`, see `.resolve_custom_se_fns()`. +#' @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 `custom_se_fn` +#' @noRd +.custom_se_fn_keywords <- c("sum", "mean") + +#' Validate one `custom_se_fn` value +#' @noRd +#' @return The value itself, or `NULL`. +.check_custom_se_fn_value <- function(value, bare) { + if (is.null(value) || is.function(value)) { + return(value) + } + if (is.character(value) && length(value) == 1L && + value %in% .custom_se_fn_keywords) { + return(value) + } + stop( + "Invalid `custom_se_fn` for measure '", bare, + "'. It must be a function, ", + paste0("\"", .custom_se_fn_keywords, "\"", collapse = " or "), + ", or NULL.", + call. = FALSE + ) +} + +#' Message listing what `custom_se_fn` accepts +#' @noRd +.custom_se_fn_help <- function() { + paste0( + "Pass a function computing the standard error of the difference, ", + paste0("\"", .custom_se_fn_keywords, "\"", collapse = " or "), + "\nto use the paired pointwise formula, or NULL to report the difference ", + "with an NA standard error." + ) +} + +#' Resolve `custom_se_fn` to a per-measure lookup +#' +#' Custom measures carry `diff_method = "custom"` and declare nothing about +#' their standard error, so the person running the comparison supplies it. A +#' bare value is only unambiguous when exactly one custom measure is compared; +#' otherwise a list keyed by bare measure name is required. +#' @noRd +#' @param custom_se_fn The user's `custom_se_fn` argument, already normalised to +#' `NULL` when it was not supplied. +#' @param supplied Whether the argument was given at all, as opposed to being +#' an explicit `NULL`. +#' @return Named list keyed by bare measure name; each element is a function, +#' `"sum"`, `"mean"`, or `NULL`. +.resolve_custom_se_fns <- function(loos, compare_cols, custom_se_fn, supplied) { + 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)) { + if (supplied) { + warning( + "`custom_se_fn` is only used for custom measures and will be ignored.", + call. = FALSE + ) + } + return(list()) + } + + if (!supplied) { + stop( + if (length(custom_bare) == 1L) "Measure '" else "Measures '", + paste(custom_bare, collapse = "', '"), + if (length(custom_bare) == 1L) { + "' is a custom measure, so `custom_se_fn` must be supplied.\n" + } else { + "' are custom measures, so `custom_se_fn` must be supplied.\n" + }, + .custom_se_fn_help(), + call. = FALSE + ) + } + + # A bare function or keyword: unambiguous only for a single custom measure. + if (is.null(custom_se_fn) || is.function(custom_se_fn) || + is.character(custom_se_fn)) { + if (!is.null(custom_se_fn) && length(custom_bare) > 1L) { + stop( + "`custom_se_fn` must be a named list when more than one custom measure ", + "is compared.\nName an entry for each of: ", + paste(custom_bare, collapse = ", "), ".", + call. = FALSE + ) + } + value <- .check_custom_se_fn_value(custom_se_fn, custom_bare[[1L]]) + return(stats::setNames(rep(list(value), length(custom_bare)), custom_bare)) + } + + if (!is.list(custom_se_fn)) { + stop( + "`custom_se_fn` must be a function, ", + paste0("\"", .custom_se_fn_keywords, "\"", collapse = " or "), + ", NULL, or a named list of those.", + call. = FALSE + ) + } + + nms <- names(custom_se_fn) + if (length(custom_se_fn) && (is.null(nms) || any(!nzchar(nms)))) { + stop( + "Every element of `custom_se_fn` must be named after a custom measure. ", + "Expected name(s): ", + paste(custom_bare, collapse = ", "), ".", + call. = FALSE + ) + } + unknown <- setdiff(nms, custom_bare) + if (length(unknown)) { + stop( + "Unknown measure(s) in `custom_se_fn`: ", + paste(unknown, collapse = ", "), + ". Custom measure(s) compared: ", + paste(custom_bare, collapse = ", "), ".", + call. = FALSE + ) + } + missing_measures <- setdiff(custom_bare, nms) + if (length(missing_measures)) { + stop( + "`custom_se_fn` has no entry for custom measure(s): ", + paste(missing_measures, collapse = ", "), ".\n", + .custom_se_fn_help(), + call. = FALSE + ) + } + + stats::setNames( + lapply(custom_bare, function(bare) { + .check_custom_se_fn_value(custom_se_fn[[bare]], bare) + }), + custom_bare + ) +} + +#' 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` or `custom_se_fn` +#' @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 value resolved from +#' `model_compare(custom_se_fn = )` for this measure. 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)) { + # "sum"/"mean" reuse the paired pointwise branch below, so a custom + # measure declaring "mean" behaves exactly like the built-in `mae`. + 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, what = "custom_se_fn") + )) + } + } + + 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..c437d071 --- /dev/null +++ b/R/model_compare-print.R @@ -0,0 +1,470 @@ +#' @rdname model_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 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 its own measure's estimate and +#' standard error, and an ELPD table also gains `p` and `se_p`. +#' @param measures For `loo_pred_measure` comparisons only, which measures to +#' print diff tables for. `NULL` (default) prints only the ranking measure +#' (`"elpd"` when `rank_by` was not set, otherwise `rank_by`); +#' `"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 = 1, 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 (!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) + + rank_spec <- attr(x, "rank_by") + if (identical(rank_spec$kind, "model")) { + message("Differences computed against model ", rank_spec$model, ".") + } + .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) { + rank_spec <- attr(x, "rank_by") + compare_measures <- attr(x, "compare_measures") + compare_source <- attr(x, "compare_source") + primary_measure <- if (is.null(rank_spec)) "elpd" else rank_spec$measure + + 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(...)`." + ) + } + + # The reference is always named, whichever way it was chosen: without + # `rank_by` each measure keeps its own best model, which is the case most in + # need of saying so and the only one that used to say nothing. + # Printed rather than messaged: it labels the tables below, and `message()` + # output is suppressed wholesale by knitr chunks and `suppressMessages()`. + .cat_wrapped( + .compare_reference_line(x, rank_spec, compare_measures) + ) + + # LOO is the familiar default, so only name the source when it is not LOO. + # Spelled out for a full sentence, unlike the short per-object tag from + # `.pred_measure_source_label()`. + if (!is.null(compare_source) && !identical(compare_source, "loo")) { + .cat_wrapped( + "Predictive measures evaluated on ", + switch( + compare_source, + kfold = "K-fold cross-validation", + test = "held-out test data", + insample = "in-sample (training) data", + compare_source + ), + "." + ) + } + + # Pareto k is a property of a model's PSIS-LOO approximation, not of any one + # measure or of the comparison, so it is reported once for all models rather + # than as a column inside a per-measure difference table. + psis_shown <- .print_psis_diag_block(x) + # A per-measure header already opens with a blank line; only the single-table + # form needs one inserted here. + if (psis_shown && is.null(measures)) { + cat("\n") + } + + for (measure in measures_to_print) { + if (!is.null(measures)) { + cat( + "\n-- ", measure, " (vs ", .measure_ref_model(x, measure), ") --\n", + sep = "" + ) + } + .print_compare_measure_table( + x, + measure = measure, + digits = digits, + p_worse = p_worse, + simplify = simplify + ) + } + + 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) +} + +#' Header line naming the reference each difference is computed against +#' +#' Always printed, so the reference is never left implicit. `rank_by` pins one +#' reference for every measure; without it each measure keeps its own best +#' model, which is the case most in need of being spelled out. +#' @noRd +#' @param x A `"compare.loo"` data frame. +#' @param rank_spec Attribute `rank_by`, or `NULL` for an object created before +#' it was set. +#' @param compare_measures Bare names of all compared measures. +#' @return A single string. +.compare_reference_line <- function(x, rank_spec, compare_measures) { + if (identical(rank_spec$kind, "measure")) { + return(paste0( + "Models ranked by ", rank_spec$measure, + " (reference: ", .measure_ref_model(x, rank_spec$measure), ")." + )) + } + if (identical(rank_spec$kind, "model")) { + return(paste0("All measures compared against model ", rank_spec$model, ".")) + } + + 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, ")." + )) + } + # Naming every reference stops being readable once there are many measures. + if (length(compare_measures) > 4L) { + return("Each measure compared against its own best model.") + } + 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 = "") +} + +#' 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) { + 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 `rank_by`), 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) + + x2 <- data.frame( + model = x$model[ord], + diff = unname(.fr(x[[diff_col]][ord], digits)), + se_diff = unname(.fr(x[[se_col]][ord], digits)), + 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)`). `simplify = FALSE` adds + # the pair this table's own measure owns, after the diagnostic columns, as + # the classic path does. `p` is an ELPD companion, so it rides with it. + if (!simplify) { + est_cols <- c(measure, paste0("se_", measure)) + if (.is_elpd_measure(measure)) { + est_cols <- c(est_cols, "p", "se_p") + } + for (col in intersect(est_cols, colnames(x))) { + x2[[col]] <- unname(.fr(x[[col]][ord], digits)) + } + } + + 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) { + diag_cols <- c("diag_elpd") + if (is.null(measures) || "elpd" %in% measures) { + diag_cols <- c("diag_diff", diag_cols) + } else if (!is.null(measures)) { + elpd_measures <- measures[vapply(measures, .is_elpd_measure, logical(1))] + if (length(elpd_measures)) { + diag_cols <- c("diag_diff", diag_cols) + } + } + + 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..43d572e5 --- /dev/null +++ b/R/model_compare.R @@ -0,0 +1,805 @@ +#' 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. +#' @param rank_by A single string naming either a **measure** or a **model**, +#' used to pin one reference model for all pairwise differences. +#' +#' A **measure name** ([`pred_measure`][pred_measure] comparisons only) orders +#' models by that measure and makes the top-ranked model the reference. Bare +#' names are matched regardless of source, so `rank_by = "rmse"` selects +#' `rmse_loo`, `rmse_kfold`, or `rmse_test` as appropriate. +#' +#' A **model name** (one of the names in the `model` column, i.e. the list +#' names or `model1`, `model2`, ...) pins that model as the reference, +#' whichever model performs best, and leaves rows ordered by `"elpd"`. This +#' form also works for classic comparisons, where `elpd_diff` is then relative +#' to the named model rather than to the best one. A name matching both a +#' measure and a model is treated as the measure, with a warning. +#' +#' With `rank_by = NULL` (the default) rows are ordered by `"elpd"` and each +#' measure is compared against *its own* best model, so `mse_diff` may use a +#' different reference than `elpd_diff`. Each `{measure}_diff` column then has +#' exactly one `0` entry, at that measure's best model. +#' @param custom_se_fn How to compute the standard error of the difference +#' between two models for a **custom** measure. Required whenever a custom +#' measure is compared; nothing is inferred from the measure's values. One of: +#' \itemize{ +#' \item a **function** called as `custom_se_fn(ref, cmp)` (see +#' **Custom measure standard errors** below); +#' \item `"sum"`, for a measure whose estimate is the sum of its pointwise +#' values, giving `sqrt(N) * sd(d_i)` as for `elpd`; +#' \item `"mean"`, for a measure whose estimate is the mean of its pointwise +#' values, giving `sd(d_i) / sqrt(N)` as for `mae`; +#' \item `NULL`, to report the difference with an `NA` standard error. +#' } +#' For two or more custom measures, pass a list named by bare measure name, +#' e.g. `list(huber = "mean", nrmse = my_se_fn)`. Ignored, with a warning, +#' when no custom measure is present. +#' +#' @section Custom measure standard errors: +#' A function passed as `custom_se_fn` is called once per comparison as +#' `custom_se_fn(ref = , cmp = )`, with **named** arguments. Each +#' argument describes one model and has elements `estimate` (scalar), `se` +#' (that model's own standard error), `pointwise` (a plain numeric vector, not +#' a matrix), and `extra` (whatever the measure returned as `extra`, or +#' `NULL`). All values are on the measure's natural scale, so the function +#' does not need to account for the utility-scale conversion applied to the +#' reported differences. It must return the standard error of the difference +#' as a numeric scalar. For example: +#' +#' ``` +#' my_se_fn <- function(ref, cmp) { +#' d <- cmp$pointwise - ref$pointwise +#' sd(d) / sqrt(length(d)) +#' } +#' ``` +#' +#' @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{`rank_by`}{ +#' How the reference model was chosen, as a list with elements `kind` +#' (`"default"`, `"measure"`, or `"model"`, for the three cases described +#' under `rank_by` above), `measure` (bare name of the measure the rows +#' are ordered by, always set, `"elpd"` by default) and `model` (the +#' pinned reference model, or `NULL` unless `kind` is `"model"`). +#' } +#' \item{`compare_reference`}{ +#' A named character vector giving, for each measure, the model its +#' differences were computed against. All entries name the same model +#' unless `kind` is `"default"`. +#' } +#' \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"`. +#' } +#' } +#' `rank_by` and `compare_reference` are 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`. See `rank_by` for how that +#' reference is chosen. When it is the best model on a measure, as in classic +#' comparisons, the remaining differences for that measure are all negative. +#' +#' The standard error of a difference is a paired estimate, which uses the +#' fact that the same \eqn{N} data points were used for both models. It should +#' not be expected to equal the difference of the two models' standard errors. +#' +#' ## `p_worse`, `diag_diff`, and `diag_elpd` +#' `p_worse` is the probability that a model has worse ELPD than the reference +#' model, computed with a normal approximation from `elpd_diff` and `se_diff`. +#' Sivula et al. (2025) give the conditions under which that approximation is +#' good; `diag_diff` reports the two that fail most often: +#' +#' * `N < 100` (small data) +#' * `|elpd_diff| < 4` (models make similar predictions) +#' +#' Either message means the error distribution is skewed or thick tailed, the +#' normal approximation is not well calibrated, and `p_worse` is likely too +#' large. If `|elpd_diff|` is many times `se_diff` the difference is +#' quite certain. Model misspecification and outliers also skew the error +#' distribution, and can be diagnosed with the usual predictive checks. +#' +#' `diag_elpd` reports the PSIS-LOO Pareto \eqn{\hat{k}} diagnostic for each +#' model's pointwise ELPD. An entry `K k_psis > 0.7`, where `K` counts the +#' high Pareto \eqn{\hat{k}} values, warns of possible bias in `elpd_diff` +#' favoring models with many such values. Pareto \eqn{\hat{k}} describes a +#' model's PSIS-LOO approximation rather than any one measure or pair of +#' models, and every LOO measure uses the same importance weights, so for +#' `pred_measure` comparisons `print()` reports it once per model in a block +#' above the difference tables instead of as a column inside one of them. The +#' `diag_elpd` column is still returned on the object. +#' +#' ## Comparing `pred_measure` objects +#' When all inputs are predictive measure results sharing one evaluation +#' source, paired differences are computed for every measure present in all +#' models. Measures are matched on their bare names, so the source suffix +#' (`_loo`, `_kfold`, `_test`, or none for in-sample) is handled +#' transparently. When the models were evaluated on different `measure` sets, +#' only the shared measures are compared and a warning lists the omitted ones. +#' +#' The data frame carries one row order for all measures, but each *printed* +#' measure table is sorted by its own difference, so the best model on that +#' measure always leads its table and the differences run in decreasing order. +#' Use `print(x, measures = "all")` to display a table for every compared +#' measure; see [loo-glossary] for column definitions. +#' +#' ## Utility scale and sign conversion +#' Measures differ in orientation in their raw form: ELPD and SRPS/SCRPS are +#' utilities (higher is better), while MSE, RPS/CRPS and the Brier score are +#' losses (lower is better). All `{measure}_diff` values are reported on a +#' common utility scale, so loss measures have their sign flipped and a +#' negative `{measure}_diff` always means worse performance than the +#' reference. Which measures are losses is recorded in the `loss` element of +#' each measure's entry in the `measure_info` attribute of an +#' `*_pred_measure()` result. The flipped measures are named in the +#' `sign_converted_measures` attribute and in a message, for example: +#' "For model comparison, differences for mse are reported on a utility scale +#' (higher is better)." +#' +#' A custom measure is treated as a utility unless it declares otherwise with +#' `attr(my_fun, "measure_loss") <- TRUE`. The declaration also determines the +#' direction of `rank_by`, 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"`: a custom measure declares nothing, so `custom_se_fn` must be +#' supplied. `{measure}_se_diff` is `NA` only when `custom_se_fn` is an +#' explicit `NULL` for that measure. +#' +#' ## 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 `rank_by` 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 +#' [Differences and their standard errors in model comparison](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 and when the normal approximation behind +#' `p_worse` can be trusted. +#' @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), +#' measure = c("rmse", "r2") +#' ) +#' pm2 <- loo_pred_measure( +#' loo = loo(fit2, save_psis = TRUE), +#' y = fit2$data$Reaction, +#' mupred = brms::posterior_epred(fit2), +#' measure = c("rmse", "r2") +#' ) +#' comp <- model_compare(pm1, pm2) +#' print(comp) # ranked by elpd (default) +#' print(comp, measures = "all") # all measure diff tables +#' model_compare(pm1, pm2, rank_by = "rmse") +#' +#' # `rank_by` also takes a model name: every measure is then compared +#' # against that model, whether or not it is the best one +#' model_compare(list(m1 = pm1, m2 = pm2), rank_by = "m1") +#' +#' # the same works for k-fold CV; `rank_by` still takes the bare name +#' # even though the measures are stored as `elpd_kfold`, `rmse_kfold`, ... +#' kf1 <- brms::kfold(fit1, K = 5, save_fits = TRUE) +#' kf2 <- brms::kfold(fit2, K = 5, save_fits = TRUE) +#' kpm1 <- kfold_pred_measure( +#' y = fit1$data$Reaction, +#' mupred = brms::kfold_predict(kf1, method = "fitted")$yrep, +#' kfold = kf1, +#' measure = "rmse" +#' ) +#' kpm2 <- kfold_pred_measure( +#' y = fit2$data$Reaction, +#' mupred = brms::kfold_predict(kf2, method = "fitted")$yrep, +#' kfold = kf2, +#' measure = "rmse" +#' ) +#' model_compare(kpm1, kpm2, rank_by = "rmse") +#' +#' # mixing evaluation sources is an error +#' try(model_compare(pm1, kpm2)) +#' } +#' } +#' +model_compare <- function(x, ..., rank_by = NULL, custom_se_fn) { + if (missing(x)) { + dots <- list(...) + if (!length(dots)) { + stop("No models supplied.", call. = FALSE) + } + # `custom_se_fn` has no default: omitted and explicit `NULL` differ, so it + # is forwarded only when the caller supplied it. + args <- list(dots, rank_by = rank_by) + if (!missing(custom_se_fn)) { + args$custom_se_fn <- custom_se_fn + } + return(do.call(model_compare, args)) + } + UseMethod("model_compare") +} + +#' @rdname model_compare +#' @export +model_compare.default <- function(x, ..., rank_by = NULL, custom_se_fn) { + # `custom_se_fn` is deliberately given no default: an omitted argument and an + # explicit `NULL` mean different things (error vs. "report an NA se_diff"). + custom_se_fn_supplied <- !missing(custom_se_fn) + if (!custom_se_fn_supplied) { + custom_se_fn <- NULL + } + + loos <- .model_compare_inputs(x, ...) + + # if subsampling is used + if (any(sapply(loos, inherits, "psis_loo_ss"))) { + if (custom_se_fn_supplied) { + stop( + "`custom_se_fn` is not supported for subsampled loo objects, which ", + "are compared on elpd only.", + call. = FALSE + ) + } + 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, + rank_by = rank_by, + custom_se_fn = custom_se_fn, + custom_se_fn_supplied = custom_se_fn_supplied + )) + } + + 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 + ) + } + + # For plain `loo` objects only the model-name form of `rank_by` applies: + # there is a single measure (elpd), so there is nothing to rank by. + ref_model <- NULL + if (!is.null(rank_by)) { + if (is.character(rank_by) && length(rank_by) == 1L && + !is.na(rank_by) && rank_by %in% find_model_names(loos)) { + ref_model <- rank_by + } else { + warning( + "`rank_by` is only used for `pred_measure` comparisons, or to name the ", + "reference model, and will be ignored.", + call. = FALSE + ) + } + } + if (custom_se_fn_supplied) { + warning( + "`custom_se_fn` is only used for `pred_measure` comparisons and will be ignored.", + 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) + ref_idx <- if (is.null(ref_model)) 1L else match(ref_model, rnms) + diffs <- mapply(FUN = elpd_diffs, loos[ord[ref_idx]], 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 reference model + # (the best model unless `rank_by` named one) 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"`: `rank_by` records how the reference was chosen and + # `compare_reference` names the model it resolved to. + attr(comp, "rank_by") <- list( + kind = if (is.null(ref_model)) "default" else "model", + measure = "elpd", + model = ref_model + ) + attr(comp, "compare_reference") <- c(elpd = rnms[[ref_idx]]) + class(comp) <- c("compare.loo", class(comp)) + comp +} + +#' Reference model a measure's differences were computed against +#' +#' Without `rank_by` 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) +} + +#' 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) + } 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 58% rename from R/loo_compare.psis_loo_ss_list.R rename to R/model_compare.psis_loo_ss_list.R index 5ef5f202..a216fd81 100644 --- a/R/loo_compare.psis_loo_ss_list.R +++ b/R/model_compare.psis_loo_ss_list.R @@ -2,27 +2,38 @@ #' @noRd #' @param x A list with `psis_loo` objects. #' @param ... Currently ignored. +#' @param custom_se_fn Not supported here; subsampled objects are compared on +#' elpd only. Explicit argument here such that a caller does not absorb it +#' into ... and silently ignore. #' @return A `compare.loo_ss` object. -#' @author Mans Magnusson #' @export -loo_compare.psis_loo_ss_list <- function(x, ...) { +model_compare.psis_loo_ss_list <- function(x, ..., custom_se_fn) { + if (!missing(custom_se_fn)) { + stop( + "`custom_se_fn` is not supported for subsampled loo objects, which are ", + "compared on elpd only.", + call. = FALSE + ) + } 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)[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 @@ -36,7 +47,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 +63,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,22 +76,22 @@ 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") @@ -99,9 +110,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") @@ -124,54 +135,8 @@ loo_compare_ss_diff <- function(ref_loo, compare_loo){ } -#' 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 +#' @rdname model_compare #' @export print.compare.loo_ss <- function(x, ..., digits = 1) { xcopy <- x @@ -181,28 +146,3 @@ print.compare.loo_ss <- function(x, ..., digits = 1) { print(.fr(xcopy, digits), quote = FALSE) invisible(x) } - - -#' Compute comparison matrix for `psis_loo_ss` objects -#' @noRd -#' @keywords internal -#' @param loos List of `psis_loo_ss` objects. -#' @return A `compare.loo_ss` matrix. -loo_compare_matrix.psis_loo_ss_list <- function(loos){ - tmp <- sapply(loos, function(x) { - est <- x$estimates - setNames(c(est), nm = c(rownames(est), - paste0("se_", rownames(est)), - paste0("subsampling_se_", rownames(est)))) - }) - colnames(tmp) <- find_model_names(loos) - rnms <- rownames(tmp) - comp <- tmp - ord <- loo_compare_order(loos) - comp <- t(comp)[ord, ] - patts <- c("elpd", "p_", "^waic$|^looic$", "se_waic$|se_looic$") - col_ord <- unlist(sapply(patts, function(p) grep(p, colnames(comp))), - use.names = FALSE) - comp <- comp[, col_ord] - comp -} diff --git a/R/pred_measure-builtin.R b/R/pred_measure-builtin.R index 0881f99b..2b5d2d02 100644 --- a/R/pred_measure-builtin.R +++ b/R/pred_measure-builtin.R @@ -5,11 +5,6 @@ #' before computing each per-observation contribution. #' @param pointwise Optional numeric vector of precomputed per-observation #' contributions. When supplied, `ylp` and `log_weights` are ignored. -#' @param higher_is_better Logical or `NULL`; whether larger values indicate -#' better predictive performance. `NULL` (default) keeps each measure's -#' natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -#' Set `TRUE` for a utility scale (higher is better) or `FALSE` for a loss -#' scale (lower is better). #' #' @return An object of class `"measure"`: a list with: #' \describe{ @@ -117,7 +112,6 @@ ptw_log_pred_density <- function(ylp, psis_log_weights = NULL) { #' pointwise log predictive density contributions (\eqn{\mathrm{lppd}_i}), using #' [ptw_log_pred_density()]. ELPD is returned on the utility scale (higher is #' better), consistent with the sign convention used throughout this package. -#' Manual change of sign convention is possible via `higher_is_better`. #' #' @inheritParams measure_density_params #' @inheritParams measure_params @@ -144,7 +138,7 @@ ptw_log_pred_density <- function(ylp, psis_log_weights = NULL) { #' measure_elpd(LLarr) #' @export measure_elpd <- function( - ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL + ylp, log_weights = NULL, pointwise = NULL ) { inputs <- .lppd_from_inputs(ylp, log_weights, pointwise, "measure_elpd") lppd_i <- inputs$lppd_i @@ -160,8 +154,7 @@ measure_elpd <- function( ) .create_measure_structure( - res, higher_is_better, "elpd", - n_draws = inputs$n_draws, n_obs = inputs$n_obs + res, "elpd", n_draws = inputs$n_draws, n_obs = inputs$n_obs ) } @@ -180,7 +173,7 @@ measure_elpd <- function( #' measure_mlpd(ylp) #' @export measure_mlpd <- function( - ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL + ylp, log_weights = NULL, pointwise = NULL ) { inputs <- .lppd_from_inputs(ylp, log_weights, pointwise, "measure_mlpd") lppd_i <- inputs$lppd_i @@ -196,7 +189,7 @@ measure_mlpd <- function( pointwise = lppd_i ) .create_measure_structure( - res, higher_is_better, "mlpd", n_draws = inputs$n_draws, n_obs = n_obs + res, "mlpd", n_draws = inputs$n_draws, n_obs = n_obs ) } @@ -217,7 +210,7 @@ measure_mlpd <- function( #' measure_ic(ylp) #' @export measure_ic <- function( - ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL + ylp, log_weights = NULL, pointwise = NULL ) { inputs <- .lppd_from_inputs(ylp, log_weights, pointwise, "measure_ic") ic_i <- if (is.null(pointwise)) -2 * inputs$lppd_i else inputs$lppd_i @@ -233,7 +226,7 @@ measure_ic <- function( pointwise = ic_i ) .create_measure_structure( - res, higher_is_better, "ic", n_draws = inputs$n_draws, n_obs = n_obs + res, "ic", n_draws = inputs$n_draws, n_obs = n_obs ) } @@ -256,7 +249,7 @@ measure_ic <- function( #' measure_acc(y, mupred) #' @export measure_acc <- function( - y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL + y, mupred, log_weights = NULL, pointwise = NULL ) { if (!is.null(pointwise)) { .inform_ignored_inputs( @@ -280,7 +273,7 @@ measure_acc <- function( pointwise = acc_i ) .create_measure_structure( - res, higher_is_better, "acc", n_draws = n_draws, n_obs = n_obs + res, "acc", n_draws = n_draws, n_obs = n_obs ) } @@ -300,14 +293,21 @@ measure_acc <- function( #' measure_bacc(y, mupred) #' @export measure_bacc <- function( - y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL + y, mupred, log_weights = NULL, pointwise = NULL ) { - .validate_numeric_vector(y, arg = "y") + if (is.null(pointwise)) { + .validate_numeric_vector(y, arg = "y") + } + classes <- sort(unique(y)) K <- length(classes) - if (K < 2) { + class_id <- match(y, classes) + n_c <- tabulate(class_id, nbins = K) + + if (is.null(pointwise) && K < 2) { cli::cli_abort("{.fn bacc} requires at least two outcome classes.") } + if (!is.null(pointwise)) { if (length(pointwise) != length(y)) { cli::cli_abort("{.arg pointwise} and {.arg y} must have the same length.") @@ -325,18 +325,22 @@ measure_bacc <- function( n_obs <- ncol(mupred) acc_i <- .acc_pointwise(y, mupred, log_weights) } - + acc_c <- vapply(classes, function(c) mean(acc_i[y == c]), numeric(1)) - n_c <- tabulate(match(y, classes)) - bacc_i <- acc_i / (K * n_c[match(y, classes)]) - + bacc_i <- acc_i / (K * n_c[class_id]) + res <- list( estimate = mean(acc_c), se = sqrt(sum(acc_c * (1 - acc_c) / n_c)) / K, - pointwise = bacc_i + pointwise = bacc_i, + # the class strata are what makes a difference of balanced accuracies more + # than a mean of pointwise differences, and `.se_diff_bacc()` cannot + # recover them from `bacc_i`: every misclassified observation stores a + # zero whatever its class + extra = list(class_id = class_id) ) .create_measure_structure( - res, higher_is_better, "bacc", n_draws = n_draws, n_obs = n_obs + res, "bacc", n_draws = n_draws, n_obs = n_obs ) } @@ -358,7 +362,7 @@ measure_bacc <- function( #' measure_brier(y, ypred) #' @export measure_brier <- function( - y, ypred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL + y, ypred, log_weights = NULL, pointwise = NULL ) { if (!is.null(pointwise)) { .inform_ignored_inputs( @@ -401,7 +405,7 @@ measure_brier <- function( pointwise = bs_i ) .create_measure_structure( - res, higher_is_better, "brier", n_draws = n_draws, n_obs = n_obs + res, "brier", n_draws = n_draws, n_obs = n_obs ) } @@ -424,7 +428,7 @@ measure_brier <- function( #' measure_mae(y, mupred) #' @export measure_mae <- function( - y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL + y, mupred, log_weights = NULL, pointwise = NULL ) { inputs <- .point_error_from_inputs( y, mupred, log_weights, pointwise, "mae", abs @@ -437,8 +441,7 @@ measure_mae <- function( pointwise = mae_i ) .create_measure_structure( - res, higher_is_better, "mae", - n_draws = inputs$n_draws, n_obs = inputs$n_obs + res, "mae", n_draws = inputs$n_draws, n_obs = inputs$n_obs ) } @@ -458,7 +461,7 @@ measure_mae <- function( #' measure_mse(y, mupred) #' @export measure_mse <- function( - y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL + y, mupred, log_weights = NULL, pointwise = NULL ) { inputs <- .point_error_from_inputs( y, mupred, log_weights, pointwise, "mse", function(e) e^2 @@ -471,8 +474,7 @@ measure_mse <- function( pointwise = sqe_i ) .create_measure_structure( - res, higher_is_better, "mse", - n_draws = inputs$n_draws, n_obs = inputs$n_obs + res, "mse", n_draws = inputs$n_draws, n_obs = inputs$n_obs ) } @@ -491,7 +493,7 @@ measure_mse <- function( #' measure_rmse(y, mupred) #' @export measure_rmse <- function( - y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL + y, mupred, log_weights = NULL, pointwise = NULL ) { mse_res <- measure_mse( y = y, mupred = mupred, log_weights = log_weights, @@ -514,10 +516,37 @@ measure_rmse <- function( pointwise = sqe_i ) .create_measure_structure( - res, higher_is_better, "rmse", n_draws = n_draws, n_obs = n_obs + res, "rmse", n_draws = n_draws, n_obs = n_obs ) } +#' Delta-method standard error of an R-squared quantity +#' +#' The R-squared of one model and the difference in R-squared between two +#' models have the same form: a mean of squared-error contributions divided by +#' the model-independent baseline `MSE(y)`. Their standard errors are therefore +#' the same first-order Taylor approximation, evaluated either at one model's +#' pointwise squared errors or at the pointwise differences between two models. +#' +#' Writing `c = mean(sqe) / MSE(y)`, the three-term expansion +#' `Var[MSE] - 2 * c * Cov[MSE, MSE(y)] + c^2 * Var[MSE(y)]`, scaled by +#' `MSE(y)^-1`, is exactly the standard error of the mean of +#' `sqe_i - c * mse_y_i`. That is the form used here: it needs one variance +#' rather than three moments, it cannot go negative under the square root, and +#' it is exactly `0` when `sqe` is identically zero, as it is when a model is +#' compared against itself. +#' +#' @noRd +#' @param sqe Pointwise squared errors of one model, or pointwise differences +#' in squared error between two models. +#' @param mse_y_i Pointwise baseline `(y_i - mean(y))^2`. +#' @return Numeric scalar standard error. +.se_r2_delta <- function(sqe, mse_y_i) { + mse_y_hat <- mean(mse_y_i) + scaled <- sqe - (mean(sqe) / mse_y_hat) * mse_y_i + sqrt(var(scaled) / length(sqe)) / mse_y_hat +} + #' Predictive R-squared (`r2`) #' #' Computes predictive R-squared as one minus the ratio of prediction MSE to @@ -535,7 +564,7 @@ measure_rmse <- function( #' measure_r2(y, mupred) #' @export measure_r2 <- function( - y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL + y, mupred, log_weights = NULL, pointwise = NULL ) { .validate_numeric_vector(y, arg = "y") if (var(y) == 0) { @@ -557,25 +586,21 @@ measure_r2 <- function( mse_y_i <- (y - mean(y))^2 mse_y_hat <- mean(mse_y_i) - - var_mse_hat <- mse_res$estimates[2]^2 - cov_mse_msey <- stats::cov(sqe_i, mse_y_i) / n_obs - var_mse_y_hat <- var(mse_y_i) / n_obs - - t1 <- var_mse_hat - t2 <- -2 * (mse_hat / mse_y_hat) * cov_mse_msey - t3 <- (mse_hat^2 / mse_y_hat^2) * var_mse_y_hat - se_r2 <- sqrt(t1 + t2 + t3) * (1 / mse_y_hat) - + est_r2 <- 1 - mse_hat / mse_y_hat - + se_r2 <- .se_r2_delta(sqe_i, mse_y_i) + res <- list( estimate = est_r2, se = se_r2, - pointwise = sqe_i + pointwise = sqe_i, + # `model_compare()` needs the baseline to propagate uncertainty into the + # standard error of an r2 difference; `y` is gone by then. See + # `.se_diff_r2()`. + extra = list(mse_y_i = mse_y_i) ) .create_measure_structure( - res, higher_is_better, "r2", n_draws = n_draws, n_obs = n_obs + res, "r2", n_draws = n_draws, n_obs = n_obs ) } @@ -614,22 +639,39 @@ measure_r2 <- function( #' both discrete and continuous outcomes; see Hosking (1990, 1996) for #' theoretical justification in the discrete case. #' -#' If log-weights (`log_weights`) are provided (e.g., PSIS weights -#' for LOO cross-validation), a weighted PWM estimator is used instead, which -#' accounts for the importance weights when estimating expectations. +#' The term \eqn{E[|X - X'|]} is computed as a weighted average over all pairs +#' of draws, +#' \deqn{E[|X - X'|] = \frac{\sum_i \sum_{j \neq i} w_i w_j |x_i - x_j|}{1 - +#' \sum_i w_i^2},} +#' which is evaluated in \eqn{O(S \log S)} using the sorted draws and the +#' cumulative sums of their weights. If log-weights (`log_weights`) are provided +#' (e.g., PSIS weights for LOO cross-validation), the \eqn{w_i} are the +#' normalized importance weights and \eqn{E[|X - y|]} is likewise a weighted +#' mean. Otherwise the weights are equal, \eqn{w_i = 1/S}, and the expression +#' reduces to the usual unbiased PWM estimator with the \eqn{1 / (S (S - 1))} +#' normalization. Because the estimate is a convex combination of +#' \eqn{|x_i - x_j|}, it is always non-negative and invariant to shifts of +#' `ypred`. #' #' **Sign convention:** #' -#' Unscaled scores are returned as losses (lower is better). Scaled scores are -#' returned as utilities (higher is better), after Bolin & Wallin (2023). Set -#' `higher_is_better` to select the orientation you want. +#' Unscaled scores (RPS, CRPS) are returned on the loss scale of Gneiting & +#' Raftery (2007): lower is better. Scaled scores (SRPS, SCRPS) follow Bolin & +#' Wallin (2023) and are returned on the utility scale: higher is better. +#' [model_compare()] reports differences for both on the utility scale, so no +#' manual conversion is needed there. The deprecated [crps()] returned the +#' negated unscaled score; `-measure_rps(...)$pointwise` reproduces it. #' #' @param y A numeric vector of \eqn{n} observed outcomes. May be integer-valued #' (for RPS/SRPS) or continuous (for CRPS/SCRPS). #' @param ypred A numeric matrix of posterior predictive draws with dimensions #' \eqn{S \times n} (draws × observations). -#' @param pointwise Optional numeric vector of precomputed pointwise rps values. -#' If provided, `y`, `ypred`, and `log_weights` are ignored. +#' @param pointwise Optional numeric vector of precomputed pointwise values, on +#' the scale of the measure that is returned: RPS/CRPS when `scaled = FALSE` +#' and SRPS/SCRPS when `scaled = TRUE`. The values are used as they are, with +#' no further transformation; in particular, unscaled values are not converted +#' to the scaled variant. If provided, `y`, `ypred`, and `log_weights` are +#' ignored. #' @param scaled Logical; if `TRUE`, computes the scaled variant (SRPS for #' discrete outcomes, SCRPS for continuous outcomes). Default is `FALSE`. #' @inheritParams measure_params @@ -682,12 +724,14 @@ measure_r2 <- function( #' weather forecasts. *Mathematical Geosciences*, 50:209–234. #' #' @export -measure_rps <- function(y, ypred, log_weights = NULL, pointwise = NULL, scaled = FALSE, - higher_is_better = NULL) { +measure_rps <- function(y, ypred, log_weights = NULL, pointwise = NULL, + scaled = FALSE) { if (is.null(pointwise)) { + .validate_numeric_vector(y, arg = "y") + .validate_numeric_matrix(ypred, arg = "ypred", ncol = length(y)) n_draws <- nrow(ypred) n_obs <- ncol(ypred) - + w <- if (is.null(log_weights)) { NULL } else { @@ -738,7 +782,7 @@ measure_rps <- function(y, ypred, log_weights = NULL, pointwise = NULL, scaled = ) name <- if(isTRUE(scaled)) "srps" else "rps" .create_measure_structure( - res, higher_is_better, name, n_draws = n_draws, n_obs = n_obs + res, name, n_draws = n_draws, n_obs = n_obs ) } @@ -761,11 +805,10 @@ measure_rps <- function(y, ypred, log_weights = NULL, pointwise = NULL, scaled = #' measure_srps(y, ypred) #' #' @export -measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL, - higher_is_better = NULL) { +measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL) { measure_rps( - y = y, ypred = ypred, log_weights = log_weights, - scaled = TRUE, higher_is_better = higher_is_better + y = y, ypred = ypred, log_weights = log_weights, pointwise = pointwise, + scaled = TRUE ) } @@ -785,23 +828,246 @@ measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL, # the base measure block rather than from the raw inputs. `.compute_measure()` # then supplies `pointwise`, optionally passed through `elpd_transform` first. .measure_spec <- list( - elpd = list(fun = measure_elpd, loss = FALSE), + elpd = list(fun = measure_elpd, loss = FALSE, diff_method = "sum"), ic = list( - fun = measure_ic, loss = TRUE, - needs_elpd = TRUE, elpd_transform = function(x) -2 * x + fun = measure_ic, + loss = TRUE, + diff_method = "sum", + needs_elpd = TRUE, + elpd_transform = function(x) -2 * x + ), + mlpd = list( + fun = measure_mlpd, + loss = FALSE, + diff_method = "mean", + needs_elpd = TRUE ), - mlpd = list(fun = measure_mlpd, loss = FALSE, needs_elpd = TRUE), - mae = list(fun = measure_mae, loss = TRUE), - r2 = list(fun = measure_r2, loss = FALSE), - rmse = list(fun = measure_rmse, loss = TRUE), - mse = list(fun = measure_mse, loss = TRUE), - acc = list(fun = measure_acc, loss = FALSE), - bacc = list(fun = measure_bacc, loss = FALSE), - rps = list(fun = measure_rps, loss = TRUE), - srps = list(fun = measure_srps, loss = FALSE), - brier = list(fun = measure_brier, loss = TRUE) + 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" + ), + 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"), + bacc = list( + fun = measure_bacc, + loss = FALSE, + diff_method = "measure_specific", + se_diff_fun = "bacc" + ), + # 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") ) +# 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 `model_compare(custom_se_fn = )` instead, +# 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 + )) + } + + # Custom measures never declare how their standard error of the difference is + # computed. That is supplied at comparison time via + # `model_compare(custom_se_fn = )`, so nothing here is inferred and no closure + # is stored on the result object. Whether the measure is a loss is declared by + # the measure itself, through `attr(fun, "measure_loss")`. + list( + loss = isTRUE(measure_entry$loss), + diff_method = "custom" + ) +} + #' Supported predictive measure names #' #' A character vector of measure names that can be passed to the `measure` @@ -812,17 +1078,7 @@ measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL, supported_measures_list <- names(.measure_spec) # internal function that produces output format for measures -.create_measure_structure <- function( - res, higher_is_better, measure_name, n_draws, n_obs -) { - if (!is.null(higher_is_better)) { - spec <- .measure_spec[[measure_name]] - natural_higher <- is.null(spec) || !isTRUE(spec$loss) - if (xor(natural_higher, isTRUE(higher_is_better))) { - res$estimate <- -res$estimate - res$pointwise <- -res$pointwise - } - } +.create_measure_structure <- function(res, measure_name, n_draws, n_obs) { out <- list() out$estimates <- matrix( c(res$estimate, res$se), @@ -834,6 +1090,9 @@ supported_measures_list <- names(.measure_spec) ncol = 1, dimnames = list(NULL, measure_name) ) + # `extra` carries auxiliary data for `se_diff_fun()`, on the measure's + # natural scale; absent when the measure stores nothing + out$extra <- res$extra structure( out, diff --git a/R/pred_measure-compute.R b/R/pred_measure-compute.R index 4fe38e1f..b59dc5ed 100644 --- a/R/pred_measure-compute.R +++ b/R/pred_measure-compute.R @@ -34,9 +34,38 @@ #' Custom functions are called with any of `y`, `ypred`, `mupred`, `ylp`, and #' `log_weights` that appear in their formals, plus arguments from `control`. #' They must return a list with `estimates` and `pointwise`. -#' @param measure_name For a single custom function, set -#' `attr(my_fun, "measure_name") <- "my_metric"` before passing `my_fun` to -#' `measure`. +#' +#' A custom measure declares whether it is a loss (lower is better) or a +#' utility (higher is better) with attribute `"measure_loss"`: +#' `attr(my_fun, "measure_loss") <- TRUE` for a loss. 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 declares nothing about the standard error of a difference +#' between two models. That is supplied at comparison time through the +#' `custom_se_fn` argument of [model_compare()], which accepts a function +#' `function(ref, cmp) ...`, the shorthands `"sum"` and `"mean"` for the +#' paired pointwise formulas, or `NULL` to report 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 +#' `custom_se_fn`; 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 measure_name Only needed when `measure` is a single custom function +#' passed directly (not inside a list) — it sets the name that function is +#' reported under. Set it with `attr(my_fun, "measure_name") <- "my_metric"` +#' before passing `my_fun` to `measure`. If you pass the same function inside +#' a list instead (e.g. `list(my_metric = my_fun)`), it takes its name from +#' the list element and `measure_name` isn't needed — this also lets the +#' same function be reused under several names. If both are set and disagree, +#' the list name wins and a warning is issued. Either way, +#' `attr(my_fun, "measure_loss")` is still read from the function itself. #' @param group_ids Optional vector of group identifiers for grouped summaries #' (reserved; not yet implemented). #' @param loo A [loo::loo()] result, computed with @@ -77,8 +106,6 @@ do_pred_measure <- function( control = list() ) { # input validation --------------------------------------------------- - .validate_control(control) - if (!is.null(group_ids)) { cli::cli_abort( "`group_ids` is reserved for future feature but is not yet implemented." @@ -88,6 +115,10 @@ do_pred_measure <- function( measures <- .prepare_measures( measure, predperf, supported_measures_list, source ) + # validated against every requested measure, including the ones + # `.prepare_measures()` dropped as already present: those are reported by their + # own warning, and a control entry for them is not a mistake + .validate_control(control, .normalize_measure(measure)) if (source == "loo") { if (is.null(predperf)) { @@ -164,6 +195,13 @@ do_pred_measure <- function( if (is.null(result_name)) { result_name <- entry$name } + # A measure may rename its own result: `rps` with `scaled = TRUE` returns + # `srps`. Read the spec under that name, or the requested measure's + # orientation leaks into the renamed row and inverts the ranking. + info_entry <- entry + if (entry$type == "builtin" && !is.null(.measure_spec[[result_name]])) { + info_entry$key <- result_name + } # add new measures to existing pred_measure results name_updated <- .measure_result_name(source, result_name) if (!is.null(estimates) && name_updated %in% rownames(estimates)) { @@ -177,7 +215,9 @@ do_pred_measure <- function( mat = estimates, name = result_name, values = .measure_estimate_se(sel_measure), - margin = 1 + margin = 1, + measure_entry = info_entry, + extra = sel_measure$extra ) pointwise <- .merge_matrix( source = source, @@ -195,21 +235,22 @@ do_pred_measure <- function( psis_object = psis_object, save_psis = save_psis ) - - .add_attributes( - save_psis, - predperf_res, - y, - ypred, - mupred, - ylp, - ylp_test, - kfold, - loo, - predperf, - source + + predperf_res <- .add_attributes( + save_psis = save_psis, + predperf_res = predperf_res, + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + ylp_test = ylp_test, + kfold = kfold, + loo = loo, + predperf = predperf, + source = source ) - } + predperf_res +} # internal helper functions --------------------------------------------------- @@ -362,21 +403,21 @@ do_pred_measure <- function( #' #' @noRd .compute_measure <- function( - y, - ypred, - mupred, - ylp, - measure_entry, - log_weights, - control = list(), - base_measure + y, + ypred, + mupred, + ylp, + measure_entry, + log_weights, + control = list(), + base_measure ) { if (measure_entry$type == "builtin") { spec <- .measure_spec[[measure_entry$key]] - measure_fun <- spec$fun - if (is.null(measure_fun)) { + if (is.null(spec)) { cli::cli_abort("Unknown built-in measure {.val {measure_entry$key}}.") } + measure_fun <- spec$fun } else { spec <- NULL measure_fun <- measure_entry$key @@ -584,6 +625,12 @@ do_pred_measure <- function( #' `(estimate, se)`; for `margin = 2`, length-`n` pointwise vector. #' @param margin `1` to merge along rows (estimates table), `2` along columns #' (pointwise table). +#' @param measure_entry Optional normalized measure entry; when merging an +#' estimates row (`margin = 1`), the `measure_info` used by [model_compare()] +#' is recorded from this entry. +#' @param extra Optional list of auxiliary data the measure stores for its +#' `se_diff_fun` (the measure result's `extra` element); recorded in `measure_info` +#' when merging an estimates row (`margin = 1`). #' #' @return Updated matrix with `name` as a row or column name. #' @@ -599,7 +646,15 @@ do_pred_measure <- function( } #' @noRd -.merge_matrix <- function(source, mat, name, values, margin) { +.merge_matrix <- function( + source, + mat, + name, + values, + margin, + measure_entry = NULL, + extra = NULL +) { is_row <- margin == 1 bind_fn <- if (is_row) rbind else cbind name_updated <- .measure_result_name(source, name) @@ -610,8 +665,31 @@ do_pred_measure <- function( matrix(values, ncol = 1, dimnames = list(NULL, name_updated)) } - if (is.null(mat)) return(new_slice) - bind_fn(mat, new_slice) + info <- if (is_row && !is.null(measure_entry)) { + .measure_info(measure_entry) + } + if (!is.null(info) && !is.null(extra)) { + info$extra <- extra + } + + old_info <- if (is_row && !is.null(mat)) { + attr(mat, "measure_info") + } + + mat <- if (is.null(mat)) new_slice else bind_fn(mat, new_slice) + + if (is_row && (!is.null(info) || !is.null(old_info))) { + measure_info <- old_info + if (is.null(measure_info)) { + measure_info <- list() + } + if (!is.null(info)) { + measure_info[[name]] <- info + } + attr(mat, "measure_info") <- measure_info + } + + mat } #' Construct the S3 predictive measure result object @@ -634,8 +712,9 @@ do_pred_measure <- function( #' @param save_psis Logical; if `TRUE`, include `psis_object` in the result. #' #' @return A list with elements `estimates`, `pointwise`, and optionally -#' `diagnostics`, `psis_object`, and `log_weights`. Class attributes are added -#' by \code{.add_attributes()}. +#' `diagnostics`, `psis_object`, and `log_weights`. Attribute `measure_info` +#' records per-measure metadata for measures added in the current call. Class +#' attributes are added by \code{.add_attributes()}. #' #' @noRd .build_pred_measure <- function( @@ -645,6 +724,12 @@ do_pred_measure <- function( psis_object, save_psis ) { + measure_info <- attr(estimates, "measure_info") + if (is.null(measure_info)) { + measure_info <- list() + } + attr(estimates, "measure_info") <- NULL + output_list <- list( estimates = estimates, pointwise = pointwise @@ -658,23 +743,30 @@ do_pred_measure <- function( if (!is.null(psis_object)) { output_list$log_weights <- psis_object$log_weights } - - structure(output_list) + + structure( + output_list, + measure_info = measure_info + ) } #' Attach S3 classes and metadata attributes to a result #' #' @description -#' Sets `class`, `source`, and `dims` attributes on a predictive measure object. +#' Sets `class`, `source`, `dims`, and `measure_info` attributes on a predictive +#' measure object. #' #' When updating an existing result (`predperf` is not `NULL`), copies attributes #' from `predperf` and refreshes `dims` from newly supplied input matrices. +#' Merges `measure_info` from the prior result with any new entries supplied on +#' `predperf_res` (from \code{.build_pred_measure()}). #' When `save_psis = FALSE`, clears any stored `psis_object` from the prior #' result. #' #' For new objects, copies relevant attributes from `loo` or `kfold` inputs #' (e.g. `yhash`, `model_name`, fold structure) and assigns a source-specific -#' subclass (`"insample_pred_measure"`, `"loo_pred_measure"`, etc.). +#' subclass (`"insample_pred_measure"`, `"loo_pred_measure"`, etc.). Sets +#' `measure_info`, seeding the `elpd` entry. #' #' @param save_psis Logical; when `FALSE` and accumulating, clears stored #' `psis_object` from the prior result. @@ -694,13 +786,30 @@ do_pred_measure <- function( #' @return The updated `predperf_res` with class and attributes set. #' #' @noRd -.add_attributes <- function(save_psis, predperf_res, y, ypred, mupred, ylp, ylp_test, kfold, loo, predperf, source) { +.add_attributes <- function( + save_psis, + predperf_res, + y, + ypred, + mupred, + ylp, + ylp_test, + kfold, + loo, + predperf, + source +) { + new_info <- attr(predperf_res, "measure_info") + if (is.null(new_info)) { + new_info <- list() + } + if (!is.null(predperf)) { if (isFALSE(save_psis)) { predperf$psis_object <- NULL } attributes(predperf_res) <- attributes(predperf) - + dims <- if (!is.null(ypred)) { dim(ypred) } else if (!is.null(mupred)) { @@ -711,10 +820,21 @@ do_pred_measure <- function( attr(predperf, "dims") } attr(predperf_res, "dims") <- dims - + measure_info <- attr(predperf, "measure_info") + if (is.null(measure_info)) { + measure_info <- list() + } + if (is.null(measure_info$elpd)) { + measure_info$elpd <- .measure_info("elpd") + } + if (length(new_info)) { + measure_info[names(new_info)] <- new_info + } + attr(predperf_res, "measure_info") <- measure_info + return(predperf_res) } - + predperf_res <- switch( source, kfold = .copy_attrs( @@ -758,6 +878,13 @@ do_pred_measure <- function( } attr(predperf_res, "class") <- classes attr(predperf_res, "source") <- source - - return(predperf_res) -} \ No newline at end of file + measure_info <- list( + elpd = .measure_info("elpd") + ) + if (length(new_info)) { + measure_info[names(new_info)] <- new_info + } + attr(predperf_res, "measure_info") <- measure_info + + predperf_res +} diff --git a/R/pred_measure-helpers.R b/R/pred_measure-helpers.R index 767c04de..7d5243ba 100644 --- a/R/pred_measure-helpers.R +++ b/R/pred_measure-helpers.R @@ -3,7 +3,8 @@ #' @description #' Converts `measure` (character, function, list, or `NULL`) into a list of #' entries with elements `name`, `type` (`"builtin"` or `"custom"`), and `key` -#' (built-in name or function). +#' (built-in name or function). Custom entries also carry `loss`, taken from +#' `attr(fun, "measure_loss")`. #' #' @param measure User-supplied `measure` argument. #' @@ -46,7 +47,7 @@ "i" = "Use {.code measure = list(my_metric = my_fun)}." )) } - list(name = nm, type = "custom", key = el) + .measure_entry_custom(el, name = nm) } else { cli::cli_abort(c( "Each element of {.arg measure} must be a character scalar (built-in", @@ -68,18 +69,50 @@ #' Build a custom measure entry from a function #' +#' The name and the orientation of a measure are properties of its definition, +#' so both are declared once on the function via `attr(fun, "measure_name")` +#' and `attr(fun, "measure_loss")` rather than at every call. A custom measure +#' is a utility (higher is better) unless it declares itself a loss. +#' #' @param fun Function implementing a custom measure. +#' @param name Measure name, when it comes from the name of a `measure` list +#' element rather than from `attr(fun, "measure_name")`. #' @noRd -.measure_entry_custom <- function(fun) { - name <- attr(fun, "measure_name", exact = TRUE) - if (is.null(name) || length(name) != 1L || !nzchar(name)) { - cli::cli_abort(c( - "A custom function passed to {.arg measure} must have attribute", - "{.code measure_name}.", - "i" = "Set {.code attr(my_fun, \"measure_name\") <- \"my_metric\"}." - )) +.measure_entry_custom <- function(fun, name = NULL) { + if (is.null(name)) { + name <- attr(fun, "measure_name", exact = TRUE) + if (is.null(name) || length(name) != 1L || !nzchar(name)) { + stop( + "A custom function passed to 'measure' must have attribute ", + "'measure_name', e.g. attr(my_fun, \"measure_name\") <- \"my_metric\".", + call. = FALSE + ) + } + } else { + attr_name <- attr(fun, "measure_name", exact = TRUE) + if (!is.null(attr_name) && length(attr_name) == 1L && nzchar(attr_name) && + !identical(attr_name, name)) { + cli::cli_warn(c( + "Custom measure named {.val {name}} in {.arg measure} also has", + "{.code attr(fun, \"measure_name\") = {.val {attr_name}}}.", + "i" = "Using the list name {.val {name}}; the attribute is ignored here." + )) + } } - list(name = name, type = "custom", key = fun) + + 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( + "Attribute 'measure_loss' of a custom measure must be TRUE or FALSE, ", + "e.g. attr(my_fun, \"measure_loss\") <- TRUE for a measure where lower ", + "values are better.", + call. = FALSE + ) + } + + list(name = name, type = "custom", key = fun, loss = loss) } #' Check duplicate measure names @@ -242,6 +275,13 @@ } # pass measure name if user set it as attribute attr(res, "measure") <- measure_name + if (!is.null(res$extra) && !is.list(res$extra)) { + cli::cli_abort(c( + "{.field extra} from custom measure {.val {measure_name}} must be a list.", + "i" = "It is handed to {.code custom_se_fn(ref, cmp)} as + {.code ref$extra} and {.code cmp$extra}." + )) + } invisible(res) } @@ -577,6 +617,7 @@ ) } + #' Probability-weighted moment estimator of E|X - X'| #' #' @description @@ -599,6 +640,10 @@ #' non-negative, so `log()` of it in the scaled scores is always defined, and #' the coefficients sum to zero, so it is invariant to shifts of `ypred`. #' +#' This is the bias-corrected weighted Gini mean difference, not the estimator +#' derived in `notes/crps_pwm.pdf`; see decision D5 in `notes/developer-notes.md` +#' for why that derivation is not used here. +#' #' @param ypred Numeric matrix of posterior predictive draws (`n_draws` #' \eqn{\times} `n_obs`), where rows are draws and columns are observations. #' @param w Optional numeric matrix of column-normalized weights on the @@ -645,20 +690,22 @@ ) } - - #' Validate control argument -#' +#' #' @description -#' Validates that the arguments passed to the control list are valid -#' arguments for the corresponding function. If not, a warning is issued that +#' Validates that the arguments passed to the control list are valid +#' arguments for the corresponding function. If not, a warning is issued that #' corresponding invalid argument is ignored. -#' +#' #' @param control Named list of per-measure settings. +#' @param measures Optional list of normalized measure entries from +#' `.prepare_measures()`. When supplied, control names are resolved against +#' the requested measures, so custom measures are validated against their own +#' formals; without it only built-in names can be checked. #' #' @keywords internal #' @noRd -.validate_control <- function(control) { +.validate_control <- function(control, measures = NULL) { res <- checkmate::check_list(control, types = "list", names = "named") if (!isTRUE(res)) { cli::cli_abort(c( @@ -666,17 +713,45 @@ "i" = "Expected format: {.code list(fun_name = list(arg1 = val1, arg2 = val2))}" )) } - + + # without `measures` the requested measures are unknown, so a control name is + # only checked against the built-in registry + known_measures <- !is.null(measures) + if (is.null(measures)) { + measures <- list() + } + entries <- stats::setNames( + measures, + vapply(measures, function(e) e$name, character(1L)) + ) + for (func_name in names(control)) { - invalid_args <- names(control[[func_name]])[ - !names(control[[func_name]]) %in% names(formals(match.fun(paste0("measure_", func_name)))) - ] + entry <- if (func_name %in% names(entries)) entries[[func_name]] else NULL + # custom measures are validated against their own formals, built-ins + # against the registry; a name matching neither accepts nothing + valid_args <- if (!is.null(entry) && identical(entry$type, "custom")) { + names(formals(entry$key)) + } else if (is.null(entry) && known_measures) { + NULL + } else { + spec <- .measure_spec[[if (is.null(entry)) func_name else entry$key]] + if (is.null(spec)) NULL else names(formals(spec$fun)) + } + if (is.null(valid_args)) { + cli::cli_warn(c( + "Ignoring {.arg control} entry {.val {func_name}}, which matches no", + "measure being computed." + )) + next + } + invalid_args <- setdiff(names(control[[func_name]]), valid_args) if (length(invalid_args) > 0) { cli::cli_warn( "Ignoring {.arg {invalid_args}} as it is not a valid argument of {.fn {func_name}}." ) } } + invisible(NULL) } #' Subset measure results diff --git a/R/pred_measure.R b/R/pred_measure.R index 38dadea1..51976a24 100644 --- a/R/pred_measure.R +++ b/R/pred_measure.R @@ -28,7 +28,11 @@ #' } #' #' The attribute `source` is `"insample"`. Attribute `dims` gives posterior -#' draws × observations. Use [print()] for a readable summary table. +#' draws × observations. Attribute `measure_info` records what `model_compare()` +#' needs to know about each measure; see section below. Use [print()] +#' for a readable summary table. +#' +#' @template measure-info-attribute #' #' @details #' **Input requirements by measure.** Supply only the inputs each measure @@ -52,6 +56,15 @@ #' 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 +#' `attr(my_fun, "measure_loss") <- TRUE` so that [model_compare()] converts and +#' ranks it in the right direction. +#' +#' A custom measure declares nothing about the standard error of a difference +#' between two models. Supply it when comparing, through the `custom_se_fn` +#' argument of [model_compare()]. +#' #' @examples #' \donttest{ #' if (requireNamespace("brms", quietly = TRUE)) { @@ -153,6 +166,8 @@ insample_pred_measure <- function( #' #' Measure names carry a `_loo` suffix (e.g. `elpd_loo`, `crps_loo`). #' +#' @template measure-info-attribute +#' #' @details #' **Three equivalent input patterns:** #' @@ -243,6 +258,8 @@ loo_pred_measure <- function( #' list contains `estimates` and `pointwise`; measure names carry a `_kfold` #' suffix (e.g. `elpd_kfold`, `crps_kfold`). #' +#' @template measure-info-attribute +#' #' @details #' For distributional measures on held-out folds, obtain posterior predictions #' with `brms::kfold_predict()` and pass the resulting `yrep` matrices as @@ -325,6 +342,8 @@ kfold_pred_measure <- function( #' `elpd_test`, `crps_test`). Attribute `dims` reflects the test-set size #' (from `ylp_test`), not the training data. #' +#' @template measure-info-attribute +#' #' @details #' The base summary `elpd_test` is computed from `ylp_test` on the holdout #' observations only. @@ -403,7 +422,10 @@ test_pred_measure <- function( #' An updated object of the same class as `predperf`, with new rows in #' `estimates` and columns in `pointwise` for each requested measure. Base #' summaries (`elpd` and LOO/k-fold complexity terms such as `p_loo`) are not -#' recomputed. +#' recomputed. Attribute `measure_info` is extended for any newly added +#' measures. +#' +#' @template measure-info-attribute #' #' @details #' **Typical workflow:** diff --git a/R/psis.R b/R/psis.R index dd8b0176..d7e0f491 100644 --- a/R/psis.R +++ b/R/psis.R @@ -315,7 +315,7 @@ enough_tail_samples <- function(tail_len, min_len = 5) { #' throw_pareto_warnings <- function(k, k_threshold) { if (isTRUE(any(k > k_threshold))) { - .warn("Some Pareto k diagnostic values are too high. ", .k_help()) + .warn("Some Pareto k diagnostic values are too high.\n", .k_help()) } } @@ -384,27 +384,3 @@ prepare_psis_r_eff <- function(r_eff, len) { } r_eff } - -#' Check if `psis()` was called from one of the loo methods -#' -#' @noRd -#' @return `TRUE` if the `loo()` array, matrix, or function method is found in -#' the active call list, `FALSE` otherwise. -#' -called_from_loo <- function() { - calls <- sys.calls() - txt <- unlist(lapply(calls, deparse)) - patts <- "loo.array\\(|loo.matrix\\(|loo.function\\(" - check <- sapply(txt, function(x) grepl(patts, x)) - isTRUE(any(check)) -} - -#' Warning message about missing `r_eff` argument -#' @noRd -throw_psis_r_eff_warning <- function() { - warning( - "Relative effective sample sizes ('r_eff' argument) not specified. ", - "PSIS ESS (n_eff) will not be adjusted based on MCMC ESS (n_eff).", - call. = FALSE - ) -} diff --git a/R/waic.R b/R/waic.R index 2dac6456..1be2701c 100644 --- a/R/waic.R +++ b/R/waic.R @@ -30,7 +30,8 @@ #' * The __loo__ package [vignettes](https://mc-stan.org/loo/articles/) and #' Vehtari, Gelman, and Gabry (2017) and Vehtari, Simpson, Gelman, Yao, #' and Gabry (2024) for more details on why we prefer `loo()` to `waic()`. -#' * [loo_compare()] for comparing models on approximate LOO-CV or WAIC. +#' * [loo_compare()] and [model_compare()] for comparing models on approximate +#' LOO-CV or WAIC. #' #' @references #' Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation and diff --git a/_pkgdown.yml b/_pkgdown.yml index b3d56da9..0a7f15aa 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -66,6 +66,7 @@ articles: contents: - articles-online-only/pred-measure-workflow - articles-online-only/overview-measures + - articles-online-only/model-comparison - title: Frequently asked questions contents: - faq @@ -103,6 +104,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 diff --git a/man-roxygen/measure-info-attribute.R b/man-roxygen/measure-info-attribute.R new file mode 100644 index 00000000..703473af --- /dev/null +++ b/man-roxygen/measure-info-attribute.R @@ -0,0 +1,17 @@ +#' @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 the standard error of their difference from the `custom_se_fn` +#' argument of [model_compare()]; their `loss` comes from +#' `attr(my_fun, "measure_loss") <- TRUE`, which declares that lower values are +#' better. Without that declaration a custom measure is treated as a utility, so +#' an undeclared loss is compared and ranked in the wrong direction. See +#' [loo-glossary]. diff --git a/man/compare.Rd b/man/compare.Rd index 3d95059f..21b317d5 100644 --- a/man/compare.Rd +++ b/man/compare.Rd @@ -21,7 +21,7 @@ standard error of the difference are returned. If more than two objects are provided then a matrix of summary information is returned (see \strong{Details}). } \description{ -\strong{This function is deprecated}. Please use the new \code{\link[=loo_compare]{loo_compare()}} function +\strong{This function is deprecated}. Please use the new \code{\link[=model_compare]{model_compare()}} function instead. See \code{vignette("migration-guide", package = "loo")} for details. \code{compare()} and \code{R/compare.R} are scheduled for removal in a future release. } diff --git a/man/find_model_names.Rd b/man/find_model_names.Rd index 70a79d58..7c6a5eaf 100644 --- a/man/find_model_names.Rd +++ b/man/find_model_names.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo_compare.R +% Please edit documentation in R/model_compare.R \name{find_model_names} \alias{find_model_names} \title{Find the model names associated with \code{"loo"} objects} diff --git a/man/insample_pred_measure.Rd b/man/insample_pred_measure.Rd index f236c45d..aee68f9d 100644 --- a/man/insample_pred_measure.Rd +++ b/man/insample_pred_measure.Rd @@ -42,7 +42,30 @@ functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. } Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and \code{log_weights} that appear in their formals, plus arguments from \code{control}. -They must return a list with \code{estimates} and \code{pointwise}.} +They must return a list with \code{estimates} and \code{pointwise}. + +A custom measure declares whether it is a loss (lower is better) or a +utility (higher is better) with attribute \code{"measure_loss"}: +\code{attr(my_fun, "measure_loss") <- TRUE} for a loss. 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 declares nothing about the standard error of a difference +between two models. That is supplied at comparison time through the +\code{custom_se_fn} argument of \code{\link[=model_compare]{model_compare()}}, which accepts a function +\code{function(ref, cmp) ...}, the shorthands \code{"sum"} and \code{"mean"} for the +paired pointwise formulas, or \code{NULL} to report 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 +\code{custom_se_fn}; the built-in \code{r2} uses it for the baseline +\code{(y_i - mean(y))^2}, which cannot be recovered once \code{y} is out of scope.} \item{group_ids}{Optional vector of group identifiers for grouped summaries (reserved; not yet implemented).} @@ -67,7 +90,9 @@ per measure).} } The attribute \code{source} is \code{"insample"}. Attribute \code{dims} gives posterior -draws × observations. Use \code{\link[=print]{print()}} for a readable summary table. +draws × observations. Attribute \code{measure_info} records what \code{model_compare()} +needs to know about each measure; see section below. Use \code{\link[=print]{print()}} +for a readable summary table. } \description{ Compute predictive performance measures on the same data used to fit the @@ -104,7 +129,36 @@ article for definitions and orientation (higher vs lower is better). \code{measure_name} and 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{attr(my_fun, "measure_loss") <- TRUE} so that \code{\link[=model_compare]{model_compare()}} converts and +ranks it in the right direction. + +A custom measure declares nothing about the standard error of a difference +between two models. Supply it when comparing, through the \code{custom_se_fn} +argument of \code{\link[=model_compare]{model_compare()}}. } +\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 the standard error of their difference from the \code{custom_se_fn} +argument of \code{\link[=model_compare]{model_compare()}}; their \code{loss} comes from +\code{attr(my_fun, "measure_loss") <- TRUE}, which declares that lower values are +better. Without that declaration a custom measure is treated as a utility, so +an undeclared loss is compared and ranked in the wrong direction. See +\link{loo-glossary}. +} + \examples{ \donttest{ if (requireNamespace("brms", quietly = TRUE)) { diff --git a/man/kfold-generic.Rd b/man/kfold-generic.Rd index bcf3c84b..1901a199 100644 --- a/man/kfold-generic.Rd +++ b/man/kfold-generic.Rd @@ -29,7 +29,7 @@ the pointwise contributions for each data point. It is important for the object to have at least these classes and components so that it is compatible with other functions like -\code{\link[=loo_compare]{loo_compare()}} and \code{print()} methods. +\code{\link[=model_compare]{model_compare()}} and \code{print()} methods. } \description{ For developers of Bayesian modeling packages, \strong{loo} includes @@ -39,5 +39,5 @@ CV without name conflicts between packages. See, for example, the The \strong{Value} section below describes the objects that \code{kfold()} methods should return in order to be compatible with -\code{\link[=loo_compare]{loo_compare()}} and the \strong{loo} package print methods. +\code{\link[=model_compare]{model_compare()}} and the \strong{loo} package print methods. } diff --git a/man/kfold_pred_measure.Rd b/man/kfold_pred_measure.Rd index f3f590c0..1c6c3cb6 100644 --- a/man/kfold_pred_measure.Rd +++ b/man/kfold_pred_measure.Rd @@ -42,7 +42,30 @@ functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. } Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and \code{log_weights} that appear in their formals, plus arguments from \code{control}. -They must return a list with \code{estimates} and \code{pointwise}.} +They must return a list with \code{estimates} and \code{pointwise}. + +A custom measure declares whether it is a loss (lower is better) or a +utility (higher is better) with attribute \code{"measure_loss"}: +\code{attr(my_fun, "measure_loss") <- TRUE} for a loss. 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 declares nothing about the standard error of a difference +between two models. That is supplied at comparison time through the +\code{custom_se_fn} argument of \code{\link[=model_compare]{model_compare()}}, which accepts a function +\code{function(ref, cmp) ...}, the shorthands \code{"sum"} and \code{"mean"} for the +paired pointwise formulas, or \code{NULL} to report 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 +\code{custom_se_fn}; 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 @@ -78,6 +101,26 @@ with \code{brms::kfold_predict()} and pass the resulting \code{yrep} matrices as \code{ypred} and/or \code{mupred}. See the sleep-study workflow in \href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{pred-measure workflow article}. } +\section{\code{measure_info} attribute}{ + +All \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results include attribute +\code{measure_info}: a named list, keyed by bare measure name, recording what +\code{\link[=model_compare]{model_compare()}} needs to know about each measure — \code{loss} (whether lower +values are better), \code{diff_method} (how the standard error of a difference is +obtained), and, where applicable, \code{se_diff_fun} and \code{extra}. When measures +are added incrementally with \code{\link[=pred_measure]{pred_measure()}}, the attribute is extended for +the newly computed measures. + +Built-in measures take \code{loss}, \code{diff_method}, and \code{se_diff_fun} from the +package measure registry. Custom measures always get \code{diff_method = "custom"} +and take the standard error of their difference from the \code{custom_se_fn} +argument of \code{\link[=model_compare]{model_compare()}}; their \code{loss} comes from +\code{attr(my_fun, "measure_loss") <- TRUE}, which declares that lower values are +better. Without that declaration a custom measure is treated as a utility, so +an undeclared loss is compared and ranked in the wrong direction. See +\link{loo-glossary}. +} + \examples{ \donttest{ if (requireNamespace("brms", quietly = TRUE)) { diff --git a/man/loo-glossary.Rd b/man/loo-glossary.Rd index 58529429..88bf7c57 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,45 @@ 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. The \code{rank_by} and +\code{custom_se_fn} arguments are available here only. +\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, +\code{rank_by}, or \code{custom_se_fn} arguments 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 by default the best model on the measure unless +\code{model_compare()} was given \code{rank_by}. +} + \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()} by default the model with the best +performance per measure unless stated otherwise via \code{rank_by}. } \section{se_diff}{ @@ -171,35 +205,37 @@ 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. Because models are ordered by \code{elpd_loo} before computing \code{p_worse}, all -reported values are at least 0.5 by construction. A value close to 0.5 -indicates that the models are nearly indistinguishable in predictive -performance and that the ranking could easily be reversed with different -data. A value close to 1 indicates that the lower-ranked model is almost +reported values are at least 0.5 by construction. This always holds for +\code{loo_compare()}, and for \code{model_compare()} unless \code{rank_by} pins a reference +model that is not the best one; models better than a pinned reference then +have \code{p_worse < 0.5}. A value close to 0.5 indicates that the models are +nearly indistinguishable in predictive performance and that the ranking could +easily be reversed with different data. A value close to 1 indicates that the +lower-ranked model is almost certainly worse. \code{p_worse} inherits all the limitations of \code{se_diff} and the normal approximation on which it is based. In particular, when \code{se_diff} is 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 +258,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 +283,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 +301,140 @@ 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 and the \code{rank_by} and \code{custom_se_fn} +arguments. + +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 the \code{rank_by} argument +(default \code{"elpd"}). By default each measure is compared against the model +that is best on that measure, so different difference columns may use +different reference models. Supplying \code{rank_by} pins the top-ranked model as +the single reference for all difference columns. +\subsection{\verb{\{measure\}_diff} and \verb{\{measure\}_se_diff}}{ + +For each non-ELPD measure \code{m}, \code{model_compare()} adds columns \code{m_diff} and +\code{m_se_diff}. In all cases \code{m_diff} is the difference between the two overall +estimates on a utility scale (higher is better; loss measures such as MSE, +Brier score, and SRPS have their sign flipped from the raw loss orientation). +Measures already returned on a utility scale (e.g. ELPD, CRPS/RPS) are not +sign-flipped. Negative \code{m_diff} values then indicate worse performance than +the reference model, which has \code{m_diff = 0}. + +How \code{m_se_diff} is obtained depends on the measure: +\itemize{ +\item When the overall estimate is a sum or mean of pointwise contributions, it +is computed from paired pointwise differences using the same approach as +\code{elpd_diff} and \code{se_diff} (Eq 24 in VGG2017 for sums; the mean analogue for +means). This covers ELPD, \code{mlpd}, \code{ic}, \code{mae}, \code{mse}, \code{acc}, \code{brier}, and +the ranked probability scores. +\item When a built-in measure is a transformation of such quantities, it supplies +its own delta-method standard error (\code{se_diff_fun}). For \code{rmse} this is the +first-order bivariate Taylor approximation propagated from the MSE scale, +which requires the covariance between the two models' pointwise squared +errors and is therefore not a paired pointwise standard deviation. For +\code{r2} it is the trivariate analogue, which additionally propagates the +uncertainty in the baseline \code{MSE(y)} shared by both models. +\item For custom measures it comes from the \code{custom_se_fn} argument of +\code{\link[=model_compare]{model_compare()}}, which must be supplied whenever a custom measure is +compared. It is \code{NA} when \code{custom_se_fn} is \code{NULL} for that measure. +} + +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; when a loss is +compared on a utility scale, \code{model_compare()} emits a short message naming +those measures (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 is resolved at +comparison time from the \code{custom_se_fn} argument of \code{\link[=model_compare]{model_compare()}}, +which supplies either a function, the \code{"sum"}/\code{"mean"} pointwise formulas, +or \code{NULL} 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. Custom measures never store a function here. +\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 +\code{custom_se_fn}. 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} from \code{attr(my_fun, "measure_loss") <- TRUE}, which declares +that lower values are better; without it they are treated as utilities (see +\code{\link[=insample_pred_measure]{insample_pred_measure()}}). +\code{\link[=model_compare]{model_compare()}} requires all models to provide matching \code{measure_info} for +each shared measure; a mismatched \code{measure_loss} declaration, or missing +\code{measure_info} on some models, produces an error. +} + +\subsection{\code{rank_by}, \code{compare_measures}, and related attributes}{ + +The \code{rank_by} argument takes either a measure name or a model name. A +measure name selects which measure determines model ordering, and pins the +top-ranked model as the single reference model for all pairwise differences. +A model name keeps the \code{"elpd"} ordering but pins that model as the single +reference model, whether or not it is the best one. When \code{rank_by} is +omitted, models are ordered by \code{"elpd"} and each measure is compared against +its own best model. Attribute \code{rank_by} records which of these three cases +applied, as a list with elements \code{kind} (\code{"default"}, \code{"measure"}, or +\code{"model"}), \code{measure} (the measure the rows are ordered by, always set) and +\code{model} (the pinned reference model, or \code{NULL}). 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 +(\code{"elpd"} when \code{rank_by} was not set); 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 +458,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..76f9bc3b 100644 --- a/man/loo_compare.Rd +++ b/man/loo_compare.Rd @@ -1,164 +1,54 @@ % 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, or using the \code{rank_by} and +\code{custom_se_fn} arguments, requires \code{\link[=model_compare]{model_compare()}}. -The column \code{diag_elpd} shows the PSIS-LOO Pareto k diagnostic for the -pointwise ELPD computations for each model. If \verb{K k_psis > 0.7} is shown, -where \code{K} is the number of high Pareto k values in the PSIS -computation, then there may be significant bias in \code{elpd_diff} favoring -models with a large number of high Pareto k values. -} - -\subsection{Warnings for many model comparisons}{ - -If more than \eqn{11} models are compared, we internally recompute the model -differences using the median model by ELPD as the baseline model. We then -estimate whether the differences in predictive performance are potentially -due to chance as described by McLatchie and Vehtari (2023). This will flag -a warning if it is deemed that there is a risk of over-fitting due to the -selection process. In that case users are recommended to avoid model -selection based on LOO-CV, and instead to favor model averaging/stacking or -projection predictive inference. -} +The deprecation warning is issued once per session, so a script that calls +\code{loo_compare()} repeatedly is not flooded with warnings. } \examples{ -# very artificial example, just for demonstration! LL <- example_loglik_array() -loo1 <- loo(LL) # should be worst model when compared -loo2 <- loo(LL + 1) # should be second best model when compared -loo3 <- loo(LL + 2) # should be best model when compared - -comp <- loo_compare(loo1, loo2, loo3) -print(comp, digits = 2) -print(comp, simplify = FALSE) # full table +loo1 <- loo(LL) +loo2 <- loo(LL + 1) -# can use a list of objects with custom names -# the names will be used in the output -loo_compare(list("apple" = loo1, "banana" = loo2, "cherry" = loo3)) +# deprecated; identical to model_compare(loo1, loo2) +suppressWarnings(loo_compare(loo1, loo2)) -\dontrun{ -# works for waic (and kfold) too -loo_compare(waic(LL), waic(LL - 10)) -} +# use this instead +model_compare(loo1, loo2) -} -\references{ -Vehtari, A., Gelman, A., and Gabry, J. (2017). Practical Bayesian model -evaluation using leave-one-out cross-validation and WAIC. -\emph{Statistics and Computing}. 27(5), 1413--1432. doi:10.1007/s11222-016-9696-4 -(\href{https://link.springer.com/article/10.1007/s11222-016-9696-4}{journal version}, -\href{https://arxiv.org/abs/1507.04544}{preprint arXiv:1507.04544}). - -Vehtari, A., Simpson, D., Gelman, A., Yao, Y., and Gabry, J. (2024). -Pareto smoothed importance sampling. \emph{Journal of Machine Learning Research}, -25(72):1-58. -\href{https://jmlr.org/papers/v25/19-556.html}{PDF} - -Sivula, T, Magnusson, M., Matamoros A. A., and Vehtari, A. (2025). -Uncertainty in Bayesian leave-one-out cross-validation based model -comparison. \emph{Bayesian Analysis}. \doi{10.1214/25-BA1569} - -McLatchie, Y., and Vehtari, A. (2024). Efficient estimation and -correction of selection-induced bias with order statistics. -\emph{Statistics and Computing}. 34(132). \doi{10.1007/s11222-024-10442-4} } \seealso{ -\itemize{ -\item The \href{https://mc-stan.org/loo/articles/online-only/faq.html}{FAQ page} on -the \strong{loo} website for answers to frequently asked questions. -} +\code{\link[=model_compare]{model_compare()}} } diff --git a/man/loo_pred_measure.Rd b/man/loo_pred_measure.Rd index 0f7d89a1..75e1731c 100644 --- a/man/loo_pred_measure.Rd +++ b/man/loo_pred_measure.Rd @@ -44,7 +44,30 @@ functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. } Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and \code{log_weights} that appear in their formals, plus arguments from \code{control}. -They must return a list with \code{estimates} and \code{pointwise}.} +They must return a list with \code{estimates} and \code{pointwise}. + +A custom measure declares whether it is a loss (lower is better) or a +utility (higher is better) with attribute \code{"measure_loss"}: +\code{attr(my_fun, "measure_loss") <- TRUE} for a loss. 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 declares nothing about the standard error of a difference +between two models. That is supplied at comparison time through the +\code{custom_se_fn} argument of \code{\link[=model_compare]{model_compare()}}, which accepts a function +\code{function(ref, cmp) ...}, the shorthands \code{"sum"} and \code{"mean"} for the +paired pointwise formulas, or \code{NULL} to report 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 +\code{custom_se_fn}; 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 @@ -115,6 +138,26 @@ adding measures incrementally, call \code{\link[=pred_measure]{pred_measure()}} 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 the standard error of their difference from the \code{custom_se_fn} +argument of \code{\link[=model_compare]{model_compare()}}; their \code{loss} comes from +\code{attr(my_fun, "measure_loss") <- TRUE}, which declares that lower values are +better. Without that declaration a custom measure is treated as a utility, so +an undeclared loss is compared and ranked in the wrong direction. See +\link{loo-glossary}. +} + \examples{ \donttest{ if (requireNamespace("brms", quietly = TRUE)) { diff --git a/man/loo_subsample.Rd b/man/loo_subsample.Rd index 6f381db6..663045e7 100644 --- a/man/loo_subsample.Rd +++ b/man/loo_subsample.Rd @@ -196,5 +196,5 @@ In \emph{Proceedings of the 23rd International Conference on Artificial Intelligence and Statistics (AISTATS)}, PMLR 108:341-351. } \seealso{ -\code{\link[=loo]{loo()}}, \code{\link[=psis]{psis()}}, \code{\link[=loo_compare]{loo_compare()}} +\code{\link[=loo]{loo()}}, \code{\link[=psis]{psis()}}, \code{\link[=loo_compare]{loo_compare()}}, \code{\link[=model_compare]{model_compare()}} } diff --git a/man/measure_acc.Rd b/man/measure_acc.Rd index f430d0d8..2e253e38 100644 --- a/man/measure_acc.Rd +++ b/man/measure_acc.Rd @@ -4,13 +4,7 @@ \alias{measure_acc} \title{Classification accuracy (\code{acc})} \usage{ -measure_acc( - y, - mupred, - log_weights = NULL, - pointwise = NULL, - higher_is_better = NULL -) +measure_acc(y, mupred, log_weights = NULL, pointwise = NULL) } \arguments{ \item{y}{An integer vector of observed class labels.} @@ -25,12 +19,6 @@ before computing each per-observation contribution.} \item{pointwise}{Optional numeric vector of precomputed pointwise accuracy contributions. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \description{ Computes pointwise and average classification accuracy for binary or diff --git a/man/measure_bacc.Rd b/man/measure_bacc.Rd index 824fe977..062dec82 100644 --- a/man/measure_bacc.Rd +++ b/man/measure_bacc.Rd @@ -4,13 +4,7 @@ \alias{measure_bacc} \title{Balanced classification accuracy (\code{bacc})} \usage{ -measure_bacc( - y, - mupred, - log_weights = NULL, - pointwise = NULL, - higher_is_better = NULL -) +measure_bacc(y, mupred, log_weights = NULL, pointwise = NULL) } \arguments{ \item{y}{An integer vector of observed class labels.} @@ -25,12 +19,6 @@ before computing each per-observation contribution.} \item{pointwise}{Optional numeric vector of precomputed pointwise accuracy contributions. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \description{ Computes balanced accuracy by averaging class-specific mean accuracy, giving diff --git a/man/measure_brier.Rd b/man/measure_brier.Rd index 3019f357..ede2aa45 100644 --- a/man/measure_brier.Rd +++ b/man/measure_brier.Rd @@ -4,13 +4,7 @@ \alias{measure_brier} \title{Brier score (\code{brier})} \usage{ -measure_brier( - y, - ypred, - log_weights = NULL, - pointwise = NULL, - higher_is_better = NULL -) +measure_brier(y, ypred, log_weights = NULL, pointwise = NULL) } \arguments{ \item{y}{A numeric vector of binary outcomes coded as 0 or 1.} @@ -24,12 +18,6 @@ before computing each per-observation contribution.} \item{pointwise}{Optional numeric vector of precomputed pointwise Brier scores. If provided, \code{y}, \code{ypred}, and \code{log_weights} are ignored.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \description{ Computes the Brier score for binary outcomes as squared error between the diff --git a/man/measure_elpd.Rd b/man/measure_elpd.Rd index a588e577..b9efd035 100644 --- a/man/measure_elpd.Rd +++ b/man/measure_elpd.Rd @@ -4,12 +4,7 @@ \alias{measure_elpd} \title{Expected log pointwise predictive density (\code{elpd})} \usage{ -measure_elpd( - ylp, - log_weights = NULL, - pointwise = NULL, - higher_is_better = NULL -) +measure_elpd(ylp, log_weights = NULL, pointwise = NULL) } \arguments{ \item{ylp}{A numeric matrix or three-dimensional array of log predictive @@ -28,19 +23,12 @@ before computing each per-observation contribution.} \item{pointwise}{Optional numeric vector of precomputed \eqn{\mathrm{lppd}_i} values. When supplied, \code{ylp} and \code{log_weights} are ignored.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \description{ Computes the expected log pointwise predictive density (ELPD) as the sum of pointwise log predictive density contributions (\eqn{\mathrm{lppd}_i}), using \code{\link[=ptw_log_pred_density]{ptw_log_pred_density()}}. ELPD is returned on the utility scale (higher is better), consistent with the sign convention used throughout this package. -Manual change of sign convention is possible via \code{higher_is_better}. } \details{ \deqn{\mathrm{elpd} = \sum_{i=1}^{n} \mathrm{lppd}_i,} diff --git a/man/measure_ic.Rd b/man/measure_ic.Rd index b8a64c53..902f5117 100644 --- a/man/measure_ic.Rd +++ b/man/measure_ic.Rd @@ -4,7 +4,7 @@ \alias{measure_ic} \title{Information Criteria (\code{ic})} \usage{ -measure_ic(ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL) +measure_ic(ylp, log_weights = NULL, pointwise = NULL) } \arguments{ \item{ylp}{A numeric matrix or three-dimensional array of log predictive @@ -24,12 +24,6 @@ before computing each per-observation contribution.} \item{pointwise}{Optional numeric vector of precomputed pointwise contributions \eqn{\mathrm{ic}_i = -2 \cdot \mathrm{lppd}_i}. If provided, \code{ylp} and \code{log_weights} are ignored.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \description{ Computes the information criteria as -2 x log predictive density (lppd_i) diff --git a/man/measure_mae.Rd b/man/measure_mae.Rd index 0b0cfe88..7192a790 100644 --- a/man/measure_mae.Rd +++ b/man/measure_mae.Rd @@ -4,13 +4,7 @@ \alias{measure_mae} \title{Mean absolute error (\code{mae})} \usage{ -measure_mae( - y, - mupred, - log_weights = NULL, - pointwise = NULL, - higher_is_better = NULL -) +measure_mae(y, mupred, log_weights = NULL, pointwise = NULL) } \arguments{ \item{y}{A numeric vector of observed outcomes.} @@ -24,12 +18,6 @@ before computing each per-observation contribution.} \item{pointwise}{Optional numeric vector of precomputed pointwise absolute errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \description{ Computes MAE between observed outcomes and posterior predictive point diff --git a/man/measure_mlpd.Rd b/man/measure_mlpd.Rd index 8017e44c..571217df 100644 --- a/man/measure_mlpd.Rd +++ b/man/measure_mlpd.Rd @@ -4,12 +4,7 @@ \alias{measure_mlpd} \title{Mean log pointwise predictive density (\code{mlpd})} \usage{ -measure_mlpd( - ylp, - log_weights = NULL, - pointwise = NULL, - higher_is_better = NULL -) +measure_mlpd(ylp, log_weights = NULL, pointwise = NULL) } \arguments{ \item{ylp}{A numeric matrix or three-dimensional array of log predictive @@ -28,12 +23,6 @@ before computing each per-observation contribution.} \item{pointwise}{Optional numeric vector of precomputed \eqn{\mathrm{lppd}_i} values. When supplied, \code{ylp} and \code{log_weights} are ignored.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \description{ Computes MLPD as the average of pointwise log predictive density (lppd_i) diff --git a/man/measure_mse.Rd b/man/measure_mse.Rd index dc511b36..be0f5b47 100644 --- a/man/measure_mse.Rd +++ b/man/measure_mse.Rd @@ -4,13 +4,7 @@ \alias{measure_mse} \title{Mean squared error (\code{mse})} \usage{ -measure_mse( - y, - mupred, - log_weights = NULL, - pointwise = NULL, - higher_is_better = NULL -) +measure_mse(y, mupred, log_weights = NULL, pointwise = NULL) } \arguments{ \item{y}{A numeric vector of observed outcomes.} @@ -24,12 +18,6 @@ before computing each per-observation contribution.} \item{pointwise}{Optional numeric vector of precomputed pointwise squared errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \description{ Computes MSE between observed outcomes and posterior predictive point diff --git a/man/measure_params.Rd b/man/measure_params.Rd index ad7aa8d7..fd880a57 100644 --- a/man/measure_params.Rd +++ b/man/measure_params.Rd @@ -10,12 +10,6 @@ before computing each per-observation contribution.} \item{pointwise}{Optional numeric vector of precomputed per-observation contributions. When supplied, \code{ylp} and \code{log_weights} are ignored.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \value{ An object of class \code{"measure"}: a list with: diff --git a/man/measure_r2.Rd b/man/measure_r2.Rd index 42a4f71f..f9d6e9bf 100644 --- a/man/measure_r2.Rd +++ b/man/measure_r2.Rd @@ -4,13 +4,7 @@ \alias{measure_r2} \title{Predictive R-squared (\code{r2})} \usage{ -measure_r2( - y, - mupred, - log_weights = NULL, - pointwise = NULL, - higher_is_better = NULL -) +measure_r2(y, mupred, log_weights = NULL, pointwise = NULL) } \arguments{ \item{y}{A numeric vector of observed outcomes.} @@ -25,12 +19,6 @@ before computing each per-observation contribution.} \item{pointwise}{Optional numeric vector of precomputed pointwise squared errors. If provided, \code{mupred} and \code{log_weights} are ignored. \code{y} is always required, because \code{r2} needs the variance of \code{y} as its baseline.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \description{ Computes predictive R-squared as one minus the ratio of prediction MSE to diff --git a/man/measure_rmse.Rd b/man/measure_rmse.Rd index 95a98e37..ca04c7a1 100644 --- a/man/measure_rmse.Rd +++ b/man/measure_rmse.Rd @@ -4,13 +4,7 @@ \alias{measure_rmse} \title{Root mean squared error (\code{rmse})} \usage{ -measure_rmse( - y, - mupred, - log_weights = NULL, - pointwise = NULL, - higher_is_better = NULL -) +measure_rmse(y, mupred, log_weights = NULL, pointwise = NULL) } \arguments{ \item{y}{A numeric vector of observed outcomes.} @@ -24,12 +18,6 @@ before computing each per-observation contribution.} \item{pointwise}{Optional numeric vector of precomputed pointwise squared errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \description{ Computes RMSE as the square root of MSE and propagates uncertainty via a diff --git a/man/measure_rps.Rd b/man/measure_rps.Rd index 11e9f14c..fd953307 100644 --- a/man/measure_rps.Rd +++ b/man/measure_rps.Rd @@ -4,14 +4,7 @@ \alias{measure_rps} \title{Ranked Probability Score (RPS, SRPS, CRPS, SCRPS)} \usage{ -measure_rps( - y, - ypred, - log_weights = NULL, - pointwise = NULL, - scaled = FALSE, - higher_is_better = NULL -) +measure_rps(y, ypred, log_weights = NULL, pointwise = NULL, scaled = FALSE) } \arguments{ \item{y}{A numeric vector of \eqn{n} observed outcomes. May be integer-valued @@ -24,17 +17,15 @@ measure_rps( weights with dimensions \eqn{S \times n}. Weights are column-normalized before computing each per-observation contribution.} -\item{pointwise}{Optional numeric vector of precomputed pointwise rps values. -If provided, \code{y}, \code{ypred}, and \code{log_weights} are ignored.} +\item{pointwise}{Optional numeric vector of precomputed pointwise values, on +the scale of the measure that is returned: RPS/CRPS when \code{scaled = FALSE} +and SRPS/SCRPS when \code{scaled = TRUE}. The values are used as they are, with +no further transformation; in particular, unscaled values are not converted +to the scaled variant. If provided, \code{y}, \code{ypred}, and \code{log_weights} are +ignored.} \item{scaled}{Logical; if \code{TRUE}, computes the scaled variant (SRPS for discrete outcomes, SCRPS for continuous outcomes). Default is \code{FALSE}.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} } \description{ Computes proper scoring rules based on the ranked probability score family, @@ -74,15 +65,28 @@ accurate than single-permutation estimators. The same estimator is used for both discrete and continuous outcomes; see Hosking (1990, 1996) for theoretical justification in the discrete case. -If log-weights (\code{log_weights}) are provided (e.g., PSIS weights -for LOO cross-validation), a weighted PWM estimator is used instead, which -accounts for the importance weights when estimating expectations. +The term \eqn{E[|X - X'|]} is computed as a weighted average over all pairs +of draws, +\deqn{E[|X - X'|] = \frac{\sum_i \sum_{j \neq i} w_i w_j |x_i - x_j|}{1 - + \sum_i w_i^2},} +which is evaluated in \eqn{O(S \log S)} using the sorted draws and the +cumulative sums of their weights. If log-weights (\code{log_weights}) are provided +(e.g., PSIS weights for LOO cross-validation), the \eqn{w_i} are the +normalized importance weights and \eqn{E[|X - y|]} is likewise a weighted +mean. Otherwise the weights are equal, \eqn{w_i = 1/S}, and the expression +reduces to the usual unbiased PWM estimator with the \eqn{1 / (S (S - 1))} +normalization. Because the estimate is a convex combination of +\eqn{|x_i - x_j|}, it is always non-negative and invariant to shifts of +\code{ypred}. \strong{Sign convention:} -Unscaled scores are returned as losses (lower is better). Scaled scores are -returned as utilities (higher is better), after Bolin & Wallin (2023). Set -\code{higher_is_better} to select the orientation you want. +Unscaled scores (RPS, CRPS) are returned on the loss scale of Gneiting & +Raftery (2007): lower is better. Scaled scores (SRPS, SCRPS) follow Bolin & +Wallin (2023) and are returned on the utility scale: higher is better. +\code{\link[=model_compare]{model_compare()}} reports differences for both on the utility scale, so no +manual conversion is needed there. The deprecated \code{\link[=crps]{crps()}} returned the +negated unscaled score; \code{-measure_rps(...)$pointwise} reproduces it. } \examples{ # Discrete outcomes: RPS diff --git a/man/measure_srps.Rd b/man/measure_srps.Rd index 270cf74e..4e472582 100644 --- a/man/measure_srps.Rd +++ b/man/measure_srps.Rd @@ -4,13 +4,7 @@ \alias{measure_srps} \title{Scaled Ranked Probability Score (SRPS, SCRPS)} \usage{ -measure_srps( - y, - ypred, - log_weights = NULL, - pointwise = NULL, - higher_is_better = NULL -) +measure_srps(y, ypred, log_weights = NULL, pointwise = NULL) } \arguments{ \item{y}{A numeric vector of \eqn{n} observed outcomes. May be integer-valued @@ -23,14 +17,12 @@ measure_srps( weights with dimensions \eqn{S \times n}. Weights are column-normalized before computing each per-observation contribution.} -\item{pointwise}{Optional numeric vector of precomputed pointwise rps values. -If provided, \code{y}, \code{ypred}, and \code{log_weights} are ignored.} - -\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate -better predictive performance. \code{NULL} (default) keeps each measure's -natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). -Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss -scale (lower is better).} +\item{pointwise}{Optional numeric vector of precomputed pointwise values, on +the scale of the measure that is returned: RPS/CRPS when \code{scaled = FALSE} +and SRPS/SCRPS when \code{scaled = TRUE}. The values are used as they are, with +no further transformation; in particular, unscaled values are not converted +to the scaled variant. If provided, \code{y}, \code{ypred}, and \code{log_weights} are +ignored.} } \description{ A convenience wrapper around \code{\link[=measure_rps]{measure_rps()}} with \code{scaled = TRUE}. Computes the diff --git a/man/model_compare.Rd b/man/model_compare.Rd new file mode 100644 index 00000000..8cdeafcd --- /dev/null +++ b/man/model_compare.Rd @@ -0,0 +1,399 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/model_compare-print.R, R/model_compare.R, +% R/model_compare.psis_loo_ss_list.R +\name{print.compare.loo} +\alias{print.compare.loo} +\alias{model_compare} +\alias{model_compare.default} +\alias{print.compare.loo_ss} +\title{Model comparison} +\usage{ +\method{print}{compare.loo}(x, ..., digits = 1, p_worse = TRUE, simplify = TRUE, measures = NULL) + +model_compare(x, ..., rank_by = NULL, custom_se_fn) + +\method{model_compare}{default}(x, ..., rank_by = NULL, custom_se_fn) + +\method{print}{compare.loo_ss}(x, ..., digits = 1) +} +\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 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 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 its own measure's estimate and +standard error, and an ELPD table also gains \code{p} and \code{se_p}.} + +\item{measures}{For \code{loo_pred_measure} comparisons only, which measures to +print diff tables for. \code{NULL} (default) prints only the ranking measure +(\code{"elpd"} when \code{rank_by} was not set, otherwise \code{rank_by}); +\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.} + +\item{rank_by}{A single string naming either a \strong{measure} or a \strong{model}, +used to pin one reference model for all pairwise differences. + +A \strong{measure name} (\code{\link{pred_measure}} comparisons only) orders +models by that measure and makes the top-ranked model the reference. Bare +names are matched regardless of source, so \code{rank_by = "rmse"} selects +\code{rmse_loo}, \code{rmse_kfold}, or \code{rmse_test} as appropriate. + +A \strong{model name} (one of the names in the \code{model} column, i.e. the list +names or \code{model1}, \code{model2}, ...) pins that model as the reference, +whichever model performs best, and leaves rows ordered by \code{"elpd"}. This +form also works for classic comparisons, where \code{elpd_diff} is then relative +to the named model rather than to the best one. A name matching both a +measure and a model is treated as the measure, with a warning. + +With \code{rank_by = NULL} (the default) rows are ordered by \code{"elpd"} and each +measure is compared against \emph{its own} best model, so \code{mse_diff} may use a +different reference than \code{elpd_diff}. Each \verb{\{measure\}_diff} column then has +exactly one \code{0} entry, at that measure's best model.} + +\item{custom_se_fn}{How to compute the standard error of the difference +between two models for a \strong{custom} measure. Required whenever a custom +measure is compared; nothing is inferred from the measure's values. One of: +\itemize{ +\item a \strong{function} called as \code{custom_se_fn(ref, cmp)} (see +\strong{Custom measure standard errors} below); +\item \code{"sum"}, for a measure whose estimate is the sum of its pointwise +values, giving \code{sqrt(N) * sd(d_i)} as for \code{elpd}; +\item \code{"mean"}, for a measure whose estimate is the mean of its pointwise +values, giving \code{sd(d_i) / sqrt(N)} as for \code{mae}; +\item \code{NULL}, to report the difference with an \code{NA} standard error. +} +For two or more custom measures, pass a list named by bare measure name, +e.g. \code{list(huber = "mean", nrmse = my_se_fn)}. Ignored, with a warning, +when no custom measure is present.} +} +\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{rank_by}}{ +How the reference model was chosen, as a list with elements \code{kind} +(\code{"default"}, \code{"measure"}, or \code{"model"}, for the three cases described +under \code{rank_by} above), \code{measure} (bare name of the measure the rows +are ordered by, always set, \code{"elpd"} by default) and \code{model} (the +pinned reference model, or \code{NULL} unless \code{kind} is \code{"model"}). +} +\item{\code{compare_reference}}{ +A named character vector giving, for each measure, the model its +differences were computed against. All entries name the same model +unless \code{kind} is \code{"default"}. +} +\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{rank_by} and \code{compare_reference} are 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}. See \code{rank_by} for how that +reference is chosen. When it is the best model on a measure, as in classic +comparisons, the remaining differences for that measure are all negative. + +The standard error of a difference is a paired estimate, which uses the +fact that the same \eqn{N} data points were used for both models. It should +not be expected to equal the difference of the two models' standard errors. +} + +\subsection{\code{p_worse}, \code{diag_diff}, and \code{diag_elpd}}{ + +\code{p_worse} is the probability that a model has worse ELPD than the reference +model, computed with a normal approximation from \code{elpd_diff} and \code{se_diff}. +Sivula et al. (2025) give the conditions under which that approximation is +good; \code{diag_diff} reports the two that fail most often: +\itemize{ +\item \code{N < 100} (small data) +\item \verb{|elpd_diff| < 4} (models make similar predictions) +} + +Either message means the error distribution is skewed or thick tailed, the +normal approximation is not well calibrated, and \code{p_worse} is likely too +large. If \verb{|elpd_diff|} is many times \code{se_diff} the difference is +quite certain. Model misspecification and outliers also skew the error +distribution, and can be diagnosed with the usual predictive checks. + +\code{diag_elpd} reports the PSIS-LOO Pareto \eqn{\hat{k}} diagnostic for each +model's pointwise ELPD. An entry \verb{K k_psis > 0.7}, where \code{K} counts the +high Pareto \eqn{\hat{k}} values, warns of possible bias in \code{elpd_diff} +favoring models with many such values. Pareto \eqn{\hat{k}} describes a +model's PSIS-LOO approximation rather than any one measure or pair of +models, and every LOO measure uses the same importance weights, so for +\code{pred_measure} comparisons \code{print()} reports it once per model in a block +above the difference tables instead of as a column inside one of them. The +\code{diag_elpd} column is still returned on the object. +} + +\subsection{Comparing \code{pred_measure} objects}{ + +When all inputs are predictive measure results sharing one evaluation +source, paired differences are computed for every measure present in all +models. Measures are matched on their bare names, so the source suffix +(\verb{_loo}, \verb{_kfold}, \verb{_test}, or none for in-sample) is handled +transparently. When the models were evaluated on different \code{measure} sets, +only the shared measures are compared and a warning lists the omitted ones. + +The data frame carries one row order for all measures, but each \emph{printed} +measure table is sorted by its own difference, so the best model on that +measure always leads its table and the differences run in decreasing order. +Use \code{print(x, measures = "all")} to display a table for every compared +measure; see \link{loo-glossary} for column definitions. +} + +\subsection{Utility scale and sign conversion}{ + +Measures differ in orientation in their raw form: ELPD and SRPS/SCRPS are +utilities (higher is better), while MSE, RPS/CRPS and the Brier score are +losses (lower is better). All \verb{\{measure\}_diff} values are reported on a +common utility scale, so loss measures have their sign flipped and a +negative \verb{\{measure\}_diff} always means worse performance than the +reference. Which measures are losses is recorded in the \code{loss} element of +each measure's entry in the \code{measure_info} attribute of an +\verb{*_pred_measure()} result. The flipped measures are named in the +\code{sign_converted_measures} attribute and in a message, for example: +"For model comparison, differences for mse are reported on a utility scale +(higher is better)." + +A custom measure is treated as a utility unless it declares otherwise with +\code{attr(my_fun, "measure_loss") <- TRUE}. The declaration also determines the +direction of \code{rank_by}, 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"}: a custom measure declares nothing, so \code{custom_se_fn} must be +supplied. \verb{\{measure\}_se_diff} is \code{NA} only when \code{custom_se_fn} is an +explicit \code{NULL} for that measure. +} +} + +\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 \code{rank_by} 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. +} +} +\section{Custom measure standard errors}{ + +A function passed as \code{custom_se_fn} is called once per comparison as +\verb{custom_se_fn(ref = , cmp = )}, with \strong{named} arguments. Each +argument describes one model and has elements \code{estimate} (scalar), \code{se} +(that model's own standard error), \code{pointwise} (a plain numeric vector, not +a matrix), and \code{extra} (whatever the measure returned as \code{extra}, or +\code{NULL}). All values are on the measure's natural scale, so the function +does not need to account for the utility-scale conversion applied to the +reported differences. It must return the standard error of the difference +as a numeric scalar. For example: + +\if{html}{\out{
}}\preformatted{my_se_fn <- function(ref, cmp) \{ + d <- cmp$pointwise - ref$pointwise + sd(d) / sqrt(length(d)) +\} +}\if{html}{\out{
}} +} + +\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), + measure = c("rmse", "r2") + ) + pm2 <- loo_pred_measure( + loo = loo(fit2, save_psis = TRUE), + y = fit2$data$Reaction, + mupred = brms::posterior_epred(fit2), + measure = c("rmse", "r2") + ) + comp <- model_compare(pm1, pm2) + print(comp) # ranked by elpd (default) + print(comp, measures = "all") # all measure diff tables + model_compare(pm1, pm2, rank_by = "rmse") + + # `rank_by` also takes a model name: every measure is then compared + # against that model, whether or not it is the best one + model_compare(list(m1 = pm1, m2 = pm2), rank_by = "m1") + + # the same works for k-fold CV; `rank_by` still takes the bare name + # even though the measures are stored as `elpd_kfold`, `rmse_kfold`, ... + kf1 <- brms::kfold(fit1, K = 5, save_fits = TRUE) + kf2 <- brms::kfold(fit2, K = 5, save_fits = TRUE) + kpm1 <- kfold_pred_measure( + y = fit1$data$Reaction, + mupred = brms::kfold_predict(kf1, method = "fitted")$yrep, + kfold = kf1, + measure = "rmse" + ) + kpm2 <- kfold_pred_measure( + y = fit2$data$Reaction, + mupred = brms::kfold_predict(kf2, method = "fitted")$yrep, + kfold = kf2, + measure = "rmse" + ) + model_compare(kpm1, kpm2, rank_by = "rmse") + + # 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}{Differences and their standard errors in model comparison} +on the \strong{loo} website, for how the differences and their standard errors +are computed for each measure and when the normal approximation behind +\code{p_worse} can be trusted. +} +} diff --git a/man/pred_measure.Rd b/man/pred_measure.Rd index fa8c3e36..eea117cc 100644 --- a/man/pred_measure.Rd +++ b/man/pred_measure.Rd @@ -44,7 +44,30 @@ functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. } Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and \code{log_weights} that appear in their formals, plus arguments from \code{control}. -They must return a list with \code{estimates} and \code{pointwise}.} +They must return a list with \code{estimates} and \code{pointwise}. + +A custom measure declares whether it is a loss (lower is better) or a +utility (higher is better) with attribute \code{"measure_loss"}: +\code{attr(my_fun, "measure_loss") <- TRUE} for a loss. 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 declares nothing about the standard error of a difference +between two models. That is supplied at comparison time through the +\code{custom_se_fn} argument of \code{\link[=model_compare]{model_compare()}}, which accepts a function +\code{function(ref, cmp) ...}, the shorthands \code{"sum"} and \code{"mean"} for the +paired pointwise formulas, or \code{NULL} to report 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 +\code{custom_se_fn}; 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, base density summaries and @@ -69,7 +92,8 @@ measure's summary function (e.g. \code{list(new_measure = list(add_arg = 10))}). 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. Base summaries (\code{elpd} and LOO/k-fold complexity terms such as \code{p_loo}) are not -recomputed. +recomputed. Attribute \code{measure_info} is extended for any newly added +measures. } \description{ Extend a \code{"pred_measure"} object with additional measures \strong{without @@ -100,6 +124,26 @@ 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. } +\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 the standard error of their difference from the \code{custom_se_fn} +argument of \code{\link[=model_compare]{model_compare()}}; their \code{loss} comes from +\code{attr(my_fun, "measure_loss") <- TRUE}, which declares that lower values are +better. Without that declaration a custom measure is treated as a utility, so +an undeclared loss is compared and ranked in the wrong direction. See +\link{loo-glossary}. +} + \examples{ \donttest{ if (requireNamespace("brms", quietly = TRUE)) { diff --git a/man/pred_measure_params.Rd b/man/pred_measure_params.Rd index 3d3eb294..0135e3ab 100644 --- a/man/pred_measure_params.Rd +++ b/man/pred_measure_params.Rd @@ -54,7 +54,30 @@ functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. } Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and \code{log_weights} that appear in their formals, plus arguments from \code{control}. -They must return a list with \code{estimates} and \code{pointwise}.} +They must return a list with \code{estimates} and \code{pointwise}. + +A custom measure declares whether it is a loss (lower is better) or a +utility (higher is better) with attribute \code{"measure_loss"}: +\code{attr(my_fun, "measure_loss") <- TRUE} for a loss. 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 declares nothing about the standard error of a difference +between two models. That is supplied at comparison time through the +\code{custom_se_fn} argument of \code{\link[=model_compare]{model_compare()}}, which accepts a function +\code{function(ref, cmp) ...}, the shorthands \code{"sum"} and \code{"mean"} for the +paired pointwise formulas, or \code{NULL} to report 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 +\code{custom_se_fn}; 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, base density summaries and @@ -87,9 +110,15 @@ functions; required when calling \code{\link[=do_pred_measure]{do_pred_measure() element of \code{measure}; the value is a list of arguments passed to that measure's summary function (e.g. \code{list(new_measure = list(add_arg = 10))}).} -\item{measure_name}{For a single custom function, set -\code{attr(my_fun, "measure_name") <- "my_metric"} before passing \code{my_fun} to -\code{measure}.} +\item{measure_name}{Only needed when \code{measure} is a single custom function +passed directly (not inside a list) — it sets the name that function is +reported under. Set it with \code{attr(my_fun, "measure_name") <- "my_metric"} +before passing \code{my_fun} to \code{measure}. If you pass the same function inside +a list instead (e.g. \code{list(my_metric = my_fun)}), it takes its name from +the list element and \code{measure_name} isn't needed — this also lets the +same function be reused under several names. If both are set and disagree, +the list name wins and a warning is issued. Either way, +\code{attr(my_fun, "measure_loss")} is still read from the function itself.} } \description{ Parameter definitions shared by the user-facing entry points and the diff --git a/man/test_pred_measure.Rd b/man/test_pred_measure.Rd index c91b58dd..fe30df8f 100644 --- a/man/test_pred_measure.Rd +++ b/man/test_pred_measure.Rd @@ -47,7 +47,30 @@ functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. } Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and \code{log_weights} that appear in their formals, plus arguments from \code{control}. -They must return a list with \code{estimates} and \code{pointwise}.} +They must return a list with \code{estimates} and \code{pointwise}. + +A custom measure declares whether it is a loss (lower is better) or a +utility (higher is better) with attribute \code{"measure_loss"}: +\code{attr(my_fun, "measure_loss") <- TRUE} for a loss. 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 declares nothing about the standard error of a difference +between two models. That is supplied at comparison time through the +\code{custom_se_fn} argument of \code{\link[=model_compare]{model_compare()}}, which accepts a function +\code{function(ref, cmp) ...}, the shorthands \code{"sum"} and \code{"mean"} for the +paired pointwise formulas, or \code{NULL} to report 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 +\code{custom_se_fn}; the built-in \code{r2} uses it for the baseline +\code{(y_i - mean(y))^2}, which cannot be recovered once \code{y} is out of scope.} \item{group_ids}{Optional vector of group identifiers for grouped summaries (reserved; not yet implemented).} @@ -79,6 +102,26 @@ training fit. The base summary \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 the standard error of their difference from the \code{custom_se_fn} +argument of \code{\link[=model_compare]{model_compare()}}; their \code{loss} comes from +\code{attr(my_fun, "measure_loss") <- TRUE}, which declares that lower values are +better. Without that declaration a custom measure is treated as a utility, so +an undeclared loss is compared and ranked in the wrong direction. See +\link{loo-glossary}. +} + \examples{ \donttest{ if (requireNamespace("brms", quietly = TRUE)) { diff --git a/man/waic.Rd b/man/waic.Rd index 345bd638..101b7462 100644 --- a/man/waic.Rd +++ b/man/waic.Rd @@ -135,6 +135,7 @@ Pareto smoothed importance sampling. \emph{Journal of Machine Learning Research} \item The \strong{loo} package \href{https://mc-stan.org/loo/articles/}{vignettes} and Vehtari, Gelman, and Gabry (2017) and Vehtari, Simpson, Gelman, Yao, and Gabry (2024) for more details on why we prefer \code{loo()} to \code{waic()}. -\item \code{\link[=loo_compare]{loo_compare()}} for comparing models on approximate LOO-CV or WAIC. +\item \code{\link[=loo_compare]{loo_compare()}} and \code{\link[=model_compare]{model_compare()}} for comparing models on approximate +LOO-CV or WAIC. } } diff --git a/notes/developer-notes.Rmd b/notes/developer-notes.Rmd index ae190ae4..6c684061 100644 --- a/notes/developer-notes.Rmd +++ b/notes/developer-notes.Rmd @@ -20,10 +20,10 @@ knitr::opts_chunk$set( > **Status:** In Progress > **Base branch:** `loo-v3.0.0` -> **Compare branch:** `pred_measure` +> **Compare branch:** `pred_measure` (+ `integrate-loo_compare`) > **Related PR:** [#363](https://github.com/stan-dev/loo/pull/363) > **Contributors:** @florence-bockting, @avehtari, @VisruthSK, @jgabry -> **Last updated:** 2026-07-03 +> **Last updated:** 2026-07-07 These notes document internal design decisions and ongoing work for the `pred_measure` feature. This PR **adds** the new API. @@ -37,7 +37,7 @@ These notes document internal design decisions and ongoing work for the | Scoring rules (`measure_rps`) | Done | | Documentation | In progress | | `group_ids` grouping | Not started | -| `loo_compare` integration | Not started | +| `loo_compare` integration | Done (`integrate-loo_compare`) | ## Scope of this PR (`pred_measure` vs `loo-v3.0.0`) @@ -52,6 +52,7 @@ These notes document internal design decisions and ongoing work for the - `vignettes/migration-guide.Rmd` - Website-only articles: `overview-measures.Rmd`, `pred-measure-workflow.Rmd` - Test suite + pre-fitted fixtures + `test_data_generation.R` +- `loo_compare()` multi-measure path for `loo_pred_measure` objects ### Changed on existing code (implementations retained) @@ -61,6 +62,9 @@ These notes document internal design decisions and ongoing work for the - `elpd()` — refactored to `.elpd_matrix_impl()` to avoid double deprecation warnings - Minor doc cross-references in `compare.R`, `psislw.R` +- `loo_compare()` — extended for `loo_pred_measure` objects: `rank_by`, multi-measure + paired diffs, updated `print.compare.loo(measures = ...)`; classic `loo` path unchanged +- `R/loo-glossary.R` — multi-measure comparison columns (`{measure}_diff`, `rank_by`, etc.) - `NEWS.md`, `NAMESPACE`, `_pkgdown.yml`, pkgdown CI workflow ## Design decisions (resolved) @@ -111,15 +115,41 @@ Design choices **internal to `pred_measure`**: - [ ] Verify `kfold_pred_measure()` with categorical/multinomial examples end-to-end (penguins fixture exists; confirm test/doc coverage) +### D4: `loo_compare()` for `loo_pred_measure` objects + +**Decision:** Extend existing `loo_compare()`, not a separate function. + +- When all inputs are `loo_pred_measure` objects, compute paired differences for + every measure common to all models +- Rank models by `rank_by` (default `"elpd"`); top-ranked model is the reference + for all `{measure}_diff` columns +- ELPD-family measures keep `elpd_diff` / `se_diff`; other measures use + `{measure}_diff` / `{measure}_se_diff` +- `p_worse` and `diag_diff` apply to ELPD only; `diag_elpd` per model as before +- Loss measures (MSE, RMSE, MAE, IC) compared on a utility scale (negated) so + worse models have negative diffs, consistent with ELPD +- Pointwise SEs use the same paired formula as ELPD when the overall estimate is + a sum or mean of pointwise contributions; otherwise `{measure}_se_diff` is `NA` + (e.g. `r2`, `mse`, `rmse`) +- Reuse `elpd_diffs`, `se_elpd_diff`, `diag_diff`, `diag_elpd`, and many-model + order-statistic check (with `rank_by` when applicable) +- `print.compare.loo(measures = ...)` shows one or all measure diff tables + +Implemented on branch `integrate-loo_compare`; tests in `test_compare.R` with +fixture `test_data_roaches_compare.Rds`. + ## Open decisions ### D1: Sign convention for pointwise estimates - **Context:** Measures differ in orientation (`rps`: lower is better; `srps`: higher is better). Aligning orientations may help comparisons. -- **Options:** `lower_is_better`, `orientation = "utility" / "loss"`, - `higher_is_better` (per-measure orientation control on `measure_*()` functions) -- **Decision:** *pending* +- **Decision:** *resolved.* Values are always stored on the measure's own + scale. A single `loss` flag (`.measure_spec` for built-ins, + `attr(fun, "measure_loss")` for custom measures) records the orientation, and + `model_compare()` converts to a common utility scale when reporting + differences. The per-call `higher_is_better` control has been removed: it only + changed the sign of stored values, and comparisons were invariant to it. ### D3: Handling of `r_eff` @@ -127,6 +157,103 @@ Design choices **internal to `pred_measure`**: - **Question:** How should `r_eff` be handled in `pred_measure` workflows? - **Decision:** *pending* +### D5: Weighted `E|X − X'|` — why the derivation in `crps_pwm.pdf` is not used + +- **Decision:** *resolved.* `.exx_pwm()` (`R/pred_measure-helpers.R`) estimates + `E|X − X'|` with the bias-corrected weighted Gini mean difference + + ``` r + EXX = sum_{i != j} w_i w_j |x_i - x_j| / (1 - sum_i w_i^2) + ``` + + computed on sorted draws as `2 * sum(w_s * x_s * (2 * C_s - w_s - 1)) / (1 - sum(w^2))`, + with `C_s = sum_{k <= s} w_k`. At equal weights this is exactly the unbiased + PWM estimator of Taillardat et al. (2016) with the `1 / (S (S - 1))` + normalization, so the weighted and unweighted paths agree. + +- **Why not `notes/crps_pwm.pdf` (section 0.3).** The note derives a weighted + estimator from `E|X − X'| = 2 (E[X] − E[X_{1,1:2}])`, taking the probability + that the `s`-th order statistic is the smaller of a random pair to be + `2 * w_s * (1 - C_s) / (1 - w_s)`, where the factor 2 is said to handle order + invariance. Under weighted sampling *without replacement* the two orderings do + not have the same probability: + + ``` + P(x_s is the pair minimum) = w_s (1 - C_s) / (1 - w_s) # x_s drawn first + + sum_{k > s} w_k w_s / (1 - w_k) # x_s drawn second + ``` + + The two lines coincide only when all weights are equal — which is why the + note's section 0.2 (unweighted) is exact and section 0.3 is not. Doubling the + first line overweights draws that are both heavy and small, and the implied + coefficients no longer sum to zero. `EXX` is then neither shift invariant nor + guaranteed non-negative, and `measure_srps()` takes `log()` of a negative + number. (Deriving the exact pair probabilities is not a small fix: they are + the second-order inclusion probabilities of PPS sampling without replacement, + which do not factorize in general.) + + Measured on a toy sample of `S = 10` standard normal draws with weights + `(0.02, ..., 0.02, 0.82)`, and on the roaches fixture + (`tests/testthat/data-for-tests/test_data_roaches.Rds`, 262 obs × 400 draws): + + | case | note (0.3) | implemented | + |---|---|---| + | toy `EXX` | 2.647 | 1.547 | + | toy `EXX`, draws shifted by +100 | 136.525 | 1.547 | + | roaches obs 230 (max weight 0.833) | −44.67 → `NaN` in `srps` | 6.53 | + | roaches obs 16 (max weight 0.778) | 392.25 | 22.97 | + + The note's coefficients sum to 1.339 rather than 0 in the toy case. The + unweighted path is unaffected — there the note is exact and agrees with the + implementation to machine precision. + +- **Independent backing (ArviZ).** `arviz-stats` implements the same weighted + PWM score in the same PSIS-LOO setting, in + [`_loo_score()`](https://github.com/arviz-devs/arviz-stats/blob/main/src/arviz_stats/base/diagnostics.py): + + ``` python + f_minus = cumulative_weights - weights_sorted + bracket = 2.0 * f_minus + weights_sorted - 1.0 + gini_mean_difference = 2.0 * np.sum(weights_sorted * values_sorted * bracket) + ``` + + This is our numerator exactly (`2 * C_s - w_s - 1 = 2 * f_minus + w_s - 1`), + and it carries no `1 / (1 - w_s)` factor — i.e. ArviZ independently arrived at + the weighted Gini mean difference rather than at the note's estimator. The + same double-sum form is the standard survey-weighted Gini estimator, + `sum_k sum_l w_k w_l |y_k - y_l| / (2 N̂ Ŷ)`. + +- **Why we keep the `1 / (1 - sum w^2)` correction that ArviZ omits.** ArviZ + computes the plug-in version; ours divides by `1 - sum_i w_i^2 = 1 - 1/S_eff`, + the standard reliability-weights bias correction (the weighted-variance + analogue), which at equal weights is the `(S - 1) / S` "fair score" correction + of Ferro (2014) discussed by Zamo & Naveau (2018). Two reasons: + + 1. **The bias is per observation, not a constant.** With equal weights the + plug-in is low by a fixed `(S - 1) / S`, which cancels everywhere. With PSIS + weights the factor is `1 - 1/S_eff`, and on the roaches fixture `S_eff` + ranges from 400 (median 368, factor 0.9973) down to 1.4 (factor 0.2973). + 27 of 262 observations differ by more than 1%, and in `srps` the omitted + correction lands as an additive per-observation shift in `-0.5 * log(EXX)` + of up to 0.61 — largest exactly where the importance weights are already + concentrated. + 2. **Consistency with the unweighted path.** `measure_rps()` uses the unbiased + PWM estimator when `log_weights` is `NULL`. Without the correction, uniform + `log_weights` would no longer reproduce that result (off by `(S - 1) / S`); + the test *"uniform log-weights reproduce the unweighted measure_rps()"* + asserts that they do. + + Adopting ArviZ's plug-in form would therefore mean changing the unweighted + path as well, which changes published `measure_rps()` output and drops the + fair-score correction that `crps()`'s own references argue for. + +- **Follow-up:** report the section 0.3 issue to the author of + `notes/crps_pwm.pdf`; the note's unweighted result stands, only the weighted + generalization needs revising. Note also that the printed code for + `EXX_compute_pwm()` in section 0.4 has a typo (`- 2` should be + `- 2 * (S + 1) / (S - 1)`); it disagrees with the note's own formula and is + not shift invariant. `.exx_pwm()` follows the formula, not that snippet. + ## Tasks ### Refactoring (within new API) @@ -138,7 +265,7 @@ Design choices **internal to `pred_measure`**: - [x] In `*_pred_measure()`, compute `elpd` as base when `ylp` supplied; require explicit `measure = "ic"` for information criterion - [x] Document and test deprecated vs new API comparisons *(see appendix)* -- [ ] Provide an interface to `loo_compare` and verify consistency +- [x] Provide an interface to `loo_compare` and verify consistency - [ ] Resolve `r_eff` handling *(see D3)* ### Implementation @@ -156,7 +283,8 @@ Design choices **internal to `pred_measure`**: - [x] Online-only articles published via `_pkgdown.yml` - [ ] Formula derivations article (`pred_measure-formulas.Rmd`) - [ ] Detailed per-measure descriptions (derivations where appropriate) -- [ ] Extend glossary (`R/loo-glossary.R`) — measure, metric, score, utility, loss +- [x] Extend glossary (`R/loo-glossary.R`) — multi-measure `loo_compare` columns +- [ ] Extend glossary further — measure, metric, score, utility, loss (general terms) ### Grouping via `group_ids` @@ -170,8 +298,8 @@ Design choices **internal to `pred_measure`**: - Rename `ic` → `information_criteria` for clarity? - Should `measure_elpd()` also return `ic`, or keep them separate? -- What defines class `"loo"` on measure objects? (e.g. deprecated `elpd_generic` - inherits `"loo"`) +- What defines class `"loo"` on measure objects? `loo_pred_measure` inherits `"loo"` + (see `integrate-loo_compare`); deprecated `elpd_generic` also inherits `"loo"`. - Should `elpd` always be computed when `ylp` is supplied, or allow `loo_pred_measure()` for non-ELPD measures only? @@ -203,17 +331,18 @@ the same scoring rules but use different estimators. | Deprecated | New workflow | Notes | |------------|--------------|-------| -| `crps(x, x2, y)` | `measure_rps(y, ypred = x, higher_is_better = FALSE)` | Loss-scale unscaled score | +| `crps(x, x2, y)` | `-measure_rps(y, ypred = x)$pointwise` | `crps()` returns the negated unscaled score | | `scrps(x, x2, y)` | `measure_srps(y, ypred = x)` | Same sign convention | | `loo_crps(...)` | `loo_pred_measure(..., measure = "rps")` | Additional LOO weighting difference | | `loo_scrps(...)` | `loo_pred_measure(..., measure = "srps")` | Additional LOO weighting difference | #### Sources of numerical difference -1. **Sign convention (unscaled only).** `crps()` returns `0.5·EXX − EXy` (utility: - higher is better). Default `measure_rps()` negates this; use - `higher_is_better = FALSE` to match `crps()`. Scaled scores (`scrps` / `measure_srps`) - already share the formula `−EXy/EXX − 0.5·log(EXX)`. +1. **Sign convention (unscaled only).** `measure_rps()` returns `EXy − 0.5·EXX`, + the Gneiting & Raftery (2007) loss (lower is better); `crps()` returns its + negation `0.5·EXX − EXy`. Negate `measure_rps()` to match `crps()`. Scaled + scores (`scrps` / `measure_srps`) already share the formula + `−EXy/EXX − 0.5·log(EXX)` and are utilities. 2. **EXX estimator (in-sample).** Both estimate `E|X − X'|`, but: - **Deprecated:** two draw matrices `x`, `x2`; one random shuffle per @@ -228,6 +357,9 @@ the same scoring rules but use different estimators. uses weighted PWM on a single `ypred` with PSIS weights from `ylp` only — so LOO differences combine EXX method and importance-weighting approach. + For why the weighted PWM estimator does not follow section 0.3 of + `notes/crps_pwm.pdf`, see D5 in *Open decisions*. + #### Key results (reference simulation) ![CRPS/RPS comparison: PWM vs permutation EXX estimators](figures/crps-rps-comparison.png) @@ -273,7 +405,9 @@ EXX_perm <- colMeans(abs(x1 - x2[sample(S), , drop = FALSE])) EXX_pwm <- .exx_pwm(x1) old_crps <- suppressWarnings(crps(x1, x2, y)) -new_rps <- measure_rps(y, x1, higher_is_better = FALSE) +# `crps()` is the negated unscaled score, so align signs here +new_rps <- measure_rps(y, x1) +new_rps$pointwise <- -new_rps$pointwise old_scrps <- suppressWarnings(scrps(x1, x2, y)) new_srps <- measure_srps(y, x1) @@ -355,7 +489,7 @@ invisible(dev.off()) ![CRPS/RPS outcome comparison across replications](figures/crps-rps-outcomes.png) *Figure: 200 simulations (S = 100, n = 30). Left — `crps()` vs -`measure_rps(higher_is_better = FALSE)`; right — `scrps()` vs `measure_srps()`.* +`-measure_rps()`; right — `scrps()` vs `measure_srps()`.* ```{r crps-rps-outcomes-figure, fig.show = "hide"} n_repl <- 200L @@ -369,11 +503,12 @@ for (i in seq_len(n_repl)) { x1 <- matrix(rnorm(n_obs * n_draws), nrow = n_draws) x2 <- matrix(rnorm(n_obs * n_draws), nrow = n_draws) old <- suppressWarnings(crps(x1, x2, y)) - new <- measure_rps(y, x1, higher_is_better = FALSE) + new <- measure_rps(y, x1) old_s <- suppressWarnings(scrps(x1, x2, y)) new_s <- measure_srps(y, x1) crps_old[i] <- old$estimates["Estimate"] - rps_new[i] <- new$estimates[1, "Estimate"] + # `crps()` is the negated unscaled score, so align signs here + rps_new[i] <- -new$estimates[1, "Estimate"] scrps_old[i] <- old_s$estimates["Estimate"] srps_new[i] <- new_s$estimates[1, "Estimate"] } @@ -383,7 +518,7 @@ par(mfrow = c(1, 2), mar = c(4, 4, 2.5, 1)) .outcome_panel( crps_old, rps_new, xlab = "crps() estimate", - ylab = "measure_rps(higher_is_better = FALSE)", + ylab = "-measure_rps()", main = "Unscaled (CRPS / RPS)" ) .outcome_panel( diff --git a/notes/developer-notes.md b/notes/developer-notes.md index 0dd96f5c..299c788a 100644 --- a/notes/developer-notes.md +++ b/notes/developer-notes.md @@ -14,10 +14,10 @@ Developer Notes: `pred_measure` Feature > **Status:** In Progress > **Base branch:** `loo-v3.0.0` -> **Compare branch:** `add-pred-measure` +> **Compare branch:** `pred_measure` (+ `integrate-loo_compare`) > **Related PR:** [\#363](https://github.com/stan-dev/loo/pull/363) > **Contributors:** @florence-bockting, @avehtari, @VisruthSK, @jgabry -> **Last updated:** 2026-07-03 +> **Last updated:** 2026-07-07 These notes document internal design decisions and ongoing work for the `pred_measure` feature. This PR **adds** the new API on top of @@ -39,7 +39,7 @@ For the merge summary, see the PR description | Scoring rules (`measure_rps`) | Done | | Documentation | In progress | | `group_ids` grouping | Not started | -| `loo_compare` integration | Not started | +| `loo_compare` integration | Done (`integrate-loo_compare`) | ------------------------------------------------------------------------ @@ -59,6 +59,8 @@ For the merge summary, see the PR description - Website-only articles: `overview-measures.Rmd`, `pred-measure-workflow.Rmd` - Test suite + pre-fitted fixtures + `test_data_generation.R` +- `loo_compare()` multi-measure path for `loo_pred_measure` objects + (`integrate-loo_compare`) ### Changed on existing code (implementations retained) @@ -69,6 +71,11 @@ For the merge summary, see the PR description - `elpd()` — refactored to `.elpd_matrix_impl()` to avoid double deprecation warnings - Minor doc cross-references in `compare.R`, `psislw.R` +- `loo_compare()` — extended for `loo_pred_measure` objects: `rank_by`, + multi-measure paired diffs, updated `print.compare.loo(measures = ...)`; + classic `loo` path unchanged +- `R/loo-glossary.R` — multi-measure comparison columns (`{measure}_diff`, + `rank_by`, etc.) - `NEWS.md`, `NAMESPACE`, `_pkgdown.yml`, pkgdown CI workflow ------------------------------------------------------------------------ @@ -127,17 +134,52 @@ Design choices **internal to `pred_measure`** (not a migration from examples end-to-end (penguins fixture exists; confirm test/doc coverage) +### D4: `loo_compare()` for `loo_pred_measure` objects + +**Decision:** Extend existing `loo_compare()` + +- When all inputs are `loo_pred_measure` objects, compute paired + differences for every measure common to all models +- Rank models by `rank_by` (default `"elpd"`); top-ranked model is the + reference for all `{measure}_diff` columns +- ELPD-family measures keep `elpd_diff` / `se_diff`; other measures use + `{measure}_diff` / `{measure}_se_diff` +- `p_worse` and `diag_diff` apply to ELPD only; `diag_elpd` per model as + before +- Loss measures (MSE, RMSE, MAE, IC, Brier score, RPS) compared on a common + utility scale (higher is better): sign flipped from the raw loss orientation + so worse models have negative diffs, consistent with ELPD. Orientation is + read from the `loss` element of `measure_info` on each + `*_pred_measure()` result; attribute `sign_converted_measures` records + affected measures. A short message is emitted at compare time; full + interpretation is in `?loo_compare` / `?loo-glossary`. +- Pointwise SEs use the same paired formula as ELPD when the overall + estimate is a sum or mean of pointwise contributions; otherwise + `{measure}_se_diff` is `NA` (e.g. `r2`, `mse`, `rmse`) +- Reuse `elpd_diffs`, `se_elpd_diff`, `diag_diff`, `diag_elpd`, and + many-model order-statistic check (with `rank_by` when applicable) +- `print.compare.loo(measures = ...)` shows one or all measure diff tables + +Implemented on branch `integrate-loo_compare`; tests in `test_compare.R` +with fixture `test_data_roaches_compare.Rds`. + ------------------------------------------------------------------------ ## Open decisions ### D1: Sign convention for pointwise estimates -- **Context:** Measures differ in orientation (`rps`: lower is better; - `srps`: higher is better). Aligning orientations may help comparisons. -- **Options:** `lower_is_better`, `orientation = "utility" / "loss"`, - `revert_sign` (currently internal on some `measure_*()` functions) -- **Decision:** *pending* +- **Context:** Measures differ in orientation (e.g. ELPD/CRPS on a utility + scale; MSE and Brier score as losses). `loo_compare()` aligns them for + paired differences. +- **Decision:** Values are always stored on the measure's own scale. A single + `loss` flag records the orientation --- `.measure_spec` for built-ins, + `attr(fun, "measure_loss")` for custom measures --- and is recorded per + measure in the `measure_info` attribute of each `*_pred_measure()` result. + `model_compare()` sign-flips measures with `loss = TRUE` for utility-scale + `{measure}_diff`. The per-call `higher_is_better` control has been removed: + it only changed the sign of stored values, and comparisons were invariant + to it. ### D3: Handling of `r_eff` @@ -147,6 +189,103 @@ Design choices **internal to `pred_measure`** (not a migration from workflows? - **Decision:** *pending* +### D5: Weighted `E|X − X'|` — why the derivation in `crps_pwm.pdf` is not used + +- **Decision:** *resolved.* `.exx_pwm()` (`R/pred_measure-helpers.R`) estimates + `E|X − X'|` with the bias-corrected weighted Gini mean difference + + ``` r + EXX = sum_{i != j} w_i w_j |x_i - x_j| / (1 - sum_i w_i^2) + ``` + + computed on sorted draws as `2 * sum(w_s * x_s * (2 * C_s - w_s - 1)) / (1 - sum(w^2))`, + with `C_s = sum_{k <= s} w_k`. At equal weights this is exactly the unbiased + PWM estimator of Taillardat et al. (2016) with the `1 / (S (S - 1))` + normalization, so the weighted and unweighted paths agree. + +- **Why not `notes/crps_pwm.pdf` (section 0.3).** The note derives a weighted + estimator from `E|X − X'| = 2 (E[X] − E[X_{1,1:2}])`, taking the probability + that the `s`-th order statistic is the smaller of a random pair to be + `2 * w_s * (1 - C_s) / (1 - w_s)`, where the factor 2 is said to handle order + invariance. Under weighted sampling *without replacement* the two orderings do + not have the same probability: + + ``` + P(x_s is the pair minimum) = w_s (1 - C_s) / (1 - w_s) # x_s drawn first + + sum_{k > s} w_k w_s / (1 - w_k) # x_s drawn second + ``` + + The two lines coincide only when all weights are equal — which is why the + note's section 0.2 (unweighted) is exact and section 0.3 is not. Doubling the + first line overweights draws that are both heavy and small, and the implied + coefficients no longer sum to zero. `EXX` is then neither shift invariant nor + guaranteed non-negative, and `measure_srps()` takes `log()` of a negative + number. (Deriving the exact pair probabilities is not a small fix: they are + the second-order inclusion probabilities of PPS sampling without replacement, + which do not factorize in general.) + + Measured on a toy sample of `S = 10` standard normal draws with weights + `(0.02, ..., 0.02, 0.82)`, and on the roaches fixture + (`tests/testthat/data-for-tests/test_data_roaches.Rds`, 262 obs × 400 draws): + + | case | note (0.3) | implemented | + |---|---|---| + | toy `EXX` | 2.647 | 1.547 | + | toy `EXX`, draws shifted by +100 | 136.525 | 1.547 | + | roaches obs 230 (max weight 0.833) | −44.67 → `NaN` in `srps` | 6.53 | + | roaches obs 16 (max weight 0.778) | 392.25 | 22.97 | + + The note's coefficients sum to 1.339 rather than 0 in the toy case. The + unweighted path is unaffected — there the note is exact and agrees with the + implementation to machine precision. + +- **Independent backing (ArviZ).** `arviz-stats` implements the same weighted + PWM score in the same PSIS-LOO setting, in + [`_loo_score()`](https://github.com/arviz-devs/arviz-stats/blob/main/src/arviz_stats/base/diagnostics.py): + + ``` python + f_minus = cumulative_weights - weights_sorted + bracket = 2.0 * f_minus + weights_sorted - 1.0 + gini_mean_difference = 2.0 * np.sum(weights_sorted * values_sorted * bracket) + ``` + + This is our numerator exactly (`2 * C_s - w_s - 1 = 2 * f_minus + w_s - 1`), + and it carries no `1 / (1 - w_s)` factor — i.e. ArviZ independently arrived at + the weighted Gini mean difference rather than at the note's estimator. The + same double-sum form is the standard survey-weighted Gini estimator, + `sum_k sum_l w_k w_l |y_k - y_l| / (2 N̂ Ŷ)`. + +- **Why we keep the `1 / (1 - sum w^2)` correction that ArviZ omits.** ArviZ + computes the plug-in version; ours divides by `1 - sum_i w_i^2 = 1 - 1/S_eff`, + the standard reliability-weights bias correction (the weighted-variance + analogue), which at equal weights is the `(S - 1) / S` "fair score" correction + of Ferro (2014) discussed by Zamo & Naveau (2018). Two reasons: + + 1. **The bias is per observation, not a constant.** With equal weights the + plug-in is low by a fixed `(S - 1) / S`, which cancels everywhere. With PSIS + weights the factor is `1 - 1/S_eff`, and on the roaches fixture `S_eff` + ranges from 400 (median 368, factor 0.9973) down to 1.4 (factor 0.2973). + 27 of 262 observations differ by more than 1%, and in `srps` the omitted + correction lands as an additive per-observation shift in `-0.5 * log(EXX)` + of up to 0.61 — largest exactly where the importance weights are already + concentrated. + 2. **Consistency with the unweighted path.** `measure_rps()` uses the unbiased + PWM estimator when `log_weights` is `NULL`. Without the correction, uniform + `log_weights` would no longer reproduce that result (off by `(S - 1) / S`); + the test *"uniform log-weights reproduce the unweighted measure_rps()"* + asserts that they do. + + Adopting ArviZ's plug-in form would therefore mean changing the unweighted + path as well, which changes published `measure_rps()` output and drops the + fair-score correction that `crps()`'s own references argue for. + +- **Follow-up:** report the section 0.3 issue to the author of + `notes/crps_pwm.pdf`; the note's unweighted result stands, only the weighted + generalization needs revising. Note also that the printed code for + `EXX_compute_pwm()` in section 0.4 has a typo (`- 2` should be + `- 2 * (S + 1) / (S - 1)`); it disagrees with the note's own formula and is + not shift invariant. `.exx_pwm()` follows the formula, not that snippet. + ------------------------------------------------------------------------ ## Tasks @@ -163,7 +302,13 @@ Design choices **internal to `pred_measure`** (not a migration from require explicit `measure = "ic"` for information criterion - [x] Document and test deprecated vs new API comparisons *(see appendix)* -- [ ] Provide an interface to `loo_compare` and verify consistency +- [x] Provide an interface to `loo_compare` and verify consistency +- [ ] Decide whether the `loo_compare` S3 tree stays. `loo_compare.default` + (`R/loo_compare.R:34`) and `loo_compare.psis_loo_ss_list` + (`R/loo_compare.R:46`) are now two-line pass-throughs to their + `model_compare` counterparts, so the whole tree may be a thin back-compat + shim. Either keep it deliberately, as with `old_nms` / `convert_old_object()`, + or drop it as a set — not one method at a time. - [ ] Resolve `r_eff` handling *(see D3)* ### Implementation @@ -181,8 +326,9 @@ Design choices **internal to `pred_measure`** (not a migration from - [x] Online-only articles published via `_pkgdown.yml` - [ ] Formula derivations article (`pred_measure-formulas.Rmd`) - [ ] Detailed per-measure descriptions (derivations where appropriate) -- [ ] Extend glossary (`R/loo-glossary.R`) — measure, metric, score, - utility, loss +- [x] Extend glossary (`R/loo-glossary.R`) — multi-measure `loo_compare` columns +- [ ] Extend glossary further — measure, metric, score, utility, loss + (general terms) ### Grouping via `group_ids` @@ -200,8 +346,9 @@ Design choices **internal to `pred_measure`** (not a migration from - Rename `ic` → `information_criteria` for clarity? - Should `measure_elpd()` also return `ic`, or keep them separate? -- What defines class `"loo"` on measure objects? (e.g. deprecated - `elpd_generic` inherits `"loo"`) +- What defines class `"loo"` on measure objects? `loo_pred_measure` inherits + `"loo"` (see `integrate-loo_compare`); deprecated `elpd_generic` also + inherits `"loo"`. - Should `elpd` always be computed when `ylp` is supplied, or allow `loo_pred_measure()` for non-ELPD measures only? @@ -236,18 +383,18 @@ estimators. | Deprecated | New workflow | Notes | |-------------------|-------------------------------------------------|-------------------------------------| -| `crps(x, x2, y)` | `measure_rps(y, ypred = x, revert_sign = TRUE)` | Sign flip on unscaled score | +| `crps(x, x2, y)` | `-measure_rps(y, ypred = x)$pointwise` | `crps()` returns the negated unscaled score | | `scrps(x, x2, y)` | `measure_srps(y, ypred = x)` | Same sign convention | | `loo_crps(...)` | `loo_pred_measure(..., measure = "rps")` | Additional LOO weighting difference | | `loo_scrps(...)` | `loo_pred_measure(..., measure = "srps")` | Additional LOO weighting difference | #### Sources of numerical difference -1. **Sign convention (unscaled only).** `crps()` returns - `0.5·EXX − EXy` (utility: higher is better). Default `measure_rps()` - negates this; use `revert_sign = TRUE` to match `crps()`. Scaled - scores (`scrps` / `measure_srps`) already share the formula - `−EXy/EXX − 0.5·log(EXX)`. +1. **Sign convention (unscaled only).** `measure_rps()` returns + `EXy − 0.5·EXX`, the Gneiting & Raftery (2007) loss (lower is better); + `crps()` returns its negation `0.5·EXX − EXy`. Negate `measure_rps()` + to match `crps()`. Scaled scores (`scrps` / `measure_srps`) already + share the formula `−EXy/EXX − 0.5·log(EXX)` and are utilities. 2. **EXX estimator (in-sample).** Both estimate `E|X − X'|`, but: @@ -265,6 +412,9 @@ estimators. single `ypred` with PSIS weights from `ylp` only — so LOO differences combine EXX method and importance-weighting approach. + For why the weighted PWM estimator does not follow section 0.3 of + `notes/crps_pwm.pdf`, see D5 in *Open decisions*. + #### Key results (reference simulation)
@@ -295,7 +445,7 @@ replications
*Figure: 200 simulations (S = 100, n = 30). Left — `crps()` vs -`measure_rps(revert_sign = TRUE)`; right — `scrps()` vs +`-measure_rps()`; right — `scrps()` vs `measure_srps()`.* #### LOO outcome comparison 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..5a909bb0 100644 --- a/tests/testthat/_snaps/compare.md +++ b/tests/testthat/_snaps/compare.md @@ -1,6 +1,207 @@ -# loo_compare returns expected results (2 models) +# model_compare works with three loo_pred_measure models - WAoAAAACAAQEAgACAwAAAAMTAAAADAAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v + Code + print(comp) + Output + Models ranked by mae (reference: C). + PSIS-LOO unreliable for all 3 models (k_psis > 0.62); measures may be biased. + model bad_k + B 2 + C 1 + A 1 + + model mae_diff mae_se_diff + C 0.0 0.0 + B -0.1 1.2 + A -6.3 3.1 + 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 informs when measure signs are converted + + Code + comp <- model_compare(pm1, pm2) + Message + For model comparison, differences for mse is + reported on a utility scale (higher is better). + +# print.compare.loo works for loo_pred_measure comparisons + + Code + print(comp) + Output + Each measure compared against its own best model (elpd: m2, r2: m2, mae: m3). + PSIS-LOO unreliable for all 3 models (k_psis > 0.62); measures may be biased. + model bad_k + m2 2 + m3 1 + m1 1 + + model elpd_diff se_diff p_worse diag_diff + m2 0.0 0.0 NA + m3 -25.5 129.1 0.58 + m1 -850.3 372.3 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, r2: m2, mae: m3). + PSIS-LOO unreliable for all 3 models (k_psis > 0.62); measures may be biased. + model bad_k + m2 2 + m3 1 + m1 1 + + -- 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) -- + model mae_diff mae_se_diff + m3 0.00 0.00 + m2 -0.07 1.24 + m1 -6.34 3.08 + 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, r2: m2, mae: m3). + PSIS-LOO unreliable for all 3 models (k_psis > 0.62); measures may be biased. + model bad_k + m2 2 + m3 1 + m1 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 + + -- mae (vs m3) -- + model mae_diff mae_se_diff + m3 0.0 0.0 + m2 -0.1 1.2 + m1 -6.3 3.1 + 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, simplify = FALSE) + Output + Each measure compared against its own best model (elpd: m2, r2: m2, mae: m3). + PSIS-LOO unreliable for all 3 models (k_psis > 0.62); measures may be biased. + model bad_k + m2 2 + m3 1 + m1 1 + + model elpd_diff se_diff p_worse diag_diff elpd se_elpd p se_p + m2 0.0 0.0 NA -2071.4 468.9 61.6 20.7 + m3 -25.5 129.1 0.58 -2096.8 438.7 96.4 46.2 + m1 -850.3 372.3 0.99 -2921.7 449.8 75.8 21.1 + 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, r2: m2, mae: m3). + PSIS-LOO unreliable for all 3 models (k_psis > 0.62); measures may be biased. + model bad_k + m2 2 + m3 1 + m1 1 + + -- elpd (vs m2) -- + model elpd_diff se_diff p_worse diag_diff elpd se_elpd p se_p + m2 0.0 0.0 NA -2071.4 468.9 61.6 20.7 + m3 -25.5 129.1 0.58 -2096.8 438.7 96.4 46.2 + m1 -850.3 372.3 0.99 -2921.7 449.8 75.8 21.1 + + -- r2 (vs m2) -- + model r2_diff r2_se_diff r2 se_r2 + m2 0.0 0.0 0.2 0.2 + m3 -0.1 0.2 0.1 0.3 + m1 -0.1 0.2 0.0 0.0 + + -- mae (vs m3) -- + model mae_diff mae_se_diff mae se_mae + m3 0.0 0.0 21.9 3.6 + m2 -0.1 1.2 22.0 3.4 + m1 -6.3 3.1 28.2 3.2 + 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_mae) + Output + Models ranked by mae (reference: m2). + PSIS-LOO unreliable for both models (k_psis > 0.62); measures may be biased. + model bad_k + m2 2 + m1 1 + + model mae_diff mae_se_diff + m2 0.0 0.0 + m1 -6.3 2.8 + 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 +213,11 @@ AAAABnBfd2FpYwAEAAkAAAAJc2VfcF93YWljAAQACQAAAAR3YWljAAQACQAAAAdzZV93YWlj AAAEAgAAAAEABAAJAAAABWNsYXNzAAAAEAAAAAIABAAJAAAAC2NvbXBhcmUubG9vAAQACQAA AApkYXRhLmZyYW1lAAAEAgAAAAEABAAJAAAACXJvdy5uYW1lcwAAAA0AAAACgAAAAP////4A - AAD+ + AAQCAAAAAQAEAAkAAAAHcmFua19ieQAAAhMAAAADAAAAEAAAAAEABAAJAAAAB2RlZmF1bHQA + AAAQAAAAAQAEAAkAAAAEZWxwZAAAAP4AAAQCAAAB/wAAABAAAAADAAQACQAAAARraW5kAAQA + CQAAAAdtZWFzdXJlAAQACQAAAAVtb2RlbAAAAP4AAAQCAAAAAQAEAAkAAAARY29tcGFyZV9y + ZWZlcmVuY2UAAAIQAAAAAQAEAAkAAAAGbW9kZWwxAAAEAgAAAf8AAAAQAAAAAQAEAAkAAAAE + ZWxwZAAAAP4AAAD+ --- @@ -25,7 +230,7 @@ --- - WAoAAAACAAQEAgACAwAAAAMTAAAADAAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v + WAoAAAACAAQGAQACAwAAAAMTAAAADAAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v ZGVsMgAAAA4AAAACAAAAAAAAAADAEDpTX5xF7gAAAA4AAAACAAAAAAAAAAA/tmpHtC8TAQAA AA4AAAACf/AAAAAAB6I/8AAAAAAAAAAAABAAAAACAAQACQAAAAAABAAJAAAAB04gPCAxMDAA AAAQAAAAAgAEAAkAAAAAAAQACQAAAAAAAAAOAAAAAsBU4fDdyUJYwFXllhPDBrkAAAAOAAAA @@ -37,7 +242,11 @@ YWljAAQACQAAAAZwX3dhaWMABAAJAAAACXNlX3Bfd2FpYwAEAAkAAAAEd2FpYwAEAAkAAAAH c2Vfd2FpYwAABAIAAAABAAQACQAAAAVjbGFzcwAAABAAAAACAAQACQAAAAtjb21wYXJlLmxv bwAEAAkAAAAKZGF0YS5mcmFtZQAABAIAAAABAAQACQAAAAlyb3cubmFtZXMAAAANAAAAAoAA - AAD////+AAAA/g== + AAD////+AAAEAgAAAAEABAAJAAAAB3JhbmtfYnkAAAITAAAAAwAAABAAAAABAAQACQAAAAdk + ZWZhdWx0AAAAEAAAAAEABAAJAAAABGVscGQAAAD+AAAEAgAAAf8AAAAQAAAAAwAEAAkAAAAE + a2luZAAEAAkAAAAHbWVhc3VyZQAEAAkAAAAFbW9kZWwAAAD+AAAEAgAAAAEABAAJAAAAEWNv + bXBhcmVfcmVmZXJlbmNlAAACEAAAAAEABAAJAAAABm1vZGVsMQAABAIAAAH/AAAAEAAAAAEA + BAAJAAAABGVscGQAAAD+AAAA/g== --- @@ -88,11 +297,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 +313,11 @@ d2FpYwAEAAkAAAAGcF93YWljAAQACQAAAAlzZV9wX3dhaWMABAAJAAAABHdhaWMABAAJAAAA B3NlX3dhaWMAAAQCAAAAAQAEAAkAAAAFY2xhc3MAAAAQAAAAAgAEAAkAAAALY29tcGFyZS5s b28ABAAJAAAACmRhdGEuZnJhbWUAAAQCAAAAAQAEAAkAAAAJcm93Lm5hbWVzAAAADQAAAAKA - AAAA/////QAAAP4= + AAAA/////QAABAIAAAABAAQACQAAAAdyYW5rX2J5AAACEwAAAAMAAAAQAAAAAQAEAAkAAAAH + ZGVmYXVsdAAAABAAAAABAAQACQAAAARlbHBkAAAA/gAABAIAAAH/AAAAEAAAAAMABAAJAAAA + BGtpbmQABAAJAAAAB21lYXN1cmUABAAJAAAABW1vZGVsAAAA/gAABAIAAAABAAQACQAAABFj + b21wYXJlX3JlZmVyZW5jZQAAAhAAAAABAAQACQAAAAZtb2RlbDEAAAQCAAAB/wAAABAAAAAB + AAQACQAAAARlbHBkAAAA/gAAAP4= --- @@ -121,7 +334,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 a227a3aa..94878bbe 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. 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/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_generation.R b/tests/testthat/data-for-tests/test_data_generation.R index aa45670c..76a9c2b2 100644 --- a/tests/testthat/data-for-tests/test_data_generation.R +++ b/tests/testthat/data-for-tests/test_data_generation.R @@ -87,7 +87,7 @@ postprocess_res <- function(model, fit, chains = 2, draws = 200) { # only a subset of the observations. The draws stay at 400, so the Pareto k # threshold ps_khat_threshold(400) does not move. N_KEEP <- c( - roaches = 53, categorical = 67, sleep = 29, + roaches = 53, roaches_compare = 110, categorical = 67, sleep = 29, sleep_test = 20 ) @@ -192,6 +192,22 @@ shrink_res <- function(model, res) { res } +# The model-comparison fixture holds four `psis_loo` objects and four sets of +# draws. `.keep_index()` reseeds, so this keeps the same 53 observations as +# `test_data_roaches.Rds`. +shrink_roaches_compare <- function(res) { + keep <- .keep_index(length(res$y), N_KEEP[["roaches_compare"]]) + res$y <- res$y[keep] + for (nm in grep("^(ypred|mupred|ylp)(_m[0-9]+)?$", names(res), value = TRUE)) { + res[[nm]] <- res[[nm]][, keep, drop = FALSE] + } + for (nm in grep("^loo_p(_m[0-9]+)?$", names(res), value = TRUE)) { + res[[nm]] <- .shrink_psis_loo(res[[nm]], keep) + } + res +} + + get_binary_res <- function() { set.seed(SEED) df_binary <- data.frame(y = rbinom(50, 1, 0.3)) @@ -230,6 +246,60 @@ get_roaches_res <- function() { ) } +get_roaches_compare_res <- function() { + data(roaches, package = "rstanarm") + roaches$sqrt_roach1 <- sqrt(roaches$roach1) + + fit_p <- brm( + y ~ sqrt_roach1 + treatment + senior + offset(log(exposure2)), + data = roaches, + family = poisson, + prior = prior(normal(0, 1), class = b), + chains = 2, + iter = 400, + refresh = 0, + seed = SEED + ) + + fit_p <- add_criterion( + fit_p, + criterion = "loo", + moment_match = TRUE, + save_psis = TRUE, + overwrite = TRUE + ) + + fit_p_m1 <- update(fit_p, formula = y ~ treatment + senior) |> + add_criterion(criterion = "loo", moment_match = TRUE, save_psis = TRUE) + fit_p_m2 <- update(fit_p, formula = y ~ sqrt_roach1 + senior) |> + add_criterion(criterion = "loo", moment_match = TRUE, save_psis = TRUE) + fit_p_m3 <- update(fit_p, formula = y ~ sqrt_roach1 + treatment) |> + add_criterion(criterion = "loo", moment_match = TRUE, save_psis = TRUE) + + # `ypred` (posterior predictive draws) is needed by the sampling-based scores + # such as `rps`/`srps`; `mupred` (posterior_epred) is not enough for those. + set.seed(SEED) + return(list( + y = fit_p$data$y, + loo_p = fit_p$criteria$loo, + ypred = brms::posterior_predict(fit_p), + mupred = brms::posterior_epred(fit_p), + ylp = brms::log_lik(fit_p), + loo_p_m1 = fit_p_m1$criteria$loo, + ypred_m1 = brms::posterior_predict(fit_p_m1), + mupred_m1 = brms::posterior_epred(fit_p_m1), + ylp_m1 = brms::log_lik(fit_p_m1), + loo_p_m2 = fit_p_m2$criteria$loo, + ypred_m2 = brms::posterior_predict(fit_p_m2), + mupred_m2 = brms::posterior_epred(fit_p_m2), + ylp_m2 = brms::log_lik(fit_p_m2), + loo_p_m3 = fit_p_m3$criteria$loo, + ypred_m3 = brms::posterior_predict(fit_p_m3), + mupred_m3 = brms::posterior_epred(fit_p_m3), + ylp_m3 = brms::log_lik(fit_p_m3) + )) +} + get_sleep_test_train_res <- function() { # specifically for testing test_pred_measure data("sleepstudy", package = "lme4") @@ -350,9 +420,11 @@ generate_test_data <- function() { full_binomial <- get_binomial_res() full_sleep <- get_sleep_res() full_sleep_test <- get_sleep_test_train_res() + full_roaches_compare <- get_roaches_compare_res() test_path <- "tests/testthat/data-for-tests/" saveRDS(shrink_res("roaches", full_roaches$res), paste0(test_path, "test_data_roaches.Rds")) + saveRDS(shrink_roaches_compare(full_roaches_compare), paste0(test_path, "test_data_roaches_compare.Rds")) saveRDS(shrink_res("binary", full_binary$res), paste0(test_path, "test_data_binary.Rds")) saveRDS(shrink_res("categorical", full_penguins$res), paste0(test_path, "test_data_penguins.Rds")) saveRDS(shrink_res("binomial", full_binomial$res), paste0(test_path, "test_data_binomial.Rds")) 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..02aa24ef Binary files /dev/null and b/tests/testthat/data-for-tests/test_data_roaches_compare.Rds differ diff --git a/tests/testthat/test_compare.R b/tests/testthat/test_compare.R index e672ef07..fe230187 100644 --- a/tests/testthat/test_compare.R +++ b/tests/testthat/test_compare.R @@ -6,62 +6,1349 @@ 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, + measure = c("r2", "mse") + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m1, + y = res$y, + mupred = res$mupred_m1, + ylp = res$ylp_m1, + measure = c("r2", "mse") + ) + + comp <- suppressMessages(model_compare(pm1, pm2)) + expect_s3_class(comp, "compare.loo") + expect_equal( + attr(comp, "rank_by"), + list(kind = "default", measure = "elpd", model = NULL) + ) + 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 + ) + expect_equal( + attr(model_compare(w1, w2), "rank_by"), + list(kind = "default", measure = "elpd", model = NULL) + ) +}) + +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, + measure = c("r2", "mse") + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m2, + y = res$y, + mupred = res$mupred_m2, + ylp = res$ylp_m2, + measure = c("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, + measure = c("r2", "mae") + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m2, + y = res$y, + mupred = res$mupred_m2, + ylp = res$ylp_m2, + measure = c("r2", "mae") + ) + pm3 <- loo_pred_measure( + loo = res$loo_p_m3, + y = res$y, + mupred = res$mupred_m3, + ylp = res$ylp_m3, + measure = c("r2", "mae") + ) + + comp <- model_compare( + list("A" = pm1, "B" = pm2, "C" = pm3), + rank_by = "mae" + ) + expect_snapshot(print(comp)) + expect_equal(nrow(comp), 3L) + expect_equal(comp$model, c("C", "B", "A")) + expect_equal( + attr(comp, "rank_by"), + list(kind = "measure", measure = "mae", model = NULL) + ) + expect_equal(attr(comp, "compare_measures"), c("elpd", "r2", "mae")) + expect_equal(comp$mae_diff[1L], 0) + expect_true(all(comp$mae_diff[-1L] < 0)) + # `rank_by` pins the mae-best model as the reference for *every* measure, so + # only the reference row is zero. Which model wins on `elpd` depends on the + # data, so this test does not assert it. + expect_equal(comp$elpd_diff[1L], 0) + expect_true(all(comp$elpd_diff[-1L] != 0)) + expect_equal(attr(comp, "sign_converted_measures"), c("mae")) +}) + +test_that("model_compare informs when measure signs are converted", { + 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, + measure = c("r2", "mse") + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m2, + y = res$y, + mupred = res$mupred_m2, + ylp = res$ylp_m2, + measure = c("r2", "mse") + ) + + expect_snapshot(comp <- model_compare(pm1, pm2)) + expect_equal(attr(comp, "sign_converted_measures"), "mse") + + 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("model_compare rank_by changes order for loo_pred_measure", { + 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, + measure = c("r2", "mae") + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m2, + y = res$y, + mupred = res$mupred_m2, + ylp = res$ylp_m2, + measure = c("r2", "mae") + ) + + comp_elpd <- model_compare(pm1, pm2, rank_by = "elpd") + comp_mse <- model_compare(pm1, pm2, rank_by = "mae") + expect_equal( + attr(comp_elpd, "rank_by"), + list(kind = "measure", measure = "elpd", model = NULL) + ) + expect_equal( + attr(comp_mse, "rank_by"), + list(kind = "measure", measure = "mae", model = NULL) + ) + expect_equal(comp_elpd$elpd_diff[1L], 0) + expect_equal(comp_mse$mae_diff[1L], 0) +}) + +test_that("without `rank_by` 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)]], + measure = c("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 still 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)) + } + + # Whether `mse` and `elpd` pick the same model depends on the data. The loop + # above already checks that each measure takes its own best model as the + # reference; the `rank_by` block below checks the contrasting case. + + # `rank_by` instead pins a single reference for every measure + ranked <- suppressMessages(model_compare(pms, rank_by = "mse")) + ranked_refs <- attr(ranked, "compare_reference") + expect_true(all(ranked_refs == ranked$model[[1L]])) + expect_equal(ranked$mse_diff[[1L]], 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)]], + measure = c("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) + } + + for (comp in list( + suppressMessages(model_compare(pms)), + suppressMessages(model_compare(pms, rank_by = "mse")) + )) { + 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, + measure = c("r2", "mae") + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m2, + y = res$y, + mupred = res$mupred_m2, + ylp = res$ylp_m2, + measure = c("r2", "mae") + ) + pm3 <- loo_pred_measure( + loo = res$loo_p_m3, + y = res$y, + mupred = res$mupred_m3, + ylp = res$ylp_m3, + measure = c("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 = c("r2", "mae"))) + expect_snapshot(print(comp, simplify = FALSE)) + expect_snapshot(print(comp, measures = "all", simplify = FALSE)) + + comp_mae <- suppressMessages(model_compare(list(m1 = pm1, m2 = pm2), rank_by = "mae")) + expect_snapshot(print(comp_mae)) + + expect_error( + print(comp, measures = "foo"), + "Unknown measure\\(s\\) in `measures`" + ) +}) + +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, + measure = c("r2", "mse") + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m2, + y = res$y, + mupred = res$mupred_m2, + ylp = res$ylp_m2, + measure = c("r2", "mse") + ) + loos <- list(pm1, pm2) + cols <- loo:::.compare_pointwise_cols(loos) + + expect_equal(cols, c("elpd_loo", "r2_loo", "mse_loo")) + expect_equal(loo:::.compare_measures(loos), c("elpd", "r2", "mse")) + expect_equal(loo:::.pointwise_col("mse", cols), "mse_loo") + expect_equal(loo:::.pointwise_col("elpd", cols), "elpd_loo") + expect_equal(loo:::.display_name("rmse_loo"), "rmse") + expect_equal(loo:::.resolve_rank_measure(loos, NULL)$bare, "elpd") + expect_equal(loo:::.resolve_rank_measure(loos, "mse")$internal, "mse_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, + measure = "rmse" + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m2, + y = res$y, + mupred = res$mupred_m2, + ylp = res$ylp_m2, + measure = "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, measure = "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, measure = "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, + measure = "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 `custom_se_fn`", { + 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, measure = 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" + ) + + # omitting `custom_se_fn` is an error that names the measure + expect_error( + suppressMessages(model_compare(pms)), + "my_rmse.*custom measure.*must be supplied" + ) + + # an explicit NULL reports the difference with an NA standard error + comp_null <- suppressMessages(model_compare(pms, custom_se_fn = NULL)) + 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 function gets the delta-method standard error + comp_fn <- suppressMessages( + model_compare(pms, custom_se_fn = loo:::.se_diff_rmse) + ) + expect_false(any(is.na(comp_fn$my_rmse_se_diff))) + # without `rank_by`, `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 `custom_se_fn`, + # 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 `custom_se_fn` that returns nonsense is caught + expect_error( + suppressMessages( + model_compare(pms, custom_se_fn = function(ref, cmp) c(1, 2)) + ), + "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" + 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)]], + measure = 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)) + + # the sign conversion is announced, as it is for built-in loss measures + expect_message( + comp <- model_compare(declared, custom_se_fn = "mean"), + "my_mse.*utility scale" + ) + comp_plain <- suppressMessages(model_compare(plain, custom_se_fn = "mean")) + + 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"]] + )) + # against a single pinned reference, only the orientation of the difference + # changes + comp_ref <- suppressMessages( + model_compare(declared, rank_by = "elpd", custom_se_fn = "mean") + ) + comp_plain_ref <- suppressMessages( + model_compare(plain, rank_by = "elpd", custom_se_fn = "mean") + ) + expect_equal(comp_ref$my_mse_diff, -comp_plain_ref$my_mse_diff) + expect_equal(comp_ref$my_mse_se_diff, comp_plain_ref$my_mse_se_diff) + # ... 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)) + + # `rank_by` puts the lowest loss first + ranked <- suppressMessages( + model_compare(declared, rank_by = "my_mse", custom_se_fn = NULL) + ) + ranked_plain <- suppressMessages( + model_compare(plain, rank_by = "my_mse", custom_se_fn = NULL) + ) + est <- vapply( + ranked$model, + function(m) declared[[m]]$estimates["my_mse_loo", "Estimate"], + numeric(1) + ) + expect_false(is.unsorted(est)) + expect_equal(rev(ranked$model), ranked_plain$model) + + # models must agree on the declaration + expect_error( + suppressMessages( + model_compare(list(declared$m1, plain$m2), custom_se_fn = "mean") + ), + "disagree on `measure_info`" + ) +}) + +test_that("`custom_se_fn` 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" + + make <- function(loo, mupred, ylp, measure) { + loo_pred_measure( + loo = loo, y = res$y, mupred = mupred, ylp = ylp, measure = 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, custom_se_fn = "mean") + ) + 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" + # 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, custom_se_fn = "sum")) + 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" + 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, custom_se_fn = "mean")), + "does not reproduce its estimate" + ) + + # any other string is rejected + expect_error( + suppressMessages(model_compare(custom, custom_se_fn = "median")), + "must be a function" + ) +}) + +test_that("`custom_se_fn` validates its per-measure form", { + res <- readRDS("data-for-tests/test_data_roaches_compare.Rds") + + make_fun <- function(name, offset) { + f <- function(y, mupred) { + ae_i <- abs(y - colMeans(mupred)) + offset + list(estimate = mean(ae_i), se = sqrt(var(ae_i) / length(ae_i)), + pointwise = ae_i) + } + attr(f, "measure_name") <- name + f + } + a <- make_fun("m_a", 0) + b <- make_fun("m_b", 1) + + make <- function(loo, mupred, ylp, measure) { + loo_pred_measure( + loo = loo, y = res$y, mupred = mupred, ylp = ylp, measure = measure + ) + } + + two <- list( + make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, list(m_a = a, m_b = b)), + make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, list(m_a = a, m_b = b)) + ) + + # a bare value is ambiguous with more than one custom measure + expect_error( + suppressMessages(model_compare(two, custom_se_fn = "mean")), + "must be a named list" + ) + + # a named list may mix the accepted forms + comp <- suppressMessages(model_compare( + two, + custom_se_fn = list(m_a = "mean", m_b = NULL) + )) + expect_false(any(is.na(comp$m_a_se_diff))) + expect_true(all(is.na(comp$m_b_se_diff))) + + # an entry must exist for every custom measure + expect_error( + suppressMessages(model_compare(two, custom_se_fn = list(m_a = "mean"))), + "no entry for custom measure" + ) + # unknown names are typos + expect_error( + suppressMessages(model_compare( + two, + custom_se_fn = list(m_a = "mean", m_b = NULL, nope = "mean") + )), + "Unknown measure" + ) + # unnamed lists cannot be matched to measures + expect_error( + suppressMessages(model_compare(two, custom_se_fn = list("mean", NULL))), + "must be named after a custom measure" + ) + # elements must be one of the accepted forms + expect_error( + suppressMessages(model_compare( + two, + custom_se_fn = list(m_a = 1, m_b = NULL) + )), + "must be a function" + ) + + # supplying it when no custom measure is present warns and changes nothing + 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") + ) + expect_warning( + comp_builtin <- suppressMessages( + model_compare(builtin, custom_se_fn = "mean") + ), + "only used for custom measures" + ) + expect_equal( + comp_builtin$mae_se_diff, + suppressMessages(model_compare(builtin))$mae_se_diff + ) + + # the model_compare() alias forwards the argument + one <- list( + make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, a), + make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, a) + ) + expect_equal( + suppressMessages(model_compare(one, custom_se_fn = "mean"))$m_a_se_diff, + suppressMessages(model_compare(one, custom_se_fn = "mean"))$m_a_se_diff + ) + expect_error( + suppressMessages(model_compare(one)), + "must be supplied" + ) +}) + +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, + measure = 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, custom_se_fn = list(my_mse = "mean"))), + "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, + measure = "mse" + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m2, + y = res$y, + mupred = res$mupred_m2, + ylp = res$ylp_m2, + measure = "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'" + ) +}) + +test_that("model_compare warns when rank_by is ignored for classic loo objects", { + expect_warning( + model_compare(w1, w2, rank_by = "mse"), + "`rank_by` is only used for `pred_measure` comparisons" + ) +}) + +.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)]], + measure = 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, + measure = 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, + measure = 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, + measure = measure + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m2, + y = res$y, + ypred = res$ypred_m2, + ylp = res$ylp_m2, + measure = 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, + measure = "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,7 +1356,7 @@ test_that("loo_compare throws appropriate warnings", { w_list_short <- lapply(1:4, function(x) { suppressWarnings(waic(LLarr + rnorm(1, 0, 0.1))) }) - expect_no_warning(loo_compare(w_list_short)) + expect_no_warning(model_compare(w_list_short)) }) @@ -88,8 +1375,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 +1387,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 +1400,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 +1422,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 +1511,436 @@ 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, + measure = c("rmse", "mse") + ) + k2 <- kfold_pred_measure( + y = res$y, mupred = .jitter_mupred(res$mupred, 3), kfold = res$kfold, + measure = c("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", "rmse", "mse")) + + # 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, measure = "rmse" + ) + t2 <- test_pred_measure( + y = res_cv$y_test, mupred = .jitter_mupred(res_cv$mupred_test, 5), + ylp_test = res_cv$ylp_test, measure = "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, measure = "rmse" + ) + i2 <- insample_pred_measure( + y = res$y, mupred = .jitter_mupred(res$mupred, 3), ylp = res$ylp, + measure = "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, + measure = "rmse") + l1 <- loo_pred_measure(loo = res$loo, y = res$y, mupred = res$mupred, + measure = "rmse") + i1 <- insample_pred_measure(y = res$y, mupred = res$mupred, ylp = res$ylp, + measure = "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, + measure = "rmse") + k2 <- kfold_pred_measure(y = res$y, mupred = .jitter_mupred(res$mupred, 3), + kfold = res$kfold, measure = "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 rank_by resolves bare names for suffixed measures", { + res <- .compare_src_res() + set.seed(4321) + k1 <- kfold_pred_measure(y = res$y, mupred = res$mupred, kfold = res$kfold, + measure = c("rmse", "mae")) + k2 <- kfold_pred_measure(y = res$y, mupred = .jitter_mupred(res$mupred, 3), + kfold = res$kfold, measure = c("rmse", "mae")) + + comp <- suppressMessages(model_compare(list(m1 = k1, m2 = k2), rank_by = "mae")) + expect_equal( + attr(comp, "rank_by"), + list(kind = "measure", measure = "mae", model = NULL) + ) + expect_equal(comp$mae_diff[1L], 0) + expect_true(all(comp$mae_diff[-1L] <= 0)) + + expect_error( + suppressMessages(model_compare(list(m1 = k1, m2 = k2), rank_by = "nope")), + "`rank_by` value 'nope' is neither a measure nor a model name", + fixed = TRUE + ) +}) + +test_that("model_compare rank_by accepts a model name as the reference model", { + 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)]], + measure = c("r2", "mse", "mae") + ) + } + pms <- list(m1 = mk(1), m2 = mk(2), m3 = mk(3)) + + default <- suppressMessages(model_compare(pms)) + pinned <- suppressMessages(model_compare(pms, rank_by = "m1")) + + # the named model is the reference for every measure, whether or not it is + # the best model + expect_equal( + attr(pinned, "rank_by"), + list(kind = "model", measure = "elpd", model = "m1") + ) + expect_true(all(attr(pinned, "compare_reference") == "m1")) + for (col in c("elpd_diff", "r2_diff", "mse_diff", "mae_diff")) { + expect_equal(pinned[[col]][pinned$model == "m1"], 0) + } + + # rows stay ordered by elpd, as without `rank_by` + expect_equal(pinned$model, default$model) + + # differences are the same comparisons, just re-referenced + expect_equal( + pinned$elpd_diff - pinned$elpd_diff[pinned$model == default$model[[1L]]], + default$elpd_diff + ) + + expect_output(print(pinned), "All measures compared against model m1") + + # `diag_diff` flags a *small* difference, so a large positive one --- which + # only arises when the reference is not the best model --- stays unflagged + large_positive <- pinned$elpd_diff[pinned$elpd_diff > 4] + expect_true(length(large_positive) > 0) + expect_equal(pinned$diag_diff[pinned$elpd_diff > 4], rep("", length(large_positive))) +}) + +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)]], + measure = 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)) + } +}) + +test_that("model_compare rank_by model name works for plain loo objects", { + comp <- model_compare(list(a = w1, b = w2), rank_by = "b") + expect_equal( + attr(comp, "rank_by"), + list(kind = "model", measure = "elpd", model = "b") + ) + expect_equal(attr(comp, "compare_reference"), c(elpd = "b")) + expect_equal(comp$elpd_diff[comp$model == "b"], 0) + expect_true(is.na(comp$p_worse[comp$model == "b"])) + + default <- model_compare(list(a = w1, b = w2)) + expect_equal(comp$model, default$model) + expect_equal( + comp$elpd_diff - comp$elpd_diff[comp$model == default$model[[1L]]], + default$elpd_diff + ) + expect_message(print(comp), "Differences computed against model b") +}) + +test_that("model_compare rank_by prefers the measure when a model shares its name", { + 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)]], + measure = c("mse") + ) + } + pms <- list(mse = mk(1), m2 = mk(2)) + + expect_warning( + comp <- suppressMessages(model_compare(pms, rank_by = "mse")), + "matches both a measure and a model name" + ) + expect_equal( + attr(comp, "rank_by"), + list(kind = "measure", measure = "mse", model = NULL) + ) + + expect_error( + suppressMessages(model_compare(pms, rank_by = 1)), + "`rank_by` must be a single measure name or model name", + fixed = TRUE + ) +}) + +# 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, + measure = "rmse") + k2 <- kfold_pred_measure(y = res$y, mupred = .jitter_mupred(res$mupred, 3), + kfold = res$kfold, measure = "rmse") + + expect_error( + suppressWarnings(loo_compare(k1, k2)), + "Use `model_compare()` to compare 'pred_measure' results", + fixed = TRUE + ) + expect_error( + suppressWarnings(loo_compare(w1, w2, rank_by = "model1")), + "`rank_by` is not supported by the deprecated `loo_compare()`", + fixed = TRUE + ) + expect_error( + suppressWarnings(loo_compare(w1, w2, custom_se_fn = "mean")), + "`custom_se_fn` is not supported by the deprecated `loo_compare()`", + 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, + measure = "rmse") + k2 <- kfold_pred_measure(y = res$y, mupred = .jitter_mupred(res$mupred, 3), + kfold = res$kfold, measure = "rmse") + comp <- suppressMessages(model_compare(list(m1 = k1, m2 = k2))) + + expect_output(print(comp), "K-fold cross-validation", fixed = TRUE) + + # LOO is the default and stays unlabelled + l1 <- loo_pred_measure(loo = res$loo, y = res$y, mupred = res$mupred, + measure = "rmse") + l2 <- loo_pred_measure(loo = res$loo, y = res$y, + mupred = .jitter_mupred(res$mupred, 3), + measure = "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), + measure = 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)) + + # `rank_by` follows the same orientation: the well-specified model must rank + # first under both scores + expect_equal( + suppressMessages( + model_compare(list(m1 = pm1, m2 = pm2), rank_by = "rps") + )$model[1L], + "m1" + ) + expect_equal( + suppressMessages( + model_compare(list(m1 = pm1, m2 = pm2), rank_by = "srps") + )$model[1L], + "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)]], + measure = 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 48c37570..30e95e42 100644 --- a/tests/testthat/test_crps.R +++ b/tests/testthat/test_crps.R @@ -74,10 +74,10 @@ test_that("methods for single data point don't error", { # See notes/developer-notes.Rmd ("CRPS / RPS numerical comparison") for details. # ------------------------------------------------------------------------- +# Deliberately calls the package's own estimator rather than restating the +# formula, so the two cannot drift apart. .exx_pwm <- function(ypred) { - n_draws <- nrow(ypred) - ypred_sorted <- apply(ypred, 2, sort) - colMeans(ypred_sorted * ((seq_len(n_draws) * (4 / (n_draws - 1))) - 2)) + loo:::.exx_pwm(ypred) } .exy_crps <- function(ypred, y) { @@ -92,19 +92,18 @@ test_that("methods for single data point don't error", { list(y = y, x1 = x1, x2 = x2) } -test_that("measure_rps(higher_is_better = FALSE) matches deprecated crps() sign convention", { +test_that("the deprecated crps() is the negated measure_rps()", { d <- .crps_draws() old <- suppressWarnings(crps(d$x1, d$x2, d$y)) - new_rev <- measure_rps(d$y, d$x1, higher_is_better = TRUE) + # `measure_rps()` returns the Gneiting & Raftery (2007) loss; `crps()` + # returned its negation. The two use different estimators, so they agree in + # direction and closely, but not exactly. + negated <- -as.vector(measure_rps(d$y, d$x1)$pointwise) - expect_equal( - as.vector(new_rev$pointwise), - -as.vector(measure_rps(d$y, d$x1)$pointwise) - ) - expect_gt(cor(old$pointwise, as.vector(new_rev$pointwise)), 0.98) + expect_gt(cor(old$pointwise, negated), 0.98) expect_false(isTRUE(all.equal( old$pointwise, - as.vector(new_rev$pointwise), + negated, tolerance = 1e-6 ))) }) diff --git a/tests/testthat/test_loo_subsampling.R b/tests/testthat/test_loo_subsampling.R index 84e8d785..8f517782 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, @@ -1061,15 +1061,15 @@ test_that("loo_compare_subsample", { expect_equal(lcssohh[, 2][3], lcsso[, 2][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(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) }) diff --git a/tests/testthat/test_loo_subsampling_cases.R b/tests/testthat/test_loo_subsampling_cases.R index 532d5830..6bb1fe69 100644 --- a/tests/testthat/test_loo_subsampling_cases.R +++ b/tests/testthat/test_loo_subsampling_cases.R @@ -430,7 +430,7 @@ test_that("Test the vignette", { expect_snapshot(print(looss_2)) expect_warning( - comp <- loo_compare(looss_1, looss_2), + comp <- model_compare(looss_1, looss_2), "Different subsamples in 'model2' and 'model1'. Naive diff SE is used." ) expect_snapshot(print(comp)) @@ -454,7 +454,7 @@ test_that("Test the vignette", { "Simple random sampling with replacement assumed." ) - expect_silent(comp <- loo_compare(looss_1, looss_2_m)) + expect_silent(comp <- model_compare(looss_1, looss_2_m)) expect_snapshot(print(comp)) set.seed(4712) @@ -474,7 +474,7 @@ test_that("Test the vignette", { observations = looss_1 ) ) - expect_silent(comp2 <- loo_compare(looss_1, looss_2_m)) + expect_silent(comp2 <- model_compare(looss_1, looss_2_m)) expect_snapshot(print(comp2)) expect_no_warning( @@ -485,7 +485,7 @@ test_that("Test the vignette", { ) ) expect_message( - comp3 <- loo_compare(x = list(looss_1, looss_2_full)), + comp3 <- model_compare(x = list(looss_1, looss_2_full)), "Estimated elpd_diff using observations included in loo calculations for all models." ) expect_snapshot(print(comp3)) diff --git a/tests/testthat/test_pred_measure.R b/tests/testthat/test_pred_measure.R index a5d71e11..5affcb75 100644 --- a/tests/testthat/test_pred_measure.R +++ b/tests/testthat/test_pred_measure.R @@ -29,7 +29,7 @@ test_that(".compute_measure() with r2 works as expected", { log_weights = NULL ) - expect_equal(names(measure_res), c("estimates", "pointwise")) + expect_equal(names(measure_res), c("estimates", "pointwise", "extra")) }) test_that(".compute_measure() with rps works as expected", { @@ -535,4 +535,75 @@ test_that("insample_pred_measure() accepts mixed built-in and custom measures", ) expect_true(all(c("r2", "custom_rmse") %in% rownames(res$estimates))) -}) \ No newline at end of file +}) + +test_that("a custom measure can declare itself a loss", { + set.seed(11) + S <- 20L + n <- 12L + y <- rnorm(n) + mupred <- matrix(rnorm(S * n), nrow = S, ncol = n) + ylp <- matrix(rnorm(S * n), nrow = S, ncol = n) + + custom_mse <- function(y, mupred) { + sqe <- (y - colMeans(mupred))^2 + list( + estimate = mean(sqe), + se = sqrt(var(sqe) / length(sqe)), + pointwise = sqe + ) + } + attr(custom_mse, "measure_name") <- "custom_mse" + + utility <- insample_pred_measure( + y = y, mupred = mupred, ylp = ylp, measure = custom_mse + ) + expect_false(attr(utility, "measure_info")$custom_mse$loss) + + attr(custom_mse, "measure_loss") <- TRUE + loss <- insample_pred_measure( + y = y, mupred = mupred, ylp = ylp, measure = custom_mse + ) + info <- attr(loss, "measure_info")$custom_mse + expect_true(info$loss) + # the declaration says what the measure is, not how it is stored + expect_equal(loss$estimates, utility$estimates) + expect_true(all(loss$pointwise[, "custom_mse"] >= 0)) +}) + +test_that("`higher_is_better` in `control` is no longer recognised", { + set.seed(12) + S <- 20L + n <- 12L + y <- rnorm(n) + mupred <- matrix(rnorm(S * n), nrow = S, ncol = n) + ylp <- matrix(rnorm(S * n), nrow = S, ncol = n) + + custom_mse <- function(y, mupred) { + sqe <- (y - colMeans(mupred))^2 + list( + estimate = mean(sqe), + se = sqrt(var(sqe) / length(sqe)), + pointwise = sqe + ) + } + attr(custom_mse, "measure_name") <- "custom_mse" + attr(custom_mse, "measure_loss") <- TRUE + + natural <- insample_pred_measure( + y = y, mupred = mupred, ylp = ylp, measure = custom_mse + ) + expect_warning( + ignored <- insample_pred_measure( + y = y, mupred = mupred, ylp = ylp, measure = custom_mse, + control = list(custom_mse = list(higher_is_better = TRUE)) + ), + "not a valid argument" + ) + + # values are always stored on the measure's own scale + expect_equal(ignored$estimates, natural$estimates) + expect_equal(ignored$pointwise, natural$pointwise) + expect_null(attr(ignored, "measure_higher_is_better")) + expect_null(attr(ignored, "measure_info")$custom_mse$higher_is_better) +}) diff --git a/tests/testthat/test_pred_measure_builtin.R b/tests/testthat/test_pred_measure_builtin.R index 6bb3ac16..717902ae 100644 --- a/tests/testthat/test_pred_measure_builtin.R +++ b/tests/testthat/test_pred_measure_builtin.R @@ -207,6 +207,133 @@ testthat::test_that("measure_rps() with continuous data and scaled version works expect_true(all(res$pointwise < 0)) }) +# Properties of the E|X - X'| estimator behind RPS/CRPS. The estimator is a +# weighted average over all pairs of draws, so it must reproduce the +# brute-force pairwise computation exactly, stay non-negative, and be invariant +# to shifting `y` and `ypred` by the same constant. + +# brute-force reference for E|X - X'|, over all pairs of draws +.exx_brute <- function(ypred, w = NULL) { + n_draws <- nrow(ypred) + if (is.null(w)) { + w <- matrix(1 / n_draws, n_draws, ncol(ypred)) + } + vapply( + seq_len(ncol(ypred)), + function(j) { + x <- ypred[, j] + wj <- w[, j] + sum(outer(wj, wj) * abs(outer(x, x, "-"))) / (1 - sum(wj^2)) + }, + numeric(1) + ) +} + +testthat::test_that(".exx_pwm() matches the brute-force pairwise estimator", { + set.seed(4321) + for (n_draws in c(2L, 5L, 50L)) { + # a location far from zero: a biased estimator of E|X - X'| shows up here + ypred <- matrix(rnorm(n_draws * 4L, mean = 250, sd = 30), nrow = n_draws) + expect_equal(.exx_pwm(ypred), .exx_brute(ypred)) + + w <- exp(.normalize_log_weights(matrix(rnorm(n_draws * 4L), nrow = n_draws))) + expect_equal(.exx_pwm(ypred, w), .exx_brute(ypred, w)) + } +}) + +testthat::test_that(".exx_pwm() errors with fewer than two draws", { + expect_error( + .exx_pwm(matrix(1, nrow = 1L, ncol = 3L)), + "at least 2 draws" + ) + expect_error( + measure_rps(y = 1, ypred = matrix(1, nrow = 1L, ncol = 1L)), + "at least 2 draws" + ) +}) + +testthat::test_that("measure_rps() errors when `ypred` is missing or misshaped", { + expect_error( + measure_rps(y = res_sleep$y, ypred = NULL), + "`ypred` must be a numeric matrix or array" + ) + expect_error( + measure_rps(y = res_sleep$y, ypred = res_sleep$ypred[, -1L, drop = FALSE]), + "`ypred` must have" + ) +}) + +testthat::test_that("measure_rps() is invariant to shifting y and ypred", { + shift <- 1e4 + for (scaled in c(FALSE, TRUE)) { + expect_equal( + measure_rps(res_sleep$y + shift, res_sleep$ypred + shift, scaled = scaled)$pointwise, + measure_rps(res_sleep$y, res_sleep$ypred, scaled = scaled)$pointwise + ) + expect_equal( + measure_rps( + res_sleep$y + shift, + res_sleep$ypred + shift, + log_weights = res_sleep$log_weights, + scaled = scaled + )$pointwise, + measure_rps( + res_sleep$y, + res_sleep$ypred, + log_weights = res_sleep$log_weights, + scaled = scaled + )$pointwise + ) + } +}) + +testthat::test_that("measure_rps() is non-negative as an unscaled loss", { + expect_true(all(measure_rps(res_sleep$y, res_sleep$ypred)$pointwise >= 0)) + expect_true(all(measure_rps(res_binom$y, res_binom$ypred)$pointwise >= 0)) + expect_true(all( + measure_rps( + res_roaches$y, + res_roaches$ypred, + log_weights = res_roaches$log_weights + )$pointwise >= 0 + )) +}) + +testthat::test_that("measure_srps() is finite under concentrated weights", { + # Regression test: the roaches fit has an observation whose PSIS weight is + # >0.8, which used to drive the E|X - X'| estimate negative and made + # `log(EXX)` return NaN. + res <- measure_srps( + res_roaches$y, + res_roaches$ypred, + log_weights = res_roaches$log_weights + ) + + expect_true(all(is.finite(res$pointwise))) + expect_true(all(is.finite(res$estimates))) +}) + +testthat::test_that("uniform log-weights reproduce the unweighted measure_rps()", { + uniform_lw <- matrix(0, nrow(res_sleep$ypred), ncol(res_sleep$ypred)) + + for (scaled in c(FALSE, TRUE)) { + expect_equal( + measure_rps(res_sleep$y, res_sleep$ypred, log_weights = uniform_lw, + scaled = scaled)$pointwise, + measure_rps(res_sleep$y, res_sleep$ypred, scaled = scaled)$pointwise + ) + } +}) + +testthat::test_that("measure_srps() passes precomputed pointwise values through", { + pw <- c(-1.5, -2.5, -3.5) + res <- measure_srps(pointwise = pw) + + expect_equal(as.vector(res$pointwise), pw) + expect_equal(rownames(res$estimates), "srps") + expect_equal(res$estimates[1L, "Estimate"], mean(pw), ignore_attr = TRUE) +}) + # measure_brier() --------------------------------------- @@ -302,30 +429,30 @@ testthat::test_that("measure_mse() and measure_rmse() work as expected", { expect_snapshot_output(measure_rmse(y = res_roaches$y, mupred = res_roaches$mupred)) }) -testthat::test_that("higher_is_better reorients loss measures to utility scale", { - res_mse <- measure_mse(y = res_roaches$y, mupred = res_roaches$mupred) - res_mse_utility <- measure_mse( - y = res_roaches$y, - mupred = res_roaches$mupred, - higher_is_better = TRUE +testthat::test_that("rps is a loss and srps a utility", { + set.seed(1) + y <- rnorm(50) + good <- matrix(rnorm(50 * 400), nrow = 400) + bad <- matrix(rnorm(50 * 400, mean = 3, sd = 4), nrow = 400) + + # unscaled RPS/CRPS follows Gneiting & Raftery (2007): lower is better + expect_true(loo:::.measure_is_loss("rps")) + expect_lt( + measure_rps(y, good)$estimates[1L, "Estimate"], + measure_rps(y, bad)$estimates[1L, "Estimate"] ) - expect_equal( - unname(res_mse_utility$estimates["Estimate"]), - -unname(res_mse$estimates["Estimate"]) + # the scaled variant follows Bolin & Wallin (2023): higher is better + expect_false(loo:::.measure_is_loss("srps")) + expect_gt( + measure_srps(y, good)$estimates[1L, "Estimate"], + measure_srps(y, bad)$estimates[1L, "Estimate"] ) - expect_equal(res_mse_utility$pointwise, -res_mse$pointwise) }) -testthat::test_that("higher_is_better reorients rps and srps", { +testthat::test_that("the raw rps score is a non-negative loss", { raw <- measure_rps(res_sleep$y, res_sleep$ypred) expect_true(all(raw$pointwise >= 0)) - up <- measure_rps(res_sleep$y, res_sleep$ypred, higher_is_better = TRUE) - expect_equal(up$pointwise, -raw$pointwise) - - s_raw <- measure_srps(res_sleep$y, res_sleep$ypred) - s_dn <- measure_srps(res_sleep$y, res_sleep$ypred, higher_is_better = FALSE) - expect_equal(s_dn$pointwise, -s_raw$pointwise) }) testthat::test_that("measure_rmse() works with se=0", { @@ -344,7 +471,7 @@ testthat::test_that("measure_rmse() works with se=0", { testthat::test_that("measure_r2() works as expected", { res <- measure_r2(y = res_roaches$y, mupred = res_roaches$mupred, log_weights = NULL) - expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(names(res), c("estimates", "pointwise", "extra")) expect_equal(length(res$estimates), 2) expect_equal(length(res$pointwise), length(res_roaches$y)) expect_true(all(res$estimates[1] >= 0 & res$estimates[1] <= 1)) @@ -356,7 +483,7 @@ testthat::test_that("measure_r2() with log_weights works as expected", { res <- measure_r2(y = res_roaches$y, mupred = res_roaches$mupred, log_weights = res_roaches$log_weights) - expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(names(res), c("estimates", "pointwise", "extra")) expect_equal(length(res$estimates), 2) expect_equal(length(res$pointwise), length(res_roaches$y)) expect_true(all(res$estimates[1] >= 0 & res$estimates[1] <= 1)) @@ -443,7 +570,7 @@ testthat::test_that("measure_bacc() pointwise contributions sum to estimate", { testthat::test_that("measure_bacc() works as expected", { res <- measure_bacc(y = as.integer(res_cat$y), mupred = res_cat$mupred, log_weights = NULL) - expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(names(res), c("estimates", "pointwise", "extra")) expect_equal(length(res$estimates), 2) expect_equal(length(res$pointwise), length(res_cat$y)) expect_true(!all(res$pointwise < 0 | res$pointwise > 1)) @@ -487,7 +614,7 @@ testthat::test_that("measure_bacc() with log-weights works as expected", { log_weights = res_cat$log_weights ) - expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(names(res), c("estimates", "pointwise", "extra")) expect_equal(length(res$estimates), 2) expect_equal(length(res$pointwise), length(res_cat$y)) expect_true(!all(res$pointwise < 0 | res$pointwise > 1)) diff --git a/tests/testthat/test_pred_measure_helpers.R b/tests/testthat/test_pred_measure_helpers.R index 59e088cf..680b93d1 100644 --- a/tests/testthat/test_pred_measure_helpers.R +++ b/tests/testthat/test_pred_measure_helpers.R @@ -35,6 +35,26 @@ test_that(".normalize_measure() handles a mixed list", { expect_equal(entries[[2]]$name, "custom_mae") }) +test_that(".normalize_measure() reads the `measure_loss` declaration", { + f <- function(y, mupred) list(estimate = 1, se = 0, pointwise = y) + attr(f, "measure_name") <- "custom_mae" + + # a custom measure is a utility unless it says otherwise + expect_false(.normalize_measure(f)[[1]]$loss) + + attr(f, "measure_loss") <- TRUE + expect_true(.normalize_measure(f)[[1]]$loss) + # the list form takes its name from the element, but the same declaration + expect_true(.normalize_measure(list(my_loss = f))[[1]]$loss) + + attr(f, "measure_loss") <- "yes" + expect_error(.normalize_measure(f), regexp = "measure_loss") + attr(f, "measure_loss") <- c(TRUE, FALSE) + expect_error(.normalize_measure(list(my_loss = f)), regexp = "measure_loss") + attr(f, "measure_loss") <- NA + expect_error(.normalize_measure(f), regexp = "measure_loss") +}) + test_that(".normalize_measure() errors on duplicate names", { expect_error( .normalize_measure(c("mse", "mse")), @@ -124,7 +144,7 @@ test_that(".validate_control() accepts valid control silently", { expect_invisible(.validate_control(list(rps = list(scaled = TRUE)))) expect_invisible(.validate_control(list( rps = list(scaled = TRUE), - srps = list(higher_is_better = TRUE) + srps = list(pointwise = NULL) ))) }) @@ -166,9 +186,44 @@ test_that(".validate_control() errors on malformed control", { .validate_control(list(rps = c(scaled = TRUE))), regexp = "must be a named list of named lists." ) - expect_error( - .validate_control(list(not_a_function = list(x = 1))), - regexp = "not_a_function" +}) + +test_that(".validate_control() warns on a control entry naming no measure", { + expect_warning( + .validate_control(list(not_a_measure = list(x = 1))), + regexp = "not_a_measure.*matches no" + ) + # the same when the requested measures are known + expect_warning( + .validate_control( + list(mse = list(pointwise = NULL)), + measures = .normalize_measure("rps") + ), + regexp = "mse.*matches no" + ) +}) + +test_that(".validate_control() validates custom measures against their formals", { + f <- function(y, mupred, delta = 1) { + list(estimate = 1, se = 0, pointwise = y) + } + attr(f, "measure_name") <- "custom_huber" + entries <- .normalize_measure(f) + + # only the custom function's own formals are accepted + expect_silent( + .validate_control(list(custom_huber = list(delta = 2)), entries) + ) + expect_warning( + .validate_control( + list(custom_huber = list(higher_is_better = TRUE)), + entries + ), + regexp = "Ignoring `higher_is_better` as it is not a valid argument" + ) + expect_warning( + .validate_control(list(custom_huber = list(nope = 1)), entries), + regexp = "Ignoring `nope` as it is not a valid argument" ) }) diff --git a/vignettes/articles-online-only/model-comparison.Rmd b/vignettes/articles-online-only/model-comparison.Rmd new file mode 100644 index 00000000..913a1a77 --- /dev/null +++ b/vignettes/articles-online-only/model-comparison.Rmd @@ -0,0 +1,983 @@ +--- +title: "Differences and their standard errors in model comparison" +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 #!r identical(Sys.getenv("NOT_CRAN"), "true") +vignette: > + %\VignetteIndexEntry{Differences and their standard errors in model comparison} + %\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" +) +``` + +::: {.callout .callout-warning} +**Questions** + ++ How detailed should the math for the computation be and how to attribute properly the work from the overleaf document? Are you considering to publish it? -> Answered: we target for a preprint that we can cite. ++ Currently, `elpd` is computed by default in `pred_measure`. This is helpful, when we want to have it by default in `model_compare`. Do we want this default behavior? ++ Related question: The default print method of `model_compare` shows only the `elpd`, only when `print(..., measures = "all")` is passed, all measures are shown. Do we want this? ++ For `elpd`, we provide in the `model_compare` output the additional columns `p_worse`, `diag_diff`, `diag_elpd`. + + Do we want to have `p_worse` and `diag_diff` for all measures? + + I moved the column `diag_elpd` out from the elpd-specific measure block and treat it as an "overall" information (see printed output below). + + Furthermore, I renamed `diag_elpd` to `diag_psis` as it seems not be specific to elpd or do I misunderstand this? ++ General: Is the current design of `model_compare()` okay? ++ Which warnings/messages do we want to provide and which should only be part of the function documentation? +::: + +```{r, child="../children/LOAD-BRMS-GITHUB.txt", eval=params$EVAL} +``` + +::: {.callout .callout-note} +**Acknowledgements** + +We thank Seth Axen, Frank Weber, and Aki Vehtari for deriving the formulas of +the standard errors for LOO-CV estimators and differences. +::: + +## Introduction +In the following, our goal is to compare performance between two or more +models. To do this, we will use the function `loo::model_compare()`. + +`model_compare()` compares model performance between multiple models based +on one or more performance criteria. We provide a list of built-in criteria +including `elpd, ic, mlpd, mae, mse, acc, brier, rps, srps, rmse, r2, bacc` +(see the [Overview of scores and metrics](overview-measures.html) +article). +Additionally, it is possible to define a custom performance criterion. + +The `model_compare()` function accepts any object that inherits from the `loo` +class. This includes outputs from: + ++ `loo()`, `kfold()`, and `waic()` ++ all `_pred_measure` functions (with `` being a placeholder for `loo`, `kfold`, `test`, or `insample`) + +In this vignette we focus on the comparison of **predictive performance +measures** produced by `_pred_measure()` and explain: + +1. The approaches for computing the point estimate and standard error of the + difference for each `` and built-in measure. +2. How to compute the point estimate and standard error of the difference 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, +`rank_by`, and `custom_se_fn` 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`). + + + +```{r load-libraries} +library(loo) +``` + +```{r setup-example} +measures <- c("mae", "mse", "rmse", "r2", "rps") # elpd is computed by default +``` + +## 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, warning=TRUE} +loo_compare(loos) +``` + +When we use `model_compare` instead, we get the same output for `loo` objects: + +```{r model_compare_wloo, warning=TRUE} +model_compare(loos) +``` + +## Preview: Glimpse into the model comparison results + +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 `elpd` measure is shown. + + +```{r pred-measure} +fit_measure <- function(fit, measure) { + loo_pred_measure( + y = fit$data$y, + ypred = brms::posterior_predict(fit), + mupred = brms::posterior_epred(fit), + ylp = brms::log_lik(fit), + measure = 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") +``` + +Or in order to see all measures we can 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$^{(1)}$ (calculated as model - reference). For the reference model itself, this value is always zero. + + `_se_diff`$^{(2)}$: 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 rather than any single measure or any pair of models --- all + LOO measures are computed from the same importance weights, and the value + does not depend on the reference model. It is therefore reported once per + model instead of as a column in the difference tables. On the returned + object the same information is available in the `diag_elpd` column. + +This block is omitted when no model is flagged, and for `kfold`, `test`, and +`insample` sources, which have no Pareto $\hat{k}$ diagnostic. + +$^{(1)}$ By default, the reference model is the best model (per measure). For additional information, see Section [Selecting the reference model](#selecting-the-reference-model) + +$^{(2)}$ 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()` (and to `custom_se_fn()`) as part of each model's input | + +## Background: Computation underlying `model_compare` output + +In this section, we explain (1) how the point estimate `_diff` and the +(2) standard error of the difference `_se_diff` are computed for +each measure. While the point estimate is computed in the same way for all +measures, the computation of the standard error depends on the +measure. + +### 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 (see Section +[Selecting the reference model](#selecting-the-reference-model)), so `m3` is not +the reference for every 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 in the default case in +which 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, `model_compare()` informs the +user about this change: + +```{r sign-message, warning=TRUE, message=TRUE} +comp <- model_compare(list(m1 = m1, m2 = m2, m3 = m3)) +``` + +::: {.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 | +| :--- | :--- | :--- | +| `"sum"` | `sqrt(N) * sd(d_i)` | `elpd`, `ic` | +| `"mean"` | `sd(d_i) / sqrt(N)` | `mlpd`, `mae`, `mse`, `acc`, `brier`, `rps`, `srps` | +| `"measure_specific"` | the measure's own `se_diff_fun` | `rmse`, `r2`, `bacc` | +| `"custom"` | supplied via `model_compare(custom_se_fn = )` | 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) +``` + +#### Approach 1: "sum" {#approach-sum} + +For `elpd` and `ic` the model estimate is a **sum** of pointwise contributions, +e.g., for `elpd` + +$$ +\widehat{\text{elpd}}_{\text{loo}} = \sum_{i=1}^{N} \widehat{\text{elpd}}_{\text{loo},i}. +$$ + +Let $d_i$ be the pointwise difference for observation $i$ between the +comparison model $M_a$ and the reference model $M_b$, + +$$ +d_i = \widehat{\text{elpd}}_{\text{loo},i}(M_a) - \widehat{\text{elpd}}_{\text{loo},i}(M_b), +$$ + +and let $D = \sum_{i=1}^{N} d_i$ be the estimated total difference. Treating the +$d_i$ as independent draws from a distribution with variance $\sigma_d^2$, + +$$ +\text{Var}(D) = \sum_{i=1}^{N} \text{Var}(d_i) = N \sigma_d^2 +\quad\Longrightarrow\quad +\text{SE}(D) = \sqrt{N}\, \sigma_d . +$$ + +In practice $\sigma_d$ is replaced by the sample standard deviation of the +pointwise differences, which gives the estimator used by `model_compare()`: + +$$ +\widehat{\text{SE}}(D) = \sqrt{N} \cdot \text{sd}(d) + = \Big( N \cdot \widehat{\text{Var}}(d) \Big)^{1/2}. +$$ + +```{r sum-method} +n <- attr(m1, "dims")[2] +d_elpd <- m1$pointwise[, "elpd_loo"] - m3$pointwise[, "elpd_loo"] + +c( + by_hand = sqrt(n) * sd(d_elpd), + reported = comp$se_diff[comp$model == "m1"] +) +``` + +#### Approach 2: "mean" {#approach-mean} + +For `mlpd`, `mae`, `mse`, and most scoring rules, the model estimate is a +**mean** of pointwise contributions, e.g., for `mse` + +$$ +\widehat{\text{mse}}_{\text{loo}} = \frac{1}{N} \sum_{i=1}^{N} \widehat{\text{mse}}_{\text{loo},i}. +$$ + +With $d_i$ defined as in [Approach 1](#approach-sum), the reported difference is +the *mean* pointwise difference $\bar{d} = \frac{1}{N}\sum_{i=1}^{N} d_i = D/N$. +As $\bar{d}$ is just $D$ rescaled by the constant $1/N$, + +$$ +\text{SE}(\bar{d}) = \frac{1}{N}\, \text{SE}(D) = \frac{1}{N} \sqrt{N}\, \sigma_d += \frac{\sigma_d}{\sqrt{N}}, +$$ + +that is, the familiar standard error of a mean. Replacing $\sigma_d$ by the +sample standard deviation of the pointwise differences gives the estimator used +by `model_compare()`: + +$$ +\widehat{\text{SE}}(\bar{d}) = \frac{\text{sd}(d)}{\sqrt{N}}. +$$ + +By default every measure uses its *own* best model as the reference (see +Section [Selecting the reference model](#selecting-the-reference-model)). For +`mse` that is `m2`, not `m3` as for `elpd` above: + +```{r mean-method} +d_mse <- m1$pointwise[, "mse_loo"] - m2$pointwise[, "mse_loo"] + +c( + by_hand = sd(d_mse) / sqrt(n), + reported = comp$mse_se_diff[comp$model == "m1"] +) +``` + +Note that `mse` is a loss, so `model_compare()` flips its sign before taking the +difference (see the callout on *utility vs. loss scale* above). However, +flipping the sign leaves `sd(d)` unaffected, which is why the raw pointwise +differences above reproduce the reported value. + +#### Approach 3: "measure_specific" {#approach-measure-specific} + +The estimate of these measures is neither a sum nor a mean of pointwise +contributions, so their standard error cannot be obtained from the paired +pointwise differences alone. Instead, each such measure ships its own formula, +recorded in the `se_diff_fun` slot of the `measure_info` attribute. We +give the formulas for the built-in measures `rmse`, `r2`, and `bacc` below. + +**RMSE** + +For RMSE, the delta method (i.e., a first-order Taylor series approximation; +see Ver Hoef, 2012, for its history) on the MSE scale is used +and propagated through the square root: + +$$ +SE_{RMSE}(M_a, M_b) = \frac{1}{2}\sqrt{ + \frac{SE_{MSE}(M_a)^2}{{MSE}(M_a)} + \frac{SE_{MSE}(M_b)^2}{{MSE}(M_b)} + - \frac{2 \mathrm{Cov}_{MSE}[M_a, M_b]}{{RMSE}(M_a) \cdot {RMSE}(M_b)} +} +$$ + +All terms on the right-hand side are computable from the stored pointwise +squared errors: + +```{r pairwise-rmse} +# `rmse` is compared against its own reference model, `ref[["rmse"]]` +sqe_a <- models[[ref[["rmse"]]]]$pointwise[, "rmse_loo"] +sqe_b <- m1$pointwise[, "rmse_loo"] + +mse_a <- mean(sqe_a) +mse_b <- mean(sqe_b) +se_a <- sqrt(var(sqe_a) / n) +se_b <- sqrt(var(sqe_b) / n) +cov_rc <- sum((sqe_a - mse_a) * (sqe_b - mse_b)) / (n * (n - 1)) + +se_rmse <- 0.5 * sqrt( + se_a^2 / mse_a + se_b^2 / mse_b - + 2 * cov_rc / (sqrt(mse_a) * sqrt(mse_b)) +) + +c( + by_hand = se_rmse, + reported = comp$rmse_se_diff[comp$model == "m1"] +) +``` + +**R2** + +The R2 used here is the leave-one-out version of the classical formula, +$1 - \text{MSE}(M_k) / \text{MSE}(y)$, rather than Bayesian R2 +(Gelman et al., 2019). +For R2, let $d_i = \text{sqe}_i(M_a) - \text{sqe}_i(M_b)$ be the +pointwise difference in squared errors and +$\text{MSE}(M_a, M_b) = \frac{1}{n}\sum_{i=1}^n d_i$ its mean. The +difference in R2 is a ratio of two quantities estimated from the same data: + +$$ +R^2(M_a) - R^2(M_b) = -\frac{\text{MSE}(M_a, M_b)}{\text{MSE}(y)} +$$ + +A trivariate first-order Taylor expansion of that ratio gives + +$$ +SE_{R^2}(M_a, M_b) = \frac{1}{\text{MSE}(y)} \sqrt{ + SE_{MSE}(M_a, M_b)^2\\ + - 2\,\frac{\text{MSE}(M_a, M_b)}{\text{MSE}(y)}\, + \mathrm{Cov}\!\left[\text{MSE}(M_a, M_b),\, \text{MSE}(y)\right]\\ + + \frac{\text{MSE}(M_a, M_b)^2}{\text{MSE}(y)^2}\, + \mathrm{Var}\!\left[\text{MSE}(y)\right] +} +$$ + +With $c = \text{MSE}(M_a, M_b) / \text{MSE}(y)$ and the pointwise baseline +$\text{sqe}(y)_i = (y_i - \bar{y})^2$, the expression above is equal to + +$$ +SE_{R^2}(M_a, M_b) = \frac{1}{\text{MSE}(y)} \cdot + \frac{\mathrm{sd}\!\left(d_i - c\,\text{sqe}(y)_i\right)}{\sqrt{n}} +$$ + +This is the form used in **loo**: it cannot go negative under the square root, +and it is exactly zero when a model is compared against itself. The computation +needs the pointwise baseline $\text{sqe}(y)_i$, which is stored in the `extra` +slot of the `measure_info` attribute: + +```{r r2-extra} +str(attr(m1, "measure_info")$r2$extra) +``` + +The following code block shows the hand-computed standard error and the +reported standard error in the `comp` object for model `m1` against the +reference model used for `r2`: + +```{r pairwise-r2} +mse_y_i <- attr(m1, "measure_info")$r2$extra$mse_y_i +mse_y <- mean(mse_y_i) + +d_sqe <- m1$pointwise[, "r2_loo"] - models[[ref[["r2"]]]]$pointwise[, "r2_loo"] +scaled <- d_sqe - (mean(d_sqe) / mse_y) * mse_y_i + +c(by_hand = sd(scaled) / sqrt(n) / mse_y, + reported = comp$r2_se_diff[comp$model == "m1"]) +``` + +**bacc** + +For the balanced accuracy (bacc), let +$d_i = \text{acc}_i(M_a) - \text{acc}_i(M_b)$ be the difference +in pointwise accuracies. Because every class gets the same weight regardless of +its size, the difference in bacc is not a mean of the $d_i$, but a mean of the +$K$ class-wise mean differences: + +$$ +\text{bacc}(M_a, M_b) = \frac{1}{K} \sum_{c=1}^{K} \bar{d}_c, +\qquad \bar{d}_c = \frac{1}{n_c} \sum_{i \in c} d_i +$$ + +where $K$ is the number of classes and $n_c$ the number of observations in +class $c$. The variance of the class mean is +$\text{Var}(\bar{d}_c) = s_c^2 / n_c$, and + +$$ +SE_{\text{bacc}}(M_a, M_b) = \frac{1}{K} \sqrt{\sum_{c=1}^{K} \frac{s_c^2}{n_c}}, +\qquad s_c^2 = \frac{1}{n_c - 1} \sum_{i \in c} \left(d_i - \bar{d}_c\right)^2 +$$ + +with $s_c^2 := 0$ for any class holding a single observation. +Writing $b_c$ and $m_c$ for the number of +observations in class $c$ that only $M_a$, respectively only $M_b$, classifies +correctly, the class term is a McNemar-type variance of a paired difference of +proportions (McNemar, 1947), + +$$ +\frac{s_c^2}{n_c} = \frac{1}{n_c - 1} + \left(\frac{b_c + m_c}{n_c} - \frac{(b_c - m_c)^2}{n_c^2}\right) +$$ + +For binary outcomes balanced accuracy is +$(\text{sensitivity} + \text{specificity}) / 2$, so the difference above +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). + +To demonstrate the computation of the standard error of the difference for bacc, +we introduce another example where the outcome variable is binary. +We simulate 200 observations from a logistic model with a single continuous +predictor `x`, and fit two Bernoulli models: `m_a` uses the predictor `x` that +generated the data, while `m_b` uses a noisy version `w` of it and therefore +classifies part of the observations differently. + +```{r bacc-fit} +set.seed(2024) +n_obs <- 200 +x <- rnorm(n_obs) +df_bacc <- data.frame( + y = rbinom(n_obs, 1, plogis(-1.4 + 1.6 * x)), + x = x, + w = x + rnorm(n_obs, sd = 1.5) +) + +fit_bacc_x <- brms::brm( + y ~ x, + data = df_bacc, + family = brms::bernoulli(), + prior = brms::prior(normal(0, 2), class = b), + chains = 2, iter = 1000, seed = SEED, refresh = 0 +) +fit_bacc_w <- update(fit_bacc_x, formula = y ~ w, newdata = df_bacc, + refresh = 0) + +y <- fit_bacc_x$data$y + +m_a <- loo_pred_measure( + y = y, + mupred = brms::posterior_epred(fit_bacc_x), + ylp = brms::log_lik(fit_bacc_x), + measure = "bacc" +) +m_b <- loo_pred_measure( + y = y, + mupred = brms::posterior_epred(fit_bacc_w), + ylp = brms::log_lik(fit_bacc_w), + measure = "bacc" +) + +comp_bacc <- model_compare(list(m_a = m_a, m_b = m_b)) +print(comp_bacc, measures = "all", digits = 3) +``` + +To compute the standard error we need to know which class each observation +belongs to. This information is stored in the `extra` slot of the +`measure_info` attribute of the model object: + +```{r bacc-extra} +str(attr(m_a, "measure_info")$bacc$extra) +``` + +Undoing the pointwise weighting recovers the 0/1 accuracies, after which the +class-wise variances can be computed as shown in the formula above: + +```{r pairwise-bacc} +class_id <- attr(m_a, "measure_info")$bacc$extra$class_id +n_c <- tabulate(class_id) +K <- length(n_c) + +d <- (m_b$pointwise[, "bacc_loo"] - m_a$pointwise[, "bacc_loo"]) * + (K * n_c[class_id]) + +var_c <- sapply(seq_len(K), function(k) var(d[class_id == k]) / n_c[k]) + +c(by_hand = sqrt(sum(var_c)) / K, + reported = comp_bacc$bacc_se_diff[comp_bacc$model == "m_b"]) +``` + +## Custom measures + +A custom measure is any function returning a list with `estimate`, `se`, and +`pointwise`. It carries two attributes: `measure_name`, its name, and +`measure_loss`, which declares whether lower values are better. It always gets +`diff_method = "custom"`, and the user needs to provide information about how to +compute the standard error of the difference via the `custom_se_fn` argument of +`model_compare()`. `custom_se_fn` accepts one of four 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 `custom_se_fn(ref, cmp)` | +| `NULL` | only the estimate is computed. SE is reported as `NA` | + +### 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) +} +attr(huber_fn, "measure_name") <- "huber" +attr(huber_fn, "measure_loss") <- TRUE +``` + +Furthermore, we provide the name of the measure (i.e., "huber") as an +attribute, and 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. + +::: {.callout .callout-warning} +A custom measure is by default considered to be a utility (i.e., higher values +are better). + +This can be changed by setting the `measure_loss` attribute of the +custom-measure function to `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" = huber_fn)) +h3 <- fit_measure(fit_m3, measure = list("rmse", "huber" = huber_fn)) +``` + +(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"`. + +```{r custom-diff-method} +str(attr(h1, "measure_info")) +``` + +Consequently, we need to provide information to `model_compare()` on how to +compute the standard error of the difference, which is done via the +`custom_se_fn` argument. The Huber estimate *is* the mean of its pointwise +values, so `custom_se_fn = "mean"` is the right declaration. + +```{r custom-mean-se} +comp_h <- model_compare(list(m3 = h3, m1 = h1), custom_se_fn = "mean") +print(comp_h, measures = "huber") +``` + +The same standard error can be spelled out as a function instead. +This is the more general form, and the one to reach for when the measure +needs a custom function for computing the standard error. +It is called as `custom_se_fn(ref, cmp)`, where each argument is a list +describing **one** model with elements `estimate`, `se`, `pointwise`, and +`extra`: + +```{r custom-fn-check} +huber_se_fn <- function(ref, cmp) { + d <- cmp$pointwise - ref$pointwise + sd(d) / sqrt(length(d)) +} + +comp_h_fn <- model_compare(list(m3 = h3, m1 = h1), custom_se_fn = huber_se_fn) +print(comp_h_fn, 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)) + ) +} +attr(nrmse_fn, "measure_name") <- "nrmse" +attr(nrmse_fn, "measure_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, c("rmse", "huber" = huber_fn, "nrmse" = nrmse_fn)) +n3 <- fit_measure(fit_m3, c("rmse", "huber" = huber_fn, "nrmse" = nrmse_fn)) +``` + +Additionally, we provide a custom function for computing the standard error +of the difference for the new custom measure: + +```{r custom-se-diff-fun} +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) + + # algebraically the same as the RMSE formula shown earlier, but 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 +} +``` + +Finally, we perform model comparison with multiple custom measures: + +```{r extend-example-fit} +comp_n <- model_compare( + list(m3 = n3, m1 = n1), + custom_se_fn = list("huber" = huber_se_fn, "nrmse" = nrmse_se_fn) +) +print(comp_n, measures = "all") +``` + +## Selecting the reference model + +Different measures do not have to agree on which model is best, and in the +[roaches comparison example](#running-example-count-data) they do not. +By default, for each measure the best model is used as reference model and +printed in the first row of the output. + +```{r disagree-ranking} +print( + model_compare(list(m1 = m1, m2 = m2, m3 = m3)), + measures = "all" +) +``` + +We see that for `elpd` and `mae` the third model (`m3`) is best, while for +the other measures the second model (`m2`) is best. + +We can change the reference model using the `rank_by` argument of +`model_compare()`. For example, if we want `m3` to be the reference model for +every measure, we use `rank_by = "m3"`. + +```{r diff-ref-model} +print( + model_compare(list(m1 = m1, m2 = m2, m3 = m3), rank_by = "m3"), + measures = "all" +) +``` + +Note that the ordering remains the same: the estimates are displayed in +decreasing order (best model first). + +It is also possible to select as reference model the best model according to a +specific measure. For example, suppose we want to use for all measures the same +reference model as the one used for `r2`: + +```{r diff-ref-measure} +print( + model_compare(list(m1 = m1, m2 = m2, m3 = m3), rank_by = "r2"), + measures = "all" +) +``` + +## 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 custom_se_fn: 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 + `attr(my_fun, "measure_loss") <- TRUE`, or its differences and its `rank_by` + ordering will come out reversed. + +## References + +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. doi:10.1002/sim.6432 + +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 + +Gelman, A., and Hill, J. (2007). *Data Analysis Using Regression and +Multilevel/Hierarchical Models*. Cambridge University Press. + +McNemar, Q. (1947). Note on the sampling error of the difference between +correlated proportions or percentages. *Psychometrika*, 12(2):153–157. +doi:10.1007/BF02295996 + +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. doi:10.1002/sim.906 + +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 + +Ver Hoef, J. M. (2012). Who invented the delta method? *The American +Statistician*, 66(2):124–127. doi:10.1080/00031305.2012.687494 + +## See also + +- [Computing predictive performance measures](pred-measure-workflow.html) — how + to produce the objects compared here. +- [Overview of scores and metrics](overview-measures.html) — definitions and + formulas for each measure. +- `?"loo-glossary"` — the `measure_info` attribute in full. diff --git a/vignettes/articles-online-only/overview-measures.Rmd b/vignettes/articles-online-only/overview-measures.Rmd index fae6d1a7..61543b47 100644 --- a/vignettes/articles-online-only/overview-measures.Rmd +++ b/vignettes/articles-online-only/overview-measures.Rmd @@ -9,7 +9,7 @@ output: params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") vignette: > - %\VignetteIndexEntry{overview-measures} + %\VignetteIndexEntry{Overview of scores and metrics} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- diff --git a/vignettes/articles-online-only/pred-measure-workflow.Rmd b/vignettes/articles-online-only/pred-measure-workflow.Rmd index d4cdd394..6b9b19c7 100644 --- a/vignettes/articles-online-only/pred-measure-workflow.Rmd +++ b/vignettes/articles-online-only/pred-measure-workflow.Rmd @@ -8,7 +8,7 @@ output: params: EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") vignette: > - %\VignetteIndexEntry{pred-measure-workflow} + %\VignetteIndexEntry{Computing predictive performance measures} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- @@ -322,7 +322,7 @@ through `control`: ```{r} # custom scoring rule -hamming_loss <- function(y, ypred, log_weights = NULL, higher_is_better = NULL) { +hamming_loss <- function(y, ypred, log_weights = NULL) { if (is.null(log_weights)) { hamming_i <- colMeans(sweep(ypred, 2, y, "!=")) } else { @@ -330,20 +330,17 @@ hamming_loss <- function(y, ypred, log_weights = NULL, higher_is_better = NULL) w <- exp(lw) hamming_i <- colSums(w * sweep(ypred, 2, y, "!=")) } - - res <- list( + + list( estimate = mean(hamming_i), se = sqrt(var(hamming_i) / length(hamming_i)), pointwise = hamming_i ) - - # Hamming loss is naturally on a loss scale (lower is better). - if (isTRUE(higher_is_better)) { - res$estimate <- -res$estimate - res$pointwise <- -res$pointwise - } - res } +# Hamming loss is on a loss scale (lower is better). Declaring that lets +# `model_compare()` report its differences on the utility scale, as it does for +# built-in loss measures, and rank models in the right direction. +attr(hamming_loss, "measure_loss") <- TRUE ``` ```{r insample-custom-function} 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/loo2-elpd.Rmd b/vignettes/loo2-elpd.Rmd index cd205d49..df37f9e6 100644 --- a/vignettes/loo2-elpd.Rmd +++ b/vignettes/loo2-elpd.Rmd @@ -148,7 +148,7 @@ Now we evaluate the predictive performance of the model on the test data using ` (elpd_holdout <- elpd(log_pd)) ``` -When one wants to compare different models, the function `loo_compare()` can be used to assess the difference in performance. +When one wants to compare different models, the function `model_compare()` can be used to assess the difference in performance. # K-fold cross validation @@ -205,7 +205,7 @@ Now we evaluate the predictive performance of the model on the 10 folds using `e (elpd_kfold <- elpd(log_pd_kfold)) ``` -If one wants to compare several models (with `loo_compare`), one should use the same folds for all the different models. +If one wants to compare several models (with `model_compare`), one should use the same folds for all the different models. # References diff --git a/vignettes/loo2-example.Rmd b/vignettes/loo2-example.Rmd index 2a5037a7..44a6000d 100644 --- a/vignettes/loo2-example.Rmd +++ b/vignettes/loo2-example.Rmd @@ -263,11 +263,11 @@ the data. ## Comparing the models on expected log predictive density -We can use the `loo_compare` function to compare our two models on +We can use the `model_compare` function to compare our two models on expected log predictive density (ELPD) for new data: -```{r loo_compare} -loo_compare(loo1, loo2) +```{r model_compare} +model_compare(loo1, loo2) ``` The difference in ELPD is much larger than several times the estimated standard diff --git a/vignettes/loo2-large-data.Rmd b/vignettes/loo2-large-data.Rmd index fbaa5827..b7180c9d 100644 --- a/vignettes/loo2-large-data.Rmd +++ b/vignettes/loo2-large-data.Rmd @@ -398,7 +398,7 @@ The object created is of class `psis_loo_ss`, which inherits from the ## Comparing models To compare this model to an alternative model for the same data we can use the -`loo_compare()` function just as we would if using `loo()` instead of +`model_compare()` function just as we would if using `loo()` instead of `loo_subsample()` or `loo_approximate_posterior()`. First we'll fit a second model to the well-switching data, using `log(arsenic)` instead of `arsenic` as a predictor: @@ -470,11 +470,11 @@ All Pareto k estimates are good (k < 0.7). See help('pareto-k-diagnostic') for details. ``` -We can now compare the models on LOO using the `loo_compare` function: +We can now compare the models on LOO using the `model_compare` function: ```{r, eval=FALSE} # Compare -comp <- loo_compare(loo_ss_1, loo_ss_2) +comp <- model_compare(loo_ss_1, loo_ss_2) print(comp) ``` @@ -537,7 +537,7 @@ We can now compare the models and estimate the difference based on the same subsampled observations. ```{r, eval=FALSE} -comp <- loo_compare(loo_ss_1, loo_ss_2) +comp <- model_compare(loo_ss_1, loo_ss_2) print(comp) ``` @@ -567,7 +567,7 @@ loo_full_2 <- loo( data = stan_df_2, cores = 2 ) -loo_compare(loo_ss_1, loo_full_2) +model_compare(loo_ss_1, loo_full_2) ``` ``` diff --git a/vignettes/loo2-with-rstan.Rmd b/vignettes/loo2-with-rstan.Rmd index 9c1fcd05..5089b1b6 100644 --- a/vignettes/loo2-with-rstan.Rmd +++ b/vignettes/loo2-with-rstan.Rmd @@ -168,7 +168,7 @@ all of the estimates for $k$ are fine. ## Comparing models To compare this model to an alternative model for the same data we can use the -`loo_compare` function in the **loo** package. First we'll fit a second model to the +`model_compare` function in the **loo** package. First we'll fit a second model to the well-switching data, using `log(arsenic)` instead of `arsenic` as a predictor: ```{r, eval=FALSE} @@ -196,11 +196,11 @@ All Pareto k estimates are good (k < 0.7). See help('pareto-k-diagnostic') for details. ``` -We can now compare the models on LOO using the `loo_compare` function: +We can now compare the models on LOO using the `model_compare` function: ```{r, eval=FALSE} # Compare -comp <- loo_compare(loo_1, loo_2) +comp <- model_compare(loo_1, loo_2) ``` This new object, `comp`, contains the estimated difference of expected diff --git a/vignettes/migration-guide.Rmd b/vignettes/migration-guide.Rmd index b53c3ae4..a25c3ae3 100644 --- a/vignettes/migration-guide.Rmd +++ b/vignettes/migration-guide.Rmd @@ -54,9 +54,10 @@ branch and will extend this guide when merged into `loo-v3.0.0`. | `R/pred_measure-compute.R` | **Current** | Internal orchestration | | `R/pred_measure-helpers.R` | **Current** | Validation and helpers | | `R/pred_measure-builtin.R` | **Current** | `measure_*()` implementations | -| `R/compare.R` | Deprecated (removal in 3.0.0) | `loo_compare()` in `R/loo_compare.R` | +| `R/compare.R` | Deprecated (removal in 3.0.0) | `model_compare()` in `R/model_compare.R` | | `R/psislw.R` | Deprecated (removal in 3.0.0) | `psis()` in `R/psis.R` (since 2.0.0) | -| `R/loo_compare.R` | **Current** | Model comparison | +| `R/loo_compare.R` | Deprecated | `model_compare()` in `R/model_compare.R` | +| `R/model_compare.R` | **Current** | Model comparison | | `R/loo.R`, `R/psis.R`, `R/waic.R` | **Current** | Core LOO / PSIS / WAIC | --- @@ -168,18 +169,47 @@ supported_measures_list() | Deprecated | Replacement | Since | Planned removal | |------------|-------------|-------|-----------------| -| `compare()` | `loo_compare()` | 2.0.0 | 3.0.0 | +| `compare()` | `model_compare()` | 2.0.0 | 3.0.0 | +| `loo_compare()` | `model_compare()` | 3.0.0 | TBD | `compare()` returns a vector or matrix with class `"compare.loo"`. -`loo_compare()` returns a `data.frame` with additional diagnostic columns. -See `?loo_compare` for the current output format. +`model_compare()` returns a `data.frame` with additional diagnostic columns. +See `?model_compare` for the current output format. ```r # Deprecated compare(loo1, loo2) # Current +model_compare(loo1, loo2) +``` + +### `loo_compare()` is now `model_compare()` + +`loo_compare()` has been renamed to `model_compare()`, which better reflects +that it compares models evaluated by leave-one-out CV, k-fold CV, a held-out +test set, or in-sample scores. + +`loo_compare()` is **deprecated** but still works, and is still an exported +generic, so `loo_compare` methods registered by other packages (for example +`loo_compare.brmsfit` in **brms** and `loo_compare.stanreg` in **rstanarm**) +keep dispatching. It is frozen at its previous behavior: it compares `"loo"`, +`"waic"`, and `"kfold"` objects on ELPD only, and returns exactly what +`model_compare()` returns for those inputs. Everything added in 3.0.0 --- the +`pred_measure` sources, `rank_by`, and `custom_se_fn` --- 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, rank_by = "rmse") ``` ## PSIS importance sampling