diff --git a/.gitignore b/.gitignore index f0f29c32..dbd669d2 100644 --- a/.gitignore +++ b/.gitignore @@ -30,3 +30,5 @@ release-prep.R # personal maintainer scratch (not shared) internal-notes/ +notes/loo_se.pdf +notes/loo-compare-se-diff.md \ No newline at end of file diff --git a/NAMESPACE b/NAMESPACE index 7655e0df..c10d5b50 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -47,6 +47,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) @@ -159,6 +161,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 78be699d..3c7c8dda 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,6 +7,74 @@ * 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()]. +* `loo_compare()` is now called `model_compare()`. `loo_compare()` remains a + working alias and is still a generic, so existing code and methods registered + by other packages keep working. +* `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. +* 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 new `compare_ref_model` 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_compare_meta`, 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_compare_meta` + attribute, and models that disagree on it cannot be compared. +* `control` entries now work for custom measures instead of failing with + `object 'measure_' of mode 'function' was not found`. `higher_is_better` + is accepted for any measure, built-in or custom, and selects the scale its + values are stored on. 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. # loo 2.10.0 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/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..236fb1c0 100644 --- a/R/loo-glossary.R +++ b/R/loo-glossary.R @@ -161,7 +161,7 @@ #' #' p_worse = pnorm(0, elpd_diff, se_diff). #' -#' The best-ranked model (the first row in the `loo_compare()` output, where +#' The best-ranked model (the first row in the `model_compare()` output, where #' `elpd_diff = 0`) always receives `NA`, since the comparison is defined #' relative to that model. #' @@ -176,7 +176,7 @@ #' 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()` +#' present, `diag_diff` or `diag_elpd` will be flagged in the `model_compare()` #' output. #' For further guidance, see the sections below and the case study on #' [Uncertainty in Bayesian LOO-CV Model Comparison]( @@ -184,7 +184,7 @@ #' #' @section `diag_diff` (pairwise comparison diagnostics): #' -#' `diag_diff` is a diagnostic column in the `loo_compare()` output for each +#' `diag_diff` is a diagnostic column in the `model_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 @@ -210,7 +210,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 +#' `model_compare()` therefore follows a priority hierarchy and shows only the #' most critical flag in the table output. #' #' The hierarchy is as follows: @@ -233,7 +233,7 @@ #' #' @section `diag_elpd`: #' -#' `diag_elpd` is a diagnostic column in the `loo_compare()` output that flags +#' `diag_elpd` is a diagnostic column in the `model_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. @@ -254,4 +254,125 @@ #' #' See for further information on Pareto-k values the "Pareto k estimates" #' section. +#' +#' @section Multi-measure model comparisons: +#' +#' 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. +#' Attribute `measure_higher_is_better` on each `*_pred_measure()` +#' result records the `higher_is_better` setting used when each measure was +#' computed; when stored values are on a loss 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_higher_is_better` +#' +#' Attribute on all `*_pred_measure()` and [pred_measure()] results: a named +#' list recording the `higher_is_better` setting used for each measure (`TRUE` +#' or `FALSE`). Measures left at their natural orientation have no entry, which +#' reads as `NULL`; `elpd` is always `NULL`. Used by [model_compare()] with +#' `measure_compare_meta` to decide whether paired differences need a sign flip +#' when converting to a utility scale. +#' +#' ### `measure_compare_meta` +#' +#' Attribute on all `*_pred_measure()` and [pred_measure()] results: a named +#' list of per-measure comparison metadata used by [model_compare()]. Each entry +#' is a list with: +#' +#' * `higher_is_better` — the orientation setting used when the measure was +#' computed (`NULL`, `TRUE`, or `FALSE`), that is, which scale the values were +#' stored on +#' * `loss` — whether the measure itself is a loss (lower is better), regardless +#' of the scale its values are stored on +#' * `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 — the difference itself is still reported. +#' `"estimates_only"` appears only for legacy objects that carry no +#' comparison metadata at all. +#' * `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 metadata consistency check below, +#' since it varies with the data rather than with how the measure was +#' configured. +#' +#' 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 metadata for each +#' shared measure; mismatched `higher_is_better` or `measure_loss` settings, or +#' missing metadata on some models, produce 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` is +#' set only when `rank_by` names a measure, and attribute `compare_ref_model` +#' only when it names a model. 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..2eaad893 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 #' 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 ce5bea4a..07694a3e 100644 --- a/R/loo_compare.R +++ b/R/loo_compare.R @@ -1,440 +1,48 @@ -#' Model comparison +#' Model comparison (previous name) #' -#' @description Compare fitted models based on [ELPD][loo-glossary]. +#' @description +#' `loo_compare()` is the previous name of [model_compare()] and is kept as a +#' working alias. It is a generic so that packages registering their own +#' `loo_compare` methods keep dispatching as before; the default method simply +#' forwards to [model_compare()]. #' -#' @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**. -#' @param ... Additional objects of class `"loo"`, if not passed in as a single -#' list. -#' -#' @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. +#' New code should call [model_compare()], which additionally compares +#' [`kfold_pred_measure()`][kfold_pred_measure], +#' [`test_pred_measure()`][test_pred_measure], and +#' [`insample_pred_measure()`][insample_pred_measure] results. #' -#' ## `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. +#' @export +#' @inheritParams model_compare +#' @return See [model_compare()]. #' -#' @seealso -#' * The [FAQ page](https://mc-stan.org/loo/articles/online-only/faq.html) on -#' the __loo__ website for answers to frequently asked questions. -#' @template loo-and-compare-references +#' @seealso [model_compare()] #' #' @examples -#' # very artificial example, just for demonstration! #' LL <- example_loglik_array() -#' loo1 <- loo(LL) # should be worst model when compared -#' loo2 <- loo(LL + 1) # should be second best model when compared -#' loo3 <- loo(LL + 2) # should be best model when compared +#' loo1 <- loo(LL) +#' loo2 <- loo(LL + 1) #' -#' comp <- loo_compare(loo1, loo2, loo3) -#' print(comp, digits = 2) +#' # identical to model_compare(loo1, loo2) +#' loo_compare(loo1, loo2) #' -#' # can use a list of objects with custom names -#' # the names will be used in the output -#' loo_compare(list("apple" = loo1, "banana" = loo2, "cherry" = loo3)) -#' -#' \dontrun{ -#' # works for waic (and kfold) too -#' loo_compare(waic(LL), waic(LL - 10)) -#' } -#' -loo_compare <- function(x, ...) { +loo_compare <- function(x, ..., rank_by = NULL, custom_se_fn) { UseMethod("loo_compare") } #' @rdname loo_compare #' @export -loo_compare.default <- function(x, ...) { - if (is.loo(x)) { - dots <- list(...) - loos <- c(list(x), dots) +loo_compare.default <- function(x, ..., rank_by = NULL, custom_se_fn) { + # Forward `custom_se_fn` only when it was actually supplied, so that + # `model_compare()` can still tell an omitted argument from an explicit NULL. + if (missing(custom_se_fn)) { + model_compare(x, ..., rank_by = rank_by) } 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 + model_compare(x, ..., rank_by = rank_by, custom_se_fn = custom_se_fn) } - - # if subsampling is used - if (any(sapply(loos, inherits, "psis_loo_ss"))) { - return(loo_compare.psis_loo_ss_list(loos)) - } - - # run pre-comparison checks - loo_compare_checks(loos) - - # compute elpd_diff and se_elpd_diff relative to best model - comp <- loo_compare_matrix(loos) - ord <- loo_compare_order(loos) - rnms <- rownames(comp) - diffs <- mapply(FUN = elpd_diffs, loos[ord[1]], loos[ord]) - colnames(diffs) <- rnms - elpd_diff <- apply(diffs, 2, sum) - se_diff <- apply(diffs, 2, se_elpd_diff) - - # compute probabilities that a model has worse elpd than the best model - # using a normal approximation (Sivula et al., 2025) - p_worse <- stats::pnorm(0, elpd_diff, se_diff) - p_worse[elpd_diff == 0] <- NA - - comp <- cbind( - data.frame( - model = rnms, - elpd_diff = elpd_diff, - se_diff = se_diff, - p_worse = p_worse, - diag_diff = diag_diff(nrow(diffs), elpd_diff), - diag_elpd = diag_elpd(loos[ord]) - ), - as.data.frame(comp) - ) - rownames(comp) <- NULL - - # run order statistics-based checks for many model comparisons - loo_order_stat_check(loos, ord) - - class(comp) <- c("compare.loo", class(comp)) - comp } #' @rdname loo_compare #' @export -#' @param digits For the print method only, the number of digits to use when -#' printing. -#' @param p_worse For the print method only, should we include the normal -#' approximation based probability of each model having worse performance than -#' the best model? The default is `TRUE`. -print.compare.loo <- function(x, ..., digits = 1, p_worse = 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) - } - x2 <- cbind( - model = x$model, - .fr(x[, c("elpd_diff", "se_diff")], digits) - ) - if (p_worse && "p_worse" %in% colnames(x)) { - x2 <- cbind( - x2, - p_worse = .fr(x[, "p_worse"], digits = 2), - diag_diff = x[, "diag_diff"], - diag_elpd = x[, "diag_elpd"] - ) - } - print(x2, quote = FALSE, row.names = FALSE) - - # show glossary for diagnostic flags - has_diag <- any(nzchar(x[["diag_diff"]], keepNA = FALSE), na.rm = TRUE) || - any(nzchar(x[["diag_elpd"]], keepNA = FALSE), na.rm = TRUE) - if (has_diag && p_worse) { - message( - "\nDiagnostic flags present.\n", - "See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`)\n", - "or https://mc-stan.org/loo/reference/loo-glossary.html." - ) - } - invisible(x) -} - - -# internal ---------------------------------------------------------------- - -#' Compute pointwise elpd differences -#' @noRd -#' @param loo_a,loo_b Two `"loo"` objects. -elpd_diffs <- function(loo_a, loo_b) { - pt_a <- loo_a$pointwise - pt_b <- loo_b$pointwise - elpd <- grep("^elpd", colnames(pt_a)) - pt_b[, elpd] - pt_a[, elpd] -} - -#' 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])) { - 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 <- 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) - } -} - - -#' 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 -} - - -#' 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, ...) { + model_compare.psis_loo_ss_list(x, ...) } diff --git a/R/loo_subsample.R b/R/loo_subsample.R index bcac4b17..28f45796 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()], [model_compare()] #' @template loo-large-data-references #' #' @export loo_subsample loo_subsample.function diff --git a/R/model_compare.R b/R/model_compare.R new file mode 100644 index 00000000..45a9504a --- /dev/null +++ b/R/model_compare.R @@ -0,0 +1,1945 @@ +#' Model comparison +#' +#' @description Compare fitted models based on [ELPD][loo-glossary] or, for +#' [`pred_measure`][pred_measure] results, multiple 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: every input must +#' come from the same `*_pred_measure()` function, since paired differences +#' between, say, a LOO and a k-fold result would contrast held-out schemes +#' rather than models. Mixed inputs are an error. +#' +#' @export +#' @param x An object of class `"loo"` or `"pred_measure"`, 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**. +#' @param ... Additional objects of class `"loo"` or `"pred_measure"`, if not +#' passed in as a single list. +#' @param rank_by A single string naming either a **measure** or a **model**, +#' used to define one reference model for all pairwise differences. +#' +#' A **measure name** ([`pred_measure`][pred_measure] comparisons only) ranks +#' models by that measure and makes the top-ranked model the reference. Bare +#' names are used regardless of source, so `rank_by = "rmse"` selects +#' `rmse_loo`, `rmse_kfold`, or `rmse_test` as appropriate. For example, +#' `rank_by = "mse"` ranks models by predictive MSE (best/lowest MSE first) +#' and computes *all* measure differences relative to that one model on a +#' utility scale (higher is better; loss measures such as MSE have their sign +#' flipped). +#' +#' A **model name** (one of the names shown in the `model` column, i.e. the +#' list names or `model1`, `model2`, ...) pins that model as the reference for +#' all differences, whichever model performs best. Rows stay ordered by +#' `"elpd"`. This form also works for plain `"loo"` comparisons, where +#' `elpd_diff` is then relative to the named model rather than to the best +#' one. If a name matches both a measure and a model, the measure wins and a +#' warning is issued. +#' +#' When `rank_by` is `NULL` (the default), rows are ordered by `"elpd"` but +#' each measure is compared against *its own* best model, so `mse_diff` may be +#' relative to a different model 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. +#' } +#' When two or more custom measures are compared, 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 `higher_is_better`. 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 with class `"compare.loo"` that has its own +#' print method. See the **Details** and **Examples** sections. +#' +#' For classic `"loo"` / `"waic"` / `"kfold"` comparisons, the returned +#' columns are unchanged from previous versions. +#' +#' For [`pred_measure`][pred_measure] comparisons, the data frame +#' additionally contains `{measure}_diff` and `{measure}_se_diff` columns for +#' every predictive measure common to all models (e.g. `rmse_diff`, +#' `rmse_se_diff`). ELPD-family measures use `elpd_diff` and `se_diff`. +#' `p_worse` and `diag_diff` are computed for ELPD only. `diag_elpd` holds +#' per-model PSIS diagnostics and is present only for +#' [`loo_pred_measure()`][loo_pred_measure] comparisons, the only source with +#' Pareto \eqn{\hat{k}} values. Attributes `compare_measures` and +#' `sign_converted_measures` record which measures were compared and which +#' loss measures had their sign flipped for comparison. Attribute +#' `compare_source` records the shared evaluation source (`"loo"`, +#' `"kfold"`, `"test"`, or `"insample"`). Attribute `rank_by` is +#' set when `rank_by` named a measure (default ranking is by `"elpd"`), and +#' attribute `compare_ref_model` is set when it named a model. +#' Attribute `compare_reference` is a named character vector giving the +#' reference model each measure's differences were computed against; all +#' entries are that single reference model when `rank_by` was supplied. +#' +#' @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 `model_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. +#' +#' ## Comparing `pred_measure` objects +#' When all inputs are predictive measure results sharing one evaluation +#' source, +#' `model_compare()` computes paired differences for every predictive 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. Rows are ordered by `rank_by` (default `"elpd"`). +#' By default each measure is compared against the model that is best on that +#' measure, so `mse_diff` can use a different reference model than +#' `elpd_diff`; the reference used for each measure is recorded in attribute +#' `compare_reference` and shown by `print(x, measures = "all")`. Supplying +#' `rank_by` instead pins a single reference --- the top-ranked model --- for +#' every `{measure}_diff` column. The returned 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 is always the first row +#' and the differences run in decreasing order. +#' Measures may use different orientations in their raw form (e.g. ELPD and +#' CRPS/RPS are returned on a utility scale where higher is better, while MSE +#' and Brier score are loss measures where lower is better). For comparison, +#' all `{measure}_diff` values are reported on a common utility scale (higher +#' is better). Loss measures have their sign flipped from the raw loss +#' orientation so that negative `{measure}_diff` values indicate worse +#' performance than the reference model. Each `*_pred_measure()` result stores +#' attribute `measure_higher_is_better`, a named list recording the +#' `higher_is_better` setting used when each measure was computed. When loss measures are compared +#' on a utility scale, `model_compare()` emits a short message naming the affected +#' measures, 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()]. +#' +#' `p_worse` and `diag_diff` are computed for ELPD-family measures only. Other +#' measures receive `{measure}_diff` and `{measure}_se_diff` from paired +#' pointwise contributions when the overall estimate is a sum or mean of those +#' contributions (using the same standard error formula as `se_diff`). For +#' measures where pointwise values do not define the overall estimate (e.g. +#' `r2`, `mse`, `rmse`), `{measure}_diff` is the difference between overall +#' estimates and `{measure}_se_diff` is `NA`. When models were fit with +#' different `measure` sets, only measures common to all models are compared; a +#' warning lists omitted measures. Use `print(x, measures = "all")` to display +#' diff tables for every compared measure; see [loo-glossary] for column +#' definitions. +#' +#' ## Source-specific behavior +#' Comparisons behave the same way across sources, with three exceptions: +#' +#' * **`diag_elpd`** is only produced 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 +#' `loo_pred_measure` comparisons) 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 +#' +#' @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) { + 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) + + if (!is.null(ref_model)) { + attr(comp, "compare_ref_model") <- ref_model + } + class(comp) <- c("compare.loo", class(comp)) + comp +} + +#' @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 best model? The default is `TRUE`. +#' @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, 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, + measures = measures + )) + } + + if (!all(c("model", "elpd_diff", "se_diff") %in% colnames(x))) { + print(as.data.frame(x)) + return(x) + } + x2 <- cbind( + model = x$model, + .fr(x[, c("elpd_diff", "se_diff")], digits) + ) + if (p_worse && "p_worse" %in% colnames(x)) { + x2 <- cbind( + x2, + p_worse = .fr(x[, "p_worse"], digits = 2), + diag_diff = x[, "diag_diff"], + diag_elpd = x[, "diag_elpd"] + ) + } + print(x2, quote = FALSE, row.names = FALSE) + + ref_model_attr <- attr(x, "compare_ref_model") + if (!is.null(ref_model_attr)) { + message("Differences computed against model ", ref_model_attr, ".") + } + .print_compare_diag_message(x, p_worse = p_worse) + invisible(x) +} + + +# internal ---------------------------------------------------------------- + +#' Print `compare.loo` results from `pred_measure` comparisons +#' @noRd +.print_compare_pred_measure <- function(x, digits, p_worse, measures) { + rank_by <- attr(x, "rank_by") + ref_model_attr <- attr(x, "compare_ref_model") + compare_measures <- attr(x, "compare_measures") + compare_source <- attr(x, "compare_source") + primary_measure <- if (is.null(rank_by)) "elpd" else rank_by + ref_model <- .compare_ref_model(x, primary_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(...)`." + ) + } + + if (is.null(measures) && !is.null(rank_by)) { + message( + "Models ranked by ", rank_by, " (reference: ", ref_model, ")." + ) + } else if (is.null(measures) && !is.null(ref_model_attr)) { + message( + "All measures compared against model ", ref_model_attr, "." + ) + } + + # LOO is the familiar default, so only name the source when it is not LOO. + if (!is.null(compare_source) && !identical(compare_source, "loo")) { + cat( + "Predictive measures evaluated on ", + .compare_source_label(compare_source), + ".\n", + sep = "" + ) + } + + show_diag_elpd_primary <- is.null(measures) || identical(measures, "all") + for (i in seq_along(measures_to_print)) { + measure <- measures_to_print[[i]] + if (!is.null(measures)) { + cat( + "\n-- ", measure, " (vs ", .compare_ref_model(x, measure), ") --\n", + sep = "" + ) + } + .print_compare_measure_table( + x, + measure = measure, + digits = digits, + p_worse = p_worse, + show_diag_elpd = show_diag_elpd_primary && + identical(measure, primary_measure) && + i == match(primary_measure, measures_to_print) + ) + } + + 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)) { + # Worth naming only when a measure actually prefers a different model: + # otherwise the per-measure reference is invisible to the user. + other_refs <- vapply(other, .compare_ref_model, character(1), x = x) + differing <- is.null(rank_by) && is.null(ref_model_attr) && + any(other_refs != ref_model) + message( + if (has_diag_msg) "\n", + "Other measures compared: ", + paste(other, collapse = ", "), + ".", + if (differing) { + paste0( + " Each is compared against its own best model (", + paste0( + other[other_refs != ref_model], ": ", + other_refs[other_refs != ref_model], + collapse = ", " + ), + ")." + ) + }, + " Use print(x, measures = \"all\")." + ) + } + } + + invisible(x) +} + +#' 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 +.compare_ref_model <- function(x, measure) { + refs <- attr(x, "compare_reference") + if (!is.null(refs) && measure %in% names(refs)) { + return(refs[[measure]]) + } + x$model[[1L]] +} + +#' Print one measure's comparison table +#' @noRd +.print_compare_measure_table <- function(x, measure, digits, p_worse, show_diag_elpd) { + 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] + } + if (show_diag_elpd && "diag_elpd" %in% colnames(x)) { + x2$diag_elpd <- x[["diag_elpd"]][ord] + } + + 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) +} + +#' 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 +.warn_insample_compare <- 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) +} + +#' Warn when k-fold results do not share the same number of folds +#' @noRd +#' @param loos List of `"kfold"` or `"kfold_pred_measure"` objects. +.warn_kfold_K_mismatch <- 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) +} + +#' 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 +} + +#' 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 + ) + .warn_insample_compare(source) + if (identical(source, "kfold")) { + .warn_kfold_K_mismatch(loos) + } + .compare_metadata_check(loos) + .warn_omitted_compare_measures(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 + ) + + if (identical(rank_spec$kind, "measure")) { + attr(comp, "rank_by") <- rank_measure$bare + } else if (identical(rank_spec$kind, "model")) { + attr(comp, "compare_ref_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 +} + +#' 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) +} + +#' 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 comparison metadata 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) { + metas <- lapply(loos, function(x) { + compare_meta <- attr(x, "measure_compare_meta") + if (is.null(compare_meta)) { + return(NULL) + } + compare_meta[[bare]] + }) + has_meta <- !vapply(metas, is.null, logical(1)) + if (any(has_meta) && !all(has_meta)) { + stop( + "Not all models provide comparison metadata 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 + # `higher_is_better` disagreement. + non_null <- lapply(metas[has_meta], function(meta) { + meta$extra <- NULL + meta + }) + if (length(non_null) > 1L) { + ref <- non_null[[1L]] + inconsistent <- vapply( + non_null[-1L], + function(meta) !identical(meta, ref), + logical(1) + ) + if (any(inconsistent)) { + stop( + "Models disagree on comparison metadata for measure '", + bare, + "'. Ensure all models use the same `higher_is_better` settings for ", + "each measure, and for a custom measure the same `measure_loss` ", + "declaration.", + call. = FALSE + ) + } + } + } + + invisible(NULL) +} + +#' Warn when models do not share the same predictive measures +#' @noRd +.warn_omitted_compare_measures <- 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 per-measure comparison metadata on a result object +#' @noRd +.get_measure_compare_meta <- function(loos, bare) { + compare_meta <- attr(loos[[1L]], "measure_compare_meta") + if (is.null(compare_meta)) { + return(NULL) + } + compare_meta[[bare]] +} + +#' Whether a measure is intrinsically a loss (natural scale: lower is better) +#' +#' Unlike `.measure_lower_is_better()` this ignores `higher_is_better`, so it +#' describes the measure itself rather than the scale its values are stored on. +#' @noRd +.measure_is_loss <- function(name, loos = NULL) { + bare <- .display_name(name, loos) + + if (!is.null(loos)) { + meta <- .get_measure_compare_meta(loos, bare) + if (!is.null(meta) && !is.null(meta$loss)) { + return(isTRUE(meta$loss)) + } + } + + spec <- .measure_spec[[bare]] + if (!is.null(spec)) { + return(isTRUE(spec$loss)) + } + bare %in% c("ic", "mae", "mse", "rmse", "brier", "srps") +} + +#' Whether stored values are on a loss scale (lower is better) +#' @noRd +.measure_lower_is_better <- function(name, loos = NULL) { + bare <- .display_name(name, loos) + higher_is_better <- NULL + + if (!is.null(loos)) { + meta <- .get_measure_compare_meta(loos, bare) + if (!is.null(meta)) { + higher_is_better <- meta$higher_is_better + } else { + hib_attr <- attr(loos[[1L]], "measure_higher_is_better") + if (!is.null(hib_attr) && bare %in% names(hib_attr)) { + higher_is_better <- hib_attr[[bare]] + } + } + } + + if (!is.null(higher_is_better)) { + return(!isTRUE(higher_is_better)) + } + + .measure_is_loss(name, loos) +} + +#' Sign converting stored measure values to the measure's natural scale +#' +#' `higher_is_better` may have negated the stored values (see +#' `.create_measure_structure()`). Delta-method standard errors are derived on +#' the natural scale (e.g. RMSE positive), so they must be undone first. +#' @noRd +.measure_natural_sign <- function(name, loos = NULL) { + stored_lower_is_better <- .measure_lower_is_better(name, loos) + if (identical(stored_lower_is_better, .measure_is_loss(name, loos))) 1 else -1 +} + +#' 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_lower_is_better(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 comparison metadata: `"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. `"estimates_only"` is only reached by legacy objects +#' carrying no comparison metadata at all. +#' @noRd +.measure_pointwise_diff_method <- function(loos, col) { + bare <- .display_name(col, loos) + meta <- .get_measure_compare_meta(loos, bare) + if (!is.null(meta) && !is.null(meta$diff_method)) { + return(meta$diff_method) + } + + if (.is_elpd_measure(col) || bare == "ic") { + return("sum") + } + + "estimates_only" +} + +#' 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) + meta <- .get_measure_compare_meta(loos, bare) + + fun <- meta$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`, including `extra`, which is +#' read from that model's own comparison metadata rather than the reference +#' model's. +#' @noRd +#' @param sgn Sign restoring the measure's natural scale, see +#' `.measure_natural_sign()`. +.se_diff_input <- function(x, col, sgn) { + list( + estimate = sgn * x$estimates[col, "Estimate"], + se = x$estimates[col, "SE"], + pointwise = sgn * x$pointwise[, col, drop = TRUE], + extra = .get_measure_compare_meta(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_lower_is_better(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_)) + } + sgn <- .measure_natural_sign(col, loos) + se <- se_fn( + ref = .se_diff_input(ref, col, sgn), + cmp = .se_diff_input(cmp, col, sgn) + ) + return(c( + diff = diff, + se = .validate_se_diff(se, col, loos, what = "custom_se_fn") + )) + } + } + + if (method == "estimates_only") { + return(c( + diff = est_utility(cmp$estimates) - est_utility(ref$estimates), + se = NA_real_ + )) + } + + if (method == "measure_specific") { + se_diff_fun <- .measure_se_diff_fun(loos, col) + sgn <- .measure_natural_sign(col, loos) + se <- se_diff_fun( + ref = .se_diff_input(ref, col, sgn), + cmp = .se_diff_input(cmp, col, sgn) + ) + 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) +} + +#' 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. +#' @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. +#' @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 +) { + ## 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) nrow(x$pointwise), 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)))) { + 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(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) { + sapply(loos, function(x) { + est <- x$estimates + rows <- if (bare_names) .display_name(rownames(est), loos) else rownames(est) + setNames(c(est), nm = c(rows, paste0("se_", rows))) + }) +} + +#' 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) { + tmp <- .model_compare_estimates_table(loos, bare_names = bare_names) + 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 { + 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_lower_is_better(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)) + diag_diff[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 82% rename from R/loo_compare.psis_loo_ss_list.R rename to R/model_compare.psis_loo_ss_list.R index 5ef5f202..4bec15bd 100644 --- a/R/loo_compare.psis_loo_ss_list.R +++ b/R/model_compare.psis_loo_ss_list.R @@ -2,27 +2,36 @@ #' @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. #' @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) + model_compare_checks.psis_loo_ss_list(x) - comp <- loo_compare_matrix.psis_loo_ss_list(x) - ord <- loo_compare_order(x) + comp <- model_compare_matrix.psis_loo_ss_list(x) + 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 +45,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 +61,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 +74,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 +108,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") @@ -125,16 +134,16 @@ 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 +#' @details Similar to `model_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()`. +#' Can probably be removed by refactoring `model_compare_checks()`. #' @noRd -#' @inheritParams loo_compare_ss +#' @inheritParams model_compare_ss #' @return A 1 by 3 elpd_diff estimation. -loo_compare_checks.psis_loo_ss_list <- function(loos) { +model_compare_checks.psis_loo_ss_list <- function(loos) { ## errors if (length(loos) <= 1L) { - stop("'loo_compare' requires at least two models.", call.=FALSE) + stop("At least two models are required for comparison.", call. = FALSE) } if (!all(sapply(loos, is.loo))) { stop("All inputs should have class 'loo'.", call.=FALSE) @@ -171,7 +180,7 @@ loo_compare_checks.psis_loo_ss_list <- function(loos) { } } -#' @rdname loo_compare +#' @rdname model_compare #' @export print.compare.loo_ss <- function(x, ..., digits = 1) { xcopy <- x @@ -188,7 +197,7 @@ print.compare.loo_ss <- function(x, ..., digits = 1) { #' @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){ +model_compare_matrix.psis_loo_ss_list <- function(loos){ tmp <- sapply(loos, function(x) { est <- x$estimates setNames(c(est), nm = c(rownames(est), @@ -198,7 +207,7 @@ loo_compare_matrix.psis_loo_ss_list <- function(loos){ colnames(tmp) <- find_model_names(loos) rnms <- rownames(tmp) comp <- tmp - ord <- loo_compare_order(loos) + ord <- model_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))), diff --git a/R/pred_measure-builtin.R b/R/pred_measure-builtin.R index fda28a32..0283fd1e 100644 --- a/R/pred_measure-builtin.R +++ b/R/pred_measure-builtin.R @@ -443,14 +443,25 @@ measure_bacc <- function( acc_i <- (mupred_hat == y) * 1L } + # recomputed rather than reused from the branch above, which the + # precomputed-`pointwise` branch never enters + classes <- sort(unique(y)) + K <- length(classes) + class_id <- match(y, classes) + n_c <- tabulate(class_id, nbins = K) + 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 @@ -685,6 +696,33 @@ measure_rmse <- function( ) } +#' 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 @@ -721,22 +759,18 @@ measure_r2 <- function( mse_y_i <- (y - mean(y))^2 mse_y_hat <- mean(mse_y_i) - - var_mse_hat <- mse_res$estimate[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 @@ -940,20 +974,246 @@ measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL, # @param measure The measure used. # @return The measure specification. .measure_spec <- list( - elpd = list(fun = measure_elpd, loss = FALSE), - ic = list(fun = measure_ic, loss = TRUE), - mlpd = list(fun = measure_mlpd, loss = FALSE), - 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 = FALSE), - srps = list(fun = measure_srps, loss = TRUE), - brier = list(fun = measure_brier, loss = TRUE) + elpd = list(fun = measure_elpd, loss = FALSE, diff_method = "sum"), + ic = list(fun = measure_ic, loss = TRUE, diff_method = "sum"), + mlpd = list(fun = measure_mlpd, loss = FALSE, diff_method = "mean"), + 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" + ), + rps = list(fun = measure_rps, loss = FALSE, diff_method = "mean"), + srps = list(fun = measure_srps, loss = TRUE, 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 (`higher_is_better` sign flips are undone before the +# call and reapplied to the difference afterwards), 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) + } + + se_mse_ref <- sqrt(stats::var(sqe_ref) / n) + se_mse_cmp <- sqrt(stats::var(sqe_cmp) / n) + cov_mse <- sum((sqe_cmp - mse_cmp) * (sqe_ref - mse_ref)) / (n * (n - 1)) + + # standard errors of the two MSEs relative to their own scale, and their + # correlation + rel_ref <- se_mse_ref / sqrt(mse_ref) + rel_cmp <- se_mse_cmp / sqrt(mse_cmp) + rho <- if (se_mse_ref <= 0 || se_mse_cmp <= 0) { + 0 + } else { + cov_mse / (se_mse_cmp * se_mse_ref) + } + + # algebraically `rel_cmp^2 + rel_ref^2 - 2 * rho * rel_cmp * rel_ref`, but + # written so that two models with the same squared errors cancel exactly + # rather than leaving rounding noise behind. Both terms are non-negative, + # because the correlation cannot exceed one. + v <- (rel_cmp - rel_ref)^2 + 2 * rel_cmp * rel_ref * max(1 - rho, 0) + + 0.5 * sqrt(v) +} + +#' 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 <- ref$extra$mse_y_i + if (is.null(mse_y_i)) { + mse_y_i <- 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 comparison metadata for a measure +#' @noRd +#' @param measure_entry Normalized measure entry, or a built-in measure name. +#' @param higher_is_better Value of `higher_is_better` used for this measure. +.measure_compare_meta <- function(measure_entry, higher_is_better = NULL) { + 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( + higher_is_better = higher_is_better, + 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( + higher_is_better = higher_is_better, + 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` @@ -963,18 +1223,43 @@ measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL, #' @export supported_measures_list <- names(.measure_spec) +#' Store a measure result on the requested scale +#' +#' `higher_is_better` selects the scale values are stored on; `natural_higher` +#' says which scale the measure produced them on. When the two disagree, the +#' estimate and the pointwise values are negated. The standard error is not (it +#' is invariant to the sign), and neither is `extra`, which carries auxiliary +#' data for `se_diff_fun()` on the measure's natural scale. +#' +#' @param res A measure result, with either `estimate`/`se` or a length-2 +#' `estimates` vector (estimate and SE). +#' @param natural_higher `TRUE` when the measure is naturally a utility. +#' @param higher_is_better The requested scale, or `NULL` to keep the natural +#' one. +#' @noRd +.apply_measure_scale <- function(res, natural_higher, higher_is_better) { + if (is.null(higher_is_better) || !xor(natural_higher, isTRUE(higher_is_better))) { + return(res) + } + if (!is.null(res$estimates)) { + res$estimates[1L] <- -res$estimates[1L] + } else { + res$estimate <- -res$estimate + } + res$pointwise <- -res$pointwise + res +} + # 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 - } - } + spec <- .measure_spec[[measure_name]] + res <- .apply_measure_scale( + res, + natural_higher = is.null(spec) || !isTRUE(spec$loss), + higher_is_better = higher_is_better + ) out <- list() out$estimates <- matrix( c(res$estimate, res$se), @@ -991,6 +1276,26 @@ supported_measures_list <- names(.measure_spec) out, class = c("measure", "loo"), measure = measure_name, - dims = c(n_draws, n_obs) + dims = c(n_draws, n_obs), + higher_is_better = higher_is_better, + # not affected by the sign flip above: `extra` carries auxiliary data for + # `se_diff_fun()`, which always works on the measure's natural scale + compare_extra = res$extra ) } + +#' Auxiliary data a measure stores for its `se_diff_fun` +#' +#' Built-in measures carry it as the `compare_extra` attribute added by +#' `.create_measure_structure()`; custom measures return it as an `extra` +#' element of their result list. +#' @noRd +#' @param res A measure result. +#' @return A list, or `NULL` when the measure stores nothing. +.measure_compare_extra <- function(res) { + extra <- attr(res, "compare_extra", exact = TRUE) + if (is.null(extra)) { + extra <- res$extra + } + extra +} diff --git a/R/pred_measure-compute.R b/R/pred_measure-compute.R index 9fbbcd54..8cbf4f5b 100644 --- a/R/pred_measure-compute.R +++ b/R/pred_measure-compute.R @@ -34,9 +34,34 @@ #' 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`. +#' +#' 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 For a single custom function, set #' `attr(my_fun, "measure_name") <- "my_metric"` before passing `my_fun` to -#' `measure`. +#' `measure`. A custom measure passed inside a list takes its name from the +#' list element instead, but `attr(my_fun, "measure_loss")` is read in both +#' forms. #' @param group_ids Optional vector of group identifiers for grouped summaries #' (reserved; not yet implemented). #' @param loo A [loo::loo()] result, computed with @@ -54,6 +79,9 @@ #' @param control Named list of per-measure settings. Each name must match an #' element of `measure`; the value is a list of arguments passed to that #' measure's summary function (e.g. `list(new_measure = list(add_arg = 10))`). +#' `higher_is_better` selects the scale a measure's values are stored on and +#' works for built-in and custom measures alike; for a custom measure it is +#' applied to the returned result rather than passed to the function. #' @param source Character string indicating the evaluation mode: `"insample"`, #' `"loo"`, `"kfold"`, or `"test"`. Set automatically by the wrapper #' functions; required when calling [do_pred_measure()] directly. @@ -77,9 +105,11 @@ do_pred_measure <- function( control = list() ) { # input validation --------------------------------------------------- - .validate_control(control) - measures <- .prepare_measures(measure, predperf, supported_measures_list) + # 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)) { @@ -165,7 +195,10 @@ do_pred_measure <- function( mat = estimates, name = entry$name, values = .measure_estimate_se(sel_measure), - margin = 1 + margin = 1, + measure_entry = entry, + higher_is_better = attr(sel_measure, "higher_is_better"), + extra = .measure_compare_extra(sel_measure) ) pointwise <- .merge_matrix( source = source, @@ -184,7 +217,7 @@ do_pred_measure <- function( save_psis = save_psis ) - .add_attributes( + predperf_res <- .add_attributes( save_psis, predperf_res, y, @@ -197,6 +230,7 @@ do_pred_measure <- function( predperf, source ) + predperf_res } # internal helper functions --------------------------------------------------- @@ -323,10 +357,11 @@ do_pred_measure <- function( base_measure ) { if (measure_entry$type == "builtin") { - measure_fun <- .measure_spec[[measure_entry$key]]$fun - if (is.null(measure_fun)) { + spec <- .measure_spec[[measure_entry$key]] + if (is.null(spec)) { cli::cli_abort("Unknown built-in measure {.val {measure_entry$key}}.") } + measure_fun <- spec$fun } else { measure_fun <- measure_entry$key } @@ -347,6 +382,16 @@ do_pred_measure <- function( measure_control <- list() } + # Built-in measures take `higher_is_better` as an argument and flip their own + # sign. Custom measures know nothing about it, so it is held back here and + # applied to the result below; forwarding it as well could flip twice. + is_custom <- measure_entry$type == "custom" + custom_higher_is_better <- NULL + if (is_custom) { + custom_higher_is_better <- measure_control$higher_is_better + measure_control$higher_is_better <- NULL + } + pool <- c( list( y = y, @@ -359,9 +404,17 @@ do_pred_measure <- function( ) args <- pool[intersect(names(formals(measure_fun)), names(pool))] res <- do.call(measure_fun, args) - if (measure_entry$type == "custom") { + if (is_custom) { n_obs <- .measure_n_obs(y, ypred, mupred, ylp) res <- .validate_measure_result(res, measure_entry$name, n_obs = n_obs) + res <- .apply_measure_scale( + res, + natural_higher = !isTRUE(measure_entry$loss), + higher_is_better = custom_higher_is_better + ) + if (!is.null(custom_higher_is_better)) { + attr(res, "higher_is_better") <- custom_higher_is_better + } } res } @@ -536,6 +589,14 @@ 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`), comparison metadata for [model_compare()] is +#' recorded from this entry and `higher_is_better`. +#' @param higher_is_better Optional logical or `NULL`; records the orientation +#' used for `name` when merging an estimates row (`margin = 1`). +#' @param extra Optional list of auxiliary data the measure stores for its +#' `se_diff_fun` (see `.measure_compare_extra()`); recorded in the comparison +#' metadata when merging an estimates row (`margin = 1`). #' #' @return Updated matrix with `name` as a row or column name. #' @@ -551,7 +612,16 @@ do_pred_measure <- function( } #' @noRd -.merge_matrix <- function(source, mat, name, values, margin) { +.merge_matrix <- function( + source, + mat, + name, + values, + margin, + measure_entry = NULL, + higher_is_better = NULL, + extra = NULL +) { is_row <- margin == 1 bind_fn <- if (is_row) rbind else cbind name_updated <- .measure_result_name(source, name) @@ -562,8 +632,46 @@ 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) + compare_meta <- if (is_row && !is.null(measure_entry)) { + .measure_compare_meta(measure_entry, higher_is_better) + } + if (!is.null(compare_meta) && !is.null(extra)) { + compare_meta$extra <- extra + } + + old_higher_is_better <- if (is_row && !is.null(mat)) { + attr(mat, "measure_higher_is_better") + } + old_compare_meta <- if (is_row && !is.null(mat)) { + attr(mat, "measure_compare_meta") + } + + mat <- if (is.null(mat)) new_slice else bind_fn(mat, new_slice) + + if (is_row) { + if (!is.null(measure_entry) || !is.null(old_higher_is_better)) { + measure_higher_is_better <- old_higher_is_better + if (is.null(measure_higher_is_better)) { + measure_higher_is_better <- list() + } + if (!is.null(measure_entry)) { + measure_higher_is_better[[name]] <- higher_is_better + } + attr(mat, "measure_higher_is_better") <- measure_higher_is_better + } + if (!is.null(compare_meta) || !is.null(old_compare_meta)) { + measure_compare_meta <- old_compare_meta + if (is.null(measure_compare_meta)) { + measure_compare_meta <- list() + } + if (!is.null(compare_meta)) { + measure_compare_meta[[name]] <- compare_meta + } + attr(mat, "measure_compare_meta") <- measure_compare_meta + } + } + + mat } #' Construct the S3 predictive measure result object @@ -586,7 +694,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 +#' `diagnostics`, `psis_object`, and `log_weights`. Attributes +#' `measure_higher_is_better` and `measure_compare_meta` record per-measure +#' metadata for measures added in the current call. Class attributes are added #' by \code{.add_attributes()}. #' #' @noRd @@ -597,6 +707,18 @@ do_pred_measure <- function( psis_object, save_psis ) { + measure_higher_is_better <- attr(estimates, "measure_higher_is_better") + if (is.null(measure_higher_is_better)) { + measure_higher_is_better <- list() + } + attr(estimates, "measure_higher_is_better") <- NULL + + measure_compare_meta <- attr(estimates, "measure_compare_meta") + if (is.null(measure_compare_meta)) { + measure_compare_meta <- list() + } + attr(estimates, "measure_compare_meta") <- NULL + output_list <- list( estimates = estimates, pointwise = pointwise @@ -610,23 +732,32 @@ do_pred_measure <- function( if (!is.null(psis_object)) { output_list$log_weights <- psis_object$log_weights } - - structure(output_list) + + structure( + output_list, + measure_higher_is_better = measure_higher_is_better, + measure_compare_meta = measure_compare_meta + ) } #' 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`, `measure_higher_is_better`, and +#' `measure_compare_meta` 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_higher_is_better` and `measure_compare_meta` 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_higher_is_better` and `measure_compare_meta`, seeding `elpd` defaults. #' #' @param save_psis Logical; when `FALSE` and accumulating, clears stored #' `psis_object` from the prior result. @@ -646,7 +777,28 @@ 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_higher_is_better <- attr(predperf_res, "measure_higher_is_better") + if (is.null(new_higher_is_better)) { + new_higher_is_better <- list() + } + new_compare_meta <- attr(predperf_res, "measure_compare_meta") + if (is.null(new_compare_meta)) { + new_compare_meta <- list() + } + if (!is.null(predperf)) { if (isFALSE(save_psis)) { predperf$psis_object <- NULL @@ -661,6 +813,25 @@ do_pred_measure <- function( dim(ylp) } attr(predperf_res, "dims") <- dims + measure_higher_is_better <- attr(predperf, "measure_higher_is_better") + if (is.null(measure_higher_is_better)) { + measure_higher_is_better <- list() + } + if (length(new_higher_is_better)) { + measure_higher_is_better[names(new_higher_is_better)] <- new_higher_is_better + } + attr(predperf_res, "measure_higher_is_better") <- measure_higher_is_better + compare_meta <- attr(predperf, "measure_compare_meta") + if (is.null(compare_meta)) { + compare_meta <- list() + } + if (is.null(compare_meta$elpd)) { + compare_meta$elpd <- .measure_compare_meta("elpd") + } + if (length(new_compare_meta)) { + compare_meta[names(new_compare_meta)] <- new_compare_meta + } + attr(predperf_res, "measure_compare_meta") <- compare_meta return(predperf_res) } @@ -708,6 +879,19 @@ do_pred_measure <- function( } attr(predperf_res, "class") <- classes attr(predperf_res, "source") <- source + measure_higher_is_better <- list(elpd = NULL) + if (length(new_higher_is_better)) { + measure_higher_is_better[names(new_higher_is_better)] <- new_higher_is_better + } + attr(predperf_res, "measure_higher_is_better") <- measure_higher_is_better + compare_meta <- list( + elpd = .measure_compare_meta("elpd") + ) + if (length(new_compare_meta)) { + compare_meta[names(new_compare_meta)] <- new_compare_meta + } + attr(predperf_res, "measure_compare_meta") <- compare_meta return(predperf_res) -} \ No newline at end of file +} + diff --git a/R/pred_measure-helpers.R b/R/pred_measure-helpers.R index 761f2a6e..4f4a4866 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", @@ -69,17 +70,45 @@ #' Build a custom measure entry from a function #' #' @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)) { +.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)) { + 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\"}." + )) + } + } + list(name = name, type = "custom", key = fun, loss = .measure_entry_loss(fun)) +} + +#' Whether a custom measure declares itself a loss +#' +#' A measure's orientation is a property of its definition, so it is declared +#' once on the function rather than at every call. `higher_is_better` in +#' `control` is a separate, per-call choice of the scale values are stored on. +#' @noRd +#' @param fun Function implementing a custom measure. +#' @return `TRUE` for a loss (lower is better), `FALSE` otherwise. +.measure_entry_loss <- function(fun) { + loss <- attr(fun, "measure_loss", exact = TRUE) + if (is.null(loss)) { + return(FALSE) + } + if (!is.logical(loss) || length(loss) != 1L || is.na(loss)) { 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\"}." + "Attribute {.code measure_loss} of a custom measure must be", + "{.code TRUE} or {.code FALSE}.", + "i" = "Set {.code attr(my_fun, \"measure_loss\") <- TRUE} for a measure + where lower values are better." )) } - list(name = name, type = "custom", key = fun) + loss } #' Check duplicate and reserved measure names @@ -236,6 +265,13 @@ "length {.val {n_obs}}, not {.val {length(res$pointwise)}}." )) } + 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) } @@ -422,18 +458,30 @@ } +#' Control arguments that are handled by the package, not by a measure function +#' +#' `higher_is_better` selects the scale a custom measure's values are stored on. +#' It is applied by `.compute_measure()` and never forwarded to the measure +#' function itself, which would otherwise flip the sign twice. +#' @noRd +.control_reserved_args <- "higher_is_better" + #' 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( @@ -441,17 +489,60 @@ "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 + valid_args <- if (is.null(entry) && known_measures) { + NULL + } else { + .control_valid_args(func_name, entry) + } + 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) +} + +#' Argument names a `control` entry may set for one measure +#' +#' @param name Name of the `control` entry. +#' @param entry Normalized measure entry of that name, or `NULL` when the +#' requested measures are unknown (see `.validate_control()`). +#' @return Character vector of accepted argument names, or `NULL` when the name +#' matches no built-in measure either. +#' @noRd +.control_valid_args <- function(name, entry = NULL) { + if (!is.null(entry) && identical(entry$type, "custom")) { + return(union(names(formals(entry$key)), .control_reserved_args)) + } + key <- if (is.null(entry)) name else entry$key + spec <- .measure_spec[[key]] + if (is.null(spec)) { + return(NULL) + } + names(formals(spec$fun)) } #' Subset measure results diff --git a/R/pred_measure.R b/R/pred_measure.R index 829dfb59..2b9edbb0 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_higher_is_better` records the +#' `higher_is_better` setting used for each measure; see section below. Use [print()] +#' for a readable summary table. +#' +#' @template measure-higher-is-better-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()]. For a custom loss measure, pass +#' `control = list(my_measure = list(higher_is_better = TRUE))` or negate values +#' in the custom function so that [model_compare()] ranks models correctly. +#' +#' 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)) { @@ -151,6 +164,8 @@ insample_pred_measure <- function( #' #' Measure names carry a `_loo` suffix (e.g. `elpd_loo`, `crps_loo`). #' +#' @template measure-higher-is-better-attribute +#' #' @details #' **Three equivalent input patterns:** #' @@ -241,6 +256,8 @@ loo_pred_measure <- function( #' list contains `estimates` and `pointwise`; measure names carry a `_kfold` #' suffix (e.g. `elpd_kfold`, `crps_kfold`). #' +#' @template measure-higher-is-better-attribute +#' #' @details #' For distributional measures on held-out folds, obtain posterior predictions #' with `brms::kfold_predict()` and pass the resulting `yrep` matrices as @@ -323,6 +340,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-higher-is-better-attribute +#' #' @details #' The base summary `elpd_test` is computed from `ylp_test` on the holdout #' observations only. @@ -401,7 +420,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_higher_is_better` is updated for any newly added +#' measures. +#' +#' @template measure-higher-is-better-attribute #' #' @details #' **Typical workflow:** diff --git a/R/print.R b/R/print.R index 5fb36255..d187e6cb 100644 --- a/R/print.R +++ b/R/print.R @@ -338,6 +338,24 @@ print.loo_pred_measure <- function(x, digits = 1, plot_k = FALSE, ...) { invisible(x) } +#' Human-readable description of an evaluation source +#' +#' Used by `print.compare.loo()` to name the cross-validation scheme a +#' comparison was computed on. Unlike `.pred_measure_source_label()`, which +#' returns a short tag for one object, this spells the scheme out for a +#' full sentence. +#' @noRd +.compare_source_label <- function(source) { + switch( + source, + loo = "PSIS-LOO cross-validation", + kfold = "K-fold cross-validation", + test = "held-out test data", + insample = "in-sample (training) data", + source + ) +} + .pred_measure_source_label <- function(x) { cls <- class(x) if ("loo_pred_measure" %in% cls) { diff --git a/R/waic.R b/R/waic.R index 2dac6456..dee098dc 100644 --- a/R/waic.R +++ b/R/waic.R @@ -30,7 +30,7 @@ #' * 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. +#' * [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..87e071ad 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/comparison-standard-errors - 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-higher-is-better-attribute.R b/man-roxygen/measure-higher-is-better-attribute.R new file mode 100644 index 00000000..eeb36020 --- /dev/null +++ b/man-roxygen/measure-higher-is-better-attribute.R @@ -0,0 +1,22 @@ +#' @section `measure_higher_is_better` attribute: +#' All `*_pred_measure()` and [pred_measure()] results include attribute +#' `measure_higher_is_better`: a named list recording the `higher_is_better` +#' setting used for each measure (`TRUE` or `FALSE` per bare measure name). +#' Measures left at their natural orientation have no entry, which reads as +#' `NULL`; `elpd` is always `NULL`. Built-in loss measures such as MSE are +#' stored on a loss scale by default; pass +#' `control = list(mse = list(higher_is_better = TRUE))` to store values on a +#' utility scale. The same works for a custom measure, using the name it was +#' given in `measure`. When measures are added incrementally with +#' [pred_measure()], the attribute is updated for newly computed measures. +#' +#' Attribute `measure_compare_meta` records per-measure comparison metadata +#' (`higher_is_better`, `loss`, and `diff_method`) used by [model_compare()]. +#' Built-in measures take `loss` and `diff_method` 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 98b3598e..5a3ee637 100644 --- a/man/insample_pred_measure.Rd +++ b/man/insample_pred_measure.Rd @@ -20,15 +20,15 @@ insample_pred_measure( point-prediction measures such as \code{crps}, \code{mae}, and \code{acc}.} \item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} -observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +observations), typically from \code{\link[brms:posterior_predict.brmsfit]{brms::posterior_predict()}}. Required for distributional measures such as \code{crps}, \code{rps}, and \code{scrps}.} \item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from -\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for point-prediction measures such as +\code{\link[brms:posterior_epred.brmsfit]{brms::posterior_epred()}}. Required for point-prediction measures such as \code{mae}, \code{rmse}, \code{r2}, and \code{acc}.} \item{ylp}{Matrix of pointwise log predictive densities or probabilities -(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}. Required for density-based +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik.brmsfit]{brms::log_lik()}}. Required for density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} \item{measure}{Additional measures beyond the base summary \code{elpd} (always @@ -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).} @@ -53,7 +76,10 @@ recomputing PSIS weights.} \item{control}{Named list of per-measure settings. Each name must match an 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))}).} +measure's summary function (e.g. \code{list(new_measure = list(add_arg = 10))}). +\code{higher_is_better} selects the scale a measure's values are stored on and +works for built-in and custom measures alike; for a custom measure it is +applied to the returned result rather than passed to the function.} } \value{ An object of class \code{"insample_pred_measure"} and \code{"pred_measure"}: a list @@ -67,7 +93,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_higher_is_better} records the +\code{higher_is_better} setting used for 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 +132,41 @@ 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()}}. For a custom loss measure, pass +\code{control = list(my_measure = list(higher_is_better = TRUE))} or negate values +in the custom function so that \code{\link[=model_compare]{model_compare()}} ranks models correctly. + +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_higher_is_better} attribute}{ + +All \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results include attribute +\code{measure_higher_is_better}: a named list recording the \code{higher_is_better} +setting used for each measure (\code{TRUE} or \code{FALSE} per bare measure name). +Measures left at their natural orientation have no entry, which reads as +\code{NULL}; \code{elpd} is always \code{NULL}. Built-in loss measures such as MSE are +stored on a loss scale by default; pass +\code{control = list(mse = list(higher_is_better = TRUE))} to store values on a +utility scale. The same works for a custom measure, using the name it was +given in \code{measure}. When measures are added incrementally with +\code{\link[=pred_measure]{pred_measure()}}, the attribute is updated for newly computed measures. + +Attribute \code{measure_compare_meta} records per-measure comparison metadata +(\code{higher_is_better}, \code{loss}, and \code{diff_method}) used by \code{\link[=model_compare]{model_compare()}}. +Built-in measures take \code{loss} and \code{diff_method} 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-helpers.Rd b/man/kfold-helpers.Rd index f1cd25a6..26a4d273 100644 --- a/man/kfold-helpers.Rd +++ b/man/kfold-helpers.Rd @@ -19,7 +19,7 @@ kfold_split_grouped(K = 10, x = NULL) \item{N}{The number of observations in the data.} \item{x}{A discrete variable of length \code{N} with at least \code{K} levels (unique -values). Will be coerced to a \link{factor}.} +values). Will be coerced to a \link[=factor]{factor}.} } \value{ An integer vector of length \code{N} where each element is an index in \code{1:K}. diff --git a/man/kfold_pred_measure.Rd b/man/kfold_pred_measure.Rd index aa0588e4..32107861 100644 --- a/man/kfold_pred_measure.Rd +++ b/man/kfold_pred_measure.Rd @@ -20,15 +20,15 @@ kfold_pred_measure( point-prediction measures such as \code{crps}, \code{mae}, and \code{acc}.} \item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} -observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +observations), typically from \code{\link[brms:posterior_predict.brmsfit]{brms::posterior_predict()}}. Required for distributional measures such as \code{crps}, \code{rps}, and \code{scrps}.} \item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from -\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for point-prediction measures such as +\code{\link[brms:posterior_epred.brmsfit]{brms::posterior_epred()}}. Required for point-prediction measures such as \code{mae}, \code{rmse}, \code{r2}, and \code{acc}.} \item{ylp}{Matrix of pointwise log predictive densities or probabilities -(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}. Required for density-based +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik.brmsfit]{brms::log_lik()}}. Required for density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} \item{measure}{Additional measures beyond the base summary \code{elpd} (always @@ -42,9 +42,32 @@ 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}. -\item{kfold}{A \code{kfold} object from \code{\link[brms:kfold]{brms::kfold()}}. Supplies ELPD summaries +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.brmsfit]{brms::kfold()}}. Supplies ELPD summaries and fold structure for \code{\link[=kfold_pred_measure]{kfold_pred_measure()}}; pass \code{y}, \code{ypred}, and/or \code{mupred} when requesting additional measures.} @@ -53,7 +76,10 @@ and fold structure for \code{\link[=kfold_pred_measure]{kfold_pred_measure()}}; \item{control}{Named list of per-measure settings. Each name must match an 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))}).} +measure's summary function (e.g. \code{list(new_measure = list(add_arg = 10))}). +\code{higher_is_better} selects the scale a measure's values are stored on and +works for built-in and custom measures alike; for a custom measure it is +applied to the returned result rather than passed to the function.} } \value{ An object of class \code{"kfold_pred_measure"} and \code{"pred_measure"}, inheriting @@ -66,7 +92,7 @@ Compute predictive performance measures under \strong{k-fold cross-validation}. K-fold CV holds out groups of observations, refits (or reuses stored fits), and scores the held-out folds. -Pass a \code{kfold} object from \code{\link[brms:kfold]{brms::kfold()}} (with \code{save_fits = TRUE} when +Pass a \code{kfold} object from \code{\link[brms:kfold.brmsfit]{brms::kfold()}} (with \code{save_fits = TRUE} when you need posterior predictions on held-out folds). Base density summaries (\code{elpd_kfold}, \code{ic_kfold}, \code{p_kfold}) come from the \code{kfold} object; additional measures require the same optional inputs as @@ -78,6 +104,31 @@ 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_higher_is_better} attribute}{ + +All \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results include attribute +\code{measure_higher_is_better}: a named list recording the \code{higher_is_better} +setting used for each measure (\code{TRUE} or \code{FALSE} per bare measure name). +Measures left at their natural orientation have no entry, which reads as +\code{NULL}; \code{elpd} is always \code{NULL}. Built-in loss measures such as MSE are +stored on a loss scale by default; pass +\code{control = list(mse = list(higher_is_better = TRUE))} to store values on a +utility scale. The same works for a custom measure, using the name it was +given in \code{measure}. When measures are added incrementally with +\code{\link[=pred_measure]{pred_measure()}}, the attribute is updated for newly computed measures. + +Attribute \code{measure_compare_meta} records per-measure comparison metadata +(\code{higher_is_better}, \code{loss}, and \code{diff_method}) used by \code{\link[=model_compare]{model_compare()}}. +Built-in measures take \code{loss} and \code{diff_method} 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)) { @@ -101,6 +152,6 @@ if (requireNamespace("brms", quietly = TRUE)) { } \seealso{ \code{\link[=loo_pred_measure]{loo_pred_measure()}}, \code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=pred_measure]{pred_measure()}}, -\code{\link[brms:kfold]{brms::kfold()}}, \link{supported_measures_list}, +\code{\link[brms:kfold.brmsfit]{brms::kfold()}}, \link{supported_measures_list}, \href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{pred-measure workflow article} } diff --git a/man/loo-glossary.Rd b/man/loo-glossary.Rd index 58529429..82b39519 100644 --- a/man/loo-glossary.Rd +++ b/man/loo-glossary.Rd @@ -171,7 +171,7 @@ approximation to the uncertainty in \code{elpd_diff}. It is computed as \if{html}{\out{
}}\preformatted{p_worse = pnorm(0, elpd_diff, se_diff). }\if{html}{\out{
}} -The best-ranked model (the first row in the \code{loo_compare()} output, where +The best-ranked model (the first row in the \code{model_compare()} output, where \code{elpd_diff = 0}) always receives \code{NA}, since the comparison is defined relative to that model. @@ -186,7 +186,7 @@ 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()} +present, \code{diag_diff} or \code{diag_elpd} will be flagged in the \code{model_compare()} 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}. @@ -195,7 +195,7 @@ For further guidance, see the sections below and the case study on \section{\code{diag_diff} (pairwise comparison diagnostics)}{ -\code{diag_diff} is a diagnostic column in the \code{loo_compare()} output for each +\code{diag_diff} is a diagnostic column in the \code{model_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 @@ -222,7 +222,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 +\code{model_compare()} therefore follows a priority hierarchy and shows only the most critical flag in the table output. The hierarchy is as follows: @@ -247,7 +247,7 @@ 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 +\code{diag_elpd} is a diagnostic column in the \code{model_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. @@ -270,6 +270,134 @@ section. } } +\section{Multi-measure model comparisons}{ + + +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. +Attribute \code{measure_higher_is_better} on each \verb{*_pred_measure()} +result records the \code{higher_is_better} setting used when each measure was +computed; when stored values are on a loss 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_higher_is_better}}{ + +Attribute on all \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results: a named +list recording the \code{higher_is_better} setting used for each measure (\code{TRUE} +or \code{FALSE}). Measures left at their natural orientation have no entry, which +reads as \code{NULL}; \code{elpd} is always \code{NULL}. Used by \code{\link[=model_compare]{model_compare()}} with +\code{measure_compare_meta} to decide whether paired differences need a sign flip +when converting to a utility scale. +} + +\subsection{\code{measure_compare_meta}}{ + +Attribute on all \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results: a named +list of per-measure comparison metadata used by \code{\link[=model_compare]{model_compare()}}. Each entry +is a list with: +\itemize{ +\item \code{higher_is_better} — the orientation setting used when the measure was +computed (\code{NULL}, \code{TRUE}, or \code{FALSE}), that is, which scale the values were +stored on +\item \code{loss} — whether the measure itself is a loss (lower is better), regardless +of the scale its values are stored on +\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 — the difference itself is still reported. +\code{"estimates_only"} appears only for legacy objects that carry no +comparison metadata at all. +\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 metadata consistency check below, +since it varies with the data rather than with how the measure was +configured. +} + +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 metadata for each +shared measure; mismatched \code{higher_is_better} or \code{measure_loss} settings, or +missing metadata on some models, produce 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} is +set only when \code{rank_by} names a measure, and attribute \code{compare_ref_model} +only when it names a model. 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. diff --git a/man/loo-package.Rd b/man/loo-package.Rd index aa158231..31b5a49c 100644 --- a/man/loo-package.Rd +++ b/man/loo-package.Rd @@ -122,7 +122,6 @@ Useful links: Authors: \itemize{ - \item Jonah Gabry \email{jgabry@gmail.com} \item Aki Vehtari \email{Aki.Vehtari@aalto.fi} \item Måns Magnusson \item Yuling Yao 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 c54b9f86..e9de0ed0 100644 --- a/man/loo_compare.Rd +++ b/man/loo_compare.Rd @@ -1,157 +1,89 @@ % 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 (previous name)} \usage{ -loo_compare(x, ...) +loo_compare(x, ..., rank_by = NULL, custom_se_fn) -\method{loo_compare}{default}(x, ...) +\method{loo_compare}{default}(x, ..., rank_by = NULL, custom_se_fn) -\method{print}{compare.loo}(x, ..., digits = 1, p_worse = 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}.} - -\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}.} -} -\value{ -A data frame with class \code{"compare.loo"} that has its own -print method. See the \strong{Details} and \strong{Examples} sections. -} -\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: +\item{x}{An object of class \code{"loo"} or \code{"pred_measure"}, 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}.} + +\item{...}{Additional objects of class \code{"loo"} or \code{"pred_measure"}, if not +passed in as a single list.} + +\item{rank_by}{A single string naming either a \strong{measure} or a \strong{model}, +used to define one reference model for all pairwise differences. + +A \strong{measure name} (\code{\link{pred_measure}} comparisons only) ranks +models by that measure and makes the top-ranked model the reference. Bare +names are used regardless of source, so \code{rank_by = "rmse"} selects +\code{rmse_loo}, \code{rmse_kfold}, or \code{rmse_test} as appropriate. For example, +\code{rank_by = "mse"} ranks models by predictive MSE (best/lowest MSE first) +and computes \emph{all} measure differences relative to that one model on a +utility scale (higher is better; loss measures such as MSE have their sign +flipped). + +A \strong{model name} (one of the names shown in the \code{model} column, i.e. the +list names or \code{model1}, \code{model2}, ...) pins that model as the reference for +all differences, whichever model performs best. Rows stay ordered by +\code{"elpd"}. This form also works for plain \code{"loo"} comparisons, where +\code{elpd_diff} is then relative to the named model rather than to the best +one. If a name matches both a measure and a model, the measure wins and a +warning is issued. + +When \code{rank_by} is \code{NULL} (the default), rows are ordered by \code{"elpd"} but +each measure is compared against \emph{its own} best model, so \code{mse_diff} may be +relative to a different model 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 \code{N < 100} (small data) -\item \verb{|elpd_diff| < 4} (models make similar predictions) +\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. } - -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. - -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. +When two or more custom measures are compared, 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.} } - -\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. +\value{ +See \code{\link[=model_compare]{model_compare()}}. } +\description{ +\code{loo_compare()} is the previous name of \code{\link[=model_compare]{model_compare()}} and is kept as a +working alias. It is a generic so that packages registering their own +\code{loo_compare} methods keep dispatching as before; the default method simply +forwards to \code{\link[=model_compare]{model_compare()}}. + +New code should call \code{\link[=model_compare]{model_compare()}}, which additionally compares +\code{\link[=kfold_pred_measure]{kfold_pred_measure()}}, +\code{\link[=test_pred_measure]{test_pred_measure()}}, and +\code{\link[=insample_pred_measure]{insample_pred_measure()}} results. } \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) - -# 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)) +loo1 <- loo(LL) +loo2 <- loo(LL + 1) -\dontrun{ -# works for waic (and kfold) too -loo_compare(waic(LL), waic(LL - 10)) -} +# identical to model_compare(loo1, loo2) +loo_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 eeae51b3..f9f59df6 100644 --- a/man/loo_pred_measure.Rd +++ b/man/loo_pred_measure.Rd @@ -22,15 +22,15 @@ loo_pred_measure( point-prediction measures such as \code{crps}, \code{mae}, and \code{acc}.} \item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} -observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +observations), typically from \code{\link[brms:posterior_predict.brmsfit]{brms::posterior_predict()}}. Required for distributional measures such as \code{crps}, \code{rps}, and \code{scrps}.} \item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from -\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for point-prediction measures such as +\code{\link[brms:posterior_epred.brmsfit]{brms::posterior_epred()}}. Required for point-prediction measures such as \code{mae}, \code{rmse}, \code{r2}, and \code{acc}.} \item{ylp}{Matrix of pointwise log predictive densities or probabilities -(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}. Required for density-based +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik.brmsfit]{brms::log_lik()}}. Required for density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} \item{measure}{Additional measures beyond the base summary \code{elpd} (always @@ -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 @@ -63,7 +86,10 @@ recomputing PSIS weights.} \item{control}{Named list of per-measure settings. Each name must match an 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))}).} +measure's summary function (e.g. \code{list(new_measure = list(add_arg = 10))}). +\code{higher_is_better} selects the scale a measure's values are stored on and +works for built-in and custom measures alike; for a custom measure it is +applied to the returned result rather than passed to the function.} } \value{ An object of class \code{"loo_pred_measure"}, \code{"pred_measure"}, and \code{"loo"}. @@ -113,6 +139,31 @@ 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_higher_is_better} attribute}{ + +All \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results include attribute +\code{measure_higher_is_better}: a named list recording the \code{higher_is_better} +setting used for each measure (\code{TRUE} or \code{FALSE} per bare measure name). +Measures left at their natural orientation have no entry, which reads as +\code{NULL}; \code{elpd} is always \code{NULL}. Built-in loss measures such as MSE are +stored on a loss scale by default; pass +\code{control = list(mse = list(higher_is_better = TRUE))} to store values on a +utility scale. The same works for a custom measure, using the name it was +given in \code{measure}. When measures are added incrementally with +\code{\link[=pred_measure]{pred_measure()}}, the attribute is updated for newly computed measures. + +Attribute \code{measure_compare_meta} records per-measure comparison metadata +(\code{higher_is_better}, \code{loss}, and \code{diff_method}) used by \code{\link[=model_compare]{model_compare()}}. +Built-in measures take \code{loss} and \code{diff_method} 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..8288c262 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[=model_compare]{model_compare()}} } diff --git a/man/model_compare.Rd b/man/model_compare.Rd new file mode 100644 index 00000000..1e9d7c93 --- /dev/null +++ b/man/model_compare.Rd @@ -0,0 +1,382 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/model_compare.R, +% R/model_compare.psis_loo_ss_list.R +\name{model_compare} +\alias{model_compare} +\alias{model_compare.default} +\alias{print.compare.loo} +\alias{print.compare.loo_ss} +\title{Model comparison} +\usage{ +model_compare(x, ..., rank_by = NULL, custom_se_fn) + +\method{model_compare}{default}(x, ..., rank_by = NULL, custom_se_fn) + +\method{print}{compare.loo}(x, ..., digits = 1, p_worse = TRUE, measures = NULL) + +\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. If a list is used then the list names will be 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.} + +\item{rank_by}{A single string naming either a \strong{measure} or a \strong{model}, +used to define one reference model for all pairwise differences. + +A \strong{measure name} (\code{\link{pred_measure}} comparisons only) ranks +models by that measure and makes the top-ranked model the reference. Bare +names are used regardless of source, so \code{rank_by = "rmse"} selects +\code{rmse_loo}, \code{rmse_kfold}, or \code{rmse_test} as appropriate. For example, +\code{rank_by = "mse"} ranks models by predictive MSE (best/lowest MSE first) +and computes \emph{all} measure differences relative to that one model on a +utility scale (higher is better; loss measures such as MSE have their sign +flipped). + +A \strong{model name} (one of the names shown in the \code{model} column, i.e. the +list names or \code{model1}, \code{model2}, ...) pins that model as the reference for +all differences, whichever model performs best. Rows stay ordered by +\code{"elpd"}. This form also works for plain \code{"loo"} comparisons, where +\code{elpd_diff} is then relative to the named model rather than to the best +one. If a name matches both a measure and a model, the measure wins and a +warning is issued. + +When \code{rank_by} is \code{NULL} (the default), rows are ordered by \code{"elpd"} but +each measure is compared against \emph{its own} best model, so \code{mse_diff} may be +relative to a different model 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. +} +When two or more custom measures are compared, 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.} + +\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{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.} +} +\value{ +A data frame with class \code{"compare.loo"} that has its own +print method. See the \strong{Details} and \strong{Examples} sections. + +For classic \code{"loo"} / \code{"waic"} / \code{"kfold"} comparisons, the returned +columns are unchanged from previous versions. + +For \code{\link{pred_measure}} comparisons, the data frame +additionally contains \verb{\{measure\}_diff} and \verb{\{measure\}_se_diff} columns for +every predictive measure common to all models (e.g. \code{rmse_diff}, +\code{rmse_se_diff}). ELPD-family measures use \code{elpd_diff} and \code{se_diff}. +\code{p_worse} and \code{diag_diff} are computed for ELPD only. \code{diag_elpd} holds +per-model PSIS diagnostics and is present only for +\code{\link[=loo_pred_measure]{loo_pred_measure()}} comparisons, the only source with +Pareto \eqn{\hat{k}} values. Attributes \code{compare_measures} and +\code{sign_converted_measures} record which measures were compared and which +loss measures had their sign flipped for comparison. Attribute +\code{compare_source} records the shared evaluation source (\code{"loo"}, +\code{"kfold"}, \code{"test"}, or \code{"insample"}). Attribute \code{rank_by} is +set when \code{rank_by} named a measure (default ranking is by \code{"elpd"}), and +attribute \code{compare_ref_model} is set when it named a model. +Attribute \code{compare_reference} is a named character vector giving the +reference model each measure's differences were computed against; all +entries are that single reference model when \code{rank_by} was supplied. +} +\description{ +Compare fitted models based on \link[=loo-glossary]{ELPD} or, for +\code{\link{pred_measure}} results, multiple 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: every input must +come from the same \verb{*_pred_measure()} function, since paired differences +between, say, a LOO and a k-fold result would contrast held-out schemes +rather than models. Mixed inputs are an error. +} +\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{model_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) +} + +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. + +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{Comparing \code{pred_measure} objects}{ + +When all inputs are predictive measure results sharing one evaluation +source, +\code{model_compare()} computes paired differences for every predictive 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. Rows are ordered by \code{rank_by} (default \code{"elpd"}). +By default each measure is compared against the model that is best on that +measure, so \code{mse_diff} can use a different reference model than +\code{elpd_diff}; the reference used for each measure is recorded in attribute +\code{compare_reference} and shown by \code{print(x, measures = "all")}. Supplying +\code{rank_by} instead pins a single reference --- the top-ranked model --- for +every \verb{\{measure\}_diff} column. The returned 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 is always the first row +and the differences run in decreasing order. +Measures may use different orientations in their raw form (e.g. ELPD and +CRPS/RPS are returned on a utility scale where higher is better, while MSE +and Brier score are loss measures where lower is better). For comparison, +all \verb{\{measure\}_diff} values are reported on a common utility scale (higher +is better). Loss measures have their sign flipped from the raw loss +orientation so that negative \verb{\{measure\}_diff} values indicate worse +performance than the reference model. Each \verb{*_pred_measure()} result stores +attribute \code{measure_higher_is_better}, a named list recording the +\code{higher_is_better} setting used when each measure was computed. When loss measures are compared +on a utility scale, \code{model_compare()} emits a short message naming the affected +measures, 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()}}. + +\code{p_worse} and \code{diag_diff} are computed for ELPD-family measures only. Other +measures receive \verb{\{measure\}_diff} and \verb{\{measure\}_se_diff} from paired +pointwise contributions when the overall estimate is a sum or mean of those +contributions (using the same standard error formula as \code{se_diff}). For +measures where pointwise values do not define the overall estimate (e.g. +\code{r2}, \code{mse}, \code{rmse}), \verb{\{measure\}_diff} is the difference between overall +estimates and \verb{\{measure\}_se_diff} is \code{NA}. When models were fit with +different \code{measure} sets, only measures common to all models are compared; a +warning lists omitted measures. Use \code{print(x, measures = "all")} to display +diff tables for every compared measure; see \link{loo-glossary} for column +definitions. +} + +\subsection{Source-specific behavior}{ + +Comparisons behave the same way across sources, with three exceptions: +\itemize{ +\item \strong{\code{diag_elpd}} is only produced 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{loo_pred_measure} comparisons) 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. +} +} +\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 \code{higher_is_better}. 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. +} +} diff --git a/man/pred_measure.Rd b/man/pred_measure.Rd index 380ca194..5452ce29 100644 --- a/man/pred_measure.Rd +++ b/man/pred_measure.Rd @@ -22,15 +22,15 @@ pred_measure( point-prediction measures such as \code{crps}, \code{mae}, and \code{acc}.} \item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} -observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +observations), typically from \code{\link[brms:posterior_predict.brmsfit]{brms::posterior_predict()}}. Required for distributional measures such as \code{crps}, \code{rps}, and \code{scrps}.} \item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from -\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for point-prediction measures such as +\code{\link[brms:posterior_epred.brmsfit]{brms::posterior_epred()}}. Required for point-prediction measures such as \code{mae}, \code{rmse}, \code{r2}, and \code{acc}.} \item{ylp}{Matrix of pointwise log predictive densities or probabilities -(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}. Required for density-based +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik.brmsfit]{brms::log_lik()}}. Required for density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} \item{measure}{Additional measures beyond the base summary \code{elpd} (always @@ -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 @@ -63,13 +86,17 @@ recomputing PSIS weights.} \item{control}{Named list of per-measure settings. Each name must match an 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))}).} +measure's summary function (e.g. \code{list(new_measure = list(add_arg = 10))}). +\code{higher_is_better} selects the scale a measure's values are stored on and +works for built-in and custom measures alike; for a custom measure it is +applied to the returned result rather than passed to the function.} } \value{ An updated object of the same class as \code{predperf}, with new rows in \code{estimates} and columns in \code{pointwise} for each requested measure. Base summaries (\code{elpd} and LOO/k-fold complexity terms such as \code{p_loo}) are not -recomputed. +recomputed. Attribute \code{measure_higher_is_better} is updated for any newly added +measures. } \description{ Extend a \code{"pred_measure"} object with additional measures \strong{without @@ -100,6 +127,31 @@ 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_higher_is_better} attribute}{ + +All \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results include attribute +\code{measure_higher_is_better}: a named list recording the \code{higher_is_better} +setting used for each measure (\code{TRUE} or \code{FALSE} per bare measure name). +Measures left at their natural orientation have no entry, which reads as +\code{NULL}; \code{elpd} is always \code{NULL}. Built-in loss measures such as MSE are +stored on a loss scale by default; pass +\code{control = list(mse = list(higher_is_better = TRUE))} to store values on a +utility scale. The same works for a custom measure, using the name it was +given in \code{measure}. When measures are added incrementally with +\code{\link[=pred_measure]{pred_measure()}}, the attribute is updated for newly computed measures. + +Attribute \code{measure_compare_meta} records per-measure comparison metadata +(\code{higher_is_better}, \code{loss}, and \code{diff_method}) used by \code{\link[=model_compare]{model_compare()}}. +Built-in measures take \code{loss} and \code{diff_method} 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 60ba9954..262bd388 100644 --- a/man/pred_measure_params.Rd +++ b/man/pred_measure_params.Rd @@ -27,15 +27,15 @@ do_pred_measure( point-prediction measures such as \code{crps}, \code{mae}, and \code{acc}.} \item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} -observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +observations), typically from \code{\link[brms:posterior_predict.brmsfit]{brms::posterior_predict()}}. Required for distributional measures such as \code{crps}, \code{rps}, and \code{scrps}.} \item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from -\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for point-prediction measures such as +\code{\link[brms:posterior_epred.brmsfit]{brms::posterior_epred()}}. Required for point-prediction measures such as \code{mae}, \code{rmse}, \code{r2}, and \code{acc}.} \item{ylp}{Matrix of pointwise log predictive densities or probabilities -(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}. Required for density-based +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik.brmsfit]{brms::log_lik()}}. Required for density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} \item{ylp_test}{Matrix of pointwise log predictive densities for holdout @@ -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 @@ -64,7 +87,7 @@ They must return a list with \code{estimates} and \code{pointwise}.} \code{save_psis = TRUE} so that PSIS weights are available for additional measures. See \code{\link[=loo_pred_measure]{loo_pred_measure()}}.} -\item{kfold}{A \code{kfold} object from \code{\link[brms:kfold]{brms::kfold()}}. Supplies ELPD summaries +\item{kfold}{A \code{kfold} object from \code{\link[brms:kfold.brmsfit]{brms::kfold()}}. Supplies ELPD summaries and fold structure for \code{\link[=kfold_pred_measure]{kfold_pred_measure()}}; pass \code{y}, \code{ypred}, and/or \code{mupred} when requesting additional measures.} @@ -85,11 +108,16 @@ functions; required when calling \code{\link[=do_pred_measure]{do_pred_measure() \item{control}{Named list of per-measure settings. Each name must match an element of \code{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))}).} +measure's summary function (e.g. \code{list(new_measure = list(add_arg = 10))}). +\code{higher_is_better} selects the scale a measure's values are stored on and +works for built-in and custom measures alike; for a custom measure it is +applied to the returned result rather than passed to the function.} \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}.} +\code{measure}. A custom measure passed inside a list takes its name from the +list element instead, but \code{attr(my_fun, "measure_loss")} is read in both +forms.} } \description{ Parameter definitions shared by the user-facing entry points and the diff --git a/man/print.loo.Rd b/man/print.loo.Rd index 52e5b4ca..42a37bbe 100644 --- a/man/print.loo.Rd +++ b/man/print.loo.Rd @@ -30,7 +30,7 @@ \arguments{ \item{x}{An object returned by \code{\link[=loo]{loo()}}, \code{\link[=psis]{psis()}}, or \code{\link[=waic]{waic()}}.} -\item{digits}{An integer passed to \code{\link[base:round]{base::round()}}.} +\item{digits}{An integer passed to \code{\link[base:Round]{base::round()}}.} \item{...}{Arguments passed to \code{\link[=plot.psis_loo]{plot.psis_loo()}} if \code{plot_k} is \code{TRUE}.} diff --git a/man/psis.Rd b/man/psis.Rd index 534792d8..0462af97 100644 --- a/man/psis.Rd +++ b/man/psis.Rd @@ -82,7 +82,7 @@ page for details. } } -Objects of class \code{"psis"} also have the following \link{attributes}: +Objects of class \code{"psis"} also have the following \link[=attributes]{attributes}: \describe{ \item{\code{norm_const_log}}{ Vector of precomputed values of \code{colLogSumExps(log_weights)} that are diff --git a/man/sis.Rd b/man/sis.Rd index d39af007..d2663d60 100644 --- a/man/sis.Rd +++ b/man/sis.Rd @@ -67,7 +67,7 @@ A named list containing one vector: } } -Objects of class \code{"sis"} also have the following \link{attributes}: +Objects of class \code{"sis"} also have the following \link[=attributes]{attributes}: \describe{ \item{\code{norm_const_log}}{ Vector of precomputed values of \code{colLogSumExps(log_weights)} that are diff --git a/man/supported_measures_list.Rd b/man/supported_measures_list.Rd index 4b1cb44c..d1595026 100644 --- a/man/supported_measures_list.Rd +++ b/man/supported_measures_list.Rd @@ -1,8 +1,12 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/pred_measure-builtin.R +\docType{data} \name{supported_measures_list} \alias{supported_measures_list} \title{Supported predictive measure names} +\format{ +An object of class \code{character} of length 12. +} \usage{ supported_measures_list } @@ -11,3 +15,4 @@ A character vector of measure names that can be passed to the \code{measure} argument of \code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=loo_pred_measure]{loo_pred_measure()}}, \code{\link[=kfold_pred_measure]{kfold_pred_measure()}}, \code{\link[=test_pred_measure]{test_pred_measure()}}, and \code{\link[=pred_measure]{pred_measure()}}. } +\keyword{datasets} diff --git a/man/test_pred_measure.Rd b/man/test_pred_measure.Rd index 0b3710e9..5f8df2ef 100644 --- a/man/test_pred_measure.Rd +++ b/man/test_pred_measure.Rd @@ -20,15 +20,15 @@ test_pred_measure( point-prediction measures such as \code{crps}, \code{mae}, and \code{acc}.} \item{ypred}{Matrix of posterior predictive draws (\code{S} draws × \code{n} -observations), typically from \code{\link[brms:posterior_predict]{brms::posterior_predict()}}. Required for +observations), typically from \code{\link[brms:posterior_predict.brmsfit]{brms::posterior_predict()}}. Required for distributional measures such as \code{crps}, \code{rps}, and \code{scrps}.} \item{mupred}{Matrix of posterior expected values (\code{S} × \code{n}), typically from -\code{\link[brms:posterior_epred]{brms::posterior_epred()}}. Required for point-prediction measures such as +\code{\link[brms:posterior_epred.brmsfit]{brms::posterior_epred()}}. Required for point-prediction measures such as \code{mae}, \code{rmse}, \code{r2}, and \code{acc}.} \item{ylp}{Matrix of pointwise log predictive densities or probabilities -(\code{S} × \code{n}), typically from \code{\link[brms:log_lik]{brms::log_lik()}}. Required for density-based +(\code{S} × \code{n}), typically from \code{\link[brms:log_lik.brmsfit]{brms::log_lik()}}. Required for density-based summaries (\code{elpd}, \code{mlpd}, \code{ic}).} \item{ylp_test}{Matrix of pointwise log predictive densities for holdout @@ -47,14 +47,40 @@ 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).} \item{control}{Named list of per-measure settings. Each name must match an 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))}).} +measure's summary function (e.g. \code{list(new_measure = list(add_arg = 10))}). +\code{higher_is_better} selects the scale a measure's values are stored on and +works for built-in and custom measures alike; for a custom measure it is +applied to the returned result rather than passed to the function.} } \value{ An object of class \code{"test_pred_measure"} and \code{"pred_measure"} with @@ -79,6 +105,31 @@ training fit. The base summary \code{elpd_test} is computed from \code{ylp_test} on the holdout observations only. } +\section{\code{measure_higher_is_better} attribute}{ + +All \verb{*_pred_measure()} and \code{\link[=pred_measure]{pred_measure()}} results include attribute +\code{measure_higher_is_better}: a named list recording the \code{higher_is_better} +setting used for each measure (\code{TRUE} or \code{FALSE} per bare measure name). +Measures left at their natural orientation have no entry, which reads as +\code{NULL}; \code{elpd} is always \code{NULL}. Built-in loss measures such as MSE are +stored on a loss scale by default; pass +\code{control = list(mse = list(higher_is_better = TRUE))} to store values on a +utility scale. The same works for a custom measure, using the name it was +given in \code{measure}. When measures are added incrementally with +\code{\link[=pred_measure]{pred_measure()}}, the attribute is updated for newly computed measures. + +Attribute \code{measure_compare_meta} records per-measure comparison metadata +(\code{higher_is_better}, \code{loss}, and \code{diff_method}) used by \code{\link[=model_compare]{model_compare()}}. +Built-in measures take \code{loss} and \code{diff_method} 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/tis.Rd b/man/tis.Rd index 1747a64f..46cf30a8 100644 --- a/man/tis.Rd +++ b/man/tis.Rd @@ -69,7 +69,7 @@ A named list containing one vector: } } -Objects of class \code{"tis"} also have the following \link{attributes}: +Objects of class \code{"tis"} also have the following \link[=attributes]{attributes}: \describe{ \item{\code{norm_const_log}}{ Vector of precomputed values of \code{colLogSumExps(log_weights)} that are diff --git a/man/waic.Rd b/man/waic.Rd index 345bd638..f0660497 100644 --- a/man/waic.Rd +++ b/man/waic.Rd @@ -135,6 +135,6 @@ 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[=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..2298e5c7 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,6 +115,29 @@ 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 @@ -138,7 +165,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 +183,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 +198,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? diff --git a/notes/developer-notes.md b/notes/developer-notes.md index 0dd96f5c..28cb6b5d 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,53 @@ Design choices **internal to `pred_measure`** (not a migration from examples end-to-end (penguins fixture exists; confirm test/doc coverage) +### D4: `loo_compare()` for `loo_pred_measure` objects + +**Decision:** Extend existing `loo_compare()` + +- When all inputs are `loo_pred_measure` objects, compute paired + differences for every measure common to all models +- Rank models by `rank_by` (default `"elpd"`); top-ranked model is the + reference for all `{measure}_diff` columns +- ELPD-family measures keep `elpd_diff` / `se_diff`; other measures use + `{measure}_diff` / `{measure}_se_diff` +- `p_worse` and `diag_diff` apply to ELPD only; `diag_elpd` per model as + before +- Loss measures (MSE, RMSE, MAE, IC, Brier score, SRPS) 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 `measure_compare_meta` and `measure_higher_is_better` 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 (for `loo_compare`):** Each `*_pred_measure()` result stores + `higher_is_better` per measure in `measure_higher_is_better` and comparison + metadata in `measure_compare_meta` (`higher_is_better`, `loss`, + `diff_method`). Built-in loss measures are sign-flipped for utility-scale + `{measure}_diff` when stored on a loss scale (`higher_is_better = NULL` with + `loss = TRUE`). +- **Still open:** Whether to expose orientation metadata on `*_pred_measure()` + results themselves beyond the attributes above (e.g. when + `higher_is_better = TRUE` in `control`). ### D3: Handling of `r_eff` @@ -163,7 +206,7 @@ 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 - [ ] Resolve `r_eff` handling *(see D3)* ### Implementation @@ -181,8 +224,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 +244,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,7 +281,7 @@ 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, higher_is_better = FALSE)` | Sign flip on 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 | @@ -245,7 +290,7 @@ estimators. 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 + 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)`. @@ -295,7 +340,7 @@ replications *Figure: 200 simulations (S = 100, n = 30). Left — `crps()` vs -`measure_rps(revert_sign = TRUE)`; right — `scrps()` vs +`measure_rps(higher_is_better = FALSE)`; 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/_problems/test_compare-222.R b/tests/testthat/_problems/test_compare-222.R new file mode 100644 index 00000000..35d24aed --- /dev/null +++ b/tests/testthat/_problems/test_compare-222.R @@ -0,0 +1,40 @@ +# Extracted from test_compare.R:222 + +# setup ------------------------------------------------------------------------ +library(testthat) +test_env <- simulate_test_env(package = "loo", path = "..") +attach(test_env, warn.conflicts = FALSE) + +# prequel ---------------------------------------------------------------------- +set.seed(123) +LLarr <- example_loglik_array() +LLarr2 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 0.5), dim = dim(LLarr)) +LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr)) +w1 <- suppressWarnings(waic(LLarr)) +w2 <- suppressWarnings(waic(LLarr2)) + +# test ------------------------------------------------------------------------- +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(loo_compare(list(m1 = pm1, m2 = pm2, m3 = pm3))) +expect_snapshot(print(comp)) diff --git a/tests/testthat/_problems/test_compare-223.R b/tests/testthat/_problems/test_compare-223.R new file mode 100644 index 00000000..ab27c0de --- /dev/null +++ b/tests/testthat/_problems/test_compare-223.R @@ -0,0 +1,41 @@ +# Extracted from test_compare.R:223 + +# setup ------------------------------------------------------------------------ +library(testthat) +test_env <- simulate_test_env(package = "loo", path = "..") +attach(test_env, warn.conflicts = FALSE) + +# prequel ---------------------------------------------------------------------- +set.seed(123) +LLarr <- example_loglik_array() +LLarr2 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 0.5), dim = dim(LLarr)) +LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr)) +w1 <- suppressWarnings(waic(LLarr)) +w2 <- suppressWarnings(waic(LLarr2)) + +# test ------------------------------------------------------------------------- +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(loo_compare(list(m1 = pm1, m2 = pm2, m3 = pm3))) +expect_snapshot(print(comp)) +expect_snapshot(print(comp, measures = "all", digits = 2)) diff --git a/tests/testthat/_problems/test_compare-224.R b/tests/testthat/_problems/test_compare-224.R new file mode 100644 index 00000000..540033e4 --- /dev/null +++ b/tests/testthat/_problems/test_compare-224.R @@ -0,0 +1,42 @@ +# Extracted from test_compare.R:224 + +# setup ------------------------------------------------------------------------ +library(testthat) +test_env <- simulate_test_env(package = "loo", path = "..") +attach(test_env, warn.conflicts = FALSE) + +# prequel ---------------------------------------------------------------------- +set.seed(123) +LLarr <- example_loglik_array() +LLarr2 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 0.5), dim = dim(LLarr)) +LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr)) +w1 <- suppressWarnings(waic(LLarr)) +w2 <- suppressWarnings(waic(LLarr2)) + +# test ------------------------------------------------------------------------- +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(loo_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"))) diff --git a/tests/testthat/_problems/test_compare-261.R b/tests/testthat/_problems/test_compare-261.R new file mode 100644 index 00000000..6063bfa8 --- /dev/null +++ b/tests/testthat/_problems/test_compare-261.R @@ -0,0 +1,40 @@ +# Extracted from test_compare.R:261 + +# setup ------------------------------------------------------------------------ +library(testthat) +test_env <- simulate_test_env(package = "loo", path = "..") +attach(test_env, warn.conflicts = FALSE) + +# prequel ---------------------------------------------------------------------- +set.seed(123) +LLarr <- example_loglik_array() +LLarr2 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 0.5), dim = dim(LLarr)) +LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr)) +w1 <- suppressWarnings(waic(LLarr)) +w2 <- suppressWarnings(waic(LLarr2)) + +# test ------------------------------------------------------------------------- +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(loo_compare(list(m1 = pm1, m2 = pm2, m3 = pm3))) +expect_snapshot(print(comp)) diff --git a/tests/testthat/_problems/test_compare-262.R b/tests/testthat/_problems/test_compare-262.R new file mode 100644 index 00000000..251a31a6 --- /dev/null +++ b/tests/testthat/_problems/test_compare-262.R @@ -0,0 +1,36 @@ +# Extracted from test_compare.R:262 + +# prequel ---------------------------------------------------------------------- +set.seed(123) +LLarr <- example_loglik_array() +LLarr2 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 0.5), dim = dim(LLarr)) +LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr)) +w1 <- suppressWarnings(waic(LLarr)) +w2 <- suppressWarnings(waic(LLarr2)) + +# test ------------------------------------------------------------------------- +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(loo_compare(list(m1 = pm1, m2 = pm2, m3 = pm3))) +expect_snapshot(print(comp)) +expect_snapshot(print(comp, measures = "all", digits = 2)) diff --git a/tests/testthat/_problems/test_compare-263.R b/tests/testthat/_problems/test_compare-263.R new file mode 100644 index 00000000..f2e08af1 --- /dev/null +++ b/tests/testthat/_problems/test_compare-263.R @@ -0,0 +1,37 @@ +# Extracted from test_compare.R:263 + +# prequel ---------------------------------------------------------------------- +set.seed(123) +LLarr <- example_loglik_array() +LLarr2 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 0.5), dim = dim(LLarr)) +LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr)) +w1 <- suppressWarnings(waic(LLarr)) +w2 <- suppressWarnings(waic(LLarr2)) + +# test ------------------------------------------------------------------------- +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(loo_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"))) diff --git a/tests/testthat/_problems/test_compare-267.R b/tests/testthat/_problems/test_compare-267.R new file mode 100644 index 00000000..bed3897a --- /dev/null +++ b/tests/testthat/_problems/test_compare-267.R @@ -0,0 +1,47 @@ +# Extracted from test_compare.R:267 + +# setup ------------------------------------------------------------------------ +library(testthat) +test_env <- simulate_test_env(package = "loo", path = "..") +attach(test_env, warn.conflicts = FALSE) + +# prequel ---------------------------------------------------------------------- +set.seed(123) +LLarr <- example_loglik_array() +LLarr2 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 0.5), dim = dim(LLarr)) +LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr)) +w1 <- suppressWarnings(waic(LLarr)) +w2 <- suppressWarnings(waic(LLarr2)) + +# test ------------------------------------------------------------------------- +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)) + ) + 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") + expected <- comp$model[order(comp[[diff_col]], decreasing = TRUE)] + expect_equal(printed_order(comp, measure), expected) + # the best model on the measure leads, and the table runs downhill + expect_equal(expected[[1L]], comp$model[[which.max(comp[[diff_col]])]]) + expect_false(is.unsorted(rev(comp[[diff_col]][order(comp[[diff_col]])]))) + } + } diff --git a/tests/testthat/_problems/test_compare-782.R b/tests/testthat/_problems/test_compare-782.R new file mode 100644 index 00000000..e6e704bb --- /dev/null +++ b/tests/testthat/_problems/test_compare-782.R @@ -0,0 +1,82 @@ +# Extracted from test_compare.R:782 + +# setup ------------------------------------------------------------------------ +library(testthat) +test_env <- simulate_test_env(package = "loo", path = "..") +attach(test_env, warn.conflicts = FALSE) + +# prequel ---------------------------------------------------------------------- +set.seed(123) +LLarr <- example_loglik_array() +LLarr2 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 0.5), dim = dim(LLarr)) +LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr)) +w1 <- suppressWarnings(waic(LLarr)) +w2 <- suppressWarnings(waic(LLarr2)) +.make_bacc_pms <- function(bias = 0.6, higher_is_better = NULL) { + 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", + control = list(bacc = list(higher_is_better = higher_is_better)) + )) + } + list(pm1 = make(res$mupred), pm2 = make(biased), y = y) +} + +# test ------------------------------------------------------------------------- +res <- readRDS("data-for-tests/test_data_roaches_compare.Rds") +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( + 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_equal( + attr(pms[[1L]], "measure_compare_meta")$my_rmse$diff_method, + "custom" + ) +expect_null(attr(pms[[1L]], "measure_compare_meta")$my_rmse$se_diff_fun) +expect_equal( + loo:::.measure_pointwise_diff_method(pms, "my_rmse_loo"), + "custom" + ) +expect_error( + suppressMessages(model_compare(pms)), + "my_rmse.*custom measure.*must be supplied" + ) +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"] + )) +comp_fn <- suppressMessages( + model_compare(pms, custom_se_fn = loo:::.se_diff_rmse) + ) +expect_false(any(is.na(comp_fn$my_rmse_se_diff))) +expect_gt(comp_fn$my_rmse_se_diff[[2L]], 0) diff --git a/tests/testthat/_problems/test_compare-790.R b/tests/testthat/_problems/test_compare-790.R new file mode 100644 index 00000000..4327f9da --- /dev/null +++ b/tests/testthat/_problems/test_compare-790.R @@ -0,0 +1,88 @@ +# Extracted from test_compare.R:790 + +# setup ------------------------------------------------------------------------ +library(testthat) +test_env <- simulate_test_env(package = "loo", path = "..") +attach(test_env, warn.conflicts = FALSE) + +# prequel ---------------------------------------------------------------------- +set.seed(123) +LLarr <- example_loglik_array() +LLarr2 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 0.5), dim = dim(LLarr)) +LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr)) +w1 <- suppressWarnings(waic(LLarr)) +w2 <- suppressWarnings(waic(LLarr2)) +.make_bacc_pms <- function(bias = 0.6, higher_is_better = NULL) { + 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", + control = list(bacc = list(higher_is_better = higher_is_better)) + )) + } + list(pm1 = make(res$mupred), pm2 = make(biased), y = y) +} + +# test ------------------------------------------------------------------------- +res <- readRDS("data-for-tests/test_data_roaches_compare.Rds") +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( + 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_equal( + attr(pms[[1L]], "measure_compare_meta")$my_rmse$diff_method, + "custom" + ) +expect_null(attr(pms[[1L]], "measure_compare_meta")$my_rmse$se_diff_fun) +expect_equal( + loo:::.measure_pointwise_diff_method(pms, "my_rmse_loo"), + "custom" + ) +expect_error( + suppressMessages(model_compare(pms)), + "my_rmse.*custom measure.*must be supplied" + ) +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"] + )) +comp_fn <- suppressMessages( + model_compare(pms, custom_se_fn = loo:::.se_diff_rmse) + ) +expect_false(any(is.na(comp_fn$my_rmse_se_diff))) +expect_gt(comp_fn$my_rmse_se_diff[[2L]], 0) +expect_equal(comp_fn$my_rmse_diff, comp_null$my_rmse_diff) +pair <- loo:::.pair_measure_stats( + pms[[2L]], pms[[1L]], "my_rmse_loo", + loos = pms, se_fn = loo:::.se_diff_rmse + ) +expect_equal(unname(pair["se"]), comp_fn$my_rmse_se_diff[[2L]]) diff --git a/tests/testthat/_problems/test_compare-900.R b/tests/testthat/_problems/test_compare-900.R new file mode 100644 index 00000000..0e392c71 --- /dev/null +++ b/tests/testthat/_problems/test_compare-900.R @@ -0,0 +1,76 @@ +# Extracted from test_compare.R:900 + +# setup ------------------------------------------------------------------------ +library(testthat) +test_env <- simulate_test_env(package = "loo", path = "..") +attach(test_env, warn.conflicts = FALSE) + +# prequel ---------------------------------------------------------------------- +set.seed(123) +LLarr <- example_loglik_array() +LLarr2 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 0.5), dim = dim(LLarr)) +LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr)) +w1 <- suppressWarnings(waic(LLarr)) +w2 <- suppressWarnings(waic(LLarr2)) +.make_bacc_pms <- function(bias = 0.6, higher_is_better = NULL) { + 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", + control = list(bacc = list(higher_is_better = higher_is_better)) + )) + } + list(pm1 = make(res$mupred), pm2 = make(biased), y = y) +} + +# test ------------------------------------------------------------------------- +res <- readRDS("data-for-tests/test_data_roaches_compare.Rds") +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_compare_meta")$my_mse$loss) +expect_true(loo:::.measure_is_loss("my_mse_loo", declared)) +expect_true(loo:::.measure_lower_is_better("my_mse_loo", declared)) +expect_false(loo:::.measure_lower_is_better("my_mse_loo", plain)) +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) +expect_equal(comp$my_mse_diff, -comp_plain$my_mse_diff) diff --git a/tests/testthat/_problems/test_compare-901.R b/tests/testthat/_problems/test_compare-901.R new file mode 100644 index 00000000..191fb917 --- /dev/null +++ b/tests/testthat/_problems/test_compare-901.R @@ -0,0 +1,77 @@ +# Extracted from test_compare.R:901 + +# setup ------------------------------------------------------------------------ +library(testthat) +test_env <- simulate_test_env(package = "loo", path = "..") +attach(test_env, warn.conflicts = FALSE) + +# prequel ---------------------------------------------------------------------- +set.seed(123) +LLarr <- example_loglik_array() +LLarr2 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 0.5), dim = dim(LLarr)) +LLarr3 <- array(rnorm(prod(dim(LLarr)), c(LLarr), 1), dim = dim(LLarr)) +w1 <- suppressWarnings(waic(LLarr)) +w2 <- suppressWarnings(waic(LLarr2)) +.make_bacc_pms <- function(bias = 0.6, higher_is_better = NULL) { + 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", + control = list(bacc = list(higher_is_better = higher_is_better)) + )) + } + list(pm1 = make(res$mupred), pm2 = make(biased), y = y) +} + +# test ------------------------------------------------------------------------- +res <- readRDS("data-for-tests/test_data_roaches_compare.Rds") +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_compare_meta")$my_mse$loss) +expect_true(loo:::.measure_is_loss("my_mse_loo", declared)) +expect_true(loo:::.measure_lower_is_better("my_mse_loo", declared)) +expect_false(loo:::.measure_lower_is_better("my_mse_loo", plain)) +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) +expect_equal(comp$my_mse_diff, -comp_plain$my_mse_diff) +expect_equal(comp$my_mse_se_diff, comp_plain$my_mse_se_diff) diff --git a/tests/testthat/_snaps/compare.md b/tests/testthat/_snaps/compare.md index 8abb5cf3..6f99cad2 100644 --- a/tests/testthat/_snaps/compare.md +++ b/tests/testthat/_snaps/compare.md @@ -1,3 +1,117 @@ +# loo_compare works with three loo_pred_measure models + + Code + print(comp) + Message + Models ranked by mae (reference: C). + Output + model mae_diff mae_se_diff diag_elpd + C 0.0 0.0 13 k_psis > 0.62 + B -0.1 0.7 9 k_psis > 0.62 + A -7.6 1.7 25 k_psis > 0.62 + Message + + Diagnostic flags present. + See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`) + or https://mc-stan.org/loo/reference/loo-glossary.html. + + Other measures compared: elpd, r2. Use print(x, measures = "all"). + +# loo_compare informs when measure signs are converted + + Code + comp <- loo_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 + model elpd_diff se_diff p_worse diag_diff diag_elpd + m3 0.0 0.0 NA 13 k_psis > 0.62 + m2 -219.0 221.6 0.84 9 k_psis > 0.62 + m1 -2764.4 634.3 1.00 25 k_psis > 0.62 + Message + + Diagnostic flags present. + See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`) + or https://mc-stan.org/loo/reference/loo-glossary.html. + + Other measures compared: r2, mae. Each is compared against its own best model (r2: m2). Use print(x, measures = "all"). + +--- + + Code + print(comp, measures = "all", digits = 2) + Output + + -- elpd (vs m3) -- + model elpd_diff se_diff p_worse diag_diff diag_elpd + m3 0.00 0.00 NA 13 k_psis > 0.62 + m2 -218.98 221.65 0.84 9 k_psis > 0.62 + m1 -2764.42 634.26 1.00 25 k_psis > 0.62 + + -- r2 (vs m2) -- + model r2_diff r2_se_diff + m2 0.00 0.00 + m3 -0.01 0.07 + m1 -0.22 0.09 + + -- mae (vs m3) -- + model mae_diff mae_se_diff + m3 0.00 0.00 + m2 -0.08 0.71 + m1 -7.64 1.68 + 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 + + -- r2 (vs m2) -- + model r2_diff r2_se_diff + m2 0.0 0.0 + m3 0.0 0.1 + m1 -0.2 0.1 + + -- mae (vs m3) -- + model mae_diff mae_se_diff + m3 0.0 0.0 + m2 -0.1 0.7 + m1 -7.6 1.7 + 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) + Message + Models ranked by mae (reference: m2). + Output + model mae_diff mae_se_diff diag_elpd + m2 0.0 0.0 9 k_psis > 0.62 + m1 -7.6 1.5 25 k_psis > 0.62 + Message + + Diagnostic flags present. + See ?`loo-glossary` (sections `diag_diff` and `diag_elpd`) + or https://mc-stan.org/loo/reference/loo-glossary.html. + + Other measures compared: elpd, r2. Use print(x, measures = "all"). + # loo_compare returns expected results (2 models) WAoAAAACAAQEAgACAwAAAAMTAAAADAAAABAAAAACAAQACQAAAAZtb2RlbDEABAAJAAAABm1v diff --git a/tests/testthat/data-for-tests/test_data_generation.R b/tests/testthat/data-for-tests/test_data_generation.R index 3b05b39a..07691fab 100644 --- a/tests/testthat/data-for-tests/test_data_generation.R +++ b/tests/testthat/data-for-tests/test_data_generation.R @@ -105,6 +105,40 @@ get_binary_res <- function() { ) } +get_bacc_compare_res <- function() { + # Binary example for the model-comparison vignette: the same outcome is + # modelled once with the predictor that generated it (x) and once with a + # noisy version of that predictor (w), so that the two models classify part + # of the observations differently. + 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 = bernoulli(), + prior = 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 + ) + + list(fit_x = fit_bacc_x, fit_w = fit_bacc_w) +} + get_roaches_res <- function() { data(roaches, package = "rstanarm") roaches$sqrt_roach1 <- sqrt(roaches$roach1) @@ -125,6 +159,52 @@ 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, + overwrite = TRUE + ) + + fit_p_m1 <- update(fit_p, formula = y ~ treatment + senior) |> + add_criterion(criterion = "loo", moment_match = TRUE) + fit_p_m2 <- update(fit_p, formula = y ~ sqrt_roach1 + senior) |> + add_criterion(criterion = "loo", moment_match = TRUE) + fit_p_m3 <- update(fit_p, formula = y ~ sqrt_roach1 + treatment) |> + add_criterion(criterion = "loo", moment_match = TRUE) + + return(list( + y = fit_p$data$y, + loo_p = fit_p$loo, + mupred = brms::posterior_epred(fit_p), + ylp = brms::log_lik(fit_p), + loo_p_m1 = fit_p_m1$loo, + mupred_m1 = brms::posterior_epred(fit_p_m1), + ylp_m1 = brms::log_lik(fit_p_m1), + loo_p_m2 = fit_p_m2$loo, + mupred_m2 = brms::posterior_epred(fit_p_m2), + ylp_m2 = brms::log_lik(fit_p_m2), + loo_p_m3 = fit_p_m3$loo, + 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") @@ -256,10 +336,13 @@ generate_test_data <- function(vignettes_only = FALSE) { 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() + full_bacc <- get_bacc_compare_res() if (!vignettes_only) { test_path <- "tests/testthat/data-for-tests/" saveRDS(full_roaches$res, paste0(test_path, "test_data_roaches.Rds")) + saveRDS(full_roaches_compare, paste0(test_path, "test_data_roaches_compare.Rds")) saveRDS(full_binary$res, paste0(test_path, "test_data_binary.Rds")) saveRDS(full_penguins$res, paste0(test_path, "test_data_penguins.Rds")) saveRDS(full_binomial$res, paste0(test_path, "test_data_binomial.Rds")) @@ -275,6 +358,8 @@ generate_test_data <- function(vignettes_only = FALSE) { saveRDS(full_penguins$fit, paste0(vignette_path, "fit_penguins.Rds")) saveRDS(full_binomial$fit, paste0(vignette_path, "fit_binomial.Rds")) saveRDS(full_sleep$fit, paste0(vignette_path, "fit_sleep.Rds")) + saveRDS(full_bacc$fit_x, paste0(vignette_path, "fit_bacc_x.Rds")) + saveRDS(full_bacc$fit_w, paste0(vignette_path, "fit_bacc_w.Rds")) message("Saved vignette fits to ", vignette_path) elapsed_min <- round((proc.time() - t0)[3] / 60, 1) 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..efcf2dac 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 4a00a10a..572ef687 100644 --- a/tests/testthat/test_compare.R +++ b/tests/testthat/test_compare.R @@ -10,14 +10,14 @@ test_that("loo_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(loo_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)), "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(loo_compare(w1), "At least two models are required for comparison") + expect_error(loo_compare(x = list(w1)), "At least two models are required for comparison") expect_error( loo_compare(w1, w3), "All models must have the same number of observations, but models have inconsistent observation counts: 'model1' (32), 'model2' (31)", @@ -35,6 +35,1365 @@ test_that("loo_compare throws appropriate errors", { ) }) +test_that("loo_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(loo_compare(pm1, pm2)) + expect_s3_class(comp, "compare.loo") + expect_null(attr(comp, "rank_by")) + 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( + loo_compare(w1, pm1), + "Cannot mix 'pred_measure' objects with plain 'loo' objects", + fixed = TRUE + ) + expect_error( + loo_compare(pm1), + "At least two models are required for comparison", + fixed = TRUE + ) + expect_null(attr(loo_compare(w1, w2), "rank_by")) +}) + +test_that("loo_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(loo_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("loo_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 <- loo_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"), "mae") + 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)) + expect_true(all(comp$elpd_diff[-1L] <= 0)) + expect_equal(attr(comp, "sign_converted_measures"), c("mae")) +}) + +test_that("loo_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 <- loo_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(loo_compare(pm_elpd, pm_elpd)) +}) + +test_that("loo_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 <- loo_compare(pm1, pm2, rank_by = "elpd") + comp_mse <- loo_compare(pm1, pm2, rank_by = "mae") + expect_equal(attr(comp_elpd, "rank_by"), "elpd") + expect_equal(attr(comp_mse, "rank_by"), "mae") + 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)) + } + + # mse and elpd disagree here, which is the point of the per-measure reference + expect_false(identical(refs[["mse"]], refs[["elpd"]])) + + # `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)) + ) + 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(loo_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"))) + + comp_mae <- suppressMessages(loo_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("loo_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_higher_is_better")$mse, NULL) + expect_equal(attr(pm1, "measure_higher_is_better")$r2, NULL) + expect_equal(attr(pm1, "measure_higher_is_better")$elpd, NULL) + expect_equal(attr(pm1, "measure_compare_meta")$elpd$diff_method, "sum") + expect_equal(attr(pm1, "measure_compare_meta")$mse$loss, TRUE) + expect_equal(attr(pm1, "measure_compare_meta")$mse$diff_method, "mean") + expect_equal(attr(pm1, "measure_compare_meta")$r2$diff_method, "measure_specific") + expect_equal(attr(pm1, "measure_compare_meta")$r2$se_diff_fun, "r2") + expect_equal( + attr(pm1, "measure_compare_meta")$r2$extra$mse_y_i, + (res$y - mean(res$y))^2 + ) + # only measures that need it carry `extra` + expect_null(attr(pm1, "measure_compare_meta")$mse$extra) + expect_true(loo:::.measure_lower_is_better("mse_loo", loos)) + expect_false(loo:::.measure_lower_is_better("r2_loo", loos)) + expect_true(loo:::.measure_lower_is_better("mse_loo")) + expect_false(loo:::.measure_lower_is_better("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(loo_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(loo_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 se_diff is invariant to `higher_is_better`", { + res <- readRDS("data-for-tests/test_data_roaches_compare.Rds") + make <- function(loo, mupred, ylp, higher_is_better) { + loo_pred_measure( + loo = loo, + y = res$y, + mupred = mupred, + ylp = ylp, + measure = "r2", + control = list(r2 = list(higher_is_better = higher_is_better)) + ) + } + + utility <- list( + make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, TRUE), + make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, TRUE) + ) + loss <- list( + make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, FALSE), + make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, FALSE) + ) + + # r2 is naturally a utility, so `higher_is_better = FALSE` is the flipped one + expect_equal(loo:::.measure_natural_sign("r2_loo", utility), 1) + expect_equal(loo:::.measure_natural_sign("r2_loo", loss), -1) + + # the baseline is a property of `y`, so it is never sign-flipped + expect_equal( + attr(loss[[1L]], "measure_compare_meta")$r2$extra$mse_y_i, + attr(utility[[1L]], "measure_compare_meta")$r2$extra$mse_y_i + ) + + pair_utility <- loo:::.pair_measure_stats( + utility[[2L]], utility[[1L]], "r2_loo", loos = utility + ) + pair_loss <- loo:::.pair_measure_stats( + loss[[2L]], loss[[1L]], "r2_loo", loos = loss + ) + expect_equal(unname(pair_loss["se"]), unname(pair_utility["se"])) + expect_equal(unname(pair_loss["diff"]), unname(pair_utility["diff"])) +}) + +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_compare_meta") + meta$r2$extra <- NULL + attr(x, "measure_compare_meta") <- 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(loo_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(loo_compare(stale1, pm2)) + expect_false(anyNA(mixed$r2_se_diff)) +}) + +test_that("rmse se_diff is invariant to `higher_is_better`", { + res <- readRDS("data-for-tests/test_data_roaches_compare.Rds") + make <- function(loo, mupred, ylp, higher_is_better) { + loo_pred_measure( + loo = loo, + y = res$y, + mupred = mupred, + ylp = ylp, + measure = "rmse", + control = list(rmse = list(higher_is_better = higher_is_better)) + ) + } + + loss <- list( + make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, FALSE), + make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, FALSE) + ) + utility <- list( + make(res$loo_p_m1, res$mupred_m1, res$ylp_m1, TRUE), + make(res$loo_p_m2, res$mupred_m2, res$ylp_m2, TRUE) + ) + + # stored on opposite scales, so the natural scale must be restored before the + # square roots and ratios of the delta method are applied + expect_equal(loo:::.measure_natural_sign("rmse_loo", loss), 1) + expect_equal(loo:::.measure_natural_sign("rmse_loo", utility), -1) + + pair_loss <- loo:::.pair_measure_stats( + loss[[2L]], loss[[1L]], "rmse_loo", loos = loss + ) + pair_utility <- loo:::.pair_measure_stats( + utility[[2L]], utility[[1L]], "rmse_loo", loos = utility + ) + expect_equal(unname(pair_loss["se"]), unname(pair_utility["se"])) + expect_equal(unname(pair_loss["diff"]), unname(pair_utility["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, higher_is_better = NULL) { + 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", + control = list(bacc = list(higher_is_better = higher_is_better)) + )) + } + 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_compare_meta")$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_compare_meta")$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(loo_compare(pm1, pm2)) + expect_false(anyNA(comp$bacc_se_diff)) + expect_equal(comp$bacc_se_diff[1], 0) +}) + +test_that("bacc se_diff is invariant to `higher_is_better`", { + utility <- .make_bacc_pms(higher_is_better = TRUE) + loss <- .make_bacc_pms(higher_is_better = FALSE) + + # bacc is naturally a utility, so `higher_is_better = FALSE` is the flipped one + expect_equal( + loo:::.measure_natural_sign("bacc_loo", list(utility$pm1, utility$pm2)), 1 + ) + expect_equal( + loo:::.measure_natural_sign("bacc_loo", list(loss$pm1, loss$pm2)), -1 + ) + + # the strata are a property of `y`, so they are never sign-flipped + expect_equal( + attr(loss$pm1, "measure_compare_meta")$bacc$extra$class_id, + attr(utility$pm1, "measure_compare_meta")$bacc$extra$class_id + ) + + pair_utility <- loo:::.pair_measure_stats( + utility$pm2, utility$pm1, "bacc_loo", loos = list(utility$pm1, utility$pm2) + ) + pair_loss <- loo:::.pair_measure_stats( + loss$pm2, loss$pm1, "bacc_loo", loos = list(loss$pm1, loss$pm2) + ) + expect_equal(unname(pair_loss["se"]), unname(pair_utility["se"])) + expect_equal(unname(pair_loss["diff"]), unname(pair_utility["diff"])) +}) + +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_compare_meta") + meta$bacc$extra <- NULL + attr(x, "measure_compare_meta") <- 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(loo_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(loo_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_compare_meta")$my_rmse$diff_method, + "custom" + ) + expect_null(attr(pms[[1L]], "measure_compare_meta")$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_compare_meta")$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_compare_meta")$my_mse$loss) + expect_true(loo:::.measure_is_loss("my_mse_loo", declared)) + expect_true(loo:::.measure_lower_is_better("my_mse_loo", declared)) + expect_false(loo:::.measure_lower_is_better("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 comparison metadata" + ) +}) + +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 loo_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(loo_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(loo_compare(one)), + "must be supplied" + ) +}) + +test_that("loo_compare errors on inconsistent measure metadata", { + 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", + control = list(mse = list(higher_is_better = NULL)) + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m2, + y = res$y, + mupred = res$mupred_m2, + ylp = res$ylp_m2, + measure = "mse", + control = list(mse = list(higher_is_better = TRUE)) + ) + + expect_error( + suppressMessages(loo_compare(pm1, pm2)), + "disagree on comparison metadata for measure 'mse'" + ) +}) + +test_that("loo_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" + ) + compare_meta <- attr(pm2, "measure_compare_meta") + compare_meta$mse <- NULL + attr(pm2, "measure_compare_meta") <- compare_meta + + expect_error( + suppressMessages(loo_compare(pm1, pm2)), + "Not all models provide comparison metadata for measure 'mse'" + ) +}) + +test_that("loo_compare warns when rank_by is ignored for classic loo objects", { + expect_warning( + loo_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("loo_compare works for all built-in measures", { + res <- readRDS("data-for-tests/test_data_roaches_compare.Rds") + res_roaches <- readRDS("data-for-tests/test_data_roaches.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(loo_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_roaches$ypred, + ylp = res$ylp_m1, + measure = measure + ) + pm2 <- loo_pred_measure( + loo = res$loo_p_m2, + y = res$y, + ypred = res_roaches$ypred, + ylp = res$ylp_m2, + measure = measure + ) + comp <- suppressMessages(loo_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(loo_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("loo_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(loo_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(loo_compare(pm_list_short))) +}) + test_that("loo_compare throws appropriate warnings", { w3 <- w1 w4 <- w2 @@ -214,3 +1573,265 @@ 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"), "mae") + 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_null(attr(pinned, "rank_by")) + expect_equal(attr(pinned, "compare_ref_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_message(print(pinned), "All measures compared against model m1") +}) + +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, "compare_ref_model"), "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"), "mse") + expect_null(attr(comp, "compare_ref_model")) + + expect_error( + suppressMessages(model_compare(pms, rank_by = 1)), + "`rank_by` must be a single measure name or model name", + fixed = TRUE + ) +}) + +test_that("loo_compare remains a working alias for model_compare", { + 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_identical( + suppressMessages(loo_compare(list(m1 = k1, m2 = k2))), + suppressMessages(model_compare(list(m1 = k1, m2 = k2))) + ) + expect_identical(loo_compare(w1, w2), model_compare(w1, w2)) + + # `loo_compare` is still a generic, so 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 + ) +}) diff --git a/tests/testthat/test_pred_measure.R b/tests/testthat/test_pred_measure.R index e6f08170..d43d14a5 100644 --- a/tests/testthat/test_pred_measure.R +++ b/tests/testthat/test_pred_measure.R @@ -472,4 +472,98 @@ test_that("insample_pred_measure() accepts mixed built-in and custom measures", ) expect_true(all(c("r2", "custom_rmse") %in% rownames(res$estimates))) +}) + +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_compare_meta")$custom_mse$loss) + + attr(custom_mse, "measure_loss") <- TRUE + loss <- insample_pred_measure( + y = y, mupred = mupred, ylp = ylp, measure = custom_mse + ) + meta <- attr(loss, "measure_compare_meta")$custom_mse + expect_true(meta$loss) + expect_null(meta$higher_is_better) + # 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` reorients a custom measure", { + 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 + ) + flipped <- insample_pred_measure( + y = y, mupred = mupred, ylp = ylp, measure = custom_mse, + control = list(custom_mse = list(higher_is_better = TRUE)) + ) + + expect_equal( + flipped$estimates["custom_mse", "Estimate"], + -natural$estimates["custom_mse", "Estimate"] + ) + # the standard error is invariant to the sign + expect_equal( + flipped$estimates["custom_mse", "SE"], + natural$estimates["custom_mse", "SE"] + ) + expect_equal( + flipped$pointwise[, "custom_mse"], + -natural$pointwise[, "custom_mse"] + ) + + expect_true(attr(flipped, "measure_higher_is_better")$custom_mse) + meta <- attr(flipped, "measure_compare_meta")$custom_mse + # `higher_is_better` records the stored scale, `loss` what the measure is + expect_true(meta$higher_is_better) + expect_true(meta$loss) + + # a custom utility is flipped by `higher_is_better = FALSE` instead + attr(custom_mse, "measure_loss") <- FALSE + as_utility <- insample_pred_measure( + y = y, mupred = mupred, ylp = ylp, measure = custom_mse, + control = list(custom_mse = list(higher_is_better = FALSE)) + ) + expect_equal( + as_utility$estimates["custom_mse", "Estimate"], + -natural$estimates["custom_mse", "Estimate"] + ) }) \ No newline at end of file diff --git a/tests/testthat/test_pred_measure_helpers.R b/tests/testthat/test_pred_measure_helpers.R index 1443d30e..cdf56298 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")), @@ -162,9 +182,43 @@ 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(higher_is_better = TRUE)), + 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) + + # a formal of the custom function, and the reserved `higher_is_better` + expect_silent( + .validate_control(list(custom_huber = list(delta = 2)), entries) + ) + expect_silent( + .validate_control( + list(custom_huber = list(higher_is_better = TRUE)), + entries + ) + ) + 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/comparison-standard-errors.Rmd b/vignettes/articles-online-only/comparison-standard-errors.Rmd new file mode 100644 index 00000000..d7c0c9ca --- /dev/null +++ b/vignettes/articles-online-only/comparison-standard-errors.Rmd @@ -0,0 +1,850 @@ +--- +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{comparison-standard-errors} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + + + +```{r, child="../children/SEE-ONLINE.txt", eval = if (isTRUE(exists("params"))) !params$EVAL else TRUE} +``` + +```{r setup, include=FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + message = FALSE, + warning = FALSE, + eval = params$EVAL, + fig.width = 7, + fig.height = 4, + fig.align = "center" +) +devtools::load_all(".") +``` + +::: {.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? ++ Currently, `elpd` is computed by default in pred_measure. This is also helpful, when we want to have it by default in model_compare. Question is whether we want this default behavior. +::: + +::: {.callout .callout-note} +**Acknowledgements** + +We thank Aki Vehtari and Frank Weber 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 Vignette [TODO] for an overview). +Additionally, it is possible to define a custom performance criteria. + +The `model_compare()` function accepts any object that inherits from the `loo` +class. This includes outputs from: + ++ `loo()`, `kfold()`, `waic()`, and 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-tip} +**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 introdued `model_compare`. While `model_compare` retains full +backward compatibility, it also expands functionality to handle outputs from +the `pred_measure` family. + +Both functions will remain available for the time being, though `loo_compare` +will be removed in a future release. For more details, please see our +**Migration guide**[TODO]. +::: + +## Running example (count data) + +To illustrate the funcationality of `model_compare()` we introduce first a +*running example*. In this example, we compare three Poisson regression +models fitted on the **`roaches` data** from `rstanarm` [CITE]. 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 five predictive performance measures: +`elpd`, `mae`, `mse`, `rmse`, and `r2` computed by `loo_pred_measure`. + + + +```{r setup-example} +measures <- c("mae", "mse", "rmse", "r2") # elpd is computed by default +``` + +**Preview: Glimpse into the model comparison results** + +As the actual model building workflow is not focus of this tutorial, we skip +this part and load the results from a pre-fitted object in the variable `res`. +Then, we 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()`. + +```{r example} +path <- "../../tests/testthat/data-for-tests/test_data_roaches_compare.Rds" +res <- readRDS(path) + +fit_measure <- function(i, measure) { + loo_pred_measure( + y = res$y, + mupred = res[[paste0("mupred_m", i)]], + ylp = res[[paste0("ylp_m", i)]], + measure = measure + ) +} + +m1 <- fit_measure(1, measures) +m2 <- fit_measure(2, measures) +m3 <- fit_measure(3, measures) + +comp <- model_compare(list(m1 = m1, m2 = m2, m3 = m3)) +print(comp, measures = "all") +``` + +**Output of `model_compare()`** + +Using `print(., measures = "all")` returns a subsection for each measure. +The *rows* present the different models, whereby the best model is always in +the first row followed by the second best, etc. +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 normal approximation behind `p_worse` and `se_diff` + + `diag_elpd`: (only for `elpd`) Diagnostic column flagging unreliable PSIS-LOO approximation for a model + +$^{(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 structure is `elpd` where the column is called `se_diff` for backwards compatibility. + +## 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 differs dependent 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 to be all +on the same scale which is in our case the **utility scale**. Therefore, losses +are converted to the utility scale As such, higher values are always better. +The best model has consequently the highest value and +for 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_compare_meta` attribute of the model object: +```{r measure-meta} +meta <- attr(m1, "measure_compare_meta") +sapply(meta, function(x) x$loss) +``` + +::: + +### Computation of the standard error `_se_diff` + + + + +The standard error summarises 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 | + +whereby `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 inspect which approach is used per measure by inspecting the +`diff_method` slot in the `measure_compare_meta` 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. + +(final check until here) + +#### 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_compare_meta` 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). With LOO every prediction comes from a different +posterior, so the model-based residual variance that Bayesian R2 relies on is +not a natural quantity in this setting. + +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$ for 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_compare_meta` attribute: + +```{r r2-extra} +str(attr(m1, "measure_compare_meta")$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_compare_meta")$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} +fit_bacc_x <- readRDS("data-for-vignettes/fit_bacc_x.Rds") +fit_bacc_w <- readRDS("data-for-vignettes/fit_bacc_w.Rds") + +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_compare_meta` attribute of the model object: + +```{r bacc-extra} +str(attr(m_a, "measure_compare_meta")$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_compare_meta")$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 need 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. It is defined 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 attribute, +and declare that it is a loss rather than a utility. Note, a custom measure is +considered by default to be a utility. + + + +First, we compute the predictive performance measure for two different models +using the `huber loss`. Therefore, we pass a function (`huber_fn`) to the +`measure` argument. + +```{r custom-measure} +h1 <- fit_measure(1, measure = huber_fn) +h3 <- fit_measure(3, measure = huber_fn) +``` + +Inspecting the attribute `measure_compare_meta` reveals the method used for +computing the standard error of the difference is `custom`. + +```{r custom-diff-method} +str(attr(h1, "measure_compare_meta")) +``` + +Consequently, we need to provide an 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. Which measures to +show is decided when printing, so `measures = "all"` is passed to `print()` +rather than to `model_compare()`: + +```{r custom-mean-se} +comp_h <- model_compare(list(m3 = h3, m1 = h1), custom_se_fn = "mean") +print(comp_h, measures = "all") +``` + +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 = "all") +``` + +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 will extend the introduced example, by adding one further +custom measure and show how this would be implemented. As additional custom +measure we use RMSE normalised 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 + +n1 <- fit_measure(1, c("huber" = huber_fn, "nrmse" = nrmse_fn)) +n3 <- fit_measure(3, c("huber" = huber_fn, "nrmse" = nrmse_fn)) + +n1 +``` + +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 +} +``` + +Now, we can 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 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 from +`model_compare`. For example, we want to have everywhere `m3` as the reference +model. Note that the ordering still remains the same in that the estimates are +displayed in decreasing order (best model is first). + +```{r diff-ref-model} +print( + model_compare(list(m1 = m1, m2 = m2, m3 = m3), rank_by = "m3"), + measures = "all" +) +``` + +It is also possible, to select as reference model the best model +according to a specific measure. In this case, we provide the measure name +to the `rank_by` argument: + +```{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 + +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_compare_meta` attribute in full. diff --git a/vignettes/articles-online-only/pred-measure-workflow.Rmd b/vignettes/articles-online-only/pred-measure-workflow.Rmd index 0e222cf4..f0812d97 100644 --- a/vignettes/articles-online-only/pred-measure-workflow.Rmd +++ b/vignettes/articles-online-only/pred-measure-workflow.Rmd @@ -241,27 +241,25 @@ It is also possible to pass a custom function for any measure. The function must ```{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 { w <- exp(.normalize_log_weights(log_weights)) 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 naturally 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 lets `control` reorient the stored +# values with `list(hamming = list(higher_is_better = TRUE))`. +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..ed19d4d8 --- /dev/null +++ b/vignettes/articles-online-only/styles.css @@ -0,0 +1,35 @@ +/* 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; +} \ No newline at end of file diff --git a/vignettes/migration-guide.Rmd b/vignettes/migration-guide.Rmd index b53c3ae4..7e92f827 100644 --- a/vignettes/migration-guide.Rmd +++ b/vignettes/migration-guide.Rmd @@ -168,18 +168,38 @@ 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 | `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 **not deprecated**: it remains an exported generic that +forwards to `model_compare()`, so existing code and `loo_compare` methods +registered by other packages continue to work unchanged. + +```r +# Both are equivalent loo_compare(loo1, loo2) +model_compare(loo1, loo2) + +# Only model_compare() is documented for the newer sources +model_compare(kfold_pm1, kfold_pm2) +model_compare(test_pm1, test_pm2) ``` ## PSIS importance sampling