diff --git a/.Rbuildignore b/.Rbuildignore index 63463781..4bfc39bf 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -18,7 +18,7 @@ vignettes/loo2-non-factorized_cache/* .github/* .vscode/* ^\.github$ -^vignettes/online-only$ +^vignettes/articles-online-only$ ^CRAN-SUBMISSION$ ^release-prep\.R$ @@ -27,3 +27,11 @@ vignettes/loo2-non-factorized_cache/* ^touchstone$ ^.git-blame-ignore-revs ^notes-release.md +^notes$ +^\.agents$ +^agent$ +^\.claude$ +^\.refactor-review$ +^internal-notes$ +^scratch-files$ +^skills-lock\.json$ diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 3dc20b10..00faa67f 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -39,7 +39,7 @@ jobs: local::. any::bayesplot any::BH - any::brms + paul-buerkner/brms any::ggplot2 any::rmarkdown any::Rcpp @@ -52,6 +52,7 @@ jobs: any::StanHeaders any::knitr any::withr + any::lme4 stan-dev/pkgdown-config - name: Build site diff --git a/.gitignore b/.gitignore index 27e4ea74..bc23df9e 100644 --- a/.gitignore +++ b/.gitignore @@ -19,6 +19,7 @@ vignettes/loo2-non-factorizable_cache/* vignettes/*.html vignettes/*.pdf inst/doc +*.html revdep/* tests/testthat/Rplots.pdf @@ -26,4 +27,7 @@ tests/testthat/Rplots.pdf cran-comments.md CRAN-RELEASE release-prep.R + +# personal maintainer scratch (not shared) +internal-notes/ CRAN-SUBMISSION diff --git a/DESCRIPTION b/DESCRIPTION index 4b15bd82..1f472cd9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,6 +36,7 @@ Depends: R (>= 3.5) Imports: checkmate, + cli (>= 3.4.0), matrixStats (>= 0.52), parallel, posterior (>= 1.7.0), @@ -46,6 +47,7 @@ Suggests: ggplot2, graphics, knitr, + lme4, rmarkdown, rstan, rstanarm (>= 2.19.0), diff --git a/NAMESPACE b/NAMESPACE index 3405d737..6f0be7f6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,7 @@ S3method(crps,numeric) S3method(dim,importance_sampling) S3method(dim,kfold) S3method(dim,loo) +S3method(dim,pred_measure) S3method(dim,psis_loo) S3method(dim,waic) S3method(elpd,array) @@ -58,7 +59,10 @@ S3method(print,importance_sampling) S3method(print,importance_sampling_loo) S3method(print,kfold) S3method(print,loo) +S3method(print,loo_pred_measure) +S3method(print,measure) S3method(print,pareto_k_table) +S3method(print,pred_measure) S3method(print,pseudobma_bb_weights) S3method(print,pseudobma_weights) S3method(print,psis) @@ -108,6 +112,7 @@ export(example_loglik_matrix) export(extract_log_lik) export(find_model_names) export(gpdfit) +export(insample_pred_measure) export(is.kfold) export(is.loo) export(is.psis) @@ -116,6 +121,7 @@ export(is.sis) export(is.tis) export(is.waic) export(kfold) +export(kfold_pred_measure) export(kfold_split_grouped) export(kfold_split_random) export(kfold_split_stratified) @@ -134,11 +140,24 @@ export(loo_model_weights) export(loo_model_weights.default) export(loo_moment_match) export(loo_moment_match.default) +export(loo_pred_measure) export(loo_predictive_metric) export(loo_scrps) export(loo_subsample) export(loo_subsample.function) export(mcse_loo) +export(measure_acc) +export(measure_bacc) +export(measure_brier) +export(measure_elpd) +export(measure_ic) +export(measure_mae) +export(measure_mlpd) +export(measure_mse) +export(measure_r2) +export(measure_rmse) +export(measure_rps) +export(measure_srps) export(nlist) export(obs_idx) export(pareto_k_ids) @@ -146,15 +165,19 @@ export(pareto_k_influence_values) export(pareto_k_table) export(pareto_k_values) export(pointwise) +export(pred_measure) export(print_dims) export(pseudobma_weights) export(psis) export(psis_n_eff_values) export(psislw) +export(ptw_log_pred_density) export(relative_eff) export(scrps) export(sis) export(stacking_weights) +export(supported_measures_list) +export(test_pred_measure) export(tis) export(waic) export(waic.array) diff --git a/NEWS.md b/NEWS.md index 05834e1f..40bf3243 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,12 @@ # loo (development version) +* `elpd()`, `crps()`, `scrps()`, `loo_crps()`, `loo_scrps()`, and + `loo_predictive_metric()` are deprecated in favour of the `measure_*()` + functions and the `*_pred_measure()` workflow. See `vignette("migration-guide")` + for a full mapping table. +* 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()]. * Improve numerical stability in `loo()`, `psis()`, model weighting, subsampling, and moment matching in #395 * Fix `loo_compare()` when used with subsampling: compute model comparison by diff --git a/R/compare.R b/R/compare.R index a6081d2f..a0c7819d 100644 --- a/R/compare.R +++ b/R/compare.R @@ -1,7 +1,8 @@ #' Model comparison (deprecated, old version) #' #' **This function is deprecated**. Please use the new [loo_compare()] function -#' instead. +#' instead. See `vignette("migration-guide", package = "loo")` for details. +#' `compare()` and `R/compare.R` are scheduled for removal in a future release. #' #' @export #' @param ... At least two objects returned by [loo()] (or [waic()]). diff --git a/R/crps.R b/R/crps.R index ff1c9e25..4be3bc79 100644 --- a/R/crps.R +++ b/R/crps.R @@ -1,4 +1,15 @@ -#' Continuously ranked probability score +#' Continuously ranked probability score (deprecated) +#' +#' As of loo 3.0.0, `crps()`, `scrps()`, `loo_crps()`, and `loo_scrps()` are +#' **deprecated**. Please use [measure_rps()] and [measure_srps()] instead, +#' or [loo_pred_measure()] for leave-one-out predictive performance. +#' See `vignette("migration-guide", package = "loo")` for a full mapping table. +#' +#' @details +#' The new functions use a single matrix of posterior predictive draws +#' (`ypred`) and a PWM estimator. The deprecated functions require two +#' independent draw matrices (`x` and `x2`) and use a permutation-based +#' estimator. See [measure_rps()] for migration details. #' #' The `crps()` and `scrps()` functions and their `loo_*()` counterparts can be #' used to compute the continuously ranked probability score (CRPS) and scaled @@ -34,16 +45,19 @@ #' The former reports estimator and standard error and latter the pointwise #' values. Following Bolin & Wallin (2023), a larger value is better. #' +#' @seealso [measure_rps()], [measure_srps()], [loo_pred_measure()] +#' #' @examples #' \dontrun{ -#' # An example using rstanarm +#' # Deprecated: #' library(rstanarm) #' data("kidiq") #' fit <- stan_glm(kid_score ~ mom_hs + mom_iq, data = kidiq) #' ypred1 <- posterior_predict(fit) #' ypred2 <- posterior_predict(fit) #' crps(ypred1, ypred2, y = fit$y) -#' loo_crps(ypred1, ypred2, y = fit$y, log_lik = log_lik(fit)) +#' # -> +#' measure_rps(y = fit$y, ypred = ypred1) #' } #' #' @references @@ -80,6 +94,7 @@ loo_scrps <- function(x, ...) { #' @rdname crps #' @export crps.matrix <- function(x, x2, y, ..., permutations = 1) { + .Deprecated("measure_rps") validate_crps_input(x, x2, y) repeats <- replicate(permutations, EXX_compute(x, x2), simplify = F) EXX <- Reduce(`+`, repeats) / permutations @@ -114,6 +129,7 @@ loo_crps.matrix <- permutations = 1, r_eff = 1, cores = getOption("mc.cores", 1)) { + .Deprecated("loo_pred_measure") validate_crps_input(x, x2, y, log_lik) repeats <- replicate(permutations, EXX_loo_compute(x, x2, log_lik, r_eff = r_eff, ...), @@ -128,6 +144,7 @@ loo_crps.matrix <- #' @rdname crps #' @export scrps.matrix <- function(x, x2, y, ..., permutations = 1) { + .Deprecated("measure_srps") validate_crps_input(x, x2, y) repeats <- replicate(permutations, EXX_compute(x, x2), simplify = F) EXX <- Reduce(`+`, repeats) / permutations @@ -156,6 +173,7 @@ loo_scrps.matrix <- permutations = 1, r_eff = 1, cores = getOption("mc.cores", 1)) { + .Deprecated("loo_pred_measure") validate_crps_input(x, x2, y, log_lik) repeats <- replicate(permutations, EXX_loo_compute(x, x2, log_lik, r_eff = r_eff, ...), diff --git a/R/elpd.R b/R/elpd.R index b6736fb4..2b96eebc 100644 --- a/R/elpd.R +++ b/R/elpd.R @@ -1,8 +1,19 @@ -#' Generic (expected) log-predictive density +#' Generic (expected) log-predictive density (deprecated) +#' +#' As of loo 3.0.0, `elpd()` is **deprecated**. Please use [measure_elpd()] +#' instead. For full predictive performance workflows, see +#' [insample_pred_measure()] and [loo_pred_measure()]. +#' See `vignette("migration-guide", package = "loo")` for a full mapping table. +#' +#' @details +#' The return type differs: `elpd()` returns class `"elpd_generic"` with +#' `elpd` and `ic` in `pointwise`; `measure_elpd()` returns class `"measure"`. #' #' The `elpd()` methods for arrays and matrices can compute the expected log #' pointwise predictive density for a new dataset or the log pointwise #' predictive density of the observed data (an overestimate of the elpd). +#' The `elpd()` function is an S3 generic and methods are provided for +#' 3-D pointwise log-likelihood arrays and matrices. #' #' @export #' @param x A log-likelihood array or matrix. The **Methods (by class)** @@ -10,17 +21,18 @@ #' each method. #' @param ... Currently ignored. #' -#' @details The `elpd()` function is an S3 generic and methods are provided for -#' 3-D pointwise log-likelihood arrays and matrices. -#' -#' @seealso The vignette *Holdout validation and K-fold cross-validation of Stan -#' programs with the loo package* for demonstrations of using the `elpd()` -#' methods. +#' @seealso [measure_elpd()], [insample_pred_measure()], [loo_pred_measure()], +#' and the vignette *Holdout validation and K-fold cross-validation of Stan +#' programs with the loo package*. #' #' @examples -#' # Calculate the lpd of the observed data +#' \dontrun{ +#' # Deprecated: #' LLarr <- example_loglik_array() #' elpd(LLarr) +#' # -> +#' measure_elpd(LLarr) +#' } #' elpd <- function(x, ...) { UseMethod("elpd") @@ -31,8 +43,9 @@ elpd <- function(x, ...) { #' @template array #' elpd.array <- function(x, ...) { + .Deprecated("measure_elpd") ll <- llarray_to_matrix(x) - elpd.matrix(ll) + .elpd_matrix_impl(ll) } #' @export @@ -40,13 +53,18 @@ elpd.array <- function(x, ...) { #' @template matrix #' elpd.matrix <- function(x, ...) { - pointwise <- pointwise_elpd_calcs(x) - elpd_object(pointwise, dim(x)) + .Deprecated("measure_elpd") + .elpd_matrix_impl(x) } - # internal ---------------------------------------------------------------- +# used to avoid duplicated deprecation warning messages +.elpd_matrix_impl <- function(x) { + pointwise <- pointwise_elpd_calcs(x) + elpd_object(pointwise, dim(x)) +} + pointwise_elpd_calcs <- function(ll){ elpd <- colLogSumExps(ll) - log(nrow(ll)) ic <- -2 * elpd diff --git a/R/loo_predictive_metric.R b/R/loo_predictive_metric.R index 8ee18bd2..67ca3280 100644 --- a/R/loo_predictive_metric.R +++ b/R/loo_predictive_metric.R @@ -1,4 +1,15 @@ -#' Estimate leave-one-out predictive performance.. +#' Estimate leave-one-out predictive performance (deprecated) +#' +#' As of loo 3.0.0, `loo_predictive_metric()` is **deprecated**. Please use +#' [loo_pred_measure()] instead, or the standalone [measure_mae()], +#' [measure_rmse()], [measure_mse()], [measure_acc()], and [measure_bacc()] +#' functions with PSIS log-weights. +#' See `vignette("migration-guide", package = "loo")` for a full mapping table. +#' +#' @details +#' The replacement API uses `mupred` (posterior expected values) rather than +#' pre-computed LOO expectations passed as `x`. Metric names also differ: +#' `"balanced_acc"` maps to `"bacc"` in [supported_measures_list]. #' #' The `loo_predictive_metric()` function computes estimates of leave-one-out #' predictive metrics given a set of predictions and observations. Currently @@ -49,6 +60,7 @@ #' Standard error of the estimate. #' } #' } +#' @seealso [loo_pred_measure()], [measure_mae()], [supported_measures_list] #' @export #' #' @examples @@ -93,6 +105,7 @@ loo_predictive_metric.matrix <- metric = c("mae", "rmse", "mse", "acc", "balanced_acc"), r_eff = 1, cores = getOption("mc.cores", 1)) { + .Deprecated("loo_pred_measure") stopifnot( is.numeric(x), is.numeric(y), diff --git a/R/pred_measure-builtin.R b/R/pred_measure-builtin.R new file mode 100644 index 00000000..1a32cbeb --- /dev/null +++ b/R/pred_measure-builtin.R @@ -0,0 +1,847 @@ +#' Shared parameters for all measures +#' +#' @param log_weights Optional numeric matrix of unnormalized log-importance +#' weights with dimensions \eqn{S \times n}. Weights are column-normalized +#' before computing each per-observation contribution. +#' @param pointwise Optional numeric vector of precomputed per-observation +#' contributions. When supplied, `ylp` and `log_weights` are ignored. +#' @param higher_is_better Logical or `NULL`; whether larger values indicate +#' better predictive performance. `NULL` (default) keeps each measure's +#' natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +#' Set `TRUE` for a utility scale (higher is better) or `FALSE` for a loss +#' scale (lower is better). +#' +#' @return An object of class `"measure"`: a list with: +#' \describe{ +#' \item{`estimates`}{Named numeric vector with elements `Estimate` +#' and `SE` (standard error).} +#' \item{`pointwise`}{Numeric vector of length \eqn{n} with per-observation +#' values.} +#' } +#' Attributes `measure` (i.e., measure name) and `dims` (draws \eqn{\times} +#' observations) are also set. Use [print()] for a readable summary. +#' +#' @keywords internal +#' @name measure_params +NULL + +#' Shared parameters for density scores +#' +#' @param ylp A numeric matrix or three-dimensional array of log predictive +#' densities or probabilities: +#' \itemize{ +#' \item **Matrix** (\eqn{S \times n}): \eqn{S} posterior draws (chains +#' merged) by \eqn{n} observations. +#' \item **Array** (\eqn{I \times C \times n}): \eqn{I} MCMC iterations per +#' chain, \eqn{C} chains, and \eqn{n} observations. Converted to an +#' \eqn{S \times n} matrix internally. +#' } +#' +#' @keywords internal +#' @name measure_density_params +NULL + +#' Shared parameters for metrics +#' +#' @param y A vector of observed values. +#' @param mupred A numeric array of posterior predictive means. For binary +#' outcomes use a draws x observations matrix. For multiclass outcomes use a +#' draws x observations x categories array. +#' +#' @keywords internal +#' @name measure_metric_params +NULL + +#' Shared parameters for scores +#' +#' @param y A vector of observed values. +#' @param mupred A numeric array of posterior predictive means. For binary +#' outcomes use a draws x observations matrix. For multiclass outcomes use a +#' draws x observations x categories array. +#' +#' @keywords internal +#' @name measure_score_params +NULL + +#' Pointwise log predictive density (`lppd_i`) +#' +#' Computes pointwise log predictive density contributions from a matrix of +#' log predictive densities/probabilities for posterior draws. When PSIS +#' log-weights are supplied, they are used to form a weighted log-sum-exp per +#' observation. +#' +#' @param ylp A numeric matrix of log predictive densities/probabilities with +#' dimensions draws x observations. +#' @param psis_log_weights Optional numeric matrix of normalized PSIS log +#' weights with the same dimensions as `ylp`. Each column must sum to 1 on +#' the probability scale. +#' +#' @returns A numeric vector of length `ncol(ylp)` with pointwise log +#' predictive density values. +#' +#' @examples +#' ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +#' ptw_log_pred_density(ylp) +#' +#' lw <- matrix(log(c(0.7, 0.3, 0.6, 0.4)), nrow = 2) +#' ptw_log_pred_density(ylp, lw) +#' @export +ptw_log_pred_density <- function(ylp, psis_log_weights = NULL) { + .validate_numeric_matrix(ylp, arg = "ylp") + n_draws <- dim(ylp)[1] + + if (is.null(psis_log_weights)) { + return(matrixStats::colLogSumExps(ylp) - log(n_draws)) + } + .validate_numeric_matrix( + psis_log_weights, + arg = "psis_log_weights", + nrow = n_draws, + ncol = ncol(ylp) + ) + + col_sums <- colSums(exp(psis_log_weights)) + if (!isTRUE(all.equal(col_sums, rep(1, ncol(psis_log_weights))))) { + cli::cli_abort(c( + "'psis_log_weights' must be normalized (column sums equal to 1).", + "i" = "Range of current column sums: [{min(col_sums)}, {max(col_sums)}]." + )) + } + + matrixStats::colLogSumExps(ylp + psis_log_weights) +} + +#' Expected log pointwise predictive density (`elpd`) +#' +#' Computes the expected log pointwise predictive density (ELPD) as the sum of +#' pointwise log predictive density contributions (\eqn{\mathrm{lppd}_i}), using +#' [ptw_log_pred_density()]. ELPD is returned on the utility scale (higher is +#' better), consistent with the sign convention used throughout this package. +#' Manual change of sign convention is possible via `higher_is_better`. +#' +#' @inheritParams measure_density_params +#' @inheritParams measure_params +#' @param pointwise Optional numeric vector of precomputed \eqn{\mathrm{lppd}_i} +#' values. When supplied, `ylp` and `log_weights` are ignored. +#' +#' @details +#' \deqn{\mathrm{elpd} = \sum_{i=1}^{n} \mathrm{lppd}_i,} +#' where each \eqn{\mathrm{lppd}_i} is computed by [ptw_log_pred_density()]. +#' The standard error is \eqn{\sqrt{n}\,\mathrm{sd}(\mathrm{lppd}_i)}. +#' +#' @seealso [ptw_log_pred_density()], [measure_mlpd()], [measure_ic()] +#' +#' @examples +#' ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +#' measure_elpd(ylp) +#' +#' # With unnormalized importance weights (e.g., PSIS-LOO) +#' lw <- matrix(log(c(0.7, 0.3, 0.6, 0.4)), nrow = 2) +#' measure_elpd(ylp, log_weights = lw) +#' +#' # From a draws x chains x observations array +#' LLarr <- example_loglik_array() +#' measure_elpd(LLarr) +#' @export +measure_elpd <- function( + ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL +) { + inputs <- .lppd_from_inputs(ylp, log_weights, pointwise, "measure_elpd") + lppd_i <- inputs$lppd_i + + if (length(lppd_i) == 1L) { + cli::cli_warn("Only one pointwise value supplied; standard error is set to 0.") + } + + res <- list( + estimate = sum(lppd_i), + se = if (length(lppd_i) == 1L) 0 else sqrt(length(lppd_i) * var(lppd_i)), + pointwise = lppd_i + ) + + .create_measure_structure( + res, higher_is_better, "elpd", + n_draws = inputs$n_draws, n_obs = inputs$n_obs + ) +} + +#' Mean log pointwise predictive density (`mlpd`) +#' +#' Computes MLPD as the average of pointwise log predictive density (lppd_i) +#' values. Inputs follow the same conventions as [measure_elpd()]. +#' +#' @inheritParams measure_density_params +#' @inheritParams measure_params +#' @param pointwise Optional numeric vector of precomputed \eqn{\mathrm{lppd}_i} +#' values. When supplied, `ylp` and `log_weights` are ignored. +#' +#' @examples +#' ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +#' measure_mlpd(ylp) +#' @export +measure_mlpd <- function( + ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL +) { + inputs <- .lppd_from_inputs(ylp, log_weights, pointwise, "measure_mlpd") + lppd_i <- inputs$lppd_i + n_obs <- inputs$n_obs + + if (n_obs == 1L) { + cli::cli_warn("Only one pointwise value supplied; standard error is set to 0.") + } + + res <- list( + estimate = sum(lppd_i) / n_obs, + se = if (n_obs == 1L) 0 else sqrt(n_obs * var(lppd_i)) / n_obs, + pointwise = lppd_i + ) + .create_measure_structure( + res, higher_is_better, "mlpd", n_draws = inputs$n_draws, n_obs = n_obs + ) +} + +#' Information Criteria (`ic`) +#' +#' Computes the information criteria as -2 x log predictive density (lppd_i) +#' values. Inputs follow the same conventions as [measure_elpd()] and +#' [measure_mlpd()]. +#' +#' @inheritParams measure_density_params +#' @inheritParams measure_params +#' @param pointwise Optional numeric vector of precomputed pointwise +#' contributions \eqn{\mathrm{ic}_i = -2 \cdot \mathrm{lppd}_i}. If provided, +#' `ylp` and `log_weights` are ignored. +#' +#' @examples +#' ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +#' measure_ic(ylp) +#' @export +measure_ic <- function( + ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL +) { + inputs <- .lppd_from_inputs(ylp, log_weights, pointwise, "measure_ic") + ic_i <- if (is.null(pointwise)) -2 * inputs$lppd_i else inputs$lppd_i + n_obs <- inputs$n_obs + + if (n_obs == 1L) { + cli::cli_warn("Only one pointwise value supplied; standard error is set to 0.") + } + + res <- list( + estimate = sum(ic_i), + se = if (n_obs == 1L) 0 else 2 * sqrt(n_obs * var(ic_i / (-2))), + pointwise = ic_i + ) + .create_measure_structure( + res, higher_is_better, "ic", n_draws = inputs$n_draws, n_obs = n_obs + ) +} + +#' Classification accuracy (`acc`) +#' +#' Computes pointwise and average classification accuracy for binary or +#' multiclass outcomes. The class probabilities are first averaged over the +#' draws, using `log_weights` if given. For binary outcomes, the averaged +#' probability is thresholded at 0.5. For multiclass outcomes, the predicted +#' class is the most likely category of the averaged probabilities, via +#' `which.max()`. +#' +#' @inheritParams measure_score_params +#' @inheritParams measure_params +#' @param y An integer vector of observed class labels. +#' @param pointwise Optional numeric vector of precomputed pointwise accuracy +#' contributions. If provided, `y`, `mupred`, and `log_weights` are ignored. +#' +#' @examples +#' y <- c(1L, 0L, 1L) +#' mupred <- matrix(c(0.8, 0.3, 0.7, 0.6, 0.4, 0.9), nrow = 2) +#' measure_acc(y, mupred) +#' @export +measure_acc <- function( + y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL +) { + if (!is.null(pointwise)) { + .inform_ignored_inputs( + pointwise, + ignored_args = list(y = y, mupred = mupred, log_weights = log_weights), + fun_name = "acc" + ) + acc_i <- pointwise + n_draws <- NULL + n_obs <- length(pointwise) + } else { + n_draws <- nrow(mupred) + n_obs <- dim(mupred)[2] + .validate_numeric_vector(y, arg = "y") + acc_i <- .acc_pointwise(y, mupred, log_weights) + } + + res <- list( + estimate = mean(acc_i), + se = sqrt(mean(acc_i) * (1 - mean(acc_i)) / n_obs), + pointwise = acc_i + ) + .create_measure_structure( + res, higher_is_better, "acc", n_draws = n_draws, n_obs = n_obs + ) +} + +#' Balanced classification accuracy (`bacc`) +#' +#' Computes balanced accuracy by averaging class-specific mean accuracy, giving +#' each observed class equal weight regardless of class frequency. +#' +#' @inheritParams measure_acc +#' +#' @examples +#' y <- c(1L, 1L, 2L, 2L) +#' mupred <- array( +#' c(0.8, 0.2, 0.7, 0.3, 0.3, 0.7, 0.2, 0.8), +#' dim = c(1, 4, 2) +#' ) +#' measure_bacc(y, mupred) +#' @export +measure_bacc <- function( + y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL +) { + .validate_numeric_vector(y, arg = "y") + classes <- sort(unique(y)) + K <- length(classes) + if (K < 2) { + cli::cli_abort("{.fn bacc} requires at least two outcome classes.") + } + if (!is.null(pointwise)) { + if (length(pointwise) != length(y)) { + cli::cli_abort("{.arg pointwise} and {.arg y} must have the same length.") + } + .inform_ignored_inputs( + pointwise, + ignored_args = list(mupred = mupred, log_weights = log_weights), + fun_name = "bacc" + ) + acc_i <- pointwise + n_draws <- NULL + n_obs <- length(pointwise) + } else { + n_draws <- nrow(mupred) + n_obs <- ncol(mupred) + acc_i <- .acc_pointwise(y, mupred, log_weights) + } + + acc_c <- vapply(classes, function(c) mean(acc_i[y == c]), numeric(1)) + n_c <- tabulate(match(y, classes)) + bacc_i <- acc_i / (K * n_c[match(y, classes)]) + + res <- list( + estimate = mean(acc_c), + se = sqrt(sum(acc_c * (1 - acc_c) / n_c)) / K, + pointwise = bacc_i + ) + .create_measure_structure( + res, higher_is_better, "bacc", n_draws = n_draws, n_obs = n_obs + ) +} + +#' Brier score (`brier`) +#' +#' Computes the Brier score for binary outcomes as squared error between the +#' observed label and predicted event probability. +#' +#' @param y A numeric vector of binary outcomes coded as 0 or 1. +#' @param ypred A numeric matrix of posterior predictive probabilities with +#' dimensions draws x observations. +#' @inheritParams measure_params +#' @param pointwise Optional numeric vector of precomputed pointwise Brier +#' scores. If provided, `y`, `ypred`, and `log_weights` are ignored. +#' +#' @examples +#' y <- c(1, 0, 1) +#' ypred <- matrix(c(0.8, 0.2, 0.7, 0.9, 0.4, 0.6), nrow = 2) +#' measure_brier(y, ypred) +#' @export +measure_brier <- function( + y, ypred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL +) { + if (!is.null(pointwise)) { + .inform_ignored_inputs( + pointwise, + ignored_args = list(y = y, ypred = ypred, log_weights = log_weights), + fun_name = "brier" + ) + bs_i <- pointwise + n_draws <- NULL + n_obs <- length(pointwise) + } else { + n_draws <- nrow(ypred) + n_obs <- ncol(ypred) + .validate_numeric_vector(y, arg = "y") + if (any(y != 0 & y != 1)) { + cli::cli_abort(c( + "The brier score expects binary data 'y'.", + "i" = "Observed range: [{min(y)}, {max(y)}]", + "x" = "All elements of {.arg y} must be 0 or 1." + )) + } + .validate_numeric_matrix(ypred, arg = "ypred", ncol = length(y)) + .validate_probs(ypred, arg = "ypred") + if (!is.null(log_weights)) { + weights <- exp(.normalize_and_validate_log_weights( + log_weights = log_weights, + n_draws = n_draws, + n_obs = n_obs + )) + prob_i <- colSums(ypred * weights) + } else { + prob_i <- colMeans(ypred) + } + bs_i <- (prob_i - y)^2 + } + + res <- list( + estimate = mean(bs_i), + se = sqrt(var(bs_i) / length(bs_i)), + pointwise = bs_i + ) + .create_measure_structure( + res, higher_is_better, "brier", n_draws = n_draws, n_obs = n_obs + ) +} + +#' Mean absolute error (`mae`) +#' +#' Computes MAE between observed outcomes and posterior predictive point +#' predictions. Point predictions are obtained by averaging `mupred` draws, or +#' by PSIS-weighted averaging when `log_weights` is provided. +#' +#' @param y A numeric vector of observed outcomes. +#' @param mupred A numeric matrix of posterior expected predictions with +#' dimensions draws x observations. A length-`n` vector is also accepted. +#' @param pointwise Optional numeric vector of precomputed pointwise absolute +#' errors. If provided, `y`, `mupred`, and `log_weights` are ignored. +#' @inheritParams measure_params +#' +#' @examples +#' y <- c(1, 2, 3) +#' mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +#' measure_mae(y, mupred) +#' @export +measure_mae <- function( + y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL +) { + inputs <- .point_error_from_inputs( + y, mupred, log_weights, pointwise, "mae", abs + ) + mae_i <- inputs$err_i + + res <- list( + estimate = mean(mae_i), + se = sqrt(var(mae_i) / length(mae_i)), + pointwise = mae_i + ) + .create_measure_structure( + res, higher_is_better, "mae", + n_draws = inputs$n_draws, n_obs = inputs$n_obs + ) +} + +#' Mean squared error (`mse`) +#' +#' Computes MSE between observed outcomes and posterior predictive point +#' predictions. Point predictions are obtained by averaging `mupred` draws, or +#' by PSIS-weighted averaging when `log_weights` is provided. +#' +#' @param pointwise Optional numeric vector of precomputed pointwise squared +#' errors. If provided, `y`, `mupred`, and `log_weights` are ignored. +#' @inheritParams measure_mae +#' +#' @examples +#' y <- c(1, 2, 3) +#' mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +#' measure_mse(y, mupred) +#' @export +measure_mse <- function( + y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL +) { + inputs <- .point_error_from_inputs( + y, mupred, log_weights, pointwise, "mse", function(e) e^2 + ) + sqe_i <- inputs$err_i + + res <- list( + estimate = mean(sqe_i), + se = sqrt(var(sqe_i) / length(sqe_i)), + pointwise = sqe_i + ) + .create_measure_structure( + res, higher_is_better, "mse", + n_draws = inputs$n_draws, n_obs = inputs$n_obs + ) +} + +#' Root mean squared error (`rmse`) +#' +#' Computes RMSE as the square root of MSE and propagates uncertainty via a +#' first-order delta-method approximation. +#' +#' @param pointwise Optional numeric vector of precomputed pointwise squared +#' errors. If provided, `y`, `mupred`, and `log_weights` are ignored. +#' @inheritParams measure_mae +#' +#' @examples +#' y <- c(1, 2, 3) +#' mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +#' measure_rmse(y, mupred) +#' @export +measure_rmse <- function( + y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL +) { + mse_res <- measure_mse( + y = y, mupred = mupred, log_weights = log_weights, + pointwise = pointwise + ) + n_draws <- if (is.null(pointwise)) nrow(mupred) else NULL + n_obs <- length(mse_res$pointwise) + + sqe_i <- mse_res$pointwise + rmse_est <- sqrt(mse_res$estimates[1]) + if (rmse_est == 0) { + rmse_se <- 0 + } else { + rmse_se <- mse_res$estimates[2] / (2 * rmse_est) + } + + res <- list( + estimate = rmse_est, + se = rmse_se, + pointwise = sqe_i + ) + .create_measure_structure( + res, higher_is_better, "rmse", n_draws = n_draws, n_obs = n_obs + ) +} + +#' Predictive R-squared (`r2`) +#' +#' Computes predictive R-squared as one minus the ratio of prediction MSE to +#' the empirical variance of `y`. The standard error is computed with a +#' first-order delta-method approximation. +#' +#' @param pointwise Optional numeric vector of precomputed pointwise squared +#' errors. If provided, `mupred` and `log_weights` are ignored. `y` is always +#' required, because `r2` needs the variance of `y` as its baseline. +#' @inheritParams measure_mae +#' +#' @examples +#' y <- c(1, 2, 3) +#' mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +#' measure_r2(y, mupred) +#' @export +measure_r2 <- function( + y, mupred, log_weights = NULL, pointwise = NULL, higher_is_better = NULL +) { + .validate_numeric_vector(y, arg = "y") + if (var(y) == 0) { + cli::cli_abort( + "{.fn r2} is undefined when {.arg y} has zero variance." + ) + } + + mse_res <- measure_mse( + y = y, + mupred = mupred, + log_weights = log_weights, + pointwise = pointwise + ) + mse_hat <- mse_res$estimates[1] + sqe_i <- mse_res$pointwise + n_obs <- length(sqe_i) + n_draws <- if (is.null(pointwise)) nrow(mupred) else NULL + + mse_y_i <- (y - mean(y))^2 + mse_y_hat <- mean(mse_y_i) + + var_mse_hat <- mse_res$estimates[2]^2 + cov_mse_msey <- stats::cov(sqe_i, mse_y_i) / n_obs + var_mse_y_hat <- var(mse_y_i) / n_obs + + t1 <- var_mse_hat + t2 <- -2 * (mse_hat / mse_y_hat) * cov_mse_msey + t3 <- (mse_hat^2 / mse_y_hat^2) * var_mse_y_hat + se_r2 <- sqrt(t1 + t2 + t3) * (1 / mse_y_hat) + + est_r2 <- 1 - mse_hat / mse_y_hat + + res <- list( + estimate = est_r2, + se = se_r2, + pointwise = sqe_i + ) + .create_measure_structure( + res, higher_is_better, "r2", n_draws = n_draws, n_obs = n_obs + ) +} + +#' Ranked Probability Score (RPS, SRPS, CRPS, SCRPS) +#' +#' Computes proper scoring rules based on the ranked probability score family, +#' covering both discrete and continuous outcomes, with optional scaling. +#' The specific score computed depends on the type of `y` and `ypred` and the +#' value of `scaled`: +#' +#' | `y`/`ypred` type | `scaled = FALSE` | `scaled = TRUE` | +#' |------------------|-----------------|-----------------| +#' | Discrete | RPS | SRPS | +#' | Continuous | CRPS | SCRPS | +#' +#' **Scoring rules:** +#' +#' - **RPS** (Epstein, 1969): Compares predictive and observed cumulative +#' distributions for ordered discrete outcomes. +#' - **CRPS** (Matheson & Winkler, 1976; Gneiting & Raftery, 2007): Generalizes +#' RPS to continuous outcomes. Defined as +#' \deqn{\mathrm{CRPS}(X; y) = E[|X - y|] - \frac{1}{2} E[|X - X'|],} +#' where \eqn{X, X'} are independent draws from the predictive distribution. +#' - **SRPS/SCRPS** (Bolin & Wallin, 2023): Scaled variants that are invariant +#' to the scale of the predictive distribution. Defined as +#' \deqn{\mathrm{SCRPS}(X; y) = -\frac{E[|X - y|]}{E[|X - X'|]} - +#' \frac{1}{2} \log E[|X - X'|].} +#' +#' **Estimation:** +#' +#' Scores are estimated using the probability-weighted moment (PWM) estimator +#' (Taillardat et al., 2016; Zamo & Naveau, 2018), which requires only a single +#' set of predictive draws unlike permutation-based estimators, which require +#' two independent draw sets. The PWM estimator is unbiased and generally more +#' accurate than single-permutation estimators. The same estimator is used for +#' both discrete and continuous outcomes; see Hosking (1990, 1996) for +#' theoretical justification in the discrete case. +#' +#' If log-weights (`log_weights`) are provided (e.g., PSIS weights +#' for LOO cross-validation), a weighted PWM estimator is used instead, which +#' accounts for the importance weights when estimating expectations. +#' +#' **Sign convention:** +#' +#' Unscaled scores are returned as losses (lower is better). Scaled scores are +#' returned as utilities (higher is better), after Bolin & Wallin (2023). Set +#' `higher_is_better` to select the orientation you want. +#' +#' @param y A numeric vector of \eqn{n} observed outcomes. May be integer-valued +#' (for RPS/SRPS) or continuous (for CRPS/SCRPS). +#' @param ypred A numeric matrix of posterior predictive draws with dimensions +#' \eqn{S \times n} (draws × observations). +#' @param pointwise Optional numeric vector of precomputed pointwise rps values. +#' If provided, `y`, `ypred`, and `log_weights` are ignored. +#' @param scaled Logical; if `TRUE`, computes the scaled variant (SRPS for +#' discrete outcomes, SCRPS for continuous outcomes). Default is `FALSE`. +#' @inheritParams measure_params +#' +#' @examples +#' # Discrete outcomes: RPS +#' y <- c(2L, 1L, 3L) +#' ypred <- matrix(c(2, 1, 2, 3, 1, 3), nrow = 2) +#' measure_rps(y, ypred) +#' +#' # Discrete outcomes: SRPS (scaled) +#' measure_rps(y, ypred, scaled = TRUE) +#' +#' # Continuous outcomes: CRPS +#' y_cont <- c(0.5, -1.2, 2.3) +#' ypred_cont <- matrix(rnorm(200), nrow = 100, ncol = 3) +#' measure_rps(y_cont, ypred_cont) +#' +#' # With importance weights: LOO-CRPS +#' log_weights <- matrix(rnorm(200), nrow = 100, ncol = 3) +#' measure_rps(y_cont, ypred_cont, log_weights = log_weights) +#' +#' @references +#' Bolin, D. and Wallin, J. (2023). Local scale invariance and robustness of +#' proper scoring rules. *Statistical Science*, 38(1):140–159. +#' +#' Epstein, E. S. (1969). A scoring system for probability forecasts of ranked +#' categories. *Journal of Applied Meteorology*, 8(6):985–987. +#' +#' Gneiting, T. and Raftery, A. E. (2007). Strictly proper scoring rules, +#' prediction, and estimation. *Journal of the American Statistical +#' Association*, 102(477):359–378. +#' +#' Hosking, J. R. M. (1990). L-moments: Analysis and estimation of +#' distributions using linear combinations of order statistics. *Journal of +#' the Royal Statistical Society Series B*, 52(1):105–124. +#' +#' Hosking, J. R. M. (1996). Some theoretical results concerning L-moments. +#' Research report RC 14492. IBM Thomas J. Watson Research Division. +#' +#' Matheson, J. E. and Winkler, R. L. (1976). Scoring rules for continuous +#' probability distributions. *Management Science*, 22(10):1087–1096. +#' +#' Taillardat, M., Mestre, O., Zamo, M., and Naveau, P. (2016). Calibrated +#' ensemble forecasts using quantile regression forests and ensemble model +#' output statistics. *Monthly Weather Review*, 144(6):2375–2393. +#' +#' Zamo, M. and Naveau, P. (2018). Estimation of the continuous ranked +#' probability score with limited information and applications to ensemble +#' weather forecasts. *Mathematical Geosciences*, 50:209–234. +#' +#' @export +measure_rps <- function(y, ypred, log_weights = NULL, pointwise = NULL, scaled = FALSE, + higher_is_better = NULL) { + if (is.null(pointwise)) { + n_draws <- nrow(ypred) + n_obs <- ncol(ypred) + + w <- if (is.null(log_weights)) { + NULL + } else { + exp(.normalize_and_validate_log_weights( + log_weights = log_weights, + n_draws = n_draws, + n_obs = n_obs + )) + } + + EXX <- .exx_pwm(ypred, w) + EXy <- if (is.null(w)) { + colMeans(abs(sweep(ypred, 2, y))) + } else { + colSums(w * abs(sweep(ypred, 2, y))) + } + + rps_i <- if (scaled) { + # Scaled version by Bolin & Wallin (2023). The scaling divides by + # E|X - X'| and takes its logarithm, so a point-mass predictive + # distribution leaves the score undefined. + degenerate <- which(EXX == 0) + if (length(degenerate) > 0L) { + cli::cli_abort(c( + "The scaled rps score is undefined for {cli::qty(length(degenerate))} + observation{?s} {.val {degenerate}}.", + "i" = "{.code E|X - X'|} is 0 there: all the weight sits on a single + draw, so the predictive distribution is a point mass.", + "i" = "Check the PSIS diagnostics, or use the unscaled score + {.code scaled = FALSE}." + )) + } + -EXy / EXX - 0.5 * log(EXX) + } else { + # Gneiting & Raftery (2007) + EXy - 0.5 * EXX + } + } else { + rps_i <- pointwise + n_draws <- NULL + n_obs <- length(pointwise) + } + + res <- list( + estimate = mean(rps_i), + se = sqrt(var(rps_i) / n_obs), + pointwise = rps_i + ) + name <- if(isTRUE(scaled)) "srps" else "rps" + .create_measure_structure( + res, higher_is_better, name, n_draws = n_draws, n_obs = n_obs + ) +} + +#' Scaled Ranked Probability Score (SRPS, SCRPS) +#' +#' A convenience wrapper around [measure_rps()] with `scaled = TRUE`. Computes the +#' scaled ranked probability score (SRPS) for discrete outcomes or the scaled +#' continuously ranked probability score (SCRPS) for continuous outcomes. +#' Scaling makes the score invariant to the spread of the predictive +#' distribution, which can be useful when comparing models across observations +#' with very different predictive uncertainties. +#' +#' See [measure_rps()] for full details on arguments, estimation, and references. +#' +#' @inheritParams measure_rps +#' +#' @examples +#' y <- c(2L, 1L, 3L) +#' ypred <- matrix(c(2, 1, 2, 3, 1, 3), nrow = 2) +#' measure_srps(y, ypred) +#' +#' @export +measure_srps <- function(y, ypred, log_weights = NULL, pointwise = NULL, + higher_is_better = NULL) { + measure_rps( + y = y, ypred = ypred, log_weights = log_weights, + scaled = TRUE, higher_is_better = higher_is_better + ) +} + +# measure overview ----------------------------- +# +# Built-in measures are registered in `.measure_spec`. Users can also pass +# custom functions to `measure` in the pred_measure family; those functions +# must set `attr(fun, "measure_name")` and return `estimate`, `se`, and +# `pointwise` (see `?insample_pred_measure`). + +# internal function to get the measure specification +# @noRd +# @param measure The measure used. +# @return The measure specification. +# +# `needs_elpd = TRUE` marks a measure derived from the pointwise ELPD (`elpd`, +# `mlpd`, `ic`). `.elpd_pointwise()` gives that vector for the source. +# `.compute_measure()` passes it as `pointwise`, optionally through +# `elpd_transform` first. +.measure_spec <- list( + elpd = list(fun = measure_elpd, loss = FALSE, needs_elpd = TRUE), + ic = list( + fun = measure_ic, loss = TRUE, + needs_elpd = TRUE, elpd_transform = function(x) -2 * x + ), + mlpd = list(fun = measure_mlpd, loss = FALSE, needs_elpd = TRUE), + mae = list(fun = measure_mae, loss = TRUE), + r2 = list(fun = measure_r2, loss = FALSE), + rmse = list(fun = measure_rmse, loss = TRUE), + mse = list(fun = measure_mse, loss = TRUE), + acc = list(fun = measure_acc, loss = FALSE), + bacc = list(fun = measure_bacc, loss = FALSE), + rps = list(fun = measure_rps, loss = TRUE), + srps = list(fun = measure_srps, loss = FALSE), + brier = list(fun = measure_brier, loss = TRUE) +) + +#' Supported predictive measure names +#' +#' A character vector of measure names that can be passed to the `measure` +#' argument of [insample_pred_measure()], [loo_pred_measure()], +#' [kfold_pred_measure()], [test_pred_measure()], and [pred_measure()]. +#' +#' @export +supported_measures_list <- names(.measure_spec) + +# internal function that produces output format for measures +.create_measure_structure <- function( + res, 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 + } + } + out <- list() + out$estimates <- matrix( + c(res$estimate, res$se), + nrow = 1, + dimnames = list(measure_name, c("Estimate", "SE")) + ) + out$pointwise <- matrix( + res$pointwise, + ncol = 1, + dimnames = list(NULL, measure_name) + ) + + structure( + out, + class = c("measure", "loo"), + measure = measure_name, + dims = c(n_draws, n_obs) + ) +} diff --git a/R/pred_measure-compute.R b/R/pred_measure-compute.R new file mode 100644 index 00000000..d95152fd --- /dev/null +++ b/R/pred_measure-compute.R @@ -0,0 +1,714 @@ +#' Shared parameters for predictive measure wrappers +#' +#' @description +#' Parameter definitions shared by the user-facing entry points and the +#' internal engine [do_pred_measure()]. +#' +#' @param y Vector of observed values (`n`). Required for distributional and +#' point-prediction measures such as `crps`, `mae`, and `acc`. +#' @param ypred Matrix of posterior predictive draws (`S` draws × `n` +#' observations), typically from [brms::posterior_predict()]. Required for +#' distributional measures such as `crps`, `rps`, and `scrps`. +#' @param mupred Matrix of posterior expected values (`S` × `n`), typically from +#' [brms::posterior_epred()]. Required for point-prediction measures such as +#' `mae`, `rmse`, `r2`, and `acc`. +#' @param ylp Matrix of pointwise log predictive densities or probabilities +#' (`S` × `n`), typically from [brms::log_lik()]. Required for density-based +#' summaries (`elpd`, `mlpd`, `ic`). +#' @param ylp_test Matrix of pointwise log predictive densities for holdout +#' observations (`S` × `n_test`), typically from +#' `brms::log_lik(fit, newdata = test_data)`. Used with `ylp` (from the +#' training fit) in [test_pred_measure()] to score genuinely new data. +#' @param predperf An existing predictive measure object (class +#' `"pred_measure"`) to update. When supplied, stored rows and +#' (for LOO) PSIS weights are reused instead of recomputed. +#' @param measure Measures to compute. `NULL` (default) gives `elpd` (with +#' `p_loo` / `p_kfold` for LOO and k-fold). Can be: +#' \itemize{ +#' \item A **character vector** of built-in names; see +#' [supported_measures_list]. +#' \item A **function** with attribute `"measure_name"` for one custom measure. +#' \item A **list** mixing character scalars (built-in names) and named +#' functions (custom measures), e.g. `list("rps", my_metric = my_fun)`. +#' } +#' Custom functions are called with any of `y`, `ypred`, `mupred`, `ylp`, and +#' `log_weights` that appear in their formals, plus arguments from `control`. +#' They must return a list with `estimates` and `pointwise`. +#' @param measure_name For a single custom function, set +#' `attr(my_fun, "measure_name") <- "my_metric"` before passing `my_fun` to +#' `measure`. +#' @param group_ids Optional vector of group identifiers for grouped summaries +#' (reserved; not yet implemented). +#' @param loo A [loo::loo()] result, computed with +#' `save_psis = TRUE` so that PSIS weights are available for additional +#' measures. See [loo_pred_measure()]. +#' @param kfold A `kfold` object from [brms::kfold()]. Supplies ELPD summaries +#' and fold structure for [kfold_pred_measure()]; pass `y`, `ypred`, and/or +#' `mupred` when requesting additional measures. +#' @param psis_object A `psis` object with LOO importance weights. An +#' alternative to passing a full `loo` object; must be supplied together with +#' `ylp` when computing `elpd`. +#' @param save_psis Logical. If `TRUE`, store the `psis` object in the result +#' so that additional measures can be added later with [pred_measure()] without +#' recomputing PSIS weights. +#' @param control Named list of per-measure settings. Each name must match an +#' element of `measure`; the value is a list of arguments passed to that +#' measure's summary function (e.g. `list(new_measure = list(add_arg = 10))`). +#' @param source Character string indicating the evaluation mode: `"insample"`, +#' `"loo"`, `"kfold"`, or `"test"`. Set automatically by the wrapper +#' functions; required when calling [do_pred_measure()] directly. +#' +#' @keywords internal +#' @name pred_measure_params +do_pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + ylp_test = NULL, + measure = NULL, + predperf = NULL, + loo = NULL, + kfold = NULL, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + source = NULL, + control = list() +) { + # input validation --------------------------------------------------- + .validate_control(control) + + if (!is.null(group_ids)) { + cli::cli_abort( + "`group_ids` is reserved for future feature but is not yet implemented." + ) + } + + measures <- .prepare_measures( + measure, predperf, supported_measures_list, source + ) + needs_elpd <- .any_needs_elpd(measures) + + if (source == "loo") { + if (is.null(predperf)) { + if (!is.null(loo) && is.null(loo$psis_object)) { + cli::cli_abort(c( + "No `psis_object` found in `loo` object. Did you run loo(..., save_psis = 'TRUE')." + )) + } + } else { + if (is.null(psis_object) && !is.null(predperf$psis_object)) { + cli::cli_inform("Using psis_object for LOO CV from `predperf`") + psis_object <- predperf$psis_object + } + } + checkmate::assert_null(ylp_test) + } else if (source == "insample") { + checkmate::assert_null(ylp_test) + checkmate::assert_null(psis_object) + } else if (source == "test") { + checkmate::assert_null(psis_object) + } else { # kfold + checkmate::assert_null(psis_object) + if (is.null(predperf) && is.null(kfold)) { + cli::cli_abort(c( + "{.arg kfold} is required for {.fn kfold_pred_measure}.", + "i" = "Pass a {.cls kfold} object from {.fn brms::kfold}." + )) + } + } + + # core logic --------------------------------------------------- + if (source == "loo") { + psis_object <- .get_psis_object( + loo = loo, + predperf = predperf, + psis_object = psis_object, + ylp = ylp, + r_eff = 1 + ) + } + + log_weights <- if (!is.null(psis_object)) psis_object$log_weights else NULL + + lppd_i <- if (needs_elpd) { + .elpd_pointwise( + source = source, ylp = ylp, ylp_test = ylp_test, + log_weights = log_weights, loo = loo, kfold = kfold, predperf = predperf + ) + } else NULL + + # an update adds rows to predperf; a new result starts empty + estimates <- predperf$estimates + pointwise <- predperf$pointwise + diagnostics <- if (!is.null(predperf)) { + predperf$diagnostics + } else if (source == "kfold") { + kfold$diagnostics + } else { + psis_object$diagnostics + } + + for (entry in measures) { + sel_measure <- .compute_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + measure_entry = entry, + log_weights = log_weights, + control = control, + lppd_i = lppd_i + ) + result_name <- attr(sel_measure, "measure") + if (is.null(result_name)) { + result_name <- entry$name + } + # add new measures to existing pred_measure results + name_updated <- .measure_result_name(source, result_name) + if (!is.null(estimates) && name_updated %in% rownames(estimates)) { + cli::cli_warn(c( + "{.field {name_updated}} already present in results. Skipping the update." + )) + next + } + estimates <- .merge_matrix( + source = source, + mat = estimates, + name = result_name, + values = .measure_estimate_se(sel_measure), + margin = 1 + ) + pointwise <- .merge_matrix( + source = source, + mat = pointwise, + name = result_name, + values = sel_measure$pointwise, + margin = 2 + ) + + if (identical(entry$key, "elpd")) { + p_eff <- .effective_param(source, ylp, lppd_i, loo, kfold, predperf) + if (!is.null(p_eff)) { + estimates <- .merge_matrix( + source = source, mat = estimates, name = "p", + values = .measure_estimate_se(p_eff), margin = 1 + ) + pointwise <- .merge_matrix( + source = source, mat = pointwise, name = "p", + values = p_eff$pointwise, margin = 2 + ) + } + } + } + + predperf_res <- .build_pred_measure( + estimates = estimates, + pointwise = pointwise, + diagnostics = diagnostics, + psis_object = psis_object, + save_psis = save_psis + ) + + .add_attributes( + save_psis, + predperf_res, + y, + ypred, + mupred, + ylp, + ylp_test, + kfold, + loo, + predperf, + source + ) +} + +# internal helper functions --------------------------------------------------- + +#' Resolve or compute the PSIS object for LOO scoring +#' +#' @description +#' Selects a PSIS object from the available inputs, or computes one from `ylp` +#' when no precomputed weights are supplied (assuming `r_eff = 1`). +#' +#' Resolution order: +#' \enumerate{ +#' \item If both `psis_object` and `loo` are provided, return `psis_object` +#' after verifying it matches `loo$psis_object`. +#' \item Extract from `loo$psis_object` when `loo` is provided. +#' \item Use the supplied `psis_object`. +#' \item Reuse `predperf$psis_object` when accumulating measures. +#' \item Reuse `predperf$log_weights` when only the weights were stored +#' (`save_psis = FALSE`); the result carries no `diagnostics`. +#' \item Compute from `ylp` via [loo::psis()] on `-ylp` log ratios. +#' } +#' +#' @param ylp Matrix of pointwise log predictive densities (`S` × `n`). +#' @param loo Optional [loo::loo()] result containing a `psis_object`. +#' @param predperf Optional existing measure object with a stored `psis_object`. +#' @param psis_object Optional precomputed PSIS object. +#' @param r_eff Relative effective sample size passed to [loo::psis()]; +#' default `1`. +#' +#' @return A `psis` object with `log_weights` and `diagnostics`. +#' +#' @note See developer notes on computation of the `psis_object` for details. +#' @noRd +.get_psis_object <- function( + ylp, + loo, + predperf, + psis_object, + r_eff = 1 +) { + # psis_object + loo are both provided -> return psis_object + if (!is.null(psis_object) && !is.null(loo)) { + psis_equal_loo <- isTRUE(all.equal( + psis_object$log_weights, + loo$psis_object$log_weights + )) + if (!psis_equal_loo) { + cli::cli_abort( + "Provided `psis_object` and `loo$psis_object` are not identical." + ) + } + return(psis_object) + # loo is provided + } else if (!is.null(loo)) { + return(loo$psis_object) + # psis_object is provided + } else if (!is.null(psis_object)) { + return(psis_object) + # predperf with psis_object is provided + } else if (!is.null(predperf$psis_object)) { + return(predperf$psis_object) + # predperf carries log_weights only (save_psis = FALSE) + } else if (!is.null(predperf$log_weights)) { + return(list(log_weights = predperf$log_weights)) + # ylp is provided + } else if (is.null(loo) && is.null(psis_object) && !is.null(ylp)) { + cli::cli_inform( + "Compute `psis_object` internally from `ylp` assuming `r_eff = 1`." + ) + log_ratios <- -1 * ylp + return(psis(log_ratios, r_eff = r_eff)) + # nothing is provided + } else { + cli::cli_abort(c( + "psis_object can not be computed, either of `psis_object`, `loo`, or", + "`ylp` needs to be provided." + )) + }} + +#' Extract estimate and SE from a measure result +#' +#' `.create_measure_structure()` gives every builtin measure an `estimates` +#' matrix. A custom measure returns either `estimates` or `estimate` and `se`. +#' +#' @noRd +.measure_estimate_se <- function(res) { + if (!is.null(res$estimates)) { + return(res$estimates) + } + c(res$estimate, res$se) +} + +#' Pointwise ELPD for the evaluation source +#' +#' @description +#' Gives the pointwise ELPD that `elpd`, `mlpd` and `ic` use. Resolution order: +#' \enumerate{ +#' \item Reuse the `elpd` column of `predperf`. +#' \item `kfold`: take `elpd_kfold` from the `kfold` object. +#' \item `loo` with a `loo` object: take `elpd_loo` from it. +#' \item Otherwise compute from `ylp` (`insample`, `loo` with `log_weights`) +#' or from `ylp_test` (`test`). +#' } +#' +#' @return Numeric vector of length `n`. +#' +#' @noRd +.elpd_pointwise <- function( + source, ylp, ylp_test, log_weights, loo, kfold, predperf +) { + col <- .measure_result_name(source, "elpd") + if (!is.null(predperf) && col %in% colnames(predperf$pointwise)) { + return(predperf$pointwise[, col]) + } + if (source == "kfold") { + if (is.null(kfold)) { + cli::cli_abort(c( + "{.field {col}} is not stored in {.arg predperf}.", + "i" = "Call {.fn kfold_pred_measure} with the {.cls kfold} object." + )) + } + return(kfold$pointwise[, col]) + } + if (source == "loo" && !is.null(loo)) { + return(loo$pointwise[, col]) + } + arg <- if (source == "test") "ylp_test" else "ylp" + input <- if (source == "test") ylp_test else ylp + if (is.null(input)) { + cli::cli_abort(c( + "{.arg {arg}} is required to compute {.field {col}}.", + "i" = "{.val elpd}, {.val mlpd} and {.val ic} are derived from {.field {col}}." + )) + } + weights <- if (source == "loo") log_weights else NULL + .lppd_from_inputs(input, weights, NULL, ".elpd_pointwise")$lppd_i +} + +#' Compute a single predictive measure +#' +#' @description +#' Dispatches one requested predictive measure to the appropriate summary +#' function. No measure has a fixed input list. The function builds a pool of +#' candidate arguments, then keeps only the ones the measure function declares: +#' +#' `args <- pool[intersect(names(formals(measure_fun)), names(pool))]` +#' +#' The pool holds `y`, `ypred`, `mupred`, `ylp` and `log_weights`, plus the +#' measure's slice of `control`. A measure that sets `needs_elpd` in +#' `.measure_spec` gets a different pool: `pointwise` holds the ELPD column +#' taken from `lppd_i`, and `ylp` and `log_weights` are `NULL`. +#' +#' @param y Vector of observed values (n). +#' @param ypred Matrix of posterior predictive draws (S × n). +#' @param mupred Matrix of posterior point predictions (S × n). +#' @param ylp Matrix of pointwise log predictive densities (S × n). +#' @param measure_entry A normalized measure entry with elements +#' `name`, `type` (`"builtin"` or `"custom"`), and `key`. +#' @param log_weights Matrix of log-weights (S × n), as returned by +#' `.compute_log_weights()`. +#' @param control Named list of per-measure settings passed from +#' [pred_measure()]; the active slice is `control[[measure_entry$name]]`. +#' @param `lppd_i` Numeric vector from `elpd_pointwise()`; read only when the +#' measure sets `needs_elpd`. +#' +#' @return The result of the measure function, in one of two shapes. +#' \describe{ +#' \item{builtin}{A `"measure"` object from `.create_measure_structure()`: +#' `estimates`, a 1 by 2 matrix with columns `Estimate` and `SE`, and +#' `pointwise`, an n by 1 matrix.} +#' \item{custom}{Either `estimates`, a length-2 numeric vector, or +#' `estimate` and `se` as scalars. `pointwise` is a numeric vector. +#' `.validate_measure_result()` accepts both.} +#' } +#' +#' @noRd +.compute_measure <- function( + y, + ypred, + mupred, + ylp, + measure_entry, + log_weights, + control = list(), + lppd_i +) { + if (measure_entry$type == "builtin") { + spec <- .measure_spec[[measure_entry$key]] + measure_fun <- spec$fun + if (is.null(measure_fun)) { + cli::cli_abort("Unknown built-in measure {.val {measure_entry$key}}.") + } + } else { + spec <- NULL + measure_fun <- measure_entry$key + } + + measure_control <- control[[measure_entry$name]] + if (is.null(measure_control)) { + measure_control <- list() + } + + pool <- if (isTRUE(spec$needs_elpd)) { + if (is.function(spec$elpd_transform)) { + lppd_i <- spec$elpd_transform(lppd_i) + } + # `ylp` has no default, and `.inform_ignored_inputs()` forces it. Pass it as + # NULL rather than leaving it out. + list(ylp = NULL, log_weights = NULL, pointwise = lppd_i) + } else { + list( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + log_weights = log_weights + ) + } + + pool <- c(pool, measure_control) + args <- pool[intersect(names(formals(measure_fun)), names(pool))] + res <- do.call(measure_fun, args) + if (measure_entry$type == "custom") { + n_obs <- .measure_n_obs(y, ypred, mupred, ylp) + res <- .validate_measure_result(res, measure_entry$name, n_obs = n_obs) + } + res +} + +#' Effective number of parameters for the evaluation source +#' +#' @description +#' Gives `p_loo` or `p_kfold`, which follow the `elpd` row. It reuses a stored +#' row from `predperf`, `loo` or `kfold`. Otherwise, for `loo`, it computes +#' from `ylp` with `.compute_effective_param()`. +#' +#' @return A list with `estimate`, `se` and `pointwise`, or `NULL` for +#' `insample` and `test`, or when nothing is available. +#' +#' @noRd +.effective_param <- function(source, ylp, lppd_i, loo, kfold, predperf) { + if (!source %in% c("loo", "kfold")) { + return(NULL) + } + col <- .measure_result_name(source, "p") + stored <- if (!is.null(predperf)) predperf else if (source == "kfold") kfold else loo + if (col %in% rownames(stored$estimates)) { + return(list( + estimate = unname(stored$estimates[col, "Estimate"]), + se = unname(stored$estimates[col, "SE"]), + pointwise = stored$pointwise[, col] + )) + } + if (source == "loo" && !is.null(ylp)) { + return(.compute_effective_param(ylp, lppd_i)) + } + NULL +} + +#' Compute effective number of parameters (`p_loo`) +#' +#' @description +#' Per-observation effective number of parameters as the difference between +#' the log posterior predictive density (`lpd`) and the cross-validated log +#' predictive density (`elpd`). Summed across observations, this matches +#' `p_loo` from the **loo** package: it describes how much harder it is to +#' predict held-out data than the data used to fit the model. +#' +#' @param ylp Matrix of pointwise log predictive densities (`S` × `n`). +#' @param elpd_cv_i Numeric vector of length `n` with LOO pointwise ELPD +#' contributions. +#' +#' @return A named list with `estimate` (total `p_loo`), `se`, and `pointwise` +#' (`p_loo` per observation). +#' +#' @references See the **loo** package glossary (`vignette("loo2", package = "loo")`) +#' and \url{https://users.aalto.fi/~ave/CV-FAQ.html#p_loo}. +#' +#' @noRd +.compute_effective_param <- function(ylp, elpd_cv_i) { + lpd_i <- matrixStats::colLogSumExps(ylp) - log(nrow(ylp)) + p_eff_i <- lpd_i - elpd_cv_i + + list( + estimate = sum(p_eff_i), + se = sqrt(ncol(ylp) * var(p_eff_i)), + pointwise = p_eff_i + ) +} + +#' Add or update a row or column in a summary matrix +#' +#' @description +#' Builds the `estimates` and `pointwise` matrices used in +#' [pred_measure()] results. When `margin = 1`, appends or updates a **row** +#' (for estimates). When `margin = 2`, appends or updates a **column** +#' (for pointwise). +#' +#' If `mat` is `NULL`, returns a new one-row or one-column matrix for `name`. +#' If `name` is already present along that margin, the update is skipped with a +#' warning. Otherwise the new slice is bound with [rbind()] or [cbind()]. +#' +#' @param source Character string; one of `"loo"`, `"insample"`, `"kfold"`, or +#' `"test"`. +#' @param mat Existing matrix, or `NULL` when adding the first measure. +#' @param name Character label for the row (`margin = 1`) or column +#' (`margin = 2`). +#' @param values Numeric vector to store. For `margin = 1`, length-2 vector +#' `(estimate, se)`; for `margin = 2`, length-`n` pointwise vector. +#' @param margin `1` to merge along rows (estimates table), `2` along columns +#' (pointwise table). +#' +#' @return Updated matrix with `name` as a row or column name. +#' +#' @noRd +.measure_result_name <- function(source, name) { + switch( + source, + kfold = paste0(name, "_kfold"), + loo = paste0(name, "_loo"), + test = paste0(name, "_test"), + insample = name + ) +} + +#' @noRd +.merge_matrix <- function(source, mat, name, values, margin) { + is_row <- margin == 1 + bind_fn <- if (is_row) rbind else cbind + name_updated <- .measure_result_name(source, name) + + new_slice <- if (is_row) { + matrix(values, nrow = 1, dimnames = list(name_updated, c("Estimate", "SE"))) + } else { + matrix(values, ncol = 1, dimnames = list(NULL, name_updated)) + } + + if (is.null(mat)) return(new_slice) + bind_fn(mat, new_slice) +} + +#' Construct the S3 predictive measure result object +#' +#' @description +#' Wraps computed summaries into the list structure returned by the +#' [pred_measure()] pipeline. S3 classes and attributes are attached later by +#' \code{.add_attributes()}. +#' +#' When `save_psis = TRUE`, the `psis_object` is stored in the result; otherwise +#' that slot is omitted. When a `psis_object` is available, its `log_weights` are +#' copied to the result. +#' +#' @param estimates Matrix of overall estimates and standard errors (rows = +#' measures, columns = `Estimate` and `SE`). +#' @param pointwise Matrix of observation-level contributions (columns = +#' measures). +#' @param diagnostics Optional PSIS or other diagnostic information, or `NULL`. +#' @param psis_object PSIS object with LOO weights and diagnostics, or `NULL`. +#' @param save_psis Logical; if `TRUE`, include `psis_object` in the result. +#' +#' @return A list with elements `estimates`, `pointwise`, and optionally +#' `diagnostics`, `psis_object`, and `log_weights`. Class attributes are added +#' by \code{.add_attributes()}. +#' +#' @noRd +.build_pred_measure <- function( + estimates, + pointwise, + diagnostics = NULL, + psis_object, + save_psis +) { + output_list <- list( + estimates = estimates, + pointwise = pointwise + ) + if (!is.null(diagnostics)) { + output_list$diagnostics <- diagnostics + } + if (isTRUE(save_psis)) { + output_list$psis_object <- psis_object + } + if (!is.null(psis_object)) { + output_list$log_weights <- psis_object$log_weights + } + + structure(output_list) +} + +#' Attach S3 classes and metadata attributes to a result +#' +#' @description +#' Sets `class`, `source`, and `dims` 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. +#' 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.). +#' +#' @param save_psis Logical; when `FALSE` and accumulating, clears stored +#' `psis_object` from the prior result. +#' @param predperf_res List returned by \code{.build_pred_measure()}. +#' @param y Vector of observed values; used indirectly via matrix `dims`. +#' @param ypred Matrix of posterior predictive draws; used to set `dims`. +#' @param mupred Matrix of posterior expected values; used to set `dims`. +#' @param ylp Matrix of pointwise log predictive densities; used to set `dims`. +#' @param ylp_test Matrix of holdout log predictive densities; sets `dims` for +#' `source = "test"`. +#' @param kfold Optional `kfold` object whose attributes are inherited. +#' @param loo Optional [loo::loo()] object whose attributes are inherited. +#' @param predperf Existing object when accumulating measures, or `NULL`. +#' @param source Character evaluation mode (`"insample"`, `"loo"`, `"kfold"`, +#' or `"test"`). +#' +#' @return The updated `predperf_res` with class and attributes set. +#' +#' @noRd +.add_attributes <- function(save_psis, predperf_res, y, ypred, mupred, ylp, ylp_test, kfold, loo, predperf, source) { + if (!is.null(predperf)) { + if (isFALSE(save_psis)) { + predperf$psis_object <- NULL + } + attributes(predperf_res) <- attributes(predperf) + + dims <- if (!is.null(ypred)) { + dim(ypred) + } else if (!is.null(mupred)) { + dim(mupred) + } else if (!is.null(ylp)) { + dim(ylp) + } else { + attr(predperf, "dims") + } + attr(predperf_res, "dims") <- dims + + return(predperf_res) + } + + predperf_res <- switch( + source, + kfold = .copy_attrs( + predperf_res, + kfold, + setdiff(names(attributes(kfold)), "names") + ), + loo = .copy_attrs( + predperf_res, + loo, + setdiff(names(attributes(loo)), "names") + ), + test = , # fall through (same as insample) + insample = predperf_res + ) + + if (source %in% c("insample", "test") || + (is.null(attr(predperf_res, "dims")) && !is.null(ylp))){ + # make attribute names consistent between pred_measure classes + if (source == "test") { + attr(predperf_res, "dims") <- attr(ylp_test, "dim") + } else { + attr(predperf_res, "dims") <- attr(ylp, "dim") + } + } + + classes <- c( + switch( + source, + loo = "loo_pred_measure", + insample = "insample_pred_measure", + kfold = "kfold_pred_measure", + test = "test_pred_measure", + "pred_measure" + ), + "pred_measure", + attr(predperf_res, "class") + ) + if (source == "loo" && !"loo" %in% classes) { + classes <- c(classes, "loo") + } + attr(predperf_res, "class") <- classes + attr(predperf_res, "source") <- source + + return(predperf_res) +} \ No newline at end of file diff --git a/R/pred_measure-helpers.R b/R/pred_measure-helpers.R new file mode 100644 index 00000000..439d2fd4 --- /dev/null +++ b/R/pred_measure-helpers.R @@ -0,0 +1,752 @@ +#' Normalize the `measure` argument to an internal list +#' +#' @description +#' Converts `measure` (character, function, list, or `NULL`) into a list of +#' entries with elements `name`, `type` (`"builtin"` or `"custom"`), and `key` +#' (built-in name or function). +#' +#' @param measure User-supplied `measure` argument. +#' +#' @return A list of normalized measure entries, or an empty list when +#' `measure` is `NULL`. +#' +#' @noRd +.normalize_measure <- function(measure) { + if (is.null(measure)) { + return(list()) + } + + if (is.function(measure)) { + entries <- list(.measure_entry_custom(measure)) + .check_measure_entry_names(entries) + return(entries) + } + + if (is.character(measure)) { + entries <- lapply(measure, function(nm) { + list(name = nm, type = "builtin", key = nm) + }) + .check_measure_entry_names(entries) + return(entries) + } + + if (is.list(measure)) { + if (length(measure) == 0L) { + return(list()) + } + entries <- lapply(seq_along(measure), function(i) { + el <- measure[[i]] + nm <- names(measure)[i] + if (is.character(el) && length(el) == 1L) { + list(name = el, type = "builtin", key = el) + } else if (is.function(el)) { + if (is.null(nm) || !nzchar(nm)) { + cli::cli_abort(c( + "Each custom function in {.arg measure} must be named.", + "i" = "Use {.code measure = list(my_metric = my_fun)}." + )) + } + list(name = nm, type = "custom", key = el) + } else { + cli::cli_abort(c( + "Each element of {.arg measure} must be a character scalar (built-in", + "name) or a function (custom measure).", + "i" = "Element {i} has type {.cls {class(el)[1]}}." + )) + } + }) + .check_measure_entry_names(entries) + return(entries) + } + + cli::cli_abort(c( + "{.arg measure} must be a character vector, a function, a list, or", + "{.code NULL}.", + "i" = "Got an object of class {.cls {class(measure)[1]}}." + )) +} + +#' Build a custom measure entry from a function +#' +#' @param fun Function implementing a custom measure. +#' @noRd +.measure_entry_custom <- function(fun) { + name <- attr(fun, "measure_name", exact = TRUE) + if (is.null(name) || length(name) != 1L || !nzchar(name)) { + cli::cli_abort(c( + "A custom function passed to {.arg measure} must have attribute", + "{.code measure_name}.", + "i" = "Set {.code attr(my_fun, \"measure_name\") <- \"my_metric\"}." + )) + } + list(name = name, type = "custom", key = fun) +} + +#' Check duplicate measure names +#' +#' @param entries List of normalized measure entries from `.normalize_measure()`. +#' @noRd +.check_measure_entry_names <- function(entries) { + names <- vapply(entries, `[[`, "", "name") + dups <- names[duplicated(names)] + if (length(dups) > 0L) { + cli::cli_abort(c( + "Duplicate measure names in {.arg measure}: {.val {unique(dups)}}", + "i" = "Each measure may appear only once." + )) + } + invisible(NULL) +} + +#' Normalize, validate, and filter the `measure` argument +#' +#' @description +#' Converts `measure` via `.normalize_measure()`, validates built-in names and +#' custom functions, and drops entries already present in `predperf`. An empty +#' measure gives `"elpd"` for a new result. +#' +#' @param measure User-supplied `measure` argument (see `.normalize_measure()`). +#' @param predperf Existing pred_measure object used when accumulating measures. +#' @param supported_measures_list Character vector of allowed built-in names. +#' @param source Character evaluation mode (`"insample"`, `"loo"`, `"kfold"`, +#' or `"test"`); selects the row-name suffix used to match `predperf`. +#' +#' @return A list of normalized measure entries ready for computation. +#' +#' @noRd +.prepare_measures <- function( + measure, predperf, supported_measures_list, source +) { + if (length(measure) == 0L) { + if (!is.null(predperf)) return(list()) + measure <- "elpd" + } + entries <- .normalize_measure(measure) + + is_builtin <- vapply(entries, function(e) e$type == "builtin", logical(1L)) + builtin_keys <- vapply(entries[is_builtin], function(e) e$key, character(1L)) + invalid <- setdiff(builtin_keys, supported_measures_list) + if (length(invalid) > 0L) { + cli::cli_abort(c( + "Invalid measure{?s}: {paste(shQuote(invalid), collapse = ', ')}", + "i" = "Built-in measures must be one of:", + " " = "{paste(shQuote(supported_measures_list), collapse = ', ')}" + )) + } + + is_custom <- !is_builtin + if (any(is_custom)) { + for (entry in entries[is_custom]) { + checkmate::assert_function(entry$key, .var.name = "measure") + } + } + + if (!is.null(predperf)) { + existing_measures <- rownames(predperf$estimates) + entry_names <- vapply( + entries, + function(e) .measure_result_name(source, e$name), + character(1L) + ) + dups <- intersect(entry_names, existing_measures) + if (length(dups) > 0L) { + cli::cli_warn(c( + "!" = "{cli::qty(length(dups))} Measure{?s} {.val {dups}} {?is/are}", + "already present in {.arg predperf} and will be skipped." + )) + } + keep <- !(entry_names %in% existing_measures) + entries <- entries[keep] + } + + entries +} + +#' Check whether any measure needs the pointwise `elpd` +#' +#' @description +#' Returns `TRUE` if a built-in entry sets `needs_elpd` in `.measure_spec` +#' (`elpd`, `mlpd`, `ic`). Custom entries never need it. +#' +#' @param entries Normalized measure entries from `.prepare_measures()`. +#' +#' @return A single logical. +#' +#' @noRd +.any_needs_elpd <- function(entries) { + any(vapply(entries, function(e) { + e$type == "builtin" && isTRUE(.measure_spec[[e$key]]$needs_elpd) + }, logical(1L))) +} + +#' Infer number of observations from measure inputs +#' +#' @noRd +.measure_n_obs <- function(y, ypred, mupred, ylp) { + if (!is.null(y)) { + return(length(y)) + } + if (!is.null(ypred)) { + return(ncol(ypred)) + } + if (!is.null(mupred)) { + return(if (length(dim(mupred)) == 3L) dim(mupred)[2L] else ncol(mupred)) + } + if (!is.null(ylp)) { + return(ncol(ylp)) + } + NULL +} + +#' Validate the return value of a custom measure function +#' +#' @param res Object returned by a custom measure function. +#' @param measure_name Label used in error messages. +#' @param n_obs Expected length of `pointwise`, or `NULL` to skip. +#' +#' @return `res`, invisibly. +#' +#' @noRd +.validate_measure_result <- function(res, measure_name, n_obs = NULL) { + if (!is.list(res)) { + cli::cli_abort(c( + "Custom measure {.val {measure_name}} must return a list.", + "i" = "Got an object of class {.cls {class(res)[1]}}." + )) + } + + if (!is.null(res$estimates)) { + if (!is.numeric(res$estimates) || length(res$estimates) != 2L) { + cli::cli_abort(c( + "{.field estimates} from custom measure {.val {measure_name}} must be", + "a numeric vector of length 2 (estimate and SE)." + )) + } + } else { + missing <- setdiff(c("estimate", "se", "pointwise"), names(res)) + if (length(missing) > 0L) { + cli::cli_abort(c( + "Custom measure {.val {measure_name}} must return a list with", + "{.field estimate}, {.field se}, and {.field pointwise}.", + "x" = "Missing: {.field {missing}}" + )) + } + if (!is.numeric(res$estimate) || length(res$estimate) != 1L) { + cli::cli_abort( + "{.field estimate} from custom measure {.val {measure_name}} must be a numeric scalar." + ) + } + if (!is.numeric(res$se) || length(res$se) != 1L) { + cli::cli_abort( + "{.field se} from custom measure {.val {measure_name}} must be a numeric scalar." + ) + } + } + + if (is.null(res$pointwise)) { + cli::cli_abort( + "Custom measure {.val {measure_name}} must return {.field pointwise}." + ) + } + if (!is.numeric(res$pointwise) || length(res$pointwise) < 1L) { + cli::cli_abort( + "{.field pointwise} from custom measure {.val {measure_name}} must be a numeric vector." + ) + } + if (!is.null(n_obs) && length(res$pointwise) != n_obs) { + cli::cli_abort(c( + "{.field pointwise} from custom measure {.val {measure_name}} must have", + "length {.val {n_obs}}, not {.val {length(res$pointwise)}}." + )) + } + # pass measure name if user set it as attribute + attr(res, "measure") <- measure_name + + invisible(res) +} + +#' Validate a numeric matrix argument +#' +#' @description +#' Checks that `x` is a numeric matrix with at least one row and column. +#' Optionally enforces expected `nrow` and/or `ncol`. Aborts via +#' [cli::cli_abort()] when validation fails. +#' +#' @param x Object to validate. +#' @param arg Name of the argument (used in error messages). +#' @param nrow Expected number of rows, or `NULL` to skip this check. +#' @param ncol Expected number of columns, or `NULL` to skip this check. +#' +#' @return `NULL`, invisibly, on success. +#' +#' @noRd +.validate_numeric_matrix <- function(x, arg, nrow = NULL, ncol = NULL) { + if (!is.numeric(x) || (!is.matrix(x) && !is.array(x))) { + cli::cli_abort( + "{.arg {arg}} must be a numeric matrix or array, not {.obj_type_friendly {x}}." + ) + } + if (!is.null(nrow) && nrow(x) != nrow) { + cli::cli_abort( + "{.arg {arg}} must have {.val {nrow}} row{?s}, not {.val {nrow(x)}}." + ) + } + if (!is.null(ncol) && ncol(x) != ncol) { + cli::cli_abort( + "{.arg {arg}} must have {.val {ncol}} column{?s}, not {.val {ncol(x)}}." + ) + } + if (nrow(x) < 1 || ncol(x) < 1) { + cli::cli_abort("{.arg {arg}} must have at least 1 row and 1 column.") + } +} + +#' Validate a numeric vector argument +#' +#' @description +#' Checks that `x` is a numeric atomic vector (not a matrix or array) with +#' length at least one. Optionally enforces an expected `len`. Aborts via +#' [cli::cli_abort()] when validation fails. +#' +#' @param x Object to validate. +#' @param arg Name of the argument (used in error messages). +#' @param len Expected length, or `NULL` to skip this check. +#' +#' @return `NULL`, invisibly, on success. +#' +#' @noRd +.validate_numeric_vector <- function(x, arg, len = NULL) { + if (!is.atomic(x) || !is.numeric(x) || is.matrix(x) || is.array(x)) { + cli::cli_abort("{.arg {arg}} must be a numeric vector.") + } + if (!is.null(len) && length(x) != len) { + cli::cli_abort( + "{.arg {arg}} must have length {.val {len}}, not {.val {length(x)}}." + ) + } + if (length(x) < 1) { + cli::cli_abort("{.arg {arg}} must not be empty.") + } +} + +#' Validate and normalize log weights +#' +#' @description +#' Validates that `log_weights` is a numeric matrix of size `n_draws` by +#' `n_obs`, then column-normalizes it via `.normalize_log_weights()`. +#' +#' @param log_weights Numeric matrix of log weights (`n_draws` \eqn{\times} +#' `n_obs`). +#' @param n_draws Expected number of rows (posterior draws). +#' @param n_obs Expected number of columns (observations). +#' +#' @return Numeric matrix of the same dimensions as `log_weights` with +#' column-normalized log weights. +#' +#' @noRd +.normalize_and_validate_log_weights <- function(log_weights, n_draws, n_obs) { + .validate_numeric_matrix( + log_weights, + arg = "log_weights", + nrow = n_draws, + ncol = n_obs + ) + .normalize_log_weights(log_weights) +} + +#' Inform about ignored inputs when pointwise is supplied +#' +#' @description +#' When `pointwise` is not `NULL`, emits an informative message via +#' [cli::cli_inform()] listing non-`NULL` entries in `ignored_args` that are +#' not used. +#' +#' @param pointwise Optional precomputed pointwise contributions. When +#' `NULL`, no message is emitted. +#' @param ignored_args Named list of arguments that may be ignored (e.g. +#' `ylp`, `log_weights`). +#' @param fun_name Name of the calling function (shown in the message). +#' +#' @return `NULL`, invisibly. +#' +#' @noRd +.inform_ignored_inputs <- function(pointwise, ignored_args, fun_name) { + if (is.null(pointwise)) { + return(invisible(NULL)) + } + supplied <- names(ignored_args)[vapply(ignored_args, Negate(is.null), logical(1))] + if (length(supplied) > 0L) { + cli::cli_inform( + "In {.fn {fun_name}}, {.arg pointwise} is provided; ignoring {.arg {supplied}}." + ) + } + invisible(NULL) +} + +#' Validate probability values +#' +#' @description +#' Checks that all elements of `x` lie in the closed interval \eqn{[0, 1]}. +#' Aborts via [cli::cli_abort()] when any value is out of range. +#' +#' @param x Numeric vector or matrix of probabilities. +#' @param arg Name of the argument (used in error messages). +#' +#' @return `NULL`, invisibly, on success. +#' +#' @noRd +.validate_probs <- function(x, arg) { + if (!all(x >= 0 & x <= 1)) { + cli::cli_abort("{.arg {arg}} must contain values in [0, 1].") + } +} + +#' Pointwise log predictive density from measure inputs +#' +#' @description +#' `measure_elpd()`, `measure_mlpd()` and `measure_ic()` take the same inputs: +#' precomputed `pointwise` values, or an `ylp` matrix with optional +#' `log_weights`. This helper holds their shared validation. +#' +#' @param ylp A draws x observations matrix of log predictive densities, or a +#' 3-D array. +#' @param log_weights Optional log weights, normalized before use. +#' @param pointwise Optional numeric vector of precomputed pointwise values. +#' @param fun_name Name of the calling measure. Used in the message that +#' reports ignored inputs. +#' +#' @return A list with `lppd_i`, `n_draws` (`NULL` when `pointwise` is +#' supplied) and `n_obs`. +#' +#' @noRd +.lppd_from_inputs <- function(ylp, log_weights, pointwise, fun_name) { + if (!is.null(pointwise)) { + .validate_numeric_vector(pointwise, arg = "pointwise") + .inform_ignored_inputs( + pointwise, + ignored_args = list(ylp = ylp, log_weights = log_weights), + fun_name = fun_name + ) + return(list(lppd_i = pointwise, n_draws = NULL, n_obs = length(pointwise))) + } + + .validate_numeric_matrix(ylp, arg = "ylp") + ylp <- if (is.array(ylp) && length(dim(ylp)) == 3) { + llarray_to_matrix(ylp) + } else { + ylp + } + n_draws <- nrow(ylp) + n_obs <- ncol(ylp) + if (!is.null(log_weights)) { + log_weights <- .normalize_and_validate_log_weights( + log_weights = log_weights, n_draws = n_draws, n_obs = n_obs + ) + } + list( + lppd_i = ptw_log_pred_density(ylp, log_weights), + n_draws = n_draws, + n_obs = n_obs + ) +} + +#' Weighted pointwise classification accuracy +#' +#' @description +#' Shared by `measure_acc()` and `measure_bacc()`. Maps each observation to a +#' predicted class, then compares it with `y`. Binary `mupred` is thresholded +#' at 0.5. A 3-D `mupred` takes the argmax over categories. +#' +#' @param y An integer vector of observed class labels. +#' @param mupred A draws x observations matrix, or a draws x observations x +#' categories array, of predicted probabilities. +#' @param log_weights Optional log weights. Draws are equally weighted when +#' `NULL`. +#' +#' @return An integer vector of 0/1 accuracy contributions. +#' +#' @noRd +.acc_pointwise <- function(y, mupred, log_weights) { + if (!is.numeric(mupred) || (length(dim(mupred)) != 2 && length(dim(mupred)) != 3)) { + cli::cli_abort( + "{.arg mupred} must be a numeric matrix or 3D numeric array." + ) + } + .validate_probs(mupred, arg = "mupred") + + if (!is.null(log_weights)) { + weights <- exp(.normalize_and_validate_log_weights( + log_weights = log_weights, + n_draws = nrow(mupred), + n_obs = dim(mupred)[2] + )) + } else { + weights <- rep(1 / nrow(mupred), nrow(mupred)) + } + + if (length(dim(mupred)) == 3) { + # Multiclass: (draws × obs × categories) > argmax over categories + weighted_mupred <- apply(array(weights, dim(mupred)) * mupred, c(2, 3), sum) + mupred_hat <- apply(weighted_mupred, 1, which.max) + } else { + .validate_numeric_matrix(mupred, arg = "mupred") + weighted_mupred <- colSums(mupred * weights) + mupred_hat <- (weighted_mupred > 0.5) * 1L + } + + (mupred_hat == y) * 1L +} + +#' Pointwise prediction error from measure inputs +#' +#' @description +#' Shared by `measure_mae()` and `measure_mse()`. Forms a point prediction for +#' each observation, then applies `transform` to the residual. The point +#' prediction is the mean of the `mupred` draws, or their weighted mean when +#' `log_weights` is supplied. +#' +#' @param y A numeric vector of observed outcomes. +#' @param mupred A draws x observations matrix of point predictions. A vector +#' is coerced to a 1 x n matrix. +#' @param log_weights Optional log weights, normalized before use. +#' @param pointwise Optional numeric vector of precomputed pointwise errors. +#' @param fun_name Name of the calling measure. Used in the messages that +#' report ignored inputs and the coercion of `mupred`. +#' @param transform Function applied to the residual `y - yhat`. +#' +#' @return A list with `err_i`, `n_draws` (`NULL` when `pointwise` is +#' supplied) and `n_obs`. +#' +#' @noRd +.point_error_from_inputs <- function(y, mupred, log_weights, pointwise, + fun_name, transform) { + if (!is.null(pointwise)) { + .inform_ignored_inputs( + pointwise, + ignored_args = list(mupred = mupred, log_weights = log_weights), + fun_name = fun_name + ) + return(list(err_i = pointwise, n_draws = NULL, n_obs = length(pointwise))) + } + + n_draws <- nrow(mupred) + n_obs <- ncol(mupred) + .validate_numeric_vector(y, arg = "y") + if (!is.null(mupred) && !is.matrix(mupred)) { + .validate_numeric_vector(mupred, arg = "mupred", len = length(y)) + cli::cli_inform( + "Coercing {.arg mupred} from vector to 1 x n matrix for {.fn {fun_name}}." + ) + mupred <- matrix(mupred, nrow = 1, ncol = length(mupred)) + } + .validate_numeric_matrix(mupred, arg = "mupred", ncol = length(y)) + if (is.null(log_weights)) { + yhat <- colMeans(mupred) + } else { + weights <- exp(.normalize_and_validate_log_weights( + log_weights = log_weights, n_draws = n_draws, n_obs = n_obs + )) + yhat <- colSums(weights * mupred) + } + list(err_i = transform(y - yhat), n_draws = n_draws, n_obs = n_obs) +} + +#' Copy selected attributes between objects +#' +#' @description +#' Copies attributes named in `which` from `from` onto `to`, overwriting any +#' existing attributes with the same names. +#' +#' @param to Object receiving attributes. +#' @param from Object supplying attributes. +#' @param which Character vector of attribute names to copy. +#' +#' @return `to`, with updated attributes. +#' +#' @noRd +.copy_attrs <- function(to, from, which) { + for (nm in which) { + attr(to, nm) <- attr(from, nm) + } + to +} + +#' Normalize log weights +#' +#' @description +#' Normalizes a matrix of log weights column-wise so that the weights in each +#' column sum to one on the probability scale. Normalization is performed by +#' subtracting the log-sum-exp of each column from its elements, equivalent to +#' dividing each column's weights by their sum on the probability scale. +#' +#' @param log_weights Numeric matrix of log weights (`n_draws` \eqn{\times} +#' `n_obs`), where rows are draws and columns are observations. +#' +#' @return Numeric matrix of the same dimensions as `log_weights` with +#' column-normalized log weights. +#' +#' @noRd +.normalize_log_weights <- function(log_weights) { + sweep( + log_weights, + 2, + matrixStats::colLogSumExps(log_weights), + FUN = "-", + check.margin = FALSE + ) +} + +#' Probability-weighted moment estimator of E|X - X'| +#' +#' @description +#' Estimates \eqn{E[|X - X'|]}, the expected absolute difference between two +#' independent draws from the predictive distribution, which is the term the +#' (S)RPS and (S)CRPS scores in [measure_rps()] are built from. Written as a +#' weighted U-statistic over draw pairs, the estimator is +#' \deqn{E[|X - X'|] = \frac{\sum_i \sum_{j \neq i} w_i w_j |x_i - x_j|}{1 - +#' \sum_i w_i^2} = \frac{2 \sum_s w_{(s)} x_{(s)} (C_s + C_{s-1} - 1)}{1 - +#' \sum_s w_{(s)}^2},} +#' where \eqn{x_{(s)}} are the draws sorted in ascending order, \eqn{w_{(s)}} +#' their weights, and \eqn{C_s = \sum_{k \le s} w_{(k)}}. The second form is the +#' one computed here and needs only a single sort and cumulative sum per column. +#' +#' With equal weights \eqn{w_{(s)} = 1/S} this reduces exactly to the classic +#' unbiased pairwise estimator with the \eqn{1 / (S (S - 1))} normalization, +#' i.e. `colMeans(x_sorted * 2 * (2 * (1:S) - S - 1) / (S - 1))`, which is the +#' probability-weighted moment estimator of Taillardat et al. (2016). Because +#' the estimate is a convex combination of \eqn{|x_i - x_j|} it is always +#' non-negative, so `log()` of it in the scaled scores is always defined, and +#' the coefficients sum to zero, so it is invariant to shifts of `ypred`. +#' +#' @param ypred Numeric matrix of posterior predictive draws (`n_draws` +#' \eqn{\times} `n_obs`), where rows are draws and columns are observations. +#' @param w Optional numeric matrix of column-normalized weights on the +#' probability scale, of the same dimensions as `ypred`. `NULL` (the default) +#' uses equal weights and takes the faster unweighted path. +#' +#' @return Numeric vector of length `ncol(ypred)` with one estimate of +#' \eqn{E[|X - X'|]} per observation. +#' +#' @noRd +.exx_pwm <- function(ypred, w = NULL) { + n_draws <- nrow(ypred) + if (n_draws < 2) { + stop( + "`ypred` must have at least 2 draws (rows) to estimate E|X - X'|, ", + "which the RPS/CRPS measures require.", + call. = FALSE + ) + } + + if (is.null(w)) { + ypred_sorted <- apply(ypred, 2, sort) + coefs <- 2 * (2 * seq_len(n_draws) - n_draws - 1) / (n_draws - 1) + return(colMeans(ypred_sorted * coefs)) + } + + vapply( + seq_len(ncol(ypred)), + function(j) { + ord <- order(ypred[, j]) + x_sorted <- ypred[ord, j] + w_sorted <- w[ord, j] + denominator <- 1 - sum(w_sorted^2) + # All the weight sits on a single draw: the pair (X, X') is degenerate + # and E|X - X'| is 0. + if (denominator <= 0) { + return(0) + } + # C_s + C_{s-1} = 2 * C_s - w_(s) + coefs <- 2 * cumsum(w_sorted) - w_sorted - 1 + 2 * sum(w_sorted * x_sorted * coefs) / denominator + }, + numeric(1) + ) +} + + + +#' Validate control argument +#' +#' @description +#' Validates that the arguments passed to the control list are valid +#' arguments for the corresponding function. If not, a warning is issued that +#' corresponding invalid argument is ignored. +#' +#' @param control Named list of per-measure settings. +#' +#' @keywords internal +#' @noRd +.validate_control <- function(control) { + res <- checkmate::check_list(control, types = "list", names = "named") + if (!isTRUE(res)) { + cli::cli_abort(c( + "{.arg control} must be a named list of named lists.", + "i" = "Expected format: {.code list(fun_name = list(arg1 = val1, arg2 = val2))}" + )) + } + + 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)))) + ] + if (length(invalid_args) > 0) { + cli::cli_warn( + "Ignoring {.arg {invalid_args}} as it is not a valid argument of {.fn {func_name}}." + ) + } + } +} + +#' Subset measure results +#' +#' @description +#' Subsets the measure results to the specified measures and components. +#' +#' @param x Measure results object. +#' @param measures Character vector of measures to subset. +#' @param components Character vector of components to subset. +#' +#' @return Subsetted measure results object. +#' +#' @noRd +subset_measures <- function(x, measures, components) { + invalid_components <- setdiff(components, names(x)) + if (length(invalid_components) > 0) { + cli::cli_abort(c( + "{.arg components} contains invalid value{?s}: {.val {invalid_components}}.", + "i" = "Valid components: {.val {names(x)}}." + )) + } + components <- intersect(components, names(x)) + + available_measures <- if ("estimates" %in% components) { + rownames(x$estimates) + } else if ("pointwise" %in% components) { + colnames(x$pointwise) + } + + if (!is.null(available_measures)) { + invalid_measures <- setdiff(measures, available_measures) + if (length(invalid_measures) > 0) { + cli::cli_abort(c( + "{.arg measures} contains invalid value{?s}: {.val {invalid_measures}}.", + "i" = "Valid measures: {.val {available_measures}}." + )) + } + } + + result <- x[components] + + if ("estimates" %in% components) { + rows <- intersect(measures, rownames(result$estimates)) + result$estimates <- result$estimates[rows, , drop = FALSE] + } + + if ("pointwise" %in% components) { + cols <- intersect(measures, colnames(result$pointwise)) + result$pointwise <- result$pointwise[, cols, drop = FALSE] + } + + result +} diff --git a/R/pred_measure.R b/R/pred_measure.R new file mode 100644 index 00000000..5b366c80 --- /dev/null +++ b/R/pred_measure.R @@ -0,0 +1,488 @@ +#' In-sample predictive performance measures +#' +#' @description +#' Compute predictive performance measures on the same data used to fit the +#' model. This is the simplest entry point when you want density scores +#' (`elpd`) and optional distributional or point-prediction metrics in +#' one call. +#' +#' In-sample `elpd` sums the expected log pointwise predictive density (ELPD) +#' over the training observations. Because the model has already seen these +#' data, in-sample scores are **optimistically biased** for predicting future +#' or otherwise unseen observations. For out-of-sample performance, use +#' [loo_pred_measure()], [kfold_pred_measure()], or [test_pred_measure()] +#' instead; see Vehtari's +#' [Cross-validation FAQ](https://users.aalto.fi/~ave/CV-FAQ.html) (Section 4). +#' +#' @inheritParams pred_measure_params +#' +#' @return +#' An object of class `"insample_pred_measure"` and `"pred_measure"`: a list +#' with: +#' \describe{ +#' \item{`estimates`}{Matrix of summary estimates and standard errors (rows +#' are measures, columns are `Estimate` and `SE`). The row `elpd` is +#' present when `measure` is `NULL` (default) or names "elpd".} +#' \item{`pointwise`}{Matrix of observation-level contributions (one column +#' per measure).} +#' } +#' +#' The attribute `source` is `"insample"`. Attribute `dims` gives posterior +#' draws × observations. Use [print()] for a readable summary table. +#' +#' @details +#' **Input requirements by measure.** Supply only the inputs each measure +#' needs: +#' +#' | Measure | `ylp` | `y` | `ypred` | `mupred` | +#' |:---|:---:|:---:|:---:|:---:| +#' | `elpd`, `mlpd`, `ic` | ✓ | | | | +#' | `crps`, `scrps`, `rps`, `srps` | | ✓ | ✓ | | +#' | `acc`, `bacc` | | ✓ | | ✓ | +#' | `mae`, `mse`, `rmse`, `r2` | | ✓ | | ✓ | +#' +#' "elpd" is the default measure. `mlpd` and `ic` are derived from `elpd`, but +#' requesting them does not add an `elpd` row. Request `ic`, `mlpd`, or other +#' density scores via `measure`, or supply a custom function; +#' see [supported_measures_list] and the +#' [overview of scores and metrics](https://mc-stan.org/loo/articles/articles-online-only/overview-measures.html) +#' article for definitions and orientation (higher vs lower is better). +#' +#' **Custom measures.** A function passed to `measure` must have attribute +#' `measure_name` and return `estimate`, `se`, and `pointwise`. Only arguments +#' declared in the function signature among `y`, `ypred`, `mupred`, `ylp`, and +#' `log_weights` are supplied automatically. +#' +#' @examples +#' \donttest{ +#' if (requireNamespace("brms", quietly = TRUE)) { +#' fit <- brms::brm( +#' Reaction ~ Days, data = lme4::sleepstudy, +#' refresh = 0, chains = 2, iter = 1000 +#' ) +#' insample_pred_measure( +#' ylp = brms::log_lik(fit), +#' y = fit$data$Reaction, +#' ypred = brms::posterior_predict(fit), +#' mupred = brms::posterior_epred(fit), +#' measure = c("rmse", "r2") +#' ) +#' } +#' } +#' \dontrun{ +#' # Custom measure (same contract as built-in point-prediction metrics) +#' my_abs_err <- function(y, mupred, log_weights = NULL) { +#' mu <- colMeans(mupred) +#' pw <- abs(y - mu) +#' list( +#' estimate = mean(pw), +#' se = sd(pw) / sqrt(length(pw)), +#' pointwise = pw +#' ) +#' } +#' attr(my_abs_err, "measure_name") <- "my_abs_err" +#' # insample_pred_measure(y = y, mupred = mupred, ylp = ylp, measure = my_abs_err) +#' } +#' +#' @seealso [pred_measure()] to add measures incrementally, +#' [loo_pred_measure()], [kfold_pred_measure()], [test_pred_measure()], +#' [supported_measures_list], +#' [pred-measure workflow article](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html) +#' +#' @export +insample_pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measure = NULL, + group_ids = NULL, + save_psis = FALSE, + control = list() +) { + do_pred_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + measure = measure, + predperf = NULL, + loo = NULL, + kfold = NULL, + group_ids = group_ids, + psis_object = NULL, + save_psis = save_psis, + source = "insample", + control = control + ) +} + +#' PSIS-LOO predictive performance measures +#' +#' @description +#' Estimate out-of-sample predictive performance with **PSIS-LOO** +#' (Pareto-smoothed importance sampling leave-one-out cross-validation). +#' PSIS-LOO approximates exact LOO-CV without refitting the model once per +#' observation: each held-out point is scored by reweighting the full-data +#' posterior draws. +#' +#' With the default `measure = NULL`, the result holds `elpd_loo`, the LOO +#' estimate of expected log pointwise predictive density (ELPD), and `p_loo` +#' (effective number of parameters, the difference between in-sample and LOO +#' log predictive density). `p_loo` is reported together with `elpd_loo`. +#' See [loo::loo()] and the +#' [Cross-validation FAQ](https://users.aalto.fi/~ave/CV-FAQ.html) for +#' interpretation. +#' +#' @inheritParams pred_measure_params +#' +#' @return +#' An object of class `"loo_pred_measure"`, `"pred_measure"`, and `"loo"`. +#' When a `loo` object is supplied, additional classes from that object are +#' inherited (e.g. `"psis_loo"`). In addition to `estimates` and +#' `pointwise`, the list may contain: +#' \describe{ +#' \item{`diagnostics`}{PSIS diagnostics, including Pareto \eqn{\hat{k}} in +#' `diagnostics$pareto_k`. A value above the sample-size dependent +#' threshold \eqn{\min(1 - 1 / \log_{10}(S), 0.7)}, where \eqn{S} is the +#' number of draws, suggests an unreliable LOO estimate for that +#' observation. The `print()` method reports the threshold it used.} +#' \item{`log_weights`}{Normalized log importance weights used for LOO +#' scoring.} +#' \item{`psis_object`}{Stored when `save_psis = TRUE`; needed to add +#' further measures with [pred_measure()] without recomputing weights.} +#' } +#' +#' Measure names carry a `_loo` suffix (e.g. `elpd_loo`, `crps_loo`). +#' +#' @details +#' **Three equivalent input patterns:** +#' +#' \describe{ +#' \item{Precomputed `loo` object}{`loo_pred_measure(loo = loo_fit, ...)`. +#' Run [loo::loo()] with `save_psis = TRUE`.} +#' \item{`ylp` + `psis_object`}{Pass both when you have already computed +#' PSIS weights separately.} +#' \item{`ylp` only}{PSIS weights are computed internally from `ylp`.} +#' } +#' +#' For distributional and point-prediction measures (`crps`, `r2`, etc.), +#' supply `y`, `ypred`, and/or `mupred` as for [insample_pred_measure()]. When +#' adding measures incrementally, call [pred_measure()] with `predperf` set to +#' an existing result; use `save_psis = TRUE` on the initial call so weights +#' are stored. +#' +#' @examples +#' \donttest{ +#' if (requireNamespace("brms", quietly = TRUE)) { +#' fit <- brms::brm( +#' Reaction ~ Days, data = lme4::sleepstudy, +#' refresh = 0, chains = 2, iter = 1000 +#' ) +#' loo_fit <- loo::loo(fit, save_psis = TRUE) +#' loo_pred_measure( +#' loo = loo_fit, +#' y = fit$data$Reaction, +#' ypred = brms::posterior_predict(fit), +#' measure = c("rmse", "r2") +#' ) +#' } +#' } +#' +#' @seealso [insample_pred_measure()], [pred_measure()], [loo::loo()], +#' [supported_measures_list], +#' [pred-measure workflow article](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html) +#' +#' @export +loo_pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measure = NULL, + loo = NULL, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + control = list() +) { + do_pred_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + ylp_test = NULL, + measure = measure, + predperf = NULL, + loo = loo, + kfold = NULL, + group_ids = group_ids, + psis_object = psis_object, + save_psis = save_psis, + source = "loo", + control = control + ) +} + +#' K-fold cross-validation predictive performance measures +#' +#' @description +#' Compute predictive performance measures under **k-fold cross-validation**. +#' K-fold CV holds out groups of observations, refits (or reuses stored fits), +#' and scores the held-out folds. +#' +#' Pass a `kfold` object from [brms::kfold()] (with `save_fits = TRUE` when +#' you need posterior predictions on held-out folds). `elpd_kfold` and +#' `p_kfold` come from the `kfold` object and are reported by default or when +#' `measure` names "elpd"; +#' additional measures require the same optional inputs as +#' [insample_pred_measure()]. +#' +#' @inheritParams pred_measure_params +#' +#' @return +#' An object of class `"kfold_pred_measure"` and `"pred_measure"`, inheriting +#' attributes from the `kfold` object (`K`, `folds`, `fold_type`, etc.). The +#' list contains `estimates` and `pointwise`; measure names carry a `_kfold` +#' suffix (e.g. `elpd_kfold`, `crps_kfold`). +#' +#' @details +#' For distributional measures on held-out folds, obtain posterior predictions +#' with `brms::kfold_predict()` and pass the resulting `yrep` matrices as +#' `ypred` and/or `mupred`. See the sleep-study workflow in +#' [pred-measure workflow article](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html). +#' +#' @examples +#' \donttest{ +#' if (requireNamespace("brms", quietly = TRUE)) { +#' fit <- brms::brm( +#' Reaction ~ Days, data = lme4::sleepstudy, +#' refresh = 0, chains = 2, iter = 1000 +#' ) +#' kf <- brms::kfold(fit, K = 5, save_fits = TRUE) +#' ypred_kf <- brms::kfold_predict(kf, method = "predict")$yrep +#' mupred_kf <- brms::kfold_predict(kf, method = "fitted")$yrep +#' kfold_pred_measure( +#' y = fit$data$Reaction, +#' ypred = ypred_kf, +#' mupred = mupred_kf, +#' kfold = kf, +#' measure = "rmse" +#' ) +#' } +#' } +#' +#' @seealso [loo_pred_measure()], [insample_pred_measure()], [pred_measure()], +#' [brms::kfold()], [supported_measures_list], +#' [pred-measure workflow article](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html) +#' +#' @export +kfold_pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measure = NULL, + kfold = NULL, + group_ids = NULL, + control = list() +) { + do_pred_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + ylp_test = NULL, + measure = measure, + predperf = NULL, + loo = NULL, + kfold = kfold, + group_ids = group_ids, + psis_object = NULL, + save_psis = FALSE, + source = "kfold", + control = control + ) +} + +#' Holdout predictive performance measures +#' +#' @description +#' Score predictive performance on **genuinely new (holdout) data** that was +#' not used to fit the model. This mirrors the cross-validation goal of +#' assessing how well a model predicts unseen observations, but with an +#' explicit train/test split rather than LOO or k-fold reweighting. +#' +#' Supply `ylp_test` from log predictive densities evaluated on the holdout set +#' (e.g. `brms::log_lik(fit, newdata = test_data)`). This is required for +#' `elpd_test`, `mlpd_test` and `ic_test`. Optional distributional and +#' point-prediction measures use observed and predicted values on the test set +#' only. Pass training `ylp` only when an additional measure needs log +#' predictive densities from the training fit. +#' +#' @inheritParams pred_measure_params +#' +#' @return +#' An object of class `"test_pred_measure"` and `"pred_measure"` with +#' `estimates` and `pointwise`. Measure names carry a `_test` suffix (e.g. +#' `elpd_test`, `crps_test`). Attribute `dims` reflects the test-set size +#' (from `ylp_test`), not the training data. +#' +#' @details +#' `elpd_test` is computed from `ylp_test` on the holdout +#' observations only. +#' +#' @examples +#' \donttest{ +#' if (requireNamespace("brms", quietly = TRUE)) { +#' data <- lme4::sleepstudy +#' train <- data[1:150, ] +#' test <- data[151:nrow(data), ] +#' fit <- brms::brm( +#' Reaction ~ Days, data = train, +#' refresh = 0, chains = 2, iter = 1000 +#' ) +#' test_pred_measure( +#' y = test$Reaction, +#' ypred = brms::posterior_predict(fit, newdata = test), +#' mupred = brms::posterior_epred(fit, newdata = test), +#' ylp = brms::log_lik(fit), +#' ylp_test = brms::log_lik(fit, newdata = test), +#' measure = c("rmse", "r2") +#' ) +#' } +#' } +#' +#' @seealso [insample_pred_measure()], [loo_pred_measure()], +#' [kfold_pred_measure()], [pred_measure()], [supported_measures_list], +#' [pred-measure workflow article](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html) +#' +#' @export +test_pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + ylp_test = NULL, + measure = NULL, + group_ids = NULL, + control = list() +) { + do_pred_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + ylp_test = ylp_test, + measure = measure, + predperf = NULL, + loo = NULL, + kfold = NULL, + group_ids = group_ids, + psis_object = NULL, + save_psis = FALSE, + source = "test", + control = control + ) +} + +#' Add predictive performance measures to an existing result +#' +#' @description +#' Extend a `"pred_measure"` object with additional measures **without +#' recomputing** what is already stored. Use this for interactive exploration +#' or when you first compute `elpd` and later add distributional +#' or point-prediction metrics. +#' +#' Pass the existing object as `predperf` and supply any inputs newly required +#' by the requested measures (see the input table in +#' [insample_pred_measure()]). The evaluation mode (`"insample"`, `"loo"`, +#' `"kfold"`, or `"test"`) is taken from `predperf`; LOO paths reuse stored +#' PSIS weights when available. +#' +#' @inheritParams pred_measure_params +#' +#' @return +#' An updated object of the same class as `predperf`, with new rows in +#' `estimates` and columns in `pointwise` for each requested measure. Rows +#' already in `predperf` are not recomputed. If `mlpd` or `ic` needs `elpd` and +#' `predperf` has no `elpd` column, `elpd` is recomputed from `ylp` for +#' insample and LOO results. For k-fold and test results this is an error. +#' +#' @details +#' **Typical workflow:** +#' +#' \preformatted{ +#' result <- loo_pred_measure(loo = loo_fit, save_psis = TRUE) +#' pred_measure( +#' y = y, +#' mupred = mupred, +#' predperf = result, +#' measure = c("rmse", "r2") +#' ) +#' } +#' +#' When extending a LOO result, ensure the initial call used `save_psis = TRUE` +#' (or that `predperf` already contains a `psis_object`) so LOO weights are +#' available for additional measures. +#' +#' @examples +#' \donttest{ +#' if (requireNamespace("brms", quietly = TRUE)) { +#' fit <- brms::brm( +#' Reaction ~ Days, data = lme4::sleepstudy, +#' refresh = 0, chains = 2, iter = 1000 +#' ) +#' result <- insample_pred_measure( +#' ylp = brms::log_lik(fit), +#' y = fit$data$Reaction, +#' ypred = brms::posterior_predict(fit) +#' ) +#' pred_measure( +#' y = fit$data$Reaction, +#' mupred = brms::posterior_epred(fit), +#' predperf = result, +#' measure = c("rmse", "r2") +#' ) +#' } +#' } +#' +#' @seealso [insample_pred_measure()], [loo_pred_measure()], +#' [kfold_pred_measure()], [test_pred_measure()], [supported_measures_list], +#' [pred-measure workflow article](https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html) +#' +#' @export +pred_measure <- function( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measure = NULL, + predperf, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + control = list() +) { + do_pred_measure( + y = y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + ylp_test = NULL, + measure = measure, + predperf = predperf, + loo = NULL, + kfold = NULL, + group_ids = group_ids, + psis_object = psis_object, + save_psis = save_psis, + source = attr(predperf, "source"), + control = control + ) +} + +#' @export +dim.pred_measure <- function(x) { + attr(x, "dims") +} diff --git a/R/print.R b/R/print.R index 1f4030b8..24d52446 100644 --- a/R/print.R +++ b/R/print.R @@ -249,3 +249,86 @@ convert_old_object <- function(x, digits = 1, ...) { ses <- grepl("se", nms) list(estimates = data.frame(Estimate = uz[!ses], SE = uz[ses])) } + +# print.R: S3 print methods for predictive measure objects and source +# labeling helpers. + + +#' @export +print.pred_measure <- function(x, digits = 1, ...) { + dims <- attr(x, "dims") + if (is.null(dims) && !is.null(x$log_weights)) { + dims <- dim(x$log_weights) + } + source <- .pred_measure_source_label(x) + + cat("\n") + if (!is.null(dims) && length(dims) == 2) { + cat( + sprintf( + "Computed from %s posterior draws and %s observations.\n", + dims[1], + dims[2] + ) + ) + } + cat(sprintf("Data source: %s\n\n", source)) + print( + format(round(as.data.frame(x$estimates), digits), nsmall = digits), + quote = FALSE + ) + invisible(x) +} + +#' @export +print.loo_pred_measure <- function(x, digits = 1, plot_k = FALSE, ...) { + print.pred_measure(x, digits = digits, ...) + cat("------\n") + pareto_k <- x$diagnostics$pareto_k + if (is.null(pareto_k)) { + cat("No Pareto-k diagnostics available.\n") + return(invisible(x)) + } + + print(pareto_k_table(x), digits = digits) + + if (plot_k) { + graphics::plot( + pareto_k, + ylab = "Pareto-k", + xlab = "Observation", + main = "Pareto-k diagnostics", + pch = 16 + ) + } + invisible(x) +} + +.pred_measure_source_label <- function(x) { + labels <- c(loo = "loo", insample = "in-sample", kfold = "k-fold", test = "test") + source <- attr(x, "source") + if (!is.null(source) && source %in% names(labels)) { + return(unname(labels[source])) + } + # fall back to the class, for objects that lost their attributes + cls <- class(x) + hit <- names(labels)[paste0(names(labels), "_pred_measure") %in% cls] + if (length(hit)) unname(labels[hit[1]]) else "unknown" +} + +#' @export +print.measure <- function(x, digits = 2, ...) { + dims <- attr(x, "dims") + name <- attr(x, "measure") + + if (length(dims) < 2) { + # number of draws are NULL + cat("\nComputed from", dims[1], "pointwise terms.\n\n") + } else { + cat("\nComputed from", dims[1], "draws by", dims[2], "observations.\n\n") + } + + print(.fr(x$estimates, digits), quote = FALSE) + + invisible(x) +} diff --git a/R/psislw.R b/R/psislw.R index 808e657f..7b9176e1 100644 --- a/R/psislw.R +++ b/R/psislw.R @@ -2,6 +2,8 @@ #' #' As of version `2.0.0` this function is **deprecated**. Please use the #' [psis()] function for the new PSIS algorithm. +#' `psislw()` and `R/psislw.R` are scheduled for removal in a future release. +#' See `vignette("migration-guide", package = "loo")` for details. #' #' @export #' @param lw A matrix or vector of log weights. For computing LOO, `lw = diff --git a/_pkgdown.yml b/_pkgdown.yml index 0a216a02..b3d56da9 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -54,6 +54,18 @@ articles: - loo2-large-data - loo2-moment-matching - loo2-mixis + - title: Migration + desc: | + Guides for updating code when APIs change. + contents: + - migration-guide + - title: Predictive performance measures + desc: | + Reference and workflow articles for the `*_pred_measure()` API (website + only; not included in the CRAN package). + contents: + - articles-online-only/pred-measure-workflow + - articles-online-only/overview-measures - title: Frequently asked questions contents: - faq @@ -101,12 +113,22 @@ reference: - kfold_split_stratified - kfold_split_grouped - kfold - - elpd + - title: Predictive performance measures + desc: | + Unified API for predictive performance measures (density scores, scoring + rules, and point-prediction metrics) with in-sample, LOO, K-fold, and + holdout evaluation modes. + contents: + - insample_pred_measure + - loo_pred_measure + - kfold_pred_measure + - test_pred_measure + - pred_measure + - supported_measures_list + - starts_with("measure_") + - ptw_log_pred_density - title: Other functions contents: - - loo_predictive_metric - - crps - - elpd - waic - extract_log_lik - pointwise @@ -120,5 +142,6 @@ reference: - update.psis_loo_ss - title: Deprecated functions contents: - - compare - - psislw + - elpd + - crps + - loo_predictive_metric diff --git a/man/compare.Rd b/man/compare.Rd index 11412fe4..3d95059f 100644 --- a/man/compare.Rd +++ b/man/compare.Rd @@ -22,7 +22,8 @@ provided then a matrix of summary information is returned (see \strong{Details}) } \description{ \strong{This function is deprecated}. Please use the new \code{\link[=loo_compare]{loo_compare()}} function -instead. +instead. See \code{vignette("migration-guide", package = "loo")} for details. +\code{compare()} and \code{R/compare.R} are scheduled for removal in a future release. } \details{ When comparing two fitted models, we can estimate the difference in their diff --git a/man/crps.Rd b/man/crps.Rd index 72f848df..4fe7a885 100644 --- a/man/crps.Rd +++ b/man/crps.Rd @@ -11,7 +11,7 @@ \alias{scrps.matrix} \alias{scrps.numeric} \alias{loo_scrps.matrix} -\title{Continuously ranked probability score} +\title{Continuously ranked probability score (deprecated)} \usage{ crps(x, ...) @@ -85,6 +85,17 @@ The former reports estimator and standard error and latter the pointwise values. Following Bolin & Wallin (2023), a larger value is better. } \description{ +As of loo 3.0.0, \code{crps()}, \code{scrps()}, \code{loo_crps()}, and \code{loo_scrps()} are +\strong{deprecated}. Please use \code{\link[=measure_rps]{measure_rps()}} and \code{\link[=measure_srps]{measure_srps()}} instead, +or \code{\link[=loo_pred_measure]{loo_pred_measure()}} for leave-one-out predictive performance. +See \code{vignette("migration-guide", package = "loo")} for a full mapping table. +} +\details{ +The new functions use a single matrix of posterior predictive draws +(\code{ypred}) and a PWM estimator. The deprecated functions require two +independent draw matrices (\code{x} and \code{x2}) and use a permutation-based +estimator. See \code{\link[=measure_rps]{measure_rps()}} for migration details. + The \code{crps()} and \code{scrps()} functions and their \verb{loo_*()} counterparts can be used to compute the continuously ranked probability score (CRPS) and scaled CRPS (SCRPS) (as defined by Bolin and Wallin, 2023). CRPS is a proper scoring rule, and @@ -92,8 +103,7 @@ strictly proper when the first moment of the predictive distribution is finite. Both can be expressed in terms of samples form the predictive distribution. See, for example, a paper by Gneiting and Raftery (2007) for a comprehensive discussion on CRPS. -} -\details{ + To compute (S)CRPS, the user needs to provide two sets of draws, \code{x} and \code{x2}, from the predictive distribution. This is due to the fact that formulas used to compute CRPS involve an expectation of the absolute difference of \code{x} @@ -102,14 +112,15 @@ as well as Gneiting and Raftery (2007) for details. } \examples{ \dontrun{ -# An example using rstanarm +# Deprecated: library(rstanarm) data("kidiq") fit <- stan_glm(kid_score ~ mom_hs + mom_iq, data = kidiq) ypred1 <- posterior_predict(fit) ypred2 <- posterior_predict(fit) crps(ypred1, ypred2, y = fit$y) -loo_crps(ypred1, ypred2, y = fit$y, log_lik = log_lik(fit)) +# -> +measure_rps(y = fit$y, ypred = ypred1) } } @@ -121,3 +132,6 @@ Gneiting, T., & Raftery, A. E. (2007). Strictly Proper Scoring Rules, Prediction, and Estimation. Journal of the American Statistical Association, 102(477), 359–378. } +\seealso{ +\code{\link[=measure_rps]{measure_rps()}}, \code{\link[=measure_srps]{measure_srps()}}, \code{\link[=loo_pred_measure]{loo_pred_measure()}} +} diff --git a/man/elpd.Rd b/man/elpd.Rd index 35bde6eb..d21fe2c6 100644 --- a/man/elpd.Rd +++ b/man/elpd.Rd @@ -4,7 +4,7 @@ \alias{elpd} \alias{elpd.array} \alias{elpd.matrix} -\title{Generic (expected) log-predictive density} +\title{Generic (expected) log-predictive density (deprecated)} \usage{ elpd(x, ...) @@ -20,11 +20,18 @@ each method.} \item{...}{Currently ignored.} } \description{ +As of loo 3.0.0, \code{elpd()} is \strong{deprecated}. Please use \code{\link[=measure_elpd]{measure_elpd()}} +instead. For full predictive performance workflows, see +\code{\link[=insample_pred_measure]{insample_pred_measure()}} and \code{\link[=loo_pred_measure]{loo_pred_measure()}}. +See \code{vignette("migration-guide", package = "loo")} for a full mapping table. +} +\details{ +The return type differs: \code{elpd()} returns class \code{"elpd_generic"} with +\code{elpd} and \code{ic} in \code{pointwise}; \code{measure_elpd()} returns class \code{"measure"}. + The \code{elpd()} methods for arrays and matrices can compute the expected log pointwise predictive density for a new dataset or the log pointwise predictive density of the observed data (an overestimate of the elpd). -} -\details{ The \code{elpd()} function is an S3 generic and methods are provided for 3-D pointwise log-likelihood arrays and matrices. } @@ -40,13 +47,17 @@ of data points. }} \examples{ -# Calculate the lpd of the observed data +\dontrun{ +# Deprecated: LLarr <- example_loglik_array() elpd(LLarr) +# -> +measure_elpd(LLarr) +} } \seealso{ -The vignette \emph{Holdout validation and K-fold cross-validation of Stan -programs with the loo package} for demonstrations of using the \code{elpd()} -methods. +\code{\link[=measure_elpd]{measure_elpd()}}, \code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=loo_pred_measure]{loo_pred_measure()}}, +and the vignette \emph{Holdout validation and K-fold cross-validation of Stan +programs with the loo package}. } diff --git a/man/insample_pred_measure.Rd b/man/insample_pred_measure.Rd new file mode 100644 index 00000000..052cb0c0 --- /dev/null +++ b/man/insample_pred_measure.Rd @@ -0,0 +1,146 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure.R +\name{insample_pred_measure} +\alias{insample_pred_measure} +\title{In-sample predictive performance measures} +\usage{ +insample_pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measure = NULL, + group_ids = NULL, + save_psis = FALSE, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for distributional and +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 +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{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 +summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{measure}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\item A \strong{function} with attribute \code{"measure_name"} for one custom measure. +\item A \strong{list} mixing character scalars (built-in names) and named +functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. +} +Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and +\code{log_weights} that appear in their formals, plus arguments from \code{control}. +They must return a list with \code{estimates} and \code{pointwise}.} + +\item{group_ids}{Optional vector of group identifiers for grouped summaries +(reserved; not yet implemented).} + +\item{save_psis}{Logical. If \code{TRUE}, store the \code{psis} object in the result +so that additional measures can be added later with \code{\link[=pred_measure]{pred_measure()}} without +recomputing PSIS weights.} + +\item{control}{Named list of per-measure settings. Each name must match an +element of \code{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))}).} +} +\value{ +An object of class \code{"insample_pred_measure"} and \code{"pred_measure"}: a list +with: +\describe{ +\item{\code{estimates}}{Matrix of summary estimates and standard errors (rows +are measures, columns are \code{Estimate} and \code{SE}). The row \code{elpd} is +present when \code{measure} is \code{NULL} (default) or names "elpd".} +\item{\code{pointwise}}{Matrix of observation-level contributions (one column +per measure).} +} + +The attribute \code{source} is \code{"insample"}. Attribute \code{dims} gives posterior +draws × observations. Use \code{\link[=print]{print()}} for a readable summary table. +} +\description{ +Compute predictive performance measures on the same data used to fit the +model. This is the simplest entry point when you want density scores +(\code{elpd}) and optional distributional or point-prediction metrics in +one call. + +In-sample \code{elpd} sums the expected log pointwise predictive density (ELPD) +over the training observations. Because the model has already seen these +data, in-sample scores are \strong{optimistically biased} for predicting future +or otherwise unseen observations. For out-of-sample performance, use +\code{\link[=loo_pred_measure]{loo_pred_measure()}}, \code{\link[=kfold_pred_measure]{kfold_pred_measure()}}, or \code{\link[=test_pred_measure]{test_pred_measure()}} +instead; see Vehtari's +\href{https://users.aalto.fi/~ave/CV-FAQ.html}{Cross-validation FAQ} (Section 4). +} +\details{ +\strong{Input requirements by measure.} Supply only the inputs each measure +needs:\tabular{lcccc}{ + Measure \tab \code{ylp} \tab \code{y} \tab \code{ypred} \tab \code{mupred} \cr + \code{elpd}, \code{mlpd}, \code{ic} \tab ✓ \tab \tab \tab \cr + \code{crps}, \code{scrps}, \code{rps}, \code{srps} \tab \tab ✓ \tab ✓ \tab \cr + \code{acc}, \code{bacc} \tab \tab ✓ \tab \tab ✓ \cr + \code{mae}, \code{mse}, \code{rmse}, \code{r2} \tab \tab ✓ \tab \tab ✓ \cr +} + + +"elpd" is the default measure. \code{mlpd} and \code{ic} are derived from \code{elpd}, but +requesting them does not add an \code{elpd} row. Request \code{ic}, \code{mlpd}, or other +density scores via \code{measure}, or supply a custom function; +see \link{supported_measures_list} and the +\href{https://mc-stan.org/loo/articles/articles-online-only/overview-measures.html}{overview of scores and metrics} +article for definitions and orientation (higher vs lower is better). + +\strong{Custom measures.} A function passed to \code{measure} must have attribute +\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. +} +\examples{ +\donttest{ +if (requireNamespace("brms", quietly = TRUE)) { + fit <- brms::brm( + Reaction ~ Days, data = lme4::sleepstudy, + refresh = 0, chains = 2, iter = 1000 + ) + insample_pred_measure( + ylp = brms::log_lik(fit), + y = fit$data$Reaction, + ypred = brms::posterior_predict(fit), + mupred = brms::posterior_epred(fit), + measure = c("rmse", "r2") + ) +} +} +\dontrun{ +# Custom measure (same contract as built-in point-prediction metrics) +my_abs_err <- function(y, mupred, log_weights = NULL) { + mu <- colMeans(mupred) + pw <- abs(y - mu) + list( + estimate = mean(pw), + se = sd(pw) / sqrt(length(pw)), + pointwise = pw + ) +} +attr(my_abs_err, "measure_name") <- "my_abs_err" +# insample_pred_measure(y = y, mupred = mupred, ylp = ylp, measure = my_abs_err) +} + +} +\seealso{ +\code{\link[=pred_measure]{pred_measure()}} to add measures incrementally, +\code{\link[=loo_pred_measure]{loo_pred_measure()}}, \code{\link[=kfold_pred_measure]{kfold_pred_measure()}}, \code{\link[=test_pred_measure]{test_pred_measure()}}, +\link{supported_measures_list}, +\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{pred-measure workflow article} +} diff --git a/man/kfold_pred_measure.Rd b/man/kfold_pred_measure.Rd new file mode 100644 index 00000000..57ed2821 --- /dev/null +++ b/man/kfold_pred_measure.Rd @@ -0,0 +1,107 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure.R +\name{kfold_pred_measure} +\alias{kfold_pred_measure} +\title{K-fold cross-validation predictive performance measures} +\usage{ +kfold_pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measure = NULL, + kfold = NULL, + group_ids = NULL, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for distributional and +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 +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{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 +summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{measure}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\item A \strong{function} with attribute \code{"measure_name"} for one custom measure. +\item A \strong{list} mixing character scalars (built-in names) and named +functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. +} +Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and +\code{log_weights} that appear in their formals, plus arguments from \code{control}. +They must return a list with \code{estimates} and \code{pointwise}.} + +\item{kfold}{A \code{kfold} object from \code{\link[brms:kfold]{brms::kfold()}}. Supplies ELPD summaries +and fold structure for \code{\link[=kfold_pred_measure]{kfold_pred_measure()}}; pass \code{y}, \code{ypred}, and/or +\code{mupred} when requesting additional measures.} + +\item{group_ids}{Optional vector of group identifiers for grouped summaries +(reserved; not yet implemented).} + +\item{control}{Named list of per-measure settings. Each name must match an +element of \code{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))}).} +} +\value{ +An object of class \code{"kfold_pred_measure"} and \code{"pred_measure"}, inheriting +attributes from the \code{kfold} object (\code{K}, \code{folds}, \code{fold_type}, etc.). The +list contains \code{estimates} and \code{pointwise}; measure names carry a \verb{_kfold} +suffix (e.g. \code{elpd_kfold}, \code{crps_kfold}). +} +\description{ +Compute predictive performance measures under \strong{k-fold cross-validation}. +K-fold CV holds out groups of observations, refits (or reuses stored fits), +and scores the held-out folds. + +Pass a \code{kfold} object from \code{\link[brms:kfold]{brms::kfold()}} (with \code{save_fits = TRUE} when +you need posterior predictions on held-out folds). \code{elpd_kfold} and +\code{p_kfold} come from the \code{kfold} object and are reported by default or when +\code{measure} names "elpd"; +additional measures require the same optional inputs as +\code{\link[=insample_pred_measure]{insample_pred_measure()}}. +} +\details{ +For distributional measures on held-out folds, obtain posterior predictions +with \code{brms::kfold_predict()} and pass the resulting \code{yrep} matrices as +\code{ypred} and/or \code{mupred}. See the sleep-study workflow in +\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{pred-measure workflow article}. +} +\examples{ +\donttest{ +if (requireNamespace("brms", quietly = TRUE)) { + fit <- brms::brm( + Reaction ~ Days, data = lme4::sleepstudy, + refresh = 0, chains = 2, iter = 1000 + ) + kf <- brms::kfold(fit, K = 5, save_fits = TRUE) + ypred_kf <- brms::kfold_predict(kf, method = "predict")$yrep + mupred_kf <- brms::kfold_predict(kf, method = "fitted")$yrep + kfold_pred_measure( + y = fit$data$Reaction, + ypred = ypred_kf, + mupred = mupred_kf, + kfold = kf, + measure = "rmse" + ) +} +} + +} +\seealso{ +\code{\link[=loo_pred_measure]{loo_pred_measure()}}, \code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=pred_measure]{pred_measure()}}, +\code{\link[brms:kfold]{brms::kfold()}}, \link{supported_measures_list}, +\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{pred-measure workflow article} +} diff --git a/man/loo_pred_measure.Rd b/man/loo_pred_measure.Rd new file mode 100644 index 00000000..1086fc1e --- /dev/null +++ b/man/loo_pred_measure.Rd @@ -0,0 +1,141 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure.R +\name{loo_pred_measure} +\alias{loo_pred_measure} +\title{PSIS-LOO predictive performance measures} +\usage{ +loo_pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measure = NULL, + loo = NULL, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for distributional and +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 +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{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 +summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{measure}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\item A \strong{function} with attribute \code{"measure_name"} for one custom measure. +\item A \strong{list} mixing character scalars (built-in names) and named +functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. +} +Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and +\code{log_weights} that appear in their formals, plus arguments from \code{control}. +They must return a list with \code{estimates} and \code{pointwise}.} + +\item{loo}{A \code{\link[=loo]{loo()}} result, computed with +\code{save_psis = TRUE} so that PSIS weights are available for additional +measures. See \code{\link[=loo_pred_measure]{loo_pred_measure()}}.} + +\item{group_ids}{Optional vector of group identifiers for grouped summaries +(reserved; not yet implemented).} + +\item{psis_object}{A \code{psis} object with LOO importance weights. An +alternative to passing a full \code{loo} object; must be supplied together with +\code{ylp} when computing \code{elpd}.} + +\item{save_psis}{Logical. If \code{TRUE}, store the \code{psis} object in the result +so that additional measures can be added later with \code{\link[=pred_measure]{pred_measure()}} without +recomputing PSIS weights.} + +\item{control}{Named list of per-measure settings. Each name must match an +element of \code{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))}).} +} +\value{ +An object of class \code{"loo_pred_measure"}, \code{"pred_measure"}, and \code{"loo"}. +When a \code{loo} object is supplied, additional classes from that object are +inherited (e.g. \code{"psis_loo"}). In addition to \code{estimates} and +\code{pointwise}, the list may contain: +\describe{ +\item{\code{diagnostics}}{PSIS diagnostics, including Pareto \eqn{\hat{k}} in +\code{diagnostics$pareto_k}. A value above the sample-size dependent +threshold \eqn{\min(1 - 1 / \log_{10}(S), 0.7)}, where \eqn{S} is the +number of draws, suggests an unreliable LOO estimate for that +observation. The \code{print()} method reports the threshold it used.} +\item{\code{log_weights}}{Normalized log importance weights used for LOO +scoring.} +\item{\code{psis_object}}{Stored when \code{save_psis = TRUE}; needed to add +further measures with \code{\link[=pred_measure]{pred_measure()}} without recomputing weights.} +} + +Measure names carry a \verb{_loo} suffix (e.g. \code{elpd_loo}, \code{crps_loo}). +} +\description{ +Estimate out-of-sample predictive performance with \strong{PSIS-LOO} +(Pareto-smoothed importance sampling leave-one-out cross-validation). +PSIS-LOO approximates exact LOO-CV without refitting the model once per +observation: each held-out point is scored by reweighting the full-data +posterior draws. + +With the default \code{measure = NULL}, the result holds \code{elpd_loo}, the LOO +estimate of expected log pointwise predictive density (ELPD), and \code{p_loo} +(effective number of parameters, the difference between in-sample and LOO +log predictive density). \code{p_loo} is reported together with \code{elpd_loo}. +See \code{\link[=loo]{loo()}} and the +\href{https://users.aalto.fi/~ave/CV-FAQ.html}{Cross-validation FAQ} for +interpretation. +} +\details{ +\strong{Three equivalent input patterns:} + +\describe{ +\item{Precomputed \code{loo} object}{\code{loo_pred_measure(loo = loo_fit, ...)}. +Run \code{\link[=loo]{loo()}} with \code{save_psis = TRUE}.} +\item{\code{ylp} + \code{psis_object}}{Pass both when you have already computed +PSIS weights separately.} +\item{\code{ylp} only}{PSIS weights are computed internally from \code{ylp}.} +} + +For distributional and point-prediction measures (\code{crps}, \code{r2}, etc.), +supply \code{y}, \code{ypred}, and/or \code{mupred} as for \code{\link[=insample_pred_measure]{insample_pred_measure()}}. When +adding measures incrementally, call \code{\link[=pred_measure]{pred_measure()}} with \code{predperf} set to +an existing result; use \code{save_psis = TRUE} on the initial call so weights +are stored. +} +\examples{ +\donttest{ +if (requireNamespace("brms", quietly = TRUE)) { + fit <- brms::brm( + Reaction ~ Days, data = lme4::sleepstudy, + refresh = 0, chains = 2, iter = 1000 + ) + loo_fit <- loo::loo(fit, save_psis = TRUE) + loo_pred_measure( + loo = loo_fit, + y = fit$data$Reaction, + ypred = brms::posterior_predict(fit), + measure = c("rmse", "r2") + ) +} +} + +} +\seealso{ +\code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=pred_measure]{pred_measure()}}, \code{\link[=loo]{loo()}}, +\link{supported_measures_list}, +\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{pred-measure workflow article} +} diff --git a/man/loo_predictive_metric.Rd b/man/loo_predictive_metric.Rd index b82f7e30..f6588a51 100644 --- a/man/loo_predictive_metric.Rd +++ b/man/loo_predictive_metric.Rd @@ -3,7 +3,7 @@ \name{loo_predictive_metric} \alias{loo_predictive_metric} \alias{loo_predictive_metric.matrix} -\title{Estimate leave-one-out predictive performance..} +\title{Estimate leave-one-out predictive performance (deprecated)} \usage{ loo_predictive_metric(x, ...) @@ -68,6 +68,17 @@ Standard error of the estimate. } } \description{ +As of loo 3.0.0, \code{loo_predictive_metric()} is \strong{deprecated}. Please use +\code{\link[=loo_pred_measure]{loo_pred_measure()}} instead, or the standalone \code{\link[=measure_mae]{measure_mae()}}, +\code{\link[=measure_rmse]{measure_rmse()}}, \code{\link[=measure_mse]{measure_mse()}}, \code{\link[=measure_acc]{measure_acc()}}, and \code{\link[=measure_bacc]{measure_bacc()}} +functions with PSIS log-weights. +See \code{vignette("migration-guide", package = "loo")} for a full mapping table. +} +\details{ +The replacement API uses \code{mupred} (posterior expected values) rather than +pre-computed LOO expectations passed as \code{x}. Metric names also differ: +\code{"balanced_acc"} maps to \code{"bacc"} in \link{supported_measures_list}. + The \code{loo_predictive_metric()} function computes estimates of leave-one-out predictive metrics given a set of predictions and observations. Currently supported metrics are mean absolute error, mean squared error and root mean @@ -105,3 +116,6 @@ mae_90q <- loo_predictive_metric(x = mu_pred, y = d$weight, log_lik = ll, } } } +\seealso{ +\code{\link[=loo_pred_measure]{loo_pred_measure()}}, \code{\link[=measure_mae]{measure_mae()}}, \link{supported_measures_list} +} diff --git a/man/measure_acc.Rd b/man/measure_acc.Rd new file mode 100644 index 00000000..024e2763 --- /dev/null +++ b/man/measure_acc.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_acc} +\alias{measure_acc} +\title{Classification accuracy (\code{acc})} +\usage{ +measure_acc( + y, + mupred, + log_weights = NULL, + pointwise = NULL, + higher_is_better = NULL +) +} +\arguments{ +\item{y}{An integer vector of observed class labels.} + +\item{mupred}{A numeric array of posterior predictive means. For binary +outcomes use a draws x observations matrix. For multiclass outcomes use a +draws x observations x categories array.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed pointwise accuracy +contributions. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +Computes pointwise and average classification accuracy for binary or +multiclass outcomes. The class probabilities are first averaged over the +draws, using \code{log_weights} if given. For binary outcomes, the averaged +probability is thresholded at 0.5. For multiclass outcomes, the predicted +class is the most likely category of the averaged probabilities, via +\code{which.max()}. +} +\examples{ +y <- c(1L, 0L, 1L) +mupred <- matrix(c(0.8, 0.3, 0.7, 0.6, 0.4, 0.9), nrow = 2) +measure_acc(y, mupred) +} diff --git a/man/measure_bacc.Rd b/man/measure_bacc.Rd new file mode 100644 index 00000000..824fe977 --- /dev/null +++ b/man/measure_bacc.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_bacc} +\alias{measure_bacc} +\title{Balanced classification accuracy (\code{bacc})} +\usage{ +measure_bacc( + y, + mupred, + log_weights = NULL, + pointwise = NULL, + higher_is_better = NULL +) +} +\arguments{ +\item{y}{An integer vector of observed class labels.} + +\item{mupred}{A numeric array of posterior predictive means. For binary +outcomes use a draws x observations matrix. For multiclass outcomes use a +draws x observations x categories array.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed pointwise accuracy +contributions. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +Computes balanced accuracy by averaging class-specific mean accuracy, giving +each observed class equal weight regardless of class frequency. +} +\examples{ +y <- c(1L, 1L, 2L, 2L) +mupred <- array( + c(0.8, 0.2, 0.7, 0.3, 0.3, 0.7, 0.2, 0.8), + dim = c(1, 4, 2) +) +measure_bacc(y, mupred) +} diff --git a/man/measure_brier.Rd b/man/measure_brier.Rd new file mode 100644 index 00000000..3019f357 --- /dev/null +++ b/man/measure_brier.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_brier} +\alias{measure_brier} +\title{Brier score (\code{brier})} +\usage{ +measure_brier( + y, + ypred, + log_weights = NULL, + pointwise = NULL, + higher_is_better = NULL +) +} +\arguments{ +\item{y}{A numeric vector of binary outcomes coded as 0 or 1.} + +\item{ypred}{A numeric matrix of posterior predictive probabilities with +dimensions draws x observations.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed pointwise Brier +scores. If provided, \code{y}, \code{ypred}, and \code{log_weights} are ignored.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +Computes the Brier score for binary outcomes as squared error between the +observed label and predicted event probability. +} +\examples{ +y <- c(1, 0, 1) +ypred <- matrix(c(0.8, 0.2, 0.7, 0.9, 0.4, 0.6), nrow = 2) +measure_brier(y, ypred) +} diff --git a/man/measure_density_params.Rd b/man/measure_density_params.Rd new file mode 100644 index 00000000..04af3655 --- /dev/null +++ b/man/measure_density_params.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_density_params} +\alias{measure_density_params} +\title{Shared parameters for density scores} +\arguments{ +\item{ylp}{A numeric matrix or three-dimensional array of log predictive +densities or probabilities: +\itemize{ +\item \strong{Matrix} (\eqn{S \times n}): \eqn{S} posterior draws (chains +merged) by \eqn{n} observations. +\item \strong{Array} (\eqn{I \times C \times n}): \eqn{I} MCMC iterations per +chain, \eqn{C} chains, and \eqn{n} observations. Converted to an +\eqn{S \times n} matrix internally. +}} +} +\description{ +Shared parameters for density scores +} +\keyword{internal} diff --git a/man/measure_elpd.Rd b/man/measure_elpd.Rd new file mode 100644 index 00000000..a588e577 --- /dev/null +++ b/man/measure_elpd.Rd @@ -0,0 +1,64 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_elpd} +\alias{measure_elpd} +\title{Expected log pointwise predictive density (\code{elpd})} +\usage{ +measure_elpd( + ylp, + log_weights = NULL, + pointwise = NULL, + higher_is_better = NULL +) +} +\arguments{ +\item{ylp}{A numeric matrix or three-dimensional array of log predictive +densities or probabilities: +\itemize{ +\item \strong{Matrix} (\eqn{S \times n}): \eqn{S} posterior draws (chains +merged) by \eqn{n} observations. +\item \strong{Array} (\eqn{I \times C \times n}): \eqn{I} MCMC iterations per +chain, \eqn{C} chains, and \eqn{n} observations. Converted to an +\eqn{S \times n} matrix internally. +}} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed \eqn{\mathrm{lppd}_i} +values. When supplied, \code{ylp} and \code{log_weights} are ignored.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +Computes the expected log pointwise predictive density (ELPD) as the sum of +pointwise log predictive density contributions (\eqn{\mathrm{lppd}_i}), using +\code{\link[=ptw_log_pred_density]{ptw_log_pred_density()}}. ELPD is returned on the utility scale (higher is +better), consistent with the sign convention used throughout this package. +Manual change of sign convention is possible via \code{higher_is_better}. +} +\details{ +\deqn{\mathrm{elpd} = \sum_{i=1}^{n} \mathrm{lppd}_i,} +where each \eqn{\mathrm{lppd}_i} is computed by \code{\link[=ptw_log_pred_density]{ptw_log_pred_density()}}. +The standard error is \eqn{\sqrt{n}\,\mathrm{sd}(\mathrm{lppd}_i)}. +} +\examples{ +ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +measure_elpd(ylp) + +# With unnormalized importance weights (e.g., PSIS-LOO) +lw <- matrix(log(c(0.7, 0.3, 0.6, 0.4)), nrow = 2) +measure_elpd(ylp, log_weights = lw) + +# From a draws x chains x observations array +LLarr <- example_loglik_array() +measure_elpd(LLarr) +} +\seealso{ +\code{\link[=ptw_log_pred_density]{ptw_log_pred_density()}}, \code{\link[=measure_mlpd]{measure_mlpd()}}, \code{\link[=measure_ic]{measure_ic()}} +} diff --git a/man/measure_ic.Rd b/man/measure_ic.Rd new file mode 100644 index 00000000..b8a64c53 --- /dev/null +++ b/man/measure_ic.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_ic} +\alias{measure_ic} +\title{Information Criteria (\code{ic})} +\usage{ +measure_ic(ylp, log_weights = NULL, pointwise = NULL, higher_is_better = NULL) +} +\arguments{ +\item{ylp}{A numeric matrix or three-dimensional array of log predictive +densities or probabilities: +\itemize{ +\item \strong{Matrix} (\eqn{S \times n}): \eqn{S} posterior draws (chains +merged) by \eqn{n} observations. +\item \strong{Array} (\eqn{I \times C \times n}): \eqn{I} MCMC iterations per +chain, \eqn{C} chains, and \eqn{n} observations. Converted to an +\eqn{S \times n} matrix internally. +}} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed pointwise +contributions \eqn{\mathrm{ic}_i = -2 \cdot \mathrm{lppd}_i}. If provided, +\code{ylp} and \code{log_weights} are ignored.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +Computes the information criteria as -2 x log predictive density (lppd_i) +values. Inputs follow the same conventions as \code{\link[=measure_elpd]{measure_elpd()}} and +\code{\link[=measure_mlpd]{measure_mlpd()}}. +} +\examples{ +ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +measure_ic(ylp) +} diff --git a/man/measure_mae.Rd b/man/measure_mae.Rd new file mode 100644 index 00000000..0b0cfe88 --- /dev/null +++ b/man/measure_mae.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_mae} +\alias{measure_mae} +\title{Mean absolute error (\code{mae})} +\usage{ +measure_mae( + y, + mupred, + log_weights = NULL, + pointwise = NULL, + higher_is_better = NULL +) +} +\arguments{ +\item{y}{A numeric vector of observed outcomes.} + +\item{mupred}{A numeric matrix of posterior expected predictions with +dimensions draws x observations. A length-\code{n} vector is also accepted.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed pointwise absolute +errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +Computes MAE between observed outcomes and posterior predictive point +predictions. Point predictions are obtained by averaging \code{mupred} draws, or +by PSIS-weighted averaging when \code{log_weights} is provided. +} +\examples{ +y <- c(1, 2, 3) +mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +measure_mae(y, mupred) +} diff --git a/man/measure_metric_params.Rd b/man/measure_metric_params.Rd new file mode 100644 index 00000000..07a8fa23 --- /dev/null +++ b/man/measure_metric_params.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_metric_params} +\alias{measure_metric_params} +\title{Shared parameters for metrics} +\arguments{ +\item{y}{A vector of observed values.} + +\item{mupred}{A numeric array of posterior predictive means. For binary +outcomes use a draws x observations matrix. For multiclass outcomes use a +draws x observations x categories array.} +} +\description{ +Shared parameters for metrics +} +\keyword{internal} diff --git a/man/measure_mlpd.Rd b/man/measure_mlpd.Rd new file mode 100644 index 00000000..8017e44c --- /dev/null +++ b/man/measure_mlpd.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_mlpd} +\alias{measure_mlpd} +\title{Mean log pointwise predictive density (\code{mlpd})} +\usage{ +measure_mlpd( + ylp, + log_weights = NULL, + pointwise = NULL, + higher_is_better = NULL +) +} +\arguments{ +\item{ylp}{A numeric matrix or three-dimensional array of log predictive +densities or probabilities: +\itemize{ +\item \strong{Matrix} (\eqn{S \times n}): \eqn{S} posterior draws (chains +merged) by \eqn{n} observations. +\item \strong{Array} (\eqn{I \times C \times n}): \eqn{I} MCMC iterations per +chain, \eqn{C} chains, and \eqn{n} observations. Converted to an +\eqn{S \times n} matrix internally. +}} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed \eqn{\mathrm{lppd}_i} +values. When supplied, \code{ylp} and \code{log_weights} are ignored.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +Computes MLPD as the average of pointwise log predictive density (lppd_i) +values. Inputs follow the same conventions as \code{\link[=measure_elpd]{measure_elpd()}}. +} +\examples{ +ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +measure_mlpd(ylp) +} diff --git a/man/measure_mse.Rd b/man/measure_mse.Rd new file mode 100644 index 00000000..dc511b36 --- /dev/null +++ b/man/measure_mse.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_mse} +\alias{measure_mse} +\title{Mean squared error (\code{mse})} +\usage{ +measure_mse( + y, + mupred, + log_weights = NULL, + pointwise = NULL, + higher_is_better = NULL +) +} +\arguments{ +\item{y}{A numeric vector of observed outcomes.} + +\item{mupred}{A numeric matrix of posterior expected predictions with +dimensions draws x observations. A length-\code{n} vector is also accepted.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed pointwise squared +errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +Computes MSE between observed outcomes and posterior predictive point +predictions. Point predictions are obtained by averaging \code{mupred} draws, or +by PSIS-weighted averaging when \code{log_weights} is provided. +} +\examples{ +y <- c(1, 2, 3) +mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +measure_mse(y, mupred) +} diff --git a/man/measure_params.Rd b/man/measure_params.Rd new file mode 100644 index 00000000..ad7aa8d7 --- /dev/null +++ b/man/measure_params.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_params} +\alias{measure_params} +\title{Shared parameters for all measures} +\arguments{ +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed per-observation +contributions. When supplied, \code{ylp} and \code{log_weights} are ignored.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\value{ +An object of class \code{"measure"}: a list with: +\describe{ +\item{\code{estimates}}{Named numeric vector with elements \code{Estimate} +and \code{SE} (standard error).} +\item{\code{pointwise}}{Numeric vector of length \eqn{n} with per-observation +values.} +} +Attributes \code{measure} (i.e., measure name) and \code{dims} (draws \eqn{\times} +observations) are also set. Use \code{\link[=print]{print()}} for a readable summary. +} +\description{ +Shared parameters for all measures +} +\keyword{internal} diff --git a/man/measure_r2.Rd b/man/measure_r2.Rd new file mode 100644 index 00000000..42a4f71f --- /dev/null +++ b/man/measure_r2.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_r2} +\alias{measure_r2} +\title{Predictive R-squared (\code{r2})} +\usage{ +measure_r2( + y, + mupred, + log_weights = NULL, + pointwise = NULL, + higher_is_better = NULL +) +} +\arguments{ +\item{y}{A numeric vector of observed outcomes.} + +\item{mupred}{A numeric matrix of posterior expected predictions with +dimensions draws x observations. A length-\code{n} vector is also accepted.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed pointwise squared +errors. If provided, \code{mupred} and \code{log_weights} are ignored. \code{y} is always +required, because \code{r2} needs the variance of \code{y} as its baseline.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +Computes predictive R-squared as one minus the ratio of prediction MSE to +the empirical variance of \code{y}. The standard error is computed with a +first-order delta-method approximation. +} +\examples{ +y <- c(1, 2, 3) +mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +measure_r2(y, mupred) +} diff --git a/man/measure_rmse.Rd b/man/measure_rmse.Rd new file mode 100644 index 00000000..95a98e37 --- /dev/null +++ b/man/measure_rmse.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_rmse} +\alias{measure_rmse} +\title{Root mean squared error (\code{rmse})} +\usage{ +measure_rmse( + y, + mupred, + log_weights = NULL, + pointwise = NULL, + higher_is_better = NULL +) +} +\arguments{ +\item{y}{A numeric vector of observed outcomes.} + +\item{mupred}{A numeric matrix of posterior expected predictions with +dimensions draws x observations. A length-\code{n} vector is also accepted.} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed pointwise squared +errors. If provided, \code{y}, \code{mupred}, and \code{log_weights} are ignored.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +Computes RMSE as the square root of MSE and propagates uncertainty via a +first-order delta-method approximation. +} +\examples{ +y <- c(1, 2, 3) +mupred <- matrix(c(0.9, 2.1, 2.8, 1.2, 1.9, 3.1), nrow = 2) +measure_rmse(y, mupred) +} diff --git a/man/measure_rps.Rd b/man/measure_rps.Rd new file mode 100644 index 00000000..11e9f14c --- /dev/null +++ b/man/measure_rps.Rd @@ -0,0 +1,134 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_rps} +\alias{measure_rps} +\title{Ranked Probability Score (RPS, SRPS, CRPS, SCRPS)} +\usage{ +measure_rps( + y, + ypred, + log_weights = NULL, + pointwise = NULL, + scaled = FALSE, + higher_is_better = NULL +) +} +\arguments{ +\item{y}{A numeric vector of \eqn{n} observed outcomes. May be integer-valued +(for RPS/SRPS) or continuous (for CRPS/SCRPS).} + +\item{ypred}{A numeric matrix of posterior predictive draws with dimensions +\eqn{S \times n} (draws × observations).} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed pointwise rps values. +If provided, \code{y}, \code{ypred}, and \code{log_weights} are ignored.} + +\item{scaled}{Logical; if \code{TRUE}, computes the scaled variant (SRPS for +discrete outcomes, SCRPS for continuous outcomes). Default is \code{FALSE}.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +Computes proper scoring rules based on the ranked probability score family, +covering both discrete and continuous outcomes, with optional scaling. +The specific score computed depends on the type of \code{y} and \code{ypred} and the +value of \code{scaled}: +} +\details{ +\tabular{lll}{ + \code{y}/\code{ypred} type \tab \code{scaled = FALSE} \tab \code{scaled = TRUE} \cr + Discrete \tab RPS \tab SRPS \cr + Continuous \tab CRPS \tab SCRPS \cr +} + + +\strong{Scoring rules:} +\itemize{ +\item \strong{RPS} (Epstein, 1969): Compares predictive and observed cumulative +distributions for ordered discrete outcomes. +\item \strong{CRPS} (Matheson & Winkler, 1976; Gneiting & Raftery, 2007): Generalizes +RPS to continuous outcomes. Defined as +\deqn{\mathrm{CRPS}(X; y) = E[|X - y|] - \frac{1}{2} E[|X - X'|],} +where \eqn{X, X'} are independent draws from the predictive distribution. +\item \strong{SRPS/SCRPS} (Bolin & Wallin, 2023): Scaled variants that are invariant +to the scale of the predictive distribution. Defined as +\deqn{\mathrm{SCRPS}(X; y) = -\frac{E[|X - y|]}{E[|X - X'|]} - + \frac{1}{2} \log E[|X - X'|].} +} + +\strong{Estimation:} + +Scores are estimated using the probability-weighted moment (PWM) estimator +(Taillardat et al., 2016; Zamo & Naveau, 2018), which requires only a single +set of predictive draws unlike permutation-based estimators, which require +two independent draw sets. The PWM estimator is unbiased and generally more +accurate than single-permutation estimators. The same estimator is used for +both discrete and continuous outcomes; see Hosking (1990, 1996) for +theoretical justification in the discrete case. + +If log-weights (\code{log_weights}) are provided (e.g., PSIS weights +for LOO cross-validation), a weighted PWM estimator is used instead, which +accounts for the importance weights when estimating expectations. + +\strong{Sign convention:} + +Unscaled scores are returned as losses (lower is better). Scaled scores are +returned as utilities (higher is better), after Bolin & Wallin (2023). Set +\code{higher_is_better} to select the orientation you want. +} +\examples{ +# Discrete outcomes: RPS +y <- c(2L, 1L, 3L) +ypred <- matrix(c(2, 1, 2, 3, 1, 3), nrow = 2) +measure_rps(y, ypred) + +# Discrete outcomes: SRPS (scaled) +measure_rps(y, ypred, scaled = TRUE) + +# Continuous outcomes: CRPS +y_cont <- c(0.5, -1.2, 2.3) +ypred_cont <- matrix(rnorm(200), nrow = 100, ncol = 3) +measure_rps(y_cont, ypred_cont) + +# With importance weights: LOO-CRPS +log_weights <- matrix(rnorm(200), nrow = 100, ncol = 3) +measure_rps(y_cont, ypred_cont, log_weights = log_weights) + +} +\references{ +Bolin, D. and Wallin, J. (2023). Local scale invariance and robustness of +proper scoring rules. \emph{Statistical Science}, 38(1):140–159. + +Epstein, E. S. (1969). A scoring system for probability forecasts of ranked +categories. \emph{Journal of Applied Meteorology}, 8(6):985–987. + +Gneiting, T. and Raftery, A. E. (2007). Strictly proper scoring rules, +prediction, and estimation. \emph{Journal of the American Statistical +Association}, 102(477):359–378. + +Hosking, J. R. M. (1990). L-moments: Analysis and estimation of +distributions using linear combinations of order statistics. \emph{Journal of +the Royal Statistical Society Series B}, 52(1):105–124. + +Hosking, J. R. M. (1996). Some theoretical results concerning L-moments. +Research report RC 14492. IBM Thomas J. Watson Research Division. + +Matheson, J. E. and Winkler, R. L. (1976). Scoring rules for continuous +probability distributions. \emph{Management Science}, 22(10):1087–1096. + +Taillardat, M., Mestre, O., Zamo, M., and Naveau, P. (2016). Calibrated +ensemble forecasts using quantile regression forests and ensemble model +output statistics. \emph{Monthly Weather Review}, 144(6):2375–2393. + +Zamo, M. and Naveau, P. (2018). Estimation of the continuous ranked +probability score with limited information and applications to ensemble +weather forecasts. \emph{Mathematical Geosciences}, 50:209–234. +} diff --git a/man/measure_score_params.Rd b/man/measure_score_params.Rd new file mode 100644 index 00000000..244a8a0f --- /dev/null +++ b/man/measure_score_params.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_score_params} +\alias{measure_score_params} +\title{Shared parameters for scores} +\arguments{ +\item{y}{A vector of observed values.} + +\item{mupred}{A numeric array of posterior predictive means. For binary +outcomes use a draws x observations matrix. For multiclass outcomes use a +draws x observations x categories array.} +} +\description{ +Shared parameters for scores +} +\keyword{internal} diff --git a/man/measure_srps.Rd b/man/measure_srps.Rd new file mode 100644 index 00000000..270cf74e --- /dev/null +++ b/man/measure_srps.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{measure_srps} +\alias{measure_srps} +\title{Scaled Ranked Probability Score (SRPS, SCRPS)} +\usage{ +measure_srps( + y, + ypred, + log_weights = NULL, + pointwise = NULL, + higher_is_better = NULL +) +} +\arguments{ +\item{y}{A numeric vector of \eqn{n} observed outcomes. May be integer-valued +(for RPS/SRPS) or continuous (for CRPS/SCRPS).} + +\item{ypred}{A numeric matrix of posterior predictive draws with dimensions +\eqn{S \times n} (draws × observations).} + +\item{log_weights}{Optional numeric matrix of unnormalized log-importance +weights with dimensions \eqn{S \times n}. Weights are column-normalized +before computing each per-observation contribution.} + +\item{pointwise}{Optional numeric vector of precomputed pointwise rps values. +If provided, \code{y}, \code{ypred}, and \code{log_weights} are ignored.} + +\item{higher_is_better}{Logical or \code{NULL}; whether larger values indicate +better predictive performance. \code{NULL} (default) keeps each measure's +natural convention (e.g. MSE on a loss scale, ELPD on a utility scale). +Set \code{TRUE} for a utility scale (higher is better) or \code{FALSE} for a loss +scale (lower is better).} +} +\description{ +A convenience wrapper around \code{\link[=measure_rps]{measure_rps()}} with \code{scaled = TRUE}. Computes the +scaled ranked probability score (SRPS) for discrete outcomes or the scaled +continuously ranked probability score (SCRPS) for continuous outcomes. +Scaling makes the score invariant to the spread of the predictive +distribution, which can be useful when comparing models across observations +with very different predictive uncertainties. +} +\details{ +See \code{\link[=measure_rps]{measure_rps()}} for full details on arguments, estimation, and references. +} +\examples{ +y <- c(2L, 1L, 3L) +ypred <- matrix(c(2, 1, 2, 3, 1, 3), nrow = 2) +measure_srps(y, ypred) + +} diff --git a/man/pred_measure.Rd b/man/pred_measure.Rd new file mode 100644 index 00000000..7dc79858 --- /dev/null +++ b/man/pred_measure.Rd @@ -0,0 +1,130 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure.R +\name{pred_measure} +\alias{pred_measure} +\title{Add predictive performance measures to an existing result} +\usage{ +pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + measure = NULL, + predperf, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for distributional and +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 +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{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 +summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{measure}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\item A \strong{function} with attribute \code{"measure_name"} for one custom measure. +\item A \strong{list} mixing character scalars (built-in names) and named +functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. +} +Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and +\code{log_weights} that appear in their formals, plus arguments from \code{control}. +They must return a list with \code{estimates} and \code{pointwise}.} + +\item{predperf}{An existing predictive measure object (class +\code{"pred_measure"}) to update. When supplied, stored rows and +(for LOO) PSIS weights are reused instead of recomputed.} + +\item{group_ids}{Optional vector of group identifiers for grouped summaries +(reserved; not yet implemented).} + +\item{psis_object}{A \code{psis} object with LOO importance weights. An +alternative to passing a full \code{loo} object; must be supplied together with +\code{ylp} when computing \code{elpd}.} + +\item{save_psis}{Logical. If \code{TRUE}, store the \code{psis} object in the result +so that additional measures can be added later with \code{\link[=pred_measure]{pred_measure()}} without +recomputing PSIS weights.} + +\item{control}{Named list of per-measure settings. Each name must match an +element of \code{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))}).} +} +\value{ +An updated object of the same class as \code{predperf}, with new rows in +\code{estimates} and columns in \code{pointwise} for each requested measure. Rows +already in \code{predperf} are not recomputed. If \code{mlpd} or \code{ic} needs \code{elpd} and +\code{predperf} has no \code{elpd} column, \code{elpd} is recomputed from \code{ylp} for +insample and LOO results. For k-fold and test results this is an error. +} +\description{ +Extend a \code{"pred_measure"} object with additional measures \strong{without +recomputing} what is already stored. Use this for interactive exploration +or when you first compute \code{elpd} and later add distributional +or point-prediction metrics. + +Pass the existing object as \code{predperf} and supply any inputs newly required +by the requested measures (see the input table in +\code{\link[=insample_pred_measure]{insample_pred_measure()}}). The evaluation mode (\code{"insample"}, \code{"loo"}, +\code{"kfold"}, or \code{"test"}) is taken from \code{predperf}; LOO paths reuse stored +PSIS weights when available. +} +\details{ +\strong{Typical workflow:} + +\preformatted{ +result <- loo_pred_measure(loo = loo_fit, save_psis = TRUE) +pred_measure( + y = y, + mupred = mupred, + predperf = result, + measure = c("rmse", "r2") +) +} + +When extending a LOO result, ensure the initial call used \code{save_psis = TRUE} +(or that \code{predperf} already contains a \code{psis_object}) so LOO weights are +available for additional measures. +} +\examples{ +\donttest{ +if (requireNamespace("brms", quietly = TRUE)) { + fit <- brms::brm( + Reaction ~ Days, data = lme4::sleepstudy, + refresh = 0, chains = 2, iter = 1000 + ) + result <- insample_pred_measure( + ylp = brms::log_lik(fit), + y = fit$data$Reaction, + ypred = brms::posterior_predict(fit) + ) + pred_measure( + y = fit$data$Reaction, + mupred = brms::posterior_epred(fit), + predperf = result, + measure = c("rmse", "r2") + ) +} +} + +} +\seealso{ +\code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=loo_pred_measure]{loo_pred_measure()}}, +\code{\link[=kfold_pred_measure]{kfold_pred_measure()}}, \code{\link[=test_pred_measure]{test_pred_measure()}}, \link{supported_measures_list}, +\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{pred-measure workflow article} +} diff --git a/man/pred_measure_params.Rd b/man/pred_measure_params.Rd new file mode 100644 index 00000000..83fa7eab --- /dev/null +++ b/man/pred_measure_params.Rd @@ -0,0 +1,98 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-compute.R +\name{pred_measure_params} +\alias{pred_measure_params} +\alias{do_pred_measure} +\title{Shared parameters for predictive measure wrappers} +\usage{ +do_pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + ylp_test = NULL, + measure = NULL, + predperf = NULL, + loo = NULL, + kfold = NULL, + group_ids = NULL, + psis_object = NULL, + save_psis = FALSE, + source = NULL, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for distributional and +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 +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{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 +summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{ylp_test}{Matrix of pointwise log predictive densities for holdout +observations (\code{S} × \code{n_test}), typically from +\code{brms::log_lik(fit, newdata = test_data)}. Used with \code{ylp} (from the +training fit) in \code{\link[=test_pred_measure]{test_pred_measure()}} to score genuinely new data.} + +\item{measure}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\item A \strong{function} with attribute \code{"measure_name"} for one custom measure. +\item A \strong{list} mixing character scalars (built-in names) and named +functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. +} +Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and +\code{log_weights} that appear in their formals, plus arguments from \code{control}. +They must return a list with \code{estimates} and \code{pointwise}.} + +\item{predperf}{An existing predictive measure object (class +\code{"pred_measure"}) to update. When supplied, stored rows and +(for LOO) PSIS weights are reused instead of recomputed.} + +\item{loo}{A \code{\link[=loo]{loo()}} result, computed with +\code{save_psis = TRUE} so that PSIS weights are available for additional +measures. See \code{\link[=loo_pred_measure]{loo_pred_measure()}}.} + +\item{kfold}{A \code{kfold} object from \code{\link[brms:kfold]{brms::kfold()}}. Supplies ELPD summaries +and fold structure for \code{\link[=kfold_pred_measure]{kfold_pred_measure()}}; pass \code{y}, \code{ypred}, and/or +\code{mupred} when requesting additional measures.} + +\item{group_ids}{Optional vector of group identifiers for grouped summaries +(reserved; not yet implemented).} + +\item{psis_object}{A \code{psis} object with LOO importance weights. An +alternative to passing a full \code{loo} object; must be supplied together with +\code{ylp} when computing \code{elpd}.} + +\item{save_psis}{Logical. If \code{TRUE}, store the \code{psis} object in the result +so that additional measures can be added later with \code{\link[=pred_measure]{pred_measure()}} without +recomputing PSIS weights.} + +\item{source}{Character string indicating the evaluation mode: \code{"insample"}, +\code{"loo"}, \code{"kfold"}, or \code{"test"}. Set automatically by the wrapper +functions; required when calling \code{\link[=do_pred_measure]{do_pred_measure()}} directly.} + +\item{control}{Named list of per-measure settings. Each name must match an +element of \code{measure}; the value is a list of arguments passed to that +measure's summary function (e.g. \code{list(new_measure = list(add_arg = 10))}).} + +\item{measure_name}{For a single custom function, set +\code{attr(my_fun, "measure_name") <- "my_metric"} before passing \code{my_fun} to +\code{measure}.} +} +\description{ +Parameter definitions shared by the user-facing entry points and the +internal engine \code{\link[=do_pred_measure]{do_pred_measure()}}. +} +\keyword{internal} diff --git a/man/psislw.Rd b/man/psislw.Rd index 96371ba5..c49bbf8f 100644 --- a/man/psislw.Rd +++ b/man/psislw.Rd @@ -47,6 +47,8 @@ A named list with components \code{lw_smooth} (modified log weights) and \description{ As of version \verb{2.0.0} this function is \strong{deprecated}. Please use the \code{\link[=psis]{psis()}} function for the new PSIS algorithm. +\code{psislw()} and \code{R/psislw.R} are scheduled for removal in a future release. +See \code{vignette("migration-guide", package = "loo")} for details. } \references{ Vehtari, A., Gelman, A., and Gabry, J. (2017). Practical Bayesian model diff --git a/man/ptw_log_pred_density.Rd b/man/ptw_log_pred_density.Rd new file mode 100644 index 00000000..342c2669 --- /dev/null +++ b/man/ptw_log_pred_density.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{ptw_log_pred_density} +\alias{ptw_log_pred_density} +\title{Pointwise log predictive density (\code{lppd_i})} +\usage{ +ptw_log_pred_density(ylp, psis_log_weights = NULL) +} +\arguments{ +\item{ylp}{A numeric matrix of log predictive densities/probabilities with +dimensions draws x observations.} + +\item{psis_log_weights}{Optional numeric matrix of normalized PSIS log +weights with the same dimensions as \code{ylp}. Each column must sum to 1 on +the probability scale.} +} +\value{ +A numeric vector of length \code{ncol(ylp)} with pointwise log +predictive density values. +} +\description{ +Computes pointwise log predictive density contributions from a matrix of +log predictive densities/probabilities for posterior draws. When PSIS +log-weights are supplied, they are used to form a weighted log-sum-exp per +observation. +} +\examples{ +ylp <- matrix(log(c(0.2, 0.4, 0.3, 0.8)), nrow = 2) +ptw_log_pred_density(ylp) + +lw <- matrix(log(c(0.7, 0.3, 0.6, 0.4)), nrow = 2) +ptw_log_pred_density(ylp, lw) +} diff --git a/man/supported_measures_list.Rd b/man/supported_measures_list.Rd new file mode 100644 index 00000000..4b1cb44c --- /dev/null +++ b/man/supported_measures_list.Rd @@ -0,0 +1,13 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure-builtin.R +\name{supported_measures_list} +\alias{supported_measures_list} +\title{Supported predictive measure names} +\usage{ +supported_measures_list +} +\description{ +A character vector of measure names that can be passed to the \code{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()}}. +} diff --git a/man/test_pred_measure.Rd b/man/test_pred_measure.Rd new file mode 100644 index 00000000..382d3ba5 --- /dev/null +++ b/man/test_pred_measure.Rd @@ -0,0 +1,108 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pred_measure.R +\name{test_pred_measure} +\alias{test_pred_measure} +\title{Holdout predictive performance measures} +\usage{ +test_pred_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = NULL, + ylp_test = NULL, + measure = NULL, + group_ids = NULL, + control = list() +) +} +\arguments{ +\item{y}{Vector of observed values (\code{n}). Required for distributional and +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 +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{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 +summaries (\code{elpd}, \code{mlpd}, \code{ic}).} + +\item{ylp_test}{Matrix of pointwise log predictive densities for holdout +observations (\code{S} × \code{n_test}), typically from +\code{brms::log_lik(fit, newdata = test_data)}. Used with \code{ylp} (from the +training fit) in \code{\link[=test_pred_measure]{test_pred_measure()}} to score genuinely new data.} + +\item{measure}{Measures to compute. \code{NULL} (default) gives \code{elpd} (with +\code{p_loo} / \code{p_kfold} for LOO and k-fold). Can be: +\itemize{ +\item A \strong{character vector} of built-in names; see +\link{supported_measures_list}. +\item A \strong{function} with attribute \code{"measure_name"} for one custom measure. +\item A \strong{list} mixing character scalars (built-in names) and named +functions (custom measures), e.g. \code{list("rps", my_metric = my_fun)}. +} +Custom functions are called with any of \code{y}, \code{ypred}, \code{mupred}, \code{ylp}, and +\code{log_weights} that appear in their formals, plus arguments from \code{control}. +They must return a list with \code{estimates} and \code{pointwise}.} + +\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))}).} +} +\value{ +An object of class \code{"test_pred_measure"} and \code{"pred_measure"} with +\code{estimates} and \code{pointwise}. Measure names carry a \verb{_test} suffix (e.g. +\code{elpd_test}, \code{crps_test}). Attribute \code{dims} reflects the test-set size +(from \code{ylp_test}), not the training data. +} +\description{ +Score predictive performance on \strong{genuinely new (holdout) data} that was +not used to fit the model. This mirrors the cross-validation goal of +assessing how well a model predicts unseen observations, but with an +explicit train/test split rather than LOO or k-fold reweighting. + +Supply \code{ylp_test} from log predictive densities evaluated on the holdout set +(e.g. \code{brms::log_lik(fit, newdata = test_data)}). This is required for +\code{elpd_test}, \code{mlpd_test} and \code{ic_test}. Optional distributional and +point-prediction measures use observed and predicted values on the test set +only. Pass training \code{ylp} only when an additional measure needs log +predictive densities from the training fit. +} +\details{ +\code{elpd_test} is computed from \code{ylp_test} on the holdout +observations only. +} +\examples{ +\donttest{ +if (requireNamespace("brms", quietly = TRUE)) { + data <- lme4::sleepstudy + train <- data[1:150, ] + test <- data[151:nrow(data), ] + fit <- brms::brm( + Reaction ~ Days, data = train, + refresh = 0, chains = 2, iter = 1000 + ) + test_pred_measure( + y = test$Reaction, + ypred = brms::posterior_predict(fit, newdata = test), + mupred = brms::posterior_epred(fit, newdata = test), + ylp = brms::log_lik(fit), + ylp_test = brms::log_lik(fit, newdata = test), + measure = c("rmse", "r2") + ) +} +} + +} +\seealso{ +\code{\link[=insample_pred_measure]{insample_pred_measure()}}, \code{\link[=loo_pred_measure]{loo_pred_measure()}}, +\code{\link[=kfold_pred_measure]{kfold_pred_measure()}}, \code{\link[=pred_measure]{pred_measure()}}, \link{supported_measures_list}, +\href{https://mc-stan.org/loo/articles/articles-online-only/pred-measure-workflow.html}{pred-measure workflow article} +} diff --git a/notes/developer-notes.Rmd b/notes/developer-notes.Rmd new file mode 100644 index 00000000..ae190ae4 --- /dev/null +++ b/notes/developer-notes.Rmd @@ -0,0 +1,510 @@ +--- +title: "Developer Notes: `pred_measure` Feature" +output: + github_document: + toc: true + toc_depth: 2 +--- + +```{r setup, include = FALSE} +knitr::opts_chunk$set( + echo = FALSE, + message = FALSE, + warning = FALSE, + fig.path = "figures/", + fig.width = 8, + fig.height = 4.5, + dpi = 150 +) +``` + +> **Status:** In Progress +> **Base branch:** `loo-v3.0.0` +> **Compare branch:** `pred_measure` +> **Related PR:** [#363](https://github.com/stan-dev/loo/pull/363) +> **Contributors:** @florence-bockting, @avehtari, @VisruthSK, @jgabry +> **Last updated:** 2026-07-03 + +These notes document internal design decisions and ongoing work for the +`pred_measure` feature. This PR **adds** the new API. + +## Status at a Glance + +| Area | Status | +|------|--------| +| `pred_measure` API | Done | +| `measure_*()` built-ins | Done | +| Scoring rules (`measure_rps`) | Done | +| Documentation | In progress | +| `group_ids` grouping | Not started | +| `loo_compare` integration | Not started | + +## Scope of this PR (`pred_measure` vs `loo-v3.0.0`) + +### Added (did not exist on `loo-v3.0.0`) + +- `R/pred_measure.R` — `insample_pred_measure()`, `loo_pred_measure()`, + `kfold_pred_measure()`, `test_pred_measure()`, `pred_measure()` +- `R/pred_measure-compute.R`, `R/pred_measure-helpers.R`, + `R/pred_measure-builtin.R` — orchestration and `measure_*()` implementations +- `supported_measures_list()`, `ptw_log_pred_density()` +- S3 print methods for `pred_measure`, `loo_pred_measure`, `kfold_pred_measure`, `test_pred_measure` +- `vignettes/migration-guide.Rmd` +- Website-only articles: `overview-measures.Rmd`, `pred-measure-workflow.Rmd` +- Test suite + pre-fitted fixtures + `test_data_generation.R` + +### Changed on existing code (implementations retained) + +- `elpd()`, `crps()`, `scrps()`, `loo_crps()`, `loo_scrps()`, + `loo_predictive_metric()` — deprecated with migration docs; **same APIs and + implementations** (e.g. `crps(x, x2, y)` permutation estimator unchanged) +- `elpd()` — refactored to `.elpd_matrix_impl()` to avoid double deprecation + warnings +- Minor doc cross-references in `compare.R`, `psislw.R` +- `NEWS.md`, `NAMESPACE`, `_pkgdown.yml`, pkgdown CI workflow + +## Design decisions (resolved) + +### D2: Scaled RPS — separate function vs. argument + +**Decision:** Both. `measure_rps(..., scaled = TRUE)` is the implementation; +`measure_srps()` is a convenience wrapper. An explicit `srps` built-in name is +required so users can request both in one call: + +```r +pred_measure(y = y, ypred = ypred, measure = c("rps", "srps"), ...) +``` + +Without a separate `srps` name, duplicate measure names would require custom +functions. + +### Unified scoring rule in the new API + +`measure_rps()` subsumes CRPS, RPS, SCRPS, and SRPS for the **new** workflow: + +- Single `ypred` matrix (not two independent draw matrices) +- PWM/ECDF estimator (Aki's implementation; verified against Seth's derivations) +- Works for continuous and ordered categorical outcomes +- `measure_srps()` = scaled variant + +Deprecated `crps()` / `scrps()` remain for backward compatibility with the +`x`, `x2` permutation-based API. + +### ELPD and `ic` in the new API + +Design choices **internal to `pred_measure`**: + +- When `ylp` is supplied, `elpd` is computed as the base summary +- `ic` is **not** included automatically; request via `measure = "ic"` +- `measure_elpd()` is separate from deprecated `elpd()` (different return type: `"measure"` vs `"elpd_generic"`) + +### K-fold + categorical / multinomial models (brms) + +- [x] Upstream fix for 3D `brms::kfold_predict()` output + ([brms#1889](https://github.com/paul-buerkner/brms/issues/1889), + fixed in [brms#1890](https://github.com/paul-buerkner/brms/pull/1890), + merged to `main`) +- [x] Vignettes and pkgdown CI install brms from GitHub `master` + (`vignettes/children/LOAD-BRMS-GITHUB.txt`, `.github/workflows/pkgdown.yaml`, + `tests/testthat/data-for-tests/test_data_generation.R`) +- [ ] Drop GitHub brms pin once a CRAN release includes the #1890 fix +- [ ] Verify `kfold_pred_measure()` with categorical/multinomial examples + end-to-end (penguins fixture exists; confirm test/doc coverage) + +## Open decisions + +### D1: Sign convention for pointwise estimates + +- **Context:** Measures differ in orientation (`rps`: lower is better; + `srps`: higher is better). Aligning orientations may help comparisons. +- **Options:** `lower_is_better`, `orientation = "utility" / "loss"`, + `higher_is_better` (per-measure orientation control on `measure_*()` functions) +- **Decision:** *pending* + +### D3: Handling of `r_eff` + +- **Context:** [stan-dev/posterior#446](https://github.com/stan-dev/posterior/issues/446) +- **Question:** How should `r_eff` be handled in `pred_measure` workflows? +- **Decision:** *pending* + +## Tasks + +### Refactoring (within new API) + +- [x] Add `measure_elpd()` for the new API +- [x] Refactor deprecated `elpd()` to `.elpd_matrix_impl()` (no double warnings) +- [x] Add `measure_rps()` as unified scoring-rule implementation (single `ypred`) +- [x] Keep deprecated `crps()` / `scrps()` with `x`, `x2` API unchanged +- [x] In `*_pred_measure()`, compute `elpd` as base when `ylp` supplied; + require explicit `measure = "ic"` for information criterion +- [x] Document and test deprecated vs new API comparisons *(see appendix)* +- [ ] Provide an interface to `loo_compare` and verify consistency +- [ ] Resolve `r_eff` handling *(see D3)* + +### Implementation + +- [x] Consolidate CRPS/RPS/SCRPS/SRPS in `measure_rps()` for new API +- [x] Resolve `srps` naming *(see D2)* +- [x] brms k-fold categorical support unblocked upstream *(see above)* +- [ ] Drop GitHub brms pin after CRAN release + +### Documentation + +- [x] Migration guide (`vignettes/migration-guide.Rmd`) +- [x] Overview of measures (`overview-measures.Rmd`) +- [x] Workflow article (`pred-measure-workflow.Rmd`) +- [x] Online-only articles published via `_pkgdown.yml` +- [ ] Formula derivations article (`pred_measure-formulas.Rmd`) +- [ ] Detailed per-measure descriptions (derivations where appropriate) +- [ ] Extend glossary (`R/loo-glossary.R`) — measure, metric, score, utility, loss + +### Grouping via `group_ids` + +- [ ] Work out grouping scenarios for LOO and k-fold +- [ ] Implement in `kfold_pred_measure()`, `loo_pred_measure()`, `pred_measure()` + + > **Blocker:** Implementation approach uncertain; grouping scenarios must be + > understood before coding begins. + +## General questions + +- Rename `ic` → `information_criteria` for clarity? +- Should `measure_elpd()` also return `ic`, or keep them separate? +- What defines class `"loo"` on measure objects? (e.g. deprecated `elpd_generic` + inherits `"loo"`) +- Should `elpd` always be computed when `ylp` is supplied, or allow + `loo_pred_measure()` for non-ELPD measures only? + +## References & resources + +| Resource | Link / contact | +|----------|----------------| +| Cross-validation FAQ | | +| `r_eff` in posterior (Aki) | | +| brms k-fold 3D fix | [brms#1889](https://github.com/paul-buerkner/brms/issues/1889), [brms#1890](https://github.com/paul-buerkner/brms/pull/1890) | +| `rps` derivation (Seth) | @florence-bockting, @avehtari | +| `rps` implementation (Aki) | @florence-bockting, @avehtari | +| K-fold vignette | | +| Broader loo 3.0.0 migration | `loo-v3.0.0` branch, `dev/migration-guide-loo-v3.Rmd` | + +--- + +## Appendix: Numerical comparisons (deprecated vs new API) + +Simulations and tests that validate design choices in this PR. Automated +comparisons live in `tests/testthat/test_crps.R` (CRPS/RPS section). + +### CRPS / RPS + +Deprecated `crps()` / `scrps()` and new `measure_rps()` / `measure_srps()` target +the same scoring rules but use different estimators. + +#### API mapping + +| Deprecated | New workflow | Notes | +|------------|--------------|-------| +| `crps(x, x2, y)` | `measure_rps(y, ypred = x, higher_is_better = FALSE)` | Loss-scale unscaled score | +| `scrps(x, x2, y)` | `measure_srps(y, ypred = x)` | Same sign convention | +| `loo_crps(...)` | `loo_pred_measure(..., measure = "rps")` | Additional LOO weighting difference | +| `loo_scrps(...)` | `loo_pred_measure(..., measure = "srps")` | Additional LOO weighting difference | + +#### Sources of numerical difference + +1. **Sign convention (unscaled only).** `crps()` returns `0.5·EXX − EXy` (utility: + higher is better). Default `measure_rps()` negates this; use + `higher_is_better = FALSE` to match `crps()`. Scaled scores (`scrps` / `measure_srps`) + already share the formula `−EXy/EXX − 0.5·log(EXX)`. + +2. **EXX estimator (in-sample).** Both estimate `E|X − X'|`, but: + - **Deprecated:** two draw matrices `x`, `x2`; one random shuffle per + permutation (`EXX_compute()` in `R/crps.R`). + - **New:** single `ypred` matrix; PWM on sorted draws (Zamo & Naveau, 2018). + + `EXy = E|X − y|` is **identical** between APIs. After sign alignment, all + pointwise differences come from EXX. + +3. **LOO weighting.** `loo_crps()` shuffles a second draw matrix and applies + joint PSIS weights to `|x − x2|`. `loo_pred_measure(..., measure = "rps")` + uses weighted PWM on a single `ypred` with PSIS weights from `ylp` only — so + LOO differences combine EXX method and importance-weighting approach. + +#### Key results (reference simulation) + +![CRPS/RPS comparison: PWM vs permutation EXX estimators](figures/crps-rps-comparison.png) + +*Figure: left — per-observation EXX estimates at the brms default draw count +(S = 4000 post-warmup draws: 4 chains × 1000); right — mean relative EXX error +decreases with more posterior draws.* + +```{r crps-rps-comparison} +devtools::load_all(quiet = TRUE) + +.exx_pwm <- function(ypred) { + n_draws <- nrow(ypred) + ypred_sorted <- apply(ypred, 2, sort) + colMeans(ypred_sorted * ((seq_len(n_draws) * (4 / (n_draws - 1))) - 2)) +} + +.outcome_panel <- function(old_est, new_est, xlab, ylab, main, pad_frac = 0.2) { + lim <- range(c(old_est, new_est)) + pad <- diff(lim) * pad_frac + if (pad == 0) pad <- abs(lim[1]) * pad_frac + lim <- lim + c(-pad, pad) + plot( + old_est, new_est, + xlab = xlab, ylab = ylab, main = main, + xlim = lim, ylim = lim, + pch = 16, col = adjustcolor("steelblue", 0.55) + ) + abline(0, 1, lty = 2, col = "gray40") + r <- cor(old_est, new_est) + mtext(sprintf("r = %.3f", r), side = 3, line = 0.2, cex = 0.85, adj = 0) +} + +set.seed(123456789) +n <- 30 +S <- 100 +y <- rnorm(n) +x1 <- matrix(rnorm(n * S), nrow = S) +x2 <- matrix(rnorm(n * S), nrow = S) + +EXy <- colMeans(abs(sweep(x1, 2, y))) +EXX_perm <- colMeans(abs(x1 - x2[sample(S), , drop = FALSE])) +EXX_pwm <- .exx_pwm(x1) + +old_crps <- suppressWarnings(crps(x1, x2, y)) +new_rps <- measure_rps(y, x1, higher_is_better = FALSE) +old_scrps <- suppressWarnings(scrps(x1, x2, y)) +new_srps <- measure_srps(y, x1) + +comparison <- data.frame( + metric = c( + "Mean rel. |EXX_perm - EXX_pwm| / EXX_pwm", + "cor(pointwise CRPS, sign-aligned)", + "Mean |pointwise CRPS diff|", + "cor(pointwise SCRPS, SRPS)" + ), + value = c( + mean(abs(EXX_perm - EXX_pwm) / EXX_pwm), + cor(old_crps$pointwise, as.vector(new_rps$pointwise)), + mean(abs(old_crps$pointwise - as.vector(new_rps$pointwise))), + cor(old_scrps$pointwise, as.vector(new_srps$pointwise)) + ) +) +knitr::kable( + comparison, + col.names = c("Metric (S = 100, n = 30)", "Value"), + digits = 4 +) +``` + +```{r crps-rps-figure, fig.show = "hide"} +S_brms <- 4L * (getOption("brms.iter", 2000L) %/% 2L) + +set.seed(123456789) +n_obs_exx <- 30L +y_exx <- rnorm(n_obs_exx) +x1_exx <- matrix(rnorm(n_obs_exx * S_brms), nrow = S_brms) +x2_exx <- matrix(rnorm(n_obs_exx * S_brms), nrow = S_brms) +EXX_perm_brms <- colMeans(abs(x1_exx - x2_exx[sample(S_brms), , drop = FALSE])) +EXX_pwm_brms <- .exx_pwm(x1_exx) + +.exx_axis_lim <- function(x, y, pad_frac = 0.2) { + lim <- range(c(x, y)) + pad <- diff(lim) * pad_frac + if (pad == 0) pad <- abs(lim[1]) * pad_frac + c(max(0, lim[1] - pad), lim[2] + pad) +} +exx_lim <- .exx_axis_lim(EXX_perm_brms, EXX_pwm_brms) + +png("figures/crps-rps-comparison.png", width = 8, height = 4.5, units = "in", res = 150) +par(mfrow = c(1, 2), mar = c(4, 4, 2, 1)) + +plot( + EXX_perm_brms, EXX_pwm_brms, + xlab = "EXX (permutation, 1 shuffle)", + ylab = "EXX (PWM)", + xlim = exx_lim, ylim = exx_lim, + pch = 16, col = adjustcolor("steelblue", 0.7), + main = sprintf("EXX per observation (S = %d)", S_brms) +) +abline(0, 1, lty = 2, col = "gray40") + +draw_sizes <- c(50, 100, 250, 500, 1000, 2500, 5000) +rel_err <- vapply(draw_sizes, function(S) { + set.seed(99) + x1s <- matrix(rnorm(20 * S), nrow = S) + x2s <- matrix(rnorm(20 * S), nrow = S) + EXX_p <- colMeans(abs(x1s - x2s[sample(S), , drop = FALSE])) + EXX_w <- .exx_pwm(x1s) + mean(abs(EXX_p - EXX_w) / EXX_w) +}, numeric(1)) + +plot( + draw_sizes, rel_err, type = "b", pch = 16, + log = "x", + xlab = "Number of posterior draws (S)", + ylab = "Mean relative |EXX_perm - EXX_pwm| / EXX_pwm", + main = "EXX convergence with more draws" +) +invisible(dev.off()) +``` + +#### In-sample outcome comparison + +![CRPS/RPS outcome comparison across replications](figures/crps-rps-outcomes.png) + +*Figure: 200 simulations (S = 100, n = 30). Left — `crps()` vs +`measure_rps(higher_is_better = FALSE)`; right — `scrps()` vs `measure_srps()`.* + +```{r crps-rps-outcomes-figure, fig.show = "hide"} +n_repl <- 200L +n_obs <- 30L +n_draws <- 100L +crps_old <- rps_new <- scrps_old <- srps_new <- numeric(n_repl) + +for (i in seq_len(n_repl)) { + set.seed(i) + y <- rnorm(n_obs) + x1 <- matrix(rnorm(n_obs * n_draws), nrow = n_draws) + x2 <- matrix(rnorm(n_obs * n_draws), nrow = n_draws) + old <- suppressWarnings(crps(x1, x2, y)) + new <- measure_rps(y, x1, higher_is_better = FALSE) + old_s <- suppressWarnings(scrps(x1, x2, y)) + new_s <- measure_srps(y, x1) + crps_old[i] <- old$estimates["Estimate"] + rps_new[i] <- new$estimates[1, "Estimate"] + scrps_old[i] <- old_s$estimates["Estimate"] + srps_new[i] <- new_s$estimates[1, "Estimate"] +} + +png("figures/crps-rps-outcomes.png", width = 8, height = 4.5, units = "in", res = 150) +par(mfrow = c(1, 2), mar = c(4, 4, 2.5, 1)) +.outcome_panel( + crps_old, rps_new, + xlab = "crps() estimate", + ylab = "measure_rps(higher_is_better = FALSE)", + main = "Unscaled (CRPS / RPS)" +) +.outcome_panel( + scrps_old, srps_new, + xlab = "scrps() estimate", + ylab = "measure_srps()", + main = "Scaled (SCRPS / SRPS)" +) +invisible(dev.off()) +``` + +#### LOO outcome comparison + +![LOO CRPS/RPS outcome comparison across replications](figures/loo-crps-rps-outcomes.png) + +*Figure: 200 LOO simulations (S = 100, n = 30). Left — `loo_crps()` vs +sign-aligned `loo_pred_measure(..., measure = "rps")`; right — `loo_scrps()` +vs `loo_pred_measure(..., measure = "srps")`.* + +```{r loo-crps-outcomes-figure, fig.show = "hide"} +n_repl <- 200L +n_obs <- 30L +n_draws <- 100L +loo_crps_old <- loo_rps_new <- loo_scrps_old <- loo_srps_new <- numeric(n_repl) + +for (i in seq_len(n_repl)) { + set.seed(i) + y <- rnorm(n_obs) + x1 <- matrix(rnorm(n_obs * n_draws), nrow = n_draws) + x2 <- matrix(rnorm(n_obs * n_draws), nrow = n_draws) + ll <- matrix(rnorm(n_obs * n_draws) * 0.1 - 1, nrow = n_draws) + old <- suppressWarnings(loo_crps(x1, x2, y, ll)) + old_s <- suppressWarnings(loo_scrps(x1, x2, y, ll)) + psis_obj <- psis(-ll, r_eff = 1) + new <- loo_pred_measure( + y = y, ypred = x1, ylp = ll, measure = "rps", psis_object = psis_obj + ) + new_s <- loo_pred_measure( + y = y, ypred = x1, ylp = ll, measure = "srps", psis_object = psis_obj + ) + loo_crps_old[i] <- old$estimates["Estimate"] + loo_rps_new[i] <- -new$estimates["rps_loo", "Estimate"] + loo_scrps_old[i] <- old_s$estimates["Estimate"] + loo_srps_new[i] <- new_s$estimates["srps_loo", "Estimate"] +} + +png("figures/loo-crps-rps-outcomes.png", width = 8, height = 4.5, units = "in", res = 150) +par(mfrow = c(1, 2), mar = c(4, 4, 2.5, 1)) +.outcome_panel( + loo_crps_old, loo_rps_new, + xlab = "loo_crps() estimate", + ylab = "-loo_pred_measure(..., measure = 'rps')", + main = "LOO unscaled (CRPS / RPS)" +) +.outcome_panel( + loo_scrps_old, loo_srps_new, + xlab = "loo_scrps() estimate", + ylab = "loo_pred_measure(..., measure = 'srps')", + main = "LOO scaled (SCRPS / SRPS)" +) +invisible(dev.off()) +``` + +**CRPS/RPS takeaway:** Results are highly correlated but not interchangeable. The +PWM estimator is lower-variance and requires only one draw matrix. For migration, +compare trends and rankings rather than expecting pointwise equality. + +### ELPD / IC + +Deprecated `elpd()` and new `measure_elpd()` / `measure_ic()` compute the same +in-sample pointwise log predictive density and information criterion from a +log-likelihood matrix. The difference is return structure (`elpd_generic` with +both columns vs separate `"measure"` objects), not the underlying formula. + +| Deprecated | New workflow | Notes | +|------------|--------------|-------| +| `elpd(ylp)$estimates["elpd", ]` | `measure_elpd(ylp)` | Same `lppd_i` computation | +| `elpd(ylp)$estimates["ic", ]` | `measure_ic(ylp)` | `ic_i = -2 * lppd_i` in both APIs | + +#### Outcome comparison + +![ELPD / IC outcome comparison across replications](figures/elpd-ic-outcomes.png) + +*Figure: 200 simulations (S = 100, n = 30). Left — `elpd()` vs `measure_elpd()`; +right — `ic` from `elpd()` vs `measure_ic()`.* + +```{r elpd-ic-outcomes-figure, fig.show = "hide"} +n_repl <- 200L +n_obs <- 30L +n_draws <- 100L +elpd_old <- elpd_new <- ic_old <- ic_new <- numeric(n_repl) + +for (i in seq_len(n_repl)) { + set.seed(i) + ll <- matrix(rnorm(n_obs * n_draws) - 2, nrow = n_draws) + old <- suppressWarnings(elpd(ll)) + new_e <- measure_elpd(ll) + new_i <- measure_ic(ll) + elpd_old[i] <- old$estimates["elpd", "Estimate"] + elpd_new[i] <- new_e$estimates[1, "Estimate"] + ic_old[i] <- old$estimates["ic", "Estimate"] + ic_new[i] <- new_i$estimates[1, "Estimate"] +} + +png("figures/elpd-ic-outcomes.png", width = 8, height = 4.5, units = "in", res = 150) +par(mfrow = c(1, 2), mar = c(4, 4, 2.5, 1)) +.outcome_panel( + elpd_old, elpd_new, + xlab = "elpd() estimate", + ylab = "measure_elpd()", + main = "ELPD" +) +.outcome_panel( + ic_old, ic_new, + xlab = "elpd() ic estimate", + ylab = "measure_ic()", + main = "IC" +) +invisible(dev.off()) +``` + +**ELPD/IC takeaway:** In-sample estimates match between deprecated and new APIs. +Migration is about return type and `*_pred_measure()` workflow integration, not +numerical differences. diff --git a/notes/developer-notes.md b/notes/developer-notes.md new file mode 100644 index 00000000..0dd96f5c --- /dev/null +++ b/notes/developer-notes.md @@ -0,0 +1,346 @@ +Developer Notes: `pred_measure` Feature +================ + +- [Status at a Glance](#status-at-a-glance) +- [Scope of this PR (`add-pred-measure` vs + `loo-v3.0.0`)](#scope-of-this-pr-add-pred-measure-vs-loo-v300) +- [Design decisions (resolved)](#design-decisions-resolved) +- [Open decisions](#open-decisions) +- [Tasks](#tasks) +- [General questions](#general-questions) +- [References & resources](#references--resources) +- [Appendix: Numerical comparisons (deprecated vs new + API)](#appendix-numerical-comparisons-deprecated-vs-new-api) + +> **Status:** In Progress +> **Base branch:** `loo-v3.0.0` +> **Compare branch:** `add-pred-measure` +> **Related PR:** [\#363](https://github.com/stan-dev/loo/pull/363) +> **Contributors:** @florence-bockting, @avehtari, @VisruthSK, @jgabry +> **Last updated:** 2026-07-03 + +These notes document internal design decisions and ongoing work for the +`pred_measure` feature. This PR **adds** the new API on top of +`loo-v3.0.0`; it does not include other planned 3.0.0 changes +(e.g. broader `compare()` / `psislw()` removals) documented on the +`loo-v3.0.0` branch. + +For the merge summary, see the PR description +([`internal-notes/pr-pred_measure.md`](../internal-notes/pr-pred_measure.md)). + +------------------------------------------------------------------------ + +## Status at a Glance + +| Area | Status | +|-------------------------------|------------------------| +| `pred_measure` API | Done (initial release) | +| `measure_*()` built-ins | Done | +| Scoring rules (`measure_rps`) | Done | +| Documentation | In progress | +| `group_ids` grouping | Not started | +| `loo_compare` integration | Not started | + +------------------------------------------------------------------------ + +## Scope of this PR (`add-pred-measure` vs `loo-v3.0.0`) + +### Added (did not exist on `loo-v3.0.0`) + +- `R/pred_measure.R` — `insample_pred_measure()`, `loo_pred_measure()`, + `kfold_pred_measure()`, `test_pred_measure()`, `pred_measure()` +- `R/pred_measure-compute.R`, `R/pred_measure-helpers.R`, + `R/pred_measure-builtin.R` — orchestration and `measure_*()` + implementations +- `supported_measures_list()`, `ptw_log_pred_density()` +- S3 print methods for `pred_measure`, `loo_pred_measure`, + `kfold_pred_measure` +- `vignettes/migration-guide.Rmd` +- Website-only articles: `overview-measures.Rmd`, + `pred-measure-workflow.Rmd` +- Test suite + pre-fitted fixtures + `test_data_generation.R` + +### Changed on existing code (implementations retained) + +- `elpd()`, `crps()`, `scrps()`, `loo_crps()`, `loo_scrps()`, + `loo_predictive_metric()` — deprecated with migration docs; **same + APIs and implementations** (e.g. `crps(x, x2, y)` permutation + estimator unchanged) +- `elpd()` — refactored to `.elpd_matrix_impl()` to avoid double + deprecation warnings +- Minor doc cross-references in `compare.R`, `psislw.R` +- `NEWS.md`, `NAMESPACE`, `_pkgdown.yml`, pkgdown CI workflow + +------------------------------------------------------------------------ + +## Design decisions (resolved) + +### D2: Scaled RPS — separate function vs. argument + +**Decision:** Both. `measure_rps(..., scaled = TRUE)` is the +implementation; `measure_srps()` is a convenience wrapper. An explicit +`srps` built-in name is required so users can request both in one call: + +``` r +pred_measure(y = y, ypred = ypred, measure = c("rps", "srps"), ...) +``` + +Without a separate `srps` name, duplicate measure names would require +custom functions. + +### Unified scoring rule in the new API + +`measure_rps()` subsumes CRPS, RPS, SCRPS, and SRPS for the **new** +workflow: + +- Single `ypred` matrix (not two independent draw matrices) +- PWM/ECDF estimator (Aki’s implementation; verified against Seth’s + derivations) +- Works for continuous and ordered categorical outcomes +- `measure_srps()` = scaled variant + +Deprecated `crps()` / `scrps()` remain for backward compatibility with +the `x`, `x2` permutation-based API. + +### ELPD and `ic` in the new API + +Design choices **internal to `pred_measure`** (not a migration from +`loo-v3.0.0`, which has no `pred_measure`): + +- When `ylp` is supplied, `elpd` is computed as the base summary +- `ic` is **not** included automatically; request via `measure = "ic"` +- `measure_elpd()` is separate from deprecated `elpd()` (different + return type: `"measure"` vs `"elpd_generic"`) + +### K-fold + categorical / multinomial models (brms) + +- [x] Upstream fix for 3D `brms::kfold_predict()` output + ([brms#1889](https://github.com/paul-buerkner/brms/issues/1889), fixed + in [brms#1890](https://github.com/paul-buerkner/brms/pull/1890), + merged to `main`) +- [x] Vignettes and pkgdown CI install brms from GitHub `master` + (`vignettes/children/LOAD-BRMS-GITHUB.txt`, + `.github/workflows/pkgdown.yaml`, + `tests/testthat/data-for-tests/test_data_generation.R`) +- [ ] Drop GitHub brms pin once a CRAN release includes the \#1890 fix +- [ ] Verify `kfold_pred_measure()` with categorical/multinomial + examples end-to-end (penguins fixture exists; confirm test/doc + coverage) + +------------------------------------------------------------------------ + +## 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* + +### D3: Handling of `r_eff` + +- **Context:** + [stan-dev/posterior#446](https://github.com/stan-dev/posterior/issues/446) +- **Question:** How should `r_eff` be handled in `pred_measure` + workflows? +- **Decision:** *pending* + +------------------------------------------------------------------------ + +## Tasks + +### Refactoring (within new API) + +- [x] Add `measure_elpd()` for the new API +- [x] Refactor deprecated `elpd()` to `.elpd_matrix_impl()` (no double + warnings) +- [x] Add `measure_rps()` as unified scoring-rule implementation (single + `ypred`) +- [x] Keep deprecated `crps()` / `scrps()` with `x`, `x2` API unchanged +- [x] In `*_pred_measure()`, compute `elpd` as base when `ylp` supplied; + require explicit `measure = "ic"` for information criterion +- [x] Document and test deprecated vs new API comparisons *(see + appendix)* +- [ ] Provide an interface to `loo_compare` and verify consistency +- [ ] Resolve `r_eff` handling *(see D3)* + +### Implementation + +- [x] Consolidate CRPS/RPS/SCRPS/SRPS in `measure_rps()` for new API +- [x] Resolve `srps` naming *(see D2)* +- [x] brms k-fold categorical support unblocked upstream *(see above)* +- [ ] Drop GitHub brms pin after CRAN release + +### Documentation + +- [x] Migration guide (`vignettes/migration-guide.Rmd`) +- [x] Overview of measures (`overview-measures.Rmd`) +- [x] Workflow article (`pred-measure-workflow.Rmd`) +- [x] Online-only articles published via `_pkgdown.yml` +- [ ] Formula derivations article (`pred_measure-formulas.Rmd`) +- [ ] Detailed per-measure descriptions (derivations where appropriate) +- [ ] Extend glossary (`R/loo-glossary.R`) — measure, metric, score, + utility, loss + +### Grouping via `group_ids` + +- [ ] Work out grouping scenarios for LOO and k-fold + +- [ ] Implement in `kfold_pred_measure()`, `loo_pred_measure()`, + `pred_measure()` + + > **Blocker:** Implementation approach uncertain; grouping scenarios + > must be understood before coding begins. + +------------------------------------------------------------------------ + +## General questions + +- Rename `ic` → `information_criteria` for clarity? +- Should `measure_elpd()` also return `ic`, or keep them separate? +- What defines class `"loo"` on measure objects? (e.g. deprecated + `elpd_generic` inherits `"loo"`) +- Should `elpd` always be computed when `ylp` is supplied, or allow + `loo_pred_measure()` for non-ELPD measures only? + +------------------------------------------------------------------------ + +## References & resources + +| Resource | Link / contact | +|-----------------------------|------------------------------------------------------------------------------------------------------------------------------| +| Cross-validation FAQ | | +| `r_eff` in posterior (Aki) | | +| brms k-fold 3D fix | [brms#1889](https://github.com/paul-buerkner/brms/issues/1889), [brms#1890](https://github.com/paul-buerkner/brms/pull/1890) | +| `rps` derivation (Seth) | @florence-bockting, @avehtari | +| `rps` implementation (Aki) | @florence-bockting, @avehtari | +| K-fold vignette | | +| Broader loo 3.0.0 migration | `loo-v3.0.0` branch, `dev/migration-guide-loo-v3.Rmd` | + +------------------------------------------------------------------------ + +## Appendix: Numerical comparisons (deprecated vs new API) + +Simulations and tests that validate design choices in this PR. Automated +comparisons live in `tests/testthat/test_crps.R` (CRPS/RPS section). + +### CRPS / RPS + +Deprecated `crps()` / `scrps()` and new `measure_rps()` / +`measure_srps()` target the same scoring rules but use different +estimators. + +#### API mapping + +| Deprecated | New workflow | Notes | +|-------------------|-------------------------------------------------|-------------------------------------| +| `crps(x, x2, y)` | `measure_rps(y, ypred = x, revert_sign = TRUE)` | 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 | + +#### Sources of numerical difference + +1. **Sign convention (unscaled only).** `crps()` returns + `0.5·EXX − EXy` (utility: higher is better). Default `measure_rps()` + negates this; use `revert_sign = TRUE` to match `crps()`. Scaled + scores (`scrps` / `measure_srps`) already share the formula + `−EXy/EXX − 0.5·log(EXX)`. + +2. **EXX estimator (in-sample).** Both estimate `E|X − X'|`, but: + + - **Deprecated:** two draw matrices `x`, `x2`; one random shuffle + per permutation (`EXX_compute()` in `R/crps.R`). + - **New:** single `ypred` matrix; PWM on sorted draws (Zamo & + Naveau, 2018). + + `EXy = E|X − y|` is **identical** between APIs. After sign + alignment, all pointwise differences come from EXX. + +3. **LOO weighting.** `loo_crps()` shuffles a second draw matrix and + applies joint PSIS weights to `|x − x2|`. + `loo_pred_measure(..., measure = "rps")` uses weighted PWM on a + single `ypred` with PSIS weights from `ylp` only — so LOO + differences combine EXX method and importance-weighting approach. + +#### Key results (reference simulation) + +
+ + +
+ +*Figure: left — per-observation EXX estimates at the brms default draw +count (S = 4000 post-warmup draws: 4 chains × 1000); right — mean +relative EXX error decreases with more posterior draws.* + +| Metric (S = 100, n = 30) | Value | +|:-------------------------------------------|-------:| +| Mean rel. \|EXX_perm - EXX_pwm\| / EXX_pwm | 0.0688 | +| cor(pointwise CRPS, sign-aligned) | 0.9923 | +| Mean \|pointwise CRPS diff\| | 0.0339 | +| cor(pointwise SCRPS, SRPS) | 0.9911 | + +#### In-sample outcome comparison + +
+ + +
+ +*Figure: 200 simulations (S = 100, n = 30). Left — `crps()` vs +`measure_rps(revert_sign = TRUE)`; right — `scrps()` vs +`measure_srps()`.* + +#### LOO outcome comparison + +
+ + +
+ +*Figure: 200 LOO simulations (S = 100, n = 30). Left — `loo_crps()` vs +sign-aligned `loo_pred_measure(..., measure = "rps")`; right — +`loo_scrps()` vs `loo_pred_measure(..., measure = "srps")`.* + +**CRPS/RPS takeaway:** Results are highly correlated but not +interchangeable. The PWM estimator is lower-variance and requires only +one draw matrix. For migration, compare trends and rankings rather than +expecting pointwise equality. + +### ELPD / IC + +Deprecated `elpd()` and new `measure_elpd()` / `measure_ic()` compute +the same in-sample pointwise log predictive density and information +criterion from a log-likelihood matrix. The difference is return +structure (`elpd_generic` with both columns vs separate `"measure"` +objects), not the underlying formula. + +| Deprecated | New workflow | Notes | +|---------------------------------|---------------------|-----------------------------------| +| `elpd(ylp)$estimates["elpd", ]` | `measure_elpd(ylp)` | Same `lppd_i` computation | +| `elpd(ylp)$estimates["ic", ]` | `measure_ic(ylp)` | `ic_i = -2 * lppd_i` in both APIs | + +#### Outcome comparison + +
+ + +
+ +*Figure: 200 simulations (S = 100, n = 30). Left — `elpd()` vs +`measure_elpd()`; right — `ic` from `elpd()` vs `measure_ic()`.* + +**ELPD/IC takeaway:** In-sample estimates match between deprecated and +new APIs. Migration is about return type and `*_pred_measure()` workflow +integration, not numerical differences. diff --git a/notes/figures/crps-rps-comparison.png b/notes/figures/crps-rps-comparison.png new file mode 100644 index 00000000..b035d900 Binary files /dev/null and b/notes/figures/crps-rps-comparison.png differ diff --git a/notes/figures/crps-rps-outcomes.png b/notes/figures/crps-rps-outcomes.png new file mode 100644 index 00000000..b1f6d751 Binary files /dev/null and b/notes/figures/crps-rps-outcomes.png differ diff --git a/notes/figures/elpd-ic-outcomes.png b/notes/figures/elpd-ic-outcomes.png new file mode 100644 index 00000000..5d1e2cff Binary files /dev/null and b/notes/figures/elpd-ic-outcomes.png differ diff --git a/notes/figures/loo-crps-rps-outcomes.png b/notes/figures/loo-crps-rps-outcomes.png new file mode 100644 index 00000000..6bff6c65 Binary files /dev/null and b/notes/figures/loo-crps-rps-outcomes.png differ diff --git a/tests/testthat/_snaps/pred_measure_builtin.md b/tests/testthat/_snaps/pred_measure_builtin.md new file mode 100644 index 00000000..67ff3633 --- /dev/null +++ b/tests/testthat/_snaps/pred_measure_builtin.md @@ -0,0 +1,112 @@ +# measure_elpd() works as expected + + + Computed from 400 draws by 53 observations. + + Estimate SE + elpd -706.65 146.52 + +# measure_ic() works as expected + + + Computed from 400 draws by 53 observations. + + Estimate SE + ic 1413.31 293.04 + +# measure_mlpd() works as expected + + + Computed from 400 draws by 53 observations. + + Estimate SE + mlpd -13.33 2.76 + +# measure_mlpd() with pointwise works as expected + + + Computed from 53 pointwise terms. + + Estimate SE + mlpd -13.33 2.76 + +# measure_rps() with ordered categorial data works as expected + + + Computed from 400 draws by 50 observations. + + Estimate SE + rps 0.88 0.09 + +# measure_rps() scaled version with categorical data works as expected + + + Computed from 400 draws by 50 observations. + + Estimate SE + srps -1.28 0.05 + +# measure_rps() with continuous data works as expected + + + Computed from 400 draws by 29 observations. + + Estimate SE + rps 24.61 3.29 + +# measure_brier() works as expected + + + Computed from 400 draws by 50 observations. + + Estimate SE + brier 0.24 0.01 + +# measure_mae() works as expected + + + Computed from 400 draws by 53 observations. + + Estimate SE + mae 17.21 2.65 + +# measure_mse() and measure_rmse() work as expected + + + Computed from 400 draws by 53 observations. + + Estimate SE + mse 661.01 224.17 + +--- + + + Computed from 400 draws by 53 observations. + + Estimate SE + rmse 25.71 4.36 + +# measure_r2() works as expected + + + Computed from 400 draws by 53 observations. + + Estimate SE + r2 0.58 0.17 + +# measure_acc() works as expected + + + Computed from 400 draws by 67 observations. + + Estimate SE + acc 0.97 0.02 + +# measure_bacc() works as expected + + + Computed from 400 draws by 67 observations. + + Estimate SE + bacc 0.95 0.03 + diff --git a/tests/testthat/_snaps/print.md b/tests/testthat/_snaps/print.md new file mode 100644 index 00000000..1842d604 --- /dev/null +++ b/tests/testthat/_snaps/print.md @@ -0,0 +1,279 @@ +# loo_pred_measure print snapshots + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + r2_loo 0.6 0.2 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + r2_loo 0.6 0.2 + rmse_loo 26.3 4.4 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + r2_loo 0.6 0.2 + rmse_loo 26.3 4.4 + mse_loo 691.9 230.5 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + r2_loo 0.6 0.2 + rmse_loo 26.3 4.4 + mse_loo 691.9 230.5 + mae_loo 17.6 2.7 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + r2_loo 0.6 0.2 + rmse_loo 26.3 4.4 + mse_loo 691.9 230.5 + mae_loo 17.6 2.7 + rps_loo 15.2 2.6 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + r2_loo 0.6 0.2 + rmse_loo 26.3 4.4 + mse_loo 691.9 230.5 + mae_loo 17.6 2.7 + rps_loo 15.2 2.6 + srps_loo -4.1 0.5 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + r2_loo 0.6 0.2 + rmse_loo 26.3 4.4 + mse_loo 691.9 230.5 + mae_loo 17.6 2.7 + rps_loo 15.2 2.6 + srps_loo -4.1 0.5 + mlpd_loo -13.7 2.9 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + srps_loo -4.1 0.5 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + srps_loo -4.1 0.5 + r2_loo 0.6 0.2 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + srps_loo -4.1 0.5 + r2_loo 0.6 0.2 + mae_loo 17.6 2.7 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + srps_loo -4.1 0.5 + r2_loo 0.6 0.2 + mae_loo 17.6 2.7 + mse_loo 691.9 230.5 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + srps_loo -4.1 0.5 + r2_loo 0.6 0.2 + mae_loo 17.6 2.7 + mse_loo 691.9 230.5 + mlpd_loo -13.7 2.9 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + srps_loo -4.1 0.5 + r2_loo 0.6 0.2 + mae_loo 17.6 2.7 + mse_loo 691.9 230.5 + mlpd_loo -13.7 2.9 + rmse_loo 26.3 4.4 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +--- + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + srps_loo -4.1 0.5 + r2_loo 0.6 0.2 + mae_loo 17.6 2.7 + mse_loo 691.9 230.5 + mlpd_loo -13.7 2.9 + rmse_loo 26.3 4.4 + rps_loo 15.2 2.6 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +# loo_pred_measure print output with elpd + + + Computed from 400 posterior draws and 53 observations. + Data source: loo + + Estimate SE + elpd_loo -725.0 151.3 + p_loo 18.4 5.6 + r2_loo 0.6 0.2 + ------ + Pareto k diagnostic values: + Count Pct. Min. ESS + (-Inf, 0.62] (good) 52 98.1% 36 + (0.62, 1] (bad) 1 1.9% + (1, Inf) (very bad) 0 0.0% + +# test_pred_measure print output + + + Computed from 400 posterior draws and 20 observations. + Data source: test + + Estimate SE + rmse_test 58.7 6.6 + r2_test 0.0 0.2 + diff --git a/tests/testthat/data-for-tests/test_data_binary.Rds b/tests/testthat/data-for-tests/test_data_binary.Rds new file mode 100644 index 00000000..0f55a5ed Binary files /dev/null and b/tests/testthat/data-for-tests/test_data_binary.Rds differ diff --git a/tests/testthat/data-for-tests/test_data_binomial.Rds b/tests/testthat/data-for-tests/test_data_binomial.Rds new file mode 100644 index 00000000..d90c6c81 Binary files /dev/null and b/tests/testthat/data-for-tests/test_data_binomial.Rds differ diff --git a/tests/testthat/data-for-tests/test_data_generation.R b/tests/testthat/data-for-tests/test_data_generation.R new file mode 100644 index 00000000..aa45670c --- /dev/null +++ b/tests/testthat/data-for-tests/test_data_generation.R @@ -0,0 +1,368 @@ +# Data-generation pipeline for the pred_measure test fixtures. +# +# Slow: fits ~6 brms models with k-fold / LOO postprocessing (~10-20 min). +# Run from package root: +# Rscript tests/testthat/data-for-tests/test_data_generation.R +# +# Outputs: +# tests/testthat/data-for-tests/test_data_*.Rds +library(rstanarm) +# brms features used here require GitHub master (not yet on CRAN) +if (!requireNamespace("remotes", quietly = TRUE)) { + install.packages("remotes") +} +if (!requireNamespace("brms", quietly = TRUE)) { + remotes::install_github("paul-buerkner/brms", ref = "master", upgrade = "never") +} +suppressPackageStartupMessages({ + library(brms) + library(dplyr) + library(loo) +}) + +SEED <- 42 + +postprocess_res <- function(model, fit, chains = 2, draws = 200) { + ypred <- brms::posterior_predict(fit) + mupred <- brms::posterior_epred(fit) + ylp <- log_lik(fit) + log_ratios <- -1 * ylp + r_eff <- relative_eff(exp(-log_ratios), chain_id = rep(1:chains, each = draws)) + psis_object <- psis(log_ratios, r_eff = r_eff, cores = 2) + kfold2 <- brms::kfold(fit, save_fits = FALSE) + if (model %in% c("roaches", "binary", "binomial", "sleep")) { + kfold <- brms::kfold(fit, save_fits = TRUE) + mupred_kfold <- brms::kfold_predict(kfold, method = "fitted")$yrep + ypred_kfold <- brms::kfold_predict(kfold, method = "predict")$yrep + loo <- brms::loo(fit, save_psis = TRUE) + predperf <- insample_pred_measure(y = fit$data$y, mupred = mupred, + measure = "r2", ylp = ylp) + } + + if (model == "roaches") { + list( + y = fit$data$y, + ypred = ypred, + mupred = mupred, + ylp = ylp, + log_weights = psis_object$log_weights, + kfold = kfold2, + loo = loo, + predperf = predperf + ) + } else if (model == "binomial") { + list( + y = fit$data$y, + ypred = ypred, + log_weights = psis_object$log_weights, + ypred_kfold = ypred_kfold + ) + } else if (model == "binary") { + list( + y = fit$data$y, + ypred = ypred, + log_weights = psis_object$log_weights, + ypred_kfold = ypred_kfold + ) + } else if (model == "categorical") { + list( + y = fit$data$y, + mupred = mupred, + log_weights = psis_object$log_weights + ) + } else if (model == "sleep") { + list( + y = fit$data$y, + ypred = ypred, + log_weights = psis_object$log_weights, + ypred_kfold = ypred_kfold, + mupred = mupred, + mupred_kfold = mupred_kfold + ) + } +} + +# ---- fixture shrinking ------------------------------------------------------ +# These fixtures ship in the source tarball, which CRAN limits to 5 MB. Keep +# only a subset of the observations. The draws stay at 400, so the Pareto k +# threshold ps_khat_threshold(400) does not move. +N_KEEP <- c( + roaches = 53, categorical = 67, sleep = 29, + sleep_test = 20 +) + +# Estimate and SE of a summed pointwise column, in loo's convention. +.estimates_from_pointwise <- function(pointwise, cols) { + pw <- pointwise[, cols, drop = FALSE] + cbind(Estimate = colSums(pw), SE = sqrt(nrow(pw) * apply(pw, 2, var))) +} + +# Index of the observations to keep. `strata` allocates proportionally, so +# every level of a categorical outcome survives. +.keep_index <- function(n, n_keep, strata = NULL) { + set.seed(SEED) + if (is.null(strata)) { + return(sort(sample.int(n, n_keep))) + } + strata <- as.factor(strata) + per <- pmax(1L, round(n_keep * as.vector(table(strata)) / n)) + idx <- unlist(Map( + function(lev, k) sample(which(strata == lev), k), + levels(strata), per + )) + sort(as.integer(idx)) +} + +# PSIS smoothing is per observation, so subsetting columns is exact. Only the +# aggregates need recomputing. +.shrink_psis_loo <- function(x, keep) { + x$pointwise <- x$pointwise[keep, , drop = FALSE] + x$diagnostics <- lapply(x$diagnostics, function(d) d[keep]) + + po <- x$psis_object + po$log_weights <- po$log_weights[, keep, drop = FALSE] + po$diagnostics <- lapply(po$diagnostics, function(d) d[keep]) + for (a in c("norm_const_log", "tail_len", "r_eff")) { + attr(po, a) <- attr(po, a)[keep] + } + attr(po, "dims") <- c(attr(po, "dims")[1], length(keep)) + x$psis_object <- po + + est <- .estimates_from_pointwise(x$pointwise, c("elpd_loo", "p_loo", "looic")) + x$estimates <- est + x$elpd_loo <- est["elpd_loo", "Estimate"] + x$p_loo <- est["p_loo", "Estimate"] + x$looic <- est["looic", "Estimate"] + x$se_elpd_loo <- est["elpd_loo", "SE"] + x$se_p_loo <- est["p_loo", "SE"] + x$se_looic <- est["looic", "SE"] + attr(x, "dims") <- c(attr(x, "dims")[1], length(keep)) + x +} + +.shrink_kfold <- function(x, keep) { + x$pointwise <- x$pointwise[keep, , drop = FALSE] + x$estimates <- .estimates_from_pointwise(x$pointwise, colnames(x$pointwise)) + attr(x, "folds") <- attr(x, "folds")[keep] + x +} + +shrink_res <- function(model, res) { + # binary and binomial hold 50 observations and 86 KB in total. Leave them. + if (model %in% c("binary", "binomial")) { + return(res) + } + if (model == "sleep_test") { + keep_test <- .keep_index(length(res$y_test), N_KEEP[["sleep_test"]]) + res$y_test <- res$y_test[keep_test] + for (nm in c("ypred_test", "mupred_test", "ylp_test")) { + res[[nm]] <- res[[nm]][, keep_test, drop = FALSE] + } + return(res) + } + + keep <- if (model == "categorical") { + .keep_index(length(res$y), N_KEEP[["categorical"]], strata = res$y) + } else { + .keep_index(length(res$y), N_KEEP[[model]]) + } + + res$y <- res$y[keep] + for (nm in c("ypred", "mupred", "ylp", "log_weights", + "ypred_kfold", "mupred_kfold")) { + if (!is.null(res[[nm]]) && length(dim(res[[nm]])) == 2L) { + res[[nm]] <- res[[nm]][, keep, drop = FALSE] + } + } + # A categorical mupred is draws x observations x categories. + if (!is.null(res$mupred) && length(dim(res$mupred)) == 3L) { + res$mupred <- res$mupred[, keep, , drop = FALSE] + } + if (!is.null(res$loo)) { + res$loo <- .shrink_psis_loo(res$loo, keep) + } + if (!is.null(res$kfold)) { + res$kfold <- .shrink_kfold(res$kfold, keep) + } + if (!is.null(res$predperf)) { + res$predperf <- insample_pred_measure( + y = res$y, mupred = res$mupred, measure = "r2", ylp = res$ylp + ) + } + res +} + +get_binary_res <- function() { + set.seed(SEED) + df_binary <- data.frame(y = rbinom(50, 1, 0.3)) + + fit_binary <- brms::brm(formula = "y ~ 1", + data = df_binary, + family = bernoulli, + chains = 2, + iter = 400, + seed = SEED, + refresh = 0 + ) + list( + fit = fit_binary, + res = postprocess_res("binary", fit_binary) + ) +} + +get_roaches_res <- function() { + data(roaches, package = "rstanarm") + roaches$sqrt_roach1 <- sqrt(roaches$roach1) + + fit_roaches <- brm( + y ~ sqrt_roach1 + treatment + senior + offset(log(exposure2)), + data = roaches, + family = poisson, + prior = prior(normal(0, 1), class = b), + chains = 2, + iter = 400, + refresh = 0, + seed = SEED + ) + list( + fit = fit_roaches, + res = postprocess_res("roaches", fit_roaches) + ) +} + +get_sleep_test_train_res <- function() { + # specifically for testing test_pred_measure + data("sleepstudy", package = "lme4") + conditions <- brms::make_conditions(sleepstudy, "Subject", incl_vars = FALSE) + sleepstudy <- sleepstudy |> + dplyr::filter(Days >= 2) |> + dplyr::mutate( + Days = Days - 2, + y = Reaction + ) + + test_subjects <- sample(unique(sleepstudy$Subject), size = 5) + train_data <- sleepstudy |> + dplyr::filter(!Subject %in% test_subjects) + test_data <- sleepstudy |> + dplyr::filter(Subject %in% test_subjects) + + prior_lin_base <- brms::prior(normal(200, 100), class = b, coef = "Intercept") + + brms::prior(normal(0, 20), class = b, coef = "Days") + + brms::prior(exponential(0.02), class = sigma) + + fit_sleep_train <- brm( + y ~ 0 + Intercept + Days, + data = train_data, + family = gaussian(), + prior = prior_lin_base, + chains = 2, + iter = 400, + seed = SEED + ) + + list( + fit = fit_sleep_train, + res = list( + y_test = test_data$y, + ypred_test = brms::posterior_predict(fit_sleep_train, newdata = test_data), + mupred_test = brms::posterior_epred(fit_sleep_train, newdata = test_data), + ylp_test = brms::log_lik(fit_sleep_train, newdata = test_data) + ) + ) +} + +get_sleep_res <- function() { + data("sleepstudy", package = "lme4") + conditions <- brms::make_conditions(sleepstudy, "Subject", incl_vars = FALSE) + sleepstudy <- sleepstudy |> + dplyr::filter(Days >= 2) |> + dplyr::mutate(Days = Days - 2, y = Reaction) + + prior_lin_base <- brms::prior(normal(200, 100), class = b, coef = "Intercept") + + brms::prior(normal(0, 20), class = b, coef = "Days") + + brms::prior(exponential(0.02), class = sigma) + + fit_sleepstudy <- brms::brm( + y ~ 0 + Intercept + Days, + data = sleepstudy, + family = gaussian(), + prior = prior_lin_base, + chains = 2, + iter = 400, + refresh = 0, + seed = SEED + ) + list( + fit = fit_sleepstudy, + res = postprocess_res("sleep", fit_sleepstudy) + ) +} + +get_penguins_res <- function() { + data("penguins", package = "palmerpenguins") + penguins <- subset(penguins, complete.cases(penguins)) + penguins$y <- penguins$species + + fit <- brm( + y ~ bill_length_mm + bill_depth_mm, + data = penguins, + family = categorical(), + chains = 2, + iter = 400, + cores = 2, + seed = SEED + ) + list( + fit = fit, + res = postprocess_res("categorical", fit) + ) +} + +get_binomial_res <- function() { + set.seed(SEED) + df <- data.frame( + y = rbinom(50, 10, 0.3), + n = 10 + ) + + fit <- brms::brm(formula = "y | trials(n) ~ 1", + data = df, + family = binomial, + chains = 2, + iter = 400, + seed = SEED, + refresh = 0 + ) + list( + fit = fit, + res = postprocess_res("binomial", fit) + ) +} + +generate_test_data <- function() { + message("Generating test fixtures. This may take 10-20 minutes.") + t0 <- proc.time() + + full_roaches <- get_roaches_res() + full_binary <- get_binary_res() + full_penguins <- get_penguins_res() + full_binomial <- get_binomial_res() + full_sleep <- get_sleep_res() + full_sleep_test <- get_sleep_test_train_res() + + test_path <- "tests/testthat/data-for-tests/" + saveRDS(shrink_res("roaches", full_roaches$res), paste0(test_path, "test_data_roaches.Rds")) + saveRDS(shrink_res("binary", full_binary$res), paste0(test_path, "test_data_binary.Rds")) + saveRDS(shrink_res("categorical", full_penguins$res), paste0(test_path, "test_data_penguins.Rds")) + saveRDS(shrink_res("binomial", full_binomial$res), paste0(test_path, "test_data_binomial.Rds")) + saveRDS(shrink_res("sleep", full_sleep$res), paste0(test_path, "test_data_sleep.Rds")) + saveRDS(shrink_res("sleep_test", full_sleep_test$res), paste0(test_path, "test_data_sleep_cv.Rds")) + message("Saved test fixtures to ", test_path) + + elapsed_min <- round((proc.time() - t0)[3] / 60, 1) + message("Data generation finished in ", elapsed_min, " minutes.") + invisible(NULL) +} + +generate_test_data() diff --git a/tests/testthat/data-for-tests/test_data_penguins.Rds b/tests/testthat/data-for-tests/test_data_penguins.Rds new file mode 100644 index 00000000..7e8d7e63 Binary files /dev/null and b/tests/testthat/data-for-tests/test_data_penguins.Rds differ diff --git a/tests/testthat/data-for-tests/test_data_roaches.Rds b/tests/testthat/data-for-tests/test_data_roaches.Rds new file mode 100644 index 00000000..e4da781e Binary files /dev/null and b/tests/testthat/data-for-tests/test_data_roaches.Rds differ diff --git a/tests/testthat/data-for-tests/test_data_sleep.Rds b/tests/testthat/data-for-tests/test_data_sleep.Rds new file mode 100644 index 00000000..a2a9324f Binary files /dev/null and b/tests/testthat/data-for-tests/test_data_sleep.Rds differ diff --git a/tests/testthat/data-for-tests/test_data_sleep_cv.Rds b/tests/testthat/data-for-tests/test_data_sleep_cv.Rds new file mode 100644 index 00000000..65920506 Binary files /dev/null and b/tests/testthat/data-for-tests/test_data_sleep_cv.Rds differ diff --git a/tests/testthat/test_crps.R b/tests/testthat/test_crps.R index ce523476..48c37570 100644 --- a/tests/testthat/test_crps.R +++ b/tests/testthat/test_crps.R @@ -25,10 +25,22 @@ test_that("crps computation is correct", { }) test_that("crps matches snapshots", { - expect_snapshot_value(with_seed(1, crps(x1, x2, y)), style = "serialize") - expect_snapshot_value(with_seed(1, scrps(x1, x2, y)), style = "serialize") - expect_snapshot_value(with_seed(1, loo_crps(x1, x2, y, ll)), style = "serialize") - expect_snapshot_value(with_seed(1, loo_scrps(x1, x2, y, ll)), style = "serialize") + expect_snapshot_value( + with_seed(1, suppressWarnings(crps(x1, x2, y))), + style = "serialize" + ) + expect_snapshot_value( + with_seed(1, suppressWarnings(scrps(x1, x2, y))), + style = "serialize" + ) + expect_snapshot_value( + with_seed(1, suppressWarnings(loo_crps(x1, x2, y, ll))), + style = "serialize" + ) + expect_snapshot_value( + with_seed(1, suppressWarnings(loo_scrps(x1, x2, y, ll))), + style = "serialize" + ) }) test_that("input validation throws correct errors", { @@ -53,6 +65,148 @@ test_that("input validation throws correct errors", { }) test_that("methods for single data point don't error", { - expect_silent(crps(x1[,1], x2[,1], y[1])) - expect_silent(scrps(x1[,1], x2[,1], y[1])) + expect_silent(suppressWarnings(crps(x1[, 1], x2[, 1], y[1]))) + expect_silent(suppressWarnings(scrps(x1[, 1], x2[, 1], y[1]))) +}) + +# ------------------------------------------------------------------------- +# Comparison with measure_rps() / measure_srps() (PWM vs permutation EXX) +# See notes/developer-notes.Rmd ("CRPS / RPS numerical comparison") for details. +# ------------------------------------------------------------------------- + +.exx_pwm <- function(ypred) { + n_draws <- nrow(ypred) + ypred_sorted <- apply(ypred, 2, sort) + colMeans(ypred_sorted * ((seq_len(n_draws) * (4 / (n_draws - 1))) - 2)) +} + +.exy_crps <- function(ypred, y) { + colMeans(abs(sweep(ypred, 2, y))) +} + +.crps_draws <- function(seed = 123456789L, n = 10L, S = 100L) { + set.seed(seed) + y <- rnorm(n) + x1 <- matrix(rnorm(n * S), nrow = S) + x2 <- matrix(rnorm(n * S), nrow = S) + list(y = y, x1 = x1, x2 = x2) +} + +test_that("measure_rps(higher_is_better = FALSE) matches deprecated crps() sign convention", { + d <- .crps_draws() + old <- suppressWarnings(crps(d$x1, d$x2, d$y)) + new_rev <- measure_rps(d$y, d$x1, higher_is_better = TRUE) + + expect_equal( + as.vector(new_rev$pointwise), + -as.vector(measure_rps(d$y, d$x1)$pointwise) + ) + expect_gt(cor(old$pointwise, as.vector(new_rev$pointwise)), 0.98) + expect_false(isTRUE(all.equal( + old$pointwise, + as.vector(new_rev$pointwise), + tolerance = 1e-6 + ))) +}) + +test_that("crps() and measure_rps() share EXy; differences come from EXX estimator", { + d <- .crps_draws() + EXy <- .exy_crps(d$x1, d$y) + EXX_perm <- suppressWarnings({ + set.seed(1) + colMeans(abs(d$x1 - d$x2[sample(nrow(d$x1)), , drop = FALSE])) + }) + EXX_pwm <- .exx_pwm(d$x1) + + expect_equal(EXy, colMeans(abs(sweep(d$x1, 2, d$y)))) + + pw_perm <- 0.5 * EXX_perm - EXy + pw_pwm <- 0.5 * EXX_pwm - EXy + expect_false(isTRUE(all.equal(EXX_perm, EXX_pwm, tolerance = 1e-6))) + expect_gt(cor(pw_perm, pw_pwm), 0.98) + expect_equal( + max(abs(pw_perm - pw_pwm)), + max(abs((0.5 * EXX_perm - EXy) - (0.5 * EXX_pwm - EXy))) + ) +}) + +test_that("scrps() and measure_srps() share sign convention but differ numerically", { + d <- .crps_draws() + old <- suppressWarnings(scrps(d$x1, d$x2, d$y)) + new <- measure_srps(d$y, d$x1) + + expect_gt(cor(old$pointwise, as.vector(new$pointwise)), 0.98) + expect_false(isTRUE(all.equal( + old$pointwise, + as.vector(new$pointwise), + tolerance = 1e-6 + ))) +}) + +test_that("PWM and permutation EXX estimates converge with more draws", { + set.seed(42) + n <- 20L + results <- vapply( + c(100L, 1000L, 5000L), + function(S) { + d <- .crps_draws(seed = 99L, n = n, S = S) + EXX_perm <- colMeans(abs(d$x1 - d$x2[sample(S), , drop = FALSE])) + EXX_pwm <- .exx_pwm(d$x1) + mean(abs(EXX_perm - EXX_pwm) / EXX_pwm) + }, + numeric(1) + ) + expect_lt(results[3], results[1]) +}) + +test_that("loo_crps() and loo_pred_measure(..., measure = 'rps') differ like in-sample APIs", { + set.seed(1) + d <- .crps_draws(seed = 1L, n = 10L, S = 100L) + ll <- matrix(rnorm(10 * 100) * 0.1 - 1, nrow = 100) + + old <- suppressWarnings(loo_crps(d$x1, d$x2, d$y, ll)) + psis_obj <- psis(-ll, r_eff = 1) + new <- loo_pred_measure( + y = d$y, + ypred = d$x1, + ylp = ll, + measure = "rps", + psis_object = psis_obj + ) + + expect_gt( + cor(old$pointwise, -new$pointwise[, "rps_loo"]), + 0.98 + ) + expect_false(isTRUE(all.equal( + old$pointwise, + -new$pointwise[, "rps_loo"], + tolerance = 1e-6 + ))) +}) + +test_that("loo_scrps() and loo_pred_measure(..., measure = 'srps') differ like in-sample APIs", { + set.seed(1) + d <- .crps_draws(seed = 1L, n = 10L, S = 100L) + ll <- matrix(rnorm(10 * 100) * 0.1 - 1, nrow = 100) + + old <- suppressWarnings(loo_scrps(d$x1, d$x2, d$y, ll)) + psis_obj <- psis(-ll, r_eff = 1) + new <- loo_pred_measure( + y = d$y, + ypred = d$x1, + ylp = ll, + measure = "srps", + psis_object = psis_obj + ) + + expect_gt( + cor(old$pointwise, new$pointwise[, "srps_loo"]), + 0.98 + ) + expect_false(isTRUE(all.equal( + old$pointwise, + new$pointwise[, "srps_loo"], + tolerance = 1e-6 + ))) }) diff --git a/tests/testthat/test_deprecated_measures.R b/tests/testthat/test_deprecated_measures.R new file mode 100644 index 00000000..92c081a0 --- /dev/null +++ b/tests/testthat/test_deprecated_measures.R @@ -0,0 +1,72 @@ +expect_deprecated <- function(object) { + testthat::expect_warning(object, "deprecated", ignore.case = TRUE) +} + +test_that("elpd() is deprecated", { + ll <- example_loglik_matrix() + expect_deprecated(elpd(ll)) +}) + +test_that("elpd() still returns elpd_generic", { + ll <- example_loglik_matrix() + out <- suppressWarnings(elpd(ll)) + expect_s3_class(out, "elpd_generic") +}) + +test_that("elpd(array) warns only once", { + ll <- example_loglik_array() + msgs <- character() + withCallingHandlers( + elpd(ll), + warning = function(w) { + msgs <<- c(msgs, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ) + expect_length(msgs, 1L) + expect_match(msgs[[1]], "deprecated", ignore.case = TRUE) +}) + +test_that("crps() is deprecated", { + set.seed(1) + y <- rnorm(5) + x1 <- matrix(rnorm(50), nrow = 10) + x2 <- matrix(rnorm(50), nrow = 10) + expect_deprecated(crps(x1, x2, y)) + expect_deprecated(scrps(x1, x2, y)) +}) + +test_that("loo_crps() is deprecated", { + set.seed(1) + y <- rnorm(5) + x1 <- matrix(rnorm(50), nrow = 10) + x2 <- matrix(rnorm(50), nrow = 10) + ll <- matrix(rnorm(50) * 0.1 - 1, nrow = 10) + expect_warning( + tryCatch( + loo_crps(x1, x2, y, ll), + error = function(e) invisible(NULL) + ), + "deprecated", + ignore.case = TRUE + ) + expect_warning( + tryCatch( + loo_scrps(x1, x2, y, ll), + error = function(e) invisible(NULL) + ), + "deprecated", + ignore.case = TRUE + ) +}) + +test_that("loo_predictive_metric() is deprecated", { + LL <- example_loglik_matrix() + chain_id <- rep(1:2, each = nrow(LL) / 2) + r_eff <- relative_eff(exp(LL), chain_id) + x <- matrix(rnorm(length(LL)), nrow = nrow(LL), ncol = ncol(LL)) + y <- rnorm(ncol(LL)) + expect_deprecated( + loo_predictive_metric(x, y, LL, metric = "mae", r_eff = r_eff) + ) +}) diff --git a/tests/testthat/test_loo_predictive_metric.R b/tests/testthat/test_loo_predictive_metric.R index d4f44d59..b17c99d1 100644 --- a/tests/testthat/test_loo_predictive_metric.R +++ b/tests/testthat/test_loo_predictive_metric.R @@ -11,6 +11,7 @@ x_prob <- 1 / (1 + exp(-x)) y <- rnorm(ncol(LL)) y_binary <- rbinom(ncol(LL), 1, 0.5) +suppressWarnings({ mae_mean <- loo_predictive_metric(x, y, LL, metric = 'mae', r_eff = r_eff) mae_quant <- loo_predictive_metric(x, y, LL, metric = 'mae', r_eff = r_eff, type = 'quantile', probs = 0.9) @@ -30,23 +31,24 @@ acc_quant <- loo_predictive_metric(x_prob, y_binary, LL, metric = 'acc', r_eff = bacc_mean <- loo_predictive_metric(x_prob, y_binary, LL, metric = 'balanced_acc', r_eff = r_eff) bacc_quant <- loo_predictive_metric(x_prob, y_binary, LL, metric = 'balanced_acc', r_eff = r_eff, type = 'quantile', probs = 0.9) +}) test_that('loo_predictive_metric stops with incorrect inputs', { - expect_error(loo_predictive_metric(as.character(x), y, LL, r_eff = r_eff), + expect_error(suppressWarnings(loo_predictive_metric(as.character(x), y, LL, r_eff = r_eff)), 'no applicable method', fixed = TRUE) - expect_error(loo_predictive_metric(x, as.character(y), LL, r_eff = r_eff), + expect_error(suppressWarnings(loo_predictive_metric(x, as.character(y), LL, r_eff = r_eff)), 'is.numeric(y) is not TRUE', fixed = TRUE) x_invalid <- matrix(rnorm(9), nrow = 3) - expect_error(loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff), + expect_error(suppressWarnings(loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff)), 'identical(ncol(x), length(y)) is not TRUE', fixed = TRUE) x_invalid <- matrix(rnorm(64), nrow = 2) - expect_error(loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff), + expect_error(suppressWarnings(loo_predictive_metric(x_invalid, y, LL, r_eff = r_eff)), 'identical(dim(x), dim(log_lik)) is not TRUE', fixed = TRUE) }) diff --git a/tests/testthat/test_pred_measure.R b/tests/testthat/test_pred_measure.R new file mode 100644 index 00000000..e3d33d41 --- /dev/null +++ b/tests/testthat/test_pred_measure.R @@ -0,0 +1,548 @@ +# load data ----------------------------- +res <- readRDS("data-for-tests/test_data_roaches.Rds") +res_sleep_test <- readRDS("data-for-tests/test_data_sleep_cv.Rds") +n_test <- length(res_sleep_test$y_test) + +# unit tests ---------------------- +test_that("group_ids errors as not yet implemented", { + expect_error( + insample_pred_measure( + ylp = res$ylp, measure = "elpd", group_ids = rep(1:2, 131) + ), + "not yet implemented" + ) +}) + +## .compute_measure() -------------------- + +.builtin_entry <- function(name) { + list(name = name, type = "builtin", key = name) +} + +test_that(".compute_measure() with elpd works as expected", { + lppd_i <- .elpd_pointwise( + source = "insample", ylp = res$ylp, ylp_test = NULL, + log_weights = NULL, loo = NULL, kfold = NULL, predperf = NULL + ) + measure_res <- .compute_measure( + y = NULL, + ypred = NULL, + mupred = NULL, + ylp = res$ylp, + measure_entry = .builtin_entry("elpd"), + log_weights = NULL, + lppd_i = lppd_i + ) + + expect_equal(names(measure_res), c("estimates", "pointwise")) + expect_equal(measure_res$estimates, measure_elpd(res$ylp)$estimates) +}) + +test_that(".compute_measure() with rps works as expected", { + measure_res <- .compute_measure( + y = res$y, + ypred = res$ypred, + mupred = NULL, + ylp = res$ylp, + measure_entry = .builtin_entry("rps"), + log_weights = NULL + ) + + expect_equal(names(measure_res), c("estimates", "pointwise")) + expect_equal(colnames(measure_res$estimates), c("Estimate", "SE")) +}) + +test_that(".compute_measure() fails if insufficient input is provided", { + expect_error( + .compute_measure( + y = res$y, + ypred = res$ypred, + mupred = NULL, + ylp = res$ylp, + measure_entry = .builtin_entry("r2"), + log_weights = NULL + ), + regexp = "`mupred` must be a numeric matrix." + ) +}) + +## .elpd_pointwise() ------------------------- + +.elpd_pw <- function(source, ylp = NULL, ylp_test = NULL, log_weights = NULL, + loo = NULL, kfold = NULL, predperf = NULL) { + .elpd_pointwise(source, ylp, ylp_test, log_weights, loo, kfold, predperf) +} + +test_that(".elpd_pointwise() reuses the elpd column of predperf", { + expect_equal( + .elpd_pw("insample", predperf = res$predperf), + res$predperf$pointwise[, "elpd"] + ) +}) + +test_that(".elpd_pointwise() takes elpd from loo and kfold objects", { + expect_equal( + .elpd_pw("loo", loo = res$loo), res$loo$pointwise[, "elpd_loo"] + ) + expect_equal( + .elpd_pw("kfold", kfold = res$kfold), res$kfold$pointwise[, "elpd_kfold"] + ) +}) + +test_that(".elpd_pointwise() computes elpd from ylp and ylp_test", { + expect_equal( + .elpd_pw("loo", ylp = res$ylp, + log_weights = res$loo$psis_object$log_weights), + res$loo$pointwise[, "elpd_loo"], + ignore_attr = TRUE + ) + expect_length( + .elpd_pw("test", ylp_test = res_sleep_test$ylp_test), n_test + ) +}) + +test_that(".elpd_pointwise() errors if the input is missing", { + expect_error(.elpd_pw("insample"), regexp = "`ylp` is required") + expect_error(.elpd_pw("test"), regexp = "`ylp_test` is required") + expect_error(.elpd_pw("kfold"), regexp = "not stored in") +}) + +## .get_psis_object() ------------------------- + +test_that(".get_psis_object() accepts loo and psis_object together", { + expect_identical( + .get_psis_object( + ylp = res$ylp, + loo = res$loo, + predperf = NULL, + psis_object = res$loo$psis_object + ), + res$loo$psis_object + ) +}) + +## .merge_matrix() --------------------------- + +test_that(".merge_matrix() works as expected", { + mat <- matrix(c(1, 2, 3, 4), ncol = 2, nrow = 2) + val <- c(5, 6) + expected_name <- "test" + + res <- .merge_matrix( + source = "insample", mat = mat, name = expected_name, + values = val, margin = 1 + ) + + expect_equal(rownames(res)[[3]], "test") + expect_equal(dim(res), c(3, 2)) + expect_equal(colnames(res), c("Estimate", "SE")) + + res <- .merge_matrix( + source = "insample", mat = mat, name = expected_name, + values = val, margin = 2 + ) + + expect_equal(dim(res), c(2, 3)) + expect_equal(colnames(res)[3], "test") +}) + +test_that(".merge_matrix() with mat = NULL works as expected", { + res <- .merge_matrix( + source = "insample", mat = NULL, name = "test", + values = c(1, 2), margin = 1 + ) + + expect_equal(rownames(res), "test") + expect_equal(colnames(res), c("Estimate", "SE")) + expect_equal(dim(res), c(1, 2)) +}) + +test_that(".merge_matrix() with loo showes correct names", { + res <- .merge_matrix( + source = "loo", mat = NULL, name = "test", + values = c(1, 2), margin = 1 + ) + + expect_equal(rownames(res), "test_loo") + expect_equal(colnames(res), c("Estimate", "SE")) + expect_equal(dim(res), c(1, 2)) +}) + +test_that(".merge_matrix() with kfold showes correct names", { + res <- .merge_matrix( + source = "kfold", mat = NULL, name = "test", + values = c(1, 2), margin = 1 + ) + + expect_equal(rownames(res), "test_kfold") + expect_equal(colnames(res), c("Estimate", "SE")) + expect_equal(dim(res), c(1, 2)) +}) + +test_that("duplicate measure on update warns once and keeps the results", { + predperf <- insample_pred_measure(ylp = res$ylp) + warnings <- character() + withCallingHandlers( + updated <- pred_measure( + ylp = res$ylp, predperf = predperf, measure = "elpd" + ), + warning = function(w) { + warnings <<- c(warnings, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ) + + expect_length(warnings, 1L) + expect_match(warnings[[1]], "already present in") + expect_equal(rownames(updated$estimates), "elpd") + expect_equal(colnames(updated$pointwise), "elpd") +}) + +# integration tests ------------------------------ +## loo_pred_measure() / pred_measure() / kfold_pred_measure() --------- + +test_that("control scaled = TRUE stores the result as srps, not rps", { + out <- insample_pred_measure( + y = res$y, + ypred = res$ypred, + ylp = res$ylp, + measure = "rps", + control = list(rps = list(scaled = TRUE)) + ) + + expect_true("srps" %in% rownames(out$estimates)) + expect_false("rps" %in% rownames(out$estimates)) + expect_true("srps" %in% colnames(out$pointwise)) +}) + +test_that("pred_measure() updates loo results as expected", { + predperf_loo <- loo_pred_measure( + loo = res$loo, + y = res$y, + mupred = res$mupred, + ylp = res$ylp, + measure = c("elpd", "r2", "mse"), + save_psis = TRUE + ) + + updated_predperf <- pred_measure( + y = res$y, + mupred = res$mupred, + predperf = predperf_loo, + measure = "mae" + ) + + expect_equal( + rownames(updated_predperf$estimates), + c("elpd_loo", "p_loo", "r2_loo", "mse_loo", "mae_loo") + ) + expect_equal(dim(updated_predperf$estimates), c(5, 2)) +}) + +test_that("pred_measure() keeps dims when the update has no matrix input", { + predperf_loo <- loo_pred_measure( + loo = res$loo, y = res$y, mupred = res$mupred, ylp = res$ylp, + measure = c("elpd", "r2"), save_psis = TRUE + ) + updated <- pred_measure(predperf = predperf_loo, measure = "mlpd") + + expect_false(is.null(attr(updated, "dims"))) + expect_equal(attr(updated, "dims"), attr(predperf_loo, "dims")) +}) + +test_that("pred_measure() reuses stored log_weights when save_psis = FALSE", { + predperf_loo <- loo_pred_measure( + loo = res$loo, y = res$y, mupred = res$mupred, ylp = res$ylp, + measure = "r2" + ) + expect_null(predperf_loo$psis_object) + expect_false(is.null(predperf_loo$log_weights)) + + updated <- pred_measure( + y = res$y, mupred = res$mupred, predperf = predperf_loo, measure = "mae" + ) + expect_true("mae_loo" %in% rownames(updated$estimates)) +}) + +test_that("pred_measure() provides warning for duplicate measure", { + predperf_loo <- loo_pred_measure( + loo = res$loo, + y = res$y, + mupred = res$mupred, + ylp = res$ylp, + measure = "r2", + save_psis = TRUE + ) + + expect_warning( + pred_measure( + y = res$y, + mupred = res$mupred, + predperf = predperf_loo, + measure = "r2" + ), + regexp = "already present in .* and will be skipped" + ) + + expect_error( + loo_pred_measure( + y = res$y, + mupred = res$mupred, + ylp = res$ylp, + loo = res$loo, + measure = c("mse", "r2", "r2") + ), + regexp = "Duplicate measure" + ) +}) + +test_that("loo_pred_measure() computes expected measures", { + predperf1 <- loo_pred_measure( + loo = res$loo, + y = res$y, + mupred = res$mupred, + ylp = res$ylp, + measure = c("r2", "mse") + ) + + expect_equal( + rownames(predperf1$estimates), + c("r2_loo", "mse_loo") + ) + expect_equal(dim(predperf1$estimates), c(2, 2)) + expect_true(is.loo(predperf1)) +}) + +test_that("loo_pred_measure() has class 'loo' for all input patterns", { + predperf_loo <- loo_pred_measure( + loo = res$loo, + y = res$y, + ylp = res$ylp + ) + predperf_ylp_psis <- suppressMessages(loo_pred_measure( + ylp = res$ylp, + psis_object = res$loo$psis_object + )) + predperf_ylp <- suppressMessages(loo_pred_measure(ylp = res$ylp)) + + expect_true(is.loo(predperf_loo)) + expect_true(is.loo(predperf_ylp_psis)) + expect_true(is.loo(predperf_ylp)) + expect_true(is.psis_loo(predperf_loo)) + expect_false(is.psis_loo(predperf_ylp_psis)) + expect_false(is.psis_loo(predperf_ylp)) +}) + +test_that("do_pred_measure() warns if control args are invalid", { + expect_warning( + kfold_pred_measure( + y = res$y, + ypred = res$ypred, + mupred = res$mupred, + ylp = res$ylp, + measure = c("rps", "srps"), + kfold = res$kfold, + control = list( + rps = list(size = 10) + ) + ), + regexp = "Ignoring `size` as it is not a valid argument" + ) +}) + +test_that("kfold_pred_measure() requires kfold argument", { + expect_error( + kfold_pred_measure( + y = res$y, + mupred = res$mupred, + measure = "rmse" + ), + regexp = "`kfold` is required" + ) +}) + +test_that("kfold_pred_measure() works with rps as expected", { + kfold_res <- kfold_pred_measure( + y = res$y, + ypred = res$ypred, + mupred = res$mupred, + ylp = res$ylp, + measure = c("mlpd", "ic", "rps", "srps"), + kfold = res$kfold + ) + + expect_equal( + rownames(kfold_res$estimates), + c("mlpd_kfold", "ic_kfold", "rps_kfold", "srps_kfold") + ) +}) + +## test_pred_measure() ------------------------------------------------- + +test_that("test_pred_measure() computes holdout measures as expected", { + test_res <- test_pred_measure( + y = res_sleep_test$y_test, + ypred = res_sleep_test$ypred_test, + mupred = res_sleep_test$mupred_test, + ylp_test = res_sleep_test$ylp_test, + measure = c("elpd", "rmse", "r2") + ) + + expect_s3_class(test_res, "test_pred_measure") + expect_s3_class(test_res, "pred_measure") + expect_equal(attr(test_res, "source"), "test") + expect_equal( + rownames(test_res$estimates), + c("elpd_test", "rmse_test", "r2_test") + ) + expect_equal(dim(test_res$estimates), c(3, 2)) + expect_equal(attr(test_res, "dims"), c(400L, n_test)) + expect_equal(dim(test_res$pointwise), c(n_test, 3L)) +}) + +test_that("test_pred_measure() works with ylp_test only for base summary", { + test_res <- test_pred_measure( + y = res_sleep_test$y_test, + mupred = res_sleep_test$mupred_test, + ylp_test = res_sleep_test$ylp_test, + measure = c("elpd", "mae") + ) + + expect_equal(rownames(test_res$estimates), c("elpd_test", "mae_test")) + expect_equal(nrow(test_res$pointwise), length(res_sleep_test$y_test)) +}) + +test_that("pred_measure() updates test_pred_measure results as expected", { + test_res <- test_pred_measure( + y = res_sleep_test$y_test, + ypred = res_sleep_test$ypred_test, + mupred = res_sleep_test$mupred_test, + ylp_test = res_sleep_test$ylp_test, + measure = "rmse" + ) + + updated <- pred_measure( + y = res_sleep_test$y_test, + mupred = res_sleep_test$mupred_test, + predperf = test_res, + measure = "mae" + ) + + expect_equal(rownames(updated$estimates), c("rmse_test", "mae_test")) + expect_equal(attr(updated, "source"), "test") + expect_equal(dim(updated$pointwise), c(n_test, 2L)) +}) + +# pred_measure() with custom function ------------------------------ +test_that("insample_pred_measure() accepts a custom measure function", { + set.seed(42) + S <- 4L + n <- 8L + y <- rnorm(n) + mupred <- matrix(rnorm(S * n), nrow = S, ncol = n) + ylp <- matrix(rnorm(S * n), nrow = S, ncol = n) + + custom_rmse <- function(y, mupred, log_weights = NULL) { + measure_rmse(y, mupred, log_weights = log_weights) + } + attr(custom_rmse, "measure_name") <- "custom_rmse" + + res <- insample_pred_measure( + y = y, + mupred = mupred, + ylp = ylp, + measure = custom_rmse + ) + + expect_true("custom_rmse" %in% rownames(res$estimates)) + expect_true("custom_rmse" %in% colnames(res$pointwise)) +}) + +test_that("insample_pred_measure() accepts mixed built-in and custom measures", { + set.seed(1) + S <- 4L + n <- 8L + y <- rnorm(n) + mupred <- matrix(rnorm(S * n), nrow = S, ncol = n) + ylp <- matrix(rnorm(S * n), nrow = S, ncol = n) + + custom_rmse <- function(y, mupred, log_weights = NULL) { + measure_rmse(y, mupred, log_weights = log_weights) + } + attr(custom_rmse, "measure_name") <- "custom_rmse" + + res <- insample_pred_measure( + y = y, + mupred = mupred, + ylp = ylp, + measure = list("r2", custom_rmse = custom_rmse) + ) + + expect_true(all(c("r2", "custom_rmse") %in% rownames(res$estimates))) +}) + +## elpd on demand ------------------------------------------------------- + +test_that("measure = NULL reports elpd and p for every source", { + expect_equal(rownames(insample_pred_measure(ylp = res$ylp)$estimates), "elpd") + expect_equal( + rownames(loo_pred_measure(loo = res$loo)$estimates), c("elpd_loo", "p_loo") + ) + expect_equal( + rownames(kfold_pred_measure(kfold = res$kfold)$estimates), + c("elpd_kfold", "p_kfold") + ) + expect_equal( + rownames(test_pred_measure(ylp_test = res_sleep_test$ylp_test)$estimates), + "elpd_test" + ) +}) + +test_that("elpd and p from loo and kfold objects equal the object estimates", { + expect_equal( + loo_pred_measure(loo = res$loo)$estimates, + res$loo$estimates[c("elpd_loo", "p_loo"), ], + ignore_attr = TRUE + ) + expect_equal( + kfold_pred_measure(kfold = res$kfold)$estimates, + res$kfold$estimates[c("elpd_kfold", "p_kfold"), ], + ignore_attr = TRUE + ) +}) + +test_that("insample_pred_measure() does not need ylp without elpd", { + x <- insample_pred_measure(y = res$y, mupred = res$mupred, measure = "rmse") + expect_equal(rownames(x$estimates), "rmse") +}) + +test_that("loo_pred_measure() keeps diagnostics without elpd", { + x <- loo_pred_measure( + loo = res$loo, y = res$y, mupred = res$mupred, measure = "rmse" + ) + expect_equal(x$diagnostics$pareto_k, res$loo$diagnostics$pareto_k) +}) + +test_that("pred_measure() recomputes elpd for loo but aborts for kfold", { + loo_res <- loo_pred_measure( + loo = res$loo, y = res$y, mupred = res$mupred, measure = "r2", + save_psis = TRUE + ) + updated <- suppressMessages( + pred_measure(ylp = res$ylp, predperf = loo_res, measure = "ic") + ) + expect_equal(rownames(updated$estimates), c("r2_loo", "ic_loo")) + expect_equal( + updated$estimates["ic_loo", "Estimate"], + -2 * res$loo$estimates["elpd_loo", "Estimate"], + ignore_attr = TRUE + ) + + kfold_res <- kfold_pred_measure( + y = res$y, mupred = res$mupred, kfold = res$kfold, measure = "r2" + ) + expect_error( + pred_measure(ylp = res$ylp, predperf = kfold_res, measure = "ic"), + regexp = "not stored in" + ) +}) diff --git a/tests/testthat/test_pred_measure_builtin.R b/tests/testthat/test_pred_measure_builtin.R new file mode 100644 index 00000000..20584bec --- /dev/null +++ b/tests/testthat/test_pred_measure_builtin.R @@ -0,0 +1,599 @@ +# load test data -------------------------------------- +path <- ""#"tests/testthat/" +res_roaches <- readRDS(paste0(path, "data-for-tests/test_data_roaches.Rds")) +res_sleep <- readRDS(paste0(path, "data-for-tests/test_data_sleep.Rds")) +res_binom <- readRDS(paste0(path, "data-for-tests/test_data_binomial.Rds")) +res_binary <- readRDS(paste0(path, "data-for-tests/test_data_binary.Rds")) +res_cat <- readRDS(paste0(path, "data-for-tests/test_data_penguins.Rds")) + +# ptw_log_pred_density ------------------------ +testthat::test_that("ptw_log_pred_density() works as expected", { + res <- ptw_log_pred_density(ylp = res_roaches$ylp, psis_log_weights = NULL) + + expect_equal(length(res), dim(res_roaches$ylp)[2]) + expect_equal(res, matrixStats::colLogSumExps(res_roaches$ylp) - log(dim(res_roaches$ylp)[1])) +}) + +testthat::test_that("ptw_log_pred_density() with psis_log_weights works as expected", { + norm_log_weights <- .normalize_log_weights(res_roaches$log_weights) + res <- ptw_log_pred_density( + ylp = res_roaches$ylp, + psis_log_weights = norm_log_weights + ) + + expect_equal(length(res), dim(res_roaches$ylp)[2]) + expect_equal(res, matrixStats::colLogSumExps(res_roaches$ylp + norm_log_weights) + ) +}) + +testthat::test_that("ptw_log_pred_density() returns error when weights are not normalized", { + expect_error( + ptw_log_pred_density( + ylp = res_roaches$ylp, + psis_log_weights = res_roaches$log_weights + ), + regexp = "Range of current column sums" + ) +}) + +# measure_elpd() ----------------------------------- + +testthat::test_that("measure_elpd() works as expected", { + res <- measure_elpd(ylp = res_roaches$ylp, log_weights = NULL) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates[1]), 1) + expect_equal(length(res$estimates[2]), 1) + expect_equal(length(res$pointwise), dim(res_roaches$ylp)[2]) + + expect_snapshot_output( + measure_elpd(ylp = res_roaches$ylp, log_weights = NULL) + ) +}) + +testthat::test_that("measure_elpd() with unnormalized log-weights works as expected", { + log_weights <- res_roaches$log_weights + res <- measure_elpd(ylp = res_roaches$ylp, log_weights = log_weights) + + expect_false(all(.normalize_log_weights(log_weights) == log_weights)) + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates[1]), 1) + expect_equal(length(res$estimates[2]), 1) + expect_equal(length(res$pointwise), dim(res_roaches$ylp)[2]) +}) + +testthat::test_that("measure_elpd() with normalized log-weights works as expected", { + log_weights <- .normalize_log_weights(res_roaches$log_weights) + res <- measure_elpd(ylp = res_roaches$ylp, log_weights = log_weights) + + expect_equal(.normalize_log_weights(log_weights), log_weights) + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates[1]), 1) + expect_equal(length(res$estimates[2]), 1) + expect_equal(length(res$pointwise), dim(res_roaches$ylp)[2]) + # measure_elpd() normalizes internally, so the result must not change + expect_equal( + res, + measure_elpd(ylp = res_roaches$ylp, log_weights = res_roaches$log_weights) + ) +}) + +# measure_ic() ----------------------------------- + +testthat::test_that("measure_ic() works as expected", { + res <- measure_ic(ylp = res_roaches$ylp) + n_obs <- dim(res_roaches$ylp)[2] + + expect_equal(names(res), c("estimates", "pointwise")) + expect_snapshot_output(measure_ic(ylp = res_roaches$ylp)) +}) + +# measure_mlpd() ----------------------------------- + +testthat::test_that("measure_mlpd() works as expected", { + res <- measure_mlpd(ylp = res_roaches$ylp, log_weights = NULL) + res_elpd <- measure_elpd(ylp = res_roaches$ylp, log_weights = NULL) + n_obs <- dim(res_roaches$ylp)[2] + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates[1]), 1) + expect_equal(length(res$estimates[2]), 1) + expect_equal(length(res$pointwise), n_obs) + expect_equal(unname(res$estimates), unname(res_elpd$estimates) / n_obs) + expect_equal(unname(res$pointwise), unname(res_elpd$pointwise)) + + expect_snapshot_output(measure_mlpd(ylp = res_roaches$ylp, log_weights = NULL)) +}) + +testthat::test_that("measure_mlpd() with pointwise works as expected", { + res_elpd <- measure_elpd(ylp = res_roaches$ylp, log_weights = NULL) + res <- measure_mlpd(ylp = NULL, pointwise = res_elpd$pointwise[ ,"elpd"]) + + n_obs <- dim(res_roaches$ylp)[2] + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates[1]), 1) + expect_equal(length(res$estimates[2]), 1) + expect_equal(length(res$pointwise), n_obs) + expect_equal(unname(res$estimates), unname(res_elpd$estimates) / n_obs) + expect_equal(unname(res$pointwise), unname(res_elpd$pointwise)) + + expect_snapshot_output(measure_mlpd(ylp = NULL, pointwise = res_elpd$pointwise[ ,"elpd"])) +}) + +# measure_rps() ------------------------------------- + +testthat::test_that("measure_rps() with ordered categorial data works as expected", { + res <- measure_rps( + y = res_binom$y, + ypred = res_binom$ypred + ) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_binom$y)) + + expect_snapshot_output(measure_rps(y = res_binom$y, ypred = res_binom$ypred)) +}) + +testthat::test_that("measure_rps() scaled version with categorical data works as expected", { + res <- measure_rps( + y = res_binom$y, + ypred = res_binom$ypred, + scaled = TRUE + ) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_binom$y)) + expect_true(all(res$pointwise < 0)) + + expect_snapshot_output(measure_srps(y = res_binom$y, ypred = res_binom$ypred)) +}) + +testthat::test_that("measure_rps() for categorical data with log-weights works as expected", { + res <- measure_rps( + y = res_binom$y, + ypred = res_binom$ypred, + log_weights = res_binom$log_weights + ) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_binary$y)) + expect_true(all(res$pointwise >= 0)) +}) + +testthat::test_that("measure_rps() validates the shape of log_weights", { + bad_log_weights <- res_binom$log_weights[, -1, drop = FALSE] + expect_error( + measure_rps( + y = res_binom$y, + ypred = res_binom$ypred, + log_weights = bad_log_weights + ), + regexp = "`log_weights` must have" + ) +}) + +testthat::test_that("measure_rps() with continuous data works as expected", { + res <- measure_rps(res_sleep$y, res_sleep$ypred) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_sleep$y)) + + expect_snapshot_output(measure_rps(res_sleep$y, res_sleep$ypred)) +}) + +testthat::test_that("measure_rps() with continuous data and log-weights works as expected", { + res <- measure_rps( + res_sleep$y, + res_sleep$ypred, + log_weights = res_sleep$log_weights + ) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_sleep$y)) +}) + +testthat::test_that("measure_rps() with continuous data and scaled version works as expected", { + res <- measure_rps(res_sleep$y, res_sleep$ypred, scaled = TRUE) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_sleep$y)) + expect_true(all(res$pointwise < 0)) +}) + + +# measure_brier() --------------------------------------- + +testthat::test_that("measure_brier() works as expected", { + res_brier <- measure_brier(y = res_binary$y, ypred = res_binary$ypred, log_weights = NULL) + + expect_equal(names(res_brier), c("estimates", "pointwise")) + expect_equal(length(res_brier$estimates), 2) + expect_equal(length(res_brier$pointwise), length(res_binary$y)) + expect_true(all(res_brier$pointwise >= 0 & res_brier$pointwise <= 1)) + + expect_snapshot_output(measure_brier(y = res_binary$y, ypred = res_binary$ypred)) +}) + +testthat::test_that("measure_brier() rejects out-of-range ypred", { + bad_ypred <- res_binary$ypred + bad_ypred[1, 1] <- 1.5 + expect_error( + measure_brier(y = res_binary$y, ypred = bad_ypred), + regexp = "`ypred` must contain values in \\[0, 1\\]" + ) +}) + +testthat::test_that("measure_brier() with log-weights works as expected", { + res_brier <- measure_brier( + y = res_binary$y, + ypred = res_binary$ypred, + log_weights = res_binary$log_weights + ) + + expect_equal(names(res_brier), c("estimates", "pointwise")) + expect_equal(length(res_brier$estimates), 2) + expect_equal(length(res_brier$pointwise), length(res_binary$y)) + expect_true(all(res_brier$pointwise >= 0 & res_brier$pointwise <= 1)) + + res_brier2 <- measure_brier( + y = res_binary$y, + ypred = res_binary$ypred, + log_weights = .normalize_log_weights(res_binary$log_weights) + ) + expect_equal(res_brier2$pointwise, res_brier$pointwise) +}) + +testthat::test_that("measure_brier() errors when y not binary", { + expect_error( + measure_brier( + y = res_binom$y, + ypred = res_binary$ypred, + log_weights = res_binary$log_weights + ), + regexp = "The brier score expects binary data 'y'." + ) +}) + +# measure_mae() ------------------------------------------------ +testthat::test_that("measure_mae() works as expected", { + res <- measure_mae(y = res_roaches$y, mupred = res_roaches$mupred, + log_weights = NULL) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_roaches$y)) + + expect_snapshot_output(measure_mae(y = res_roaches$y, mupred = res_roaches$mupred)) +}) + +testthat::test_that("measure_mae() with log_weights works as expected", { + res <- measure_mae(y = res_roaches$y, mupred = res_roaches$mupred, + log_weights = res_roaches$log_weights) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_roaches$y)) +}) + +# measure_rmse() / measure_mse() ----------------------------------------- +testthat::test_that("measure_mse() and measure_rmse() work as expected", { + res_mse <- measure_mse(y = res_roaches$y, mupred = res_roaches$mupred, + log_weights = NULL) + + res_rmse <- measure_rmse(y = res_roaches$y, mupred = res_roaches$mupred, + log_weights = NULL) + + expect_equal(names(res_mse), c("estimates", "pointwise")) + expect_equal(length(res_mse$estimates), 2) + expect_equal(length(res_mse$pointwise), length(res_roaches$y)) + + expect_equal(sqrt(abs(res_mse$estimates[1])), res_rmse$estimates[1]) + expect_equal(res_mse$estimates[2]/(2*sqrt(abs(res_mse$estimates[1]))), + res_rmse$estimates[2]) + + expect_snapshot_output(measure_mse(y = res_roaches$y, mupred = res_roaches$mupred)) + expect_snapshot_output(measure_rmse(y = res_roaches$y, mupred = res_roaches$mupred)) +}) + +testthat::test_that("higher_is_better reorients loss measures to utility scale", { + res_mse <- measure_mse(y = res_roaches$y, mupred = res_roaches$mupred) + res_mse_utility <- measure_mse( + y = res_roaches$y, + mupred = res_roaches$mupred, + higher_is_better = TRUE + ) + + expect_equal( + unname(res_mse_utility$estimates["Estimate"]), + -unname(res_mse$estimates["Estimate"]) + ) + expect_equal(res_mse_utility$pointwise, -res_mse$pointwise) +}) + +testthat::test_that("higher_is_better reorients rps and srps", { + raw <- measure_rps(res_sleep$y, res_sleep$ypred) + expect_true(all(raw$pointwise >= 0)) + up <- measure_rps(res_sleep$y, res_sleep$ypred, higher_is_better = TRUE) + expect_equal(up$pointwise, -raw$pointwise) + + s_raw <- measure_srps(res_sleep$y, res_sleep$ypred) + s_dn <- measure_srps(res_sleep$y, res_sleep$ypred, higher_is_better = FALSE) + expect_equal(s_dn$pointwise, -s_raw$pointwise) +}) + +testthat::test_that("measure_rmse() works with se=0", { + mupred0 <- t(replicate(4000, res_roaches$y)) + + res_rmse <- measure_rmse(y = res_roaches$y, mupred = mupred0, + log_weights = NULL) + + expect_equal(names(res_rmse), c("estimates", "pointwise")) + expect_equal(length(res_rmse$estimates), 2) + expect_equal(length(res_rmse$pointwise), length(res_roaches$y)) + expect_equal(unname(res_rmse$estimates[2]), 0) +}) + +# measure_r2() --------------------------------------------------- +testthat::test_that("measure_r2() works as expected", { + res <- measure_r2(y = res_roaches$y, mupred = res_roaches$mupred, log_weights = NULL) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_roaches$y)) + expect_true(all(res$estimates[1] >= 0 & res$estimates[1] <= 1)) + + expect_snapshot_output(measure_r2(y = res_roaches$y, mupred = res_roaches$mupred)) +}) + +testthat::test_that("measure_r2() with log_weights works as expected", { + res <- measure_r2(y = res_roaches$y, mupred = res_roaches$mupred, + log_weights = res_roaches$log_weights) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_roaches$y)) + expect_true(all(res$estimates[1] >= 0 & res$estimates[1] <= 1)) +}) + +# measure_acc() / measure_bacc() ----------------------------------------------------- +testthat::skip_if_not_installed("brms") + +testthat::test_that("measure_acc() works as expected", { + res <- measure_acc(y = as.integer(res_cat$y), mupred = res_cat$mupred, log_weights = NULL) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_cat$y)) + expect_true(all(res$pointwise >= 0 & res$pointwise <= 1)) + + expect_snapshot_output(measure_acc(y = as.integer(res_cat$y), mupred = res_cat$mupred)) +}) + +testthat::test_that("measure_acc() rejects out-of-range mupred", { + bad_mupred <- res_cat$mupred + bad_mupred[1, 1, 1] <- -0.1 + expect_error( + measure_acc(y = as.integer(res_cat$y), mupred = bad_mupred), + regexp = "`mupred` must contain values in \\[0, 1\\]" + ) +}) + +testthat::test_that("measure_acc() with log-weights works as expected", { + res <- measure_acc( + y = as.integer(res_cat$y), + mupred = res_cat$mupred, + log_weights = res_cat$log_weights + ) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_cat$y)) + expect_true(!all(res$pointwise < 0 | res$pointwise > 1)) +}) + +testthat::test_that("measure_acc() broadcasts weights over categories without warning", { + y <- as.integer(res_cat$y) + lw <- res_cat$log_weights + + expect_no_warning(res <- measure_acc( + y = y, mupred = res_cat$mupred, log_weights = lw + )) + expect_no_warning(measure_bacc( + y = y, mupred = res_cat$mupred, log_weights = lw + )) + + w <- exp(.normalize_log_weights(lw)) + n_cat <- dim(res_cat$mupred)[3] + manual <- vapply( + seq_len(n_cat), + function(k) colSums(w * res_cat$mupred[, , k]), + numeric(length(y)) + ) + expect_equal(as.numeric(res$pointwise), (apply(manual, 1, which.max) == y) * 1) +}) + +testthat::test_that("measure_bacc() pointwise contributions sum to estimate", { + y <- c(1L, 1L, 2L, 2L) + mupred <- array( + c(0.8, 0.2, 0.7, 0.3, 0.3, 0.7, 0.2, 0.8), + dim = c(1, 4, 2) + ) + res <- measure_bacc(y, mupred) + + classes <- sort(unique(y)) + K <- length(classes) + weights <- rep(1 / nrow(mupred), nrow(mupred)) + weighted_mupred <- apply(sweep(mupred, 1, weights, `*`), c(2, 3), sum) + mupred_hat <- apply(weighted_mupred, 1, which.max) + acc_i <- (mupred_hat == y) * 1L + n_c <- tabulate(match(y, classes)) + expected_bacc_i <- acc_i / (K * n_c[match(y, classes)]) + + expect_equal(as.numeric(res$pointwise), expected_bacc_i) + expect_equal(sum(as.numeric(res$pointwise)), unname(res$estimates[1, "Estimate"])) +}) + +testthat::test_that("measure_bacc() works as expected", { + res <- measure_bacc(y = as.integer(res_cat$y), mupred = res_cat$mupred, log_weights = NULL) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_cat$y)) + expect_true(!all(res$pointwise < 0 | res$pointwise > 1)) + + expect_snapshot_output(measure_bacc(y = as.integer(res_cat$y), mupred = res_cat$mupred)) +}) + +testthat::test_that("measure_bacc() accepts precomputed pointwise values", { + y <- c(1L, 1L, 2L, 2L) + acc_i <- c(1L, 0L, 1L, 1L) + res <- measure_bacc(y = y, mupred = NULL, pointwise = acc_i) + + expect_equal(unname(res$estimates[1, "Estimate"]), 0.75) + expect_error( + measure_bacc(y = y, mupred = NULL, pointwise = acc_i[-1]), + regexp = "must have the same length" + ) +}) + +testthat::test_that("mlpd and ic count draws after the 3-D conversion", { + LLarr <- example_loglik_array() + dims_elpd <- attr(measure_elpd(LLarr), "dims") + + expect_equal(attr(measure_mlpd(LLarr), "dims"), dims_elpd) + expect_equal(attr(measure_ic(LLarr), "dims"), dims_elpd) +}) + +testthat::test_that("measure_bacc() rejects out-of-range mupred", { + bad_mupred <- res_cat$mupred + bad_mupred[1, 1, 1] <- 1.2 + expect_error( + measure_bacc(y = as.integer(res_cat$y), mupred = bad_mupred), + regexp = "`mupred` must contain values in \\[0, 1\\]" + ) +}) + +testthat::test_that("measure_bacc() with log-weights works as expected", { + res <- measure_bacc( + y = as.integer(res_cat$y), + mupred = res_cat$mupred, + log_weights = res_cat$log_weights + ) + + expect_equal(names(res), c("estimates", "pointwise")) + expect_equal(length(res$estimates), 2) + expect_equal(length(res$pointwise), length(res_cat$y)) + expect_true(!all(res$pointwise < 0 | res$pointwise > 1)) +}) + +# mlpd / ic derived from elpd ------------------------ +testthat::test_that("mlpd and ic keep the sign of a positive pointwise lppd", { + # lppd_i is a log density and is positive for concentrated predictions. + set.seed(1) + S <- 200 + n <- 30 + y <- rnorm(n, 0, 0.05) + mu <- matrix(rnorm(S * n, 0, 0.01), S, n) + ylp <- t(sapply(1:S, function(s) dnorm(y, mu[s, ], 0.05, log = TRUE))) + lppd <- matrixStats::colLogSumExps(ylp) - log(S) + + # the removed heuristic negated every entry as soon as one was positive + expect_true(any(lppd > 0)) + expect_true(any(lppd < 0)) + + res <- insample_pred_measure(ylp = ylp, measure = c("elpd", "mlpd", "ic")) + + expect_equal(unname(res$estimates["mlpd", 1]), mean(lppd)) + expect_equal(unname(res$estimates["ic", 1]), sum(-2 * lppd)) + expect_equal(unname(res$pointwise[, "mlpd"]), unname(lppd)) + expect_equal(unname(res$pointwise[, "ic"]), unname(-2 * lppd)) + expect_equal(cor(res$pointwise[, "elpd"], res$pointwise[, "mlpd"]), 1) +}) + +testthat::test_that("mlpd on the test source uses ylp_test, not ylp", { + set.seed(2) + S <- 100 + ylp <- matrix(rnorm(S * 20, -1, 0.1), S, 20) + ylp_test <- matrix(rnorm(S * 8, -5, 0.1), S, 8) + lppd_test <- matrixStats::colLogSumExps(ylp_test) - log(S) + + res <- test_pred_measure(ylp = ylp, ylp_test = ylp_test, measure = "mlpd") + + expect_equal(unname(res$estimates["mlpd_test", 1]), mean(lppd_test)) + expect_equal(unname(res$pointwise[, "mlpd_test"]), unname(lppd_test)) +}) + +testthat::test_that("mlpd and ic work when only a loo object is given", { + LL <- example_loglik_matrix() + lo <- suppressWarnings( + loo(LL, save_psis = TRUE, r_eff = rep(1, ncol(LL))) + ) + + res <- loo_pred_measure(loo = lo, measure = c("mlpd", "ic")) + + elpd_loo_i <- lo$pointwise[, "elpd_loo"] + expect_equal(unname(res$estimates["mlpd_loo", 1]), mean(elpd_loo_i)) + expect_equal(unname(res$estimates["ic_loo", 1]), sum(-2 * elpd_loo_i)) +}) + +# .exx_pwm ------------------------ +testthat::test_that(".exx_pwm() reduces to the classic unbiased PWM estimator", { + set.seed(3) + S <- 500 + x <- matrix(rnorm(S * 6), S, 6) + ref <- colMeans(apply(x, 2, sort) * (2 * (2 * seq_len(S) - S - 1) / (S - 1))) + + expect_equal(.exx_pwm(x), ref) + expect_equal(.exx_pwm(x, matrix(1 / S, S, 6)), .exx_pwm(x)) +}) + +testthat::test_that(".exx_pwm() stays non-negative under concentrated weights", { + # E|X - X'| is non-negative by definition. The previous inline estimator + # divided by (1 - w) and drove the estimate negative when one draw dominated, + # which made log(EXX) in srps NaN. + set.seed(4) + S <- 200 + x <- matrix(rgamma(S * 4, 2, 1), S, 4) + lw <- matrix(0, S, 4) + lw[1, ] <- 8 # one draw carries most, but not all, of the weight + w <- exp(.normalize_log_weights(lw)) + expect_gt(max(w), 0.9) + + EXX <- .exx_pwm(x, w) + expect_true(all(EXX > 0)) + expect_true(all(is.finite(EXX))) + + srps <- measure_rps(y = colMeans(x), ypred = x, log_weights = lw, scaled = TRUE) + expect_true(all(is.finite(srps$pointwise))) +}) + +testthat::test_that("the scaled score aborts on a point-mass predictive", { + # All the weight on one draw makes E|X - X'| exactly 0, so the scaling term + # log(E|X - X'|) is undefined. The unscaled score stays well defined. + set.seed(5) + S <- 100 + x <- matrix(rgamma(S * 3, 2, 1), S, 3) + lw <- matrix(0, S, 3) + lw[1, ] <- 60 + y <- colMeans(x) + + expect_equal(.exx_pwm(x, exp(.normalize_log_weights(lw))), rep(0, 3)) + expect_error( + measure_rps(y = y, ypred = x, log_weights = lw, scaled = TRUE), + "point mass" + ) + expect_true(all(is.finite( + measure_rps(y = y, ypred = x, log_weights = lw)$pointwise + ))) +}) + +testthat::test_that(".exx_pwm() requires at least two draws", { + expect_error(.exx_pwm(matrix(1, 1, 3)), "at least 2 draws") +}) diff --git a/tests/testthat/test_pred_measure_helpers.R b/tests/testthat/test_pred_measure_helpers.R new file mode 100644 index 00000000..5be36b3b --- /dev/null +++ b/tests/testthat/test_pred_measure_helpers.R @@ -0,0 +1,309 @@ +# load data ----------------------------- +res <- readRDS("data-for-tests/test_data_roaches.Rds") + +supported_measures_list <- getFromNamespace("supported_measures_list", "loo") + +# helpers for tests ------------------------------------------------ +.builtin_entry <- function(name) { + list(name = name, type = "builtin", key = name) +} + +# .normalize_measure() ---------------------------------------------- + +test_that(".normalize_measure() handles NULL and character input", { + expect_equal(.normalize_measure(NULL), list()) + entries <- .normalize_measure(c("mse", "rps")) + expect_length(entries, 2) + expect_equal(entries[[1]], .builtin_entry("mse")) +}) + +test_that(".normalize_measure() handles a custom function", { + f <- function(y, mupred) list(estimate = 1, se = 0, pointwise = y) + attr(f, "measure_name") <- "custom_mae" + entries <- .normalize_measure(f) + expect_length(entries, 1) + expect_equal(entries[[1]]$type, "custom") + expect_equal(entries[[1]]$name, "custom_mae") +}) + +test_that(".normalize_measure() handles a mixed list", { + f <- function(y, mupred) list(estimate = 1, se = 0, pointwise = y) + attr(f, "measure_name") <- "custom_mae" + entries <- .normalize_measure(list("r2", custom_mae = f)) + expect_length(entries, 2) + expect_equal(entries[[1]]$name, "r2") + expect_equal(entries[[2]]$name, "custom_mae") +}) + +test_that(".normalize_measure() errors on duplicate names", { + expect_error( + .normalize_measure(c("mse", "mse")), + regexp = "Duplicate measure" + ) +}) + +test_that(".normalize_measure() errors on unnamed list function", { + f <- function(y, mupred) list(estimate = 1, se = 0, pointwise = y) + expect_error( + .normalize_measure(list(f)), + regexp = "must be named" + ) +}) + +# .prepare_measures() ----------------------------------------------- + +test_that(".prepare_measures() errors on invalid built-in names", { + expect_error( + .prepare_measures( + "pps", res$predperf, supported_measures_list, source = "insample" + ), + regexp = "Invalid measure" + ) +}) + +test_that(".prepare_measures() filters measures already in predperf", { + expect_warning( + .prepare_measures( + c("mse", "elpd"), predperf = res$predperf, + supported_measures_list, source = "insample" + ), + regexp = "already present in" + ) + + expect_warning( + .prepare_measures( + c("mse", "elpd", "r2"), predperf = res$predperf, + supported_measures_list, source = "insample" + ), + regexp = "already present in" + ) + + entries <- .prepare_measures( + c("mse", "rps"), predperf = res$predperf, + supported_measures_list, source = "insample" + ) + expect_equal(vapply(entries, `[[`, "", "name"), c("mse", "rps")) + + entries <- .prepare_measures( + c("mse"), predperf = res$predperf, + supported_measures_list, source = "insample" + ) + expect_equal(vapply(entries, `[[`, "", "name"), "mse") +}) + +test_that(".prepare_measures() defaults to elpd for a new result only", { + entries <- .prepare_measures(NULL, NULL, supported_measures_list, "insample") + expect_equal(vapply(entries, `[[`, "", "key"), "elpd") + expect_length( + .prepare_measures(NULL, res$predperf, supported_measures_list, "insample"), + 0L + ) +}) + +# .any_needs_elpd() ------------------------------------------------- + +test_that(".any_needs_elpd() detects measures derived from elpd", { + entry <- function(k) list(name = k, type = "builtin", key = k) + custom <- list(name = "my_fun", type = "custom", key = function(...) NULL) + + expect_true(.any_needs_elpd(list(entry("rmse"), entry("mlpd")))) + expect_true(.any_needs_elpd(list(entry("elpd")))) + expect_false(.any_needs_elpd(list(entry("rmse"), custom))) + expect_false(.any_needs_elpd(list())) +}) + +# .validate_measure_result() ---------------------------------------- + +test_that(".validate_measure_result() accepts standard and CRPS-style output", { + res_std <- list(estimate = 1, se = 0.1, pointwise = c(1, 2)) + expect_invisible(.validate_measure_result(res_std, "m", n_obs = 2)) + + res_crps <- list(estimates = c(1, 0.1), pointwise = c(1, 2)) + expect_invisible(.validate_measure_result(res_crps, "m", n_obs = 2)) +}) + +test_that(".validate_measure_result() errors on invalid output", { + expect_error( + .validate_measure_result(list(estimate = 1), "m"), + regexp = "Missing" + ) + expect_error( + .validate_measure_result( + list(estimate = 1, se = 0.1, pointwise = c(1, 2, 3)), + "m", + n_obs = 2 + ), + regexp = "length 2, not 3" + ) +}) + +# .validate_control() --------------------------------------- + +test_that(".validate_control() accepts valid control silently", { + expect_invisible(.validate_control(list())) + expect_invisible(.validate_control(list(rps = list()))) + expect_invisible(.validate_control(list(rps = list(scaled = TRUE)))) + expect_invisible(.validate_control(list( + rps = list(scaled = TRUE), + srps = list(higher_is_better = TRUE) + ))) +}) + +test_that(".validate_control() warns on invalid measure args", { + expect_warning( + .validate_control(list(rps = list(size = 10))), + regexp = "Ignoring `size` as it is not a valid argument" + ) + + expect_warning( + .validate_control(list(rps = list(foo = 1, bar = 2))), + regexp = "Ignoring `foo` and `bar` as it is not a valid argument" + ) + + expect_warning( + .validate_control(list(rps = list(scaled = TRUE, bad = 1))), + regexp = "Ignoring `bad` as it is not a valid argument" + ) + + expect_warning( + expect_warning( + .validate_control(list(rps = list(foo = 1), mse = list(bar = 2))), + regexp = "Ignoring `foo` as it is not a valid argument" + ), + regexp = "Ignoring `bar` as it is not a valid argument" + ) +}) + +test_that(".validate_control() errors on malformed control", { + expect_error( + .validate_control("rps"), + regexp = "must be a named list of named lists." + ) + expect_error( + .validate_control(list(list(scaled = TRUE))), + regexp = "must be a named list of named lists." + ) + expect_error( + .validate_control(list(rps = c(scaled = TRUE))), + regexp = "must be a named list of named lists." + ) + expect_error( + .validate_control(list(not_a_function = list(x = 1))), + regexp = "not_a_function" + ) +}) + +# .validate_probs() ----------------------------------------- + +test_that(".validate_probs() accepts values in [0, 1]", { + expect_invisible(.validate_probs(c(0, 0.5, 1), "x")) + expect_invisible(.validate_probs(matrix(c(0.2, 0.8), nrow = 1), "x")) +}) + +test_that(".validate_probs() rejects out-of-range values", { + expect_error( + .validate_probs(c(-0.1, 0.5), "mupred"), + regexp = "`mupred` must contain values in \\[0, 1\\]" + ) + expect_error( + .validate_probs(c(0.5, 1.1), "ypred"), + regexp = "`ypred` must contain values in \\[0, 1\\]" + ) +}) + +# subset_measures() ----------------------------------------- + +.make_measure_result <- function() { + list( + estimates = matrix( + 1:4, 2, 2, + dimnames = list(c("a", "b"), c("Estimate", "SE")) + ), + pointwise = matrix( + 1:6, 3, 2, + dimnames = list(NULL, c("a", "b")) + ), + diagnostics = list(pareto_k = c(0.1, 0.2, 0.3)), + psis_object = list(foo = 1) + ) +} + +test_that("subset_measures() subsets kfold and loo base measures", { + kfold_sub <- subset_measures( + res$kfold, + measures = c("elpd_kfold", "p_kfold"), + components = c("estimates", "pointwise") + ) + expect_equal(names(kfold_sub), c("estimates", "pointwise")) + expect_equal(rownames(kfold_sub$estimates), c("elpd_kfold", "p_kfold")) + expect_equal(colnames(kfold_sub$pointwise), c("elpd_kfold", "p_kfold")) + + loo_sub <- subset_measures( + res$loo, + measures = c("elpd_loo", "p_loo"), + components = c("estimates", "pointwise", "diagnostics") + ) + expect_equal(names(loo_sub), c("estimates", "pointwise", "diagnostics")) + expect_equal(rownames(loo_sub$estimates), c("elpd_loo", "p_loo")) + expect_equal(colnames(loo_sub$pointwise), c("elpd_loo", "p_loo")) + expect_identical(loo_sub$diagnostics, res$loo$diagnostics) +}) + +test_that("subset_measures() respects components argument", { + x <- .make_measure_result() + + estimates_only <- subset_measures(x, measures = c("a", "b"), components = "estimates") + expect_equal(names(estimates_only), "estimates") + expect_equal(rownames(estimates_only$estimates), c("a", "b")) + + pointwise_only <- subset_measures(x, measures = "a", components = "pointwise") + expect_equal(names(pointwise_only), "pointwise") + expect_equal(colnames(pointwise_only$pointwise), "a") + + diagnostics_only <- subset_measures(x, measures = "a", components = "diagnostics") + expect_equal(names(diagnostics_only), "diagnostics") + expect_identical(diagnostics_only$diagnostics, x$diagnostics) +}) + +test_that("subset_measures() drops unknown measures and components", { + x <- .make_measure_result() + + expect_error( + subset_measures( + x, + measures = c("a", "missing", "b"), + components = c("estimates", "pointwise") + ), + regexp = "contains invalid value:" + ) + + expect_error( + subset_measures( + x, + measures = c("a", "b"), + components = c("estimates", "pointwise", "measure") + ), + regexp = "contains invalid value:" + ) + + empty_measures <- subset_measures( + x, + measures = character(0), + components = c("estimates", "pointwise") + ) + expect_equal(dim(empty_measures$estimates), c(0, 2)) + expect_equal(dim(empty_measures$pointwise), c(3, 0)) +}) + +test_that("subset_measures() preserves requested measure order", { + x <- .make_measure_result() + + sub <- subset_measures( + x, + measures = c("b", "a"), + components = c("estimates", "pointwise") + ) + + expect_equal(rownames(sub$estimates), c("b", "a")) + expect_equal(colnames(sub$pointwise), c("b", "a")) +}) \ No newline at end of file diff --git a/tests/testthat/test_print.R b/tests/testthat/test_print.R new file mode 100644 index 00000000..2e2cf854 --- /dev/null +++ b/tests/testthat/test_print.R @@ -0,0 +1,98 @@ +# load data +temp <- readRDS("data-for-tests/test_data_roaches.Rds") + +measure_specs <- function(temp) { + list( + list(measure = "r2", args = list(y = temp$y, mupred = temp$mupred)), + list(measure = "rmse", args = list(y = temp$y, mupred = temp$mupred)), + list(measure = "mse", args = list(y = temp$y, mupred = temp$mupred)), + list(measure = "mae", args = list(y = temp$y, mupred = temp$mupred)), + list(measure = "rps", args = list(y = temp$y, ypred = temp$ypred)), + list(measure = "srps", args = list(y = temp$y, ypred = temp$ypred)), + list(measure = "mlpd", args = list(ylp = temp$ylp)) + ) +} + +run_measure_snapshots <- function(loo_start, measures) { + loo_iter <- loo_start + for (i in seq_along(measures)) { + measure <- measures[[i]] + loo_prev <- loo_iter + call_args <- c( + measure$args, + list( + measure = measure$measure, + save_psis = TRUE + ) + ) + if (!is.null(measure$control)) { + call_args$control <- measure$control + } + if (i == 1L) { + call_args$loo <- loo_iter + loo_iter <- do.call(loo_pred_measure, call_args) + } else { + call_args$predperf <- loo_iter + loo_iter <- do.call(pred_measure, call_args) + } + common_rows <- intersect( + rownames(loo_prev$estimates), + rownames(loo_iter$estimates) + ) + common_cols <- intersect( + colnames(loo_prev$pointwise), + colnames(loo_iter$pointwise) + ) + expect_equal( + loo_iter$estimates[common_rows, , drop = FALSE], + loo_prev$estimates[common_rows, , drop = FALSE], + info = measure$measure + ) + expect_equal( + loo_iter$pointwise[, common_cols, drop = FALSE], + loo_prev$pointwise[, common_cols, drop = FALSE], + info = measure$measure + ) + expect_snapshot_output(print(loo_iter)) + } + loo_iter +} + +test_that("loo_pred_measure print snapshots", { + loo_ordered <- run_measure_snapshots(temp$loo, measure_specs(temp)) + loo_shuffled <- run_measure_snapshots( + temp$loo, + with(set.seed(0), sample(measure_specs(temp))) + ) + expect_setequal( + rownames(loo_ordered$estimates), + rownames(loo_shuffled$estimates) + ) + expect_equal( + loo_ordered$estimates[rownames(loo_shuffled$estimates), , drop = FALSE], + loo_shuffled$estimates + ) +}) + +test_that("loo_pred_measure print output with elpd", { + x <- loo_pred_measure( + loo = temp$loo, + y = temp$y, + mupred = temp$mupred, + measure = c("elpd", "r2") + ) + expect_snapshot_output(print(x)) +}) + +test_that("test_pred_measure print output", { + res <- readRDS("data-for-tests/test_data_sleep_cv.Rds") + x <- test_pred_measure( + y = res$y_test, + ypred = res$ypred_test, + mupred = res$mupred_test, + ylp_test = res$ylp_test, + measure = c("rmse", "r2") + ) + expect_s3_class(x, "test_pred_measure") + expect_snapshot_output(print(x)) +}) \ No newline at end of file diff --git a/vignettes/articles-online-only/overview-measures.Rmd b/vignettes/articles-online-only/overview-measures.Rmd new file mode 100644 index 00000000..c71b37e0 --- /dev/null +++ b/vignettes/articles-online-only/overview-measures.Rmd @@ -0,0 +1,693 @@ +--- +title: "Overview of predictive measures" +author: "Florence Bockting" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + css: + - !expr system.file("rmarkdown/templates/html_vignette/resources/vignette.css", package = "rmarkdown") + - styles.css + toc: true + toc_depth: 3 +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +vignette: > + %\VignetteIndexEntry{Overview of predictive measures} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, child="../children/SEE-ONLINE.txt", eval = if (isTRUE(exists("params"))) !params$EVAL else TRUE} +``` + +```{r setup, include=FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + message = FALSE, + warning = FALSE, + eval = params$EVAL, + fig.width = 7, + fig.height = 4, + fig.align = "center" +) +``` + +```{r, child="../children/LOAD-BRMS-GITHUB.txt", eval=params$EVAL} +``` + +## Introduction + +A *predictive measure* summarizes how well a model predicts data. **loo** +implements twelve of them. Each one has its own `measure_*()` function. + +This article introduces each measure. For each measure it gives: + +1. the motivation: what the measure rewards, +2. when to use it: the outcome type and the required input, +3. the key formula, +4. the standard error, +5. the call in **loo**, +6. a plot and its interpretation, for a model that performs well and a model + that performs badly. + +The article states only the key formulas. The full definitions, the +estimators, and the standard errors are in the formula reference +(Vehtari et al., 2026). Equation numbers in this article refer to that paper. + +::: {.callout .callout-note} +**What this article does not cover** + ++ **Predictive schemes.** All examples use in-sample predictions. In-sample + estimates are optimistic for new data. The same measure can use leave-one-out, + K-fold, or test-data predictions instead. [TODO: link to the schemes and + `pred_measure()` article.] ++ **Model comparison.** See the [model comparison](model-comparison.html) + article. +::: + +## Overview of the measures + +| Keyword | Measure | Family | Input | Outcome | Natural scale | Aggregation | +| :--- | :--- | :--- | :--- | :--- | :--- | :--- | +| `elpd` | expected log pointwise predictive density | [log score](#log-score) | `ylp` | any | utility | sum | +| `mlpd` | mean log predictive density | [log score](#log-score) | `ylp` | any | utility | mean | +| `ic` | information criterion, $-2\,\text{elpd}$ | [log score](#log-score) | `ylp` | any | loss | sum | +| `rps` | (continuous) ranked probability score | [ranked probability score](#ranked-probability-score) | `ypred` | continuous or ordered | loss | mean | +| `srps` | scaled (continuous) ranked probability score | [ranked probability score](#ranked-probability-score) | `ypred` | continuous or ordered | utility | mean | +| `brier` | Brier score | [Brier score](#brier-score) | `ypred` | binary | loss | mean | +| `mae` | mean absolute error | [point error](#point-error) | `mupred` | continuous | loss | mean | +| `mse` | mean squared error | [point error](#point-error) | `mupred` | continuous | loss | mean | +| `rmse` | root mean squared error | [point error](#point-error) | `mupred` | continuous | loss | function of means | +| `r2` | predictive $R^2$ | [predictive $R^2$](#predictive-r2) | `mupred` | continuous | utility | function of means | +| `acc` | classification accuracy | [classification accuracy](#classification-accuracy) | `mupred` | binary or nominal | utility | mean | +| `bacc` | balanced accuracy | [classification accuracy](#classification-accuracy) | `mupred` | binary or nominal | utility | function of means | + +The columns mean: + ++ **Natural scale.** A *loss* is better when it is lower. A *utility* is better + when it is higher. `measure_*()` reports each measure on its natural scale. + Model comparison converts every loss to a utility. ++ **Aggregation.** Most measures are a sum or a mean of pointwise terms. RMSE, + $R^2$, and balanced accuracy are functions of means. They have no pointwise + terms that add up to the estimate. + +## Notation + +The paper uses one notation for all measures. The table maps each symbol to an +argument of `measure_*()` or to a field of its result. + +| Symbol | Meaning | In **loo** | +| :--- | :--- | :--- | +| $y_i$ | observed outcome $i$ | `y` | +| $\theta^s$ | posterior draw $s$, $s = 1, \ldots, S$ | rows of the input matrices | +| $\ell_i^s = \log p(y_i \mid \theta^s)$ | log density of $y_i$ under draw $s$ | `ylp`, an $S \times n$ matrix | +| $\tilde y_i^s$ | posterior predictive draw | `ypred`, an $S \times n$ matrix | +| $\mathbb{E}[\tilde y_i \mid \theta^s]$ | predictive mean under draw $s$ | `mupred`, an $S \times n$ matrix, or $S \times n \times C$ for $C$ classes | +| $w_i^s$ | normalized weight of draw $s$ (Vehtari et al., 2026, Eq. 2.5) | `log_weights`; `NULL` gives $w_i^s = 1/S$ | +| $\text{elpd}_i$, $\text{rps}_i$, $\text{ae}_i$, … | pointwise term of a measure, on its natural scale | `$pointwise` | +| $\widehat{\text{elpd}}$, $\widehat{\text{rps}}$, $\widehat{\text{mae}}$, … | estimate of a measure | `$estimates[, "Estimate"]` | +| $\widehat{\text{SE}}$ | standard error of the estimate | `$estimates[, "SE"]` | +| $\widehat{\text{Var}}$ | sample variance over the observations | | + +::: {.callout .callout-note} +**Weights** + +Every estimator in this article uses weights $w_i^s$. With +`log_weights = NULL`, all draws get the weight $1/S$. This gives in-sample +predictions. Other weights give other predictive schemes, for example PSIS-LOO. +::: + +## Data and models + +```{r load-libraries} +library(loo) +library(ggplot2) +theme_set(theme_minimal()) +``` + +For each outcome type we fit two `brms` models: + ++ **with predictors**: a model that uses the predictors of the data, ++ **intercept only**: a model that predicts the same distribution for every + observation. + +The intercept-only model shows how a measure looks for a model that performs +badly. Fitting is not the topic of this article. The model code is in the +[appendix](#appendix-model-code). + +| Object | Data | Outcome | Predictors | Used for | +| :--- | :--- | :--- | :--- | :--- | +| `fits_count` | `roaches` (`rstanarm`) | count, Poisson | `sqrt_roach1`, `treatment`, `senior` | log score | +| `fits_cont` | `kidiq` (`rstanarm`) | continuous, normal | `mom_iq`, `mom_hs` | CRPS, point error, $R^2$ | +| `fits_bin` | `wells` (`rstanarm`) | binary, Bernoulli | `dist100`, `arsenic` | Brier score | +| `fits_ord` | simulated | ordered, 4 categories | `x` | RPS | +| `fits_cat` | simulated | nominal, 3 unbalanced classes | `x` | accuracy | + +Each object is a list with the elements `"with predictors"` and +`"intercept only"`. + +**Prediction tasks.** The models predict the following outcomes: + ++ **Roach counts** (`fits_count`). A pest-management trial in 262 apartment + buildings. The outcome `y` is the number of roaches caught in traps after the + treatment. The predictors are the square root of the count before the + treatment (`sqrt_roach1`), whether the building received the treatment + (`treatment`), and whether only elderly people live in the building + (`senior`). ++ **Child IQ** (`fits_cont`). A survey of 434 American mothers and their + children. The outcome `kid_score` is the IQ score of the child. The + predictors are the IQ of the mother (`mom_iq`) and whether the mother + finished high school (`mom_hs`). ++ **Well switching** (`fits_bin`). A survey of 3020 households in Bangladesh + whose wells had high arsenic levels. The outcome `switch` is 1 if the + household switched to a safe well. The predictors are the distance to the + nearest safe well in 100 meters (`dist100`) and the arsenic level of the + current well (`arsenic`). ++ **Ordered rating** (`fits_ord`). Simulated data with 300 observations. The + outcome `y` is a rating on an ordered scale from 1 to 4. Higher values of the + predictor `x` make higher ratings more likely. ++ **Class membership** (`fits_cat`). Simulated data with 300 observations. The + outcome `y` is one of three unordered classes. Class 1 is the most frequent + class (169 observations), and class 3 the least frequent (35 observations). + The predictor `x` shifts the probabilities between the classes. + +```{r fit-models, echo=FALSE, results="hide"} +SEED <- 42 + +fit_pair <- function(formula, data, family) { + fit <- brms::brm(formula, data = data, family = family, + chains = 2, iter = 1000, seed = SEED, refresh = 0) + list( + "with predictors" = fit, + "intercept only" = update(fit, formula. = . ~ 1, seed = SEED, refresh = 0) + ) +} + +# count +data(roaches, package = "rstanarm") +roaches$sqrt_roach1 <- sqrt(roaches$roach1) +fits_count <- fit_pair(y ~ sqrt_roach1 + treatment + senior, roaches, poisson()) + +# continuous +data(kidiq, package = "rstanarm") +fits_cont <- fit_pair(kid_score ~ mom_iq + mom_hs, kidiq, gaussian()) + +# binary +data(wells, package = "rstanarm") +wells$dist100 <- wells$dist / 100 +fits_bin <- fit_pair(switch ~ dist100 + arsenic, wells, brms::bernoulli()) + +# ordered: latent logistic model with three cut points +set.seed(SEED) +n_sim <- 300 +x <- rnorm(n_sim) +latent <- 1.2 * x + rlogis(n_sim) +df_ord <- data.frame(y = 1 + rowSums(outer(latent, c(-1, 0.3, 1.5), ">")), x = x) +fits_ord <- fit_pair(y ~ x, df_ord, brms::cumulative("logit")) + +# nominal: class 1 is the most frequent +set.seed(SEED + 1) +x <- rnorm(n_sim) +prob <- cbind(1, exp(-1 + 1.5 * x), exp(-2 - x)) +prob <- prob / rowSums(prob) +df_cat <- data.frame(y = apply(prob, 1, function(p) sample(3, 1, prob = p)), x = x) +fits_cat <- fit_pair(y ~ x, df_cat, brms::categorical()) +``` + +## Log score {#log-score} + +**Motivation.** The log score evaluates the predictive density at the observed +value. A model gets a high score when it puts much probability near the +observation. It uses the whole predictive distribution, and it strongly +penalizes observations the model considers very unlikely. + +**When to use.** The log score works for any outcome type. It is the default +measure in **loo**. It needs the log-likelihood draws `ylp`. + +**Key formula.** The pointwise term and the estimate are +(Vehtari et al., 2026, Eqs. 2.16–2.18) + +$$ +\text{elpd}_i = \log \sum_{s=1}^S \exp\!\left(\log w_i^s + \ell_i^s\right), +\qquad +\widehat{\text{elpd}} = \sum_{i=1}^n \text{elpd}_i . +$$ + +**loo** reports two rescaled versions: $\widehat{\text{mlpd}} = +\widehat{\text{elpd}} / n$ on the mean scale, and the information criterion +$\widehat{\text{ic}} = -2\,\widehat{\text{elpd}}$. + +**Standard error.** The elpd is a sum, the mlpd is a mean +(Vehtari et al., 2026, Eqs. 2.8, 2.9): + +$$ +\widehat{\text{SE}}(\widehat{\text{elpd}}) = + \sqrt{n\,\widehat{\text{Var}}(\text{elpd}_i)}, +\qquad +\widehat{\text{SE}}(\widehat{\text{mlpd}}) = + \sqrt{\widehat{\text{Var}}(\text{elpd}_i) / n}, +\qquad +\widehat{\text{SE}}(\widehat{\text{ic}}) = + 2\,\widehat{\text{SE}}(\widehat{\text{elpd}}) . +$$ + +**Implementation.** + +```{r log-score} +y_count <- fits_count[[1]]$data$y +elpd_count <- lapply(fits_count, function(fit) measure_elpd(ylp = brms::log_lik(fit))) +elpd_count + +ylp_count <- brms::log_lik(fits_count[["with predictors"]]) +measure_mlpd(ylp = ylp_count) +measure_ic(ylp = ylp_count) +``` + +**Plot.** Each point is one building. The y-axis shows its pointwise log score +$\text{elpd}_i$. Higher is better. + +```{r log-score-plot} +df_log <- do.call(rbind, lapply(names(elpd_count), function(m) { + data.frame(model = m, y = y_count, elpd_i = as.vector(elpd_count[[m]]$pointwise)) +})) + +ggplot(df_log, aes(y, elpd_i)) + + geom_point(alpha = 0.5) + + scale_x_sqrt() + + facet_wrap(~model) + + labs(x = "observed roach count (square-root scale)", + y = "pointwise log score") +``` + +**Interpretation.** The intercept-only model predicts the same distribution for +every building. Its log score falls steeply as the observed count moves away +from the average count. The model with predictors uses the count before the +treatment. It moves the predictive distribution toward the observed count, so +its points lie higher for most buildings. + +## Ranked probability score {#ranked-probability-score} + +**Motivation.** The ranked probability score compares the predictive +distribution with the observed value through absolute distances. Unlike the +log score, it rewards predictions that are *close* to the observation, not only +predictions that hit it. It is less sensitive to single outliers. + +**When to use.** Use `rps` for ordered categorical outcomes (RPS) and for +continuous outcomes (CRPS). It is on the scale of $y$, so a value can be +read in the units of the outcome. Use `srps` when outcomes differ strongly in +their predictive spread. Both need the posterior predictive draws `ypred`. + +**Key formula.** Let $X$ and $X'$ be independent draws from the predictive +distribution of observation $i$ (Vehtari et al., 2026, Eqs. 2.20–2.22): + +$$ +\text{rps}_i = \mathbb{E}|X - y_i| - \tfrac{1}{2}\,\mathbb{E}|X - X'|, \qquad +\text{srps}_i = -\frac{\mathbb{E}|X - y_i|}{\mathbb{E}|X - X'|} + - \tfrac{1}{2}\log \mathbb{E}|X - X'| . +$$ + +The estimates are the means $\widehat{\text{rps}} = \frac{1}{n}\sum_i +\text{rps}_i$ and $\widehat{\text{srps}} = \frac{1}{n}\sum_i \text{srps}_i$. +**loo** estimates both expectations from one set of draws. The estimator of +$\mathbb{E}|X - X'|$ is a probability-weighted moment estimator +(Vehtari et al., 2026, Eq. 2.25). `rps` is a loss, and `srps` is a utility. + +**Standard error.** Both are means (Vehtari et al., 2026, Eq. 2.8): + +$$ +\widehat{\text{SE}}(\widehat{\text{rps}}) = + \sqrt{\widehat{\text{Var}}(\text{rps}_i) / n}, +\qquad +\widehat{\text{SE}}(\widehat{\text{srps}}) = + \sqrt{\widehat{\text{Var}}(\text{srps}_i) / n} . +$$ + +**Implementation.** For the continuous outcome, `measure_rps()` gives the CRPS: + +```{r crps} +y_cont <- fits_cont[[1]]$data$kid_score +ypred_cont <- lapply(fits_cont, brms::posterior_predict) + +(crps_cont <- lapply(ypred_cont, function(yp) measure_rps(y = y_cont, ypred = yp))) +lapply(ypred_cont, function(yp) measure_srps(y = y_cont, ypred = yp)) +``` + +For the ordered outcome, the same functions give the RPS and the SRPS: + +```{r rps} +y_ord <- fits_ord[[1]]$data$y +ypred_ord <- lapply(fits_ord, brms::posterior_predict) + +lapply(ypred_ord, function(yp) measure_rps(y = y_ord, ypred = yp)) +lapply(ypred_ord, function(yp) measure_srps(y = y_ord, ypred = yp)) +``` + +**Plot.** Both panels show the same child. We chose the child for which the +predictors reduce the CRPS the most. The solid line is the predictive CDF. The +dashed line is the step function of the observed score. The CRPS integrates +the squared vertical gap between the two lines, so a smaller shaded area is +better. + +```{r crps-plot} +crps_i <- sapply(crps_cont, function(r) as.vector(r$pointwise)) +i <- which.max(crps_i[, "intercept only"] - crps_i[, "with predictors"]) +grid <- seq(min(sapply(ypred_cont, function(yp) min(yp[, i])), y_cont[i]), + max(sapply(ypred_cont, function(yp) max(yp[, i])), y_cont[i]), + length.out = 400) + +df_cdf <- do.call(rbind, lapply(names(ypred_cont), function(m) { + data.frame( + model = sprintf("%s (CRPS = %.1f)", m, crps_i[i, m]), + x = grid, + cdf = ecdf(ypred_cont[[m]][, i])(grid), + step = as.numeric(grid >= y_cont[i]) + ) +})) + +ggplot(df_cdf, aes(x)) + + geom_ribbon(aes(ymin = pmin(cdf, step), ymax = pmax(cdf, step)), + fill = "steelblue", alpha = 0.3) + + geom_line(aes(y = cdf)) + + geom_line(aes(y = step), linetype = "dashed") + + facet_wrap(~model) + + labs(x = "kid_score", y = "cumulative probability") +``` + +**Interpretation.** The intercept-only model predicts the same distribution for +every child, centered at the average score. For this child, its CDF rises far +from the observed score, and the shaded area is large. The model with +predictors uses the mother's IQ and schooling. Its CDF rises closer to the +observed score, and the shaded area is smaller. + +## Brier score {#brier-score} + +**Motivation.** The Brier score is the squared distance between the predicted +probability of an event and the observed outcome, 0 or 1. It rewards +probabilities that are both calibrated and sharp. + +**When to use.** Use it for binary outcomes. **loo** implements the binary +Brier score only. `measure_brier()` needs the event probabilities of the +draws, passed as `ypred`. + +**Key formula.** With the predicted event probability +$\hat p_i = \sum_s w_i^s\, p(\tilde y_i = 1 \mid \theta^s)$ +(Vehtari et al., 2026, Eqs. 2.26–2.28), + +$$ +\text{bs}_i = \left(\hat p_i - y_i\right)^2, \qquad +\widehat{\text{bs}} = \frac{1}{n}\sum_{i=1}^n \text{bs}_i . +$$ + +The Brier score is a loss. It ranges from 0 to 1. + +**Standard error.** The Brier score is a mean +(Vehtari et al., 2026, Eq. 2.8): + +$$ +\widehat{\text{SE}}(\widehat{\text{bs}}) = + \sqrt{\widehat{\text{Var}}(\text{bs}_i) / n} . +$$ + +**Implementation.** + +```{r brier} +y_bin <- fits_bin[[1]]$data$switch +p_bin <- lapply(fits_bin, brms::posterior_epred) + +(brier_bin <- lapply(p_bin, function(p) measure_brier(y = y_bin, ypred = p))) +``` + +**Plot.** Each point is one household. The x-axis shows the predicted +probability $\hat p_i$ that it switches wells. Every point lies on one of two +curves: $\hat p_i^2$ if the household did not switch, and $(1 - \hat p_i)^2$ +if it switched. Lower is better. + +```{r brier-plot} +df_brier <- do.call(rbind, lapply(names(p_bin), function(m) { + data.frame( + model = m, + p = colMeans(p_bin[[m]]), + bs_i = as.vector(brier_bin[[m]]$pointwise), + switched = factor(y_bin, levels = 0:1, labels = c("no", "yes")) + ) +})) + +ggplot(df_brier, aes(p, bs_i, color = switched)) + + geom_function(fun = function(p) p^2, color = "grey70", linetype = "dotted") + + geom_function(fun = function(p) (1 - p)^2, color = "grey70", linetype = "dotted") + + geom_point(alpha = 0.5) + + facet_wrap(~model) + + labs(x = "predicted probability of switching", + y = "pointwise Brier score", color = "switched") +``` + +**Interpretation.** The intercept-only model gives every household the same +probability, the proportion of households that switched. All its points fall +on two spots, one on each curve. The model with predictors spreads the +probabilities. A household moves down its curve when the model is confident +and right. It moves up its curve when the model is confident and wrong. + +## Point error {#point-error} + +**Motivation.** The point-error measures reduce the predictive distribution to +one point prediction, the predictive mean. They then measure the distance +between that prediction and the observed value. They are easy to interpret, +but they ignore the predictive uncertainty. + +**When to use.** Use them for continuous outcomes when the quality of the point +prediction matters. MAE is less sensitive to large errors than MSE and RMSE. +MAE and RMSE are on the scale of $y$. All three need the predictive means +`mupred`. + +**Key formula.** With the point prediction +$\hat y_i = \sum_s w_i^s\, \mathbb{E}[\tilde y_i \mid \theta^s]$, the pointwise +errors are $\text{ae}_i = |y_i - \hat y_i|$ and +$\text{sqe}_i = (y_i - \hat y_i)^2$ (Vehtari et al., 2026, Eqs. 2.29–2.34): + +$$ +\widehat{\text{mae}} = \frac{1}{n}\sum_{i=1}^n \text{ae}_i, \qquad +\widehat{\text{mse}} = \frac{1}{n}\sum_{i=1}^n \text{sqe}_i, \qquad +\widehat{\text{rmse}} = \sqrt{\widehat{\text{mse}}} . +$$ + +All three are losses. + +**Standard error.** MAE and MSE are means (Vehtari et al., 2026, Eq. 2.8). +RMSE is a function of a mean, so its standard error uses the delta method +(Vehtari et al., 2026, Eq. 2.33): + +$$ +\widehat{\text{SE}}(\widehat{\text{mae}}) = + \sqrt{\widehat{\text{Var}}(\text{ae}_i) / n}, +\qquad +\widehat{\text{SE}}(\widehat{\text{mse}}) = + \sqrt{\widehat{\text{Var}}(\text{sqe}_i) / n}, +\qquad +\widehat{\text{SE}}(\widehat{\text{rmse}}) = + \frac{\widehat{\text{SE}}(\widehat{\text{mse}})}{2\,\widehat{\text{rmse}}} . +$$ + +**Implementation.** + +```{r point-error} +mu_cont <- lapply(fits_cont, brms::posterior_epred) + +lapply(mu_cont, function(mu) measure_mae(y = y_cont, mupred = mu)) +lapply(mu_cont, function(mu) measure_mse(y = y_cont, mupred = mu)) +lapply(mu_cont, function(mu) measure_rmse(y = y_cont, mupred = mu)) +``` + +**Plot.** Each point is one child. Each vertical segment is the error of the +point prediction, the distance to the dashed diagonal $y = \hat y$. Shorter +segments are better. + +```{r point-error-plot} +df_pe <- do.call(rbind, lapply(names(mu_cont), function(m) { + data.frame(model = m, y = y_cont, yhat = colMeans(mu_cont[[m]])) +})) + +ggplot(df_pe, aes(yhat, y)) + + geom_segment(aes(xend = yhat, yend = yhat), alpha = 0.3) + + geom_abline(linetype = "dashed") + + geom_point(size = 0.8) + + facet_wrap(~model) + + labs(x = "point prediction", y = "observed kid_score") +``` + +**Interpretation.** The intercept-only model predicts the average score for +every child. All its points form one vertical column, and each error is the +distance of the child's score from the average. The model with predictors +spreads the predictions along the diagonal. Its segments are shorter on +average, so its MAE and RMSE are lower. + +## Predictive $R^2$ {#predictive-r2} + +**Motivation.** The predictive $R^2$ compares the squared error of the model +with the squared error of the simplest prediction, the mean of the +observations. A value of 0 means the model predicts no better than the mean. + +**When to use.** Use it for continuous outcomes, when a unitless summary of the +point prediction is needed. It is a predictive version of the classical $R^2$, +not the Bayesian $R^2$ of Gelman et al. (2019). It needs `mupred`. + +**Key formula.** With $\text{sqe}_i$ and $\widehat{\text{mse}}$ from the +[point error](#point-error) section (Vehtari et al., 2026, Eqs. 2.35, 2.36), + +$$ +\widehat{R^2} = 1 - \frac{\widehat{\text{mse}}}{\widehat{\text{mse}}_y}, +\qquad +\widehat{\text{mse}}_y = \frac{1}{n}\sum_{i=1}^n (y_i - \bar y)^2 . +$$ + +$R^2$ is a utility. + +**Standard error.** $R^2$ is a function of two means, so its standard error +uses the delta method. With $c = \widehat{\text{mse}} / +\widehat{\text{mse}}_y$ (Vehtari et al., 2026, Eq. 2.39), + +$$ +\widehat{\text{SE}}(\widehat{R^2}) = \frac{1}{\widehat{\text{mse}}_y} + \sqrt{\widehat{\text{Var}}\!\left(\text{sqe}_i - c\,(y_i - \bar y)^2\right) / n} . +$$ + +**Implementation.** + +```{r r2} +lapply(mu_cont, function(mu) measure_r2(y = y_cont, mupred = mu)) +``` + +**Plot.** Each point is one child. It compares the squared error of the model +with the squared error of the mean. Points below the dashed line are children +for whom the model is better than the mean. + +```{r r2-plot} +df_r2 <- do.call(rbind, lapply(names(mu_cont), function(m) { + data.frame( + model = m, + sqe_model = (y_cont - colMeans(mu_cont[[m]]))^2, + sqe_mean = (y_cont - mean(y_cont))^2 + ) +})) + +ggplot(df_r2, aes(sqe_mean, sqe_model)) + + geom_abline(linetype = "dashed") + + geom_point(alpha = 0.5) + + scale_x_sqrt() + + scale_y_sqrt() + + facet_wrap(~model) + + labs(x = "squared error of the mean (square-root scale)", + y = "squared error of the model (square-root scale)") +``` + +**Interpretation.** The intercept-only model predicts the average score, so +its squared errors are the squared errors of the mean. Its points lie on the +dashed line, and its $R^2$ is close to 0. The model with predictors moves +points off the line. Points below the line outweigh points above it, so its +$R^2$ is positive. + +## Classification accuracy {#classification-accuracy} + +**Motivation.** Accuracy is the proportion of observations whose predicted class +is the observed class. It is easy to interpret, but it uses only the predicted +class, not the predictive probabilities. Balanced accuracy gives each class the +same weight. It prevents a model from scoring well by predicting only the most +frequent class. + +**When to use.** Use them for binary or nominal outcomes. Prefer `bacc` when the +classes are unbalanced. Both need the class probabilities `mupred`: an +$S \times n$ matrix for binary outcomes, or an $S \times n \times C$ array for +$C$ classes. + +**Key formula.** The predicted class is +$\hat c_i = \arg\max_c \sum_s w_i^s\, p(\tilde y_i = c \mid \theta^s)$, and the +pointwise accuracy is $\text{acc}_i = \mathbb{1}\{\hat c_i = y_i\}$. With $n_c$ +observations in class $c$ (Vehtari et al., 2026, Eqs. 2.40–2.44), + +$$ +\widehat{\text{acc}} = \frac{1}{n}\sum_{i=1}^n \text{acc}_i, +\qquad +\widehat{\text{bacc}} = \frac{1}{C}\sum_{c=1}^C \widehat{\text{acc}}_c, +\qquad +\widehat{\text{acc}}_c = \frac{1}{n_c}\sum_{i:\, y_i = c} \text{acc}_i . +$$ + +Both are utilities. + +**Standard error.** Both use the binomial standard error, for balanced accuracy +within each class (Vehtari et al., 2026, Eqs. 2.43, 2.45): + +$$ +\widehat{\text{SE}}(\widehat{\text{acc}}) = + \sqrt{\frac{\widehat{\text{acc}}\,(1 - \widehat{\text{acc}})}{n}}, +\qquad +\widehat{\text{SE}}(\widehat{\text{bacc}}) = \frac{1}{C} + \sqrt{\sum_{c=1}^C \frac{\widehat{\text{acc}}_c\,(1 - \widehat{\text{acc}}_c)}{n_c}} . +$$ + +**Implementation.** + +```{r accuracy} +y_cat <- fits_cat[[1]]$data$y +mu_cat <- lapply(fits_cat, brms::posterior_epred) + +(acc_cat <- lapply(mu_cat, function(mu) measure_acc(y = y_cat, mupred = mu))) +(bacc_cat <- lapply(mu_cat, function(mu) measure_bacc(y = y_cat, mupred = mu))) +``` + +**Plot.** The bars show the accuracy within each observed class. The labels +give the class sizes. The dashed line is the accuracy, and the dotted line is +the balanced accuracy. Higher is better. + +```{r accuracy-plot} +df_acc <- do.call(rbind, lapply(names(mu_cat), function(m) { + acc_i <- as.vector(acc_cat[[m]]$pointwise) + data.frame( + model = m, + class = factor(sort(unique(y_cat))), + acc_c = as.vector(tapply(acc_i, y_cat, mean)), + n_c = as.vector(table(y_cat)) + ) +})) +df_lines <- data.frame( + model = names(mu_cat), + acc = sapply(acc_cat, function(r) r$estimates[, "Estimate"]), + bacc = sapply(bacc_cat, function(r) r$estimates[, "Estimate"]) +) + +ggplot(df_acc, aes(class, acc_c)) + + geom_col(fill = "grey70") + + geom_text(aes(label = paste("n =", n_c)), vjust = -0.4) + + geom_hline(data = df_lines, aes(yintercept = acc), linetype = "dashed") + + geom_hline(data = df_lines, aes(yintercept = bacc), linetype = "dotted") + + scale_y_continuous(limits = c(0, 1.05)) + + facet_wrap(~model) + + labs(x = "observed class", y = "accuracy within the class") +``` + +**Interpretation.** The intercept-only model predicts class 1, the most +frequent class, for every observation. Its accuracy is 1 in class 1 and 0 in +the other classes. Its accuracy equals the share of class 1, but its balanced +accuracy is only $1/3$. The model with predictors also classifies part of +classes 2 and 3 correctly. Its balanced accuracy is higher, although its +accuracy can be close to that of the intercept-only model. + +## References + +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 + +Vehtari, A., Axen, S., Weber, F., and Bockting, F. (2026). Predictive measures +and model comparison in the loo package: A formula reference. [TODO: arXiv ID] + +## See also + +- [Model comparison](model-comparison.html) — differences between models and + their standard errors. +- [TODO: schemes and `pred_measure()` article] + +## Appendix: model code {#appendix-model-code} + +```{r fit-models-code, ref.label="fit-models", eval=FALSE} +``` diff --git a/vignettes/articles-online-only/pred-measure-workflow.Rmd b/vignettes/articles-online-only/pred-measure-workflow.Rmd new file mode 100644 index 00000000..07277818 --- /dev/null +++ b/vignettes/articles-online-only/pred-measure-workflow.Rmd @@ -0,0 +1,890 @@ +--- +title: "Predictive schemes with pred_measure()" +author: "Florence Bockting" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + css: + - !expr system.file("rmarkdown/templates/html_vignette/resources/vignette.css", package = "rmarkdown") + - styles.css + toc: true + toc_depth: 3 +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +vignette: > + %\VignetteIndexEntry{Predictive schemes with pred_measure()} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, child="../children/SEE-ONLINE.txt", eval = if (isTRUE(exists("params"))) !params$EVAL else TRUE} +``` + +```{r setup, include=FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + message = FALSE, + warning = FALSE, + eval = params$EVAL, + fig.width = 7, + fig.height = 4, + fig.align = "center" +) +``` + +```{r, child="../children/LOAD-BRMS-GITHUB.txt", eval=params$EVAL} +``` + +## Introduction + +How well does a fitted model predict data that were not used to fit it? The +formula reference (Vehtari et al., 2026, Sec. 1) divides this question into +three questions: + +1. **What counts as a good prediction?** This is the *predictive measure*, for + example the log score or the RMSE. +2. **Which predictions are evaluated?** This is the *predictive scheme*. It + sets the observations that train the model before observation $i$ is + evaluated. +3. **How are the predictions computed?** From posterior draws, from refits, or + with importance weights. + +The [overview of predictive measures](overview-measures.html) answers the first +question. This article answers the second and the third. It shows how the +`pred_measure()` family computes any measure under four predictive schemes: +in-sample, PSIS-LOO, K-fold, and test data. + +::: {.callout .callout-note} +**What this article does not cover** + ++ **Measure definitions.** See the + [overview of predictive measures](overview-measures.html). ++ **Model comparison.** See the [model comparison](model-comparison.html) + article. ++ **Leave-one-group-out and leave-future-out schemes.** The `pred_measure()` + family has no entry point for them yet. +::: + +## Training data and evaluation data {#data-sets} + +A predictive scheme is a rule that splits the observed data. Let +$y = (y_1, \ldots, y_n)$ be the observed data. In the example of this article, +$y_i$ is the reaction time of one subject on one day, and $n = 144$. + +A predictive measure compares a prediction for $y_i$ with the observed $y_i$. +Before **loo** can compute it, two questions need an answer: + +1. **Which observations are scored?** These observations are the *evaluation + data*. The formula reference writes their indices as the evaluation set + $\mathcal{E}$. +2. **Which observations fit the model that predicts $y_i$?** These + observations are the *training data* of observation $i$. Their indices are + the training set $\mathcal{T}(i)$. + +Both sets hold indices of observations. They do not hold parameters or draws. +Two examples: + ++ **Leave-one-out.** Every observation is scored, so + $\mathcal{E} = \{1, \ldots, n\}$. All observations except $y_i$ fit the + model that predicts $y_i$, so $\mathcal{T}(i) = \{1, \ldots, n\} \setminus \{i\}$. + The training data change with $i$. ++ **Test data.** Only the 40 observations of five held-out subjects are scored, + so $\mathcal{E} = \mathcal{S}$. The other 104 observations fit the model, so + $\mathcal{T}(i) = \mathcal{R}$ for every $i$. + +With the two sets, the estimator of an additive measure is +(Vehtari et al., 2026, Eq. 1.7) + +$$ +\hat U = \sum_{i \in \mathcal{E}} u_i\!\left(p(y_i \mid y_{\mathcal{T}(i)}), y_i\right). +$$ + +$\mathcal{T}(i)$ sets the predictive distribution of $y_i$. $\mathcal{E}$ sets +the observations in the sum. Other sets answer other predictive questions +(Vehtari et al., 2026, Sec. 1.2). + +## Overview of the schemes + +**loo** has one entry point for each scheme +(Vehtari et al., 2026, Table 1, Eqs. 2.1–2.4): + +| Scheme | Training data $\mathcal{T}(i)$ | Evaluation data $\mathcal{E}$ | Predictive distribution $p^q(y_i)$ | Weights $w_i^s$ | Entry point | +| :--- | :--- | :--- | :--- | :--- | :--- | +| [in-sample](#in-sample) | $\{1, \ldots, n\}$ | $\{1, \ldots, n\}$ | $p(y_i \mid y)$ | $1/S$ | `insample_pred_measure()` | +| [PSIS-LOO](#psis-loo) | $\{1, \ldots, n\} \setminus \{i\}$ | $\{1, \ldots, n\}$ | $p(y_i \mid y_{-i})$ | PSIS weights | `loo_pred_measure()` | +| [K-fold](#k-fold) | $\{1, \ldots, n\} \setminus \mathcal{I}_{k(i)}$ | $\{1, \ldots, n\}$ | $p(y_i \mid y_{-\mathcal{I}_{k(i)}})$ | $1/S$ | `kfold_pred_measure()` | +| [test data](#test-data) | $\mathcal{R}$ | $\mathcal{S}$ | $p(y_i \mid y_{\mathcal{R}})$ | $1/S$ | `test_pred_measure()` | +A fifth function, `pred_measure()`, [adds measures](#add-measures) to an +existing result of any scheme. + +::: {.callout .callout-note} +**One formula, four schemes** + +A measure uses the same formula in every scheme. Only the draws and the +weights change (Vehtari et al., 2026, Eq. 2.5): + +$$ +\hat p^q(y_i) = \sum_{s=1}^S w_i^s\, p(y_i \mid \theta^s) . +$$ + +Thus `measure = "rps"` gives $\widehat{\text{rps}}^{\text{in}}$ in +`insample_pred_measure()` and $\widehat{\text{rps}}^{\text{LOO}}$ in +`loo_pred_measure()`. +::: + +## Notation + +The article uses the notation of the formula reference. The table maps each +symbol to an argument of the entry points or to a field of their result. + +| Symbol | Meaning | In **loo** | +| :--- | :--- | :--- | +| $q$ | predictive scheme | the entry point; `attr(x, "source")` | +| $\mathcal{E}$ | indices of the evaluation data | the observations in `y` and in the columns of the input matrices | +| $\mathcal{T}(i)$ | indices of the training data for observation $i$ | the data of the fit that gave the draws | +| $\mathcal{R}$, $\mathcal{S}$ | training set and test set of a single split | `train_data`, `test_data` | +| $\mathcal{I}_k$ | observations in fold $k$ | `attr(x, "folds")` | +| $\theta^s$ | posterior draw $s$, $s = 1, \ldots, S$ | rows of the input matrices | +| $w_i^s$ | normalized weight of draw $s$ | `log_weights` of the PSIS object for PSIS-LOO; $1/S$ otherwise | +| $\ell_i^s = \log p(y_i \mid \theta^s)$ | log density of $y_i$ under draw $s$ | `ylp`; `ylp_test` for test data | +| $\tilde y_i^s$ | posterior predictive draw | `ypred` | +| $\mathbb{E}[\tilde y_i \mid \theta^s]$ | predictive mean under draw $s$ | `mupred` | +| $u_i^q$ | pointwise term of a measure under scheme $q$ | `$pointwise` | +| $\hat U^q$, $\hat u^q$ | estimate on the sum scale and the mean scale | `$estimates[, "Estimate"]` | +| $\widehat{\text{SE}}$ | standard error of the estimate | `$estimates[, "SE"]` | + +**Inputs by measure.** Each measure needs one kind of draw. Pass only the inputs +that the requested measures need: + +| Measure | `ylp` | `ypred` | `mupred` | +| :--- | :---: | :---: | :---: | +| `elpd`, `mlpd`, `ic` | ✓ | | | +| `rps`, `srps`, `brier` | | ✓ | | +| `mae`, `mse`, `rmse`, `r2`, `acc`, `bacc` | | | ✓ | + +All measures except the log score also need the observations `y`. The list of +built-in names is in `supported_measures_list`: + +```{r load-libraries} +library(loo) +library(ggplot2) +theme_set(theme_minimal()) + +supported_measures_list +``` + +**Inputs by scheme.** The schemes differ in the fit that gives the draws: + +| Scheme | `ylp` | `ypred`, `mupred` | Extra input | +| :--- | :--- | :--- | :--- | +| in-sample | `log_lik(fit)` | `posterior_predict(fit)`, `posterior_epred(fit)` | | +| PSIS-LOO | as in-sample | as in-sample | `loo`, or `psis_object` | +| K-fold | from `kfold` | `kfold_predict(kfold)$yrep` | `kfold` | +| test data | `ylp_test = log_lik(fit_train, newdata = test_data)` | `posterior_predict(fit_train, newdata = test_data)`, … | | + +## Data and model + +**Prediction task.** The `sleepstudy` data (**lme4**) come from a study of sleep +restriction (Belenky et al., 2003). Eighteen subjects slept at most three hours +each night. The outcome `y` is the average reaction time (ms) of a subject on +one day. Days 0 and 1 were adaptation and training, so the article keeps days +2 to 9. The predictor `Days` counts the days of sleep restriction, from 0 to 7. +This gives 144 observations. + +The model is a normal regression of `y` on `Days`. It has no subject effects. +Fitting is not the topic of this article. The model code is in the +[appendix](#appendix-model-code). + +| Object | Data | Used for | +| :--- | :--- | :--- | +| `fit_sleep` | all 18 subjects, 144 observations | in-sample, PSIS-LOO, K-fold | +| `fit_sleep_train` | 13 subjects, 104 observations ($\mathcal{R}$) | test data | +| `test_data` | the other 5 subjects, 40 observations ($\mathcal{S}$) | test data | + +Each fit uses 2 chains with 200 draws after warmup, so $S = 400$. + +```{r fit-models, echo=FALSE, results="hide"} +SEED <- 42 +set.seed(SEED) + +data("sleepstudy", package = "lme4") +sleepstudy <- subset(sleepstudy, Days >= 2) +sleepstudy$Days <- sleepstudy$Days - 2 +sleepstudy$y <- sleepstudy$Reaction + +prior_sleep <- brms::prior(normal(200, 100), class = b, coef = "Intercept") + + brms::prior(normal(0, 20), class = b, coef = "Days") + + brms::prior(exponential(0.02), class = sigma) + +# all subjects +fit_sleep <- brms::brm( + y ~ 0 + Intercept + Days, + data = sleepstudy, + family = gaussian(), + prior = prior_sleep, + chains = 2, iter = 400, seed = SEED, refresh = 0 +) + +# five subjects held out as test data +test_subjects <- sample(unique(sleepstudy$Subject), size = 5) +train_data <- subset(sleepstudy, !Subject %in% test_subjects) +test_data <- subset(sleepstudy, Subject %in% test_subjects) + +fit_sleep_train <- update(fit_sleep, newdata = train_data, seed = SEED, refresh = 0) +``` +The draws of `fit_sleep` are the input for the in-sample and the PSIS-LOO +scheme. All schemes request the same measures: + +```{r inputs} +y_sleep <- fit_sleep$data$y +ylp_sleep <- brms::log_lik(fit_sleep) +ypred_sleep <- brms::posterior_predict(fit_sleep) +mupred_sleep <- brms::posterior_epred(fit_sleep) + +measures <- c("elpd", "mlpd", "rps", "rmse", "r2") +``` + +## In-sample {#in-sample} + +**Predictive question.** How well does the fitted model describe the data used +to fit it? + +**Predictive distribution.** The draws come from the posterior of all data. All +draws get the same weight, and $\mathcal{E} = \{1, \ldots, n\}$ +(Vehtari et al., 2026, Eqs. 2.1, 2.5): + +$$ +\hat p^{\text{in}}(y_i) = \frac{1}{S}\sum_{s=1}^S p(y_i \mid \theta^s), +\qquad \theta^s \sim p(\theta \mid y) . +$$ + +**Inputs.** `ylp`, `ypred`, and `mupred` from `fit_sleep`, and the +observations `y`. + +**Implementation.** + +```{r insample} +insample_sleep <- insample_pred_measure( + y = y_sleep, + ypred = ypred_sleep, + mupred = mupred_sleep, + ylp = ylp_sleep, + measure = measures +) +insample_sleep +``` + +**Result.** The rows have no suffix. The result holds `$estimates` and +`$pointwise`. `elpd` is on the sum scale, and the other measures are on the +mean scale (Vehtari et al., 2026, Eq. 2.7). Two attributes identify the result: + +```{r insample-attributes} +attributes(insample_sleep)[c("source", "dims")] +``` + +**Interpretation.** The model has already seen each $y_i$ that it predicts. +Thus the in-sample estimates are optimistic for new data. They are not an +estimate of out-of-sample performance. Use them as a reference point: the +difference to a cross-validation estimate shows how optimistic they are +(Vehtari et al., 2026, Sec. 1.2). + +## PSIS-LOO {#psis-loo} + +**Predictive question.** How well does the model predict a new observation that +is exchangeable with the observed data? + +**Predictive distribution.** Exact leave-one-out cross-validation needs one +refit for each observation, here 144. PSIS-LOO uses the draws of the full-data +fit instead. It gives them Pareto-smoothed importance weights, so that each +$y_i$ is scored as if it was left out (Vehtari et al., 2026, Eqs. 2.2, 2.5; +Vehtari et al., 2024): + +$$ +\hat p^{\text{LOO}}(y_i) = \sum_{s=1}^S w_i^s\, p(y_i \mid \theta^s), +\qquad \theta^s \sim p(\theta \mid y) . +$$ + +**Inputs.** The same draws as in-sample. Add the PSIS weights in one of three +ways: + +| Input | Call | +| :--- | :--- | +| a `loo` object | `loo_pred_measure(loo = loo_sleep, ...)` | +| `ylp` and a `psis` object | `loo_pred_measure(ylp = ylp_sleep, psis_object = psis_sleep, ...)` | +| `ylp` only | `loo_pred_measure(ylp = ylp_sleep, ...)` | + +With `ylp` only, `loo_pred_measure()` computes the weights with `r_eff = 1`. + +**Implementation.** Set `save_psis = TRUE` in `loo()`. Without it, +`loo_pred_measure()` stops with an error. + +```{r loo} +loo_sleep <- brms::loo(fit_sleep, save_psis = TRUE) + +loo_sleep_measure <- loo_pred_measure( + loo = loo_sleep, + y = y_sleep, + ypred = ypred_sleep, + mupred = mupred_sleep, + measure = measures +) +loo_sleep_measure +``` + +**Result.** The rows have the suffix `_loo`. The measure `elpd` also adds +`p_loo`, the difference between the in-sample and the LOO log score +(Vehtari et al., 2026, Eq. 2.19). The result has two more fields: + ++ `$diagnostics$pareto_k`: one Pareto $\hat k$ for each observation. A value + above $\min(1 - 1/\log_{10} S,\, 0.7)$ shows an unreliable weight. For + $S = 400$ this threshold is 0.62. `print()` shows a table of the $\hat k$ + values when at least one value is above the threshold. Otherwise it prints + one line. ++ `$log_weights`: the log PSIS weights. + +**Plot.** Each point is one observation. The x-axis shows its in-sample log +score, and the y-axis its LOO log score. The vertical distance to the dashed +diagonal is the pointwise $p_{\text{loo}}$. The color shows the Pareto +$\hat k$. + +```{r loo-plot} +df_loo <- data.frame( + insample = insample_sleep$pointwise[, "elpd"], + loo = loo_sleep_measure$pointwise[, "elpd_loo"], + pareto_k = loo_sleep_measure$diagnostics$pareto_k +) + +ggplot(df_loo, aes(insample, loo, color = pareto_k)) + + geom_abline(linetype = "dashed") + + geom_point() + + scale_color_viridis_c() + + labs(x = "pointwise in-sample log score", + y = "pointwise LOO log score", + color = "Pareto k") +``` + +**Interpretation.** Points below the diagonal are observations that are harder +to predict when they are left out. The farther a point lies from the diagonal, +the more the observation influences the posterior. Such observations often have +a high Pareto $\hat k$. The model has three parameters. A `p_loo` much larger +than three can show that the model is misspecified (see `?loo-glossary`). + +## K-fold {#k-fold} + +**Predictive question.** How well does the model predict held-out folds? + +**Predictive distribution.** The data are split into $K$ folds +$\mathcal{I}_1, \ldots, \mathcal{I}_K$. The model is fit once for each fold, +without the observations in that fold. This needs $K$ fits, not $n$ +(Vehtari et al., 2026, Eqs. 2.3, 2.5): + +$$ +\hat p^{K\text{-fold}}(y_i) = \frac{1}{S}\sum_{s=1}^S p(y_i \mid \theta^s), +\qquad \theta^s \sim p(\theta \mid y_{-\mathcal{I}_{k(i)}}) . +$$ + +**Inputs.** **loo** does not refit the model. `kfold_pred_measure()` takes +`elpd_kfold` and `p_kfold` from a `kfold` object, for example from +`brms::kfold()`. For the other measures, pass the draws of the held-out fits +from `brms::kfold_predict()`: `method = "predict"` gives `ypred`, and +`method = "fitted"` gives `mupred`. + +**Implementation.** Set `save_fits = TRUE` in `brms::kfold()`. Without the +fits, `brms::kfold_predict()` cannot compute the held-out draws. + +```{r kfold, results="hide"} +set.seed(SEED) +kfold_sleep <- brms::kfold(fit_sleep, K = 10, save_fits = TRUE) +ypred_kfold <- brms::kfold_predict(kfold_sleep, method = "predict")$yrep +mupred_kfold <- brms::kfold_predict(kfold_sleep, method = "fitted")$yrep +``` + +```{r kfold-measures} +kfold_sleep_measure <- kfold_pred_measure( + y = y_sleep, + ypred = ypred_kfold, + mupred = mupred_kfold, + kfold = kfold_sleep, + measure = measures +) +kfold_sleep_measure +``` + +**Result.** The rows have the suffix `_kfold`. The result takes the attributes +`K`, `folds`, `fold_type`, `joint`, `yhash`, and `model_name` from the `kfold` +object. It has `$diagnostics` only when the `kfold` object has them; recent +versions of `brms::kfold()` do. Their Pareto $\hat k$ describes the Monte Carlo +estimate of the log predictive density in each fold. K-fold uses no importance +weights. + +**Interpretation.** With $K = 10$, each fit uses 90% of the data. Thus K-fold +and PSIS-LOO answer almost the same question, and their estimates are usually +close. Use K-fold when PSIS-LOO shows many high Pareto $\hat k$ values. + +`brms::kfold()` also accepts `folds = "grouped"` with `group = "Subject"`. Then +each fold holds out whole subjects, and the predictive question changes to new +subjects. + +## Test data {#test-data} + +**Predictive question.** How well does the model predict data that were +withheld from the start? + +**Predictive distribution.** The data are split once into a training set +$\mathcal{R}$ and a test set $\mathcal{S}$. The model is fit to $\mathcal{R}$, +and $\mathcal{E} = \mathcal{S}$ (Vehtari et al., 2026, Eqs. 2.4, 2.5): + +$$ +\hat p^{\text{test}}(y_i) = \frac{1}{S}\sum_{s=1}^S p(y_i \mid \theta^s), +\qquad \theta^s \sim p(\theta \mid y_{\mathcal{R}}), +\qquad i \in \mathcal{S} . +$$ + +**Inputs.** The draws of `fit_sleep_train`, evaluated at `test_data` with +`newdata`. Pass the log densities of the test observations as `ylp_test`, not +as `ylp`. The log-score measures `elpd`, `mlpd`, and `ic` need `ylp_test`. + +**Implementation.** + +```{r test} +test_sleep_measure <- test_pred_measure( + y = test_data$y, + ypred = brms::posterior_predict(fit_sleep_train, newdata = test_data), + mupred = brms::posterior_epred(fit_sleep_train, newdata = test_data), + ylp_test = brms::log_lik(fit_sleep_train, newdata = test_data), + measure = measures +) +test_sleep_measure +``` + +**Result.** The rows have the suffix `_test`. The attribute `dims` gives the +size of the test set, 40 observations, not the size of the training set. + +**Interpretation.** The test set holds five subjects that the model did not +see. Thus the predictive question is about new subjects, not about new +observations of known subjects. The test set is small, so the standard errors +are larger than in the other schemes (Vehtari et al., 2026, Eq. 2.8). One split +also depends on which subjects are in the test set. A different split can give +a different estimate. + +## Computing leave-one-out predictions {#computing-loo} + +The scheme sets the predictive distribution $p(y_i \mid y_{-i})$. The +computation of that distribution is a separate choice +(Vehtari et al., 2026, Sec. 1.3). Exact LOO fits the model once for each +observation, here 144 times. The approximations in the table need fewer fits. + +::: {.callout .callout-warning} +**Moment matching and reloo give correct `elpd` only** + +Both methods update `elpd_loo` for the observations with a high Pareto +$\hat k$. The other measures do not get this update: + ++ `loo_moment_match()` computes new weights for *transformed* draws. It stores + the weights in the `psis` object, but not the transformed draws. `ypred` and + `mupred` still hold the original draws, so they do not match the weights. ++ `reloo` refits the model and replaces `elpd_loo`. It keeps the old PSIS + weights and sets the Pareto $\hat k$ of these observations to 0. The other + measures then use unreliable weights, and the diagnostics do not show it. + +For `elpd`, `mlpd`, and `ic`, pass the updated `loo` object to +`loo_pred_measure()`. For the other measures, use exact LOO, mixture importance +sampling, or K-fold. +::: + +| Method | Fits | Use when | Call | Entry point | +| :--- | :--- | :--- | :--- | :--- | +| exact LOO | $n$ | the model is fast, or $n$ is small | `brms::kfold(fit, folds = "loo", save_fits = TRUE)` | `kfold_pred_measure()`, all measures | +| PSIS-LOO | 1 | all Pareto $\hat k$ are below the threshold | `loo(fit, save_psis = TRUE)` | `loo_pred_measure()`, all measures | +| PSIS-LOO with moment matching | 1 | some $\hat k$ are high; the fit keeps all draws (`save_pars(all = TRUE)` in **brms**) | `loo(fit, moment_match = TRUE, save_psis = TRUE)` | `loo_pred_measure()`, log score only | +| PSIS-LOO with reloo | 1, plus one for each high $\hat k$ | few $\hat k$ are high | `loo(fit, reloo = TRUE, save_psis = TRUE)` | `loo_pred_measure()`, log score only | +| mixture importance sampling | 1, of a mixture posterior | many $\hat k$ are high | a fit with one extra term, weights by hand | `loo_pred_measure()` with `ylp` and `psis_object`, all measures | +| subsampling | 1 | $n$ is large | `loo_subsample(fit, observations = m)` | not supported | +| K-fold | $K$ | many $\hat k$ are high, or LOO is too slow | `brms::kfold(fit, K = 10, save_fits = TRUE)` | `kfold_pred_measure()`, all measures | + +The **loo** articles describe the methods in detail: +[moment matching](../loo2-moment-matching.html), +[mixture importance sampling](../loo2-mixis.html), and +[subsampling for large data](../loo2-large-data.html). + +The subsections below run each method on `fit_sleep`. The +[comparison](#compare-schemes) at the end of the article plots all results. +PSIS-LOO and K-fold are in the sections above. + +### Exact LOO {#exact-loo} + +`brms::kfold()` with `folds = "loo"` fits the model 144 times, once without +each observation. The result is a `kfold` object. Thus its rows have the suffix +`_kfold`, although the scheme is leave-one-out. Exact LOO is the reference for +all approximations in this section. + +```{r exact-loo, results="hide"} +exact_loo <- brms::kfold(fit_sleep, folds = "loo", save_fits = TRUE) +ypred_exact <- brms::kfold_predict(exact_loo, method = "predict")$yrep +mupred_exact <- brms::kfold_predict(exact_loo, method = "fitted")$yrep +``` + +```{r exact-loo-measures} +exact_measure <- kfold_pred_measure( + y = y_sleep, + ypred = ypred_exact, + mupred = mupred_exact, + kfold = exact_loo, + measure = measures +) +exact_measure +``` + +### Moment matching {#moment-matching} + +Moment matching transforms the draws for each observation with a high Pareto +$\hat k$, until the importance weights are reliable +(Paananen et al., 2021). **brms** needs all draws of the fit, so refit the +model with `save_pars(all = TRUE)`. + +```{r moment-matching, results="hide"} +fit_sleep_mm <- update(fit_sleep, save_pars = brms::save_pars(all = TRUE), + seed = SEED, refresh = 0) +loo_mm <- brms::loo(fit_sleep_mm, moment_match = TRUE, save_psis = TRUE) +``` + +Request only the log score, see the warning above: + +```{r moment-matching-measures} +mm_measure <- loo_pred_measure(loo = loo_mm, measure = c("elpd", "mlpd")) +mm_measure +``` + +All Pareto $\hat k$ of this model are below the threshold. Thus moment matching +transforms no draws, and the result equals PSIS-LOO of `fit_sleep_mm`. + +### Reloo {#reloo} + +`reloo` refits the model once for each observation with a high Pareto $\hat k$. + +```{r reloo, results="hide"} +loo_reloo <- brms::loo(fit_sleep, reloo = TRUE, save_psis = TRUE) +``` + +```{r reloo-measures} +reloo_measure <- loo_pred_measure(loo = loo_reloo, measure = c("elpd", "mlpd")) +reloo_measure +``` + +No Pareto $\hat k$ is above the threshold, so `reloo` runs no refits. The +result equals PSIS-LOO. + +### Mixture importance sampling {#mixture-is} + +PSIS-LOO takes its draws from the full-data posterior. When many observations +have a high Pareto $\hat k$, these draws cover the leave-one-out posteriors +badly. Mixture importance sampling takes its draws from a mixture of all +leave-one-out posteriors instead (Silva and Zanella, 2022): + +$$ +q_{\text{mix}}(\theta) \propto p(\theta \mid y) + \sum_{i=1}^n p(y_i \mid \theta)^{-1} . +$$ + +**Fit.** The mixture adds one term to the log density of the model. Add it to +the Stan code of **brms** with a `stanvar`. `Y`, `X`, `b`, and `sigma` are the +names in the code that **brms** writes for this model; check them with +`brms::stancode()` for other models. + +```{r mixis-fit, results="hide"} +mixis_term <- brms::stanvar( + scode = " + { + vector[N] log_lik_mix; + for (n in 1:N) { + log_lik_mix[n] = normal_lpdf(Y[n] | X[n] * b, sigma); + } + target += log_sum_exp(-log_lik_mix); + }", + block = "likelihood" +) + +fit_sleep_mix <- brms::brm( + y ~ 0 + Intercept + Days, + data = sleepstudy, + family = gaussian(), + prior = prior_sleep, + stanvars = mixis_term, + chains = 2, iter = 400, seed = SEED, refresh = 0 +) +``` + +**Weights.** For observation $i$, the importance weight of the mixture draw +$\theta^s$ is + +$$ +\log w_i^s = -\ell_i^s - \log \sum_{j=1}^n \exp(-\ell_j^s) + \text{const} . +$$ + +`loo_pred_measure()` normalizes the weights. Pass them in a list as +`psis_object`, together with the log densities and the predictive draws of the +mixture fit: + +```{r mixis-measures} +ylp_mix <- brms::log_lik(fit_sleep_mix) +log_weights_mix <- -ylp_mix - matrixStats::rowLogSumExps(-ylp_mix) + +mixis_measure <- loo_pred_measure( + ylp = ylp_mix, + psis_object = list(log_weights = log_weights_mix), + y = y_sleep, + ypred = brms::posterior_predict(fit_sleep_mix), + mupred = brms::posterior_epred(fit_sleep_mix), + measure = c("mlpd", "rps", "rmse", "r2") +) +mixis_measure +``` + +The draws come from the mixture, not from the posterior. Thus the result has +no Pareto $\hat k$. It has no `elpd` row either: `p_loo` compares the LOO log +score with the in-sample log score of the posterior draws, and those draws are +missing. + +### Subsampling {#subsampling} + +For large $n$, even PSIS-LOO is slow. `loo_subsample()` computes the LOO log +score for a random subsample of $m$ observations. It estimates `elpd_loo` for +all $n$ observations from this subsample. + +```{r subsampling} +set.seed(SEED) +loo_ss <- brms::loo_subsample(fit_sleep, observations = 50) +loo_ss +``` + +`loo_pred_measure()` does not accept this result. Its PSIS object holds weights +for the 50 subsampled observations only. Thus subsampling gives the log score +only, with an additional subsampling standard error. + +## Add measures to an existing result {#add-measures} + +`pred_measure()` adds measures to a result of any entry point. It takes the +scheme from the result. It does not recompute the rows that are already +stored. If a requested measure is already stored, `pred_measure()` warns and +skips it. + +| Approach | When to use | Call | +| :--- | :--- | :--- | +| **one call** | you know all measures beforehand | `loo_pred_measure(..., measure = c("rps", "r2"))` | +| **step by step** | you explore, or you add measures later | `pred_measure(..., predperf = result, measure = "r2")` | + +**Implementation.** For PSIS-LOO, set `save_psis = TRUE` in the first call. +`pred_measure()` then reuses the stored PSIS object and its diagnostics. + +```{r add-measures} +loo_elpd <- loo_pred_measure(loo = loo_sleep, save_psis = TRUE) +loo_elpd + +pred_measure( + y = y_sleep, + mupred = mupred_sleep, + predperf = loo_elpd, + measure = c("mae", "rmse") +) +``` + +The first call uses the default `measure = NULL`, which gives `elpd`. The +second call adds `mae_loo` and `rmse_loo` with the stored PSIS weights. + +## Custom measures {#custom-measures} + +`measure` also accepts functions. A custom function must follow three rules: + ++ **Arguments.** Name the arguments from `y`, `ypred`, `mupred`, `ylp`, and + `log_weights`. **loo** supplies each of these names that appears in the + function. ++ **Weights.** `log_weights` holds the PSIS weights for PSIS-LOO. In the other + schemes it is `NULL`. A function that ignores `log_weights` gives in-sample + values under PSIS-LOO. ++ **Return value.** Return a list with `estimate`, `se`, and `pointwise`. + +Pass the function in a named list. The name becomes the row name, for example +`list("rps", cover90 = coverage)`. + +**Example.** The coverage of the central 90% predictive interval is the +proportion of observations inside that interval. For a calibrated model it is +close to 0.9. Observation $i$ is inside the interval when its probability +integral transform lies between 0.05 and 0.95: + +$$ +\text{pit}_i = \sum_{s=1}^S w_i^s\, \mathbb{1}\{\tilde y_i^s \le y_i\}, +\qquad +\text{cover}_i = \mathbb{1}\{0.05 < \text{pit}_i \le 0.95\} . +$$ + +```{r custom-function} +coverage <- function(y, ypred, log_weights = NULL, prob = 0.9) { + if (is.null(log_weights)) { + log_weights <- matrix(-log(nrow(ypred)), nrow(ypred), ncol(ypred)) + } + w <- exp(sweep(log_weights, 2, matrixStats::colLogSumExps(log_weights))) + pit <- colSums(w * sweep(ypred, 2, y, "<=")) + alpha <- 1 - prob + cover_i <- as.numeric(pit > alpha / 2 & pit <= 1 - alpha / 2) + list( + estimate = mean(cover_i), + se = sqrt(var(cover_i) / length(cover_i)), + pointwise = cover_i + ) +} +``` + +**Implementation.** The same function works in every scheme: + +```{r custom-measures} +insample_pred_measure( + y = y_sleep, + ypred = ypred_sleep, + measure = list("rps", cover90 = coverage) +) + +loo_pred_measure( + loo = loo_sleep, + y = y_sleep, + ypred = ypred_sleep, + measure = list("rps", cover90 = coverage) +) +``` + +## Compare the schemes and methods {#compare-schemes} + +The results use the same model and the same measures. They differ in the +scheme, which sets the predictive question, and in the method, which computes +the predictions. + +Compare the results on the mean scale. `elpd` is a sum over $\mathcal{E}$ +(Vehtari et al., 2026, Eq. 2.7). The test set has 40 observations and the other +schemes have 144, so their `elpd` values are not comparable. `mlpd` removes +this dependence. The subsampling result has only `elpd_loo`. Divide its +estimate and its standard error by $n$ to get `mlpd`. + +```{r compare-table} +results <- list( + "in-sample" = insample_sleep, + "exact LOO" = exact_measure, + "PSIS-LOO" = loo_sleep_measure, + "PSIS-LOO, moment matching" = mm_measure, + "PSIS-LOO, reloo" = reloo_measure, + "mixture IS" = mixis_measure, + "K-fold" = kfold_sleep_measure, + "test data" = test_sleep_measure +) + +df_methods <- do.call(rbind, lapply(names(results), function(method) { + est <- results[[method]]$estimates + measure <- sub("_(loo|kfold|test)$", "", rownames(est)) + keep <- measure %in% c("mlpd", "rps", "rmse", "r2") + data.frame( + method = method, + measure = measure[keep], + estimate = est[keep, "Estimate"], + se = est[keep, "SE"], + row.names = NULL + ) +})) + +n_sleep <- length(y_sleep) +df_methods <- rbind(df_methods, data.frame( + method = "subsampling", + measure = "mlpd", + estimate = loo_ss$estimates["elpd_loo", "Estimate"] / n_sleep, + se = loo_ss$estimates["elpd_loo", "SE"] / n_sleep +)) + +method_levels <- c("in-sample", "exact LOO", "PSIS-LOO", + "PSIS-LOO, moment matching", "PSIS-LOO, reloo", + "mixture IS", "subsampling", "K-fold", "test data") +df_methods$method <- factor(df_methods$method, levels = rev(method_levels)) +df_methods$scheme <- factor( + ifelse(df_methods$method %in% c("in-sample", "K-fold", "test data"), + as.character(df_methods$method), "leave-one-out"), + levels = c("in-sample", "leave-one-out", "K-fold", "test data") +) +df_methods[order(df_methods$measure, df_methods$method, decreasing = TRUE), ] +``` + +**Plot.** Each panel shows one measure. Each row is one method, and the color +shows its scheme. The point is the estimate, and the bar is $\pm 1$ standard +error. `mlpd` and `r2` are utilities: higher is better. `rps` and `rmse` are +losses: lower is better. Moment matching, reloo, and subsampling have a point +in the `mlpd` panel only. + +```{r compare-plot, fig.height=6} +ggplot(df_methods, aes(estimate, method, color = scheme)) + + geom_pointrange(aes(xmin = estimate - se, xmax = estimate + se)) + + facet_wrap(~measure, scales = "free_x") + + scale_color_manual(values = c("in-sample" = "grey50", + "leave-one-out" = "#0072B2", + "K-fold" = "#009E73", + "test data" = "#D55E00")) + + labs(x = "estimate ± SE", y = NULL, color = "scheme") + + theme(legend.position = "bottom") +``` + +**Interpretation.** In-sample, leave-one-out, and K-fold score the same 144 +observations. The in-sample estimates are the most optimistic for every +measure, because the model has seen each $y_i$. K-fold answers almost the same +question as leave-one-out, so its estimates are close. + +All leave-one-out methods agree with exact LOO. The largest difference is in +`rps`: PSIS-LOO gives 28.47 and exact LOO 28.76. This difference is much +smaller than the standard error of 1.8. Mixture importance sampling gives 28.76. +All Pareto $\hat k$ are good, so moment matching and reloo change nothing, and +their `mlpd` equals that of PSIS-LOO. For a model with many high $\hat k$, the +methods differ more. Then exact LOO, mixture importance sampling, or K-fold +give the reliable values for all measures. + +The test data score better than all other schemes here. One split gives a noisy +estimate: the five test subjects are easier to predict than the average +subject. The standard errors show this. The `rmse` of the test data has a +standard error more than twice as large as in the other schemes, because the +test set has 40 observations, not 144. + +The standard errors describe the uncertainty from the finite +evaluation set. They do not include the Monte Carlo error from the finite +number of draws (Vehtari et al., 2026, Sec. 2.2). + +## References + +Belenky, G., Wesensten, N. J., Thorne, D. R., et al. (2003). Patterns of +performance degradation and restoration during sleep restriction and subsequent +recovery: A sleep dose-response study. *Journal of Sleep Research*, +12(1):1–12. + +Paananen, T., Piironen, J., Bürkner, P.-C., and Vehtari, A. (2021). Implicitly +adaptive importance sampling. *Statistics and Computing*, 31(2):16. + +Silva, L. and Zanella, G. (2022). Robust leave-one-out cross-validation for +high-dimensional Bayesian models. Preprint at +[arXiv:2209.09190](https://arxiv.org/abs/2209.09190). + +Vehtari, A., Axen, S., Weber, F., and Bockting, F. (2026). Predictive measures +and model comparison in the loo package: A formula reference. [TODO: arXiv ID] + +Vehtari, A., Gelman, A., and Gabry, J. (2017). Practical Bayesian model +evaluation using leave-one-out cross-validation and WAIC. *Statistics and +Computing*, 27(5):1413–1432. doi:10.1007/s11222-016-9696-4 + +Vehtari, A., Simpson, D., Gelman, A., Yao, Y., and Gabry, J. (2024). Pareto +smoothed importance sampling. *Journal of Machine Learning Research*, +25(72):1–58. + +## See also + +- [Overview of predictive measures](overview-measures.html) — definitions, + formulas, and standard errors of the measures. +- [Model comparison](model-comparison.html) — differences between models and + their standard errors. +- [Cross-validation FAQ](https://users.aalto.fi/~ave/CV-FAQ.html) — when to use + which cross-validation scheme. + +## Appendix: model code {#appendix-model-code} + +```{r fit-models-code, ref.label="fit-models", eval=FALSE} +``` diff --git a/vignettes/articles-online-only/styles.css b/vignettes/articles-online-only/styles.css new file mode 100644 index 00000000..7afc3951 --- /dev/null +++ b/vignettes/articles-online-only/styles.css @@ -0,0 +1,41 @@ +/* Base Callout Styling */ +.callout { + padding: 1rem 1rem 1rem 1.2rem; + margin: 1.5rem 0; + border-left: 5px solid #ccc; + background-color: #f8f9fa; + border-radius: 0.25rem; +} + +/* Callout Variations */ +.callout-note { + border-left-color: #0d6efd; /* Blue */ + background-color: #cfe2ff22; +} + +.callout-warning { + border-left-color: #ffc107; /* Yellow/Amber */ + background-color: #fff3cd22; +} + +.callout-tip { + border-left-color: #198754; /* Green */ + background-color: #d1e7dd22; +} + +.callout-message { + border-left-color: #bec0bf; /* Grey */ + background-color: #d1e7dd22; +} + +/* Optional: Style headings inside callouts to match */ +.callout p:first-child { + font-weight: bold; + margin-top: 0; +} + +/* Make output scrollable +.scroll-output { + max-height: 300px; + overflow-y: auto; +} \ No newline at end of file diff --git a/vignettes/children/LOAD-BRMS-GITHUB.txt b/vignettes/children/LOAD-BRMS-GITHUB.txt new file mode 100644 index 00000000..d4ca5078 --- /dev/null +++ b/vignettes/children/LOAD-BRMS-GITHUB.txt @@ -0,0 +1,8 @@ +```{r load-brms-github, include=FALSE} +# Features used in these vignettes require brms from GitHub master (not yet on CRAN). +if (!requireNamespace("remotes", quietly = TRUE)) { + install.packages("remotes") +} +remotes::install_github("paul-buerkner/brms", ref = "master", upgrade = "never") +suppressPackageStartupMessages(library(brms)) +``` diff --git a/vignettes/migration-guide.Rmd b/vignettes/migration-guide.Rmd index 8b265380..b53c3ae4 100644 --- a/vignettes/migration-guide.Rmd +++ b/vignettes/migration-guide.Rmd @@ -47,6 +47,13 @@ branch and will extend this guide when merged into `loo-v3.0.0`. | File | Status | Replacement / notes | |------|--------|---------------------| +| `R/elpd.R` | Deprecated | `measure_elpd()` in `R/pred_measure-builtin.R` | +| `R/crps.R` | Deprecated | `measure_rps()`, `measure_srps()`, `loo_pred_measure()` | +| `R/loo_predictive_metric.R` | Deprecated | `loo_pred_measure()`, `measure_*()` | +| `R/pred_measure.R` | **Current** | `*_pred_measure()` entry points | +| `R/pred_measure-compute.R` | **Current** | Internal orchestration | +| `R/pred_measure-helpers.R` | **Current** | Validation and helpers | +| `R/pred_measure-builtin.R` | **Current** | `measure_*()` implementations | | `R/compare.R` | Deprecated (removal in 3.0.0) | `loo_compare()` in `R/loo_compare.R` | | `R/psislw.R` | Deprecated (removal in 3.0.0) | `psis()` in `R/psis.R` (since 2.0.0) | | `R/loo_compare.R` | **Current** | Model comparison | @@ -56,6 +63,107 @@ branch and will extend this guide when merged into `loo-v3.0.0`. # Function migration tables +## Expected log predictive density + +| Deprecated | Replacement | Since | Planned removal | +|------------|-------------|-------|-----------------| +| `elpd()` | `measure_elpd()` | 3.0.0 | | + +**Return type change:** `elpd()` returns class `"elpd_generic"` with `elpd` and +`ic` columns in `pointwise`. `measure_elpd()` returns class `"measure"`. + +```r +# Deprecated +elpd(log_lik_matrix) + +# Current +measure_elpd(log_lik_matrix) +``` + +## Scoring rules (CRPS / SCRPS) + +| Deprecated | Replacement | Since | Planned removal | +|------------|-------------|-------|-----------------| +| `crps(x, x2, y)` | `measure_rps(y, ypred = x)` | 3.0.0 | | +| `scrps(x, x2, y)` | `measure_srps(y, ypred = x)` | 3.0.0 | | +| `loo_crps(...)` | `loo_pred_measure(..., measure = "rps")` | 3.0.0 | | +| `loo_scrps(...)` | `loo_pred_measure(..., measure = "srps")` | 3.0.0 | | + +**API change:** deprecated functions require **two** draw matrices (`x`, `x2`) +and use a permutation-based estimator. The replacement uses **one** draw +matrix (`ypred`) and a PWM estimator. Results are not identical. + +```r +# Deprecated +crps(ypred1, ypred2, y = y) + +# Current +measure_rps(y = y, ypred = ypred1) +``` + +## Leave-one-out predictive metrics + +| Deprecated | Replacement | Since | Planned removal | +|------------|-------------|-------|-----------------| +| `loo_predictive_metric()` | `loo_pred_measure()` | 3.0.0 | | + +**Argument mapping:** + +| Old (`loo_predictive_metric`) | New (`loo_pred_measure`) | +|-------------------------------|--------------------------| +| `x` (predictions) | `mupred` | +| `log_lik` | via `loo(..., save_psis = TRUE)` or `ylp` + `psis_object` | +| `metric = "mae"` | `measure = "mae"` | +| `metric = "balanced_acc"` | `measure = "bacc"` | + +```r +# Deprecated +loo_predictive_metric(x = mupred, y = y, log_lik = ll, metric = "mae") + +# Current +loo_fit <- loo(ll, save_psis = TRUE) +loo_pred_measure(loo = loo_fit, y = y, mupred = mupred, measure = "mae") +``` + +--- + +# Current predictive performance API (3.0.0) + +## Workflow entry points + +| Function | Evaluation mode | Source file | +|----------|-----------------|-------------| +| `insample_pred_measure()` | In-sample | `pred_measure.R` | +| `loo_pred_measure()` | PSIS-LOO | `pred_measure.R` | +| `kfold_pred_measure()` | K-fold CV | `pred_measure.R` | +| `test_pred_measure()` | Holdout test set | `pred_measure.R` | +| `pred_measure()` | Add measures incrementally | `pred_measure.R` | + +## Built-in measures + +Pass short names to the `measure` argument, or call standalone functions: + +| `measure =` | Function | Source file | +|-------------|----------|-------------| +| `"elpd"` | `measure_elpd()` | `pred_measure-builtin.R` | +| `"mlpd"` | `measure_mlpd()` | `pred_measure-builtin.R` | +| `"ic"` | `measure_ic()` | `pred_measure-builtin.R` | +| `"mae"` | `measure_mae()` | `pred_measure-builtin.R` | +| `"mse"` | `measure_mse()` | `pred_measure-builtin.R` | +| `"rmse"` | `measure_rmse()` | `pred_measure-builtin.R` | +| `"r2"` | `measure_r2()` | `pred_measure-builtin.R` | +| `"acc"` | `measure_acc()` | `pred_measure-builtin.R` | +| `"bacc"` | `measure_bacc()` | `pred_measure-builtin.R` | +| `"rps"` | `measure_rps()` | `pred_measure-builtin.R` | +| `"srps"` | `measure_srps()` | `pred_measure-builtin.R` | + +List all registered built-in names: + +```r +supported_measures_list() +``` + +`measure_brier()` is exported but not yet registered in `supported_measures_list()`. ## Model comparison | Deprecated | Replacement | Since | Planned removal | @@ -141,7 +249,7 @@ replacements are not yet exported here. # Maintainer checklist -When deprecating or removing a function: +When deprecating or removing a function on this branch: 1. Add `.Deprecated("replacement")` in each exported method (only if the replacement exists in the same branch). @@ -171,8 +279,25 @@ articles: - migration-guide reference: + - title: Predictive performance measures + desc: | + Unified API for predictive performance measures (density scores, scoring + rules, and point-prediction metrics) with in-sample, LOO, K-fold, and + holdout evaluation modes. + contents: + - insample_pred_measure + - loo_pred_measure + - kfold_pred_measure + - test_pred_measure + - pred_measure + - supported_measures_list + - starts_with("measure_") + - ptw_log_pred_density - title: Deprecated functions contents: + - elpd + - crps + - loo_predictive_metric - compare - psislw ```