From bba6adf37fb9fd9147e250cc4b3594638211ca51 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Wed, 10 Apr 2024 11:45:16 +0300 Subject: [PATCH 001/134] subsampling LOO estimates with diff-est-srs-wor start --- R/cv_varsel.R | 169 ++++++++------------ R/methods.R | 3 +- R/summary_funs.R | 394 +++++++++++++++++++++++++---------------------- 3 files changed, 280 insertions(+), 286 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index b92300bae..6d3bd877a 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -16,17 +16,18 @@ #' #' @inheritParams varsel #' @param cv_method The CV method, either `"LOO"` or `"kfold"`. In the `"LOO"` -#' case, a Pareto-smoothed importance sampling leave-one-out CV (PSIS-LOO CV) +#' case, a Pareto-smoothed importance sampling leave-one-out CV (PSIS-LOO-CV) #' is performed, which avoids refitting the reference model `nloo` times (in -#' contrast to a standard LOO CV). In the `"kfold"` case, a \eqn{K}-fold CV is +#' contrast to a standard LOO-CV). In the `"kfold"` case, a \eqn{K}-fold CV is #' performed. See also section "Note" below. #' @param nloo **Caution:** Still experimental. Only relevant if `cv_method = #' "LOO"`. If `nloo` is smaller than the number of all observations, -#' approximate full LOO CV using probability-proportional-to-size-sampling -#' (PPS) to make accurate computation only for `nloo` (anything from 1 to the -#' number of all observations) leave-one-out folds (Magnusson et al., 2019). -#' Smaller values lead to faster computation but higher uncertainty in the -#' evaluation part. If `NULL`, all observations are used (as by default). +#' approximate full LOO-CV using difference estimator with simple random +#' sampling (SRS) without replacement (WOR) to make accurate computation only +#' for `nloo` (anything from 1 to the number of all observations) leave-one-out +#' folds (Magnusson et al., 2020). Smaller values lead to faster computation, +#' but higher uncertainty in the evaluation part. If `NULL`, all observations +#' are used (as by default). #' @param K Only relevant if `cv_method = "kfold"` and if `cvfits` is `NULL` #' (which is the case for reference model objects created by #' [get_refmodel.stanreg()] or [brms::get_refmodel.brmsfit()]). Number of @@ -50,7 +51,7 @@ #' `NA`, then the PRNG state is reset (to the state before calling #' [cv_varsel()]) upon exiting [cv_varsel()]. Here, `seed` is used for #' clustering the reference model's posterior draws (if `!is.null(nclusters)` -#' or `!is.null(nclusters_pred)`), for subsampling PSIS-LOO CV folds (if +#' or `!is.null(nclusters_pred)`), for subsampling PSIS-LOO-CV folds (if #' `nloo` is smaller than the number of observations), for sampling the folds #' in \eqn{K}-fold CV, and for drawing new group-level effects when predicting #' from a multilevel submodel (however, not yet in case of a GAMM). @@ -70,7 +71,7 @@ #' @note If `validate_search` is `FALSE`, the search is not included in the CV #' so that only a single full-data search is run. #' -#' For PSIS-LOO CV, \pkg{projpred} calls [loo::psis()] (or, exceptionally, +#' For PSIS-LOO-CV, \pkg{projpred} calls [loo::psis()] (or, exceptionally, #' [loo::sis()], see below) with `r_eff = NA`. This is only a problem if there #' was extreme autocorrelation between the MCMC iterations when the reference #' model was built. In those cases however, the reference model should not @@ -161,7 +162,7 @@ cv_varsel.vsel <- function( cvfits = object$cvfits, validate_search = object$validate_search %||% TRUE, ... -) { + ) { arg_nms_internal <- c("method", "ndraws", "nclusters", "nterms_max", "search_control", "penalty", "search_terms") arg_nms_internal_used <- intersect(arg_nms_internal, ...names()) @@ -203,6 +204,7 @@ cv_varsel.vsel <- function( "brms:::get_refmodel.brmsfit() to some non-`NULL` value.") } } + return(cv_varsel( object = refmodel, method = object[["args_search"]][["method"]], @@ -218,6 +220,7 @@ cv_varsel.vsel <- function( cvfits = cvfits, validate_search = validate_search, search_out = nlist(search_path = object[["search_path"]], rk_foldwise), + summaries_fast = object$summaries_fast, ... )) } @@ -247,9 +250,9 @@ cv_varsel.refmodel <- function( seed = NA, search_terms = NULL, search_out = NULL, + summaries_fast = NULL, parallel = getOption("projpred.prll_cv", FALSE), - ... -) { + ...) { if (!missing(lambda_min_ratio)) { warning("Argument `lambda_min_ratio` is deprecated. Please specify ", "control arguments for the search via argument `search_control`. ", @@ -304,6 +307,7 @@ cv_varsel.refmodel <- function( ) cv_method <- args$cv_method nloo <- args$nloo + n <- object$nobs K <- args$K cvfits <- args$cvfits @@ -352,7 +356,7 @@ cv_varsel.refmodel <- function( nclusters_pred = nclusters_pred, refit_prj = refit_prj, penalty = penalty, verbose = verbose, search_control = search_control, nloo = nloo, validate_search = validate_search, - search_path_fulldata = if (validate_search) { + search_path_fulldata = if (validate_search) { # && nloo==n) { # check this # Not needed in this case, so for computational efficiency, avoiding # passing the large object `search_path_fulldata` to loo_varsel(): NULL @@ -363,6 +367,29 @@ cv_varsel.refmodel <- function( search_terms_was_null = search_terms_was_null, search_out_rks = search_out_rks, parallel = parallel, ... ) + if (is.null(sel_cv$summaries_fast) && validate_search==TRUE && nloo 0.7), n05 = sum(0.7 >= pareto_k & pareto_k > 0.5), warn_txt_start = paste0("In the calculation of the reference model's ", - "PSIS-LOO CV weights, "), + "PSIS-LOO-CV weights, "), warn_txt_mid_common = paste0(" (out of ", n, ") Pareto k-values are "), warn_txt_end = paste0( ". Moment matching (see the loo package), mixture importance ", @@ -624,7 +653,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, "are not supported by projpred. If these techniques (run outside of ", "projpred, i.e., for the reference model only; note that `reloo`-ing ", "may be computationally costly) result in a markedly different ", - "reference model ELPD estimate than ordinary PSIS-LOO CV does, we ", + "reference model ELPD estimate than ordinary PSIS-LOO-CV does, we ", "recommend to use K-fold CV within projpred." ) ) @@ -660,11 +689,13 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, refmodel$y <- y_lat_E$value } - # LOO PPS subsampling (by default, don't subsample, but use all observations): - # validset <- loo_subsample(n, nloo, pareto_k) - loo_ref_oscale <- apply(loglik_forPSIS + lw, 2, log_sum_exp) - validset <- loo_subsample_pps(nloo, loo_ref_oscale) - inds <- validset$inds + if (nloo < n) { + # Select which LOO-folds get more accurate computation using simple + # random sampling without resampling (Magnusson et al., 2020) + inds <- sample(1:n, nloo, replace=FALSE) + } else { + inds <- 1:n + } # Initialize objects where to store the results: loo_sub <- replicate(nterms_max + 1L, rep(NA, n), simplify = FALSE) @@ -676,6 +707,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, fixed = TRUE)), simplify = FALSE ) + loo_ref_oscale <- apply(loglik_forPSIS + lw, 2, log_sum_exp) if (refmodel$family$for_latent) { loo_sub_oscale <- loo_sub # In general, we could use `mu_sub_oscale <- mu_sub` here, but the case @@ -714,7 +746,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, refdist_eval <- perf_eval_out[["p_ref"]] # Step 2: Weight the full-data performance evaluation results according to - # the PSIS-LOO CV weights. + # the PSIS-LOO-CV weights. if (refmodel$family$for_latent) { refdist_eval_mu_offs_oscale <- refmodel$family$latent_ilink( t(refdist_eval$mu_offs), cl_ref = refdist_eval$cl, @@ -771,7 +803,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, if (no_psis_eval) { if (getOption("projpred.warn_psis", TRUE)) { warning( - "In the recalculation of the reference model's PSIS-LOO CV ", + "In the recalculation of the reference model's PSIS-LOO-CV ", "weights for the performance evaluation, the number of draws ", "after clustering or thinning is too small for Pareto ", "smoothing. Using standard importance sampling (SIS) instead. ", @@ -830,7 +862,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, n07 = sum(pareto_k_eval > 0.7), n05 = sum(0.7 >= pareto_k_eval & pareto_k_eval > 0.5), warn_txt_start = paste0( - "In the recalculation of the reference model's PSIS-LOO CV ", + "In the recalculation of the reference model's PSIS-LOO-CV ", "weights for the performance evaluation (based on clustered or ", "thinned posterior draws), " ), @@ -929,7 +961,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } verb_out(verb_txt_start, verb_txt_mid, "the performance evaluation with ", "`refit_prj = ", refit_prj, "` for each of the N = ", nloo, " ", - "LOO CV folds separately ...") + "LOO-CV folds separately ...") } one_obs <- function(run_index, verbose_search = verbose && @@ -1067,10 +1099,9 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, # Submodel predictive performance: summ_sub <- lapply(seq_len(prv_len_rk + 1L), function(k) { - summ_k <- list(lppd = loo_sub[[k]], mu = mu_sub[[k]], wcv = validset$wcv) + summ_k <- list(lppd = loo_sub[[k]], mu = mu_sub[[k]]) if (refmodel$family$for_latent) { - summ_k$oscale <- list(lppd = loo_sub_oscale[[k]], mu = mu_sub_oscale[[k]], - wcv = validset$wcv) + summ_k$oscale <- list(lppd = loo_sub_oscale[[k]], mu = mu_sub_oscale[[k]]) } return(summ_k) }) @@ -1187,7 +1218,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, out_list <- c(out_list, nlist(summaries, y_wobs_test = as.data.frame(refmodel[nms_y_wobs_test()]), - clust_used_eval, nprjdraws_eval)) + clust_used_eval, nprjdraws_eval, inds)) return(out_list) } @@ -1378,15 +1409,9 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, summ$mu <- summ$mu[order(idxs_sorted_by_fold_flx)] summ$lppd <- summ$lppd[order(idxs_sorted_by_fold)] - # Add fold-specific weights (see the discussion at GitHub issue #94 for why - # this might have to be changed): - summ$wcv <- rep(1, length(summ$lppd)) - summ$wcv <- summ$wcv / sum(summ$wcv) - if (!is.null(summ$oscale)) { summ$oscale$mu <- summ$oscale$mu[order(idxs_sorted_by_fold_aug)] summ$oscale$lppd <- summ$oscale$lppd[order(idxs_sorted_by_fold)] - summ$oscale$wcv <- summ$wcv } return(summ) }) @@ -1584,65 +1609,3 @@ run_cvfun.refmodel <- function(object, return(structure(cvfits, folds = folds)) } -# PSIS-LOO CV helpers ----------------------------------------------------- - -# ## decide which points to go through in the validation (i.e., which points -# ## belong to the semi random subsample of validation points) -# loo_subsample <- function(n, nloo, pareto_k) { -# # Note: A seed is not set here because this function is not exported and has -# # a calling stack at the beginning of which a seed is set. -# -# resample <- function(x, ...) x[sample.int(length(x), ...)] -# -# if (nloo < n) { -# bad <- which(pareto_k > 0.7) -# ok <- which(pareto_k <= 0.7 & pareto_k > 0.5) -# good <- which(pareto_k <= 0.5) -# inds <- resample(bad, min(length(bad), floor(nloo / 3))) -# inds <- c(inds, resample(ok, min(length(ok), floor(nloo / 3)))) -# inds <- c(inds, resample(good, min(length(good), floor(nloo / 3)))) -# if (length(inds) < nloo) { -# ## not enough points selected, so choose randomly among the rest -# inds <- c(inds, resample(setdiff(seq_len(n), inds), nloo - length(inds))) -# } -# -# ## assign the weights corresponding to this stratification (for example, -# ## the 'bad' values are likely to be overpresented in the sample) -# wcv <- rep(0, n) -# wcv[inds[inds %in% bad]] <- length(bad) / sum(inds %in% bad) -# wcv[inds[inds %in% ok]] <- length(ok) / sum(inds %in% ok) -# wcv[inds[inds %in% good]] <- length(good) / sum(inds %in% good) -# } else { -# ## all points used -# inds <- seq_len(n) -# wcv <- rep(1, n) -# } -# -# ## ensure weights are normalized -# wcv <- wcv / sum(wcv) -# -# return(nlist(inds, wcv)) -# } - -## Select which points to go through in the validation based on -## proportional-to-size subsampling (PPS) as proposed by Magnusson, M., -## Andersen, M. R., Jonasson, J. and Vehtari, A. (2019). Leave-One-Out -## Cross-Validation for Large Data. In *Proceedings of -## the 36th International Conference on Machine Learning*, edited by Kamalika -## Chaudhuri and Ruslan Salakhutdinov, 97:4244--53. Proceedings of Machine -## Learning Research. PMLR. . -loo_subsample_pps <- function(nloo, lppd) { - # Note: A seed is not set here because this function is not exported and has a - # calling stack at the beginning of which a seed is set. - - if (nloo == length(lppd)) { - inds <- seq_len(nloo) - wcv <- rep(1, nloo) - } else if (nloo < length(lppd)) { - wcv <- exp(lppd - max(lppd)) - inds <- sample(seq_along(lppd), size = nloo, prob = wcv) - } - wcv <- wcv / sum(wcv) - - return(nlist(inds, wcv)) -} diff --git a/R/methods.R b/R/methods.R index 8e25a8e96..869bc0269 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1065,7 +1065,7 @@ plot.vsel <- function( # direction = 1) ### } - if (all(stats %in% c("rmse", "auc"))) { + if (all(stats %in% c("rmse","auc"))) { ci_type <- "bootstrap " } else if (all(stats %in% c("gmpd"))) { ci_type <- "exponentiated normal-approximation " @@ -1319,7 +1319,6 @@ summary.vsel <- function( stats_table_all <- .tabulate_stats(object, stats, alpha = alpha, nfeat_baseline = nfeat_baseline_for_tab, resp_oscale = resp_oscale, ...) - # Extract the reference model performance results from `stats_table_all`: stats_table_ref <- subset(stats_table_all, stats_table_all$size == Inf) diff --git a/R/summary_funs.R b/R/summary_funs.R index e397d5bf9..3def6e7f1 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -90,8 +90,13 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, .tabulate_stats <- function(varsel, stats, alpha = 0.05, nfeat_baseline = NULL, resp_oscale = TRUE, ...) { stat_tab <- data.frame() - summ_ref <- varsel$summaries$ref - summ_sub <- varsel$summaries$sub + summaries_ref <- varsel$summaries$ref + summaries_sub <- varsel$summaries$sub + if (!is.null(varsel$summaries_fast)) { + summaries_fast_sub <- varsel$summaries_fast$sub + } else { + summaries_fast_sub <- NULL + } if (!varsel$refmodel$family$for_latent && !resp_oscale) { stop("`resp_oscale = FALSE` can only be used in case of the latent ", @@ -99,12 +104,12 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, } if (varsel$refmodel$family$for_latent) { if (resp_oscale) { - summ_ref <- summ_ref$oscale - summ_sub <- lapply(summ_sub, "[[", "oscale") - ref_lppd_NA <- all(is.na(summ_ref$lppd)) - sub_lppd_NA <- any(sapply(summ_sub, check_sub_NA, el_nm = "lppd")) - ref_mu_NA <- all(is.na(summ_ref$mu)) - sub_mu_NA <- any(sapply(summ_sub, check_sub_NA, el_nm = "mu")) + summaries_ref <- summaries_ref$oscale + summaries_sub <- lapply(summaries_sub, "[[", "oscale") + ref_lppd_NA <- all(is.na(summaries_ref$lppd)) + sub_lppd_NA <- any(sapply(summaries_sub, check_sub_NA, el_nm = "lppd")) + ref_mu_NA <- all(is.na(summaries_ref$mu)) + sub_mu_NA <- any(sapply(summaries_sub, check_sub_NA, el_nm = "mu")) if (ref_mu_NA || sub_mu_NA) { message( "`latent_ilink` returned only `NA`s, so all performance statistics ", @@ -149,11 +154,11 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, if (resp_oscale && !is.null(varsel$refmodel$family$cats) && any(stats %in% c("acc", "pctcorr"))) { - summ_ref$mu <- catmaxprb(summ_ref$mu, lvls = varsel$refmodel$family$cats) - summ_sub <- lapply(summ_sub, function(summ_sub_k) { - summ_sub_k$mu <- catmaxprb(summ_sub_k$mu, + summaries_ref$mu <- catmaxprb(summaries_ref$mu, lvls = varsel$refmodel$family$cats) + summaries_sub <- lapply(summaries_sub, function(summaries_sub_k) { + summaries_sub_k$mu <- catmaxprb(summaries_sub_k$mu, lvls = varsel$refmodel$family$cats) - return(summ_sub_k) + return(summaries_sub_k) }) # Since `mu` is an unordered factor, `y` needs to be unordered, too (or both # would need to be ordered; however, unordered is the simpler type): @@ -173,17 +178,14 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, if (is.null(nfeat_baseline)) { ## no baseline model, i.e, compute the statistics on the actual ## (non-relative) scale - mu.bs <- NULL - lppd.bs <- NULL + summaries_baseline <- NULL delta <- FALSE } else { if (nfeat_baseline == Inf) { - summ.bs <- summ_ref + summaries_baseline <- summaries_ref } else { - summ.bs <- summ_sub[[nfeat_baseline + 1]] + summaries_baseline <- summaries_sub[[nfeat_baseline + 1]] } - mu.bs <- summ.bs$mu - lppd.bs <- summ.bs$lppd delta <- TRUE } @@ -191,9 +193,11 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, stat <- stats[s] ## reference model statistics - summ <- summ_ref - res <- get_stat(summ$mu, summ$lppd, varsel$y_wobs_test, stat, mu.bs = mu.bs, - lppd.bs = lppd.bs, wcv = NULL, alpha = alpha, ...) + summaries <- summaries_ref + res <- get_stat(summaries = summaries_ref, + summaries_baseline = summaries_baseline, + summaries_fast = NULL, + varsel$y_wobs_test, stat, alpha = alpha, ...) row <- data.frame( data = varsel$type_test, size = Inf, delta = delta, statistic = stat, value = res$value, lq = res$lq, uq = res$uq, se = res$se, diff = NA, @@ -202,192 +206,174 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, stat_tab <- rbind(stat_tab, row) ## submodel statistics - for (k in seq_along(summ_sub)) { - summ <- summ_sub[[k]] - if (delta == FALSE && sum(!is.na(summ_ref$mu)) > sum(!is.na(summ$mu))) { - ## special case (subsampling loo): reference model summaries computed - ## for more points than for the submodel, so utilize the reference model - ## results to get more accurate statistic fot the submodel on the actual - ## scale - res_ref <- get_stat(summ_ref$mu, summ_ref$lppd, varsel$y_wobs_test, - stat, mu.bs = NULL, lppd.bs = NULL, wcv = NULL, - alpha = alpha, ...) - res_diff <- get_stat(summ$mu, summ$lppd, varsel$y_wobs_test, stat, - mu.bs = summ_ref$mu, lppd.bs = summ_ref$lppd, - wcv = summ$wcv, alpha = alpha, ...) - val <- res_ref$value + res_diff$value - # TODO (subsampled PSIS-LOO CV): Is `val.se` really computed correctly - # or do we need to take into account that `res_ref$se` and `res_diff$se` - # might be stochastically dependent? - val.se <- sqrt(res_ref$se^2 + res_diff$se^2) - if (stat %in% c("rmse", "auc")) { - # TODO (subsampled PSIS-LOO CV): Use bootstrap for lower and upper - # confidence interval bounds as well as for the standard error. - warning("Lower and upper confidence interval bounds of performance ", - "statistic `", stat, "` are based on a normal ", - "approximation, not the bootstrap. The standard error of ", - "performance statistic `", stat, "` is also not based on a ", - "bootstrap.") - } - lq <- qnorm(alpha / 2, mean = val, sd = val.se) - uq <- qnorm(1 - alpha / 2, mean = val, sd = val.se) - row <- data.frame( - data = varsel$type_test, size = k - 1, delta = delta, - statistic = stat, value = val, lq = lq, uq = uq, se = val.se, - diff = res_diff$value, diff.se = res_diff$se - ) + for (k in seq_along(summaries_sub)) { + diff <- get_stat(summaries = summaries_sub[[k]], + summaries_baseline = summaries_baseline, + summaries_fast = summaries_fast_sub[[k]], + varsel$y_wobs_test, stat, alpha = alpha, ...) + if (!delta) { + res <- get_stat(summaries = summaries_sub[[k]], + summaries_baseline = NULL, + summaries_fast = summaries_fast_sub[[k]], + varsel$y_wobs_test, stat, alpha = alpha, ...) } else { - ## normal case - res <- get_stat(summ$mu, summ$lppd, varsel$y_wobs_test, stat, - mu.bs = mu.bs, lppd.bs = lppd.bs, wcv = summ$wcv, - alpha = alpha, ...) - diff <- get_stat(summ$mu, summ$lppd, varsel$y_wobs_test, stat, - mu.bs = summ_ref$mu, lppd.bs = summ_ref$lppd, - wcv = summ$wcv, alpha = alpha, ...) - row <- data.frame( - data = varsel$type_test, size = k - 1, delta = delta, - statistic = stat, value = res$value, lq = res$lq, uq = res$uq, - se = res$se, diff = diff$value, diff.se = diff$se - ) + res <- diff } + row <- data.frame( + data = varsel$type_test, size = k - 1, delta = delta, + statistic = stat, value = res$value, lq = res$lq, uq = res$uq, + se = res$se, diff = diff$value, diff.se = diff$se + ) stat_tab <- rbind(stat_tab, row) } } - return(stat_tab) } # Helper function checking whether all entries of a summaries vector are `NA`. # -# @param summ_sub_k Typically `$summaries$sub[[k]]`. +# @param summaries_sub_k Typically `$summaries$sub[[k]]`. # @param el_nm A single character string, giving the name of the subelement of -# `summ_sub_k` to check for `NA`s. +# `summaries_sub_k` to check for `NA`s. # # @return A single logical value, indicating whether all entries of -# `summ_sub_k[[el_nm]]` are `NA`. -check_sub_NA <- function(summ_sub_k, el_nm) { - all(is.na(summ_sub_k[[el_nm]])) +# `summaries_sub_k[[el_nm]]` are `NA`. +check_sub_NA <- function(summaries_sub_k, el_nm) { + all(is.na(summaries_sub_k[[el_nm]])) } -## Calculates given statistic stat with standard error and confidence bounds. -## mu.bs and lppd.bs are the pointwise mu and lppd for another model that is -## used as a baseline for computing the difference (ratio in case of the GMPD) -## in the given statistic. If these arguments are not given (NULL) then the -## actual (non-relative) value is computed. NOTE: Element `wcv[i]` (with i = 1, -## ..., N and N denoting the number of observations) contains the weight of the -## CV fold that observation i is in. In case of varsel() output, this is `NULL`. -## Currently, these `wcv` are nonconstant (and not `NULL`) only in case of -## subsampled PSIS-LOO CV. The actual observation weights (specified by the +## The actual observation weights (specified by the ## user) are contained in `y_wobs_test$wobs`. These are already taken into ## account by `$family$ll_fun()` (or ## `$family$latent_ll_oscale()`) and are thus already taken ## into account in `lppd`. However, `mu` does not take them into account, so ## some further adjustments are necessary below. -get_stat <- function(mu, lppd, y_wobs_test, stat, mu.bs = NULL, lppd.bs = NULL, - wcv = NULL, alpha = 0.1, ...) { - n_notna.bs <- NULL - if (stat %in% c("elpd", "mlpd", "gmpd")) { - if (!is.null(lppd.bs)) { - # Compute the performance statistics using only those observations for - # which both `lppd` and `lppd.bs` are not `NA`: - lppd[is.na(lppd.bs)] <- NA - lppd.bs[is.na(lppd)] <- NA - n_notna.bs <- sum(!is.na(lppd.bs)) - } - n_notna <- sum(!is.na(lppd)) - n <- length(lppd) - } else { - hasNA_y <- is.na(y_wobs_test$y_prop %||% y_wobs_test$y) - if (!is.null(mu.bs)) { - # Compute the performance statistics using only those observations for - # which both `mu` and `mu.bs` are not `NA`: - mu[is.na(mu.bs)] <- NA - mu.bs[is.na(mu)] <- NA - n_notna.bs <- sum(!is.na(mu.bs) & !hasNA_y) - } - n_notna <- sum(!is.na(mu) & !hasNA_y) - n <- length(mu) - } - if (!is.null(n_notna.bs) && getOption("projpred.additional_checks", FALSE)) { - stopifnot(n_notna == n_notna.bs) - } - if (n_notna == 0) { +get_stat <- function(summaries, summaries_baseline = NULL, + summaries_fast = NULL, + y_wobs_test, stat, alpha = 0.1, ...) { + mu <- summaries$mu + lppd <- summaries$lppd + loo_inds <- which(!is.na(lppd)) + n <- length(lppd) + n_loo <- length(loo_inds) + ## is this needed anymore? + ## n_notna.bs <- NULL + ## if (!is.null(summaries_fast)) { + ## # Compute the performance statistics using only those observations for + ## # which fast summaries are not NA + ## if (stat %in% c("elpd", "mlpd", "gmpd")) { + ## lppd[is.na(lppd_baseline)] <- NA + ## n_notna.bs <- sum(!is.na(lppd_baseline)) + ## } + ## n_notna <- sum(!is.na(lppd)) + ## n <- length(lppd) + ## } else { + ## hasNA_y <- is.na(y_wobs_test$y_prop %||% y_wobs_test$y) + ## if (!is.null(mu_baseline)) { + ## # Compute the performance statistics using only those observations for + ## # which both `mu` and `mu_baseline` are not `NA`: + ## mu[is.na(mu_baseline)] <- NA + ## mu_baseline[is.na(mu)] <- NA + ## n_notna.bs <- sum(!is.na(mu_baseline) & !hasNA_y) + ## } + ## n_notna <- sum(!is.na(mu) & !hasNA_y) + ## n <- length(mu) + ## } + ## if (!is.null(n_notna.bs) && getOption("projpred.additional_checks", FALSE)) { + ## stopifnot(n_notna == n_notna.bs) + ## } + if (n_loo == 0) { return(list(value = NA, se = NA, lq = NA, uq = NA)) } - - if (is.null(wcv)) { - ## set default CV fold weights if not given - wcv <- rep(1, n) - } - ## ensure the CV fold weights sum to n_notna - wcv <- n_notna * wcv / sum(wcv) - alpha_half <- alpha / 2 one_minus_alpha_half <- 1 - alpha_half if (stat %in% c("elpd", "mlpd", "gmpd")) { - if (!is.null(lppd.bs)) { - value <- sum((lppd - lppd.bs) * wcv, na.rm = TRUE) - value.se <- weighted.sd(lppd - lppd.bs, wcv, na.rm = TRUE) * - sqrt(n_notna) + if (is.null(summaries_baseline)) { + lppd_baseline = 0 + } else { + lppd_baseline = summaries_baseline$lppd + } + if (!is.null(summaries_fast) && sum(n_loo1) { + w_m <- w[y_idx] + w_m <- length(w_m)*w_m/sum(w_m) + w <- length(w)*w/sum(w) + } + + e_i <- y - y_approx_m + t_pi_tilde <- sum(w*y_approx) + t_pi2_tilde <- sum(w*y_approx^2) + t_e <- N * mean(w_m*e_i) + t_hat_epsilon <- N * mean(w_m*(y^2 - y_approx_m^2)) + + est_list <- list(m = length(y), N = N) + # eq (7) + est_list$y_hat <- t_pi_tilde + t_e + # eq (8) + var_e_i <- m/(m-1)*(mean(w_m*e_i^2)-mean(w_m*e_i)^2) + est_list$v_y_hat <- N^2 * (1 - m / N) * var_e_i / m + # eq (9) first row second `+` should be `-` + # Supplementary material eq (6) has this correct + # Here the variance is for sum, while in the paper the variance is for mean + # which explains the proportional difference of 1/N + est_list$hat_v_y <- (t_pi2_tilde + t_hat_epsilon) - # a (has been checked) + (1/N) * (t_e^2 - est_list$v_y_hat + 2 * t_pi_tilde * est_list$y_hat - t_pi_tilde^2) # b + est_list +} From 781e331b20c3cd763fe2bb3f40185d47b299d100 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Wed, 10 Apr 2024 12:02:45 +0300 Subject: [PATCH 002/134] put back unnecessarily removed weights back in kfold --- R/cv_varsel.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 6d3bd877a..18b21b068 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1099,9 +1099,10 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, # Submodel predictive performance: summ_sub <- lapply(seq_len(prv_len_rk + 1L), function(k) { - summ_k <- list(lppd = loo_sub[[k]], mu = mu_sub[[k]]) + summ_k <- list(lppd = loo_sub[[k]], mu = mu_sub[[k]], wcv = validset$wcv) if (refmodel$family$for_latent) { - summ_k$oscale <- list(lppd = loo_sub_oscale[[k]], mu = mu_sub_oscale[[k]]) + summ_k$oscale <- list(lppd = loo_sub_oscale[[k]], mu = mu_sub_oscale[[k]], + wcv = validset$wcv) } return(summ_k) }) From d50f4bd9271869c9c3e0bae7c15d0e8d5063da16 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Wed, 10 Apr 2024 13:40:11 +0300 Subject: [PATCH 003/134] Revert "put back unnecessarily removed weights back in kfold" This reverts commit 781e331b20c3cd763fe2bb3f40185d47b299d100. --- R/cv_varsel.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 18b21b068..6d3bd877a 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1099,10 +1099,9 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, # Submodel predictive performance: summ_sub <- lapply(seq_len(prv_len_rk + 1L), function(k) { - summ_k <- list(lppd = loo_sub[[k]], mu = mu_sub[[k]], wcv = validset$wcv) + summ_k <- list(lppd = loo_sub[[k]], mu = mu_sub[[k]]) if (refmodel$family$for_latent) { - summ_k$oscale <- list(lppd = loo_sub_oscale[[k]], mu = mu_sub_oscale[[k]], - wcv = validset$wcv) + summ_k$oscale <- list(lppd = loo_sub_oscale[[k]], mu = mu_sub_oscale[[k]]) } return(summ_k) }) From 4de50b7f896a00016e58241111e2f030aa177993 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Wed, 10 Apr 2024 20:30:46 +0300 Subject: [PATCH 004/134] subsampling LOO for acc and pctcor --- R/glmfun.R | 2 +- R/misc.R | 4 +-- R/summary_funs.R | 87 ++++++++++++++++++++++++++++++------------------ 3 files changed, 57 insertions(+), 36 deletions(-) diff --git a/R/glmfun.R b/R/glmfun.R index 648b25348..044678b9a 100644 --- a/R/glmfun.R +++ b/R/glmfun.R @@ -16,7 +16,7 @@ standardization <- function(x, center = TRUE, scale = TRUE, weights = NULL) { mx <- rep(0, ncol(x)) } if (scale) { - sx <- apply(x, 2, weighted.sd, w) + sx <- apply(x, 2, .weighted_sd, w) } else { sx <- rep(1, ncol(x)) } diff --git a/R/misc.R b/R/misc.R index bc5344b4d..02bf03c5b 100644 --- a/R/misc.R +++ b/R/misc.R @@ -14,7 +14,7 @@ nms_y_wobs_test <- function(wobs_nm = "wobs") { c("y", "y_oscale", wobs_nm) } -weighted.sd <- function(x, w, na.rm = FALSE) { +.weighted_sd <- function(x, w, na.rm = FALSE) { if (na.rm) { ind <- !is.na(w) & !is.na(x) n <- sum(ind) @@ -63,7 +63,7 @@ ilinkfun_raw <- function(x, link_nm) { return(basic_ilink(x)) } -auc <- function(x) { +.auc <- function(x) { resp <- x[, 1] pred <- x[, 2] wcv <- x[, 3] diff --git a/R/summary_funs.R b/R/summary_funs.R index 3def6e7f1..3b5bd53d4 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -94,6 +94,9 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, summaries_sub <- varsel$summaries$sub if (!is.null(varsel$summaries_fast)) { summaries_fast_sub <- varsel$summaries_fast$sub + if (stats %in% c("auc")) { + warning("Subsampling LOO with AUC not implemented. Using fast LOO for submodel AUC.") + } } else { summaries_fast_sub <- NULL } @@ -361,7 +364,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, # full LOO estimator if (stat == "mse") { value <- mean(wcv * ((mu - y)^2 - mu_baseline)) - value_se <- weighted.sd((mu - y)^2 - mu_baseline, wcv) / sqrt(n) + value_se <- .weighted_sd((mu - y)^2 - mu_baseline, wcv) / sqrt(n) } else if (stat == "rmse") { value <- sqrt(mean(wcv * ((mu - y)^2))) - sqrt(mean(mu_baseline)) diffvalue.bootstrap <- bootstrap( @@ -380,6 +383,8 @@ get_stat <- function(summaries, summaries_baseline = NULL, } } else if (stat %in% c("acc", "pctcorr", "auc")) { y <- y_wobs_test$y + wcv <- y_wobs_test$wobs + wcv <- n * wcv / sum(wcv) if (!is.null(y_wobs_test$y_prop)) { # CAUTION: The following checks also ensure that `y` does not have `NA`s # (see the other "CAUTION" comments below for changes that are needed if @@ -392,57 +397,73 @@ get_stat <- function(summaries, summaries_baseline = NULL, rep(1L, y[i_short])) })) mu <- rep(mu, y_wobs_test$wobs) - if (!is.null(mu_baseline)) { - mu_baseline <- rep(mu_baseline, y_wobs_test$wobs) - # CAUTION: If `y` is allowed to have `NA`s here, then `n_notna.bs` needs - # to be adapted: - n_notna.bs <- sum(!is.na(mu_baseline)) - } - # CAUTION: If `y` is allowed to have `NA`s here, then `n_notna` needs to - # be adapted: - n_notna <- sum(!is.na(mu)) - if (!is.null(n_notna.bs) && - getOption("projpred.additional_checks", FALSE)) { - stopifnot(n_notna == n_notna.bs) + if (!is.null(summaries_baseline)) { + mu_baseline <- rep(summaries_baseline$mu, y_wobs_test$wobs) + } else { + mu_baseline <- NULL } - wcv <- rep(wcv, y_wobs_test$wobs) # What? - wcv <- n_notna * wcv / sum(wcv) + wcv <- rep(wcv, y_wobs_test$wobs) + wcv <- n * wcv / sum(wcv) } else { stopifnot(all(y_wobs_test$wobs == 1)) + if (!is.null(summaries_baseline)) { + mu_baseline <- summaries_baseline$mu + } else { + mu_baseline <- NULL + } } if (stat %in% c("acc", "pctcorr")) { # Find out whether each observation was classified correctly or not: if (!is.factor(mu)) { mu <- round(mu) } - crrct <- mu == y + correct <- mu == y if (!is.null(mu_baseline)) { if (!is.factor(mu_baseline)) { mu_baseline <- round(mu_baseline) } - crrct.bs <- mu_baseline == y + correct_baseline <- mu_baseline == y + } else { + correct_baseline <- 0 + } - value <- mean(wcv * (crrct - crrct.bs), na.rm = TRUE) - value_se <- weighted.sd(crrct - crrct.bs, wcv, na.rm = TRUE) / - sqrt(n_notna) + if (!is.null(summaries_fast) && sum(n_loo Date: Wed, 10 Apr 2024 21:09:26 +0300 Subject: [PATCH 005/134] ignore nloo if validate_search=FALSE --- R/cv_varsel.R | 33 ++++++++++++++------------------- 1 file changed, 14 insertions(+), 19 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 6d3bd877a..c9c3df2a2 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -20,14 +20,13 @@ #' is performed, which avoids refitting the reference model `nloo` times (in #' contrast to a standard LOO-CV). In the `"kfold"` case, a \eqn{K}-fold CV is #' performed. See also section "Note" below. -#' @param nloo **Caution:** Still experimental. Only relevant if `cv_method = -#' "LOO"`. If `nloo` is smaller than the number of all observations, -#' approximate full LOO-CV using difference estimator with simple random -#' sampling (SRS) without replacement (WOR) to make accurate computation only -#' for `nloo` (anything from 1 to the number of all observations) leave-one-out -#' folds (Magnusson et al., 2020). Smaller values lead to faster computation, -#' but higher uncertainty in the evaluation part. If `NULL`, all observations -#' are used (as by default). +#' @param nloo Only relevant if `cv_method = "LOO"` and `validate_search = TRUE`. +#' If `nloo>0` is smaller than the number of all observations, full LOO is +#' approximated by combining the fast LOO result for the selected models and +#' `nloo` leave-one-out searches using the difference estimator with simple +#' random sampling (SRS) without replacement (WOR) (Magnusson et al., 2020). +#' Smaller values lead to faster computation, but higher uncertainty in the +#' evaluation part. If `NULL`, all observations are used (as by default). #' @param K Only relevant if `cv_method = "kfold"` and if `cvfits` is `NULL` #' (which is the case for reference model objects created by #' [get_refmodel.stanreg()] or [brms::get_refmodel.brmsfit()]). Number of @@ -37,14 +36,11 @@ #' [run_cvfun()] can be inserted here straightforwardly. #' @param validate_search A single logical value indicating whether to #' cross-validate also the search part, i.e., whether to run the search -#' separately for each CV fold (`TRUE`) or not (`FALSE`). We strongly do not -#' recommend setting this to `FALSE`, because this is known to bias the -#' predictive performance estimates of the selected submodels. However, -#' setting this to `FALSE` can sometimes be useful because comparing the -#' results to the case where this argument is `TRUE` gives an idea of how -#' strongly the search is (over-)fitted to the data (the difference -#' corresponds to the search degrees of freedom or the effective number of -#' parameters introduced by the search). +#' separately for each CV fold (`TRUE`) or not (`FALSE`). With `FALSE` +#' the computation is faster, but the predictive performance estimates +#' of the selected submodels are biased. However, these fast biased +#' estimated can be useful to obtain initial information on the usefulnes +#' of projection predictive variable selection. #' @param seed Pseudorandom number generation (PRNG) seed by which the same #' results can be obtained again if needed. Passed to argument `seed` of #' [set.seed()], but can also be `NA` to not call [set.seed()] at all. If not @@ -368,7 +364,6 @@ cv_varsel.refmodel <- function( search_out_rks = search_out_rks, parallel = parallel, ... ) if (is.null(sel_cv$summaries_fast) && validate_search==TRUE && nloo Date: Thu, 11 Apr 2024 20:46:15 +0300 Subject: [PATCH 006/134] fix tests --- R/varsel.R | 2 ++ tests/testthat/helpers/testers.R | 27 +++++---------------------- tests/testthat/setup.R | 3 ++- tests/testthat/test_varsel.R | 2 +- 4 files changed, 10 insertions(+), 24 deletions(-) diff --git a/R/varsel.R b/R/varsel.R index e80215f5b..f4c57cc7d 100644 --- a/R/varsel.R +++ b/R/varsel.R @@ -462,11 +462,13 @@ varsel.refmodel <- function(object, d_test = NULL, method = "forward", y_wobs_test, nobs_test, summaries = nlist(sub = perf_eval_out[["sub_summaries"]], ref), + summaries_fast = NULL, nterms_all, nterms_max, method, cv_method = NULL, nloo = NULL, + loo_inds = NULL, K = NULL, validate_search = NULL, ### Not set to `NULL` because in K-fold CV (relevant when using diff --git a/tests/testthat/helpers/testers.R b/tests/testthat/helpers/testers.R index 6513b4377..6d3dc2044 100644 --- a/tests/testthat/helpers/testers.R +++ b/tests/testthat/helpers/testers.R @@ -1972,11 +1972,10 @@ vsel_tester <- function( search_control_expected = NULL, extra_tol = 1.1, info_str = "" -) { + ) { + # Preparations: if (with_cv) { - vsel_smmrs_sub_nms <- c(vsel_smmrs_sub_nms, "wcv") - if (is.null(cv_method_expected)) { cv_method_expected <- "LOO" } @@ -2256,12 +2255,6 @@ vsel_tester <- function( } if (vs$refmodel$family$for_latent) { vsel_smmrs_sub_nms <- c(vsel_smmrs_sub_nms, "oscale") - if ("wcv" %in% vsel_smmrs_sub_nms && - identical(cv_method_expected, "kfold")) { - vsel_smmrs_sub_nms[vsel_smmrs_sub_nms %in% c("wcv", "oscale")] <- c( - "oscale", "wcv" - ) - } vsel_smmrs_ref_nms <- c(vsel_smmrs_ref_nms, "oscale") } smmrs_sub_j_tester <- function(smmrs_sub_j, tests_oscale = FALSE) { @@ -2283,7 +2276,7 @@ vsel_tester <- function( !is.null(vs$refmodel$family$cats))) { expect_s3_class(smmrs_sub_j$mu, "augvec") } - if (with_cv) { + if (with_cv && valsearch_expected && identical(cv_method_expected, "LOO")) { expect_identical(sum(!is.na(smmrs_sub_j$mu)), nloo_expected * ncats, info = info_str) } else { @@ -2295,26 +2288,16 @@ vsel_tester <- function( if (vs$refmodel$family$for_latent && !tests_oscale && identical(cv_method_expected, "kfold")) { expect_true(all(is.na(smmrs_sub_j$lppd)), info = info_str) - } else { + } else if (valsearch_expected && identical(cv_method_expected, "LOO")) { expect_identical(sum(!is.na(smmrs_sub_j$lppd)), nloo_expected, info = info_str) } } else { expect_true(all(!is.na(smmrs_sub_j$lppd)), info = info_str) } - if (with_cv) { - expect_type(smmrs_sub_j$wcv, "double") - expect_length(smmrs_sub_j$wcv, nobsv) - expect_true(all(!is.na(smmrs_sub_j$wcv)), info = info_str) - if (nloo_expected == nobsv) { - expect_equal(smmrs_sub_j$wcv, rep(1 / nobsv, nobsv), info = info_str) - } else { - expect_true(any(smmrs_sub_j$wcv != rep(1 / nobsv, nobsv)), - info = info_str) - } - } return(invisible(TRUE)) } + for (j in seq_along(vs$summaries$sub)) { smmrs_sub_j_tester(vs$summaries$sub[[j]]) if (vs$refmodel$family$for_latent) { diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 47afa7839..b8062043f 100755 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -2009,7 +2009,8 @@ if (run_cvvs) { vsel_nms <- c( "refmodel", "nobs_train", "search_path", "predictor_ranking", "predictor_ranking_cv", "ce", "type_test", "y_wobs_test", "nobs_test", - "summaries", "nterms_all", "nterms_max", "method", "cv_method", "nloo", "K", + "summaries", "summaries_fast", "nterms_all", "nterms_max", "method", + "cv_method", "nloo", "loo_inds", "K", "validate_search", "cvfits", "args_search", "clust_used_search", "clust_used_eval", "nprjdraws_search", "nprjdraws_eval", "refit_prj", "projpred_version" diff --git a/tests/testthat/test_varsel.R b/tests/testthat/test_varsel.R index 0c4c37589..b0f06cc77 100644 --- a/tests/testthat/test_varsel.R +++ b/tests/testthat/test_varsel.R @@ -1428,7 +1428,7 @@ test_that("setting `nloo` smaller than the number of observations works", { skip_if_not(run_cvvs) nloo_tst <- nobsv %/% 5L # Output elements of `vsel` objects that may be influenced by `nloo`: - vsel_nms_nloo <- c("summaries", "predictor_ranking_cv", "nloo", "ce") + vsel_nms_nloo <- c("summaries", "summaries_fast","predictor_ranking_cv", "nloo", "loo_inds", "ce") # In general, element `ce` is affected as well (because the PRNG state when # doing the clustering for the performance evaluation is different when `nloo` # is smaller than the number of observations compared to when `nloo` is equal From aba8670dfae549868e6ddb8409fd0920e9d2c615 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Fri, 12 Apr 2024 13:54:32 +0300 Subject: [PATCH 007/134] fix mse interval for delta=TRUE --- R/summary_funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 3b5bd53d4..898af5182 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -483,7 +483,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, } } - if (stat %in% c("mse")) { + if (stat %in% c("mse") && is.null(mu_baseline)) { # Compute mean and variance in log scale by matching the variance of a # log-normal approximation # https://en.wikipedia.org/wiki/Log-normal_distribution#Arithmetic_moments From 81b5dc3ef6844724f11dfa8823911231d22403d9 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Fri, 12 Apr 2024 15:08:19 +0300 Subject: [PATCH 008/134] don't stop due to repeated arguments --- R/cv_varsel.R | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index c9c3df2a2..c2b09e2af 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -159,16 +159,20 @@ cv_varsel.vsel <- function( validate_search = object$validate_search %||% TRUE, ... ) { + ## the following arguments should not change arg_nms_internal <- c("method", "ndraws", "nclusters", "nterms_max", "search_control", "penalty", "search_terms") arg_nms_internal_used <- intersect(arg_nms_internal, ...names()) n_arg_nms_internal_used <- length(arg_nms_internal_used) - if (n_arg_nms_internal_used > 0) { - stop("Argument", if (n_arg_nms_internal_used > 1) "s" else "", " ", - paste(paste0("`", arg_nms_internal_used, "`"), collapse = ", "), " ", - "cannot be specified in this case because cv_varsel.vsel() specifies ", - if (n_arg_nms_internal_used > 1) "them" else "it", " ", "internally.") + dots <- list(...) + for (arg in arg_nms_internal_used) { + if (!identical(object[[arg]], dots[[arg]])) { + message("Argument \"", arg, "\" ignored. Using the argument value stored in the varsel object (\"", object[[arg]], "\").") + } + ## remove duplicate arguments + dots[[arg]]<-NULL } + refmodel <- get_refmodel(object) rk_foldwise <- ranking(object)[["foldwise"]] if (validate_search && !is.null(rk_foldwise)) { @@ -201,7 +205,7 @@ cv_varsel.vsel <- function( } } - return(cv_varsel( + return(do.call(cv_varsel, c(list( object = refmodel, method = object[["args_search"]][["method"]], ndraws = object[["args_search"]][["ndraws"]], @@ -216,8 +220,8 @@ cv_varsel.vsel <- function( cvfits = cvfits, validate_search = validate_search, search_out = nlist(search_path = object[["search_path"]], rk_foldwise), - summaries_fast = object$summaries_fast, - ... + summaries_fast = object$summaries_fast), + dots) )) } From 0ed83914eff49bba52c6c065e7059d0b300b9643 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Mon, 15 Apr 2024 14:04:40 +0300 Subject: [PATCH 009/134] normal approximation for mse, rmse, and R2 --- R/methods.R | 4 +- R/misc.R | 4 +- R/summary_funs.R | 154 +++++++++++++++++++++++++++++++---------------- 3 files changed, 105 insertions(+), 57 deletions(-) diff --git a/R/methods.R b/R/methods.R index 869bc0269..f79fea707 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1065,11 +1065,11 @@ plot.vsel <- function( # direction = 1) ### } - if (all(stats %in% c("rmse","auc"))) { + if (all(stats %in% c("auc"))) { ci_type <- "bootstrap " } else if (all(stats %in% c("gmpd"))) { ci_type <- "exponentiated normal-approximation " - } else if (all(!stats %in% c("rmse", "auc", "gmpd"))) { + } else if (all(!stats %in% c("auc", "gmpd"))) { ci_type <- "normal-approximation " } else { ci_type <- "" diff --git a/R/misc.R b/R/misc.R index 02bf03c5b..42aa2fab4 100644 --- a/R/misc.R +++ b/R/misc.R @@ -152,8 +152,8 @@ validate_vsel_object_stats <- function(object, stats, resp_oscale = TRUE) { } resp_oscale <- object$refmodel$family$for_latent && resp_oscale - trad_stats <- c("elpd", "mlpd", "gmpd", "mse", "rmse", "acc", "pctcorr", - "auc") + trad_stats <- c("elpd", "mlpd", "gmpd", "mse", "rmse", "R2", + "acc", "pctcorr", "auc") trad_stats_binom_only <- c("acc", "pctcorr", "auc") augdat_stats <- c("elpd", "mlpd", "gmpd", "acc", "pctcorr") resp_oscale_stats_fac <- augdat_stats diff --git a/R/summary_funs.R b/R/summary_funs.R index 898af5182..2a0a25eda 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -319,67 +319,115 @@ get_stat <- function(summaries, summaries_baseline = NULL, value_gmpd_se <- value_se * value_gmpd } } - } else if (stat %in% c("mse", "rmse")) { + } else if (stat %in% c("mse", "rmse", "R2")) { y <- y_wobs_test$y_prop %||% y_wobs_test$y wcv <- y_wobs_test$wobs wcv <- n * wcv / sum(wcv) if (is.null(summaries_baseline)) { mu_baseline = 0 } else { - mu_baseline = (summaries_baseline$mu - y)^2 + mu_baseline = summaries_baseline$mu } - if (!is.null(summaries_fast) && sum(n_loo Date: Tue, 16 Apr 2024 18:15:15 +0300 Subject: [PATCH 010/134] rename internal function select -> .select --- R/cv_varsel.R | 6 +++--- R/varsel.R | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index c2b09e2af..59b13eec9 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -324,7 +324,7 @@ cv_varsel.refmodel <- function( } verb_txt_search <- paste0(verb_txt_search, "...") verb_out(verb_txt_search, verbose = verbose) - search_path_fulldata <- select( + search_path_fulldata <- .select( refmodel = refmodel, ndraws = ndraws, nclusters = nclusters, method = method, nterms_max = nterms_max, penalty = penalty, verbose = verbose, search_control = search_control, @@ -976,7 +976,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, if (!search_out_rks_was_null) { search_path <- list(predictor_ranking = search_out_rks[[run_index]]) } else { - search_path <- select( + search_path <- .select( refmodel = refmodel, ndraws = ndraws, nclusters = nclusters, reweighting_args = list(cl_ref = cl_sel, wdraws_ref = exp(lw[, i])), method = method, nterms_max = nterms_max, penalty = penalty, @@ -1296,7 +1296,7 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, } else if (!search_out_rks_was_null) { search_path <- list(predictor_ranking = rk) } else { - search_path <- select( + search_path <- .select( refmodel = fold$refmodel, ndraws = ndraws, nclusters = nclusters, method = method, nterms_max = nterms_max, penalty = penalty, verbose = verbose_search, search_control = search_control, diff --git a/R/varsel.R b/R/varsel.R index f4c57cc7d..5263ed220 100644 --- a/R/varsel.R +++ b/R/varsel.R @@ -375,7 +375,7 @@ varsel.refmodel <- function(object, d_test = NULL, method = "forward", search_path <- search_out[["search_path"]] } else { verb_out("-----\nRunning the search ...", verbose = verbose) - search_path <- select( + search_path <- .select( refmodel = refmodel, ndraws = ndraws, nclusters = nclusters, method = method, nterms_max = nterms_max, penalty = penalty, verbose = verbose, search_control = search_control, @@ -510,7 +510,7 @@ varsel.refmodel <- function(object, d_test = NULL, method = "forward", # `outdmins` (the submodel fits along the predictor ranking, with the number # of fits per model size being equal to the number of projected draws), and # `p_sel` (the output from get_refdist() for the search). -select <- function(refmodel, ndraws, nclusters, reweighting_args = NULL, method, +.select <- function(refmodel, ndraws, nclusters, reweighting_args = NULL, method, nterms_max, penalty, verbose, search_control, ...) { if (is.null(reweighting_args)) { p_sel <- get_refdist(refmodel, ndraws = ndraws, nclusters = nclusters) From 2c846a398963b8cffd8b7f83a2bcc6be90d1658c Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Tue, 16 Apr 2024 20:07:26 +0300 Subject: [PATCH 011/134] with delta and mse/rmse/R2/acc/pctcorr/auc, plot values in orig scale --- R/methods.R | 35 +++++++++++++++++++---------------- R/summary_funs.R | 18 ++++++------------ 2 files changed, 25 insertions(+), 28 deletions(-) diff --git a/R/methods.R b/R/methods.R index f79fea707..a6907a165 100644 --- a/R/methods.R +++ b/R/methods.R @@ -782,16 +782,11 @@ plot.vsel <- function( } else { baseline_pretty <- "best submodel" } + ylab <- "Value" if (deltas) { - if (all(stats != "gmpd")) { - ylab <- paste0("Difference vs. ", baseline_pretty) - } else if (all(stats == "gmpd")) { - ylab <- paste0("Ratio vs. ", baseline_pretty) - } else { - ylab <- paste0("Difference (ratio for GMPD) vs. ", baseline_pretty) - } + delta_lab <- "for baseline comparison" } else { - ylab <- "Value" + delta_lab <- "" } if (object$refmodel$family$for_latent) { if (resp_oscale) { @@ -962,6 +957,14 @@ plot.vsel <- function( } # Create the plot: + if (deltas) { + data_gg$statistic[data_gg$statistic=="elpd"] <- "elpd_diff" + stats_ref$statistic[stats_ref$statistic=="elpd"] <- "elpd_diff" + data_gg$statistic[data_gg$statistic=="mlpd"] <- "mlpd_diff" + stats_ref$statistic[stats_ref$statistic=="mlpd"] <- "mlpd_diff" + data_gg$statistic[data_gg$statistic=="gmpd"] <- "gmpd_ratio" + stats_ref$statistic[stats_ref$statistic=="gmpd"] <- "gmpd_ratio" + } pp <- ggplot(data = data_gg, mapping = aes(x = .data[["size"]], y = .data[["value"]], ymin = .data[["lq"]], ymax = .data[["uq"]])) @@ -981,9 +984,9 @@ plot.vsel <- function( thres_tab_ref$thres[is_elpd_mlpd_ref] <- thres_tab_ref$value[is_elpd_mlpd_ref] + thres_tab_ref$thres[is_elpd_mlpd_ref] - is_gmpd_ref <- thres_tab_ref$statistic %in% c("gmpd") + is_gmpd_ref <- thres_tab_ref$statistic %in% c("gmpd","gmpd ratio") thres_tab_ref$thres[is_gmpd_ref] <- - thres_tab_ref$value[is_gmpd_ref] * + thres_tab_ref$value[is_gmpd_ref] * thres_tab_ref$thres[is_gmpd_ref] pp <- pp + geom_hline(aes(yintercept = .data[["thres"]]), @@ -1067,9 +1070,7 @@ plot.vsel <- function( } if (all(stats %in% c("auc"))) { ci_type <- "bootstrap " - } else if (all(stats %in% c("gmpd"))) { - ci_type <- "exponentiated normal-approximation " - } else if (all(!stats %in% c("auc", "gmpd"))) { + } else if (all(!stats %in% c("auc"))) { ci_type <- "normal-approximation " } else { ci_type <- "" @@ -1104,9 +1105,11 @@ plot.vsel <- function( labels = tick_labs_x, sec.axis = x_axis_sec) + labs(x = xlab, y = ylab, title = "Predictive performance", - subtitle = paste0("Vertical bars indicate ", - round(100 * (1 - alpha), 1), "% ", ci_type, - "intervals")) + + subtitle = paste0("With ", + round(100 * (1 - alpha), 1), "% ", + ci_type, + "intervals ", + delta_lab)) + theme(axis.text.x.bottom = element_text(angle = text_angle, hjust = hjust_val, vjust = vjust_val)) + diff --git a/R/summary_funs.R b/R/summary_funs.R index 2a0a25eda..41d001e18 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -366,18 +366,12 @@ get_stat <- function(summaries, summaries_baseline = NULL, cov_mse_e_b <- srs_diffe$y_hat / n^2 } value_se <- sqrt(value_se^2 - 2*cov_mse_e_b + var_mse_b) - value <- mse_e - mse_b } if (stat == "rmse") { # simple transformation of mse value <- sqrt(mse_e) # the first-order Taylor approximation of the variance value_se <- sqrt(value_se^2 / mse_e / 4) - if (!is.null(summaries_baseline)) { - # delta=TRUE - value <- sqrt(mse_e) - sqrt(mse_b) - # delta se comes automatically via mse - } } else if (stat == "R2") { # simple transformation of mse mse_y <- mean(wcv * (mean(y)-y)^2) @@ -422,7 +416,6 @@ get_stat <- function(summaries, summaries_baseline = NULL, var_mse_e <- value_se^2 if (!is.null(summaries_baseline)) { # delta=TRUE - value <- (mse_e - mse_b) / mse_y mse_e <- mse_e - mse_b } value_se <- sqrt((var_mse_e - @@ -487,12 +480,12 @@ get_stat <- function(summaries, summaries_baseline = NULL, y = (correct-correct_baseline)[loo_inds], y_idx = loo_inds, w = wcv) - value <- srs_diffe$y_hat / n + value <- srs_diffe$y_hat / n + mean(wcv * correct_baseline) # combine estimates of var(y_hat) and var(y) value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n } else { # full LOO estimator - value <- mean(wcv * (correct - correct_baseline)) + value <- mean(wcv * correct) value_se <- .weighted_sd(correct - correct_baseline, wcv) / sqrt(n) } } else if (stat == "auc") { @@ -503,7 +496,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, if (!is.null(mu_baseline)) { auc_data <- cbind(y, mu, wcv) auc_data_baseline <- cbind(y, mu_baseline, wcv) - value <- .auc(auc_data) - .auc(auc_data_baseline) + value <- .auc(auc_data) idxs_cols <- seq_len(ncol(auc_data)) idxs_cols_bs <- setdiff(seq_len(ncol(auc_data) + ncol(auc_data_baseline)), idxs_cols) @@ -518,7 +511,8 @@ get_stat <- function(summaries, summaries_baseline = NULL, value_se <- sd(diffvalue.bootstrap, na.rm = TRUE) lq_uq <- quantile(diffvalue.bootstrap, probs = c(alpha_half, one_minus_alpha_half), - names = FALSE, na.rm = TRUE) + names = FALSE, na.rm = TRUE) + + .auc(auc_data_baseline) } else { auc_data <- cbind(y, mu, wcv) value <- .auc(auc_data) @@ -531,7 +525,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, } } - if (stat %in% c("mse","rmse") && is.null(mu_baseline)) { + if (stat %in% c("mse","rmse")) { # Compute mean and variance in log scale by matching the variance of a # log-normal approximation # https://en.wikipedia.org/wiki/Log-normal_distribution#Arithmetic_moments From fbda70ed99193fca865852201253c330d0a1317d Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Tue, 16 Apr 2024 20:09:18 +0300 Subject: [PATCH 012/134] don't warn about subsampling --- R/cv_varsel.R | 3 --- 1 file changed, 3 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 59b13eec9..6dad946ea 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -531,9 +531,6 @@ parse_args_cv_varsel <- function(refmodel, cv_method, nloo, K, cvfits, nloo <- min(nloo, refmodel[["nobs"]]) if (nloo < 1) { stop("nloo must be at least 1") - } else if (nloo < refmodel[["nobs"]] && - getOption("projpred.warn_subsampled_loo", TRUE)) { - warning("Subsampled PSIS-LOO-CV is still experimental.") } } From 1fa7fcdcabc8f04dab17dd5cc86d01d23eac7f02 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Wed, 17 Apr 2024 14:45:13 +0300 Subject: [PATCH 013/134] improve messages --- R/cv_varsel.R | 146 ++++++++++++++++++++++++++------------------------ 1 file changed, 77 insertions(+), 69 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 6dad946ea..1ce046076 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -322,6 +322,10 @@ cv_varsel.refmodel <- function( # no fold-wise searches, so pointing out "full-data" could be confusing): verb_txt_search <- paste0(verb_txt_search, "using the full dataset ") } + verb_txt_search <- paste0(verb_txt_search, "with ", + ifelse(!is.null(ndraws), + paste0(ndraws, " draws"), + paste0(nclusters, " clusters"))) verb_txt_search <- paste0(verb_txt_search, "...") verb_out(verb_txt_search, verbose = verbose) search_path_fulldata <- .select( @@ -728,8 +732,15 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, # "Run" the performance evaluation for the submodels along the predictor # ranking (in fact, we only prepare the performance evaluation by computing # precursor quantities, but for users, this difference is not perceivable): - verb_out("-----\nRunning the performance evaluation with `refit_prj = ", - refit_prj, "` ...", verbose = verbose) + verb_out("-----\nRunning the performance evaluation with ", + ifelse(refit_prj, + ifelse(!is.null(ndraws_pred), + paste0(ndraws_pred, " draws"), + paste0(nclusters_pred, " clusters")), + ifelse(!is.null(ndraws), + paste0(ndraws, " draws"), + paste0(nclusters, " clusters"))), + " (`refit_prj = ", refit_prj, "`) ...", verbose = verbose) # Step 1: Re-project (using the full dataset) onto the submodels along the # full-data predictor ranking and evaluate their predictive performance. perf_eval_out <- perf_eval( @@ -779,63 +790,50 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, )) } if (nrow(log_lik_ref) > 1) { - # Use loo::sis() if the projected draws (i.e., the draws resulting - # from the clustering or thinning) have nonconstant weights: - if (refdist_eval$const_wdraws_prj) { - # Internally, loo::psis() doesn't perform the Pareto smoothing if the - # number of draws is small (as indicated by object `no_psis_eval`, see - # below). In projpred, this can occur, e.g., if users request a number - # of projected draws (for performance evaluation, either after - # clustering or thinning the reference model's posterior draws) that is - # much smaller than the default of 400. In order to throw a customized - # warning message (and to avoid the calculation of Pareto k-values, see - # loo issue stan-dev/loo#227), object `no_psis_eval` indicates whether - # loo::psis() would perform the Pareto smoothing or not (for the - # decision rule, see loo:::n_pareto() and loo:::enough_tail_samples(), - # keeping in mind that we have `r_eff = 1` for all observations here). - S_for_psis_eval <- nrow(log_lik_ref) - no_psis_eval <- ceiling(min(0.2 * S_for_psis_eval, - 3 * sqrt(S_for_psis_eval))) < 5 - if (no_psis_eval) { - if (getOption("projpred.warn_psis", TRUE)) { - warning( - "In the recalculation of the reference model's PSIS-LOO-CV ", - "weights for the performance evaluation, the number of draws ", - "after clustering or thinning is too small for Pareto ", - "smoothing. Using standard importance sampling (SIS) instead. ", - "Watch out for warnings thrown by the original-draws Pareto ", - "smoothing to see whether it makes sense to increase the number ", - "of draws (resulting from the clustering or thinning for the ", - "performance evaluation). Alternatively, K-fold CV can be used." - ) - } - # Use loo::sis(). - # In principle, we could rely on loo::psis() here (because in such a - # case, it would internally switch to SIS automatically), but using - # loo::sis() explicitly is safer because if the loo package changes - # its decision rule, we would get a mismatch between our customized - # warning here and the IS method used by loo. See also loo issue - # stan-dev/loo#227. - importance_sampling_nm <- "sis" - } else { - # Use loo::psis(). - # Usually, we have a small number of projected draws here (400 by - # default), which means that the 'loo' package will automatically - # perform the regularization from Vehtari et al. (2022, - # , appendix G). - importance_sampling_nm <- "psis" - } - } else { + # Take into account that clustered draws usually have different weights: + lw_sub <- log_lik_ref + log(refdist_eval$wdraws_prj) + # This re-weighting requires a re-normalization (as.array() is applied to + # have stricter consistency checks, see `?sweep`): + lw_sub <- sweep(lw_sub, 2, as.array(apply(lw_sub, 2, log_sum_exp))) + # Internally, loo::psis() doesn't perform the Pareto smoothing if the + # number of draws is small (as indicated by object `no_psis_eval`, see + # below). In projpred, this can occur, e.g., if users request a number + # of projected draws (for performance evaluation, either after + # clustering or thinning the reference model's posterior draws) that is + # much smaller than the default of 400. In order to throw a customized + # warning message (and to avoid the calculation of Pareto k-values, see + # loo issue stan-dev/loo#227), object `no_psis_eval` indicates whether + # loo::psis() would perform the Pareto smoothing or not (for the + # decision rule, see loo:::n_pareto() and loo:::enough_tail_samples(), + # keeping in mind that we have `r_eff = 1` for all observations here). + S_for_psis_eval <- nrow(log_lik_ref) + no_psis_eval <- ceiling(min(0.2 * S_for_psis_eval, + 3 * sqrt(S_for_psis_eval))) < 5 + if (no_psis_eval) { if (getOption("projpred.warn_psis", TRUE)) { - warning( - "The projected draws used for the performance evaluation have ", - "different (i.e., nonconstant) weights, so using standard ", - "importance sampling (SIS) instead of Pareto-smoothed importance ", - "sampling (PSIS). In general, PSIS is recommended over SIS." - ) + verb_out( + "Using simple importance sampling due to a small number of", + ifelse(refit_prj, + ifelse(!is.null(ndraws_pred), " draws", " clusters"), + ifelse(!is.null(ndraws), " draws", " clusters") + ), + verbose=verbose) } # Use loo::sis(). + # In principle, we could rely on loo::psis() here (because in such a + # case, it would internally switch to SIS automatically), but using + # loo::sis() explicitly is safer because if the loo package changes + # its decision rule, we would get a mismatch between our customized + # warning here and the IS method used by loo. See also loo issue + # stan-dev/loo#227. importance_sampling_nm <- "sis" + } else { + # Use loo::psis(). + # Usually, we have a small number of projected draws here (400 by + # default), which means that the 'loo' package will automatically + # perform the regularization from Vehtari et al. (2022, + # , appendix G). + importance_sampling_nm <- "psis" } importance_sampling_func <- get(importance_sampling_nm, asNamespace("loo")) @@ -877,11 +875,6 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } else { lw_sub <- matrix(0, nrow = nrow(log_lik_ref), ncol = ncol(log_lik_ref)) } - # Take into account that clustered draws usually have different weights: - lw_sub <- lw_sub + log(refdist_eval$wdraws_prj) - # This re-weighting requires a re-normalization (as.array() is applied to - # have stricter consistency checks, see `?sweep`): - lw_sub <- sweep(lw_sub, 2, as.array(apply(lw_sub, 2, log_sum_exp))) for (k in seq_len(1 + length(search_path_fulldata$predictor_ranking))) { # TODO: For consistency, replace `k` in this `for` loop by `j`. mu_k <- perf_eval_out[["mu_by_size"]][[k]] @@ -949,14 +942,29 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } if (verbose) { - verb_txt_start <- "-----\nRunning " + verb_txt_start <- if (!search_out_rks_was_null) { verb_txt_mid <- "" } else { verb_txt_mid <- "the search and " } - verb_out(verb_txt_start, verb_txt_mid, "the performance evaluation with ", - "`refit_prj = ", refit_prj, "` for each of the N = ", nloo, " ", + verb_out("-----\nRunning ", + ifelse(!search_out_rks_was_null, "", + paste0("the search with ", + ifelse(!is.null(ndraws), + paste0(ndraws, " draws"), + paste0(nclusters, " clusters")), + " and ")), + "the performance evaluation with ", + ifelse(refit_prj, + ifelse(!is.null(ndraws_pred), + paste0(ndraws_pred, " draws"), + paste0(nclusters_pred, " clusters")), + ifelse(!is.null(ndraws), + paste0(ndraws, " draws"), + paste0(nclusters, " clusters"))), + " (`refit_prj = ", refit_prj, + "`) for each of the nloo = ", nloo, " ", "LOO-CV folds separately ...") } one_obs <- function(run_index, @@ -1002,16 +1010,16 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, # would require adding more "hard" dependencies (because packages # 'foreach' and 'doRNG' would have to be moved from `Suggests:` to # `Imports:`). - if (verbose) { + if (verbose && interactive()) { pb <- utils::txtProgressBar(min = 0, max = nloo, style = 3, initial = 0) } res_cv <- lapply(seq_along(inds), function(run_index) { - if (verbose) { + if (verbose && interactive()) { on.exit(utils::setTxtProgressBar(pb, run_index)) } one_obs(run_index, ...) }) - if (verbose) { + if (verbose && interactive()) { close(pb) } } else { @@ -1335,16 +1343,16 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, # foreach::`%do%`` here and then proceed as in the parallel case, but that # would require adding more "hard" dependencies (because packages 'foreach' # and 'doRNG' would have to be moved from `Suggests:` to `Imports:`). - if (verbose) { + if (verbose && interactive()) { pb <- utils::txtProgressBar(min = 0, max = K, style = 3, initial = 0) } res_cv <- lapply(seq_along(list_cv), function(k) { - if (verbose) { + if (verbose && interactive()) { on.exit(utils::setTxtProgressBar(pb, k)) } one_fold(fold = list_cv[[k]], rk = search_out_rks[[k]], ...) }) - if (verbose) { + if (verbose && interactive()) { close(pb) } } else { From 7e7fc7a846b3cfad7713918f85e722ff33e6a98d Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Wed, 17 Apr 2024 14:45:27 +0300 Subject: [PATCH 014/134] if available, use progressr for parallel progress bar --- R/cv_varsel.R | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 1ce046076..50a05fb02 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1028,8 +1028,20 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, stop("Please install the 'foreach' package.") } if (!requireNamespace("doRNG", quietly = TRUE)) { - stop("Please install the 'doRNG' package.") + stop("Please install the 'doRNG' package.") } + if (verbose && + requireNamespace("progressr", quietly = TRUE) && + requireNamespace("progress", quietly = TRUE) && + interactive()) { + progressr_installed <- TRUE + progressr::handlers(global = TRUE) + progressr::handlers("progress") + p <- progressr::progressor(along = seq_along(inds)) + } else { + progressr_installed <- FALSE + } + .select <- .select dot_args <- list(...) `%do_projpred%` <- doRNG::`%dorng%` res_cv <- foreach::foreach( @@ -1039,6 +1051,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, "loo_ref_oscale", "validset", "loo_sub", "mu_sub", "loo_sub_oscale", "mu_sub_oscale") ) %do_projpred% { + if (progressr_installed) p("") do.call(one_obs, c(list(run_index = run_index, verbose_search = FALSE), dot_args)) } @@ -1363,6 +1376,18 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, if (!requireNamespace("doRNG", quietly = TRUE)) { stop("Please install the 'doRNG' package.") } + if (verbose && + requireNamespace("progressr", quietly = TRUE) && + requireNamespace("progress", quietly = TRUE) && + interactive()) { + use_progressr <- TRUE + progressr::handlers(global = TRUE) + progressr::handlers("progress") + p <- progressr::progressor(along = seq_along(inds)) + } else { + use_progressr <- FALSE + } + .select <- .select dot_args <- list(...) `%do_projpred%` <- doRNG::`%dorng%` res_cv <- foreach::foreach( @@ -1371,6 +1396,7 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, .export = c("one_fold", "dot_args"), .noexport = c("list_cv", "search_out_rks") ) %do_projpred% { + if (use_progressr) p("") do_call(one_fold, c(list(fold = list_cv_k, rk = search_out_rks_k, verbose_search = FALSE), dot_args)) From 09223c601e83d7b31742067d114df0b51b404827 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Thu, 25 Apr 2024 12:48:23 +0300 Subject: [PATCH 015/134] verbosity improvements --- R/cv_varsel.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 50a05fb02..a776eae47 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -315,7 +315,7 @@ cv_varsel.refmodel <- function( if (!is.null(search_out)) { search_path_fulldata <- search_out[["search_path"]] } else { - verb_txt_search <- "-----\nRunning the search " + verb_txt_search <- paste0("-----\nRunning ", method, " search ") if (validate_search) { # Point out that this is the full-data search (if `validate_search` is # `FALSE`, this is still a full-data search, but in that case, there are @@ -950,7 +950,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } verb_out("-----\nRunning ", ifelse(!search_out_rks_was_null, "", - paste0("the search with ", + paste0(method, " search with ", ifelse(!is.null(ndraws), paste0(ndraws, " draws"), paste0(nclusters, " clusters")), From 45e22a6659b75a7fafd9ebcedc155541f451cd08 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Thu, 25 Apr 2024 12:48:52 +0300 Subject: [PATCH 016/134] fix --- R/summary_funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 41d001e18..e32f5413f 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -94,7 +94,7 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, summaries_sub <- varsel$summaries$sub if (!is.null(varsel$summaries_fast)) { summaries_fast_sub <- varsel$summaries_fast$sub - if (stats %in% c("auc")) { + if (any(stats %in% c("auc"))) { warning("Subsampling LOO with AUC not implemented. Using fast LOO for submodel AUC.") } } else { From 1cb78fc79c1e64e3aa63d976a7a9f9e85bd8e83d Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Thu, 25 Apr 2024 12:48:59 +0300 Subject: [PATCH 017/134] use do_call instead of do.call --- R/cv_varsel.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index a776eae47..78faa2ff1 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -205,7 +205,7 @@ cv_varsel.vsel <- function( } } - return(do.call(cv_varsel, c(list( + return(do_call(cv_varsel, c(list( object = refmodel, method = object[["args_search"]][["method"]], ndraws = object[["args_search"]][["ndraws"]], From 98757a92520217568c35d0fb1d8c984e295d8720 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Thu, 25 Apr 2024 12:53:45 +0300 Subject: [PATCH 018/134] add progress and progressr to Suggests --- DESCRIPTION | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 70d4cc510..7df40f988 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -80,7 +80,9 @@ Suggests: doParallel, future, future.callr, - doFuture + doFuture, + progress, + progressr LinkingTo: Rcpp, RcppArmadillo Additional_repositories: https://mc-stan.org/r-packages/ From 01f3bedf4ec6a8b29674f9782d2b6ca338bc7486 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Thu, 27 Jun 2024 14:28:00 +0300 Subject: [PATCH 019/134] remove unneeded code --- R/methods.R | 5 ----- 1 file changed, 5 deletions(-) diff --git a/R/methods.R b/R/methods.R index a6907a165..acee5e8bc 100644 --- a/R/methods.R +++ b/R/methods.R @@ -777,11 +777,6 @@ plot.vsel <- function( nterms_max <- as.integer(nterms_max) # Define some "pretty" text strings for the plot: - if (baseline == "ref") { - baseline_pretty <- "reference model" - } else { - baseline_pretty <- "best submodel" - } ylab <- "Value" if (deltas) { delta_lab <- "for baseline comparison" From a5c51037355f92bb2b746725a5ed2de5b566234d Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Thu, 27 Jun 2024 14:28:17 +0300 Subject: [PATCH 020/134] remove unnecessary sum --- R/summary_funs.R | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index e32f5413f..884b9c946 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -297,7 +297,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, } else { lppd_baseline = summaries_baseline$lppd } - if (!is.null(summaries_fast) && sum(n_loo Date: Fri, 28 Jun 2024 11:17:14 +0300 Subject: [PATCH 021/134] revert the addition of correct_baseline --- R/summary_funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 884b9c946..07506d5f3 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -485,7 +485,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n } else { # full LOO estimator - value <- mean(wcv * correct - correct_baseline) + value <- mean(wcv * correct) value_se <- .weighted_sd(correct - correct_baseline, wcv) / sqrt(n) } } else if (stat == "auc") { From 24fc370ec7a3d36016ae9963852d0d1215b88e3d Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Fri, 28 Jun 2024 11:27:16 +0300 Subject: [PATCH 022/134] remove unneeded code --- R/summary_funs.R | 26 -------------------------- 1 file changed, 26 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 07506d5f3..6135d7597 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -259,32 +259,6 @@ get_stat <- function(summaries, summaries_baseline = NULL, loo_inds <- which(!is.na(lppd)) n <- length(lppd) n_loo <- length(loo_inds) - ## is this needed anymore? - ## n_notna.bs <- NULL - ## if (!is.null(summaries_fast)) { - ## # Compute the performance statistics using only those observations for - ## # which fast summaries are not NA - ## if (stat %in% c("elpd", "mlpd", "gmpd")) { - ## lppd[is.na(lppd_baseline)] <- NA - ## n_notna.bs <- sum(!is.na(lppd_baseline)) - ## } - ## n_notna <- sum(!is.na(lppd)) - ## n <- length(lppd) - ## } else { - ## hasNA_y <- is.na(y_wobs_test$y_prop %||% y_wobs_test$y) - ## if (!is.null(mu_baseline)) { - ## # Compute the performance statistics using only those observations for - ## # which both `mu` and `mu_baseline` are not `NA`: - ## mu[is.na(mu_baseline)] <- NA - ## mu_baseline[is.na(mu)] <- NA - ## n_notna.bs <- sum(!is.na(mu_baseline) & !hasNA_y) - ## } - ## n_notna <- sum(!is.na(mu) & !hasNA_y) - ## n <- length(mu) - ## } - ## if (!is.null(n_notna.bs) && getOption("projpred.additional_checks", FALSE)) { - ## stopifnot(n_notna == n_notna.bs) - ## } if (n_loo == 0) { return(list(value = NA, se = NA, lq = NA, uq = NA)) } From 36f3543f1e016378970e9f1d19815c604e535668 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Fri, 28 Jun 2024 11:27:34 +0300 Subject: [PATCH 023/134] document deltas=TRUE change --- R/methods.R | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/R/methods.R b/R/methods.R index acee5e8bc..0e28d03a7 100644 --- a/R/methods.R +++ b/R/methods.R @@ -736,6 +736,12 @@ plot.vsel <- function( # .tabulate_stats()'s argument `nfeat_baseline`: nfeat_baseline <- get_nfeat_baseline(object, baseline, stats[1], resp_oscale = resp_oscale) + if (getOption("projpred.extra_verbose",FALSE) && + deltas && + !all(stats %in% c("elpd","mlpd","gmpd"))) { + message(paste0("With deltas=TRUE, statistics ", paste(stats[!(stats %in% c("elpd","mlpd","gmpd"))], collapse=", "), + " report the uncertainty relative to the baseline, but the value in the original scale.")) + } if (deltas) { nfeat_baseline_for_tab <- nfeat_baseline } else { @@ -1172,7 +1178,7 @@ plot.vsel <- function( #' in section "Details" below). #' * `"rmse"`: root mean squared error (only available in the situations #' mentioned in section "Details" below). For the corresponding standard error -#' and lower and upper confidence interval bounds, bootstrapping is used. +#' and lower and upper confidence interval bounds, the delta method is used. #' * `"acc"` (or its alias, `"pctcorr"`): classification accuracy (only #' available in the situations mentioned in section "Details" below). By #' "classification accuracy", we mean the proportion of correctly classified @@ -1194,11 +1200,15 @@ plot.vsel <- function( #' (nominal) coverage `1 - alpha`. Items `"diff"` and `"diff.se"` are only #' supported if `deltas` is `FALSE`. #' @param deltas If `TRUE`, the submodel statistics are estimated relatively to -#' the baseline model (see argument `baseline`). For the GMPD, the term +#' the baseline model (see argument `baseline`). For the `"gmpd"`, the term #' "relatively" refers to the ratio vs. the baseline model (i.e., the submodel #' statistic divided by the baseline model statistic). For all other `stats`, #' "relatively" refers to the difference from the baseline model (i.e., the -#' submodel statistic minus the baseline model statistic). +#' submodel statistic minus the baseline model statistic). For `"elpd"` and +#' `"mlpd"` the baseline performance is reported as 0. For `"gmpd"` +#' the baseline performance is reported as 1. For other statistics, the +#' baseline performance is reported in the original scale. For all +#' statistics the related uncertainty is reported relative to the baseline. #' @param alpha A number determining the (nominal) coverage `1 - alpha` of the #' normal-approximation (or bootstrap or exponentiated normal-approximation; #' see argument `stats`) confidence intervals. For example, in case of the @@ -1282,7 +1292,7 @@ summary.vsel <- function( ) { validate_vsel_object_stats(object, stats, resp_oscale = resp_oscale) baseline <- validate_baseline(object$refmodel, baseline, deltas) - + # Initialize output: out <- c( object$refmodel[c("formula", "family")], From eeef49a3a7a9397c3a080e77d12c8656dfaa39c6 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Fri, 28 Jun 2024 12:12:11 +0300 Subject: [PATCH 024/134] wcv -> wobs in summary_funs --- R/summary_funs.R | 56 ++++++++++++++++++++++++------------------------ 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 6135d7597..3f61481f1 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -295,8 +295,8 @@ get_stat <- function(summaries, summaries_baseline = NULL, } } else if (stat %in% c("mse", "rmse", "R2")) { y <- y_wobs_test$y_prop %||% y_wobs_test$y - wcv <- y_wobs_test$wobs - wcv <- n * wcv / sum(wcv) + wobs <- y_wobs_test$wobs + wobs <- n * wobs / sum(wobs) if (is.null(summaries_baseline)) { mu_baseline <- 0 } else { @@ -305,14 +305,14 @@ get_stat <- function(summaries, summaries_baseline = NULL, # Use normal approximation for mse and delta method for rmse and R2 if (is.null(summaries_fast) || n_loo==n) { # full LOO estimator - value <- mean(wcv * (mu - y)^2) - value_se <- .weighted_sd((mu - y)^2, wcv) / sqrt(n) + value <- mean(wobs * (mu - y)^2) + value_se <- .weighted_sd((mu - y)^2, wobs) / sqrt(n) } else { # subsampling difference estimator (Magnusson et al., 2020) srs_diffe <- .srs_diff_est_w(y_approx = (summaries_fast$mu - y)^2, y = ((mu-y)^2)[loo_inds], y_idx = loo_inds, - w = wcv) + w = wobs) value <- srs_diffe$y_hat / n # combine estimates of var(y_hat) and var(y) value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n @@ -322,13 +322,13 @@ get_stat <- function(summaries, summaries_baseline = NULL, var_mse_e <- value_se^2 if (!is.null(summaries_baseline)) { # delta=TRUE, variance of difference of two normally distributed - mse_b <- mean(wcv * (mu_baseline - y)^2) - var_mse_b <- .weighted_sd((mu_baseline - y)^2, wcv)^2 / n + mse_b <- mean(wobs * (mu_baseline - y)^2) + var_mse_b <- .weighted_sd((mu_baseline - y)^2, wobs)^2 / n if (is.null(summaries_fast) || n_loo==n) { - cov_mse_e_b <- mean(wcv * ((mu - y)^2-mse_e) * + cov_mse_e_b <- mean(wobs * ((mu - y)^2-mse_e) * ((mu_baseline-y)^2-mse_b)) / n } else { - mse_e_fast <- mean(wcv * (summaries_fast$mu-y)^2) + mse_e_fast <- mean(wobs * (summaries_fast$mu-y)^2) srs_diffe <- .srs_diff_est_w(y_approx = ((summaries_fast$mu - y)^2 -mse_e_fast) * @@ -336,7 +336,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, y = (((mu - y)^2 -mse_e) * ((mu_baseline-y)^2 -mse_b))[loo_inds], y_idx = loo_inds, - w = wcv) + w = wobs) cov_mse_e_b <- srs_diffe$y_hat / n^2 } value_se <- sqrt(value_se^2 - 2*cov_mse_e_b + var_mse_b) @@ -348,21 +348,21 @@ get_stat <- function(summaries, summaries_baseline = NULL, value_se <- sqrt(value_se^2 / mse_e / 4) } else if (stat == "R2") { # simple transformation of mse - mse_y <- mean(wcv * (mean(y)-y)^2) + mse_y <- mean(wobs * (mean(y)-y)^2) value <- 1 - mse_e / mse_y # the first-order Taylor approximation of the variance - var_mse_y <- .weighted_sd((mean(y)-y)^2, wcv)^2 / n + var_mse_y <- .weighted_sd((mean(y)-y)^2, wobs)^2 / n if (is.null(summaries_fast) || n_loo==n) { if (is.null(summaries_baseline)) { - cov_mse_e_y <- mean(wcv * ((mu - y)^2 - mse_e) * + cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e) * ((mean(y)-y)^2-mse_y)) / n } else { - cov_mse_e_y <- mean(wcv * ((mu - y)^2 - mse_e - + cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e - ((mu_baseline - y)^2 - mse_b)) * ((mean(y)-y)^2-mse_y)) / n } } else { - mse_e_fast <- mean(wcv * (summaries_fast$mu-y)^2) + mse_e_fast <- mean(wobs * (summaries_fast$mu-y)^2) if (is.null(summaries_baseline)) { srs_diffe <- .srs_diff_est_w(y_approx = @@ -371,7 +371,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, y = (((mu - y)^2 - mse_e) * ((mean(y)-y)^2 -mse_y))[loo_inds], y_idx = loo_inds, - w = wcv) + w = wobs) } else { srs_diffe <- .srs_diff_est_w(y_approx = @@ -382,7 +382,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, ((mu_baseline - y)^2 - mse_b)) * ((mean(y)-y)^2 -mse_y))[loo_inds], y_idx = loo_inds, - w = wcv) + w = wobs) } cov_mse_e_y <- srs_diffe$y_hat / n^2 } @@ -398,8 +398,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, } } else if (stat %in% c("acc", "pctcorr", "auc")) { y <- y_wobs_test$y - wcv <- y_wobs_test$wobs - wcv <- n * wcv / sum(wcv) + wobs <- rep(1, n) if (!is.null(y_wobs_test$y_prop)) { # CAUTION: The following checks also ensure that `y` does not have `NA`s # (see the other "CAUTION" comments below for changes that are needed if @@ -417,8 +416,9 @@ get_stat <- function(summaries, summaries_baseline = NULL, } else { mu_baseline <- NULL } - wcv <- rep(wcv, y_wobs_test$wobs) - wcv <- n * wcv / sum(wcv) + n <- sum(!is.na(mu)) + wobs <- rep(wobs, y_wobs_test$wobs) + wobs <- n * wobs / sum(wobs) } else { stopifnot(all(y_wobs_test$wobs == 1)) if (!is.null(summaries_baseline)) { @@ -453,14 +453,14 @@ get_stat <- function(summaries, summaries_baseline = NULL, srs_diffe <- .srs_diff_est_w(y_approx = correct_fast - correct_baseline, y = (correct-correct_baseline)[loo_inds], y_idx = loo_inds, - w = wcv) - value <- srs_diffe$y_hat / n + mean(wcv * correct_baseline) + w = wobs) + value <- srs_diffe$y_hat / n + mean(wobs * correct_baseline) # combine estimates of var(y_hat) and var(y) value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n } else { # full LOO estimator - value <- mean(wcv * correct) - value_se <- .weighted_sd(correct - correct_baseline, wcv) / sqrt(n) + value <- mean(wobs * correct) + value_se <- .weighted_sd(correct - correct_baseline, wobs) / sqrt(n) } } else if (stat == "auc") { if (!is.null(summaries_fast) && n_loo Date: Fri, 28 Jun 2024 12:12:31 +0300 Subject: [PATCH 025/134] newline in startup message to make it more readable --- R/misc.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/misc.R b/R/misc.R index 42aa2fab4..9166e56bc 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1,7 +1,7 @@ .onAttach <- function(...) { ver <- utils::packageVersion("projpred") - msg <- paste0("This is projpred version ", ver, ".") - msg <- paste0(msg, " ", "NOTE: In projpred 2.7.0, the default search method ", + msg <- paste0("This is projpred version ", ver, ".\n") + msg <- paste0(msg, "NOTE: In projpred 2.7.0, the default search method ", "was set to \"forward\" (for all kinds of models).") packageStartupMessage(msg) } From 10ab731b5a20fd86cd1160d4998a76592b056fc3 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 30 Jun 2024 21:59:56 +0200 Subject: [PATCH 026/134] rename remaining occurrences of `wcv` to `wobs` --- R/misc.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/misc.R b/R/misc.R index 9166e56bc..a704784a9 100644 --- a/R/misc.R +++ b/R/misc.R @@ -66,7 +66,7 @@ ilinkfun_raw <- function(x, link_nm) { .auc <- function(x) { resp <- x[, 1] pred <- x[, 2] - wcv <- x[, 3] + wobs <- x[, 3] # Make it explicit that `x` should not be used anymore (due to the possibility # of `NA`s, but also due to the re-ordering): @@ -77,9 +77,9 @@ ilinkfun_raw <- function(x, link_nm) { resp <- resp[ord] pred <- pred[ord] - wcv <- wcv[ord] + wobs <- wobs[ord] - w0 <- w1 <- wcv + w0 <- w1 <- wobs # CAUTION: The following check also ensures that `resp` does not have `NA`s: stopifnot(all(resp %in% c(0, 1))) w0[resp == 1] <- 0 # for calculating the false positive rate (fpr) From c23fa783b1dc044cbe4e52e25682e530192f6fde Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 30 Jun 2024 22:14:07 +0200 Subject: [PATCH 027/134] re-add a comment --- R/summary_funs.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/summary_funs.R b/R/summary_funs.R index 3f61481f1..ffdb80792 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -416,6 +416,8 @@ get_stat <- function(summaries, summaries_baseline = NULL, } else { mu_baseline <- NULL } + # CAUTION: If `y` is allowed to have `NA`s here, then `n` needs to be + # adapted: n <- sum(!is.na(mu)) wobs <- rep(wobs, y_wobs_test$wobs) wobs <- n * wobs / sum(wobs) From 71a2198f791fe837853a855dc07a380d4e1ceac2 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 12 Jul 2024 00:36:32 +0200 Subject: [PATCH 028/134] progressr: remove code that is part of the end-user's API (see ) --- R/cv_varsel.R | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index eb00e346a..730d0eb68 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -951,7 +951,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } if (verbose) { - verb_txt_start <- + verb_txt_start <- if (!search_out_rks_was_null) { verb_txt_mid <- "" } else { @@ -1044,8 +1044,6 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, requireNamespace("progress", quietly = TRUE) && interactive()) { progressr_installed <- TRUE - progressr::handlers(global = TRUE) - progressr::handlers("progress") p <- progressr::progressor(along = seq_along(inds)) } else { progressr_installed <- FALSE @@ -1378,8 +1376,6 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, requireNamespace("progress", quietly = TRUE) && interactive()) { use_progressr <- TRUE - progressr::handlers(global = TRUE) - progressr::handlers("progress") p <- progressr::progressor(along = seq_along(inds)) } else { use_progressr <- FALSE From b41ad1eb0c2ce337c1f32fb0f4b646d04d428b1a Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 12 Jul 2024 00:38:28 +0200 Subject: [PATCH 029/134] use `use_progressr` consistently --- R/cv_varsel.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 730d0eb68..ddb8358e1 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1043,10 +1043,10 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, requireNamespace("progressr", quietly = TRUE) && requireNamespace("progress", quietly = TRUE) && interactive()) { - progressr_installed <- TRUE + use_progressr <- TRUE p <- progressr::progressor(along = seq_along(inds)) } else { - progressr_installed <- FALSE + use_progressr <- FALSE } .select <- .select dot_args <- list(...) @@ -1058,7 +1058,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, "loo_ref_oscale", "validset", "loo_sub", "mu_sub", "loo_sub_oscale", "mu_sub_oscale") ) %do_projpred% { - if (progressr_installed) p("") + if (use_progressr) p("") do.call(one_obs, c(list(run_index = run_index, verbose_search = FALSE), dot_args)) } From 81b4bf0ae07e2fbb9a1a31f01753902a206707b6 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 12 Jul 2024 00:41:14 +0200 Subject: [PATCH 030/134] package `progress` is no longer needed in the "Suggests" dependencies --- DESCRIPTION | 1 - R/cv_varsel.R | 2 -- 2 files changed, 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 966803e48..5cb70c335 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -81,7 +81,6 @@ Suggests: future, future.callr, doFuture, - progress, progressr LinkingTo: Rcpp, RcppArmadillo Additional_repositories: diff --git a/R/cv_varsel.R b/R/cv_varsel.R index ddb8358e1..0caca8448 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1041,7 +1041,6 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } if (verbose && requireNamespace("progressr", quietly = TRUE) && - requireNamespace("progress", quietly = TRUE) && interactive()) { use_progressr <- TRUE p <- progressr::progressor(along = seq_along(inds)) @@ -1373,7 +1372,6 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, } if (verbose && requireNamespace("progressr", quietly = TRUE) && - requireNamespace("progress", quietly = TRUE) && interactive()) { use_progressr <- TRUE p <- progressr::progressor(along = seq_along(inds)) From 497a245adc278e03f5aab419fb55f6a252afbcd9 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 12 Jul 2024 00:54:36 +0200 Subject: [PATCH 031/134] add function `get_use_progressr()` to avoid redundancies; also introduce global option `projpred.use_progressr` so that all users (even those with `progressr` installed) may refrain from using `progressr`; also handle the export of `use_progressr` --- R/cv_varsel.R | 12 ++++-------- R/misc.R | 5 +++++ 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 0caca8448..2c9a50e6c 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1039,9 +1039,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, if (!requireNamespace("doRNG", quietly = TRUE)) { stop("Please install the 'doRNG' package.") } - if (verbose && - requireNamespace("progressr", quietly = TRUE) && - interactive()) { + if (verbose && get_use_progressr()) { use_progressr <- TRUE p <- progressr::progressor(along = seq_along(inds)) } else { @@ -1052,7 +1050,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, `%do_projpred%` <- doRNG::`%dorng%` res_cv <- foreach::foreach( run_index = seq_along(inds), - .export = c("one_obs", "dot_args"), + .export = c("one_obs", "dot_args", "use_progressr"), .noexport = c("mu_offs_oscale", "loglik_forPSIS", "psisloo", "y_lat_E", "loo_ref_oscale", "validset", "loo_sub", "mu_sub", "loo_sub_oscale", "mu_sub_oscale") @@ -1370,9 +1368,7 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, if (!requireNamespace("doRNG", quietly = TRUE)) { stop("Please install the 'doRNG' package.") } - if (verbose && - requireNamespace("progressr", quietly = TRUE) && - interactive()) { + if (verbose && get_use_progressr()) { use_progressr <- TRUE p <- progressr::progressor(along = seq_along(inds)) } else { @@ -1384,7 +1380,7 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, res_cv <- foreach::foreach( list_cv_k = list_cv, search_out_rks_k = search_out_rks, - .export = c("one_fold", "dot_args"), + .export = c("one_fold", "dot_args", "use_progressr"), .noexport = c("list_cv", "search_out_rks") ) %do_projpred% { if (use_progressr) p("") diff --git a/R/misc.R b/R/misc.R index a704784a9..3b62d0213 100644 --- a/R/misc.R +++ b/R/misc.R @@ -705,3 +705,8 @@ element_unq <- function(list_obj, nm) { } return(el_unq) } + +get_use_progressr <- function() { + getOption("projpred.use_progressr", + requireNamespace("progressr", quietly = TRUE) && interactive()) +} From 5ac404131609eda63886e72a94b0d6f0c05ab7d3 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 12 Jul 2024 00:57:56 +0200 Subject: [PATCH 032/134] rename `p` to `progressor_obj` to identify it more clearly and to avoid potential problems when exporting to parallel workers (the export is handled here explicitly as well) --- R/cv_varsel.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 2c9a50e6c..d1237e531 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1041,7 +1041,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } if (verbose && get_use_progressr()) { use_progressr <- TRUE - p <- progressr::progressor(along = seq_along(inds)) + progressor_obj <- progressr::progressor(along = seq_along(inds)) } else { use_progressr <- FALSE } @@ -1050,12 +1050,12 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, `%do_projpred%` <- doRNG::`%dorng%` res_cv <- foreach::foreach( run_index = seq_along(inds), - .export = c("one_obs", "dot_args", "use_progressr"), + .export = c("one_obs", "dot_args", "use_progressr", "progressor_obj"), .noexport = c("mu_offs_oscale", "loglik_forPSIS", "psisloo", "y_lat_E", "loo_ref_oscale", "validset", "loo_sub", "mu_sub", "loo_sub_oscale", "mu_sub_oscale") ) %do_projpred% { - if (use_progressr) p("") + if (use_progressr) progressor_obj("") do.call(one_obs, c(list(run_index = run_index, verbose_search = FALSE), dot_args)) } @@ -1370,7 +1370,7 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, } if (verbose && get_use_progressr()) { use_progressr <- TRUE - p <- progressr::progressor(along = seq_along(inds)) + progressor_obj <- progressr::progressor(along = seq_along(inds)) } else { use_progressr <- FALSE } @@ -1380,10 +1380,10 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, res_cv <- foreach::foreach( list_cv_k = list_cv, search_out_rks_k = search_out_rks, - .export = c("one_fold", "dot_args", "use_progressr"), + .export = c("one_fold", "dot_args", "use_progressr", "progressor_obj"), .noexport = c("list_cv", "search_out_rks") ) %do_projpred% { - if (use_progressr) p("") + if (use_progressr) progressor_obj("") do_call(one_fold, c(list(fold = list_cv_k, rk = search_out_rks_k, verbose_search = FALSE), dot_args)) From 825fc3d09735a9cfec3624ef99b3ab21fa8165ba Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 12 Jul 2024 01:01:49 +0200 Subject: [PATCH 033/134] use argument `steps` of `progressr::progressor()` explicitly and fix a bug in `kfold_varsel()` where object `inds` does not exist --- R/cv_varsel.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index d1237e531..6e93d17d7 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1041,7 +1041,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } if (verbose && get_use_progressr()) { use_progressr <- TRUE - progressor_obj <- progressr::progressor(along = seq_along(inds)) + progressor_obj <- progressr::progressor(length(inds)) } else { use_progressr <- FALSE } @@ -1370,7 +1370,7 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, } if (verbose && get_use_progressr()) { use_progressr <- TRUE - progressor_obj <- progressr::progressor(along = seq_along(inds)) + progressor_obj <- progressr::progressor(length(list_cv)) } else { use_progressr <- FALSE } From 1655c84475d1d88e87e434f08792f3e3f4f02d5c Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 12 Jul 2024 01:06:48 +0200 Subject: [PATCH 034/134] remove unnecessary `""` in the `progressor_obj()` call --- R/cv_varsel.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 6e93d17d7..81112accd 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1055,7 +1055,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, "loo_ref_oscale", "validset", "loo_sub", "mu_sub", "loo_sub_oscale", "mu_sub_oscale") ) %do_projpred% { - if (use_progressr) progressor_obj("") + if (use_progressr) progressor_obj() do.call(one_obs, c(list(run_index = run_index, verbose_search = FALSE), dot_args)) } @@ -1383,7 +1383,7 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, .export = c("one_fold", "dot_args", "use_progressr", "progressor_obj"), .noexport = c("list_cv", "search_out_rks") ) %do_projpred% { - if (use_progressr) progressor_obj("") + if (use_progressr) progressor_obj() do_call(one_fold, c(list(fold = list_cv_k, rk = search_out_rks_k, verbose_search = FALSE), dot_args)) From 1633137ad6a050d9768c526517c35d6f1c748482 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 12 Jul 2024 01:11:10 +0200 Subject: [PATCH 035/134] use a simpler solution for identifying whether `progressr` should be used --- R/cv_varsel.R | 18 ++++++++---------- R/misc.R | 2 +- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 81112accd..57e1544d9 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1039,23 +1039,22 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, if (!requireNamespace("doRNG", quietly = TRUE)) { stop("Please install the 'doRNG' package.") } - if (verbose && get_use_progressr()) { - use_progressr <- TRUE + if (verbose && use_progressr()) { progressor_obj <- progressr::progressor(length(inds)) } else { - use_progressr <- FALSE + progressor_obj <- NULL } .select <- .select dot_args <- list(...) `%do_projpred%` <- doRNG::`%dorng%` res_cv <- foreach::foreach( run_index = seq_along(inds), - .export = c("one_obs", "dot_args", "use_progressr", "progressor_obj"), + .export = c("one_obs", "dot_args", "progressor_obj"), .noexport = c("mu_offs_oscale", "loglik_forPSIS", "psisloo", "y_lat_E", "loo_ref_oscale", "validset", "loo_sub", "mu_sub", "loo_sub_oscale", "mu_sub_oscale") ) %do_projpred% { - if (use_progressr) progressor_obj() + if (!is.null(progressor_obj)) progressor_obj() do.call(one_obs, c(list(run_index = run_index, verbose_search = FALSE), dot_args)) } @@ -1368,11 +1367,10 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, if (!requireNamespace("doRNG", quietly = TRUE)) { stop("Please install the 'doRNG' package.") } - if (verbose && get_use_progressr()) { - use_progressr <- TRUE + if (verbose && use_progressr()) { progressor_obj <- progressr::progressor(length(list_cv)) } else { - use_progressr <- FALSE + progressor_obj <- NULL } .select <- .select dot_args <- list(...) @@ -1380,10 +1378,10 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, res_cv <- foreach::foreach( list_cv_k = list_cv, search_out_rks_k = search_out_rks, - .export = c("one_fold", "dot_args", "use_progressr", "progressor_obj"), + .export = c("one_fold", "dot_args", "progressor_obj"), .noexport = c("list_cv", "search_out_rks") ) %do_projpred% { - if (use_progressr) progressor_obj() + if (!is.null(progressor_obj)) progressor_obj() do_call(one_fold, c(list(fold = list_cv_k, rk = search_out_rks_k, verbose_search = FALSE), dot_args)) diff --git a/R/misc.R b/R/misc.R index 3b62d0213..b680f7ede 100644 --- a/R/misc.R +++ b/R/misc.R @@ -706,7 +706,7 @@ element_unq <- function(list_obj, nm) { return(el_unq) } -get_use_progressr <- function() { +use_progressr <- function() { getOption("projpred.use_progressr", requireNamespace("progressr", quietly = TRUE) && interactive()) } From 0996e7c476ba68d940a834314f3cbf2beebe097d Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 12 Jul 2024 01:17:51 +0200 Subject: [PATCH 036/134] add the possibility to use `progressr` at the remaining occurrences of `foreach::foreach()` --- R/divergence_minimizers.R | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/R/divergence_minimizers.R b/R/divergence_minimizers.R index 0fe07e034..245bcbbd5 100644 --- a/R/divergence_minimizers.R +++ b/R/divergence_minimizers.R @@ -91,18 +91,24 @@ divmin <- function( if (!requireNamespace("iterators", quietly = TRUE)) { stop("Please install the 'iterators' package.") } + if (verbose_divmin && use_progressr()) { + progressor_obj <- progressr::progressor(length(formulas)) + } else { + progressor_obj <- NULL + } dot_args <- list(...) `%do_projpred%` <- foreach::`%dopar%` outdmin <- foreach::foreach( formula_s = formulas, projpred_var_s = iterators::iter(projpred_var, by = "column"), projpred_formula_no_random_s = projpred_formulas_no_random, - .export = c("sdivmin", "projpred_random", "dot_args"), + .export = c("sdivmin", "projpred_random", "dot_args", "progressor_obj"), .noexport = c( "object", "p_sel", "search_path", "p_ref", "refmodel", "formulas", "projpred_var", "projpred_ws_aug", "projpred_formulas_no_random" ) ) %do_projpred% { + if (!is.null(progressor_obj)) progressor_obj() mssgs_warns_capt <- capt_mssgs_warns( soutdmin <- do.call( sdivmin, @@ -649,19 +655,25 @@ divmin_augdat <- function( if (!requireNamespace("iterators", quietly = TRUE)) { stop("Please install the 'iterators' package.") } + if (verbose_divmin && use_progressr()) { + progressor_obj <- progressr::progressor(ncol(projpred_ws_aug)) + } else { + progressor_obj <- NULL + } dot_args <- list(...) `%do_projpred%` <- foreach::`%dopar%` outdmin <- foreach::foreach( projpred_w_aug_s = iterators::iter(projpred_ws_aug, by = "column"), .export = c( "sdivmin", "formula", "data", "family", "projpred_formula_no_random", - "projpred_random", "dot_args" + "projpred_random", "dot_args", "progressor_obj" ), .noexport = c( "object", "p_sel", "search_path", "p_ref", "refmodel", "projpred_var", "projpred_ws_aug", "linkobjs" ) ) %do_projpred% { + if (!is.null(progressor_obj)) progressor_obj() mssgs_warns_capt <- capt_mssgs_warns( soutdmin <- do.call( sdivmin, From 8488e3eeddfd376b8ba623bc761c8bed46229857 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 12 Jul 2024 21:03:41 +0200 Subject: [PATCH 037/134] fix a bug (`could not find function "do_call"`) when using the `doFuture` backend for parallelization (this issue does not get resolved when installing projpred (instead of using `devtools::load_all()`)) --- R/cv_varsel.R | 2 ++ R/divergence_minimizers.R | 2 ++ 2 files changed, 4 insertions(+) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 57e1544d9..c9a7f6e39 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1049,6 +1049,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, `%do_projpred%` <- doRNG::`%dorng%` res_cv <- foreach::foreach( run_index = seq_along(inds), + .packages = c("projpred"), .export = c("one_obs", "dot_args", "progressor_obj"), .noexport = c("mu_offs_oscale", "loglik_forPSIS", "psisloo", "y_lat_E", "loo_ref_oscale", "validset", "loo_sub", "mu_sub", @@ -1378,6 +1379,7 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, res_cv <- foreach::foreach( list_cv_k = list_cv, search_out_rks_k = search_out_rks, + .packages = c("projpred"), .export = c("one_fold", "dot_args", "progressor_obj"), .noexport = c("list_cv", "search_out_rks") ) %do_projpred% { diff --git a/R/divergence_minimizers.R b/R/divergence_minimizers.R index 245bcbbd5..dbab5a6cd 100644 --- a/R/divergence_minimizers.R +++ b/R/divergence_minimizers.R @@ -102,6 +102,7 @@ divmin <- function( formula_s = formulas, projpred_var_s = iterators::iter(projpred_var, by = "column"), projpred_formula_no_random_s = projpred_formulas_no_random, + .packages = c("projpred"), .export = c("sdivmin", "projpred_random", "dot_args", "progressor_obj"), .noexport = c( "object", "p_sel", "search_path", "p_ref", "refmodel", "formulas", @@ -664,6 +665,7 @@ divmin_augdat <- function( `%do_projpred%` <- foreach::`%dopar%` outdmin <- foreach::foreach( projpred_w_aug_s = iterators::iter(projpred_ws_aug, by = "column"), + .packages = c("projpred"), .export = c( "sdivmin", "formula", "data", "family", "projpred_formula_no_random", "projpred_random", "dot_args", "progressor_obj" From 118838cf1b30836422ccdf3ef1f1fdb5fa6c7e68 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 15 Jul 2024 22:33:11 +0200 Subject: [PATCH 038/134] remove `.select <- .select` (the issue does not occur when installing projpred (instead of using `devtools::load_all()`)) --- R/cv_varsel.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index c9a7f6e39..f0e2225e8 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -1044,7 +1044,6 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } else { progressor_obj <- NULL } - .select <- .select dot_args <- list(...) `%do_projpred%` <- doRNG::`%dorng%` res_cv <- foreach::foreach( @@ -1373,7 +1372,6 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, } else { progressor_obj <- NULL } - .select <- .select dot_args <- list(...) `%do_projpred%` <- doRNG::`%dorng%` res_cv <- foreach::foreach( From d663df89a33a3afeabcec0c6d2f282d90fe63ec6 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 17 Jul 2024 23:10:13 +0200 Subject: [PATCH 039/134] fix a bug when checking arguments in `cv_varsel.vsel()` --- R/cv_varsel.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index f0e2225e8..9f554d0c0 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -191,11 +191,13 @@ cv_varsel.vsel <- function( n_arg_nms_internal_used <- length(arg_nms_internal_used) dots <- list(...) for (arg in arg_nms_internal_used) { - if (!identical(object[[arg]], dots[[arg]])) { - message("Argument \"", arg, "\" ignored. Using the argument value stored in the varsel object (\"", object[[arg]], "\").") + if (!identical(object[["args_search"]][[arg]], dots[[arg]])) { + message("Argument \"", arg, "\" ignored. Using the argument value ", + "stored in the `vsel` object (\"", object[["args_search"]][[arg]], + "\").") } ## remove duplicate arguments - dots[[arg]]<-NULL + dots[[arg]] <- NULL } refmodel <- get_refmodel(object) From b6fe949739da14c1496dfcf2fb049e084e9827de Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 17 Jul 2024 23:17:43 +0200 Subject: [PATCH 040/134] minor cleaning for consistency --- R/cv_varsel.R | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 9f554d0c0..2e4da08a6 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -183,7 +183,7 @@ cv_varsel.vsel <- function( cvfits = object$cvfits, validate_search = object$validate_search %||% TRUE, ... - ) { +) { ## the following arguments should not change arg_nms_internal <- c("method", "ndraws", "nclusters", "nterms_max", "search_control", "penalty", "search_terms") @@ -192,9 +192,9 @@ cv_varsel.vsel <- function( dots <- list(...) for (arg in arg_nms_internal_used) { if (!identical(object[["args_search"]][[arg]], dots[[arg]])) { - message("Argument \"", arg, "\" ignored. Using the argument value ", - "stored in the `vsel` object (\"", object[["args_search"]][[arg]], - "\").") + message("Argument `", arg, "` ignored. Using the argument value ", + "stored in the `vsel` object (`", object[["args_search"]][[arg]], + "``).") } ## remove duplicate arguments dots[[arg]] <- NULL @@ -828,11 +828,11 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, if (no_psis_eval) { if (getOption("projpred.warn_psis", TRUE)) { verb_out( - "Using standard importance sampling (SIS) due to a small number of", - ifelse(refit_prj, - ifelse(!is.null(ndraws_pred), " draws", " clusters"), - ifelse(!is.null(ndraws), " draws", " clusters") - ), + "Using standard importance sampling (SIS) due to a small number of", + ifelse(refit_prj, + ifelse(!is.null(ndraws_pred), " draws", " clusters"), + ifelse(!is.null(ndraws), " draws", " clusters") + ), verbose=verbose) } # Use loo::sis(). @@ -954,11 +954,11 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, if (verbose) { verb_txt_start <- - if (!search_out_rks_was_null) { - verb_txt_mid <- "" - } else { - verb_txt_mid <- "the search and " - } + if (!search_out_rks_was_null) { + verb_txt_mid <- "" + } else { + verb_txt_mid <- "the search and " + } verb_out("-----\nRunning ", ifelse(!search_out_rks_was_null, "", paste0(method, " search with ", @@ -1039,7 +1039,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, stop("Please install the 'foreach' package.") } if (!requireNamespace("doRNG", quietly = TRUE)) { - stop("Please install the 'doRNG' package.") + stop("Please install the 'doRNG' package.") } if (verbose && use_progressr()) { progressor_obj <- progressr::progressor(length(inds)) From d9fdbaf1ba842ae247256426505b430d49d3bba7 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 17 Jul 2024 23:25:36 +0200 Subject: [PATCH 041/134] don't include the argument content in the message as the argument content may be a list, for example --- R/cv_varsel.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 2e4da08a6..921504028 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -192,9 +192,8 @@ cv_varsel.vsel <- function( dots <- list(...) for (arg in arg_nms_internal_used) { if (!identical(object[["args_search"]][[arg]], dots[[arg]])) { - message("Argument `", arg, "` ignored. Using the argument value ", - "stored in the `vsel` object (`", object[["args_search"]][[arg]], - "``).") + message("Argument `", arg, "` ignored. Using the argument value stored ", + "in the `vsel` object.") } ## remove duplicate arguments dots[[arg]] <- NULL From 5b2f28380c5dfcade8f48d9acf47694dfec239f6 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Sun, 11 Aug 2024 17:00:35 +0300 Subject: [PATCH 042/134] add functionality for option deltas='mixed' --- R/methods.R | 40 ++++++++++++++++++++++++++++------------ R/summary_funs.R | 32 +++++++++++++++++++++----------- 2 files changed, 49 insertions(+), 23 deletions(-) diff --git a/R/methods.R b/R/methods.R index 0e28d03a7..fadd3e771 100644 --- a/R/methods.R +++ b/R/methods.R @@ -736,13 +736,13 @@ plot.vsel <- function( # .tabulate_stats()'s argument `nfeat_baseline`: nfeat_baseline <- get_nfeat_baseline(object, baseline, stats[1], resp_oscale = resp_oscale) - if (getOption("projpred.extra_verbose",FALSE) && - deltas && - !all(stats %in% c("elpd","mlpd","gmpd"))) { - message(paste0("With deltas=TRUE, statistics ", paste(stats[!(stats %in% c("elpd","mlpd","gmpd"))], collapse=", "), - " report the uncertainty relative to the baseline, but the value in the original scale.")) - } - if (deltas) { + ## if (getOption("projpred.extra_verbose",FALSE) && + ## deltas && + ## !all(stats %in% c("elpd","mlpd","gmpd"))) { + ## message(paste0("With deltas=TRUE, statistics ", paste(stats[!(stats %in% c("elpd","mlpd","gmpd"))], collapse=", "), + ## " report the uncertainty relative to the baseline, but the value in the original scale.")) + ## } + if (is.character(deltas) || deltas) { nfeat_baseline_for_tab <- nfeat_baseline } else { nfeat_baseline_for_tab <- NULL @@ -751,7 +751,7 @@ plot.vsel <- function( # Compute the predictive performance statistics: stats_table_all <- .tabulate_stats(object, stats, alpha = alpha, nfeat_baseline = nfeat_baseline_for_tab, - resp_oscale = resp_oscale, ...) + resp_oscale = resp_oscale, deltas, ...) stats_ref <- subset(stats_table_all, stats_table_all$size == Inf) stats_sub <- subset(stats_table_all, stats_table_all$size != Inf) stats_bs <- subset(stats_table_all, stats_table_all$size == nfeat_baseline) @@ -784,7 +784,7 @@ plot.vsel <- function( # Define some "pretty" text strings for the plot: ylab <- "Value" - if (deltas) { + if (is.character(deltas) || deltas) { delta_lab <- "for baseline comparison" } else { delta_lab <- "" @@ -958,13 +958,28 @@ plot.vsel <- function( } # Create the plot: - if (deltas) { + if (is.character(deltas) || deltas) { data_gg$statistic[data_gg$statistic=="elpd"] <- "elpd_diff" stats_ref$statistic[stats_ref$statistic=="elpd"] <- "elpd_diff" data_gg$statistic[data_gg$statistic=="mlpd"] <- "mlpd_diff" stats_ref$statistic[stats_ref$statistic=="mlpd"] <- "mlpd_diff" data_gg$statistic[data_gg$statistic=="gmpd"] <- "gmpd_ratio" stats_ref$statistic[stats_ref$statistic=="gmpd"] <- "gmpd_ratio" + if (!(is.character(deltas) && identical(deltas,'mixed'))) { + data_gg$statistic[data_gg$statistic=="mse"] <- "mse_diff" + stats_ref$statistic[stats_ref$statistic=="mse"] <- "mse_diff" + data_gg$statistic[data_gg$statistic=="rmse"] <- "rmse_diff" + stats_ref$statistic[stats_ref$statistic=="rmse"] <- "rmse_diff" + data_gg$statistic[data_gg$statistic=="rmse"] <- "rmse_diff" + stats_ref$statistic[stats_ref$statistic=="R2"] <- "R2_diff" + data_gg$statistic[data_gg$statistic=="R2"] <- "R2_diff" + stats_ref$statistic[stats_ref$statistic=="acc"] <- "acc_diff" + data_gg$statistic[data_gg$statistic=="acc"] <- "acc_diff" + stats_ref$statistic[stats_ref$statistic=="pctcorr"] <- "pctcorr_diff" + data_gg$statistic[data_gg$statistic=="pctcorr"] <- "pctcorr_diff" + stats_ref$statistic[stats_ref$statistic=="auc"] <- "auc_diff" + data_gg$statistic[data_gg$statistic=="auc"] <- "auc_diff" + } } pp <- ggplot(data = data_gg, mapping = aes(x = .data[["size"]], y = .data[["value"]], @@ -1207,7 +1222,8 @@ plot.vsel <- function( #' submodel statistic minus the baseline model statistic). For `"elpd"` and #' `"mlpd"` the baseline performance is reported as 0. For `"gmpd"` #' the baseline performance is reported as 1. For other statistics, the -#' baseline performance is reported in the original scale. For all +#' baseline performance is reported as 0 if `deltas=TRUE` and in the original +#' scale if `deltas="mixed"`. If `deltas=TRUE` or `deltas="mixed"`, for all #' statistics the related uncertainty is reported relative to the baseline. #' @param alpha A number determining the (nominal) coverage `1 - alpha` of the #' normal-approximation (or bootstrap or exponentiated normal-approximation; @@ -1326,7 +1342,7 @@ summary.vsel <- function( } stats_table_all <- .tabulate_stats(object, stats, alpha = alpha, nfeat_baseline = nfeat_baseline_for_tab, - resp_oscale = resp_oscale, ...) + resp_oscale = resp_oscale, deltas, ...) # Extract the reference model performance results from `stats_table_all`: stats_table_ref <- subset(stats_table_all, stats_table_all$size == Inf) diff --git a/R/summary_funs.R b/R/summary_funs.R index ffdb80792..d0c635b84 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -88,7 +88,8 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, # statistics relative to the baseline model of that size (`nfeat_baseline = Inf` # means that the baseline model is the reference model). .tabulate_stats <- function(varsel, stats, alpha = 0.05, - nfeat_baseline = NULL, resp_oscale = TRUE, ...) { + nfeat_baseline = NULL, resp_oscale = TRUE, + deltas, ...) { stat_tab <- data.frame() summaries_ref <- varsel$summaries$ref summaries_sub <- varsel$summaries$sub @@ -200,7 +201,8 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, res <- get_stat(summaries = summaries_ref, summaries_baseline = summaries_baseline, summaries_fast = NULL, - varsel$y_wobs_test, stat, alpha = alpha, ...) + varsel$y_wobs_test, stat, alpha = alpha, + deltas, ...) row <- data.frame( data = varsel$type_test, size = Inf, delta = delta, statistic = stat, value = res$value, lq = res$lq, uq = res$uq, se = res$se, diff = NA, @@ -213,12 +215,14 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, diff <- get_stat(summaries = summaries_sub[[k]], summaries_baseline = summaries_baseline, summaries_fast = summaries_fast_sub[[k]], - varsel$y_wobs_test, stat, alpha = alpha, ...) + varsel$y_wobs_test, stat, alpha = alpha, + deltas, ...) if (!delta) { res <- get_stat(summaries = summaries_sub[[k]], summaries_baseline = NULL, summaries_fast = summaries_fast_sub[[k]], - varsel$y_wobs_test, stat, alpha = alpha, ...) + varsel$y_wobs_test, stat, alpha = alpha, + deltas, ...) } else { res <- diff } @@ -253,7 +257,8 @@ check_sub_NA <- function(summaries_sub_k, el_nm) { ## some further adjustments are necessary below. get_stat <- function(summaries, summaries_baseline = NULL, summaries_fast = NULL, - y_wobs_test, stat, alpha = 0.1, ...) { + y_wobs_test, stat, alpha = 0.1, + deltas, ...) { mu <- summaries$mu lppd <- summaries$lppd loo_inds <- which(!is.na(lppd)) @@ -341,15 +346,17 @@ get_stat <- function(summaries, summaries_baseline = NULL, } value_se <- sqrt(value_se^2 - 2*cov_mse_e_b + var_mse_b) } - if (stat == "rmse") { + if (stat == "mse") { + value <- mse_e - ifelse(!is.character(deltas) && deltas, mse_b, 0)#X + } else if (stat == "rmse") { # simple transformation of mse - value <- sqrt(mse_e) + value <- sqrt(mse_e) - ifelse(!is.character(deltas) && deltas, sqrt(mse_b), 0)#X # the first-order Taylor approximation of the variance value_se <- sqrt(value_se^2 / mse_e / 4) } else if (stat == "R2") { # simple transformation of mse mse_y <- mean(wobs * (mean(y)-y)^2) - value <- 1 - mse_e / mse_y + value <- 1 - mse_e / mse_y - ifelse(!is.character(deltas) && deltas, (1 - mse_b / mse_y), 0)#X # the first-order Taylor approximation of the variance var_mse_y <- .weighted_sd((mean(y)-y)^2, wobs)^2 / n if (is.null(summaries_fast) || n_loo==n) { @@ -456,12 +463,14 @@ get_stat <- function(summaries, summaries_baseline = NULL, y = (correct-correct_baseline)[loo_inds], y_idx = loo_inds, w = wobs) - value <- srs_diffe$y_hat / n + mean(wobs * correct_baseline) + value <- srs_diffe$y_hat / n + mean(wobs * correct_baseline) - + ifelse(!is.character(deltas) && deltas, mean(wobs * correct_baseline), 0) # combine estimates of var(y_hat) and var(y) value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n } else { # full LOO estimator - value <- mean(wobs * correct) + value <- mean(wobs * correct) - + ifelse(!is.character(deltas) && deltas, mean(wobs * correct_baseline), 0)#X value_se <- .weighted_sd(correct - correct_baseline, wobs) / sqrt(n) } } else if (stat == "auc") { @@ -472,7 +481,8 @@ get_stat <- function(summaries, summaries_baseline = NULL, if (!is.null(mu_baseline)) { auc_data <- cbind(y, mu, wobs) auc_data_baseline <- cbind(y, mu_baseline, wobs) - value <- .auc(auc_data) + value <- .auc(auc_data) - + ifelse(!is.character(deltas) && deltas, .auc(auc_data_baseline), 0)#X idxs_cols <- seq_len(ncol(auc_data)) idxs_cols_bs <- setdiff(seq_len(ncol(auc_data) + ncol(auc_data_baseline)), idxs_cols) From 17be148deeb9ef79c1187d0b62e7be3cb323cc51 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Sun, 11 Aug 2024 17:09:26 +0300 Subject: [PATCH 043/134] remove option `baseline = "best"` --- R/methods.R | 17 +++++------------ R/misc.R | 4 ++-- 2 files changed, 7 insertions(+), 14 deletions(-) diff --git a/R/methods.R b/R/methods.R index fadd3e771..11b587125 100644 --- a/R/methods.R +++ b/R/methods.R @@ -668,13 +668,11 @@ proj_predict_aux <- function(proj, newdata, offsetnew, weightsnew, #' # Horizontal lines #' #' As long as the reference model's performance is computable, it is always -#' shown in the plot as a dashed red horizontal line. If `baseline = "best"`, -#' the baseline model's performance is shown as a dotted black horizontal line. +#' shown in the plot as a dashed red horizontal line. #' If `!is.na(thres_elpd)` and `any(stats %in% c("elpd", "mlpd", "gmpd"))`, the #' value supplied to `thres_elpd` (which is automatically adapted internally in #' case of the MLPD or the GMPD or `deltas = FALSE`) is shown as a dot-dashed -#' gray horizontal line for the reference model and, if `baseline = "best"`, as -#' a long-dashed green horizontal line for the baseline model. +#' gray horizontal line for the reference model. #' #' @examplesIf requireNamespace("rstanarm", quietly = TRUE) #' # Data: @@ -702,7 +700,7 @@ plot.vsel <- function( stats = "elpd", deltas = FALSE, alpha = 2 * pnorm(-1), - baseline = if (!inherits(x$refmodel, "datafit")) "ref" else "best", + baseline = "ref", thres_elpd = NA, resp_oscale = TRUE, point_size = 3, @@ -1231,10 +1229,6 @@ plot.vsel <- function( #' normal approximation, `alpha = 2 * pnorm(-1)` corresponds to a confidence #' interval stretching by one standard error on either side of the point #' estimate. -#' @param baseline For [summary.vsel()]: Only relevant if `deltas` is `TRUE`. -#' For [plot.vsel()]: Always relevant. Either `"ref"` or `"best"`, indicating -#' whether the baseline is the reference model or the best submodel found (in -#' terms of `stats[1]`), respectively. #' @param resp_oscale Only relevant for the latent projection. A single logical #' value indicating whether to calculate the performance statistics on the #' original response scale (`TRUE`) or on latent scale (`FALSE`). @@ -1301,7 +1295,7 @@ summary.vsel <- function( type = c("mean", "se", "diff", "diff.se"), deltas = FALSE, alpha = 2 * pnorm(-1), - baseline = if (!inherits(object$refmodel, "datafit")) "ref" else "best", + baseline = "ref", resp_oscale = TRUE, cumulate = FALSE, ... @@ -1599,8 +1593,7 @@ print.vsel <- function(x, digits = getOption("projpred.digits", 2), ...) { #' falls above (or is equal to) \deqn{\texttt{pct} \cdot (u_0 - #' u_{\mathrm{base}})}{pct * (u_0 - u_base)} where \eqn{u_0} denotes the null #' model's estimated utility and \eqn{u_{\mathrm{base}}}{u_base} the baseline -#' model's estimated utility. The baseline model is either the reference model -#' or the best submodel found (see argument `baseline` of [summary.vsel()]). +#' model's estimated utility. #' #' In doing so, loss statistics like the root mean squared error (RMSE) and #' the mean squared error (MSE) are converted to utilities by multiplying them diff --git a/R/misc.R b/R/misc.R index b680f7ede..833bef3d8 100644 --- a/R/misc.R +++ b/R/misc.R @@ -198,8 +198,8 @@ validate_vsel_object_stats <- function(object, stats, resp_oscale = TRUE) { validate_baseline <- function(refmodel, baseline, deltas) { stopifnot(!is.null(baseline)) - if (!(baseline %in% c("ref", "best"))) { - stop("Argument 'baseline' must be either 'ref' or 'best'.") + if (!(baseline %in% c("ref"))) { + stop("Argument 'baseline' must be 'ref'.") } if (baseline == "ref" && deltas == TRUE && inherits(refmodel, "datafit")) { # no reference model (or the results missing for some other reason), From 6b6520abebd8f32f9a4d03931edd9b738b75bcc8 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Sun, 11 Aug 2024 17:36:17 +0300 Subject: [PATCH 044/134] attempt to fix vsel.summary --- R/methods.R | 4 ++-- R/summary_funs.R | 33 +++++++++------------------------ 2 files changed, 11 insertions(+), 26 deletions(-) diff --git a/R/methods.R b/R/methods.R index 11b587125..b5f18d00a 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1328,7 +1328,7 @@ summary.vsel <- function( } # The full table of the performance statistics from `stats`: - if (deltas) { + if (is.character(deltas) || deltas) { nfeat_baseline_for_tab <- get_nfeat_baseline(object, baseline, stats[1], resp_oscale = resp_oscale) } else { @@ -1405,7 +1405,7 @@ summary.vsel <- function( # reference model performance and one table for the submodel performance): mk_colnms_smmry <- function(type, stats, deltas) { # Pre-process `type`: - if (is.null(deltas) || deltas) { + if (is.null(deltas) || (is.character(deltas) || deltas)) { type <- setdiff(type, c("diff", "diff.se")) } type_dot <- paste0(".", type) diff --git a/R/summary_funs.R b/R/summary_funs.R index d0c635b84..db8740326 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -88,7 +88,7 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, # statistics relative to the baseline model of that size (`nfeat_baseline = Inf` # means that the baseline model is the reference model). .tabulate_stats <- function(varsel, stats, alpha = 0.05, - nfeat_baseline = NULL, resp_oscale = TRUE, + nfeat_baseline = Inf, resp_oscale = TRUE, deltas, ...) { stat_tab <- data.frame() summaries_ref <- varsel$summaries$ref @@ -179,19 +179,8 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, } ## fetch the mu and lppd for the baseline model - if (is.null(nfeat_baseline)) { - ## no baseline model, i.e, compute the statistics on the actual - ## (non-relative) scale - summaries_baseline <- NULL - delta <- FALSE - } else { - if (nfeat_baseline == Inf) { - summaries_baseline <- summaries_ref - } else { - summaries_baseline <- summaries_sub[[nfeat_baseline + 1]] - } - delta <- TRUE - } + summaries_baseline <- summaries_ref + delta <- deltas for (s in seq_along(stats)) { stat <- stats[s] @@ -216,16 +205,12 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, summaries_baseline = summaries_baseline, summaries_fast = summaries_fast_sub[[k]], varsel$y_wobs_test, stat, alpha = alpha, - deltas, ...) - if (!delta) { - res <- get_stat(summaries = summaries_sub[[k]], - summaries_baseline = NULL, - summaries_fast = summaries_fast_sub[[k]], - varsel$y_wobs_test, stat, alpha = alpha, - deltas, ...) - } else { - res <- diff - } + TRUE, ...) + res <- get_stat(summaries = summaries_sub[[k]], + summaries_baseline = NULL, + summaries_fast = summaries_fast_sub[[k]], + varsel$y_wobs_test, stat, alpha = alpha, + FALSE, ...) row <- data.frame( data = varsel$type_test, size = k - 1, delta = delta, statistic = stat, value = res$value, lq = res$lq, uq = res$uq, From fc8c6655af516ed0a028eca5149734fe40f72ebe Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Mon, 12 Aug 2024 22:17:55 +0300 Subject: [PATCH 045/134] move code for deltas='mixed' to plot.vsel --- R/methods.R | 45 +++++++++++++++++++++++++++++++++------------ R/summary_funs.R | 43 ++++++++++++++++++------------------------- 2 files changed, 51 insertions(+), 37 deletions(-) diff --git a/R/methods.R b/R/methods.R index b5f18d00a..1881d944c 100644 --- a/R/methods.R +++ b/R/methods.R @@ -745,15 +745,30 @@ plot.vsel <- function( } else { nfeat_baseline_for_tab <- NULL } - # Compute the predictive performance statistics: stats_table_all <- .tabulate_stats(object, stats, alpha = alpha, nfeat_baseline = nfeat_baseline_for_tab, - resp_oscale = resp_oscale, deltas, ...) + resp_oscale = resp_oscale, ...) stats_ref <- subset(stats_table_all, stats_table_all$size == Inf) stats_sub <- subset(stats_table_all, stats_table_all$size != Inf) stats_bs <- subset(stats_table_all, stats_table_all$size == nfeat_baseline) - + if (!is.character(deltas) && deltas) { + stats_ref[,'value'] <- 0 + stats_ref[stats_ref[,'statistic']=="gmpd",'value'] <- 1 + } else if (is.character(deltas) && identical(deltas,'mixed')) { + stats_ref[stats_ref[,'statistic'] %in% c("elpd","mlpd"),'value'] <- 0 + stats_ref[stats_ref[,'statistic']=="gmpd",'value'] <- 1 + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff'] <- + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff'] + + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.lq'] <- + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.lq'] + + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.uq'] <- + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.uq'] + + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] + } + # Catch unexpected output from .tabulate_stats(): if (NROW(stats_sub) == 0) { stop(ifelse(length(stats) > 1, "Statistics ", "Statistic "), @@ -979,9 +994,15 @@ plot.vsel <- function( data_gg$statistic[data_gg$statistic=="auc"] <- "auc_diff" } } - pp <- ggplot(data = data_gg, - mapping = aes(x = .data[["size"]], y = .data[["value"]], - ymin = .data[["lq"]], ymax = .data[["uq"]])) + if (is.character(deltas) || deltas) { + pp <- ggplot(data = data_gg, + mapping = aes(x = .data[["size"]], y = .data[["diff"]], + ymin = .data[["diff.lq"]], ymax = .data[["diff.uq"]])) + } else { + pp <- ggplot(data = data_gg, + mapping = aes(x = .data[["size"]], y = .data[["value"]], + ymin = .data[["lq"]], ymax = .data[["uq"]])) + } if (!all(is.na(stats_ref$se))) { # In this case, add the predictive performance of the reference model. pp <- pp + @@ -1328,15 +1349,15 @@ summary.vsel <- function( } # The full table of the performance statistics from `stats`: - if (is.character(deltas) || deltas) { + ## if (is.character(deltas) || deltas) { nfeat_baseline_for_tab <- get_nfeat_baseline(object, baseline, stats[1], resp_oscale = resp_oscale) - } else { - nfeat_baseline_for_tab <- NULL - } + ## } else { + ## nfeat_baseline_for_tab <- NULL + ## } stats_table_all <- .tabulate_stats(object, stats, alpha = alpha, nfeat_baseline = nfeat_baseline_for_tab, - resp_oscale = resp_oscale, deltas, ...) + resp_oscale = resp_oscale, ...) # Extract the reference model performance results from `stats_table_all`: stats_table_ref <- subset(stats_table_all, stats_table_all$size == Inf) @@ -1360,7 +1381,7 @@ summary.vsel <- function( # For renaming columns of the two output tables (one for the reference model # performance and for the submodel performance): colnms_ref <- mk_colnms_smmry(type = type, stats = stats, deltas = NULL) - colnms_sub <- mk_colnms_smmry(type = type, stats = stats, deltas = deltas) + colnms_sub <- mk_colnms_smmry(type = type, stats = stats, deltas = FALSE) # Fill the output table for the reference model performance (essentially, we # reshape `stats_table_ref`, thereby selecting only the requested `type`s and diff --git a/R/summary_funs.R b/R/summary_funs.R index db8740326..3a095cae9 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -88,8 +88,7 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, # statistics relative to the baseline model of that size (`nfeat_baseline = Inf` # means that the baseline model is the reference model). .tabulate_stats <- function(varsel, stats, alpha = 0.05, - nfeat_baseline = Inf, resp_oscale = TRUE, - deltas, ...) { + nfeat_baseline = Inf, resp_oscale = TRUE, ...) { stat_tab <- data.frame() summaries_ref <- varsel$summaries$ref summaries_sub <- varsel$summaries$sub @@ -180,7 +179,7 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, ## fetch the mu and lppd for the baseline model summaries_baseline <- summaries_ref - delta <- deltas + delta <- !is.null(summaries_ref) for (s in seq_along(stats)) { stat <- stats[s] @@ -188,14 +187,13 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, ## reference model statistics summaries <- summaries_ref res <- get_stat(summaries = summaries_ref, - summaries_baseline = summaries_baseline, + summaries_baseline = NULL, summaries_fast = NULL, - varsel$y_wobs_test, stat, alpha = alpha, - deltas, ...) + varsel$y_wobs_test, stat, alpha = alpha, ...) row <- data.frame( data = varsel$type_test, size = Inf, delta = delta, statistic = stat, - value = res$value, lq = res$lq, uq = res$uq, se = res$se, diff = NA, - diff.se = NA + value = res$value, lq = res$lq, uq = res$uq, se = res$se, + diff = NA, diff.lq = NA, diff.uq = NA, diff.se = NA ) stat_tab <- rbind(stat_tab, row) @@ -204,17 +202,15 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, diff <- get_stat(summaries = summaries_sub[[k]], summaries_baseline = summaries_baseline, summaries_fast = summaries_fast_sub[[k]], - varsel$y_wobs_test, stat, alpha = alpha, - TRUE, ...) + varsel$y_wobs_test, stat, alpha = alpha, ...) res <- get_stat(summaries = summaries_sub[[k]], summaries_baseline = NULL, summaries_fast = summaries_fast_sub[[k]], - varsel$y_wobs_test, stat, alpha = alpha, - FALSE, ...) + varsel$y_wobs_test, stat, alpha = alpha, ...) row <- data.frame( data = varsel$type_test, size = k - 1, delta = delta, - statistic = stat, value = res$value, lq = res$lq, uq = res$uq, - se = res$se, diff = diff$value, diff.se = diff$se + statistic = stat, value = res$value, lq = res$lq, uq = res$uq, se = res$se, + diff = diff$value, diff.lq = diff$lq, diff.uq = diff$uq, diff.se = diff$se ) stat_tab <- rbind(stat_tab, row) } @@ -242,8 +238,7 @@ check_sub_NA <- function(summaries_sub_k, el_nm) { ## some further adjustments are necessary below. get_stat <- function(summaries, summaries_baseline = NULL, summaries_fast = NULL, - y_wobs_test, stat, alpha = 0.1, - deltas, ...) { + y_wobs_test, stat, alpha = 0.1, ...) { mu <- summaries$mu lppd <- summaries$lppd loo_inds <- which(!is.na(lppd)) @@ -332,16 +327,16 @@ get_stat <- function(summaries, summaries_baseline = NULL, value_se <- sqrt(value_se^2 - 2*cov_mse_e_b + var_mse_b) } if (stat == "mse") { - value <- mse_e - ifelse(!is.character(deltas) && deltas, mse_b, 0)#X + value <- mse_e - ifelse(is.null(summaries_baseline), 0, mse_b) } else if (stat == "rmse") { # simple transformation of mse - value <- sqrt(mse_e) - ifelse(!is.character(deltas) && deltas, sqrt(mse_b), 0)#X + value <- sqrt(mse_e) - ifelse(is.null(summaries_baseline), 0, sqrt(mse_b)) # the first-order Taylor approximation of the variance value_se <- sqrt(value_se^2 / mse_e / 4) } else if (stat == "R2") { # simple transformation of mse mse_y <- mean(wobs * (mean(y)-y)^2) - value <- 1 - mse_e / mse_y - ifelse(!is.character(deltas) && deltas, (1 - mse_b / mse_y), 0)#X + value <- 1 - mse_e / mse_y - ifelse(is.null(summaries_baseline), 0, 1 - mse_b / mse_y) # the first-order Taylor approximation of the variance var_mse_y <- .weighted_sd((mean(y)-y)^2, wobs)^2 / n if (is.null(summaries_fast) || n_loo==n) { @@ -449,13 +444,12 @@ get_stat <- function(summaries, summaries_baseline = NULL, y_idx = loo_inds, w = wobs) value <- srs_diffe$y_hat / n + mean(wobs * correct_baseline) - - ifelse(!is.character(deltas) && deltas, mean(wobs * correct_baseline), 0) + ifelse(is.null(mu_baseline), 0, mean(wobs * correct_baseline)) # combine estimates of var(y_hat) and var(y) value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n } else { # full LOO estimator - value <- mean(wobs * correct) - - ifelse(!is.character(deltas) && deltas, mean(wobs * correct_baseline), 0)#X + value <- mean(wobs * correct) - mean(wobs * correct_baseline) value_se <- .weighted_sd(correct - correct_baseline, wobs) / sqrt(n) } } else if (stat == "auc") { @@ -466,8 +460,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, if (!is.null(mu_baseline)) { auc_data <- cbind(y, mu, wobs) auc_data_baseline <- cbind(y, mu_baseline, wobs) - value <- .auc(auc_data) - - ifelse(!is.character(deltas) && deltas, .auc(auc_data_baseline), 0)#X + value <- .auc(auc_data) - .auc(auc_data_baseline) idxs_cols <- seq_len(ncol(auc_data)) idxs_cols_bs <- setdiff(seq_len(ncol(auc_data) + ncol(auc_data_baseline)), idxs_cols) @@ -496,7 +489,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, } } - if (stat %in% c("mse","rmse")) { + if (stat %in% c("mse","rmse") && is.null(mu_baseline)) { # Compute mean and variance in log scale by matching the variance of a # log-normal approximation # https://en.wikipedia.org/wiki/Log-normal_distribution#Arithmetic_moments From 99e9c7944cc0a884d234f33312f39d75e5d9aed0 Mon Sep 17 00:00:00 2001 From: Aki Vehtari Date: Tue, 13 Aug 2024 13:12:08 +0300 Subject: [PATCH 046/134] fixes --- R/methods.R | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/R/methods.R b/R/methods.R index 1881d944c..c68927e40 100644 --- a/R/methods.R +++ b/R/methods.R @@ -752,6 +752,7 @@ plot.vsel <- function( stats_ref <- subset(stats_table_all, stats_table_all$size == Inf) stats_sub <- subset(stats_table_all, stats_table_all$size != Inf) stats_bs <- subset(stats_table_all, stats_table_all$size == nfeat_baseline) + if (!is.character(deltas) && deltas) { stats_ref[,'value'] <- 0 stats_ref[stats_ref[,'statistic']=="gmpd",'value'] <- 1 @@ -760,13 +761,13 @@ plot.vsel <- function( stats_ref[stats_ref[,'statistic']=="gmpd",'value'] <- 1 stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff'] <- stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff'] + - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] + stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.lq'] <- stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.lq'] + - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] + stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.uq'] <- stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.uq'] + - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] + stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] } # Catch unexpected output from .tabulate_stats(): @@ -994,6 +995,7 @@ plot.vsel <- function( data_gg$statistic[data_gg$statistic=="auc"] <- "auc_diff" } } + if (is.character(deltas) || deltas) { pp <- ggplot(data = data_gg, mapping = aes(x = .data[["size"]], y = .data[["diff"]], @@ -1437,6 +1439,8 @@ mk_colnms_smmry <- function(type, stats, deltas) { nms_old[nms_old == "mean"] <- "value" nms_old[nms_old == "upper"] <- "uq" nms_old[nms_old == "lower"] <- "lq" + nms_old[nms_old == "diff.upper"] <- "diff.uq" + nms_old[nms_old == "diff.lower"] <- "diff.lq" # The clean column names that should be used in the output table: nms_new <- lapply(stats, paste0, type_dot) return(nlist(nms_old, nms_new)) @@ -1717,9 +1721,10 @@ suggest_size.vsel <- function( if (length(stat) > 1) { stop("Only one statistic can be specified to suggest_size") } + stats <- summary.vsel(object, stats = stat, - type = c("mean", "upper", "lower"), + type = c("diff", "diff.upper", "diff.lower"), deltas = TRUE, ...) stats <- stats$perf_sub @@ -1734,9 +1739,9 @@ suggest_size.vsel <- function( type <- "upper" } } - bound <- paste0(stat, ".", type) - - util_null <- sgn * unlist(unname(subset(stats, stats$size == 0, stat))) + bound <- paste0(stat, ".diff.", type) + stat.diff <- paste0(stat, ".", 'diff') + util_null <- sgn * unlist(unname(subset(stats, stats$size == 0, stat.diff))) if (stat != "gmpd") { util_cutoff <- pct * util_null } else { @@ -1745,12 +1750,13 @@ suggest_size.vsel <- function( if (is.na(thres_elpd)) { thres_elpd <- Inf } + nobs_test <- object$nobs_test res <- stats[ (sgn * stats[, bound] >= util_cutoff) | - (stat == "elpd" & stats[, stat] > thres_elpd) | - (stat == "mlpd" & stats[, stat] > thres_elpd / nobs_test) | - (stat == "gmpd" & stats[, stat] > exp(thres_elpd / nobs_test)), + (stat == "elpd" & stats[, stat.diff] > thres_elpd) | + (stat == "mlpd" & stats[, stat.diff] > thres_elpd / nobs_test) | + (stat == "gmpd" & stats[, stat.diff] > exp(thres_elpd / nobs_test)), "size", drop = FALSE ] From cd4b248fcecefa1bea46e0e2955cb770c686ceaa Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 19 Jul 2024 01:28:46 +0200 Subject: [PATCH 047/134] docs: fix minor typos --- R/cv_varsel.R | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 921504028..3b215503f 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -20,13 +20,14 @@ #' is performed, which avoids refitting the reference model `nloo` times (in #' contrast to a standard LOO-CV). In the `"kfold"` case, a \eqn{K}-fold-CV is #' performed. See also section "Note" below. -#' @param nloo Only relevant if `cv_method = "LOO"` and `validate_search = TRUE`. -#' If `nloo>0` is smaller than the number of all observations, full LOO-CV is -#' approximated by combining the fast LOO result for the selected models and -#' `nloo` leave-one-out searches using the difference estimator with simple -#' random sampling (SRS) without replacement (WOR) (Magnusson et al., 2020). -#' Smaller values lead to faster computation, but higher uncertainty in the -#' evaluation part. If `NULL`, all observations are used (as by default). +#' @param nloo Only relevant if `cv_method = "LOO"` and `validate_search = +#' TRUE`. If `nloo > 0` is smaller than the number of all observations, full +#' LOO-CV is approximated by combining the fast LOO result for the selected +#' models and `nloo` leave-one-out searches using the difference estimator +#' with simple random sampling (SRS) without replacement (WOR) (Magnusson et +#' al., 2020). Smaller values lead to faster computation, but higher +#' uncertainty in the evaluation part. If `NULL`, all observations are used +#' (as by default). #' @param K Only relevant if `cv_method = "kfold"` and if `cvfits` is `NULL` #' (which is the case for reference model objects created by #' [get_refmodel.stanreg()] or [brms::get_refmodel.brmsfit()]). Number of @@ -40,7 +41,7 @@ #' the computation is faster, but the predictive performance estimates #' of the selected submodels are optimistically biased. However, these fast #' biased estimated can be useful to obtain initial information on the -#' usefulnes of projection predictive variable selection. +#' usefulness of projection predictive variable selection. #' @param seed Pseudorandom number generation (PRNG) seed by which the same #' results can be obtained again if needed. Passed to argument `seed` of #' [set.seed()], but can also be `NA` to not call [set.seed()] at all. If not From 7176dfe725a596f23adf1eedf4f00a92a3fb10c9 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 19 Jul 2024 01:33:17 +0200 Subject: [PATCH 048/134] avoid `object` within `cv_varsel.refmodel()` (for consistency; I don't know why both `object` and `refmodel` exist) --- R/cv_varsel.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 3b215503f..9c50df563 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -334,7 +334,7 @@ cv_varsel.refmodel <- function( ) cv_method <- args$cv_method nloo <- args$nloo - n <- object$nobs + n <- refmodel$nobs K <- args$K cvfits <- args$cvfits From 4109aaec8e196d22e7406e8b74936bf666a5e718 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 19 Jul 2024 01:40:42 +0200 Subject: [PATCH 049/134] fix a verbose message (at `?projpred::cv_varsel`, the documentation for argument `ndraws` explains that it is `nclusters` which decides the clustering/thinning mechanism by being `NULL` or not) --- R/cv_varsel.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 9c50df563..c4d7a5d55 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -350,9 +350,9 @@ cv_varsel.refmodel <- function( verb_txt_search <- paste0(verb_txt_search, "using the full dataset ") } verb_txt_search <- paste0(verb_txt_search, "with ", - ifelse(!is.null(ndraws), - paste0(ndraws, " draws"), - paste0(nclusters, " clusters"))) + ifelse(!is.null(nclusters), + paste0(nclusters, " clusters"), + paste0(ndraws, " draws"))) verb_txt_search <- paste0(verb_txt_search, "...") verb_out(verb_txt_search, verbose = verbose) search_path_fulldata <- .select( From 7616128f6d7144bb4d9a756bd6dae54c31e3eb86 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 19 Jul 2024 01:42:01 +0200 Subject: [PATCH 050/134] mention thinning in the verbose message which gives information about the clustering/thinning used --- R/cv_varsel.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index c4d7a5d55..19074c4bb 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -349,10 +349,15 @@ cv_varsel.refmodel <- function( # no fold-wise searches, so pointing out "full-data" could be confusing): verb_txt_search <- paste0(verb_txt_search, "using the full dataset ") } + # Note concerning the following verbose text: If `nclusters == S`, + # get_refdist() will use "thinning", not "clustering" (in that case, they + # give the same set of draws, namely the original one; hence the quotation + # marks), but here for this verbose message, we do not want to make things + # too complicated: verb_txt_search <- paste0(verb_txt_search, "with ", ifelse(!is.null(nclusters), paste0(nclusters, " clusters"), - paste0(ndraws, " draws"))) + paste0(ndraws, " draws (from thinning)"))) verb_txt_search <- paste0(verb_txt_search, "...") verb_out(verb_txt_search, verbose = verbose) search_path_fulldata <- .select( From 48a6af1c25c70a1be48530002d26b96da7d8cb52 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 19 Aug 2024 00:33:14 +0200 Subject: [PATCH 051/134] minor cleaning --- R/cv_varsel.R | 13 ++++++------- tests/testthat/setup.R | 2 -- 2 files changed, 6 insertions(+), 9 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 19074c4bb..1a54488a3 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -247,7 +247,7 @@ cv_varsel.vsel <- function( cvfits = cvfits, validate_search = validate_search, search_out = nlist(search_path = object[["search_path"]], rk_foldwise), - summaries_fast = object$summaries_fast), + summaries_fast = object[["summaries_fast"]]), dots) )) } @@ -392,7 +392,7 @@ cv_varsel.refmodel <- function( nclusters_pred = nclusters_pred, refit_prj = refit_prj, penalty = penalty, verbose = verbose, search_control = search_control, nloo = nloo, validate_search = validate_search, - search_path_fulldata = if (validate_search) { # && nloo==n) { # check this + search_path_fulldata = if (validate_search) { # Not needed in this case, so for computational efficiency, avoiding # passing the large object `search_path_fulldata` to loo_varsel(): NULL @@ -403,16 +403,16 @@ cv_varsel.refmodel <- function( search_terms_was_null = search_terms_was_null, search_out_rks = search_out_rks, parallel = parallel, ... ) - if (is.null(sel_cv$summaries_fast) && validate_search==TRUE && nloo Date: Mon, 19 Aug 2024 00:35:08 +0200 Subject: [PATCH 052/134] fix usage of argument `summaries_fast` (at that place, `sel_cv$summaries_fast` is always `NULL`) --- R/cv_varsel.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 1a54488a3..3d95b291f 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -403,7 +403,7 @@ cv_varsel.refmodel <- function( search_terms_was_null = search_terms_was_null, search_out_rks = search_out_rks, parallel = parallel, ... ) - if (is.null(sel_cv$summaries_fast) && validate_search && nloo < n) { + if (is.null(summaries_fast) && validate_search && nloo < n) { # Run fast LOO-CV to be used in subsampling difference estimator sel_cv$summaries_fast <- loo_varsel( refmodel = refmodel, method = method, nterms_max = nterms_max, From 0c85eb6f713ebb561d6caf90b1293717f5df6b2f Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 19 Aug 2024 00:38:03 +0200 Subject: [PATCH 053/134] use argument `summaries_fast` as it was probably intended to --- R/cv_varsel.R | 45 +++++++++++++++++++++++++-------------------- 1 file changed, 25 insertions(+), 20 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 3d95b291f..8b41a7b83 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -403,26 +403,31 @@ cv_varsel.refmodel <- function( search_terms_was_null = search_terms_was_null, search_out_rks = search_out_rks, parallel = parallel, ... ) - if (is.null(summaries_fast) && validate_search && nloo < n) { - # Run fast LOO-CV to be used in subsampling difference estimator - sel_cv$summaries_fast <- loo_varsel( - refmodel = refmodel, method = method, nterms_max = nterms_max, - ndraws = ndraws, nclusters = nclusters, ndraws_pred = ndraws_pred, - nclusters_pred = nclusters_pred, refit_prj = refit_prj, penalty = penalty, - verbose = verbose, search_control = search_control, - nloo = n, # fast LOO-CV for all n - validate_search = FALSE, # fast LOO-CV for all n - search_path_fulldata = if (validate_search) { - # Not needed in this case, so for computational efficiency, avoiding - # passing the large object `search_path_fulldata` to loo_varsel(): - NULL - } else { - search_path_fulldata - }, - search_terms = search_terms, - search_terms_was_null = search_terms_was_null, - search_out_rks = search_out_rks, parallel = parallel, ... - )[["summaries"]] + if (validate_search && nloo < n) { + # Run fast LOO-CV (or use existing results) to be used in subsampling + # difference estimator: + if (is.null(summaries_fast)) { + sel_cv$summaries_fast <- loo_varsel( + refmodel = refmodel, method = method, nterms_max = nterms_max, + ndraws = ndraws, nclusters = nclusters, ndraws_pred = ndraws_pred, + nclusters_pred = nclusters_pred, refit_prj = refit_prj, penalty = penalty, + verbose = verbose, search_control = search_control, + nloo = n, # fast LOO-CV for all n + validate_search = FALSE, # fast LOO-CV for all n + search_path_fulldata = if (validate_search) { + # Not needed in this case, so for computational efficiency, avoiding + # passing the large object `search_path_fulldata` to loo_varsel(): + NULL + } else { + search_path_fulldata + }, + search_terms = search_terms, + search_terms_was_null = search_terms_was_null, + search_out_rks = search_out_rks, parallel = parallel, ... + )[["summaries"]] + } else { + sel_cv$summaries_fast <- summaries_fast + } } } else if (cv_method == "kfold") { sel_cv <- kfold_varsel( From 4f893f93b1dcab5d83bb4b5ea1c5b7855a73dd4a Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 19 Aug 2024 00:41:53 +0200 Subject: [PATCH 054/134] fixup! use argument `summaries_fast` as it was probably intended to --- R/cv_varsel.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 8b41a7b83..39ffa86d8 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -407,7 +407,7 @@ cv_varsel.refmodel <- function( # Run fast LOO-CV (or use existing results) to be used in subsampling # difference estimator: if (is.null(summaries_fast)) { - sel_cv$summaries_fast <- loo_varsel( + summaries_fast <- loo_varsel( refmodel = refmodel, method = method, nterms_max = nterms_max, ndraws = ndraws, nclusters = nclusters, ndraws_pred = ndraws_pred, nclusters_pred = nclusters_pred, refit_prj = refit_prj, penalty = penalty, @@ -425,8 +425,6 @@ cv_varsel.refmodel <- function( search_terms_was_null = search_terms_was_null, search_out_rks = search_out_rks, parallel = parallel, ... )[["summaries"]] - } else { - sel_cv$summaries_fast <- summaries_fast } } } else if (cv_method == "kfold") { @@ -481,7 +479,7 @@ cv_varsel.refmodel <- function( y_wobs_test, nobs_test = nrow(y_wobs_test), summaries = sel_cv$summaries, - summaries_fast = sel_cv$summaries_fast, + summaries_fast, nterms_all, nterms_max, method, From d40acd8af390bef85b9116f1d6cbda68859d7c3e Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 19 Aug 2024 00:42:55 +0200 Subject: [PATCH 055/134] fixup! fixup! use argument `summaries_fast` as it was probably intended to --- R/cv_varsel.R | 43 ++++++++++++++++++++----------------------- 1 file changed, 20 insertions(+), 23 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 39ffa86d8..990fdd833 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -403,29 +403,26 @@ cv_varsel.refmodel <- function( search_terms_was_null = search_terms_was_null, search_out_rks = search_out_rks, parallel = parallel, ... ) - if (validate_search && nloo < n) { - # Run fast LOO-CV (or use existing results) to be used in subsampling - # difference estimator: - if (is.null(summaries_fast)) { - summaries_fast <- loo_varsel( - refmodel = refmodel, method = method, nterms_max = nterms_max, - ndraws = ndraws, nclusters = nclusters, ndraws_pred = ndraws_pred, - nclusters_pred = nclusters_pred, refit_prj = refit_prj, penalty = penalty, - verbose = verbose, search_control = search_control, - nloo = n, # fast LOO-CV for all n - validate_search = FALSE, # fast LOO-CV for all n - search_path_fulldata = if (validate_search) { - # Not needed in this case, so for computational efficiency, avoiding - # passing the large object `search_path_fulldata` to loo_varsel(): - NULL - } else { - search_path_fulldata - }, - search_terms = search_terms, - search_terms_was_null = search_terms_was_null, - search_out_rks = search_out_rks, parallel = parallel, ... - )[["summaries"]] - } + if (is.null(summaries_fast) && validate_search && nloo < n) { + # Run fast LOO-CV to be used in subsampling difference estimator + summaries_fast <- loo_varsel( + refmodel = refmodel, method = method, nterms_max = nterms_max, + ndraws = ndraws, nclusters = nclusters, ndraws_pred = ndraws_pred, + nclusters_pred = nclusters_pred, refit_prj = refit_prj, penalty = penalty, + verbose = verbose, search_control = search_control, + nloo = n, # fast LOO-CV for all n + validate_search = FALSE, # fast LOO-CV for all n + search_path_fulldata = if (validate_search) { + # Not needed in this case, so for computational efficiency, avoiding + # passing the large object `search_path_fulldata` to loo_varsel(): + NULL + } else { + search_path_fulldata + }, + search_terms = search_terms, + search_terms_was_null = search_terms_was_null, + search_out_rks = search_out_rks, parallel = parallel, ... + )[["summaries"]] } } else if (cv_method == "kfold") { sel_cv <- kfold_varsel( From d1d37bd1d0ae17bb60ea19b264ea179a3c13351f Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 19 Aug 2024 00:46:25 +0200 Subject: [PATCH 056/134] fix input for argument `search_path_fulldata` when running fast LOO-CV for subsampled PSIS-LOO-CV --- R/cv_varsel.R | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 990fdd833..f6e635d07 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -412,13 +412,7 @@ cv_varsel.refmodel <- function( verbose = verbose, search_control = search_control, nloo = n, # fast LOO-CV for all n validate_search = FALSE, # fast LOO-CV for all n - search_path_fulldata = if (validate_search) { - # Not needed in this case, so for computational efficiency, avoiding - # passing the large object `search_path_fulldata` to loo_varsel(): - NULL - } else { - search_path_fulldata - }, + search_path_fulldata = search_path_fulldata, search_terms = search_terms, search_terms_was_null = search_terms_was_null, search_out_rks = search_out_rks, parallel = parallel, ... From b9f836841df1932654fb40cdc19ab137b84a5aff Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 19 Aug 2024 16:22:22 +0200 Subject: [PATCH 057/134] for argument `verbose`, default to a new global option: `getOption("projpred.verbose", interactive())` --- R/cv_varsel.R | 14 +++++++------- R/varsel.R | 34 +++++++++++++++++++++++----------- 2 files changed, 30 insertions(+), 18 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index f6e635d07..d79bbe37c 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -265,7 +265,7 @@ cv_varsel.refmodel <- function( refit_prj = !inherits(object, "datafit"), nterms_max = NULL, penalty = NULL, - verbose = TRUE, + verbose = getOption("projpred.verbose", interactive()), nloo = object$nobs, K = if (!inherits(object, "datafit")) 5 else 10, cvfits = object$cvfits, @@ -1019,16 +1019,16 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, # would require adding more "hard" dependencies (because packages # 'foreach' and 'doRNG' would have to be moved from `Suggests:` to # `Imports:`). - if (verbose && interactive()) { + if (verbose) { pb <- utils::txtProgressBar(min = 0, max = nloo, style = 3, initial = 0) } res_cv <- lapply(seq_along(inds), function(run_index) { - if (verbose && interactive()) { + if (verbose) { on.exit(utils::setTxtProgressBar(pb, run_index)) } one_obs(run_index, ...) }) - if (verbose && interactive()) { + if (verbose) { close(pb) } } else { @@ -1347,16 +1347,16 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, # foreach::`%do%`` here and then proceed as in the parallel case, but that # would require adding more "hard" dependencies (because packages 'foreach' # and 'doRNG' would have to be moved from `Suggests:` to `Imports:`). - if (verbose && interactive()) { + if (verbose) { pb <- utils::txtProgressBar(min = 0, max = K, style = 3, initial = 0) } res_cv <- lapply(seq_along(list_cv), function(k) { - if (verbose && interactive()) { + if (verbose) { on.exit(utils::setTxtProgressBar(pb, k)) } one_fold(fold = list_cv[[k]], rk = search_out_rks[[k]], ...) }) - if (verbose && interactive()) { + if (verbose) { close(pb) } } else { diff --git a/R/varsel.R b/R/varsel.R index d3656d18b..1f7b5632a 100644 --- a/R/varsel.R +++ b/R/varsel.R @@ -248,15 +248,27 @@ varsel.vsel <- function(object, ...) { #' @rdname varsel #' @export -varsel.refmodel <- function(object, d_test = NULL, method = "forward", - ndraws = NULL, nclusters = 20, ndraws_pred = 400, - nclusters_pred = NULL, - refit_prj = !inherits(object, "datafit"), - nterms_max = NULL, verbose = TRUE, - search_control = NULL, lambda_min_ratio = 1e-5, - nlambda = 150, thresh = 1e-6, penalty = NULL, - search_terms = NULL, search_out = NULL, seed = NA, - ...) { +varsel.refmodel <- function( + object, + d_test = NULL, + method = "forward", + ndraws = NULL, + nclusters = 20, + ndraws_pred = 400, + nclusters_pred = NULL, + refit_prj = !inherits(object, "datafit"), + nterms_max = NULL, + verbose = getOption("projpred.verbose", interactive()), + search_control = NULL, + lambda_min_ratio = 1e-5, + nlambda = 150, + thresh = 1e-6, + penalty = NULL, + search_terms = NULL, + search_out = NULL, + seed = NA, + ... +) { if (!missing(lambda_min_ratio)) { warning("Argument `lambda_min_ratio` is deprecated. Please specify ", "control arguments for the search via argument `search_control`. ", @@ -511,8 +523,8 @@ varsel.refmodel <- function(object, d_test = NULL, method = "forward", # `outdmins` (the submodel fits along the predictor ranking, with the number # of fits per model size being equal to the number of projected draws), and # `p_sel` (the output from get_refdist() for the search). -.select <- function(refmodel, ndraws, nclusters, reweighting_args = NULL, method, - nterms_max, penalty, verbose, search_control, ...) { +.select <- function(refmodel, ndraws, nclusters, reweighting_args = NULL, + method, nterms_max, penalty, verbose, search_control, ...) { if (is.null(reweighting_args)) { p_sel <- get_refdist(refmodel, ndraws = ndraws, nclusters = nclusters) } else { From a9ce55f574a0c2a65d427583ec4204be68dc0702 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Tue, 20 Aug 2024 21:55:09 +0200 Subject: [PATCH 058/134] argument `summaries_fast` should not change either (when calling `cv_varsel.vsel()`) --- R/cv_varsel.R | 41 ++++++++++++++++++++++------------------- 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index d79bbe37c..3568086e9 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -187,7 +187,8 @@ cv_varsel.vsel <- function( ) { ## the following arguments should not change arg_nms_internal <- c("method", "ndraws", "nclusters", "nterms_max", - "search_control", "penalty", "search_terms") + "search_control", "penalty", "search_terms", + "summaries_fast") arg_nms_internal_used <- intersect(arg_nms_internal, ...names()) n_arg_nms_internal_used <- length(arg_nms_internal_used) dots <- list(...) @@ -232,24 +233,26 @@ cv_varsel.vsel <- function( } } - return(do_call(cv_varsel, c(list( - object = refmodel, - method = object[["args_search"]][["method"]], - ndraws = object[["args_search"]][["ndraws"]], - nclusters = object[["args_search"]][["nclusters"]], - nterms_max = object[["args_search"]][["nterms_max"]], - search_control = object[["args_search"]][["search_control"]], - penalty = object[["args_search"]][["penalty"]], - search_terms = object[["args_search"]][["search_terms"]], - cv_method = cv_method, - nloo = nloo, - K = K, - cvfits = cvfits, - validate_search = validate_search, - search_out = nlist(search_path = object[["search_path"]], rk_foldwise), - summaries_fast = object[["summaries_fast"]]), - dots) - )) + return(do_call(cv_varsel, c( + list( + object = refmodel, + method = object[["args_search"]][["method"]], + ndraws = object[["args_search"]][["ndraws"]], + nclusters = object[["args_search"]][["nclusters"]], + nterms_max = object[["args_search"]][["nterms_max"]], + search_control = object[["args_search"]][["search_control"]], + penalty = object[["args_search"]][["penalty"]], + search_terms = object[["args_search"]][["search_terms"]], + summaries_fast = object[["summaries_fast"]], + cv_method = cv_method, + nloo = nloo, + K = K, + cvfits = cvfits, + validate_search = validate_search, + search_out = nlist(search_path = object[["search_path"]], rk_foldwise) + ), + dots + ))) } #' @rdname cv_varsel From 23b4a2a9b6a07c0c4a69c5012cddc23ab7487dd8 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Tue, 20 Aug 2024 21:59:10 +0200 Subject: [PATCH 059/134] remove unused object `n_arg_nms_internal_used` --- R/cv_varsel.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 3568086e9..6b5a92db5 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -190,7 +190,6 @@ cv_varsel.vsel <- function( "search_control", "penalty", "search_terms", "summaries_fast") arg_nms_internal_used <- intersect(arg_nms_internal, ...names()) - n_arg_nms_internal_used <- length(arg_nms_internal_used) dots <- list(...) for (arg in arg_nms_internal_used) { if (!identical(object[["args_search"]][[arg]], dots[[arg]])) { From cc26cf74d4dba50f071f264da400b0b4cbf35b8b Mon Sep 17 00:00:00 2001 From: fweber144 Date: Tue, 20 Aug 2024 22:00:12 +0200 Subject: [PATCH 060/134] define `arg_nms_internal_used` more straightforwardly --- R/cv_varsel.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 6b5a92db5..048df62b9 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -189,8 +189,8 @@ cv_varsel.vsel <- function( arg_nms_internal <- c("method", "ndraws", "nclusters", "nterms_max", "search_control", "penalty", "search_terms", "summaries_fast") - arg_nms_internal_used <- intersect(arg_nms_internal, ...names()) dots <- list(...) + arg_nms_internal_used <- intersect(arg_nms_internal, names(dots)) for (arg in arg_nms_internal_used) { if (!identical(object[["args_search"]][[arg]], dots[[arg]])) { message("Argument `", arg, "` ignored. Using the argument value stored ", From 66f2e34b3bc5db0abbb4f0cfc847cac00a5babcf Mon Sep 17 00:00:00 2001 From: fweber144 Date: Tue, 20 Aug 2024 22:08:58 +0200 Subject: [PATCH 061/134] minor enhancements --- R/cv_varsel.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 048df62b9..002c20172 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -358,8 +358,8 @@ cv_varsel.refmodel <- function( # too complicated: verb_txt_search <- paste0(verb_txt_search, "with ", ifelse(!is.null(nclusters), - paste0(nclusters, " clusters"), - paste0(ndraws, " draws (from thinning)"))) + paste0(nclusters, " clusters "), + paste0(ndraws, " draws (from thinning) "))) verb_txt_search <- paste0(verb_txt_search, "...") verb_out(verb_txt_search, verbose = verbose) search_path_fulldata <- .select( @@ -708,9 +708,9 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, if (validate_search && nloo < n) { # Select which LOO-folds get more accurate computation using simple # random sampling without resampling (Magnusson et al., 2020) - inds <- sample(1:n, nloo, replace=FALSE) + inds <- sample.int(n, size = nloo, replace = FALSE) } else { - inds <- 1:n + inds <- seq_len(n) } # Initialize objects where to store the results: From e61f9169395e078a8985141657b1564945f8aebc Mon Sep 17 00:00:00 2001 From: fweber144 Date: Tue, 20 Aug 2024 22:20:22 +0200 Subject: [PATCH 062/134] fix a verbose message (at `?projpred::cv_varsel`, the documentation for argument `ndraws` explains that it is `nclusters` which decides the clustering/thinning mechanism by being `NULL` or not; the same holds for `ndraws_pred` / `nclusters_pred`) --- R/cv_varsel.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 002c20172..1099c2c42 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -750,12 +750,12 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, # precursor quantities, but for users, this difference is not perceivable): verb_out("-----\nRunning the performance evaluation with ", ifelse(refit_prj, - ifelse(!is.null(ndraws_pred), - paste0(ndraws_pred, " draws"), - paste0(nclusters_pred, " clusters")), - ifelse(!is.null(ndraws), - paste0(ndraws, " draws"), - paste0(nclusters, " clusters"))), + ifelse(!is.null(nclusters_pred), + paste0(nclusters_pred, " clusters"), + paste0(ndraws_pred, " draws (from thinning)")), + ifelse(!is.null(nclusters), + paste0(nclusters, " clusters"), + paste0(ndraws, " draws (from thinning)"))), " (`refit_prj = ", refit_prj, "`) ...", verbose = verbose) # Step 1: Re-project (using the full dataset) onto the submodels along the # full-data predictor ranking and evaluate their predictive performance. From 750c81a4e4daee1769b9cf4d5218d5864f4d8eef Mon Sep 17 00:00:00 2001 From: fweber144 Date: Tue, 20 Aug 2024 22:35:39 +0200 Subject: [PATCH 063/134] fix a message when using standard importance sampling (SIS) --- R/cv_varsel.R | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 1099c2c42..e23777622 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -827,13 +827,16 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, 3 * sqrt(S_for_psis_eval))) < 5 if (no_psis_eval) { if (getOption("projpred.warn_psis", TRUE)) { - verb_out( + message( "Using standard importance sampling (SIS) due to a small number of", ifelse(refit_prj, - ifelse(!is.null(ndraws_pred), " draws", " clusters"), - ifelse(!is.null(ndraws), " draws", " clusters") - ), - verbose=verbose) + ifelse(!is.null(nclusters_pred), + " clusters", + " draws (from thinning)"), + ifelse(!is.null(nclusters), + " clusters", + " draws (from thinning)")) + ) } # Use loo::sis(). # In principle, we could rely on loo::psis() here (because in such a From f84fe55b7121c1707f5e5e0720d2dbe7194b61a2 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Thu, 22 Aug 2024 20:28:52 +0200 Subject: [PATCH 064/134] remove fragment `verb_txt_start <-` --- R/cv_varsel.R | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index e23777622..1087ceec4 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -956,12 +956,11 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } if (verbose) { - verb_txt_start <- - if (!search_out_rks_was_null) { - verb_txt_mid <- "" - } else { - verb_txt_mid <- "the search and " - } + if (!search_out_rks_was_null) { + verb_txt_mid <- "" + } else { + verb_txt_mid <- "the search and " + } verb_out("-----\nRunning ", ifelse(!search_out_rks_was_null, "", paste0(method, " search with ", From 8dde0bc19d296e14ec1d1b216e72996d8e6a5b2c Mon Sep 17 00:00:00 2001 From: fweber144 Date: Thu, 22 Aug 2024 20:35:04 +0200 Subject: [PATCH 065/134] fix verbose message --- R/cv_varsel.R | 27 +++++++++++---------------- 1 file changed, 11 insertions(+), 16 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 1087ceec4..68ce33b3d 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -956,28 +956,23 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } if (verbose) { - if (!search_out_rks_was_null) { - verb_txt_mid <- "" - } else { - verb_txt_mid <- "the search and " - } verb_out("-----\nRunning ", ifelse(!search_out_rks_was_null, "", - paste0(method, " search with ", - ifelse(!is.null(ndraws), - paste0(ndraws, " draws"), - paste0(nclusters, " clusters")), + paste0(method, " the search with ", + ifelse(!is.null(nclusters), + paste0(nclusters, " clusters"), + paste0(ndraws, " draws (from thinning)")), " and ")), "the performance evaluation with ", ifelse(refit_prj, - ifelse(!is.null(ndraws_pred), - paste0(ndraws_pred, " draws"), - paste0(nclusters_pred, " clusters")), - ifelse(!is.null(ndraws), - paste0(ndraws, " draws"), - paste0(nclusters, " clusters"))), + ifelse(!is.null(nclusters_pred), + paste0(nclusters_pred, " clusters"), + paste0(ndraws_pred, " draws (from thinning)")), + ifelse(!is.null(nclusters), + paste0(nclusters, " clusters"), + paste0(ndraws, " draws (from thinning)"))), " (`refit_prj = ", refit_prj, - "`) for each of the nloo = ", nloo, " ", + "`) for each of the `nloo = ", nloo, "` ", "LOO-CV folds separately ...") } one_obs <- function(run_index, From 9c4d1a40faf02d6b7cecb0de59984796529012ac Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 07:02:09 +0200 Subject: [PATCH 066/134] docs: abbreviate the performance statistics appropriately --- R/methods.R | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/R/methods.R b/R/methods.R index c68927e40..3cbd91eee 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1198,18 +1198,18 @@ plot.vsel <- function( #' are again all observations because the test set is the same as the training #' set). Available statistics are: #' * `"elpd"`: expected log (pointwise) predictive density (for a new -#' dataset). Estimated by the sum of the observation-specific log predictive -#' density values (with each of these predictive density values being -#' a---possibly weighted---average across the parameter draws). -#' * `"mlpd"`: mean log predictive density, that is, `"elpd"` divided by the -#' number of observations. +#' dataset) (ELPD). Estimated by the sum of the observation-specific log +#' predictive density values (with each of these predictive density values +#' being a---possibly weighted---average across the parameter draws). +#' * `"mlpd"`: mean log predictive density (MLPD), that is, the ELPD divided +#' by the number of observations. #' * `"gmpd"`: geometric mean predictive density (GMPD), that is, [exp()] of -#' `"mlpd"`. The GMPD is especially helpful for discrete response families +#' the MLPD. The GMPD is especially helpful for discrete response families #' (because there, the GMPD is bounded by zero and one). For the corresponding #' standard error, the delta method is used. The corresponding confidence #' interval type is "exponentiated normal approximation" because the #' confidence interval bounds are the exponentiated confidence interval bounds -#' of the `"mlpd"`. +#' of the MLPD. #' * `"mse"`: mean squared error (only available in the situations mentioned #' in section "Details" below). #' * `"rmse"`: root mean squared error (only available in the situations @@ -1236,12 +1236,12 @@ plot.vsel <- function( #' (nominal) coverage `1 - alpha`. Items `"diff"` and `"diff.se"` are only #' supported if `deltas` is `FALSE`. #' @param deltas If `TRUE`, the submodel statistics are estimated relatively to -#' the baseline model (see argument `baseline`). For the `"gmpd"`, the term +#' the baseline model (see argument `baseline`). For the GMPD, the term #' "relatively" refers to the ratio vs. the baseline model (i.e., the submodel #' statistic divided by the baseline model statistic). For all other `stats`, #' "relatively" refers to the difference from the baseline model (i.e., the -#' submodel statistic minus the baseline model statistic). For `"elpd"` and -#' `"mlpd"` the baseline performance is reported as 0. For `"gmpd"` +#' submodel statistic minus the baseline model statistic). For the ELPD and +#' the MLPD, the baseline performance is reported as 0. For the GMPD, #' the baseline performance is reported as 1. For other statistics, the #' baseline performance is reported as 0 if `deltas=TRUE` and in the original #' scale if `deltas="mixed"`. If `deltas=TRUE` or `deltas="mixed"`, for all From ea18e9aef11d61c7d3851510ef5a13f8ba7e7047 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 06:57:24 +0200 Subject: [PATCH 067/134] UNFINISHED: move out the new "mixed deltas" variant of `plot.vsel()`, the new column behavior of `summary.vsel()`, and the omittance of option `"best"` of argument `baseline` --- R/methods.R | 153 +++++++++++++++++------------------------------ R/misc.R | 4 +- R/summary_funs.R | 9 ++- 3 files changed, 61 insertions(+), 105 deletions(-) diff --git a/R/methods.R b/R/methods.R index 3cbd91eee..e773a44e8 100644 --- a/R/methods.R +++ b/R/methods.R @@ -668,11 +668,13 @@ proj_predict_aux <- function(proj, newdata, offsetnew, weightsnew, #' # Horizontal lines #' #' As long as the reference model's performance is computable, it is always -#' shown in the plot as a dashed red horizontal line. +#' shown in the plot as a dashed red horizontal line. If `baseline = "best"`, +#' the baseline model's performance is shown as a dotted black horizontal line. #' If `!is.na(thres_elpd)` and `any(stats %in% c("elpd", "mlpd", "gmpd"))`, the #' value supplied to `thres_elpd` (which is automatically adapted internally in #' case of the MLPD or the GMPD or `deltas = FALSE`) is shown as a dot-dashed -#' gray horizontal line for the reference model. +#' gray horizontal line for the reference model and, if `baseline = "best"`, as +#' a long-dashed green horizontal line for the baseline model. #' #' @examplesIf requireNamespace("rstanarm", quietly = TRUE) #' # Data: @@ -700,7 +702,7 @@ plot.vsel <- function( stats = "elpd", deltas = FALSE, alpha = 2 * pnorm(-1), - baseline = "ref", + baseline = if (!inherits(x$refmodel, "datafit")) "ref" else "best", thres_elpd = NA, resp_oscale = TRUE, point_size = 3, @@ -734,17 +736,12 @@ plot.vsel <- function( # .tabulate_stats()'s argument `nfeat_baseline`: nfeat_baseline <- get_nfeat_baseline(object, baseline, stats[1], resp_oscale = resp_oscale) - ## if (getOption("projpred.extra_verbose",FALSE) && - ## deltas && - ## !all(stats %in% c("elpd","mlpd","gmpd"))) { - ## message(paste0("With deltas=TRUE, statistics ", paste(stats[!(stats %in% c("elpd","mlpd","gmpd"))], collapse=", "), - ## " report the uncertainty relative to the baseline, but the value in the original scale.")) - ## } - if (is.character(deltas) || deltas) { + if (deltas) { nfeat_baseline_for_tab <- nfeat_baseline } else { nfeat_baseline_for_tab <- NULL } + # Compute the predictive performance statistics: stats_table_all <- .tabulate_stats(object, stats, alpha = alpha, nfeat_baseline = nfeat_baseline_for_tab, @@ -753,23 +750,6 @@ plot.vsel <- function( stats_sub <- subset(stats_table_all, stats_table_all$size != Inf) stats_bs <- subset(stats_table_all, stats_table_all$size == nfeat_baseline) - if (!is.character(deltas) && deltas) { - stats_ref[,'value'] <- 0 - stats_ref[stats_ref[,'statistic']=="gmpd",'value'] <- 1 - } else if (is.character(deltas) && identical(deltas,'mixed')) { - stats_ref[stats_ref[,'statistic'] %in% c("elpd","mlpd"),'value'] <- 0 - stats_ref[stats_ref[,'statistic']=="gmpd",'value'] <- 1 - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff'] <- - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff'] + - stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.lq'] <- - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.lq'] + - stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.uq'] <- - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.uq'] + - stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] - } - # Catch unexpected output from .tabulate_stats(): if (NROW(stats_sub) == 0) { stop(ifelse(length(stats) > 1, "Statistics ", "Statistic "), @@ -797,11 +777,21 @@ plot.vsel <- function( nterms_max <- as.integer(nterms_max) # Define some "pretty" text strings for the plot: - ylab <- "Value" - if (is.character(deltas) || deltas) { - delta_lab <- "for baseline comparison" + if (baseline == "ref") { + baseline_pretty <- "reference model" + } else { + baseline_pretty <- "best submodel" + } + if (deltas) { + if (all(stats != "gmpd")) { + ylab <- paste0("Difference vs. ", baseline_pretty) + } else if (all(stats == "gmpd")) { + ylab <- paste0("Ratio vs. ", baseline_pretty) + } else { + ylab <- paste0("Difference (ratio for GMPD) vs. ", baseline_pretty) + } } else { - delta_lab <- "" + ylab <- "Value" } if (object$refmodel$family$for_latent) { if (resp_oscale) { @@ -972,39 +962,9 @@ plot.vsel <- function( } # Create the plot: - if (is.character(deltas) || deltas) { - data_gg$statistic[data_gg$statistic=="elpd"] <- "elpd_diff" - stats_ref$statistic[stats_ref$statistic=="elpd"] <- "elpd_diff" - data_gg$statistic[data_gg$statistic=="mlpd"] <- "mlpd_diff" - stats_ref$statistic[stats_ref$statistic=="mlpd"] <- "mlpd_diff" - data_gg$statistic[data_gg$statistic=="gmpd"] <- "gmpd_ratio" - stats_ref$statistic[stats_ref$statistic=="gmpd"] <- "gmpd_ratio" - if (!(is.character(deltas) && identical(deltas,'mixed'))) { - data_gg$statistic[data_gg$statistic=="mse"] <- "mse_diff" - stats_ref$statistic[stats_ref$statistic=="mse"] <- "mse_diff" - data_gg$statistic[data_gg$statistic=="rmse"] <- "rmse_diff" - stats_ref$statistic[stats_ref$statistic=="rmse"] <- "rmse_diff" - data_gg$statistic[data_gg$statistic=="rmse"] <- "rmse_diff" - stats_ref$statistic[stats_ref$statistic=="R2"] <- "R2_diff" - data_gg$statistic[data_gg$statistic=="R2"] <- "R2_diff" - stats_ref$statistic[stats_ref$statistic=="acc"] <- "acc_diff" - data_gg$statistic[data_gg$statistic=="acc"] <- "acc_diff" - stats_ref$statistic[stats_ref$statistic=="pctcorr"] <- "pctcorr_diff" - data_gg$statistic[data_gg$statistic=="pctcorr"] <- "pctcorr_diff" - stats_ref$statistic[stats_ref$statistic=="auc"] <- "auc_diff" - data_gg$statistic[data_gg$statistic=="auc"] <- "auc_diff" - } - } - - if (is.character(deltas) || deltas) { - pp <- ggplot(data = data_gg, - mapping = aes(x = .data[["size"]], y = .data[["diff"]], - ymin = .data[["diff.lq"]], ymax = .data[["diff.uq"]])) - } else { - pp <- ggplot(data = data_gg, - mapping = aes(x = .data[["size"]], y = .data[["value"]], - ymin = .data[["lq"]], ymax = .data[["uq"]])) - } + pp <- ggplot(data = data_gg, + mapping = aes(x = .data[["size"]], y = .data[["value"]], + ymin = .data[["lq"]], ymax = .data[["uq"]])) if (!all(is.na(stats_ref$se))) { # In this case, add the predictive performance of the reference model. pp <- pp + @@ -1021,9 +981,9 @@ plot.vsel <- function( thres_tab_ref$thres[is_elpd_mlpd_ref] <- thres_tab_ref$value[is_elpd_mlpd_ref] + thres_tab_ref$thres[is_elpd_mlpd_ref] - is_gmpd_ref <- thres_tab_ref$statistic %in% c("gmpd","gmpd ratio") + is_gmpd_ref <- thres_tab_ref$statistic %in% c("gmpd") thres_tab_ref$thres[is_gmpd_ref] <- - thres_tab_ref$value[is_gmpd_ref] * + thres_tab_ref$value[is_gmpd_ref] * thres_tab_ref$thres[is_gmpd_ref] pp <- pp + geom_hline(aes(yintercept = .data[["thres"]]), @@ -1107,7 +1067,9 @@ plot.vsel <- function( } if (all(stats %in% c("auc"))) { ci_type <- "bootstrap " - } else if (all(!stats %in% c("auc"))) { + } else if (all(stats %in% c("gmpd"))) { + ci_type <- "exponentiated normal-approximation " + } else if (all(!stats %in% c("auc", "gmpd"))) { ci_type <- "normal-approximation " } else { ci_type <- "" @@ -1142,11 +1104,9 @@ plot.vsel <- function( labels = tick_labs_x, sec.axis = x_axis_sec) + labs(x = xlab, y = ylab, title = "Predictive performance", - subtitle = paste0("With ", - round(100 * (1 - alpha), 1), "% ", - ci_type, - "intervals ", - delta_lab)) + + subtitle = paste0("Vertical bars indicate ", + round(100 * (1 - alpha), 1), "% ", ci_type, + "intervals")) + theme(axis.text.x.bottom = element_text(angle = text_angle, hjust = hjust_val, vjust = vjust_val)) + @@ -1240,18 +1200,17 @@ plot.vsel <- function( #' "relatively" refers to the ratio vs. the baseline model (i.e., the submodel #' statistic divided by the baseline model statistic). For all other `stats`, #' "relatively" refers to the difference from the baseline model (i.e., the -#' submodel statistic minus the baseline model statistic). For the ELPD and -#' the MLPD, the baseline performance is reported as 0. For the GMPD, -#' the baseline performance is reported as 1. For other statistics, the -#' baseline performance is reported as 0 if `deltas=TRUE` and in the original -#' scale if `deltas="mixed"`. If `deltas=TRUE` or `deltas="mixed"`, for all -#' statistics the related uncertainty is reported relative to the baseline. +#' submodel statistic minus the baseline model statistic). #' @param alpha A number determining the (nominal) coverage `1 - alpha` of the #' normal-approximation (or bootstrap or exponentiated normal-approximation; #' see argument `stats`) confidence intervals. For example, in case of the #' normal approximation, `alpha = 2 * pnorm(-1)` corresponds to a confidence #' interval stretching by one standard error on either side of the point #' estimate. +#' @param baseline For [summary.vsel()]: Only relevant if `deltas` is `TRUE`. +#' For [plot.vsel()]: Always relevant. Either `"ref"` or `"best"`, indicating +#' whether the baseline is the reference model or the best submodel found (in +#' terms of `stats[1]`), respectively. #' @param resp_oscale Only relevant for the latent projection. A single logical #' value indicating whether to calculate the performance statistics on the #' original response scale (`TRUE`) or on latent scale (`FALSE`). @@ -1318,14 +1277,14 @@ summary.vsel <- function( type = c("mean", "se", "diff", "diff.se"), deltas = FALSE, alpha = 2 * pnorm(-1), - baseline = "ref", + baseline = if (!inherits(object$refmodel, "datafit")) "ref" else "best", resp_oscale = TRUE, cumulate = FALSE, ... ) { validate_vsel_object_stats(object, stats, resp_oscale = resp_oscale) baseline <- validate_baseline(object$refmodel, baseline, deltas) - + # Initialize output: out <- c( object$refmodel[c("formula", "family")], @@ -1351,15 +1310,16 @@ summary.vsel <- function( } # The full table of the performance statistics from `stats`: - ## if (is.character(deltas) || deltas) { + if (deltas) { nfeat_baseline_for_tab <- get_nfeat_baseline(object, baseline, stats[1], resp_oscale = resp_oscale) - ## } else { - ## nfeat_baseline_for_tab <- NULL - ## } + } else { + nfeat_baseline_for_tab <- NULL + } stats_table_all <- .tabulate_stats(object, stats, alpha = alpha, nfeat_baseline = nfeat_baseline_for_tab, resp_oscale = resp_oscale, ...) + # Extract the reference model performance results from `stats_table_all`: stats_table_ref <- subset(stats_table_all, stats_table_all$size == Inf) @@ -1383,7 +1343,7 @@ summary.vsel <- function( # For renaming columns of the two output tables (one for the reference model # performance and for the submodel performance): colnms_ref <- mk_colnms_smmry(type = type, stats = stats, deltas = NULL) - colnms_sub <- mk_colnms_smmry(type = type, stats = stats, deltas = FALSE) + colnms_sub <- mk_colnms_smmry(type = type, stats = stats, deltas = deltas) # Fill the output table for the reference model performance (essentially, we # reshape `stats_table_ref`, thereby selecting only the requested `type`s and @@ -1428,7 +1388,7 @@ summary.vsel <- function( # reference model performance and one table for the submodel performance): mk_colnms_smmry <- function(type, stats, deltas) { # Pre-process `type`: - if (is.null(deltas) || (is.character(deltas) || deltas)) { + if (is.null(deltas) || deltas) { type <- setdiff(type, c("diff", "diff.se")) } type_dot <- paste0(".", type) @@ -1439,8 +1399,6 @@ mk_colnms_smmry <- function(type, stats, deltas) { nms_old[nms_old == "mean"] <- "value" nms_old[nms_old == "upper"] <- "uq" nms_old[nms_old == "lower"] <- "lq" - nms_old[nms_old == "diff.upper"] <- "diff.uq" - nms_old[nms_old == "diff.lower"] <- "diff.lq" # The clean column names that should be used in the output table: nms_new <- lapply(stats, paste0, type_dot) return(nlist(nms_old, nms_new)) @@ -1618,7 +1576,8 @@ print.vsel <- function(x, digits = getOption("projpred.digits", 2), ...) { #' falls above (or is equal to) \deqn{\texttt{pct} \cdot (u_0 - #' u_{\mathrm{base}})}{pct * (u_0 - u_base)} where \eqn{u_0} denotes the null #' model's estimated utility and \eqn{u_{\mathrm{base}}}{u_base} the baseline -#' model's estimated utility. +#' model's estimated utility. The baseline model is either the reference model +#' or the best submodel found (see argument `baseline` of [summary.vsel()]). #' #' In doing so, loss statistics like the root mean squared error (RMSE) and #' the mean squared error (MSE) are converted to utilities by multiplying them @@ -1721,10 +1680,9 @@ suggest_size.vsel <- function( if (length(stat) > 1) { stop("Only one statistic can be specified to suggest_size") } - stats <- summary.vsel(object, stats = stat, - type = c("diff", "diff.upper", "diff.lower"), + type = c("mean", "upper", "lower"), deltas = TRUE, ...) stats <- stats$perf_sub @@ -1739,9 +1697,9 @@ suggest_size.vsel <- function( type <- "upper" } } - bound <- paste0(stat, ".diff.", type) - stat.diff <- paste0(stat, ".", 'diff') - util_null <- sgn * unlist(unname(subset(stats, stats$size == 0, stat.diff))) + bound <- paste0(stat, ".", type) + + util_null <- sgn * unlist(unname(subset(stats, stats$size == 0, stat))) if (stat != "gmpd") { util_cutoff <- pct * util_null } else { @@ -1750,13 +1708,12 @@ suggest_size.vsel <- function( if (is.na(thres_elpd)) { thres_elpd <- Inf } - nobs_test <- object$nobs_test res <- stats[ (sgn * stats[, bound] >= util_cutoff) | - (stat == "elpd" & stats[, stat.diff] > thres_elpd) | - (stat == "mlpd" & stats[, stat.diff] > thres_elpd / nobs_test) | - (stat == "gmpd" & stats[, stat.diff] > exp(thres_elpd / nobs_test)), + (stat == "elpd" & stats[, stat] > thres_elpd) | + (stat == "mlpd" & stats[, stat] > thres_elpd / nobs_test) | + (stat == "gmpd" & stats[, stat] > exp(thres_elpd / nobs_test)), "size", drop = FALSE ] diff --git a/R/misc.R b/R/misc.R index 833bef3d8..b680f7ede 100644 --- a/R/misc.R +++ b/R/misc.R @@ -198,8 +198,8 @@ validate_vsel_object_stats <- function(object, stats, resp_oscale = TRUE) { validate_baseline <- function(refmodel, baseline, deltas) { stopifnot(!is.null(baseline)) - if (!(baseline %in% c("ref"))) { - stop("Argument 'baseline' must be 'ref'.") + if (!(baseline %in% c("ref", "best"))) { + stop("Argument 'baseline' must be either 'ref' or 'best'.") } if (baseline == "ref" && deltas == TRUE && inherits(refmodel, "datafit")) { # no reference model (or the results missing for some other reason), diff --git a/R/summary_funs.R b/R/summary_funs.R index 3a095cae9..004a2438e 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -88,7 +88,7 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, # statistics relative to the baseline model of that size (`nfeat_baseline = Inf` # means that the baseline model is the reference model). .tabulate_stats <- function(varsel, stats, alpha = 0.05, - nfeat_baseline = Inf, resp_oscale = TRUE, ...) { + nfeat_baseline = NULL, resp_oscale = TRUE, ...) { stat_tab <- data.frame() summaries_ref <- varsel$summaries$ref summaries_sub <- varsel$summaries$sub @@ -192,8 +192,8 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, varsel$y_wobs_test, stat, alpha = alpha, ...) row <- data.frame( data = varsel$type_test, size = Inf, delta = delta, statistic = stat, - value = res$value, lq = res$lq, uq = res$uq, se = res$se, - diff = NA, diff.lq = NA, diff.uq = NA, diff.se = NA + value = res$value, lq = res$lq, uq = res$uq, se = res$se, diff = NA, + diff.se = NA ) stat_tab <- rbind(stat_tab, row) @@ -475,8 +475,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, value_se <- sd(diffvalue.bootstrap, na.rm = TRUE) lq_uq <- quantile(diffvalue.bootstrap, probs = c(alpha_half, one_minus_alpha_half), - names = FALSE, na.rm = TRUE) + - .auc(auc_data_baseline) + names = FALSE, na.rm = TRUE) } else { auc_data <- cbind(y, mu, wobs) value <- .auc(auc_data) From aea7f089a4c21ebc09b39f7a21c820b48b5121e8 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 07:04:56 +0200 Subject: [PATCH 068/134] Revert "UNFINISHED: move out the new "mixed deltas" variant of `plot.vsel()`, the" This reverts commit ea18e9aef11d61c7d3851510ef5a13f8ba7e7047. Reason for the revert: It's easier if we first add everything that should be in the final (separate) pull request that incorporates all changes from this pull request (including the new "mixed deltas" plot, the new column behavior of `summary.vsel()` etc.). Afterwards, we can simplify the current pull request and leave things like the new "mixed deltas" plot and the new column behavior of `summary.vsel()` for the separate pull request. --- R/methods.R | 153 ++++++++++++++++++++++++++++++----------------- R/misc.R | 4 +- R/summary_funs.R | 9 +-- 3 files changed, 105 insertions(+), 61 deletions(-) diff --git a/R/methods.R b/R/methods.R index e773a44e8..3cbd91eee 100644 --- a/R/methods.R +++ b/R/methods.R @@ -668,13 +668,11 @@ proj_predict_aux <- function(proj, newdata, offsetnew, weightsnew, #' # Horizontal lines #' #' As long as the reference model's performance is computable, it is always -#' shown in the plot as a dashed red horizontal line. If `baseline = "best"`, -#' the baseline model's performance is shown as a dotted black horizontal line. +#' shown in the plot as a dashed red horizontal line. #' If `!is.na(thres_elpd)` and `any(stats %in% c("elpd", "mlpd", "gmpd"))`, the #' value supplied to `thres_elpd` (which is automatically adapted internally in #' case of the MLPD or the GMPD or `deltas = FALSE`) is shown as a dot-dashed -#' gray horizontal line for the reference model and, if `baseline = "best"`, as -#' a long-dashed green horizontal line for the baseline model. +#' gray horizontal line for the reference model. #' #' @examplesIf requireNamespace("rstanarm", quietly = TRUE) #' # Data: @@ -702,7 +700,7 @@ plot.vsel <- function( stats = "elpd", deltas = FALSE, alpha = 2 * pnorm(-1), - baseline = if (!inherits(x$refmodel, "datafit")) "ref" else "best", + baseline = "ref", thres_elpd = NA, resp_oscale = TRUE, point_size = 3, @@ -736,12 +734,17 @@ plot.vsel <- function( # .tabulate_stats()'s argument `nfeat_baseline`: nfeat_baseline <- get_nfeat_baseline(object, baseline, stats[1], resp_oscale = resp_oscale) - if (deltas) { + ## if (getOption("projpred.extra_verbose",FALSE) && + ## deltas && + ## !all(stats %in% c("elpd","mlpd","gmpd"))) { + ## message(paste0("With deltas=TRUE, statistics ", paste(stats[!(stats %in% c("elpd","mlpd","gmpd"))], collapse=", "), + ## " report the uncertainty relative to the baseline, but the value in the original scale.")) + ## } + if (is.character(deltas) || deltas) { nfeat_baseline_for_tab <- nfeat_baseline } else { nfeat_baseline_for_tab <- NULL } - # Compute the predictive performance statistics: stats_table_all <- .tabulate_stats(object, stats, alpha = alpha, nfeat_baseline = nfeat_baseline_for_tab, @@ -750,6 +753,23 @@ plot.vsel <- function( stats_sub <- subset(stats_table_all, stats_table_all$size != Inf) stats_bs <- subset(stats_table_all, stats_table_all$size == nfeat_baseline) + if (!is.character(deltas) && deltas) { + stats_ref[,'value'] <- 0 + stats_ref[stats_ref[,'statistic']=="gmpd",'value'] <- 1 + } else if (is.character(deltas) && identical(deltas,'mixed')) { + stats_ref[stats_ref[,'statistic'] %in% c("elpd","mlpd"),'value'] <- 0 + stats_ref[stats_ref[,'statistic']=="gmpd",'value'] <- 1 + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff'] <- + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff'] + + stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.lq'] <- + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.lq'] + + stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.uq'] <- + stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.uq'] + + stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] + } + # Catch unexpected output from .tabulate_stats(): if (NROW(stats_sub) == 0) { stop(ifelse(length(stats) > 1, "Statistics ", "Statistic "), @@ -777,21 +797,11 @@ plot.vsel <- function( nterms_max <- as.integer(nterms_max) # Define some "pretty" text strings for the plot: - if (baseline == "ref") { - baseline_pretty <- "reference model" - } else { - baseline_pretty <- "best submodel" - } - if (deltas) { - if (all(stats != "gmpd")) { - ylab <- paste0("Difference vs. ", baseline_pretty) - } else if (all(stats == "gmpd")) { - ylab <- paste0("Ratio vs. ", baseline_pretty) - } else { - ylab <- paste0("Difference (ratio for GMPD) vs. ", baseline_pretty) - } + ylab <- "Value" + if (is.character(deltas) || deltas) { + delta_lab <- "for baseline comparison" } else { - ylab <- "Value" + delta_lab <- "" } if (object$refmodel$family$for_latent) { if (resp_oscale) { @@ -962,9 +972,39 @@ plot.vsel <- function( } # Create the plot: - pp <- ggplot(data = data_gg, - mapping = aes(x = .data[["size"]], y = .data[["value"]], - ymin = .data[["lq"]], ymax = .data[["uq"]])) + if (is.character(deltas) || deltas) { + data_gg$statistic[data_gg$statistic=="elpd"] <- "elpd_diff" + stats_ref$statistic[stats_ref$statistic=="elpd"] <- "elpd_diff" + data_gg$statistic[data_gg$statistic=="mlpd"] <- "mlpd_diff" + stats_ref$statistic[stats_ref$statistic=="mlpd"] <- "mlpd_diff" + data_gg$statistic[data_gg$statistic=="gmpd"] <- "gmpd_ratio" + stats_ref$statistic[stats_ref$statistic=="gmpd"] <- "gmpd_ratio" + if (!(is.character(deltas) && identical(deltas,'mixed'))) { + data_gg$statistic[data_gg$statistic=="mse"] <- "mse_diff" + stats_ref$statistic[stats_ref$statistic=="mse"] <- "mse_diff" + data_gg$statistic[data_gg$statistic=="rmse"] <- "rmse_diff" + stats_ref$statistic[stats_ref$statistic=="rmse"] <- "rmse_diff" + data_gg$statistic[data_gg$statistic=="rmse"] <- "rmse_diff" + stats_ref$statistic[stats_ref$statistic=="R2"] <- "R2_diff" + data_gg$statistic[data_gg$statistic=="R2"] <- "R2_diff" + stats_ref$statistic[stats_ref$statistic=="acc"] <- "acc_diff" + data_gg$statistic[data_gg$statistic=="acc"] <- "acc_diff" + stats_ref$statistic[stats_ref$statistic=="pctcorr"] <- "pctcorr_diff" + data_gg$statistic[data_gg$statistic=="pctcorr"] <- "pctcorr_diff" + stats_ref$statistic[stats_ref$statistic=="auc"] <- "auc_diff" + data_gg$statistic[data_gg$statistic=="auc"] <- "auc_diff" + } + } + + if (is.character(deltas) || deltas) { + pp <- ggplot(data = data_gg, + mapping = aes(x = .data[["size"]], y = .data[["diff"]], + ymin = .data[["diff.lq"]], ymax = .data[["diff.uq"]])) + } else { + pp <- ggplot(data = data_gg, + mapping = aes(x = .data[["size"]], y = .data[["value"]], + ymin = .data[["lq"]], ymax = .data[["uq"]])) + } if (!all(is.na(stats_ref$se))) { # In this case, add the predictive performance of the reference model. pp <- pp + @@ -981,9 +1021,9 @@ plot.vsel <- function( thres_tab_ref$thres[is_elpd_mlpd_ref] <- thres_tab_ref$value[is_elpd_mlpd_ref] + thres_tab_ref$thres[is_elpd_mlpd_ref] - is_gmpd_ref <- thres_tab_ref$statistic %in% c("gmpd") + is_gmpd_ref <- thres_tab_ref$statistic %in% c("gmpd","gmpd ratio") thres_tab_ref$thres[is_gmpd_ref] <- - thres_tab_ref$value[is_gmpd_ref] * + thres_tab_ref$value[is_gmpd_ref] * thres_tab_ref$thres[is_gmpd_ref] pp <- pp + geom_hline(aes(yintercept = .data[["thres"]]), @@ -1067,9 +1107,7 @@ plot.vsel <- function( } if (all(stats %in% c("auc"))) { ci_type <- "bootstrap " - } else if (all(stats %in% c("gmpd"))) { - ci_type <- "exponentiated normal-approximation " - } else if (all(!stats %in% c("auc", "gmpd"))) { + } else if (all(!stats %in% c("auc"))) { ci_type <- "normal-approximation " } else { ci_type <- "" @@ -1104,9 +1142,11 @@ plot.vsel <- function( labels = tick_labs_x, sec.axis = x_axis_sec) + labs(x = xlab, y = ylab, title = "Predictive performance", - subtitle = paste0("Vertical bars indicate ", - round(100 * (1 - alpha), 1), "% ", ci_type, - "intervals")) + + subtitle = paste0("With ", + round(100 * (1 - alpha), 1), "% ", + ci_type, + "intervals ", + delta_lab)) + theme(axis.text.x.bottom = element_text(angle = text_angle, hjust = hjust_val, vjust = vjust_val)) + @@ -1200,17 +1240,18 @@ plot.vsel <- function( #' "relatively" refers to the ratio vs. the baseline model (i.e., the submodel #' statistic divided by the baseline model statistic). For all other `stats`, #' "relatively" refers to the difference from the baseline model (i.e., the -#' submodel statistic minus the baseline model statistic). +#' submodel statistic minus the baseline model statistic). For the ELPD and +#' the MLPD, the baseline performance is reported as 0. For the GMPD, +#' the baseline performance is reported as 1. For other statistics, the +#' baseline performance is reported as 0 if `deltas=TRUE` and in the original +#' scale if `deltas="mixed"`. If `deltas=TRUE` or `deltas="mixed"`, for all +#' statistics the related uncertainty is reported relative to the baseline. #' @param alpha A number determining the (nominal) coverage `1 - alpha` of the #' normal-approximation (or bootstrap or exponentiated normal-approximation; #' see argument `stats`) confidence intervals. For example, in case of the #' normal approximation, `alpha = 2 * pnorm(-1)` corresponds to a confidence #' interval stretching by one standard error on either side of the point #' estimate. -#' @param baseline For [summary.vsel()]: Only relevant if `deltas` is `TRUE`. -#' For [plot.vsel()]: Always relevant. Either `"ref"` or `"best"`, indicating -#' whether the baseline is the reference model or the best submodel found (in -#' terms of `stats[1]`), respectively. #' @param resp_oscale Only relevant for the latent projection. A single logical #' value indicating whether to calculate the performance statistics on the #' original response scale (`TRUE`) or on latent scale (`FALSE`). @@ -1277,14 +1318,14 @@ summary.vsel <- function( type = c("mean", "se", "diff", "diff.se"), deltas = FALSE, alpha = 2 * pnorm(-1), - baseline = if (!inherits(object$refmodel, "datafit")) "ref" else "best", + baseline = "ref", resp_oscale = TRUE, cumulate = FALSE, ... ) { validate_vsel_object_stats(object, stats, resp_oscale = resp_oscale) baseline <- validate_baseline(object$refmodel, baseline, deltas) - + # Initialize output: out <- c( object$refmodel[c("formula", "family")], @@ -1310,16 +1351,15 @@ summary.vsel <- function( } # The full table of the performance statistics from `stats`: - if (deltas) { + ## if (is.character(deltas) || deltas) { nfeat_baseline_for_tab <- get_nfeat_baseline(object, baseline, stats[1], resp_oscale = resp_oscale) - } else { - nfeat_baseline_for_tab <- NULL - } + ## } else { + ## nfeat_baseline_for_tab <- NULL + ## } stats_table_all <- .tabulate_stats(object, stats, alpha = alpha, nfeat_baseline = nfeat_baseline_for_tab, resp_oscale = resp_oscale, ...) - # Extract the reference model performance results from `stats_table_all`: stats_table_ref <- subset(stats_table_all, stats_table_all$size == Inf) @@ -1343,7 +1383,7 @@ summary.vsel <- function( # For renaming columns of the two output tables (one for the reference model # performance and for the submodel performance): colnms_ref <- mk_colnms_smmry(type = type, stats = stats, deltas = NULL) - colnms_sub <- mk_colnms_smmry(type = type, stats = stats, deltas = deltas) + colnms_sub <- mk_colnms_smmry(type = type, stats = stats, deltas = FALSE) # Fill the output table for the reference model performance (essentially, we # reshape `stats_table_ref`, thereby selecting only the requested `type`s and @@ -1388,7 +1428,7 @@ summary.vsel <- function( # reference model performance and one table for the submodel performance): mk_colnms_smmry <- function(type, stats, deltas) { # Pre-process `type`: - if (is.null(deltas) || deltas) { + if (is.null(deltas) || (is.character(deltas) || deltas)) { type <- setdiff(type, c("diff", "diff.se")) } type_dot <- paste0(".", type) @@ -1399,6 +1439,8 @@ mk_colnms_smmry <- function(type, stats, deltas) { nms_old[nms_old == "mean"] <- "value" nms_old[nms_old == "upper"] <- "uq" nms_old[nms_old == "lower"] <- "lq" + nms_old[nms_old == "diff.upper"] <- "diff.uq" + nms_old[nms_old == "diff.lower"] <- "diff.lq" # The clean column names that should be used in the output table: nms_new <- lapply(stats, paste0, type_dot) return(nlist(nms_old, nms_new)) @@ -1576,8 +1618,7 @@ print.vsel <- function(x, digits = getOption("projpred.digits", 2), ...) { #' falls above (or is equal to) \deqn{\texttt{pct} \cdot (u_0 - #' u_{\mathrm{base}})}{pct * (u_0 - u_base)} where \eqn{u_0} denotes the null #' model's estimated utility and \eqn{u_{\mathrm{base}}}{u_base} the baseline -#' model's estimated utility. The baseline model is either the reference model -#' or the best submodel found (see argument `baseline` of [summary.vsel()]). +#' model's estimated utility. #' #' In doing so, loss statistics like the root mean squared error (RMSE) and #' the mean squared error (MSE) are converted to utilities by multiplying them @@ -1680,9 +1721,10 @@ suggest_size.vsel <- function( if (length(stat) > 1) { stop("Only one statistic can be specified to suggest_size") } + stats <- summary.vsel(object, stats = stat, - type = c("mean", "upper", "lower"), + type = c("diff", "diff.upper", "diff.lower"), deltas = TRUE, ...) stats <- stats$perf_sub @@ -1697,9 +1739,9 @@ suggest_size.vsel <- function( type <- "upper" } } - bound <- paste0(stat, ".", type) - - util_null <- sgn * unlist(unname(subset(stats, stats$size == 0, stat))) + bound <- paste0(stat, ".diff.", type) + stat.diff <- paste0(stat, ".", 'diff') + util_null <- sgn * unlist(unname(subset(stats, stats$size == 0, stat.diff))) if (stat != "gmpd") { util_cutoff <- pct * util_null } else { @@ -1708,12 +1750,13 @@ suggest_size.vsel <- function( if (is.na(thres_elpd)) { thres_elpd <- Inf } + nobs_test <- object$nobs_test res <- stats[ (sgn * stats[, bound] >= util_cutoff) | - (stat == "elpd" & stats[, stat] > thres_elpd) | - (stat == "mlpd" & stats[, stat] > thres_elpd / nobs_test) | - (stat == "gmpd" & stats[, stat] > exp(thres_elpd / nobs_test)), + (stat == "elpd" & stats[, stat.diff] > thres_elpd) | + (stat == "mlpd" & stats[, stat.diff] > thres_elpd / nobs_test) | + (stat == "gmpd" & stats[, stat.diff] > exp(thres_elpd / nobs_test)), "size", drop = FALSE ] diff --git a/R/misc.R b/R/misc.R index b680f7ede..833bef3d8 100644 --- a/R/misc.R +++ b/R/misc.R @@ -198,8 +198,8 @@ validate_vsel_object_stats <- function(object, stats, resp_oscale = TRUE) { validate_baseline <- function(refmodel, baseline, deltas) { stopifnot(!is.null(baseline)) - if (!(baseline %in% c("ref", "best"))) { - stop("Argument 'baseline' must be either 'ref' or 'best'.") + if (!(baseline %in% c("ref"))) { + stop("Argument 'baseline' must be 'ref'.") } if (baseline == "ref" && deltas == TRUE && inherits(refmodel, "datafit")) { # no reference model (or the results missing for some other reason), diff --git a/R/summary_funs.R b/R/summary_funs.R index 004a2438e..3a095cae9 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -88,7 +88,7 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, # statistics relative to the baseline model of that size (`nfeat_baseline = Inf` # means that the baseline model is the reference model). .tabulate_stats <- function(varsel, stats, alpha = 0.05, - nfeat_baseline = NULL, resp_oscale = TRUE, ...) { + nfeat_baseline = Inf, resp_oscale = TRUE, ...) { stat_tab <- data.frame() summaries_ref <- varsel$summaries$ref summaries_sub <- varsel$summaries$sub @@ -192,8 +192,8 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, varsel$y_wobs_test, stat, alpha = alpha, ...) row <- data.frame( data = varsel$type_test, size = Inf, delta = delta, statistic = stat, - value = res$value, lq = res$lq, uq = res$uq, se = res$se, diff = NA, - diff.se = NA + value = res$value, lq = res$lq, uq = res$uq, se = res$se, + diff = NA, diff.lq = NA, diff.uq = NA, diff.se = NA ) stat_tab <- rbind(stat_tab, row) @@ -475,7 +475,8 @@ get_stat <- function(summaries, summaries_baseline = NULL, value_se <- sd(diffvalue.bootstrap, na.rm = TRUE) lq_uq <- quantile(diffvalue.bootstrap, probs = c(alpha_half, one_minus_alpha_half), - names = FALSE, na.rm = TRUE) + names = FALSE, na.rm = TRUE) + + .auc(auc_data_baseline) } else { auc_data <- cbind(y, mu, wobs) value <- .auc(auc_data) From 867f29f68d86a245227b81e0fa63b30abc4870e1 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 07:08:22 +0200 Subject: [PATCH 069/134] in `.onAttach()`, keep the temporary "NOTE" in separate lines (to avoid that `\n` accidentally remains after removing the "NOTE" in the future) --- R/misc.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/misc.R b/R/misc.R index 833bef3d8..2fd3e1323 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1,8 +1,8 @@ .onAttach <- function(...) { ver <- utils::packageVersion("projpred") - msg <- paste0("This is projpred version ", ver, ".\n") - msg <- paste0(msg, "NOTE: In projpred 2.7.0, the default search method ", - "was set to \"forward\" (for all kinds of models).") + msg <- paste0("This is projpred version ", ver, ".") + msg <- paste0(msg, "\n", "NOTE: In projpred 2.7.0, the default search ", + "method was set to \"forward\" (for all kinds of models).") packageStartupMessage(msg) } From 2d9a6522a8369a659ea5c7a7192c09b43ed6a66a Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 07:18:52 +0200 Subject: [PATCH 070/134] add comments in `summary_funs.R` --- R/summary_funs.R | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 3a095cae9..43fe15d3b 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -385,6 +385,16 @@ get_stat <- function(summaries, summaries_baseline = NULL, } } else if (stat %in% c("acc", "pctcorr", "auc")) { y <- y_wobs_test$y + # In this case (`stat %in% c("acc", "pctcorr", "auc")`), we hard-code `wobs` + # to be full of ones because currently, the user-supplied observation + # weights are required to be (positive) whole numbers, so these observation + # weights are incorporated by "de-aggregating" the aggregated dataset that + # was supplied by the user (the term "de-aggregation" refers to the + # de-aggregation of the multiple Bernoulli trials belonging to one row in + # the aggregated dataset). Currently, `wobs` is not really useful and could + # be removed, but we leave it here for the future (perhaps one day, we will + # not require the user-supplied observation weights to be whole numbers + # anymore). wobs <- rep(1, n) if (!is.null(y_wobs_test$y_prop)) { # CAUTION: The following checks also ensure that `y` does not have `NA`s @@ -403,8 +413,8 @@ get_stat <- function(summaries, summaries_baseline = NULL, } else { mu_baseline <- NULL } - # CAUTION: If `y` is allowed to have `NA`s here, then `n` needs to be - # adapted: + # CAUTION: If `y` is allowed to have `NA`s here, then the following + # definition of `n` needs to be adapted: n <- sum(!is.na(mu)) wobs <- rep(wobs, y_wobs_test$wobs) wobs <- n * wobs / sum(wobs) From 35cc542ce25542b1133231f55c64e9eccf1574d8 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 21:38:55 +0200 Subject: [PATCH 071/134] simplify `summaries_fast_sub <- varsel$summaries_fast$sub` and `summaries_fast_sub <- NULL` to one line --- R/summary_funs.R | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 43fe15d3b..d7a3bb7ca 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -92,13 +92,12 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, stat_tab <- data.frame() summaries_ref <- varsel$summaries$ref summaries_sub <- varsel$summaries$sub - if (!is.null(varsel$summaries_fast)) { - summaries_fast_sub <- varsel$summaries_fast$sub + summaries_fast_sub <- varsel$summaries_fast$sub + if (!is.null(summaries_fast_sub)) { if (any(stats %in% c("auc"))) { - warning("Subsampling LOO with AUC not implemented. Using fast LOO for submodel AUC.") + warning("Subsampling LOO with AUC not implemented. Using fast LOO for ", + "submodel AUC.") } - } else { - summaries_fast_sub <- NULL } if (!varsel$refmodel$family$for_latent && !resp_oscale) { From 19948e33b3a2c4ce6c90afc4552b8004078076e6 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 21:48:11 +0200 Subject: [PATCH 072/134] `loo_inds` as stored in `vsel` objects was unused so far the intentioned usage was probably in `get_stat()` (because `loo_inds <- which(!is.na(lppd))` was error-prone; e.g., in the augmented-data or latent projection, `lppd` might consist of only `NA`s) --- R/summary_funs.R | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index d7a3bb7ca..f273d4233 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -159,7 +159,7 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, summaries_ref$mu <- catmaxprb(summaries_ref$mu, lvls = varsel$refmodel$family$cats) summaries_sub <- lapply(summaries_sub, function(summaries_sub_k) { summaries_sub_k$mu <- catmaxprb(summaries_sub_k$mu, - lvls = varsel$refmodel$family$cats) + lvls = varsel$refmodel$family$cats) return(summaries_sub_k) }) # Since `mu` is an unordered factor, `y` needs to be unordered, too (or both @@ -188,6 +188,7 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, res <- get_stat(summaries = summaries_ref, summaries_baseline = NULL, summaries_fast = NULL, + loo_inds = varsel$loo_inds, varsel$y_wobs_test, stat, alpha = alpha, ...) row <- data.frame( data = varsel$type_test, size = Inf, delta = delta, statistic = stat, @@ -201,10 +202,12 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, diff <- get_stat(summaries = summaries_sub[[k]], summaries_baseline = summaries_baseline, summaries_fast = summaries_fast_sub[[k]], + loo_inds = varsel$loo_inds, varsel$y_wobs_test, stat, alpha = alpha, ...) res <- get_stat(summaries = summaries_sub[[k]], summaries_baseline = NULL, summaries_fast = summaries_fast_sub[[k]], + loo_inds = varsel$loo_inds, varsel$y_wobs_test, stat, alpha = alpha, ...) row <- data.frame( data = varsel$type_test, size = k - 1, delta = delta, @@ -236,13 +239,12 @@ check_sub_NA <- function(summaries_sub_k, el_nm) { ## into account in `lppd`. However, `mu` does not take them into account, so ## some further adjustments are necessary below. get_stat <- function(summaries, summaries_baseline = NULL, - summaries_fast = NULL, + summaries_fast = NULL, loo_inds = NULL, y_wobs_test, stat, alpha = 0.1, ...) { mu <- summaries$mu lppd <- summaries$lppd - loo_inds <- which(!is.na(lppd)) n <- length(lppd) - n_loo <- length(loo_inds) + n_loo <- if (is.null(loo_inds)) n else length(loo_inds) if (n_loo == 0) { return(list(value = NA, se = NA, lq = NA, uq = NA)) } @@ -344,7 +346,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, ((mean(y)-y)^2-mse_y)) / n } else { cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e - - ((mu_baseline - y)^2 - mse_b)) * + ((mu_baseline - y)^2 - mse_b)) * ((mean(y)-y)^2-mse_y)) / n } } else { From f26e4fbac0550c020400fad473f67ced88f1cb94 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 22:08:24 +0200 Subject: [PATCH 073/134] in `get_stat()`, the `is.null(summaries_fast)` checks are not necessary also perform some cleaning in terms of whitespace and object names (in R, calling objects `n` is not convenient because it complicates debugging [there, `n` means "next"]; also, such a generic name makes it hard to search for these objects in the code; for `w`, the problem is that there are several different kinds of weights within projpred, so we should point out what they refer to) --- R/summary_funs.R | 129 +++++++++++++++++++++++------------------------ 1 file changed, 63 insertions(+), 66 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index f273d4233..e6ceba3c9 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -243,8 +243,8 @@ get_stat <- function(summaries, summaries_baseline = NULL, y_wobs_test, stat, alpha = 0.1, ...) { mu <- summaries$mu lppd <- summaries$lppd - n <- length(lppd) - n_loo <- if (is.null(loo_inds)) n else length(loo_inds) + n_full <- length(lppd) + n_loo <- if (is.null(loo_inds)) n_full else length(loo_inds) if (n_loo == 0) { return(list(value = NA, se = NA, lq = NA, uq = NA)) } @@ -253,14 +253,14 @@ get_stat <- function(summaries, summaries_baseline = NULL, if (stat %in% c("elpd", "mlpd", "gmpd")) { if (is.null(summaries_baseline)) { - lppd_baseline = 0 + lppd_baseline <- 0 } else { - lppd_baseline = summaries_baseline$lppd + lppd_baseline <- summaries_baseline$lppd } - if (!is.null(summaries_fast) && n_loo1) { - w_m <- w[y_idx] - w_m <- length(w_m)*w_m/sum(w_m) - w <- length(w)*w/sum(w) + wobs_m <- 1 + if (length(wobs) > 1) { + wobs_m <- wobs[y_idx] + wobs_m <- length(wobs_m) * wobs_m / sum(wobs_m) + wobs <- length(wobs) * wobs / sum(wobs) } e_i <- y - y_approx_m - t_pi_tilde <- sum(w*y_approx) - t_pi2_tilde <- sum(w*y_approx^2) - t_e <- N * mean(w_m*e_i) - t_hat_epsilon <- N * mean(w_m*(y^2 - y_approx_m^2)) + t_pi_tilde <- sum(wobs * y_approx) + t_pi2_tilde <- sum(wobs * y_approx^2) + t_e <- N * mean(wobs_m * e_i) + t_hat_epsilon <- N * mean(wobs_m * (y^2 - y_approx_m^2)) est_list <- list(m = length(y), N = N) # eq (7) est_list$y_hat <- t_pi_tilde + t_e # eq (8) - var_e_i <- m/(m-1)*(mean(w_m*e_i^2)-mean(w_m*e_i)^2) + var_e_i <- m / (m - 1) * (mean(wobs_m * e_i^2) - mean(wobs_m * e_i)^2) est_list$v_y_hat <- N^2 * (1 - m / N) * var_e_i / m # eq (9) first row second `+` should be `-` # Supplementary material eq (6) has this correct # Here the variance is for sum, while in the paper the variance is for mean # which explains the proportional difference of 1/N est_list$hat_v_y <- (t_pi2_tilde + t_hat_epsilon) - # a (has been checked) - (1/N) * (t_e^2 - est_list$v_y_hat + 2 * t_pi_tilde * est_list$y_hat - t_pi_tilde^2) # b - est_list + (1 / N) * (t_e^2 - est_list$v_y_hat + 2 * t_pi_tilde * est_list$y_hat - t_pi_tilde^2) # b + return(est_list) } From 319c2b7c8c99018e426ccb9c040ca12c261dfe0c Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 22:11:06 +0200 Subject: [PATCH 074/134] avoid object name `n` at more places (in R, calling objects `n` is not convenient because it complicates debugging [there, `n` means "next"]; also, such a generic name makes it hard to search for these objects in the code; for `w`, the problem is that there are several different kinds of weights within projpred, so we should point out what they refer to) --- R/cv_varsel.R | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 68ce33b3d..5fecf6775 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -336,7 +336,6 @@ cv_varsel.refmodel <- function( ) cv_method <- args$cv_method nloo <- args$nloo - n <- refmodel$nobs K <- args$K cvfits <- args$cvfits @@ -405,15 +404,15 @@ cv_varsel.refmodel <- function( search_terms_was_null = search_terms_was_null, search_out_rks = search_out_rks, parallel = parallel, ... ) - if (is.null(summaries_fast) && validate_search && nloo < n) { + if (is.null(summaries_fast) && validate_search && nloo < refmodel$nobs) { # Run fast LOO-CV to be used in subsampling difference estimator summaries_fast <- loo_varsel( refmodel = refmodel, method = method, nterms_max = nterms_max, ndraws = ndraws, nclusters = nclusters, ndraws_pred = ndraws_pred, nclusters_pred = nclusters_pred, refit_prj = refit_prj, penalty = penalty, verbose = verbose, search_control = search_control, - nloo = n, # fast LOO-CV for all n - validate_search = FALSE, # fast LOO-CV for all n + nloo = refmodel$nobs, # fast LOO-CV (using all observations) + validate_search = FALSE, # fast LOO-CV (using all observations) search_path_fulldata = search_path_fulldata, search_terms = search_terms, search_terms_was_null = search_terms_was_null, From dfcc58c944b548a97b9154bef4d58d3e165a4272 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 22:19:13 +0200 Subject: [PATCH 075/134] the definition of `loo_ref_oscale` does not make sense to be placed among the empty initialized objects, so move it back --- R/cv_varsel.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 5fecf6775..29aed46a8 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -704,6 +704,8 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, refmodel$y <- y_lat_E$value } + loo_ref_oscale <- apply(loglik_forPSIS + lw, 2, log_sum_exp) + if (validate_search && nloo < n) { # Select which LOO-folds get more accurate computation using simple # random sampling without resampling (Magnusson et al., 2020) @@ -722,7 +724,6 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, fixed = TRUE)), simplify = FALSE ) - loo_ref_oscale <- apply(loglik_forPSIS + lw, 2, log_sum_exp) if (refmodel$family$for_latent) { loo_sub_oscale <- loo_sub # In general, we could use `mu_sub_oscale <- mu_sub` here, but the case From f53bc4806cb0a5efd816300e665cd9c46f65ac20 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 22:22:55 +0200 Subject: [PATCH 076/134] simplify an SRS-WOR `value` computation (if `mu_baseline` is `NULL`, then `correct_baseline` is `0` anyway) --- R/summary_funs.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index e6ceba3c9..825b2f76a 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -451,8 +451,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, y = (correct-correct_baseline)[loo_inds], y_idx = loo_inds, w = wobs) - value <- srs_diffe$y_hat / n_full + mean(wobs * correct_baseline) - - ifelse(is.null(mu_baseline), 0, mean(wobs * correct_baseline)) + value <- srs_diffe$y_hat / n_full # combine estimates of var(y_hat) and var(y) value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n_full } else { From 59afc9724ecccf7a4e10ec53c5ac5419c4d88c2f Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 22:26:10 +0200 Subject: [PATCH 077/134] simplify initialization of `est_list` --- R/summary_funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 825b2f76a..d20a62be5 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -573,7 +573,7 @@ get_nfeat_baseline <- function(object, baseline, stat, ...) { t_e <- N * mean(wobs_m * e_i) t_hat_epsilon <- N * mean(wobs_m * (y^2 - y_approx_m^2)) - est_list <- list(m = length(y), N = N) + est_list <- nlist(m, N) # eq (7) est_list$y_hat <- t_pi_tilde + t_e # eq (8) From 2727cff3b74df2af800cd37b4fa9a309bc96be89 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 22:30:26 +0200 Subject: [PATCH 078/134] avoid redundant computations by moving `sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y)` into `.srs_diff_est_w()` --- R/summary_funs.R | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index d20a62be5..3f0498ff1 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -264,7 +264,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, y_idx = loo_inds) value <- srs_diffe$y_hat # combine estimates of var(y_hat) and var(y) - value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) + value_se <- srs_diffe$y_hat_se } else { # full LOO estimator value <- sum((lppd - lppd_baseline), na.rm = TRUE) @@ -301,7 +301,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, w = wobs) value <- srs_diffe$y_hat / n_full # combine estimates of var(y_hat) and var(y) - value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n_full + value_se <- srs_diffe$y_hat_se / n_full } # store for later calculations mse_e <- value @@ -453,7 +453,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, w = wobs) value <- srs_diffe$y_hat / n_full # combine estimates of var(y_hat) and var(y) - value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n_full + value_se <- srs_diffe$y_hat_se / n_full } else { # full LOO estimator value <- mean(wobs * correct) - mean(wobs * correct_baseline) @@ -585,5 +585,6 @@ get_nfeat_baseline <- function(object, baseline, stat, ...) { # which explains the proportional difference of 1/N est_list$hat_v_y <- (t_pi2_tilde + t_hat_epsilon) - # a (has been checked) (1 / N) * (t_e^2 - est_list$v_y_hat + 2 * t_pi_tilde * est_list$y_hat - t_pi_tilde^2) # b + est_list$y_hat_se <- sqrt(est_list$v_y_hat + est_list$hat_v_y) return(est_list) } From 52fd9c370d640f90e88aea0e52c3497dc34e1ac6 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 22:37:16 +0200 Subject: [PATCH 079/134] add an early error for `!validate_search && nloo < refmodel[["nobs"]]` --- R/cv_varsel.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 29aed46a8..43753321e 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -562,6 +562,10 @@ parse_args_cv_varsel <- function(refmodel, cv_method, nloo, K, cvfits, if (nloo < 1) { stop("nloo must be at least 1") } + if (!validate_search && nloo < refmodel[["nobs"]]) { + stop("Subsampled PSIS-LOO-CV is not supported for ", + "`validate_search = FALSE`.") + } } # Restrictions in case of previous search results which should be re-used: From 81ec4952e4c048a8422b4ddb7d8d087a6a18eac6 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 22:42:03 +0200 Subject: [PATCH 080/134] add a comment and a check in `loo_varsel()` for `!validate_search && nloo < refmodel[["nobs"]]` --- R/cv_varsel.R | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 43753321e..c32d938ca 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -749,6 +749,15 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, if (!validate_search) { ## Case `validate_search = FALSE` ----------------------------------------- + # NOTE: The case where `inds` is an actual subset of the set of all + # observation indices should never occur here in the + # `validate_search = FALSE` case. Thus, in principle, the code could be + # simplified here, but keeping `inds` in case this might be helpful in the + # future. + if (nloo < n) { + stop("`nloo < n` is unexpected if `validate_search = FALSE`") + } + # "Run" the performance evaluation for the submodels along the predictor # ranking (in fact, we only prepare the performance evaluation by computing # precursor quantities, but for users, this difference is not perceivable): From 348827c6dc5ffca9590b6006fa1234ab319d14ce Mon Sep 17 00:00:00 2001 From: fweber144 Date: Tue, 27 Aug 2024 00:20:51 +0200 Subject: [PATCH 081/134] Revert "avoid redundant computations by moving `sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y)` into `.srs_diff_est_w()`" This reverts commit 2727cff3b74df2af800cd37b4fa9a309bc96be89. Reason for the revert: See . --- R/summary_funs.R | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 3f0498ff1..d20a62be5 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -264,7 +264,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, y_idx = loo_inds) value <- srs_diffe$y_hat # combine estimates of var(y_hat) and var(y) - value_se <- srs_diffe$y_hat_se + value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) } else { # full LOO estimator value <- sum((lppd - lppd_baseline), na.rm = TRUE) @@ -301,7 +301,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, w = wobs) value <- srs_diffe$y_hat / n_full # combine estimates of var(y_hat) and var(y) - value_se <- srs_diffe$y_hat_se / n_full + value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n_full } # store for later calculations mse_e <- value @@ -453,7 +453,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, w = wobs) value <- srs_diffe$y_hat / n_full # combine estimates of var(y_hat) and var(y) - value_se <- srs_diffe$y_hat_se / n_full + value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n_full } else { # full LOO estimator value <- mean(wobs * correct) - mean(wobs * correct_baseline) @@ -585,6 +585,5 @@ get_nfeat_baseline <- function(object, baseline, stat, ...) { # which explains the proportional difference of 1/N est_list$hat_v_y <- (t_pi2_tilde + t_hat_epsilon) - # a (has been checked) (1 / N) * (t_e^2 - est_list$v_y_hat + 2 * t_pi_tilde * est_list$y_hat - t_pi_tilde^2) # b - est_list$y_hat_se <- sqrt(est_list$v_y_hat + est_list$hat_v_y) return(est_list) } From f4f97602e02c7438d7c7a8828cc8a6d3d68baef9 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Tue, 27 Aug 2024 01:01:47 +0200 Subject: [PATCH 082/134] simplify definitions of `mu_baseline` (possible because `NULL$mu` is `NULL` and `rep(NULL$mu, c(4, 5))` (for example) as well) --- R/summary_funs.R | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index d20a62be5..0132418b9 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -406,11 +406,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, rep(1L, y[i_short])) })) mu <- rep(mu, y_wobs_test$wobs) - if (!is.null(summaries_baseline)) { - mu_baseline <- rep(summaries_baseline$mu, y_wobs_test$wobs) - } else { - mu_baseline <- NULL - } + mu_baseline <- rep(summaries_baseline$mu, y_wobs_test$wobs) # CAUTION: If `y` is allowed to have `NA`s here, then the following # definition of `n_full` needs to be adapted: n_full <- sum(!is.na(mu)) @@ -418,11 +414,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, wobs <- n_full * wobs / sum(wobs) } else { stopifnot(all(y_wobs_test$wobs == 1)) - if (!is.null(summaries_baseline)) { - mu_baseline <- summaries_baseline$mu - } else { - mu_baseline <- NULL - } + mu_baseline <- summaries_baseline$mu } if (stat %in% c("acc", "pctcorr")) { # Find out whether each observation was classified correctly or not: From 519dac268d130a593713f75ed6f5370b25392be0 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Tue, 27 Aug 2024 01:20:23 +0200 Subject: [PATCH 083/134] fixup! `loo_inds` as stored in `vsel` objects was unused so far --- R/summary_funs.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 0132418b9..268b37b21 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -245,7 +245,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, lppd <- summaries$lppd n_full <- length(lppd) n_loo <- if (is.null(loo_inds)) n_full else length(loo_inds) - if (n_loo == 0) { + if (all(is.na(lppd)) || all(is.na(y_wobs_test$y_prop %||% y_wobs_test$y))) { return(list(value = NA, se = NA, lq = NA, uq = NA)) } alpha_half <- alpha / 2 @@ -267,7 +267,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) } else { # full LOO estimator - value <- sum((lppd - lppd_baseline), na.rm = TRUE) + value <- sum(lppd - lppd_baseline, na.rm = TRUE) value_se <-sd(lppd - lppd_baseline, na.rm = TRUE) * sqrt(n_full) } if (stat %in% c("mlpd", "gmpd")) { From a7458b98f8efbf255966c29769ac6fe08ce9253a Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 23 Aug 2024 06:57:24 +0200 Subject: [PATCH 084/134] move out the new "mixed deltas" variant of `plot.vsel()`, the new column behavior of `summary.vsel()`, and the omittance of option `"best"` of argument `baseline` --- R/methods.R | 157 +++++++++++++++++------------------------------ R/misc.R | 13 ++-- R/summary_funs.R | 56 ++++++++++------- 3 files changed, 101 insertions(+), 125 deletions(-) diff --git a/R/methods.R b/R/methods.R index 3cbd91eee..c67e777f1 100644 --- a/R/methods.R +++ b/R/methods.R @@ -668,11 +668,13 @@ proj_predict_aux <- function(proj, newdata, offsetnew, weightsnew, #' # Horizontal lines #' #' As long as the reference model's performance is computable, it is always -#' shown in the plot as a dashed red horizontal line. +#' shown in the plot as a dashed red horizontal line. If `baseline = "best"`, +#' the baseline model's performance is shown as a dotted black horizontal line. #' If `!is.na(thres_elpd)` and `any(stats %in% c("elpd", "mlpd", "gmpd"))`, the #' value supplied to `thres_elpd` (which is automatically adapted internally in #' case of the MLPD or the GMPD or `deltas = FALSE`) is shown as a dot-dashed -#' gray horizontal line for the reference model. +#' gray horizontal line for the reference model and, if `baseline = "best"`, as +#' a long-dashed green horizontal line for the baseline model. #' #' @examplesIf requireNamespace("rstanarm", quietly = TRUE) #' # Data: @@ -700,7 +702,7 @@ plot.vsel <- function( stats = "elpd", deltas = FALSE, alpha = 2 * pnorm(-1), - baseline = "ref", + baseline = if (!inherits(x$refmodel, "datafit")) "ref" else "best", thres_elpd = NA, resp_oscale = TRUE, point_size = 3, @@ -720,7 +722,7 @@ plot.vsel <- function( # Parse input: object <- x validate_vsel_object_stats(object, stats, resp_oscale = resp_oscale) - baseline <- validate_baseline(object$refmodel, baseline, deltas) + baseline <- validate_baseline(object, baseline, deltas) if (!is.null(ranking_repel) && !requireNamespace("ggrepel", quietly = TRUE)) { warning("Package 'ggrepel' is needed for a non-`NULL` argument ", "`ranking_repel`, but could not be found. Setting `ranking_repel` ", @@ -734,17 +736,12 @@ plot.vsel <- function( # .tabulate_stats()'s argument `nfeat_baseline`: nfeat_baseline <- get_nfeat_baseline(object, baseline, stats[1], resp_oscale = resp_oscale) - ## if (getOption("projpred.extra_verbose",FALSE) && - ## deltas && - ## !all(stats %in% c("elpd","mlpd","gmpd"))) { - ## message(paste0("With deltas=TRUE, statistics ", paste(stats[!(stats %in% c("elpd","mlpd","gmpd"))], collapse=", "), - ## " report the uncertainty relative to the baseline, but the value in the original scale.")) - ## } - if (is.character(deltas) || deltas) { + if (deltas) { nfeat_baseline_for_tab <- nfeat_baseline } else { nfeat_baseline_for_tab <- NULL } + # Compute the predictive performance statistics: stats_table_all <- .tabulate_stats(object, stats, alpha = alpha, nfeat_baseline = nfeat_baseline_for_tab, @@ -753,23 +750,6 @@ plot.vsel <- function( stats_sub <- subset(stats_table_all, stats_table_all$size != Inf) stats_bs <- subset(stats_table_all, stats_table_all$size == nfeat_baseline) - if (!is.character(deltas) && deltas) { - stats_ref[,'value'] <- 0 - stats_ref[stats_ref[,'statistic']=="gmpd",'value'] <- 1 - } else if (is.character(deltas) && identical(deltas,'mixed')) { - stats_ref[stats_ref[,'statistic'] %in% c("elpd","mlpd"),'value'] <- 0 - stats_ref[stats_ref[,'statistic']=="gmpd",'value'] <- 1 - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff'] <- - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff'] + - stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.lq'] <- - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.lq'] + - stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.uq'] <- - stats_sub[!(stats_sub[,'statistic'] %in% c("elpd","mlpd","gmpd")),'diff.uq'] + - stats_ref[!(stats_ref[,'statistic'] %in% c("elpd","mlpd","gmpd")),'value'] - } - # Catch unexpected output from .tabulate_stats(): if (NROW(stats_sub) == 0) { stop(ifelse(length(stats) > 1, "Statistics ", "Statistic "), @@ -797,11 +777,21 @@ plot.vsel <- function( nterms_max <- as.integer(nterms_max) # Define some "pretty" text strings for the plot: - ylab <- "Value" - if (is.character(deltas) || deltas) { - delta_lab <- "for baseline comparison" + if (baseline == "ref") { + baseline_pretty <- "reference model" + } else { + baseline_pretty <- "best submodel" + } + if (deltas) { + if (all(stats != "gmpd")) { + ylab <- paste0("Difference vs. ", baseline_pretty) + } else if (all(stats == "gmpd")) { + ylab <- paste0("Ratio vs. ", baseline_pretty) + } else { + ylab <- paste0("Difference (ratio for GMPD) vs. ", baseline_pretty) + } } else { - delta_lab <- "" + ylab <- "Value" } if (object$refmodel$family$for_latent) { if (resp_oscale) { @@ -972,39 +962,9 @@ plot.vsel <- function( } # Create the plot: - if (is.character(deltas) || deltas) { - data_gg$statistic[data_gg$statistic=="elpd"] <- "elpd_diff" - stats_ref$statistic[stats_ref$statistic=="elpd"] <- "elpd_diff" - data_gg$statistic[data_gg$statistic=="mlpd"] <- "mlpd_diff" - stats_ref$statistic[stats_ref$statistic=="mlpd"] <- "mlpd_diff" - data_gg$statistic[data_gg$statistic=="gmpd"] <- "gmpd_ratio" - stats_ref$statistic[stats_ref$statistic=="gmpd"] <- "gmpd_ratio" - if (!(is.character(deltas) && identical(deltas,'mixed'))) { - data_gg$statistic[data_gg$statistic=="mse"] <- "mse_diff" - stats_ref$statistic[stats_ref$statistic=="mse"] <- "mse_diff" - data_gg$statistic[data_gg$statistic=="rmse"] <- "rmse_diff" - stats_ref$statistic[stats_ref$statistic=="rmse"] <- "rmse_diff" - data_gg$statistic[data_gg$statistic=="rmse"] <- "rmse_diff" - stats_ref$statistic[stats_ref$statistic=="R2"] <- "R2_diff" - data_gg$statistic[data_gg$statistic=="R2"] <- "R2_diff" - stats_ref$statistic[stats_ref$statistic=="acc"] <- "acc_diff" - data_gg$statistic[data_gg$statistic=="acc"] <- "acc_diff" - stats_ref$statistic[stats_ref$statistic=="pctcorr"] <- "pctcorr_diff" - data_gg$statistic[data_gg$statistic=="pctcorr"] <- "pctcorr_diff" - stats_ref$statistic[stats_ref$statistic=="auc"] <- "auc_diff" - data_gg$statistic[data_gg$statistic=="auc"] <- "auc_diff" - } - } - - if (is.character(deltas) || deltas) { - pp <- ggplot(data = data_gg, - mapping = aes(x = .data[["size"]], y = .data[["diff"]], - ymin = .data[["diff.lq"]], ymax = .data[["diff.uq"]])) - } else { - pp <- ggplot(data = data_gg, - mapping = aes(x = .data[["size"]], y = .data[["value"]], - ymin = .data[["lq"]], ymax = .data[["uq"]])) - } + pp <- ggplot(data = data_gg, + mapping = aes(x = .data[["size"]], y = .data[["value"]], + ymin = .data[["lq"]], ymax = .data[["uq"]])) if (!all(is.na(stats_ref$se))) { # In this case, add the predictive performance of the reference model. pp <- pp + @@ -1021,9 +981,9 @@ plot.vsel <- function( thres_tab_ref$thres[is_elpd_mlpd_ref] <- thres_tab_ref$value[is_elpd_mlpd_ref] + thres_tab_ref$thres[is_elpd_mlpd_ref] - is_gmpd_ref <- thres_tab_ref$statistic %in% c("gmpd","gmpd ratio") + is_gmpd_ref <- thres_tab_ref$statistic %in% c("gmpd") thres_tab_ref$thres[is_gmpd_ref] <- - thres_tab_ref$value[is_gmpd_ref] * + thres_tab_ref$value[is_gmpd_ref] * thres_tab_ref$thres[is_gmpd_ref] pp <- pp + geom_hline(aes(yintercept = .data[["thres"]]), @@ -1107,7 +1067,9 @@ plot.vsel <- function( } if (all(stats %in% c("auc"))) { ci_type <- "bootstrap " - } else if (all(!stats %in% c("auc"))) { + } else if (all(stats %in% c("gmpd"))) { + ci_type <- "exponentiated normal-approximation " + } else if (all(!stats %in% c("auc", "gmpd"))) { ci_type <- "normal-approximation " } else { ci_type <- "" @@ -1142,11 +1104,9 @@ plot.vsel <- function( labels = tick_labs_x, sec.axis = x_axis_sec) + labs(x = xlab, y = ylab, title = "Predictive performance", - subtitle = paste0("With ", - round(100 * (1 - alpha), 1), "% ", - ci_type, - "intervals ", - delta_lab)) + + subtitle = paste0("Vertical bars indicate ", + round(100 * (1 - alpha), 1), "% ", ci_type, + "intervals")) + theme(axis.text.x.bottom = element_text(angle = text_angle, hjust = hjust_val, vjust = vjust_val)) + @@ -1240,18 +1200,17 @@ plot.vsel <- function( #' "relatively" refers to the ratio vs. the baseline model (i.e., the submodel #' statistic divided by the baseline model statistic). For all other `stats`, #' "relatively" refers to the difference from the baseline model (i.e., the -#' submodel statistic minus the baseline model statistic). For the ELPD and -#' the MLPD, the baseline performance is reported as 0. For the GMPD, -#' the baseline performance is reported as 1. For other statistics, the -#' baseline performance is reported as 0 if `deltas=TRUE` and in the original -#' scale if `deltas="mixed"`. If `deltas=TRUE` or `deltas="mixed"`, for all -#' statistics the related uncertainty is reported relative to the baseline. +#' submodel statistic minus the baseline model statistic). #' @param alpha A number determining the (nominal) coverage `1 - alpha` of the #' normal-approximation (or bootstrap or exponentiated normal-approximation; #' see argument `stats`) confidence intervals. For example, in case of the #' normal approximation, `alpha = 2 * pnorm(-1)` corresponds to a confidence #' interval stretching by one standard error on either side of the point #' estimate. +#' @param baseline For [summary.vsel()]: Only relevant if `deltas` is `TRUE`. +#' For [plot.vsel()]: Always relevant. Either `"ref"` or `"best"`, indicating +#' whether the baseline is the reference model or the best submodel found (in +#' terms of `stats[1]`), respectively. #' @param resp_oscale Only relevant for the latent projection. A single logical #' value indicating whether to calculate the performance statistics on the #' original response scale (`TRUE`) or on latent scale (`FALSE`). @@ -1318,14 +1277,14 @@ summary.vsel <- function( type = c("mean", "se", "diff", "diff.se"), deltas = FALSE, alpha = 2 * pnorm(-1), - baseline = "ref", + baseline = if (!inherits(object$refmodel, "datafit")) "ref" else "best", resp_oscale = TRUE, cumulate = FALSE, ... ) { validate_vsel_object_stats(object, stats, resp_oscale = resp_oscale) - baseline <- validate_baseline(object$refmodel, baseline, deltas) - + baseline <- validate_baseline(object, baseline, deltas) + # Initialize output: out <- c( object$refmodel[c("formula", "family")], @@ -1351,15 +1310,16 @@ summary.vsel <- function( } # The full table of the performance statistics from `stats`: - ## if (is.character(deltas) || deltas) { + if (deltas) { nfeat_baseline_for_tab <- get_nfeat_baseline(object, baseline, stats[1], resp_oscale = resp_oscale) - ## } else { - ## nfeat_baseline_for_tab <- NULL - ## } + } else { + nfeat_baseline_for_tab <- NULL + } stats_table_all <- .tabulate_stats(object, stats, alpha = alpha, nfeat_baseline = nfeat_baseline_for_tab, resp_oscale = resp_oscale, ...) + # Extract the reference model performance results from `stats_table_all`: stats_table_ref <- subset(stats_table_all, stats_table_all$size == Inf) @@ -1383,7 +1343,7 @@ summary.vsel <- function( # For renaming columns of the two output tables (one for the reference model # performance and for the submodel performance): colnms_ref <- mk_colnms_smmry(type = type, stats = stats, deltas = NULL) - colnms_sub <- mk_colnms_smmry(type = type, stats = stats, deltas = FALSE) + colnms_sub <- mk_colnms_smmry(type = type, stats = stats, deltas = deltas) # Fill the output table for the reference model performance (essentially, we # reshape `stats_table_ref`, thereby selecting only the requested `type`s and @@ -1428,7 +1388,7 @@ summary.vsel <- function( # reference model performance and one table for the submodel performance): mk_colnms_smmry <- function(type, stats, deltas) { # Pre-process `type`: - if (is.null(deltas) || (is.character(deltas) || deltas)) { + if (is.null(deltas) || deltas) { type <- setdiff(type, c("diff", "diff.se")) } type_dot <- paste0(".", type) @@ -1439,8 +1399,6 @@ mk_colnms_smmry <- function(type, stats, deltas) { nms_old[nms_old == "mean"] <- "value" nms_old[nms_old == "upper"] <- "uq" nms_old[nms_old == "lower"] <- "lq" - nms_old[nms_old == "diff.upper"] <- "diff.uq" - nms_old[nms_old == "diff.lower"] <- "diff.lq" # The clean column names that should be used in the output table: nms_new <- lapply(stats, paste0, type_dot) return(nlist(nms_old, nms_new)) @@ -1618,7 +1576,8 @@ print.vsel <- function(x, digits = getOption("projpred.digits", 2), ...) { #' falls above (or is equal to) \deqn{\texttt{pct} \cdot (u_0 - #' u_{\mathrm{base}})}{pct * (u_0 - u_base)} where \eqn{u_0} denotes the null #' model's estimated utility and \eqn{u_{\mathrm{base}}}{u_base} the baseline -#' model's estimated utility. +#' model's estimated utility. The baseline model is either the reference model +#' or the best submodel found (see argument `baseline` of [summary.vsel()]). #' #' In doing so, loss statistics like the root mean squared error (RMSE) and #' the mean squared error (MSE) are converted to utilities by multiplying them @@ -1721,10 +1680,9 @@ suggest_size.vsel <- function( if (length(stat) > 1) { stop("Only one statistic can be specified to suggest_size") } - stats <- summary.vsel(object, stats = stat, - type = c("diff", "diff.upper", "diff.lower"), + type = c("mean", "upper", "lower"), deltas = TRUE, ...) stats <- stats$perf_sub @@ -1739,9 +1697,9 @@ suggest_size.vsel <- function( type <- "upper" } } - bound <- paste0(stat, ".diff.", type) - stat.diff <- paste0(stat, ".", 'diff') - util_null <- sgn * unlist(unname(subset(stats, stats$size == 0, stat.diff))) + bound <- paste0(stat, ".", type) + + util_null <- sgn * unlist(unname(subset(stats, stats$size == 0, stat))) if (stat != "gmpd") { util_cutoff <- pct * util_null } else { @@ -1750,13 +1708,12 @@ suggest_size.vsel <- function( if (is.na(thres_elpd)) { thres_elpd <- Inf } - nobs_test <- object$nobs_test res <- stats[ (sgn * stats[, bound] >= util_cutoff) | - (stat == "elpd" & stats[, stat.diff] > thres_elpd) | - (stat == "mlpd" & stats[, stat.diff] > thres_elpd / nobs_test) | - (stat == "gmpd" & stats[, stat.diff] > exp(thres_elpd / nobs_test)), + (stat == "elpd" & stats[, stat] > thres_elpd) | + (stat == "mlpd" & stats[, stat] > thres_elpd / nobs_test) | + (stat == "gmpd" & stats[, stat] > exp(thres_elpd / nobs_test)), "size", drop = FALSE ] diff --git a/R/misc.R b/R/misc.R index 2fd3e1323..5632a764f 100644 --- a/R/misc.R +++ b/R/misc.R @@ -196,17 +196,22 @@ validate_vsel_object_stats <- function(object, stats, resp_oscale = TRUE) { return(invisible(TRUE)) } -validate_baseline <- function(refmodel, baseline, deltas) { +validate_baseline <- function(vsel_obj, baseline, deltas) { stopifnot(!is.null(baseline)) - if (!(baseline %in% c("ref"))) { - stop("Argument 'baseline' must be 'ref'.") + if (!(baseline %in% c("ref", "best"))) { + stop("Argument 'baseline' must be either 'ref' or 'best'.") } - if (baseline == "ref" && deltas == TRUE && inherits(refmodel, "datafit")) { + if (baseline == "ref" && deltas == TRUE && + inherits(vsel_obj$refmodel, "datafit")) { # no reference model (or the results missing for some other reason), # so cannot compute differences (or ratios) vs. the reference model stop("Cannot use deltas = TRUE and baseline = 'ref' when there is no ", "reference model.") } + if (baseline == "best" && vsel_obj$cv_method == "LOO" && + vsel_obj$nloo < vsel_obj$refmodel$nobs) { + stop("Cannot use `baseline = \"best\"` in case of subsampled LOO-CV.") + } return(baseline) } diff --git a/R/summary_funs.R b/R/summary_funs.R index 268b37b21..f4808e1d1 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -88,7 +88,7 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, # statistics relative to the baseline model of that size (`nfeat_baseline = Inf` # means that the baseline model is the reference model). .tabulate_stats <- function(varsel, stats, alpha = 0.05, - nfeat_baseline = Inf, resp_oscale = TRUE, ...) { + nfeat_baseline = NULL, resp_oscale = TRUE, ...) { stat_tab <- data.frame() summaries_ref <- varsel$summaries$ref summaries_sub <- varsel$summaries$sub @@ -177,46 +177,57 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, } ## fetch the mu and lppd for the baseline model - summaries_baseline <- summaries_ref - delta <- !is.null(summaries_ref) + if (is.null(nfeat_baseline)) { + ## no baseline model, i.e, compute the statistics on the actual + ## (non-relative) scale + summaries_baseline <- NULL + delta <- FALSE + } else { + if (nfeat_baseline == Inf) { + summaries_baseline <- summaries_ref + } else { + summaries_baseline <- summaries_sub[[nfeat_baseline + 1]] + } + delta <- TRUE + } for (s in seq_along(stats)) { stat <- stats[s] ## reference model statistics - summaries <- summaries_ref res <- get_stat(summaries = summaries_ref, - summaries_baseline = NULL, + summaries_baseline = summaries_baseline, summaries_fast = NULL, loo_inds = varsel$loo_inds, varsel$y_wobs_test, stat, alpha = alpha, ...) row <- data.frame( data = varsel$type_test, size = Inf, delta = delta, statistic = stat, - value = res$value, lq = res$lq, uq = res$uq, se = res$se, - diff = NA, diff.lq = NA, diff.uq = NA, diff.se = NA + value = res$value, lq = res$lq, uq = res$uq, se = res$se, diff = NA, + diff.se = NA ) stat_tab <- rbind(stat_tab, row) ## submodel statistics for (k in seq_along(summaries_sub)) { - diff <- get_stat(summaries = summaries_sub[[k]], - summaries_baseline = summaries_baseline, - summaries_fast = summaries_fast_sub[[k]], - loo_inds = varsel$loo_inds, - varsel$y_wobs_test, stat, alpha = alpha, ...) res <- get_stat(summaries = summaries_sub[[k]], - summaries_baseline = NULL, + summaries_baseline = summaries_baseline, summaries_fast = summaries_fast_sub[[k]], loo_inds = varsel$loo_inds, varsel$y_wobs_test, stat, alpha = alpha, ...) + diff <- get_stat(summaries = summaries_sub[[k]], + summaries_baseline = summaries_ref, + summaries_fast = summaries_fast_sub[[k]], + loo_inds = varsel$loo_inds, + varsel$y_wobs_test, stat, alpha = alpha, ...) row <- data.frame( - data = varsel$type_test, size = k - 1, delta = delta, - statistic = stat, value = res$value, lq = res$lq, uq = res$uq, se = res$se, - diff = diff$value, diff.lq = diff$lq, diff.uq = diff$uq, diff.se = diff$se + data = varsel$type_test, size = k - 1, delta = delta, statistic = stat, + value = res$value, lq = res$lq, uq = res$uq, se = res$se, + diff = diff$value, diff.se = diff$se ) stat_tab <- rbind(stat_tab, row) } } + return(stat_tab) } @@ -232,9 +243,13 @@ check_sub_NA <- function(summaries_sub_k, el_nm) { all(is.na(summaries_sub_k[[el_nm]])) } -## The actual observation weights (specified by the -## user) are contained in `y_wobs_test$wobs`. These are already taken into -## account by `$family$ll_fun()` (or +## Calculates given statistic stat with standard error and confidence bounds. +## `summaries_baseline` contains the pointwise mu and lppd for another model +## that is used as a baseline for computing the difference (ratio in case of the +## GMPD) in the given statistic. If these arguments are not given (NULL) then +## the actual (non-relative) value is computed. The actual observation weights +## (specified by the user) are contained in `y_wobs_test$wobs`. These are +## already taken into account by `$family$ll_fun()` (or ## `$family$latent_ll_oscale()`) and are thus already taken ## into account in `lppd`. However, `mu` does not take them into account, so ## some further adjustments are necessary below. @@ -474,8 +489,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, value_se <- sd(diffvalue.bootstrap, na.rm = TRUE) lq_uq <- quantile(diffvalue.bootstrap, probs = c(alpha_half, one_minus_alpha_half), - names = FALSE, na.rm = TRUE) + - .auc(auc_data_baseline) + names = FALSE, na.rm = TRUE) } else { auc_data <- cbind(y, mu, wobs) value <- .auc(auc_data) From 43878e1dbf1ef21444bc8a34fcdc2b9d87d56c47 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Thu, 29 Aug 2024 23:43:26 +0200 Subject: [PATCH 085/134] use a consistent order of the `if` cases differentiating between subsampled LOO (`n_loo < n_full`) and everything else (`n_loo == n_full`) --- R/summary_funs.R | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index f4808e1d1..bae172f74 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -304,11 +304,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, mu_baseline <- summaries_baseline$mu } # Use normal approximation for mse and delta method for rmse and R2 - if (n_loo == n_full) { - # full LOO estimator - value <- mean(wobs * (mu - y)^2) - value_se <- .weighted_sd((mu - y)^2, wobs) / sqrt(n_full) - } else { + if (n_loo < n_full) { # subsampling difference estimator (Magnusson et al., 2020) srs_diffe <- .srs_diff_est_w(y_approx = (summaries_fast$mu - y)^2, y = ((mu - y)^2)[loo_inds], @@ -317,6 +313,10 @@ get_stat <- function(summaries, summaries_baseline = NULL, value <- srs_diffe$y_hat / n_full # combine estimates of var(y_hat) and var(y) value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n_full + } else { + # full LOO estimator + value <- mean(wobs * (mu - y)^2) + value_se <- .weighted_sd((mu - y)^2, wobs) / sqrt(n_full) } # store for later calculations mse_e <- value @@ -325,10 +325,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, # delta=TRUE, variance of difference of two normally distributed mse_b <- mean(wobs * (mu_baseline - y)^2) var_mse_b <- .weighted_sd((mu_baseline - y)^2, wobs)^2 / n_full - if (n_loo == n_full) { - cov_mse_e_b <- mean(wobs * ((mu - y)^2 - mse_e) * - ((mu_baseline - y)^2 - mse_b)) / n_full - } else { + if (n_loo < n_full) { mse_e_fast <- mean(wobs * (summaries_fast$mu - y)^2) srs_diffe <- .srs_diff_est_w(y_approx = ((summaries_fast$mu - y)^2 - mse_e_fast) * @@ -338,6 +335,9 @@ get_stat <- function(summaries, summaries_baseline = NULL, y_idx = loo_inds, w = wobs) cov_mse_e_b <- srs_diffe$y_hat / n_full^2 + } else { + cov_mse_e_b <- mean(wobs * ((mu - y)^2 - mse_e) * + ((mu_baseline - y)^2 - mse_b)) / n_full } value_se <- sqrt(value_se^2 - 2 * cov_mse_e_b + var_mse_b) } @@ -354,16 +354,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, value <- 1 - mse_e / mse_y - ifelse(is.null(summaries_baseline), 0, 1 - mse_b / mse_y) # the first-order Taylor approximation of the variance var_mse_y <- .weighted_sd((mean(y) - y)^2, wobs)^2 / n_full - if (n_loo == n_full) { - if (is.null(summaries_baseline)) { - cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e) * - ((mean(y) - y)^2 - mse_y)) / n_full - } else { - cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e - - ((mu_baseline - y)^2 - mse_b)) * - ((mean(y) - y)^2 - mse_y)) / n_full - } - } else { + if (n_loo < n_full) { mse_e_fast <- mean(wobs * (summaries_fast$mu - y)^2) if (is.null(summaries_baseline)) { srs_diffe <- @@ -385,6 +376,15 @@ get_stat <- function(summaries, summaries_baseline = NULL, w = wobs) } cov_mse_e_y <- srs_diffe$y_hat / n_full^2 + } else { + if (is.null(summaries_baseline)) { + cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e) * + ((mean(y) - y)^2 - mse_y)) / n_full + } else { + cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e - + ((mu_baseline - y)^2 - mse_b)) * + ((mean(y) - y)^2 - mse_y)) / n_full + } } # part of delta se comes automatically via mse var_mse_e <- value_se^2 From 925f2cd43ec5b1d5101306142853e469f6f1c465 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Thu, 29 Aug 2024 23:52:34 +0200 Subject: [PATCH 086/134] remove unused `var_mse_e` definition --- R/summary_funs.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index bae172f74..43be07ee6 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -320,7 +320,6 @@ get_stat <- function(summaries, summaries_baseline = NULL, } # store for later calculations mse_e <- value - var_mse_e <- value_se^2 if (!is.null(summaries_baseline)) { # delta=TRUE, variance of difference of two normally distributed mse_b <- mean(wobs * (mu_baseline - y)^2) From 040d05e55c1d2f703d37fe4c59de2ff0597d9f91 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Thu, 29 Aug 2024 23:55:39 +0200 Subject: [PATCH 087/134] there was only one use of `var_mse_e` and since `value_se` does not change from definition of `var_mse_e` to use of `var_mse_e`, the extra definition of `var_mse_e` can be avoided --- R/summary_funs.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 43be07ee6..67ca6fec1 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -386,12 +386,11 @@ get_stat <- function(summaries, summaries_baseline = NULL, } } # part of delta se comes automatically via mse - var_mse_e <- value_se^2 if (!is.null(summaries_baseline)) { # delta=TRUE mse_e <- mse_e - mse_b } - value_se <- sqrt((var_mse_e - + value_se <- sqrt((value_se^2 - 2 * mse_e / mse_y * cov_mse_e_y + (mse_e / mse_y)^2 * var_mse_y) / mse_y^2) } From 0d73c8ea69724e29b7d183bb973b1f53fc1eeac6 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 30 Aug 2024 00:07:48 +0200 Subject: [PATCH 088/134] remove unused `mu_baseline` (only unused in case of `is.null(summaries_baseline)`); one reason is that I'm not sure whether it was supposed to read `mu_baseline <- y` in that case (instead of `mu_baseline <- 0`) --- R/summary_funs.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 67ca6fec1..81831b73f 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -298,9 +298,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, y <- y_wobs_test$y_prop %||% y_wobs_test$y wobs <- y_wobs_test$wobs wobs <- n_full * wobs / sum(wobs) - if (is.null(summaries_baseline)) { - mu_baseline <- 0 - } else { + if (!is.null(summaries_baseline)) { mu_baseline <- summaries_baseline$mu } # Use normal approximation for mse and delta method for rmse and R2 From 6a85b413f8cfc80c4b4d15f31436cbefb5ee6624 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 18 Sep 2024 21:30:25 +0200 Subject: [PATCH 089/134] re-document --- man/cv_varsel.Rd | 29 ++++++++++++++--------------- man/plot.vsel.Rd | 16 ++++++++-------- man/summary.vsel.Rd | 16 ++++++++-------- man/varsel.Rd | 2 +- 4 files changed, 31 insertions(+), 32 deletions(-) diff --git a/man/cv_varsel.Rd b/man/cv_varsel.Rd index cb01e1974..76256c395 100644 --- a/man/cv_varsel.Rd +++ b/man/cv_varsel.Rd @@ -32,7 +32,7 @@ cv_varsel(object, ...) refit_prj = !inherits(object, "datafit"), nterms_max = NULL, penalty = NULL, - verbose = TRUE, + verbose = getOption("projpred.verbose", interactive()), nloo = object$nobs, K = if (!inherits(object, "datafit")) 5 else 10, cvfits = object$cvfits, @@ -44,6 +44,7 @@ cv_varsel(object, ...) seed = NA, search_terms = NULL, search_out = NULL, + summaries_fast = NULL, parallel = getOption("projpred.prll_cv", FALSE), ... ) @@ -67,12 +68,13 @@ is performed, which avoids refitting the reference model \code{nloo} times (in contrast to a standard LOO-CV). In the \code{"kfold"} case, a \eqn{K}-fold-CV is performed. See also section "Note" below.} -\item{nloo}{\strong{Caution:} Still experimental. Only relevant if \code{cv_method = "LOO"}. If \code{nloo} is smaller than the number of all observations, -approximate full LOO-CV using probability-proportional-to-size-sampling -(PPS) to make accurate computation only for \code{nloo} (anything from 1 to the -number of all observations) leave-one-out folds (Magnusson et al., 2019). -Smaller values lead to faster computation but higher uncertainty in the -evaluation part. If \code{NULL}, all observations are used (as by default).} +\item{nloo}{Only relevant if \code{cv_method = "LOO"} and \code{validate_search = TRUE}. If \code{nloo > 0} is smaller than the number of all observations, full +LOO-CV is approximated by combining the fast LOO result for the selected +models and \code{nloo} leave-one-out searches using the difference estimator +with simple random sampling (SRS) without replacement (WOR) (Magnusson et +al., 2020). Smaller values lead to faster computation, but higher +uncertainty in the evaluation part. If \code{NULL}, all observations are used +(as by default).} \item{K}{Only relevant if \code{cv_method = "kfold"} and if \code{cvfits} is \code{NULL} (which is the case for reference model objects created by @@ -85,14 +87,11 @@ folds in \eqn{K}-fold-CV.} \item{validate_search}{A single logical value indicating whether to cross-validate also the search part, i.e., whether to run the search -separately for each CV-fold (\code{TRUE}) or not (\code{FALSE}). We strongly do not -recommend setting this to \code{FALSE}, because this is known to bias the -predictive performance estimates of the selected submodels. However, -setting this to \code{FALSE} can sometimes be useful because comparing the -results to the case where this argument is \code{TRUE} gives an idea of how -strongly the search is (over-)fitted to the data (the difference -corresponds to the search degrees of freedom or the effective number of -parameters introduced by the search).} +separately for each CV-fold (\code{TRUE}) or not (\code{FALSE}). With \code{FALSE} +the computation is faster, but the predictive performance estimates +of the selected submodels are optimistically biased. However, these fast +biased estimated can be useful to obtain initial information on the +usefulness of projection predictive variable selection.} \item{method}{The method for the search part. Possible options are \code{"forward"} for forward search and \code{"L1"} for L1 search. See also section diff --git a/man/plot.vsel.Rd b/man/plot.vsel.Rd index e2b74fa6f..3ee685bdc 100644 --- a/man/plot.vsel.Rd +++ b/man/plot.vsel.Rd @@ -46,23 +46,23 @@ are again all observations because the test set is the same as the training set). Available statistics are: \itemize{ \item \code{"elpd"}: expected log (pointwise) predictive density (for a new -dataset). Estimated by the sum of the observation-specific log predictive -density values (with each of these predictive density values being -a---possibly weighted---average across the parameter draws). -\item \code{"mlpd"}: mean log predictive density, that is, \code{"elpd"} divided by the -number of observations. +dataset) (ELPD). Estimated by the sum of the observation-specific log +predictive density values (with each of these predictive density values +being a---possibly weighted---average across the parameter draws). +\item \code{"mlpd"}: mean log predictive density (MLPD), that is, the ELPD divided +by the number of observations. \item \code{"gmpd"}: geometric mean predictive density (GMPD), that is, \code{\link[=exp]{exp()}} of -\code{"mlpd"}. The GMPD is especially helpful for discrete response families +the MLPD. The GMPD is especially helpful for discrete response families (because there, the GMPD is bounded by zero and one). For the corresponding standard error, the delta method is used. The corresponding confidence interval type is "exponentiated normal approximation" because the confidence interval bounds are the exponentiated confidence interval bounds -of the \code{"mlpd"}. +of the MLPD. \item \code{"mse"}: mean squared error (only available in the situations mentioned in section "Details" below). \item \code{"rmse"}: root mean squared error (only available in the situations mentioned in section "Details" below). For the corresponding standard error -and lower and upper confidence interval bounds, bootstrapping is used. +and lower and upper confidence interval bounds, the delta method is used. \item \code{"acc"} (or its alias, \code{"pctcorr"}): classification accuracy (only available in the situations mentioned in section "Details" below). By "classification accuracy", we mean the proportion of correctly classified diff --git a/man/summary.vsel.Rd b/man/summary.vsel.Rd index 0f6b666f3..5aaa8191a 100644 --- a/man/summary.vsel.Rd +++ b/man/summary.vsel.Rd @@ -36,23 +36,23 @@ are again all observations because the test set is the same as the training set). Available statistics are: \itemize{ \item \code{"elpd"}: expected log (pointwise) predictive density (for a new -dataset). Estimated by the sum of the observation-specific log predictive -density values (with each of these predictive density values being -a---possibly weighted---average across the parameter draws). -\item \code{"mlpd"}: mean log predictive density, that is, \code{"elpd"} divided by the -number of observations. +dataset) (ELPD). Estimated by the sum of the observation-specific log +predictive density values (with each of these predictive density values +being a---possibly weighted---average across the parameter draws). +\item \code{"mlpd"}: mean log predictive density (MLPD), that is, the ELPD divided +by the number of observations. \item \code{"gmpd"}: geometric mean predictive density (GMPD), that is, \code{\link[=exp]{exp()}} of -\code{"mlpd"}. The GMPD is especially helpful for discrete response families +the MLPD. The GMPD is especially helpful for discrete response families (because there, the GMPD is bounded by zero and one). For the corresponding standard error, the delta method is used. The corresponding confidence interval type is "exponentiated normal approximation" because the confidence interval bounds are the exponentiated confidence interval bounds -of the \code{"mlpd"}. +of the MLPD. \item \code{"mse"}: mean squared error (only available in the situations mentioned in section "Details" below). \item \code{"rmse"}: root mean squared error (only available in the situations mentioned in section "Details" below). For the corresponding standard error -and lower and upper confidence interval bounds, bootstrapping is used. +and lower and upper confidence interval bounds, the delta method is used. \item \code{"acc"} (or its alias, \code{"pctcorr"}): classification accuracy (only available in the situations mentioned in section "Details" below). By "classification accuracy", we mean the proportion of correctly classified diff --git a/man/varsel.Rd b/man/varsel.Rd index b9ade6fbb..f0cc84937 100644 --- a/man/varsel.Rd +++ b/man/varsel.Rd @@ -23,7 +23,7 @@ varsel(object, ...) nclusters_pred = NULL, refit_prj = !inherits(object, "datafit"), nterms_max = NULL, - verbose = TRUE, + verbose = getOption("projpred.verbose", interactive()), search_control = NULL, lambda_min_ratio = 1e-05, nlambda = 150, From ef33da67a80d833b38e4459512775632cdf39125 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 18 Sep 2024 21:32:45 +0200 Subject: [PATCH 090/134] add a placeholder for the documentation of argument `summaries_fast` of `cv_varsel()` --- R/cv_varsel.R | 1 + man/cv_varsel.Rd | 2 ++ 2 files changed, 3 insertions(+) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index c32d938ca..077278cb5 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -42,6 +42,7 @@ #' of the selected submodels are optimistically biased. However, these fast #' biased estimated can be useful to obtain initial information on the #' usefulness of projection predictive variable selection. +#' @param summaries_fast **TODO** #' @param seed Pseudorandom number generation (PRNG) seed by which the same #' results can be obtained again if needed. Passed to argument `seed` of #' [set.seed()], but can also be `NA` to not call [set.seed()] at all. If not diff --git a/man/cv_varsel.Rd b/man/cv_varsel.Rd index 76256c395..bf38f7c86 100644 --- a/man/cv_varsel.Rd +++ b/man/cv_varsel.Rd @@ -196,6 +196,8 @@ formula.} \item{search_out}{Intended for internal use.} +\item{summaries_fast}{\strong{TODO}} + \item{parallel}{A single logical value indicating whether to run costly parts of the CV in parallel (\code{TRUE}) or not (\code{FALSE}). See also section "Note" below.} From cdaf384611ee0d8ca97d57a23f474632843c05de Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 18 Sep 2024 21:34:38 +0200 Subject: [PATCH 091/134] avoid partial argument matching of 'w' to 'wobs' in `.srs_diff_est_w()` calls --- R/summary_funs.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 81831b73f..da86b39d3 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -307,7 +307,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, srs_diffe <- .srs_diff_est_w(y_approx = (summaries_fast$mu - y)^2, y = ((mu - y)^2)[loo_inds], y_idx = loo_inds, - w = wobs) + wobs = wobs) value <- srs_diffe$y_hat / n_full # combine estimates of var(y_hat) and var(y) value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n_full @@ -330,7 +330,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, y = (((mu - y)^2 - mse_e) * ((mu_baseline - y)^2 - mse_b))[loo_inds], y_idx = loo_inds, - w = wobs) + wobs = wobs) cov_mse_e_b <- srs_diffe$y_hat / n_full^2 } else { cov_mse_e_b <- mean(wobs * ((mu - y)^2 - mse_e) * @@ -360,7 +360,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, y = (((mu - y)^2 - mse_e) * ((mean(y) - y)^2 - mse_y))[loo_inds], y_idx = loo_inds, - w = wobs) + wobs = wobs) } else { srs_diffe <- .srs_diff_est_w(y_approx = ((summaries_fast$mu - y)^2 - mse_e_fast - @@ -370,7 +370,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, ((mu_baseline - y)^2 - mse_b)) * ((mean(y) - y)^2 - mse_y))[loo_inds], y_idx = loo_inds, - w = wobs) + wobs = wobs) } cov_mse_e_y <- srs_diffe$y_hat / n_full^2 } else { @@ -453,7 +453,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, srs_diffe <- .srs_diff_est_w(y_approx = correct_fast - correct_baseline, y = (correct-correct_baseline)[loo_inds], y_idx = loo_inds, - w = wobs) + wobs = wobs) value <- srs_diffe$y_hat / n_full # combine estimates of var(y_hat) and var(y) value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) / n_full From 8aacd5df89653a32a0a29dd85cb367ef26a2edcc Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 18 Sep 2024 21:45:27 +0200 Subject: [PATCH 092/134] fixup! remove unused `mu_baseline` (only unused in case of This fixes commit 0d73c8ea69724e29b7d183bb973b1f53fc1eeac6. However, before commit 0d73c8ea69724e29b7d183bb973b1f53fc1eeac6, `is.null(mu_baseline)` should have never occurred because if `summaries_baseline` was `NULL`, then `mu_baseline` was set to `0` (and if `summaries_baseline` was not `NULL`, then `mu_baseline` was set to `summaries_baseline$mu` which should not be `NULL` either). Hence, this fixup here does not only fix commit 0d73c8ea69724e29b7d183bb973b1f53fc1eeac6, but also the incorrect behavior which existed before it. --- R/summary_funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index da86b39d3..18622ae73 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -498,7 +498,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, } } - if (stat %in% c("mse","rmse") && is.null(mu_baseline)) { + if (stat %in% c("mse","rmse") && is.null(summaries_baseline)) { # Compute mean and variance in log scale by matching the variance of a # log-normal approximation # https://en.wikipedia.org/wiki/Log-normal_distribution#Arithmetic_moments From 1127412d37e3165a0d3e49b2aa7750fcaca9a980 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 25 Sep 2024 22:32:01 +0200 Subject: [PATCH 093/134] `vsel_obj$nloo` can be `NULL` (for `vsel_obj` created by `varsel()`), so fix `validate_baseline()`'s check --- R/misc.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/misc.R b/R/misc.R index 5632a764f..2b31d5d0c 100644 --- a/R/misc.R +++ b/R/misc.R @@ -209,7 +209,7 @@ validate_baseline <- function(vsel_obj, baseline, deltas) { "reference model.") } if (baseline == "best" && vsel_obj$cv_method == "LOO" && - vsel_obj$nloo < vsel_obj$refmodel$nobs) { + isTRUE(vsel_obj$nloo < vsel_obj$refmodel$nobs)) { stop("Cannot use `baseline = \"best\"` in case of subsampled LOO-CV.") } return(baseline) From c331cb4ddbea2b195227f5ec8441a959f6550eca Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 25 Sep 2024 22:39:05 +0200 Subject: [PATCH 094/134] fix the `get_stat()` call for the reference model statistics (`loo_inds` always needs to match `summaries_fast`) --- R/summary_funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 18622ae73..867af5878 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -198,7 +198,7 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, res <- get_stat(summaries = summaries_ref, summaries_baseline = summaries_baseline, summaries_fast = NULL, - loo_inds = varsel$loo_inds, + loo_inds = NULL, varsel$y_wobs_test, stat, alpha = alpha, ...) row <- data.frame( data = varsel$type_test, size = Inf, delta = delta, statistic = stat, From 8389d392ae436e39980fa200eaf2c0216580891e Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 25 Sep 2024 22:46:50 +0200 Subject: [PATCH 095/134] Tests: Subsampled PSIS-LOO-CV is not supported for `validate_search = FALSE`. --- tests/testthat/test_varsel.R | 80 ------------------------------------ 1 file changed, 80 deletions(-) diff --git a/tests/testthat/test_varsel.R b/tests/testthat/test_varsel.R index b0f06cc77..a4c580683 100644 --- a/tests/testthat/test_varsel.R +++ b/tests/testthat/test_varsel.R @@ -2651,41 +2651,12 @@ test_that("cv_varsel.vsel(): `nloo` works for `vsel` objects from varsel()", { } # Use suppressWarnings() because test_that() somehow redirects stderr() and # so throws warnings that projpred wants to capture internally: - cvvs_eval_valF <- suppressWarnings(cv_varsel( - vss[[tstsetup]], nloo = nloo_tst, validate_search = FALSE, - refit_prj = refit_prj_crr, nclusters_pred = nclusters_pred_crr, - verbose = FALSE, seed = seed2_tst - )) cvvs_eval_valT <- suppressWarnings(cv_varsel( vss[[tstsetup]], nloo = nloo_tst, nclusters_pred = nclusters_pred_crr, verbose = FALSE, seed = seed2_tst )) tstsetup_ref <- args_vs[[tstsetup]]$tstsetup_ref meth_exp_crr <- args_vs[[tstsetup]]$method %||% "forward" - vsel_tester( - cvvs_eval_valF, - with_cv = TRUE, - refmod_expected = refmods[[tstsetup_ref]], - prd_trms_len_expected = args_vs[[tstsetup]]$nterms_max, - method_expected = meth_exp_crr, - cv_method_expected = "LOO", - nloo_expected = nloo_tst, - valsearch_expected = FALSE, - refit_prj_expected = refit_prj_crr, - nprjdraws_eval_expected = if (!refit_prj_crr && meth_exp_crr == "L1") { - 1L - } else if (!refit_prj_crr) { - nclusters_tst - } else { - nclusters_pred_crr - }, - search_terms_expected = args_vs[[tstsetup]]$search_terms, - search_trms_empty_size = - length(args_vs[[tstsetup]]$search_terms) && - all(grepl("\\+", args_vs[[tstsetup]]$search_terms)), - search_control_expected = args_vs[[tstsetup]][c("avoid.increase")], - info_str = tstsetup - ) vsel_tester( cvvs_eval_valT, with_cv = TRUE, @@ -2730,68 +2701,17 @@ test_that(paste( # Use suppressWarnings() because test_that() somehow redirects stderr() and # so throws warnings that projpred wants to capture internally: if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { - cvvs_eval_valF <- suppressWarnings(cv_varsel( - cvvss[[tstsetup]], cv_method = "LOO", validate_search = FALSE, - nloo = nloo_tst, refit_prj = FALSE, verbose = FALSE, seed = seed2_tst - )) cvvs_eval_valT <- suppressWarnings(cv_varsel( cvvss[[tstsetup]], cv_method = "LOO", validate_search = TRUE, nloo = nloo_tst, refit_prj = FALSE, verbose = FALSE, seed = seed2_tst )) } else { - cvvs_eval_valF <- suppressWarnings(cv_varsel( - cvvss[[tstsetup]], nloo = nloo_tst, validate_search = FALSE, - refit_prj = FALSE, verbose = FALSE, seed = seed2_tst - )) cvvs_eval_valT <- suppressWarnings(cv_varsel( cvvss[[tstsetup]], nloo = nloo_tst, validate_search = TRUE, refit_prj = FALSE, verbose = FALSE, seed = seed2_tst )) } meth_exp_crr <- args_cvvs[[tstsetup]]$method %||% "forward" - extra_tol_crr <- 1.1 - if (meth_exp_crr == "L1" && - any(grepl(":", ranking(cvvs_eval_valF)[["fulldata"]]))) { - ### Testing for non-increasing element `ce` (for increasing model size) - ### doesn't make sense if the ranking of predictors involved in - ### interactions has been changed, so we choose a higher `extra_tol`: - extra_tol_crr <- 1.2 - ### - } - vsel_tester( - cvvs_eval_valF, - with_cv = TRUE, - refmod_expected = refmods[[args_cvvs[[tstsetup]]$tstsetup_ref]], - cvfits_expected = if (identical(args_cvvs[[tstsetup]]$cv_method, - "kfold")) { - cvfitss[[args_cvvs[[tstsetup]]$tstsetup_ref]] - } else { - refmods[[args_cvvs[[tstsetup]]$tstsetup_ref]]$cvfits - }, - prd_trms_len_expected = args_cvvs[[tstsetup]]$nterms_max, - method_expected = meth_exp_crr, - cv_method_expected = "LOO", - nloo_expected = nloo_tst, - valsearch_expected = FALSE, - refit_prj_expected = FALSE, - nprjdraws_eval_expected = if (meth_exp_crr == "L1") { - 1L - } else { - nclusters_tst - }, - K_expected = if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { - K_tst - } else { - NULL - }, - search_terms_expected = args_cvvs[[tstsetup]]$search_terms, - search_trms_empty_size = - length(args_cvvs[[tstsetup]]$search_terms) && - all(grepl("\\+", args_cvvs[[tstsetup]]$search_terms)), - search_control_expected = args_cvvs[[tstsetup]][c("avoid.increase")], - extra_tol = extra_tol_crr, - info_str = tstsetup - ) vsel_tester( cvvs_eval_valT, with_cv = TRUE, From a246dd39baab9bcf3a9ed1e2c6e490e7bbba2455 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Thu, 26 Sep 2024 22:19:30 +0200 Subject: [PATCH 096/134] fix the `stat %in% c("acc", "pctcorr", "auc")` case in `get_stat()` (`mu_fast`, `loo_inds`, and `n_loo` were not properly updated when de-aggregating the aggregated dataset) --- R/summary_funs.R | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 867af5878..d8da6676e 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -418,14 +418,30 @@ get_stat <- function(summaries, summaries_baseline = NULL, })) mu <- rep(mu, y_wobs_test$wobs) mu_baseline <- rep(summaries_baseline$mu, y_wobs_test$wobs) + mu_fast <- rep(summaries_fast$mu, y_wobs_test$wobs) # CAUTION: If `y` is allowed to have `NA`s here, then the following # definition of `n_full` needs to be adapted: n_full <- sum(!is.na(mu)) + if (!is.null(loo_inds)) { + stopifnot(all(y_wobs_test$wobs > 0)) + loo_inds <- unlist(lapply(loo_inds, function(loo_idx) { + cumsum_wobs <- cumsum(y_wobs_test$wobs) + if (loo_idx == 1) { + lower_idx_new <- 1L + } else { + lower_idx_new <- cumsum_wobs[loo_idx - 1L] + 1L + } + upper_idx_new <- cumsum_wobs[loo_idx] + return(lower_idx_new:upper_idx_new) + })) + } + n_loo <- if (is.null(loo_inds)) n_full else length(loo_inds) wobs <- rep(wobs, y_wobs_test$wobs) wobs <- n_full * wobs / sum(wobs) } else { stopifnot(all(y_wobs_test$wobs == 1)) mu_baseline <- summaries_baseline$mu + mu_fast <- summaries_fast$mu } if (stat %in% c("acc", "pctcorr")) { # Find out whether each observation was classified correctly or not: @@ -445,13 +461,12 @@ get_stat <- function(summaries, summaries_baseline = NULL, if (n_loo < n_full) { # subsampling difference estimator (Magnusson et al., 2020) - mu_fast <- summaries_fast$mu if (!is.factor(mu_fast)) { mu_fast <- round(mu_fast) } correct_fast <- mu_fast == y srs_diffe <- .srs_diff_est_w(y_approx = correct_fast - correct_baseline, - y = (correct-correct_baseline)[loo_inds], + y = (correct - correct_baseline)[loo_inds], y_idx = loo_inds, wobs = wobs) value <- srs_diffe$y_hat / n_full @@ -465,7 +480,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, } else if (stat == "auc") { if (n_loo < n_full) { # subsampling LOO with AUC not implemented. Using fast LOO result. - mu <- summaries_fast$mu + mu <- mu_fast } if (!is.null(mu_baseline)) { auc_data <- cbind(y, mu, wobs) From 2360630845e8a6c165b56e7c8f09204c25eb3572 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Thu, 26 Sep 2024 22:42:47 +0200 Subject: [PATCH 097/134] fix `.tabulate_stats()` (`catmaxprb()` also needs to be applied to the subsampled LOO results) --- R/summary_funs.R | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/R/summary_funs.R b/R/summary_funs.R index d8da6676e..5075f3c0c 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -162,6 +162,13 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, lvls = varsel$refmodel$family$cats) return(summaries_sub_k) }) + if (!is.null(summaries_fast_sub)) { + summaries_fast_sub <- lapply(summaries_fast_sub, function(summaries_fast_sub_k) { + summaries_fast_sub_k$mu <- catmaxprb(summaries_fast_sub_k$mu, + lvls = varsel$refmodel$family$cats) + return(summaries_fast_sub_k) + }) + } # Since `mu` is an unordered factor, `y` needs to be unordered, too (or both # would need to be ordered; however, unordered is the simpler type): varsel$y_wobs_test$y <- factor(varsel$y_wobs_test$y, ordered = FALSE) From 7469aeace5f9795d4c2f6ff608913e807c70a8f0 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Thu, 26 Sep 2024 23:15:42 +0200 Subject: [PATCH 098/134] fix `.tabulate_stats()` (several steps in case of the latent projection also need to be applied to the subsampled LOO results) --- R/summary_funs.R | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 5075f3c0c..de02ccf85 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -108,17 +108,30 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, if (resp_oscale) { summaries_ref <- summaries_ref$oscale summaries_sub <- lapply(summaries_sub, "[[", "oscale") + if (!is.null(summaries_fast_sub)) { + summaries_fast_sub <- lapply(summaries_fast_sub, "[[", "oscale") + } ref_lppd_NA <- all(is.na(summaries_ref$lppd)) sub_lppd_NA <- any(sapply(summaries_sub, check_sub_NA, el_nm = "lppd")) + if (!is.null(summaries_fast_sub)) { + fast_sub_lppd_NA <- any(sapply(summaries_fast_sub, check_sub_NA, el_nm = "lppd")) + } else { + fast_sub_lppd_NA <- FALSE + } ref_mu_NA <- all(is.na(summaries_ref$mu)) sub_mu_NA <- any(sapply(summaries_sub, check_sub_NA, el_nm = "mu")) - if (ref_mu_NA || sub_mu_NA) { + if (!is.null(summaries_fast_sub)) { + fast_sub_mu_NA <- any(sapply(summaries_fast_sub, check_sub_NA, el_nm = "mu")) + } else { + fast_sub_mu_NA <- FALSE + } + if (ref_mu_NA || sub_mu_NA || fast_sub_mu_NA) { message( "`latent_ilink` returned only `NA`s, so all performance statistics ", "will also be `NA` as long as `resp_oscale = TRUE`." ) } else if (any(stats %in% c("elpd", "mlpd", "gmpd")) && - (ref_lppd_NA || sub_lppd_NA)) { + (ref_lppd_NA || sub_lppd_NA || fast_sub_lppd_NA)) { message( "`latent_ll_oscale` returned only `NA`s, so ELPD, MLPD, and GMPD ", "will also be `NA` as long as `resp_oscale = TRUE`." From 0dcfcf2cf9766eae4468f6dea43dee5596d0895d Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 9 Oct 2024 22:55:37 +0200 Subject: [PATCH 099/134] Since `summaries_fast` is created by a call to `loo_varsel()` with `validate_search = FALSE`, the search is not run again when creating `summaries_fast`. Only the performance evaluation (including the re-projections required for it) is run again. Hence, it would be inconsistent to treat `summaries_fast` like the search-related arguments of `cv_varsel.refmodel()` when calling `cv_varsel.refmodel()` from within `cv_varsel.vsel()`. Thus, a lot of code related to `summaries_fast` can be removed, which is done here. --- R/cv_varsel.R | 9 +++------ man/cv_varsel.Rd | 3 --- 2 files changed, 3 insertions(+), 9 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 077278cb5..40889d153 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -42,7 +42,6 @@ #' of the selected submodels are optimistically biased. However, these fast #' biased estimated can be useful to obtain initial information on the #' usefulness of projection predictive variable selection. -#' @param summaries_fast **TODO** #' @param seed Pseudorandom number generation (PRNG) seed by which the same #' results can be obtained again if needed. Passed to argument `seed` of #' [set.seed()], but can also be `NA` to not call [set.seed()] at all. If not @@ -188,8 +187,7 @@ cv_varsel.vsel <- function( ) { ## the following arguments should not change arg_nms_internal <- c("method", "ndraws", "nclusters", "nterms_max", - "search_control", "penalty", "search_terms", - "summaries_fast") + "search_control", "penalty", "search_terms") dots <- list(...) arg_nms_internal_used <- intersect(arg_nms_internal, names(dots)) for (arg in arg_nms_internal_used) { @@ -243,7 +241,6 @@ cv_varsel.vsel <- function( search_control = object[["args_search"]][["search_control"]], penalty = object[["args_search"]][["penalty"]], search_terms = object[["args_search"]][["search_terms"]], - summaries_fast = object[["summaries_fast"]], cv_method = cv_method, nloo = nloo, K = K, @@ -280,7 +277,6 @@ cv_varsel.refmodel <- function( seed = NA, search_terms = NULL, search_out = NULL, - summaries_fast = NULL, parallel = getOption("projpred.prll_cv", FALSE), ...) { if (!missing(lambda_min_ratio)) { @@ -387,6 +383,7 @@ cv_varsel.refmodel <- function( search_out_rks <- NULL } + summaries_fast <- NULL if (cv_method == "LOO") { sel_cv <- loo_varsel( refmodel = refmodel, method = method, nterms_max = nterms_max, @@ -405,7 +402,7 @@ cv_varsel.refmodel <- function( search_terms_was_null = search_terms_was_null, search_out_rks = search_out_rks, parallel = parallel, ... ) - if (is.null(summaries_fast) && validate_search && nloo < refmodel$nobs) { + if (validate_search && nloo < refmodel$nobs) { # Run fast LOO-CV to be used in subsampling difference estimator summaries_fast <- loo_varsel( refmodel = refmodel, method = method, nterms_max = nterms_max, diff --git a/man/cv_varsel.Rd b/man/cv_varsel.Rd index bf38f7c86..6a1c43f61 100644 --- a/man/cv_varsel.Rd +++ b/man/cv_varsel.Rd @@ -44,7 +44,6 @@ cv_varsel(object, ...) seed = NA, search_terms = NULL, search_out = NULL, - summaries_fast = NULL, parallel = getOption("projpred.prll_cv", FALSE), ... ) @@ -196,8 +195,6 @@ formula.} \item{search_out}{Intended for internal use.} -\item{summaries_fast}{\strong{TODO}} - \item{parallel}{A single logical value indicating whether to run costly parts of the CV in parallel (\code{TRUE}) or not (\code{FALSE}). See also section "Note" below.} From 6151b0c3cb81ff800b1d352e693d31daac376c93 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 16 Oct 2024 22:12:14 +0200 Subject: [PATCH 100/134] Revert changes that are unrelated to subsampled LOO-CV (to find out why some test snapshots changed unexpectedly). --- DESCRIPTION | 3 +- R/cv_varsel.R | 226 +++++++++++++------------------ R/divergence_minimizers.R | 18 +-- R/glmfun.R | 2 +- R/misc.R | 13 +- R/summary_funs.R | 18 +-- R/varsel.R | 36 ++--- man/cv_varsel.Rd | 2 +- man/varsel.Rd | 2 +- tests/testthat/helpers/testers.R | 4 +- 10 files changed, 128 insertions(+), 196 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5cb70c335..8e9b8bbcb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -80,8 +80,7 @@ Suggests: doParallel, future, future.callr, - doFuture, - progressr + doFuture LinkingTo: Rcpp, RcppArmadillo Additional_repositories: https://mc-stan.org/r-packages/ diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 40889d153..2f2f1d558 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -185,20 +185,16 @@ cv_varsel.vsel <- function( validate_search = object$validate_search %||% TRUE, ... ) { - ## the following arguments should not change arg_nms_internal <- c("method", "ndraws", "nclusters", "nterms_max", "search_control", "penalty", "search_terms") - dots <- list(...) - arg_nms_internal_used <- intersect(arg_nms_internal, names(dots)) - for (arg in arg_nms_internal_used) { - if (!identical(object[["args_search"]][[arg]], dots[[arg]])) { - message("Argument `", arg, "` ignored. Using the argument value stored ", - "in the `vsel` object.") - } - ## remove duplicate arguments - dots[[arg]] <- NULL + arg_nms_internal_used <- intersect(arg_nms_internal, ...names()) + n_arg_nms_internal_used <- length(arg_nms_internal_used) + if (n_arg_nms_internal_used > 0) { + stop("Argument", if (n_arg_nms_internal_used > 1) "s" else "", " ", + paste(paste0("`", arg_nms_internal_used, "`"), collapse = ", "), " ", + "cannot be specified in this case because cv_varsel.vsel() specifies ", + if (n_arg_nms_internal_used > 1) "them" else "it", " ", "internally.") } - refmodel <- get_refmodel(object) rk_foldwise <- ranking(object)[["foldwise"]] if (validate_search && !is.null(rk_foldwise)) { @@ -230,26 +226,23 @@ cv_varsel.vsel <- function( "brms:::get_refmodel.brmsfit() to some non-`NULL` value.") } } - - return(do_call(cv_varsel, c( - list( - object = refmodel, - method = object[["args_search"]][["method"]], - ndraws = object[["args_search"]][["ndraws"]], - nclusters = object[["args_search"]][["nclusters"]], - nterms_max = object[["args_search"]][["nterms_max"]], - search_control = object[["args_search"]][["search_control"]], - penalty = object[["args_search"]][["penalty"]], - search_terms = object[["args_search"]][["search_terms"]], - cv_method = cv_method, - nloo = nloo, - K = K, - cvfits = cvfits, - validate_search = validate_search, - search_out = nlist(search_path = object[["search_path"]], rk_foldwise) - ), - dots - ))) + return(cv_varsel( + object = refmodel, + method = object[["args_search"]][["method"]], + ndraws = object[["args_search"]][["ndraws"]], + nclusters = object[["args_search"]][["nclusters"]], + nterms_max = object[["args_search"]][["nterms_max"]], + search_control = object[["args_search"]][["search_control"]], + penalty = object[["args_search"]][["penalty"]], + search_terms = object[["args_search"]][["search_terms"]], + cv_method = cv_method, + nloo = nloo, + K = K, + cvfits = cvfits, + validate_search = validate_search, + search_out = nlist(search_path = object[["search_path"]], rk_foldwise), + ... + )) } #' @rdname cv_varsel @@ -265,7 +258,7 @@ cv_varsel.refmodel <- function( refit_prj = !inherits(object, "datafit"), nterms_max = NULL, penalty = NULL, - verbose = getOption("projpred.verbose", interactive()), + verbose = TRUE, nloo = object$nobs, K = if (!inherits(object, "datafit")) 5 else 10, cvfits = object$cvfits, @@ -278,7 +271,8 @@ cv_varsel.refmodel <- function( search_terms = NULL, search_out = NULL, parallel = getOption("projpred.prll_cv", FALSE), - ...) { + ... +) { if (!missing(lambda_min_ratio)) { warning("Argument `lambda_min_ratio` is deprecated. Please specify ", "control arguments for the search via argument `search_control`. ", @@ -340,25 +334,16 @@ cv_varsel.refmodel <- function( if (!is.null(search_out)) { search_path_fulldata <- search_out[["search_path"]] } else { - verb_txt_search <- paste0("-----\nRunning ", method, " search ") + verb_txt_search <- "-----\nRunning the search " if (validate_search) { # Point out that this is the full-data search (if `validate_search` is # `FALSE`, this is still a full-data search, but in that case, there are # no fold-wise searches, so pointing out "full-data" could be confusing): verb_txt_search <- paste0(verb_txt_search, "using the full dataset ") } - # Note concerning the following verbose text: If `nclusters == S`, - # get_refdist() will use "thinning", not "clustering" (in that case, they - # give the same set of draws, namely the original one; hence the quotation - # marks), but here for this verbose message, we do not want to make things - # too complicated: - verb_txt_search <- paste0(verb_txt_search, "with ", - ifelse(!is.null(nclusters), - paste0(nclusters, " clusters "), - paste0(ndraws, " draws (from thinning) "))) verb_txt_search <- paste0(verb_txt_search, "...") verb_out(verb_txt_search, verbose = verbose) - search_path_fulldata <- .select( + search_path_fulldata <- select( refmodel = refmodel, ndraws = ndraws, nclusters = nclusters, method = method, nterms_max = nterms_max, penalty = penalty, verbose = verbose, search_control = search_control, @@ -759,15 +744,8 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, # "Run" the performance evaluation for the submodels along the predictor # ranking (in fact, we only prepare the performance evaluation by computing # precursor quantities, but for users, this difference is not perceivable): - verb_out("-----\nRunning the performance evaluation with ", - ifelse(refit_prj, - ifelse(!is.null(nclusters_pred), - paste0(nclusters_pred, " clusters"), - paste0(ndraws_pred, " draws (from thinning)")), - ifelse(!is.null(nclusters), - paste0(nclusters, " clusters"), - paste0(ndraws, " draws (from thinning)"))), - " (`refit_prj = ", refit_prj, "`) ...", verbose = verbose) + verb_out("-----\nRunning the performance evaluation with `refit_prj = ", + refit_prj, "` ...", verbose = verbose) # Step 1: Re-project (using the full dataset) onto the submodels along the # full-data predictor ranking and evaluate their predictive performance. perf_eval_out <- perf_eval( @@ -817,53 +795,59 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, )) } if (nrow(log_lik_ref) > 1) { - # Take into account that clustered draws usually have different weights: - lw_sub <- log_lik_ref + log(refdist_eval$wdraws_prj) - # This re-weighting requires a re-normalization (as.array() is applied to - # have stricter consistency checks, see `?sweep`): - lw_sub <- sweep(lw_sub, 2, as.array(apply(lw_sub, 2, log_sum_exp))) - # Internally, loo::psis() doesn't perform the Pareto smoothing if the - # number of draws is small (as indicated by object `no_psis_eval`, see - # below). In projpred, this can occur, e.g., if users request a number - # of projected draws (for performance evaluation, either after - # clustering or thinning the reference model's posterior draws) that is - # much smaller than the default of 400. In order to throw a customized - # warning message (and to avoid the calculation of Pareto k-values, see - # loo issue stan-dev/loo#227), object `no_psis_eval` indicates whether - # loo::psis() would perform the Pareto smoothing or not (for the - # decision rule, see loo:::n_pareto() and loo:::enough_tail_samples(), - # keeping in mind that we have `r_eff = 1` for all observations here). - S_for_psis_eval <- nrow(log_lik_ref) - no_psis_eval <- ceiling(min(0.2 * S_for_psis_eval, - 3 * sqrt(S_for_psis_eval))) < 5 - if (no_psis_eval) { + # Use loo::sis() if the projected draws (i.e., the draws resulting + # from the clustering or thinning) have nonconstant weights: + if (refdist_eval$const_wdraws_prj) { + # Internally, loo::psis() doesn't perform the Pareto smoothing if the + # number of draws is small (as indicated by object `no_psis_eval`, see + # below). In projpred, this can occur, e.g., if users request a number + # of projected draws (for performance evaluation, either after + # clustering or thinning the reference model's posterior draws) that is + # much smaller than the default of 400. In order to throw a customized + # warning message (and to avoid the calculation of Pareto k-values, see + # loo issue stan-dev/loo#227), object `no_psis_eval` indicates whether + # loo::psis() would perform the Pareto smoothing or not (for the + # decision rule, see loo:::n_pareto() and loo:::enough_tail_samples(), + # keeping in mind that we have `r_eff = 1` for all observations here). + S_for_psis_eval <- nrow(log_lik_ref) + no_psis_eval <- ceiling(min(0.2 * S_for_psis_eval, + 3 * sqrt(S_for_psis_eval))) < 5 + if (no_psis_eval) { + if (getOption("projpred.warn_psis", TRUE)) { + warning( + "Using standard importance sampling (SIS), as the number of ", + "draws or clusters is too small for PSIS. For improved ", + "accuracy, increase the number of draws or clusters, or use ", + "K-fold-CV." + ) + } + # Use loo::sis(). + # In principle, we could rely on loo::psis() here (because in such a + # case, it would internally switch to SIS automatically), but using + # loo::sis() explicitly is safer because if the loo package changes + # its decision rule, we would get a mismatch between our customized + # warning here and the IS method used by loo. See also loo issue + # stan-dev/loo#227. + importance_sampling_nm <- "sis" + } else { + # Use loo::psis(). + # Usually, we have a small number of projected draws here (400 by + # default), which means that the 'loo' package will automatically + # perform the regularization from Vehtari et al. (2024, + # , appendix G). + importance_sampling_nm <- "psis" + } + } else { if (getOption("projpred.warn_psis", TRUE)) { - message( - "Using standard importance sampling (SIS) due to a small number of", - ifelse(refit_prj, - ifelse(!is.null(nclusters_pred), - " clusters", - " draws (from thinning)"), - ifelse(!is.null(nclusters), - " clusters", - " draws (from thinning)")) + warning( + "The projected draws used for the performance evaluation have ", + "different (i.e., nonconstant) weights, so using standard ", + "importance sampling (SIS) instead of Pareto-smoothed importance ", + "sampling (PSIS). In general, PSIS is recommended over SIS." ) } # Use loo::sis(). - # In principle, we could rely on loo::psis() here (because in such a - # case, it would internally switch to SIS automatically), but using - # loo::sis() explicitly is safer because if the loo package changes - # its decision rule, we would get a mismatch between our customized - # warning here and the IS method used by loo. See also loo issue - # stan-dev/loo#227. importance_sampling_nm <- "sis" - } else { - # Use loo::psis(). - # Usually, we have a small number of projected draws here (400 by - # default), which means that the 'loo' package will automatically - # perform the regularization from Vehtari et al. (2022, - # , appendix G). - importance_sampling_nm <- "psis" } importance_sampling_func <- get(importance_sampling_nm, asNamespace("loo")) @@ -900,6 +884,11 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } else { lw_sub <- matrix(0, nrow = nrow(log_lik_ref), ncol = ncol(log_lik_ref)) } + # Take into account that clustered draws usually have different weights: + lw_sub <- lw_sub + log(refdist_eval$wdraws_prj) + # This re-weighting requires a re-normalization (as.array() is applied to + # have stricter consistency checks, see `?sweep`): + lw_sub <- sweep(lw_sub, 2, as.array(apply(lw_sub, 2, log_sum_exp))) for (k in seq_len(1 + length(search_path_fulldata$predictor_ranking))) { # TODO: For consistency, replace `k` in this `for` loop by `j`. mu_k <- perf_eval_out[["mu_by_size"]][[k]] @@ -967,23 +956,14 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, } if (verbose) { - verb_out("-----\nRunning ", - ifelse(!search_out_rks_was_null, "", - paste0(method, " the search with ", - ifelse(!is.null(nclusters), - paste0(nclusters, " clusters"), - paste0(ndraws, " draws (from thinning)")), - " and ")), - "the performance evaluation with ", - ifelse(refit_prj, - ifelse(!is.null(nclusters_pred), - paste0(nclusters_pred, " clusters"), - paste0(ndraws_pred, " draws (from thinning)")), - ifelse(!is.null(nclusters), - paste0(nclusters, " clusters"), - paste0(ndraws, " draws (from thinning)"))), - " (`refit_prj = ", refit_prj, - "`) for each of the `nloo = ", nloo, "` ", + verb_txt_start <- "-----\nRunning " + if (!search_out_rks_was_null) { + verb_txt_mid <- "" + } else { + verb_txt_mid <- "the search and " + } + verb_out(verb_txt_start, verb_txt_mid, "the performance evaluation with ", + "`refit_prj = ", refit_prj, "` for each of the N = ", nloo, " ", "LOO-CV folds separately ...") } one_obs <- function(run_index, @@ -1000,7 +980,7 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, if (!search_out_rks_was_null) { search_path <- list(predictor_ranking = search_out_rks[[run_index]]) } else { - search_path <- .select( + search_path <- select( refmodel = refmodel, ndraws = ndraws, nclusters = nclusters, reweighting_args = list(cl_ref = cl_sel, wdraws_ref = exp(lw[, i])), method = method, nterms_max = nterms_max, penalty = penalty, @@ -1049,22 +1029,15 @@ loo_varsel <- function(refmodel, method, nterms_max, ndraws, if (!requireNamespace("doRNG", quietly = TRUE)) { stop("Please install the 'doRNG' package.") } - if (verbose && use_progressr()) { - progressor_obj <- progressr::progressor(length(inds)) - } else { - progressor_obj <- NULL - } dot_args <- list(...) `%do_projpred%` <- doRNG::`%dorng%` res_cv <- foreach::foreach( run_index = seq_along(inds), - .packages = c("projpred"), - .export = c("one_obs", "dot_args", "progressor_obj"), + .export = c("one_obs", "dot_args"), .noexport = c("mu_offs_oscale", "loglik_forPSIS", "psisloo", "y_lat_E", "loo_ref_oscale", "validset", "loo_sub", "mu_sub", "loo_sub_oscale", "mu_sub_oscale") ) %do_projpred% { - if (!is.null(progressor_obj)) progressor_obj() do.call(one_obs, c(list(run_index = run_index, verbose_search = FALSE), dot_args)) } @@ -1315,7 +1288,7 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, } else if (!search_out_rks_was_null) { search_path <- list(predictor_ranking = rk) } else { - search_path <- .select( + search_path <- select( refmodel = fold$refmodel, ndraws = ndraws, nclusters = nclusters, method = method, nterms_max = nterms_max, penalty = penalty, verbose = verbose_search, search_control = search_control, @@ -1377,21 +1350,14 @@ kfold_varsel <- function(refmodel, method, nterms_max, ndraws, nclusters, if (!requireNamespace("doRNG", quietly = TRUE)) { stop("Please install the 'doRNG' package.") } - if (verbose && use_progressr()) { - progressor_obj <- progressr::progressor(length(list_cv)) - } else { - progressor_obj <- NULL - } dot_args <- list(...) `%do_projpred%` <- doRNG::`%dorng%` res_cv <- foreach::foreach( list_cv_k = list_cv, search_out_rks_k = search_out_rks, - .packages = c("projpred"), - .export = c("one_fold", "dot_args", "progressor_obj"), + .export = c("one_fold", "dot_args"), .noexport = c("list_cv", "search_out_rks") ) %do_projpred% { - if (!is.null(progressor_obj)) progressor_obj() do_call(one_fold, c(list(fold = list_cv_k, rk = search_out_rks_k, verbose_search = FALSE), dot_args)) diff --git a/R/divergence_minimizers.R b/R/divergence_minimizers.R index dbab5a6cd..0fe07e034 100644 --- a/R/divergence_minimizers.R +++ b/R/divergence_minimizers.R @@ -91,25 +91,18 @@ divmin <- function( if (!requireNamespace("iterators", quietly = TRUE)) { stop("Please install the 'iterators' package.") } - if (verbose_divmin && use_progressr()) { - progressor_obj <- progressr::progressor(length(formulas)) - } else { - progressor_obj <- NULL - } dot_args <- list(...) `%do_projpred%` <- foreach::`%dopar%` outdmin <- foreach::foreach( formula_s = formulas, projpred_var_s = iterators::iter(projpred_var, by = "column"), projpred_formula_no_random_s = projpred_formulas_no_random, - .packages = c("projpred"), - .export = c("sdivmin", "projpred_random", "dot_args", "progressor_obj"), + .export = c("sdivmin", "projpred_random", "dot_args"), .noexport = c( "object", "p_sel", "search_path", "p_ref", "refmodel", "formulas", "projpred_var", "projpred_ws_aug", "projpred_formulas_no_random" ) ) %do_projpred% { - if (!is.null(progressor_obj)) progressor_obj() mssgs_warns_capt <- capt_mssgs_warns( soutdmin <- do.call( sdivmin, @@ -656,26 +649,19 @@ divmin_augdat <- function( if (!requireNamespace("iterators", quietly = TRUE)) { stop("Please install the 'iterators' package.") } - if (verbose_divmin && use_progressr()) { - progressor_obj <- progressr::progressor(ncol(projpred_ws_aug)) - } else { - progressor_obj <- NULL - } dot_args <- list(...) `%do_projpred%` <- foreach::`%dopar%` outdmin <- foreach::foreach( projpred_w_aug_s = iterators::iter(projpred_ws_aug, by = "column"), - .packages = c("projpred"), .export = c( "sdivmin", "formula", "data", "family", "projpred_formula_no_random", - "projpred_random", "dot_args", "progressor_obj" + "projpred_random", "dot_args" ), .noexport = c( "object", "p_sel", "search_path", "p_ref", "refmodel", "projpred_var", "projpred_ws_aug", "linkobjs" ) ) %do_projpred% { - if (!is.null(progressor_obj)) progressor_obj() mssgs_warns_capt <- capt_mssgs_warns( soutdmin <- do.call( sdivmin, diff --git a/R/glmfun.R b/R/glmfun.R index 044678b9a..648b25348 100644 --- a/R/glmfun.R +++ b/R/glmfun.R @@ -16,7 +16,7 @@ standardization <- function(x, center = TRUE, scale = TRUE, weights = NULL) { mx <- rep(0, ncol(x)) } if (scale) { - sx <- apply(x, 2, .weighted_sd, w) + sx <- apply(x, 2, weighted.sd, w) } else { sx <- rep(1, ncol(x)) } diff --git a/R/misc.R b/R/misc.R index 2b31d5d0c..da1e0e41d 100644 --- a/R/misc.R +++ b/R/misc.R @@ -1,8 +1,8 @@ .onAttach <- function(...) { ver <- utils::packageVersion("projpred") msg <- paste0("This is projpred version ", ver, ".") - msg <- paste0(msg, "\n", "NOTE: In projpred 2.7.0, the default search ", - "method was set to \"forward\" (for all kinds of models).") + msg <- paste0(msg, " ", "NOTE: In projpred 2.7.0, the default search method ", + "was set to \"forward\" (for all kinds of models).") packageStartupMessage(msg) } @@ -14,7 +14,7 @@ nms_y_wobs_test <- function(wobs_nm = "wobs") { c("y", "y_oscale", wobs_nm) } -.weighted_sd <- function(x, w, na.rm = FALSE) { +weighted.sd <- function(x, w, na.rm = FALSE) { if (na.rm) { ind <- !is.na(w) & !is.na(x) n <- sum(ind) @@ -63,7 +63,7 @@ ilinkfun_raw <- function(x, link_nm) { return(basic_ilink(x)) } -.auc <- function(x) { +auc <- function(x) { resp <- x[, 1] pred <- x[, 2] wobs <- x[, 3] @@ -710,8 +710,3 @@ element_unq <- function(list_obj, nm) { } return(el_unq) } - -use_progressr <- function() { - getOption("projpred.use_progressr", - requireNamespace("progressr", quietly = TRUE) && interactive()) -} diff --git a/R/summary_funs.R b/R/summary_funs.R index de02ccf85..aca48922f 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -334,14 +334,14 @@ get_stat <- function(summaries, summaries_baseline = NULL, } else { # full LOO estimator value <- mean(wobs * (mu - y)^2) - value_se <- .weighted_sd((mu - y)^2, wobs) / sqrt(n_full) + value_se <- weighted.sd((mu - y)^2, wobs) / sqrt(n_full) } # store for later calculations mse_e <- value if (!is.null(summaries_baseline)) { # delta=TRUE, variance of difference of two normally distributed mse_b <- mean(wobs * (mu_baseline - y)^2) - var_mse_b <- .weighted_sd((mu_baseline - y)^2, wobs)^2 / n_full + var_mse_b <- weighted.sd((mu_baseline - y)^2, wobs)^2 / n_full if (n_loo < n_full) { mse_e_fast <- mean(wobs * (summaries_fast$mu - y)^2) srs_diffe <- @@ -370,7 +370,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, mse_y <- mean(wobs * (mean(y) - y)^2) value <- 1 - mse_e / mse_y - ifelse(is.null(summaries_baseline), 0, 1 - mse_b / mse_y) # the first-order Taylor approximation of the variance - var_mse_y <- .weighted_sd((mean(y) - y)^2, wobs)^2 / n_full + var_mse_y <- weighted.sd((mean(y) - y)^2, wobs)^2 / n_full if (n_loo < n_full) { mse_e_fast <- mean(wobs * (summaries_fast$mu - y)^2) if (is.null(summaries_baseline)) { @@ -495,7 +495,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, } else { # full LOO estimator value <- mean(wobs * correct) - mean(wobs * correct_baseline) - value_se <- .weighted_sd(correct - correct_baseline, wobs) / sqrt(n_full) + value_se <- weighted.sd(correct - correct_baseline, wobs) / sqrt(n_full) } } else if (stat == "auc") { if (n_loo < n_full) { @@ -505,15 +505,15 @@ get_stat <- function(summaries, summaries_baseline = NULL, if (!is.null(mu_baseline)) { auc_data <- cbind(y, mu, wobs) auc_data_baseline <- cbind(y, mu_baseline, wobs) - value <- .auc(auc_data) - .auc(auc_data_baseline) + value <- auc(auc_data) - auc(auc_data_baseline) idxs_cols <- seq_len(ncol(auc_data)) idxs_cols_bs <- setdiff(seq_len(ncol(auc_data) + ncol(auc_data_baseline)), idxs_cols) diffvalue.bootstrap <- bootstrap( cbind(auc_data, auc_data_baseline), function(x) { - .auc(x[, idxs_cols, drop = FALSE]) - - .auc(x[, idxs_cols_bs, drop = FALSE]) + auc(x[, idxs_cols, drop = FALSE]) - + auc(x[, idxs_cols_bs, drop = FALSE]) }, ... ) @@ -523,8 +523,8 @@ get_stat <- function(summaries, summaries_baseline = NULL, names = FALSE, na.rm = TRUE) } else { auc_data <- cbind(y, mu, wobs) - value <- .auc(auc_data) - value.bootstrap <- bootstrap(auc_data, .auc, ...) + value <- auc(auc_data) + value.bootstrap <- bootstrap(auc_data, auc, ...) value_se <- sd(value.bootstrap, na.rm = TRUE) lq_uq <- quantile(value.bootstrap, probs = c(alpha_half, one_minus_alpha_half), diff --git a/R/varsel.R b/R/varsel.R index 1f7b5632a..3fadef546 100644 --- a/R/varsel.R +++ b/R/varsel.R @@ -248,27 +248,15 @@ varsel.vsel <- function(object, ...) { #' @rdname varsel #' @export -varsel.refmodel <- function( - object, - d_test = NULL, - method = "forward", - ndraws = NULL, - nclusters = 20, - ndraws_pred = 400, - nclusters_pred = NULL, - refit_prj = !inherits(object, "datafit"), - nterms_max = NULL, - verbose = getOption("projpred.verbose", interactive()), - search_control = NULL, - lambda_min_ratio = 1e-5, - nlambda = 150, - thresh = 1e-6, - penalty = NULL, - search_terms = NULL, - search_out = NULL, - seed = NA, - ... -) { +varsel.refmodel <- function(object, d_test = NULL, method = "forward", + ndraws = NULL, nclusters = 20, ndraws_pred = 400, + nclusters_pred = NULL, + refit_prj = !inherits(object, "datafit"), + nterms_max = NULL, verbose = TRUE, + search_control = NULL, lambda_min_ratio = 1e-5, + nlambda = 150, thresh = 1e-6, penalty = NULL, + search_terms = NULL, search_out = NULL, seed = NA, + ...) { if (!missing(lambda_min_ratio)) { warning("Argument `lambda_min_ratio` is deprecated. Please specify ", "control arguments for the search via argument `search_control`. ", @@ -388,7 +376,7 @@ varsel.refmodel <- function( search_path <- search_out[["search_path"]] } else { verb_out("-----\nRunning the search ...", verbose = verbose) - search_path <- .select( + search_path <- select( refmodel = refmodel, ndraws = ndraws, nclusters = nclusters, method = method, nterms_max = nterms_max, penalty = penalty, verbose = verbose, search_control = search_control, @@ -523,8 +511,8 @@ varsel.refmodel <- function( # `outdmins` (the submodel fits along the predictor ranking, with the number # of fits per model size being equal to the number of projected draws), and # `p_sel` (the output from get_refdist() for the search). -.select <- function(refmodel, ndraws, nclusters, reweighting_args = NULL, - method, nterms_max, penalty, verbose, search_control, ...) { +select <- function(refmodel, ndraws, nclusters, reweighting_args = NULL, method, + nterms_max, penalty, verbose, search_control, ...) { if (is.null(reweighting_args)) { p_sel <- get_refdist(refmodel, ndraws = ndraws, nclusters = nclusters) } else { diff --git a/man/cv_varsel.Rd b/man/cv_varsel.Rd index 6a1c43f61..eefdc7e81 100644 --- a/man/cv_varsel.Rd +++ b/man/cv_varsel.Rd @@ -32,7 +32,7 @@ cv_varsel(object, ...) refit_prj = !inherits(object, "datafit"), nterms_max = NULL, penalty = NULL, - verbose = getOption("projpred.verbose", interactive()), + verbose = TRUE, nloo = object$nobs, K = if (!inherits(object, "datafit")) 5 else 10, cvfits = object$cvfits, diff --git a/man/varsel.Rd b/man/varsel.Rd index f0cc84937..b9ade6fbb 100644 --- a/man/varsel.Rd +++ b/man/varsel.Rd @@ -23,7 +23,7 @@ varsel(object, ...) nclusters_pred = NULL, refit_prj = !inherits(object, "datafit"), nterms_max = NULL, - verbose = getOption("projpred.verbose", interactive()), + verbose = TRUE, search_control = NULL, lambda_min_ratio = 1e-05, nlambda = 150, diff --git a/tests/testthat/helpers/testers.R b/tests/testthat/helpers/testers.R index 1998abadc..f9d3c1713 100644 --- a/tests/testthat/helpers/testers.R +++ b/tests/testthat/helpers/testers.R @@ -1976,8 +1976,7 @@ vsel_tester <- function( search_control_expected = NULL, extra_tol = 1.1, info_str = "" - ) { - +) { # Preparations: if (with_cv) { if (is.null(cv_method_expected)) { @@ -2305,7 +2304,6 @@ vsel_tester <- function( } return(invisible(TRUE)) } - for (j in seq_along(vs$summaries$sub)) { smmrs_sub_j_tester(vs$summaries$sub[[j]]) if (vs$refmodel$family$for_latent) { From 360354a73dd4676bb7d4e3e4b94ab96c4cdd4690 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Thu, 26 Sep 2024 23:16:25 +0200 Subject: [PATCH 101/134] Adapt the existing tests to work with the new implementation of subsampled LOO-CV. --- tests/testthat/test_varsel.R | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test_varsel.R b/tests/testthat/test_varsel.R index a4c580683..6db89b676 100644 --- a/tests/testthat/test_varsel.R +++ b/tests/testthat/test_varsel.R @@ -1384,6 +1384,10 @@ test_that("invalid `nloo` fails", { skip_if_not(run_cvvs) tstsetups_nonkfold <- grep("\\.kfold", names(cvvss), value = TRUE, invert = TRUE) + valsearch_arg <- lapply(args_cvvs[tstsetups_nonkfold], "[[", + "validate_search") + tstsetups_nonkfold <- tstsetups_nonkfold[!sapply(valsearch_arg, isFALSE)] + skip_if(length(tstsetups_nonkfold) == 0) for (tstsetup in head(tstsetups_nonkfold, 1)) { args_cvvs_i <- args_cvvs[[tstsetup]] # Use suppressWarnings() because test_that() somehow redirects stderr() and @@ -1410,6 +1414,9 @@ test_that(paste( "\\.glm\\.gauss\\..*\\.default_cvmeth\\.default_search_trms", names(cvvss), value = TRUE ) + valsearch_arg <- lapply(args_cvvs[tstsetups], "[[", "validate_search") + tstsetups <- tstsetups[!sapply(valsearch_arg, isFALSE)] + skip_if(length(tstsetups) == 0) for (tstsetup in tstsetups) { args_cvvs_i <- args_cvvs[[tstsetup]] # Use suppressWarnings() because test_that() somehow redirects stderr() and @@ -1428,7 +1435,8 @@ test_that("setting `nloo` smaller than the number of observations works", { skip_if_not(run_cvvs) nloo_tst <- nobsv %/% 5L # Output elements of `vsel` objects that may be influenced by `nloo`: - vsel_nms_nloo <- c("summaries", "summaries_fast","predictor_ranking_cv", "nloo", "loo_inds", "ce") + vsel_nms_nloo <- c("summaries", "summaries_fast","predictor_ranking_cv", + "nloo", "loo_inds", "ce") # In general, element `ce` is affected as well (because the PRNG state when # doing the clustering for the performance evaluation is different when `nloo` # is smaller than the number of observations compared to when `nloo` is equal @@ -1440,6 +1448,9 @@ test_that("setting `nloo` smaller than the number of observations works", { "\\.glm\\.gauss\\..*\\.default_cvmeth\\.default_search_trms", names(cvvss), value = TRUE ) + valsearch_arg <- lapply(args_cvvs[tstsetups], "[[", "validate_search") + tstsetups <- tstsetups[!sapply(valsearch_arg, isFALSE)] + skip_if(length(tstsetups) == 0) for (tstsetup in tstsetups) { args_cvvs_i <- args_cvvs[[tstsetup]] tstsetup_ref <- args_cvvs_i$tstsetup_ref @@ -1461,7 +1472,7 @@ test_that("setting `nloo` smaller than the number of observations works", { prd_trms_len_expected = args_cvvs_i$nterms_max, method_expected = meth_exp_crr, cv_method_expected = "LOO", - valsearch_expected = args_cvvs_i$validate_search, + valsearch_expected = TRUE, nloo_expected = nloo_tst, search_terms_expected = args_cvvs_i$search_terms, search_trms_empty_size = From 0bd3830f4c87548335ea33819e52193c301d7940 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 4 Nov 2024 22:16:54 +0100 Subject: [PATCH 102/134] fix the early check for all-`NA`s in `get_stat()` --- R/summary_funs.R | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index aca48922f..a0ff1a3d8 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -278,11 +278,28 @@ get_stat <- function(summaries, summaries_baseline = NULL, y_wobs_test, stat, alpha = 0.1, ...) { mu <- summaries$mu lppd <- summaries$lppd - n_full <- length(lppd) - n_loo <- if (is.null(loo_inds)) n_full else length(loo_inds) - if (all(is.na(lppd)) || all(is.na(y_wobs_test$y_prop %||% y_wobs_test$y))) { + all_na_baseline <- NULL + if (stat %in% c("elpd", "mlpd", "gmpd")) { + if (!is.null(summaries_baseline)) { + all_na_baseline <- all(is.na(summaries_baseline$lppd)) + } + all_na <- all(is.na(lppd)) + } else { + hasNA_y <- is.na(y_wobs_test$y_prop %||% y_wobs_test$y) + if (!is.null(summaries_baseline)) { + all_na_baseline <- all(is.na(summaries_baseline$mu) | hasNA_y) + } + all_na <- all(is.na(mu) | hasNA_y) + } + if (!is.null(all_na_baseline) && + getOption("projpred.additional_checks", FALSE)) { + stopifnot(all_na == all_na_baseline) + } + if (all_na) { return(list(value = NA, se = NA, lq = NA, uq = NA)) } + n_full <- length(lppd) + n_loo <- if (is.null(loo_inds)) n_full else length(loo_inds) alpha_half <- alpha / 2 one_minus_alpha_half <- 1 - alpha_half From 3923005d33e69d61ef33414d51f25e27942e9fe6 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 4 Nov 2024 22:31:22 +0100 Subject: [PATCH 103/134] Revert "fix the early check for all-`NA`s in `get_stat()`" This reverts commit 0bd3830f4c87548335ea33819e52193c301d7940. Reason for the revert: The "fix" from that commit would have to take `summaries_fast` into account as well. For simplicity, we will avoid the early check for all-`NA`s in `get_stat()` in its entirety. --- R/summary_funs.R | 23 +++-------------------- 1 file changed, 3 insertions(+), 20 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index a0ff1a3d8..aca48922f 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -278,28 +278,11 @@ get_stat <- function(summaries, summaries_baseline = NULL, y_wobs_test, stat, alpha = 0.1, ...) { mu <- summaries$mu lppd <- summaries$lppd - all_na_baseline <- NULL - if (stat %in% c("elpd", "mlpd", "gmpd")) { - if (!is.null(summaries_baseline)) { - all_na_baseline <- all(is.na(summaries_baseline$lppd)) - } - all_na <- all(is.na(lppd)) - } else { - hasNA_y <- is.na(y_wobs_test$y_prop %||% y_wobs_test$y) - if (!is.null(summaries_baseline)) { - all_na_baseline <- all(is.na(summaries_baseline$mu) | hasNA_y) - } - all_na <- all(is.na(mu) | hasNA_y) - } - if (!is.null(all_na_baseline) && - getOption("projpred.additional_checks", FALSE)) { - stopifnot(all_na == all_na_baseline) - } - if (all_na) { - return(list(value = NA, se = NA, lq = NA, uq = NA)) - } n_full <- length(lppd) n_loo <- if (is.null(loo_inds)) n_full else length(loo_inds) + if (all(is.na(lppd)) || all(is.na(y_wobs_test$y_prop %||% y_wobs_test$y))) { + return(list(value = NA, se = NA, lq = NA, uq = NA)) + } alpha_half <- alpha / 2 one_minus_alpha_half <- 1 - alpha_half From da4272a22d1e7f77788dba23099d1aaffc930907 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 4 Nov 2024 22:40:45 +0100 Subject: [PATCH 104/134] avoid the early check for all-`NA`s in `get_stat()` --- R/misc.R | 10 +- R/summary_funs.R | 33 +++-- tests/testthat/helpers/creators.R | 7 ++ tests/testthat/setup.R | 1 + tests/testthat/test_misc.R | 192 +++++++++++++++++++++++++++++- 5 files changed, 224 insertions(+), 19 deletions(-) create mode 100644 tests/testthat/helpers/creators.R diff --git a/R/misc.R b/R/misc.R index da1e0e41d..2e82b6583 100644 --- a/R/misc.R +++ b/R/misc.R @@ -68,11 +68,10 @@ auc <- function(x) { pred <- x[, 2] wobs <- x[, 3] - # Make it explicit that `x` should not be used anymore (due to the possibility - # of `NA`s, but also due to the re-ordering): + # Make it explicit that `x` should not be used anymore: rm(x) - ord <- order(pred, decreasing = TRUE, na.last = NA) + ord <- order(pred, decreasing = TRUE, na.last = FALSE) n <- length(ord) resp <- resp[ord] @@ -80,8 +79,9 @@ auc <- function(x) { wobs <- wobs[ord] w0 <- w1 <- wobs - # CAUTION: The following check also ensures that `resp` does not have `NA`s: - stopifnot(all(resp %in% c(0, 1))) + stopifnot(all(na.omit(resp) %in% c(0, 1))) + w0[is.na(resp)] <- NA # ensure that `NA`s in `resp` propagate to the output + w1[is.na(resp)] <- NA # ensure that `NA`s in `resp` propagate to the output w0[resp == 1] <- 0 # for calculating the false positive rate (fpr) w1[resp == 0] <- 0 # for calculating the true positive rate (tpr) cum_w0 <- cumsum(w0) diff --git a/R/summary_funs.R b/R/summary_funs.R index aca48922f..4b766ccde 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -280,9 +280,6 @@ get_stat <- function(summaries, summaries_baseline = NULL, lppd <- summaries$lppd n_full <- length(lppd) n_loo <- if (is.null(loo_inds)) n_full else length(loo_inds) - if (all(is.na(lppd)) || all(is.na(y_wobs_test$y_prop %||% y_wobs_test$y))) { - return(list(value = NA, se = NA, lq = NA, uq = NA)) - } alpha_half <- alpha / 2 one_minus_alpha_half <- 1 - alpha_half @@ -302,8 +299,8 @@ get_stat <- function(summaries, summaries_baseline = NULL, value_se <- sqrt(srs_diffe$v_y_hat + srs_diffe$hat_v_y) } else { # full LOO estimator - value <- sum(lppd - lppd_baseline, na.rm = TRUE) - value_se <-sd(lppd - lppd_baseline, na.rm = TRUE) * sqrt(n_full) + value <- sum(lppd - lppd_baseline) + value_se <- sd(lppd - lppd_baseline) * sqrt(n_full) } if (stat %in% c("mlpd", "gmpd")) { value <- value / n_full @@ -517,18 +514,28 @@ get_stat <- function(summaries, summaries_baseline = NULL, }, ... ) - value_se <- sd(diffvalue.bootstrap, na.rm = TRUE) - lq_uq <- quantile(diffvalue.bootstrap, - probs = c(alpha_half, one_minus_alpha_half), - names = FALSE, na.rm = TRUE) + value_se <- sd(diffvalue.bootstrap) + if (any(is.na(diffvalue.bootstrap))) { + # quantile() is not able to deal with `NA`s + lq_uq <- rep(NA_real_, 2) + } else { + lq_uq <- quantile(diffvalue.bootstrap, + probs = c(alpha_half, one_minus_alpha_half), + names = FALSE) + } } else { auc_data <- cbind(y, mu, wobs) value <- auc(auc_data) value.bootstrap <- bootstrap(auc_data, auc, ...) - value_se <- sd(value.bootstrap, na.rm = TRUE) - lq_uq <- quantile(value.bootstrap, - probs = c(alpha_half, one_minus_alpha_half), - names = FALSE, na.rm = TRUE) + value_se <- sd(value.bootstrap) + if (any(is.na(value.bootstrap))) { + # quantile() is not able to deal with `NA`s + lq_uq <- rep(NA_real_, 2) + } else { + lq_uq <- quantile(value.bootstrap, + probs = c(alpha_half, one_minus_alpha_half), + names = FALSE) + } } } } diff --git a/tests/testthat/helpers/creators.R b/tests/testthat/helpers/creators.R new file mode 100644 index 000000000..59f1bae3f --- /dev/null +++ b/tests/testthat/helpers/creators.R @@ -0,0 +1,7 @@ +imperfect_alternation <- function(unq_vals, n_tail = 6L, ...) { + x <- rep_len(unq_vals, ...) + tail_idxs_x <- tail(seq_along(x), n = n_tail) + x[tail_idxs_x] <- x[c(tail_idxs_x[-1], + tail_idxs_x[1])] + return(x) +} diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index c0181c176..733e6618e 100755 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -163,6 +163,7 @@ source(testthat::test_path("helpers", "getters.R"), local = TRUE) source(testthat::test_path("helpers", "formul_handlers.R"), local = TRUE) source(testthat::test_path("helpers", "predictor_handlers.R"), local = TRUE) source(testthat::test_path("helpers", "dummies.R"), local = TRUE) +source(testthat::test_path("helpers", "creators.R"), local = TRUE) # Note: The following `mod_nms` refer to *generalized* (linear/additive, # multilevel) models. This is due to history (when these tests were written, diff --git a/tests/testthat/test_misc.R b/tests/testthat/test_misc.R index d9f0f7768..982ac5e42 100644 --- a/tests/testthat/test_misc.R +++ b/tests/testthat/test_misc.R @@ -168,7 +168,7 @@ test_that("rstanarm: special formulas work", { } }) -# pseudo_data() ----------------------------------------------------------- +# Other internal functions ------------------------------------------------ test_that(paste( "`pseudo_data(f = 0, [...], family = extend_family(gaussian()), [...])` is", @@ -188,3 +188,193 @@ test_that(paste( expect_false(isTRUE(all.equal(psdat$z, mu_crr))) expect_equal(psdat$wobs, wobs_crr) }) + +test_that(".srs_diff_est_w() propagates input `NA`s to its output", { + nloo_tst <- nobsv %/% 5L + loo_inds_tst <- ceiling(seq(1L, nobsv, length.out = nloo_tst)) + skip_if_not(length(unique(loo_inds_tst)) == nloo_tst) + srs_diff_res_NAs <- list( + m = nloo_tst, + N = nobsv, + y_hat = NA_real_, + v_y_hat = NA_real_, + hat_v_y = NA_real_ + ) + expect_identical( + .srs_diff_est_w(y_approx = rep(NA, nobsv), + y = rep(NA, nloo_tst), + y_idx = loo_inds_tst, + wobs = rep(NA, nobsv)), + srs_diff_res_NAs, + info = "all inputs (except `y_idx`) are all-`NA`s" + ) + expect_identical( + .srs_diff_est_w(y_approx = rep(-0.8, nobsv), + y = rep(NA, nloo_tst), + y_idx = loo_inds_tst, + wobs = rep_len(c(2, 3), length.out = nobsv)), + srs_diff_res_NAs, + info = "`y_approx` without `NA`s, `y` only `NA`s, `wobs` without `NA`s" + ) + expect_identical( + .srs_diff_est_w(y_approx = rep(-0.8, nobsv), + y = c(rep(-0.7, nloo_tst - 1L), NA), + y_idx = loo_inds_tst, + wobs = rep_len(c(2, 3), length.out = nobsv)), + srs_diff_res_NAs, + info = paste0("`y_approx` without `NA`s, `y` with a single `NA`, ", + "`wobs` without `NA`s") + ) + expect_identical( + .srs_diff_est_w(y_approx = c(NA, rep(-0.8, nobsv - 1L)), + y = c(rep(NA, nloo_tst - 1L), -0.7), + y_idx = loo_inds_tst, + wobs = rep_len(c(2, 3), length.out = nobsv)), + srs_diff_res_NAs, + info = paste0("`y_approx` with a single `NA`, `y` with a single `NA`, ", + "`wobs` without `NA`s") + ) +}) + +test_that("weighted.sd() with `na.rm = FALSE` propagates input `NA`s to its output", { + expect_identical( + weighted.sd(x = rep(NA, nobsv), + w = rep(NA, nobsv)), + NA_real_, + info = "all inputs are all-`NA`s" + ) + expect_identical( + weighted.sd(x = rep(-0.8, nobsv), + w = c(rep_len(c(2, 3), length.out = nobsv - 1L), NA)), + NA_real_, + info = "`x` without `NA`s, `w` with a single `NA`" + ) + expect_identical( + weighted.sd(x = c(rep(-0.8, nobsv - 1L), NA), + w = rep_len(c(2, 3), length.out = nobsv)), + NA_real_, + info = "`x` with a single `NA`, `w` without `NA`s" + ) + expect_identical( + weighted.sd(x = rep(-0.8, nobsv), + w = rep(NA, nobsv)), + NA_real_, + info = "`x` without `NA`s, `w` all-`NA`s" + ) + expect_identical( + weighted.sd(x = rep(NA, nobsv), + w = rep_len(c(2, 3), length.out = nobsv)), + NA_real_, + info = "`x` all-`NA`s, `w` without `NA`s" + ) +}) + +test_that("auc() works", { + nobsv_auc <- 19L + expect_equal( + auc(cbind(rep_len(c(0, 1), length.out = nobsv_auc), + imperfect_alternation(c(0.3, 0.8), length.out = nobsv_auc), + rep(1, nobsv_auc))), + 0.6833333333333333333333, + info = "`wobs` column only `1`s" + ) + expect_equal( + auc(cbind(rep_len(c(0, 1), length.out = nobsv_auc), + imperfect_alternation(c(0.3, 0.8), length.out = nobsv_auc), + imperfect_alternation(c(1, 2), n_tail = 11L, length.out = nobsv_auc))), + 0.717948717948718062587, + info = "`wobs` column with imperfect alternation of `1`s and `2`s" + ) +}) + +test_that("auc() propagates input `NA`s to its output", { + nobsv_auc <- 19L + expect_identical( + auc(cbind(rep(NA, nobsv_auc), + rep(NA, nobsv_auc), + rep(NA, nobsv_auc))), + NA_real_, + info = "all inputs are all-`NA`s" + ) + expect_identical( + auc(cbind(rep(1, nobsv_auc), + rep(NA, nobsv_auc), + rep(1, nobsv_auc))), + NA_real_, + info = paste0("`resp` column without `NA`s, ", + "`pred` column only `NA`s, ", + "`wobs` column without `NA`s") + ) + expect_identical( + auc(cbind(rep(1, nobsv_auc), + rep(NA, nobsv_auc), + c(rep(1, nobsv_auc - 1L), NA))), + NA_real_, + info = paste0("`resp` column without `NA`s, ", + "`pred` column only `NA`s, ", + "`wobs` column with a single `NA`") + ) + expect_identical( + auc(cbind(c(rep_len(c(0, 1), length.out = nobsv_auc - 1L), NA), + rep(0.7, nobsv_auc), + rep(1, nobsv_auc))), + NA_real_, + info = paste0("`resp` column with a single `NA`, ", + "`pred` column without `NA`s, ", + "`wobs` column without `NA`s") + ) + expect_identical( + auc(cbind(rep(NA, nobsv_auc), + rep(0.7, nobsv_auc), + rep(1, nobsv_auc))), + NA_real_, + info = paste0("`resp` column only `NA`s, ", + "`pred` column without `NA`s, ", + "`wobs` column without `NA`s") + ) + expect_identical( + auc(cbind(c(rep_len(c(0, 1), length.out = nobsv_auc - 1L), NA), + c(rep(0.7, nobsv_auc - 1L), NA), + rep(1, nobsv_auc))), + NA_real_, + info = paste0("`resp` column with a single `NA`, ", + "`pred` column with a single `NA`, ", + "`wobs` column without `NA`s") + ) + expect_identical( + auc(cbind(c(rep_len(c(0, 1), length.out = nobsv_auc - 1L), NA), + c(NA, rep(0.7, nobsv_auc - 1L)), + rep(1, nobsv_auc))), + NA_real_, + info = paste0("`resp` column with a single `NA`, ", + "`pred` column with a single `NA` (at different position), ", + "`wobs` column without `NA`s") + ) + expect_identical( + auc(cbind(c(rep_len(c(0, 1), length.out = nobsv_auc - 1L), NA), + rep(NA, nobsv_auc), + rep(1, nobsv_auc))), + NA_real_, + info = paste0("`resp` column with a single `NA`, ", + "`pred` column only `NA`s, ", + "`wobs` column without `NA`s") + ) + expect_identical( + auc(cbind(rep(NA, nobsv_auc), + rep(0.7, nobsv_auc), + c(rep(1, nobsv_auc - 1L), NA))), + NA_real_, + info = paste0("`resp` column only `NA`s, ", + "`pred` column without `NA`s, ", + "`wobs` column with a single `NA`") + ) + expect_identical( + auc(cbind(rep_len(c(0, 1), length.out = nobsv_auc), + imperfect_alternation(c(0.3, 0.8), length.out = nobsv_auc), + rep(NA, nobsv_auc))), + NA_real_, + info = paste0("`resp` column without `NA`s, ", + "`pred` column without `NA`s, ", + "`wobs` column only `NA`s") + ) +}) From fbabed5fe4a059387de932427fdbcfd31ca83f43 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 17 Nov 2024 14:56:50 +0100 Subject: [PATCH 105/134] replace `n_full <- sum(!is.na(mu))` with `n_full <- length(mu)` because this ensures `all(wobs == 1)` after lines ``` wobs <- rep(wobs, y_wobs_test$wobs) wobs <- n_full * wobs / sum(wobs) ``` (but note that `NA`s in `mu` should lead to `NA` output anyway). --- R/summary_funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 4b766ccde..8ae2e41a6 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -438,7 +438,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, mu_fast <- rep(summaries_fast$mu, y_wobs_test$wobs) # CAUTION: If `y` is allowed to have `NA`s here, then the following # definition of `n_full` needs to be adapted: - n_full <- sum(!is.na(mu)) + n_full <- length(mu) if (!is.null(loo_inds)) { stopifnot(all(y_wobs_test$wobs > 0)) loo_inds <- unlist(lapply(loo_inds, function(loo_idx) { From 8666643757bd45ee87612234bcf36eba2ae709ff Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 17 Nov 2024 16:15:05 +0100 Subject: [PATCH 106/134] tests: `NA`s in summaries should be `NA_real_`s now --- tests/testthat/helpers/testers.R | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/tests/testthat/helpers/testers.R b/tests/testthat/helpers/testers.R index f9d3c1713..e69d86d93 100644 --- a/tests/testthat/helpers/testers.R +++ b/tests/testthat/helpers/testers.R @@ -2734,11 +2734,7 @@ smmry_ref_tester <- function( is_lat_kfold <- latent_expected && !resp_oscale_expected && identical(cv_method_expected, "kfold") - if (is_lat_kfold) { - expect_true(is.vector(smmry_ref, "logical"), info = info_str) - } else { - expect_true(is.vector(smmry_ref, "numeric"), info = info_str) - } + expect_true(is.vector(smmry_ref, "numeric"), info = info_str) smmry_nms <- character() stats_mean_name <- stats_expected smmry_nms <- c(smmry_nms, From 0a6b8baacf252e40a2932118b51c8c682184a808 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 22 Dec 2024 20:09:07 +0100 Subject: [PATCH 107/134] divide by `(n_full - 1)` instead of `n_full` where necessary, see --- R/summary_funs.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 8ae2e41a6..6d495a721 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -348,10 +348,10 @@ get_stat <- function(summaries, summaries_baseline = NULL, ((mu_baseline - y)^2 - mse_b))[loo_inds], y_idx = loo_inds, wobs = wobs) - cov_mse_e_b <- srs_diffe$y_hat / n_full^2 + cov_mse_e_b <- srs_diffe$y_hat / (n_full * (n_full - 1)) } else { cov_mse_e_b <- mean(wobs * ((mu - y)^2 - mse_e) * - ((mu_baseline - y)^2 - mse_b)) / n_full + ((mu_baseline - y)^2 - mse_b)) / (n_full - 1) } value_se <- sqrt(value_se^2 - 2 * cov_mse_e_b + var_mse_b) } @@ -389,15 +389,15 @@ get_stat <- function(summaries, summaries_baseline = NULL, y_idx = loo_inds, wobs = wobs) } - cov_mse_e_y <- srs_diffe$y_hat / n_full^2 + cov_mse_e_y <- srs_diffe$y_hat / (n_full * (n_full - 1)) } else { if (is.null(summaries_baseline)) { cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e) * - ((mean(y) - y)^2 - mse_y)) / n_full + ((mean(y) - y)^2 - mse_y)) / (n_full - 1) } else { cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e - ((mu_baseline - y)^2 - mse_b)) * - ((mean(y) - y)^2 - mse_y)) / n_full + ((mean(y) - y)^2 - mse_y)) / (n_full - 1) } } # part of delta se comes automatically via mse From e8f17e897dca3464b9db4bbecf1d434f6e5e6d65 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 22 Dec 2024 21:02:42 +0100 Subject: [PATCH 108/134] add test `".srs_diff_est_w() works as expected"` (copied from 'loo', see ) --- tests/testthat/test_misc.R | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/tests/testthat/test_misc.R b/tests/testthat/test_misc.R index 982ac5e42..66758b964 100644 --- a/tests/testthat/test_misc.R +++ b/tests/testthat/test_misc.R @@ -189,6 +189,43 @@ test_that(paste( expect_equal(psdat$wobs, wobs_crr) }) +# Test copied from 'loo' package and changed function name, see +# +test_that(".srs_diff_est_w() works as expected", { + set.seed(1234) + N <- 1000 + y_true <- 1:N + sigma_hat_true <- sqrt(N * sum((y_true - mean(y_true))^2) / length(y_true)) + y_approx <- rnorm(N, y_true, 0.1) + m <- 100 + sigma_hat <- y_hat <- se_y_hat <- numeric(10000) + for(i in 1:10000){ + y_idx <- sample(1:N, size = m) + y <- y_true[y_idx] + res <- .srs_diff_est_w(y_approx, y, y_idx) + y_hat[i] <- res$y_hat + se_y_hat[i] <- sqrt(res$v_y_hat) + sigma_hat[i] <- sqrt(res$hat_v_y) + } + expect_equal(mean(y_hat), sum(y_true), tol = 0.1) + + in_ki <- y_hat + 2 * se_y_hat > sum(y_true) & y_hat - 2*se_y_hat < sum(y_true) + expect_equal(mean(in_ki), 0.95, tol = 0.01) + + # Should be unbiased + expect_equal(mean(sigma_hat), sigma_hat_true, tol = 0.1) + + m <- N + y_idx <- sample(1:N, size = m) + y <- y_true[y_idx] + res <- .srs_diff_est_w(y_approx, y, y_idx) + expect_equal(res$y_hat, 500500, tol = 0.0001) + expect_equal(res$v_y_hat, 0, tol = 0.0001) + expect_equal(sqrt(res$hat_v_y), sigma_hat_true, tol = 0.1) +}) + +# TODO: Add test for .srs_diff_est_w() with `wobs` not full of ones. + test_that(".srs_diff_est_w() propagates input `NA`s to its output", { nloo_tst <- nobsv %/% 5L loo_inds_tst <- ceiling(seq(1L, nobsv, length.out = nloo_tst)) From f173ef43a31de80eec12e01ac04061c48a3ec5ff Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sat, 4 Jan 2025 21:00:29 +0100 Subject: [PATCH 109/134] explain "fast LOO" and "full LOO" in the docs, see --- R/cv_varsel.R | 14 ++++++++------ man/cv_varsel.Rd | 13 +++++++------ 2 files changed, 15 insertions(+), 12 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 2f2f1d558..1d36456ad 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -22,12 +22,14 @@ #' performed. See also section "Note" below. #' @param nloo Only relevant if `cv_method = "LOO"` and `validate_search = #' TRUE`. If `nloo > 0` is smaller than the number of all observations, full -#' LOO-CV is approximated by combining the fast LOO result for the selected -#' models and `nloo` leave-one-out searches using the difference estimator -#' with simple random sampling (SRS) without replacement (WOR) (Magnusson et -#' al., 2020). Smaller values lead to faster computation, but higher -#' uncertainty in the evaluation part. If `NULL`, all observations are used -#' (as by default). +#' LOO-CV (i.e., PSIS-LOO CV with `validate_search = TRUE` and with `nloo = +#' n` where `n` denotes the number of all observations) is approximated by +#' combining the fast (i.e., `validate_search = FALSE`) LOO result for the +#' selected models and `nloo` leave-one-out searches using the difference +#' estimator with simple random sampling (SRS) without replacement (WOR) +#' (Magnusson et al., 2020). Smaller `nloo` values lead to faster computation, +#' but higher uncertainty in the evaluation part. If `NULL`, all observations +#' are used (as by default). #' @param K Only relevant if `cv_method = "kfold"` and if `cvfits` is `NULL` #' (which is the case for reference model objects created by #' [get_refmodel.stanreg()] or [brms::get_refmodel.brmsfit()]). Number of diff --git a/man/cv_varsel.Rd b/man/cv_varsel.Rd index eefdc7e81..ac7328ee5 100644 --- a/man/cv_varsel.Rd +++ b/man/cv_varsel.Rd @@ -68,12 +68,13 @@ contrast to a standard LOO-CV). In the \code{"kfold"} case, a \eqn{K}-fold-CV is performed. See also section "Note" below.} \item{nloo}{Only relevant if \code{cv_method = "LOO"} and \code{validate_search = TRUE}. If \code{nloo > 0} is smaller than the number of all observations, full -LOO-CV is approximated by combining the fast LOO result for the selected -models and \code{nloo} leave-one-out searches using the difference estimator -with simple random sampling (SRS) without replacement (WOR) (Magnusson et -al., 2020). Smaller values lead to faster computation, but higher -uncertainty in the evaluation part. If \code{NULL}, all observations are used -(as by default).} +LOO-CV (i.e., PSIS-LOO CV with \code{validate_search = TRUE} and with \code{nloo = n} where \code{n} denotes the number of all observations) is approximated by +combining the fast (i.e., \code{validate_search = FALSE}) LOO result for the +selected models and \code{nloo} leave-one-out searches using the difference +estimator with simple random sampling (SRS) without replacement (WOR) +(Magnusson et al., 2020). Smaller \code{nloo} values lead to faster computation, +but higher uncertainty in the evaluation part. If \code{NULL}, all observations +are used (as by default).} \item{K}{Only relevant if \code{cv_method = "kfold"} and if \code{cvfits} is \code{NULL} (which is the case for reference model objects created by From 8e563b4cb2bda0bfc97b9683625a412f44fc1ebf Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 5 Jan 2025 21:44:42 +0100 Subject: [PATCH 110/134] make computation of `var_e_i` in `.srs_diff_est_w()` numerically more stable, see --- R/misc.R | 3 +++ R/summary_funs.R | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/R/misc.R b/R/misc.R index 2e82b6583..9010b0294 100644 --- a/R/misc.R +++ b/R/misc.R @@ -15,6 +15,9 @@ nms_y_wobs_test <- function(wobs_nm = "wobs") { } weighted.sd <- function(x, w, na.rm = FALSE) { + if (length(w) == 1 && length(x) > 1) { + w <- rep_len(w, length.out = length(x)) + } if (na.rm) { ind <- !is.na(w) & !is.na(x) n <- sum(ind) diff --git a/R/summary_funs.R b/R/summary_funs.R index ed074bfd8..2ff084dfe 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -631,7 +631,7 @@ get_nfeat_baseline <- function(object, baseline, stat, ...) { # eq (7) est_list$y_hat <- t_pi_tilde + t_e # eq (8) - var_e_i <- m / (m - 1) * (mean(wobs_m * e_i^2) - mean(wobs_m * e_i)^2) + var_e_i <- weighted.sd(e_i, w = wobs_m)^2 est_list$v_y_hat <- N^2 * (1 - m / N) * var_e_i / m # eq (9) first row second `+` should be `-` # Supplementary material eq (6) has this correct From de1cf4dace252a21a646de108e43bcec9d6fb052 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 5 Jan 2025 21:54:27 +0100 Subject: [PATCH 111/134] fix a comment, see --- R/summary_funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 2ff084dfe..fcd5fa555 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -328,7 +328,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, if (!is.null(summaries_baseline)) { mu_baseline <- summaries_baseline$mu } - # Use normal approximation for mse and delta method for rmse and R2 + # Use "exact" standard error for mse and delta method for rmse and R2 if (n_loo < n_full) { # subsampling difference estimator (Magnusson et al., 2020) srs_diffe <- .srs_diff_est_w(y_approx = (summaries_fast$mu - y)^2, From cac6dee94ce7fc9486d056b0f31e75c19160b3a0 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 6 Jan 2025 15:28:30 +0100 Subject: [PATCH 112/134] minor cleaning --- R/summary_funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index fcd5fa555..ceefc407d 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -550,7 +550,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, } } - if (stat %in% c("mse","rmse") && is.null(summaries_baseline)) { + if (stat %in% c("mse", "rmse") && is.null(summaries_baseline)) { # Compute mean and variance in log scale by matching the variance of a # log-normal approximation # https://en.wikipedia.org/wiki/Log-normal_distribution#Arithmetic_moments From 1184a4ee8f15b458cb2ebf55175d6d4440fb3cc1 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 6 Jan 2025 15:40:09 +0100 Subject: [PATCH 113/134] fix a comment, see --- R/summary_funs.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index ceefc407d..f3bbae23d 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -346,7 +346,10 @@ get_stat <- function(summaries, summaries_baseline = NULL, # store for later calculations mse_e <- value if (!is.null(summaries_baseline)) { - # delta=TRUE, variance of difference of two normally distributed + # delta=TRUE, variance of difference of two normally distributed random + # variables (log-normally in case of MSE and RMSE, although the central + # limit theorem would ensure convergence -- probably slower, though -- to + # a normal distribution even for MSE and RMSE) mse_b <- mean(wobs * (mu_baseline - y)^2) var_mse_b <- weighted.sd((mu_baseline - y)^2, wobs)^2 / n_full if (n_loo < n_full) { From a6b79882c9203134d176adc3b9e2ee2ff587cab7 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 6 Jan 2025 20:39:54 +0100 Subject: [PATCH 114/134] replace `mean(y)` with `mean(wobs * y)`, see --- R/summary_funs.R | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index f3bbae23d..0dbee34de 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -377,28 +377,28 @@ get_stat <- function(summaries, summaries_baseline = NULL, value_se <- sqrt(value_se^2 / mse_e / 4) } else if (stat == "R2") { # simple transformation of mse - mse_y <- mean(wobs * (mean(y) - y)^2) + mse_y <- mean(wobs * (mean(wobs * y) - y)^2) value <- 1 - mse_e / mse_y - ifelse(is.null(summaries_baseline), 0, 1 - mse_b / mse_y) # the first-order Taylor approximation of the variance - var_mse_y <- weighted.sd((mean(y) - y)^2, wobs)^2 / n_full + var_mse_y <- weighted.sd((mean(wobs * y) - y)^2, wobs)^2 / n_full if (n_loo < n_full) { mse_e_fast <- mean(wobs * (summaries_fast$mu - y)^2) if (is.null(summaries_baseline)) { srs_diffe <- .srs_diff_est_w(y_approx = ((summaries_fast$mu - y)^2 - mse_e_fast) * - ((mean(y) - y)^2 - mse_y), + ((mean(wobs * y) - y)^2 - mse_y), y = (((mu - y)^2 - mse_e) * - ((mean(y) - y)^2 - mse_y))[loo_inds], + ((mean(wobs * y) - y)^2 - mse_y))[loo_inds], y_idx = loo_inds, wobs = wobs) } else { srs_diffe <- .srs_diff_est_w(y_approx = ((summaries_fast$mu - y)^2 - mse_e_fast - ((mu_baseline - y)^2 - mse_b)) * - ((mean(y) - y)^2 - mse_y), + ((mean(wobs * y) - y)^2 - mse_y), y = (((mu - y)^2 - mse_e - ((mu_baseline - y)^2 - mse_b)) * - ((mean(y) - y)^2 - mse_y))[loo_inds], + ((mean(wobs * y) - y)^2 - mse_y))[loo_inds], y_idx = loo_inds, wobs = wobs) } @@ -406,11 +406,11 @@ get_stat <- function(summaries, summaries_baseline = NULL, } else { if (is.null(summaries_baseline)) { cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e) * - ((mean(y) - y)^2 - mse_y)) / (n_full - 1) + ((mean(wobs * y) - y)^2 - mse_y)) / (n_full - 1) } else { cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e - ((mu_baseline - y)^2 - mse_b)) * - ((mean(y) - y)^2 - mse_y)) / (n_full - 1) + ((mean(wobs * y) - y)^2 - mse_y)) / (n_full - 1) } } # part of delta se comes automatically via mse From e300620f45c03648e73a28fb9e35f195fbbe42ec Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 6 Jan 2025 20:42:10 +0100 Subject: [PATCH 115/134] avoid redundant computations by introducing object `y_mean_w` --- R/summary_funs.R | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 0dbee34de..080f4b3c3 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -376,29 +376,30 @@ get_stat <- function(summaries, summaries_baseline = NULL, # the first-order Taylor approximation of the variance value_se <- sqrt(value_se^2 / mse_e / 4) } else if (stat == "R2") { + y_mean_w <- mean(wobs * y) # simple transformation of mse - mse_y <- mean(wobs * (mean(wobs * y) - y)^2) + mse_y <- mean(wobs * (y_mean_w - y)^2) value <- 1 - mse_e / mse_y - ifelse(is.null(summaries_baseline), 0, 1 - mse_b / mse_y) # the first-order Taylor approximation of the variance - var_mse_y <- weighted.sd((mean(wobs * y) - y)^2, wobs)^2 / n_full + var_mse_y <- weighted.sd((y_mean_w - y)^2, wobs)^2 / n_full if (n_loo < n_full) { mse_e_fast <- mean(wobs * (summaries_fast$mu - y)^2) if (is.null(summaries_baseline)) { srs_diffe <- .srs_diff_est_w(y_approx = ((summaries_fast$mu - y)^2 - mse_e_fast) * - ((mean(wobs * y) - y)^2 - mse_y), + ((y_mean_w - y)^2 - mse_y), y = (((mu - y)^2 - mse_e) * - ((mean(wobs * y) - y)^2 - mse_y))[loo_inds], + ((y_mean_w - y)^2 - mse_y))[loo_inds], y_idx = loo_inds, wobs = wobs) } else { srs_diffe <- .srs_diff_est_w(y_approx = ((summaries_fast$mu - y)^2 - mse_e_fast - ((mu_baseline - y)^2 - mse_b)) * - ((mean(wobs * y) - y)^2 - mse_y), + ((y_mean_w - y)^2 - mse_y), y = (((mu - y)^2 - mse_e - ((mu_baseline - y)^2 - mse_b)) * - ((mean(wobs * y) - y)^2 - mse_y))[loo_inds], + ((y_mean_w - y)^2 - mse_y))[loo_inds], y_idx = loo_inds, wobs = wobs) } @@ -406,11 +407,11 @@ get_stat <- function(summaries, summaries_baseline = NULL, } else { if (is.null(summaries_baseline)) { cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e) * - ((mean(wobs * y) - y)^2 - mse_y)) / (n_full - 1) + ((y_mean_w - y)^2 - mse_y)) / (n_full - 1) } else { cov_mse_e_y <- mean(wobs * ((mu - y)^2 - mse_e - ((mu_baseline - y)^2 - mse_b)) * - ((mean(wobs * y) - y)^2 - mse_y)) / (n_full - 1) + ((y_mean_w - y)^2 - mse_y)) / (n_full - 1) } } # part of delta se comes automatically via mse From 8d2599047b20c1edf18eb1050e128d43ba7033fa Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 6 Jan 2025 20:59:03 +0100 Subject: [PATCH 116/134] use `log1p()` for numerical stability (in `get_stat()`), see --- R/summary_funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 080f4b3c3..1ac7adea5 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -559,7 +559,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, # log-normal approximation # https://en.wikipedia.org/wiki/Log-normal_distribution#Arithmetic_moments mul <- log(value^2 / sqrt(value_se^2 + value^2)) - varl <- log(1 + value_se^2 / value^2) + varl <- log1p(value_se^2 / value^2) lq <- qnorm(alpha_half, mean = mul, sd = sqrt(varl)) uq <- qnorm(one_minus_alpha_half, mean = mul, sd = sqrt(varl)) # Go back to linear scale From 7e6136827034384e8342d7ed41160f02b876c951 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 12 Jan 2025 10:39:01 +0100 Subject: [PATCH 117/134] drop quotes from "exact" in a comment, see --- R/summary_funs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 1ac7adea5..c9f71efdc 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -328,7 +328,7 @@ get_stat <- function(summaries, summaries_baseline = NULL, if (!is.null(summaries_baseline)) { mu_baseline <- summaries_baseline$mu } - # Use "exact" standard error for mse and delta method for rmse and R2 + # Use exact standard error for mse and delta method for rmse and R2 if (n_loo < n_full) { # subsampling difference estimator (Magnusson et al., 2020) srs_diffe <- .srs_diff_est_w(y_approx = (summaries_fast$mu - y)^2, From 9260fd0eda4cf9cef63af9c32e611756bb767b42 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 12 Jan 2025 21:49:09 +0100 Subject: [PATCH 118/134] fix docs for RMSE and R2 --- R/methods.R | 10 +++++++--- man/plot.vsel.Rd | 10 +++++++--- man/summary.vsel.Rd | 10 +++++++--- 3 files changed, 21 insertions(+), 9 deletions(-) diff --git a/R/methods.R b/R/methods.R index 17ae387cb..9fea3697f 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1173,8 +1173,11 @@ plot.vsel <- function( #' * `"mse"`: mean squared error (only available in the situations mentioned #' in section "Details" below). #' * `"rmse"`: root mean squared error (only available in the situations -#' mentioned in section "Details" below). For the corresponding standard error -#' and lower and upper confidence interval bounds, the delta method is used. +#' mentioned in section "Details" below). For the corresponding standard +#' error, the delta method is used. +#' * `"R2"`: R-squared, i.e., coefficient of determination (only available in +#' the situations mentioned in section "Details" below). For the corresponding +#' standard error, the delta method is used. #' * `"acc"` (or its alias, `"pctcorr"`): classification accuracy (only #' available in the situations mentioned in section "Details" below). By #' "classification accuracy", we mean the proportion of correctly classified @@ -1222,7 +1225,8 @@ plot.vsel <- function( #' and `seed` (see [set.seed()], but defaulting to `NA` so that [set.seed()] #' is not called within that function at all). #' -#' @details The `stats` options `"mse"` and `"rmse"` are only available for: +#' @details The `stats` options `"mse"`, `"rmse"`, and `"R2"` are only available +#' for: #' * the traditional projection, #' * the latent projection with `resp_oscale = FALSE`, #' * the latent projection with `resp_oscale = TRUE` in combination with diff --git a/man/plot.vsel.Rd b/man/plot.vsel.Rd index 3ee685bdc..ce96ee898 100644 --- a/man/plot.vsel.Rd +++ b/man/plot.vsel.Rd @@ -61,8 +61,11 @@ of the MLPD. \item \code{"mse"}: mean squared error (only available in the situations mentioned in section "Details" below). \item \code{"rmse"}: root mean squared error (only available in the situations -mentioned in section "Details" below). For the corresponding standard error -and lower and upper confidence interval bounds, the delta method is used. +mentioned in section "Details" below). For the corresponding standard +error, the delta method is used. +\item \code{"R2"}: R-squared, i.e., coefficient of determination (only available in +the situations mentioned in section "Details" below). For the corresponding +standard error, the delta method is used. \item \code{"acc"} (or its alias, \code{"pctcorr"}): classification accuracy (only available in the situations mentioned in section "Details" below). By "classification accuracy", we mean the proportion of correctly classified @@ -191,7 +194,8 @@ available; inferred from \code{\link[=cv_proportions]{cv_proportions()}}). For a see \code{\link[=summary.vsel]{summary.vsel()}} and \code{\link[=performances]{performances()}}. } \details{ -The \code{stats} options \code{"mse"} and \code{"rmse"} are only available for: +The \code{stats} options \code{"mse"}, \code{"rmse"}, and \code{"R2"} are only available +for: \itemize{ \item the traditional projection, \item the latent projection with \code{resp_oscale = FALSE}, diff --git a/man/summary.vsel.Rd b/man/summary.vsel.Rd index 5aaa8191a..61ec97e1d 100644 --- a/man/summary.vsel.Rd +++ b/man/summary.vsel.Rd @@ -51,8 +51,11 @@ of the MLPD. \item \code{"mse"}: mean squared error (only available in the situations mentioned in section "Details" below). \item \code{"rmse"}: root mean squared error (only available in the situations -mentioned in section "Details" below). For the corresponding standard error -and lower and upper confidence interval bounds, the delta method is used. +mentioned in section "Details" below). For the corresponding standard +error, the delta method is used. +\item \code{"R2"}: R-squared, i.e., coefficient of determination (only available in +the situations mentioned in section "Details" below). For the corresponding +standard error, the delta method is used. \item \code{"acc"} (or its alias, \code{"pctcorr"}): classification accuracy (only available in the situations mentioned in section "Details" below). By "classification accuracy", we mean the proportion of correctly classified @@ -125,7 +128,8 @@ results printed at the bottom of the output created by this \code{\link[=summary method, see \code{\link[=performances]{performances()}}. } \details{ -The \code{stats} options \code{"mse"} and \code{"rmse"} are only available for: +The \code{stats} options \code{"mse"}, \code{"rmse"}, and \code{"R2"} are only available +for: \itemize{ \item the traditional projection, \item the latent projection with \code{resp_oscale = FALSE}, From 1e3544a9d1866cde09e32a03aec8fc462a0584c2 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 12 Jan 2025 21:37:15 +0100 Subject: [PATCH 119/134] add `stat = "R2"` to the tests; also take into account that `stat = "rmse"` does not need a PRNG seed anymore (and should produce a point estimate between the CI bounds) --- tests/testthat/helpers/testers.R | 20 ++++++++++++-------- tests/testthat/setup.R | 13 ++++++------- tests/testthat/test_augdat.R | 8 ++++---- tests/testthat/test_methods_vsel.R | 10 +++++----- 4 files changed, 27 insertions(+), 24 deletions(-) diff --git a/tests/testthat/helpers/testers.R b/tests/testthat/helpers/testers.R index e69d86d93..9ca1d8fd1 100644 --- a/tests/testthat/helpers/testers.R +++ b/tests/testthat/helpers/testers.R @@ -2668,8 +2668,9 @@ smmry_sub_tester <- function( if ("lower" %in% type_expected && !is_lat_kfold) { lower_nm <- paste(stats_expected, "lower", sep = ".") for (stat_idx in seq_along(stats_expected)) { - if (!stats_expected[stat_idx] %in% c("rmse", "auc")) { - # RMSE and AUC are excluded here because of PR #347. + if (!stats_expected[stat_idx] %in% c("auc")) { + # AUC is excluded here because of PR #347 (originally, RMSE was excluded + # as well, but PR #496 switched to the delta method for RMSE). expect_true(all(smmry_sub[, stats_mean_name[stat_idx]] >= smmry_sub[, lower_nm[stat_idx]]), info = info_str) @@ -2679,8 +2680,9 @@ smmry_sub_tester <- function( if ("upper" %in% type_expected && !is_lat_kfold) { upper_nm <- paste(stats_expected, "upper", sep = ".") for (stat_idx in seq_along(stats_expected)) { - if (!stats_expected[stat_idx] %in% c("rmse", "auc")) { - # RMSE and AUC are excluded here because of PR #347. + if (!stats_expected[stat_idx] %in% c("auc")) { + # AUC is excluded here because of PR #347 (originally, RMSE was excluded + # as well, but PR #496 switched to the delta method for RMSE). expect_true(all(smmry_sub[, stats_mean_name[stat_idx]] <= smmry_sub[, upper_nm[stat_idx]]), info = info_str) @@ -2756,8 +2758,9 @@ smmry_ref_tester <- function( if ("lower" %in% type_expected && !is_lat_kfold && !from_datafit) { lower_nm <- paste(stats_expected, "lower", sep = ".") for (stat_idx in seq_along(stats_expected)) { - if (!stats_expected[stat_idx] %in% c("rmse", "auc")) { - # RMSE and AUC are excluded here because of PR #347. + if (!stats_expected[stat_idx] %in% c("auc")) { + # AUC is excluded here because of PR #347 (originally, RMSE was excluded + # as well, but PR #496 switched to the delta method for RMSE). expect_true(all(smmry_ref[stats_mean_name[stat_idx]] >= smmry_ref[lower_nm[stat_idx]]), info = info_str) @@ -2767,8 +2770,9 @@ smmry_ref_tester <- function( if ("upper" %in% type_expected && !is_lat_kfold && !from_datafit) { upper_nm <- paste(stats_expected, "upper", sep = ".") for (stat_idx in seq_along(stats_expected)) { - if (!stats_expected[stat_idx] %in% c("rmse", "auc")) { - # RMSE and AUC are excluded here because of PR #347. + if (!stats_expected[stat_idx] %in% c("auc")) { + # AUC is excluded here because of PR #347 (originally, RMSE was excluded + # as well, but PR #496 switched to the delta method for RMSE). expect_true(all(smmry_ref[stats_mean_name[stat_idx]] <= smmry_ref[upper_nm[stat_idx]]), info = info_str) diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 733e6618e..623a33ba5 100755 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -947,11 +947,10 @@ vsel_funs <- nlist("summary.vsel", "plot.vsel", "suggest_size.vsel") # projection (or the latent projection with `resp_oscale = FALSE` or the latent # projection with `resp_oscale = TRUE`, but the latter only in combination with # `$family$cats` being `NULL`): -stats_common <- c("elpd", "mlpd", "gmpd", "mse", "rmse") -# Performance statistics for the binomial() family only, when using the -# traditional projection (or the latent projection with `resp_oscale = TRUE`, -# but the latter only in combination with `$family$cats` being -# `NULL`): +stats_common <- c("elpd", "mlpd", "gmpd", "mse", "rmse", "R2") +# Performance statistics for the binomial() family when using the traditional +# projection (or the latent projection with `resp_oscale = TRUE` and +# `$family$cats` being `NULL`): stats_binom <- c(stats_common, "acc", "auc") # For creating test setups: stats_tst <- list( @@ -1700,7 +1699,7 @@ if (run_vs) { identical, 0L)) smmrys_vs <- lapply(args_smmry_vs, function(args_smmry_vs_i) { - if (any(c("rmse", "auc") %in% args_smmry_vs_i$stats)) { + if (any(c("auc") %in% args_smmry_vs_i$stats)) { smmry_seed <- list(seed = seed3_tst) } else { smmry_seed <- list() @@ -1723,7 +1722,7 @@ if (run_cvvs) { identical, 0L)) smmrys_cvvs <- lapply(args_smmry_cvvs, function(args_smmry_cvvs_i) { - if (any(c("rmse", "auc") %in% args_smmry_cvvs_i$stats)) { + if (any(c("auc") %in% args_smmry_cvvs_i$stats)) { smmry_seed <- list(seed = seed3_tst) } else { smmry_seed <- list() diff --git a/tests/testthat/test_augdat.R b/tests/testthat/test_augdat.R index a33831db1..95c46bf41 100644 --- a/tests/testthat/test_augdat.R +++ b/tests/testthat/test_augdat.R @@ -418,10 +418,10 @@ test_that(paste( # Exclude statistics which are not supported for the augmented-data # projection: smmry_vs_trad$perf_sub <- smmry_vs_trad$perf_sub[ - , -grep("mse|auc", names(smmry_vs_trad$perf_sub)), drop = FALSE + , -grep("mse|R2|auc", names(smmry_vs_trad$perf_sub)), drop = FALSE ] smmry_vs_trad$perf_ref <- smmry_vs_trad$perf_ref[ - -grep("mse|auc", names(smmry_vs_trad$perf_ref)) + -grep("mse|R2|auc", names(smmry_vs_trad$perf_ref)) ] expect_equal(smmry_vs$perf_sub, smmry_vs_trad$perf_sub, tolerance = 1e-6, info = tstsetup) @@ -592,10 +592,10 @@ test_that(paste( # Exclude statistics which are not supported for the augmented-data # projection: smmry_cvvs_trad$perf_sub <- smmry_cvvs_trad$perf_sub[ - , -grep("mse|auc", names(smmry_cvvs_trad$perf_sub)), drop = FALSE + , -grep("mse|R2|auc", names(smmry_cvvs_trad$perf_sub)), drop = FALSE ] smmry_cvvs_trad$perf_ref <- smmry_cvvs_trad$perf_ref[ - -grep("mse|auc", names(smmry_cvvs_trad$perf_ref)) + -grep("mse|R2|auc", names(smmry_cvvs_trad$perf_ref)) ] is_kfold <- identical( args_cvvs[[args_smmry_cvvs[[tstsetup]]$tstsetup_vsel]]$cv_method, diff --git a/tests/testthat/test_methods_vsel.R b/tests/testthat/test_methods_vsel.R index bef80b020..d5c0523dc 100644 --- a/tests/testthat/test_methods_vsel.R +++ b/tests/testthat/test_methods_vsel.R @@ -155,7 +155,7 @@ test_that("performances.vsel() is a shortcut", { skip_if_not(run_cvvs) for (tstsetup in names(smmrys_vs)) { args_smmry_i <- args_smmry_vs[[tstsetup]] - if (any(c("rmse", "auc") %in% args_smmry_i$stats)) { + if (any(c("auc") %in% args_smmry_i$stats)) { smmry_seed <- list(seed = seed3_tst) } else { smmry_seed <- list() @@ -169,7 +169,7 @@ test_that("performances.vsel() is a shortcut", { } for (tstsetup in names(smmrys_cvvs)) { args_smmry_i <- args_smmry_cvvs[[tstsetup]] - if (any(c("rmse", "auc") %in% args_smmry_i$stats)) { + if (any(c("auc") %in% args_smmry_i$stats)) { smmry_seed <- list(seed = seed3_tst) } else { smmry_seed <- list() @@ -239,7 +239,7 @@ test_that(paste( skip_if_not(run_vs) for (tstsetup in head(names(smmrys_vs), 1)) { args_smmry_vs_i <- args_smmry_vs[[tstsetup]] - if (any(c("rmse", "auc") %in% args_smmry_vs_i$stats)) { + if (any(c("auc") %in% args_smmry_vs_i$stats)) { smmry_seed <- list(seed = seed3_tst) } else { smmry_seed <- list() @@ -264,7 +264,7 @@ test_that(paste( skip_if_not(run_cvvs) for (tstsetup in head(names(smmrys_cvvs), 1)) { args_smmry_cvvs_i <- args_smmry_cvvs[[tstsetup]] - if (any(c("rmse", "auc") %in% args_smmry_cvvs_i$stats)) { + if (any(c("auc") %in% args_smmry_cvvs_i$stats)) { smmry_seed <- list(seed = seed3_tst) } else { smmry_seed <- list() @@ -527,7 +527,7 @@ test_that("`stat` works", { "common_stats")) stat_vec <- stats_tst[[stat_crr_nm]]$stats for (stat_crr in stat_vec) { - if (stat_crr %in% c("rmse", "auc")) { + if (stat_crr %in% c("auc")) { suggsize_seed <- seed3_tst } else { suggsize_seed <- NULL From f132e706c27f8970fe3f8a9b6fe5edf8ac2a6f5a Mon Sep 17 00:00:00 2001 From: fweber144 Date: Thu, 16 Jan 2025 15:39:42 +0100 Subject: [PATCH 120/134] set a negative squared standard error which is numerically equal to zero to a value of zero; this was necessary due to a failing `stat = "R2"` test for `datafit`s where such negative squared standard errors numerically equal to zero occurred --- R/summary_funs.R | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index c9f71efdc..ebf8374f0 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -419,9 +419,17 @@ get_stat <- function(summaries, summaries_baseline = NULL, # delta=TRUE mse_e <- mse_e - mse_b } - value_se <- sqrt((value_se^2 - - 2 * mse_e / mse_y * cov_mse_e_y + - (mse_e / mse_y)^2 * var_mse_y) / mse_y^2) + value_se_sq <- (value_se^2 - + 2 * mse_e / mse_y * cov_mse_e_y + + (mse_e / mse_y)^2 * var_mse_y) / mse_y^2 + if (!is.na(value_se_sq) && sign(value_se_sq) == -1) { + if (abs(value_se_sq) < sqrt(.Machine$double.eps)) { + value_se_sq <- 0 + } else { + stop("Negative (and numerically non-zero) `value_se_sq`.") + } + } + value_se <- sqrt(value_se_sq) } } else if (stat %in% c("acc", "pctcorr", "auc")) { y <- y_wobs_test$y From f2992dd1387c06bdbfc391a428e6ce6d66f9ecd8 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 12 Jan 2025 20:42:54 +0100 Subject: [PATCH 121/134] fix first-order Taylor approximation of the variance (delta method) for RMSE in the case `!is.null(summaries_baseline)`, see --- R/summary_funs.R | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index ebf8374f0..4653da246 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -366,7 +366,9 @@ get_stat <- function(summaries, summaries_baseline = NULL, cov_mse_e_b <- mean(wobs * ((mu - y)^2 - mse_e) * ((mu_baseline - y)^2 - mse_b)) / (n_full - 1) } - value_se <- sqrt(value_se^2 - 2 * cov_mse_e_b + var_mse_b) + if (stat != "rmse") { + value_se <- sqrt(value_se^2 - 2 * cov_mse_e_b + var_mse_b) + } } if (stat == "mse") { value <- mse_e - ifelse(is.null(summaries_baseline), 0, mse_b) @@ -374,7 +376,13 @@ get_stat <- function(summaries, summaries_baseline = NULL, # simple transformation of mse value <- sqrt(mse_e) - ifelse(is.null(summaries_baseline), 0, sqrt(mse_b)) # the first-order Taylor approximation of the variance - value_se <- sqrt(value_se^2 / mse_e / 4) + if (is.null(summaries_baseline)) { + value_se <- sqrt(value_se^2 / mse_e / 4) + } else { + value_se <- sqrt((value_se^2 / mse_e - + 2 * cov_mse_e_b / sqrt(mse_e * mse_b) + + var_mse_b / mse_b) / 4) + } } else if (stat == "R2") { y_mean_w <- mean(wobs * y) # simple transformation of mse From 65713b1e18259b7c8b458b0fbfffd5f5b1d30571 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Tue, 21 Jan 2025 21:35:15 +0100 Subject: [PATCH 122/134] change wording in a comment, see --- R/summary_funs.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 4653da246..a63b326d6 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -346,8 +346,8 @@ get_stat <- function(summaries, summaries_baseline = NULL, # store for later calculations mse_e <- value if (!is.null(summaries_baseline)) { - # delta=TRUE, variance of difference of two normally distributed random - # variables (log-normally in case of MSE and RMSE, although the central + # delta=TRUE, variance of difference of two normally distributed + # quantities (log-normally in case of MSE and RMSE, although the central # limit theorem would ensure convergence -- probably slower, though -- to # a normal distribution even for MSE and RMSE) mse_b <- mean(wobs * (mu_baseline - y)^2) From 3108b02f1548a0b8a54a17d0552f5f4e56f00924 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 31 Jan 2025 20:10:54 +0100 Subject: [PATCH 123/134] subsampled LOO and AUC: switch from warning to error, see --- R/summary_funs.R | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index a63b326d6..1f5992ece 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -93,11 +93,13 @@ weighted_summary_means <- function(y_wobs_test, family, wdraws, mu, dis, cl_ref, summaries_ref <- varsel$summaries$ref summaries_sub <- varsel$summaries$sub summaries_fast_sub <- varsel$summaries_fast$sub - if (!is.null(summaries_fast_sub)) { - if (any(stats %in% c("auc"))) { - warning("Subsampling LOO with AUC not implemented. Using fast LOO for ", - "submodel AUC.") - } + if (!is.null(summaries_fast_sub) && any(stats %in% c("auc"))) { + stop("Subsampled LOO-CV with AUC not implemented. Alternatives using ", + "`validate_search = TRUE` are full (i.e., non-subsampled) LOO-CV and ", + "K-fold CV. Otherwise, results from `validate_search = FALSE` (which ", + "often already exist at this point of the workflow) can be used, ", + "with the downside that the search part is not cross-validated in ", + "that case.") } if (!varsel$refmodel$family$for_latent && !resp_oscale) { From dd854b620383fc790fcbbfc88fc58a7e3c25ec15 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 31 Jan 2025 20:54:40 +0100 Subject: [PATCH 124/134] docs: mention that the `stats` option `"auc"` is not supported in case of subsampled LOO-CV, see --- R/cv_varsel.R | 18 ++++++++++-------- R/methods.R | 7 ++++++- man/cv_varsel.Rd | 16 +++++++++------- man/plot.vsel.Rd | 7 ++++++- man/summary.vsel.Rd | 7 ++++++- 5 files changed, 37 insertions(+), 18 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 1d36456ad..df704200f 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -22,14 +22,16 @@ #' performed. See also section "Note" below. #' @param nloo Only relevant if `cv_method = "LOO"` and `validate_search = #' TRUE`. If `nloo > 0` is smaller than the number of all observations, full -#' LOO-CV (i.e., PSIS-LOO CV with `validate_search = TRUE` and with `nloo = -#' n` where `n` denotes the number of all observations) is approximated by -#' combining the fast (i.e., `validate_search = FALSE`) LOO result for the -#' selected models and `nloo` leave-one-out searches using the difference -#' estimator with simple random sampling (SRS) without replacement (WOR) -#' (Magnusson et al., 2020). Smaller `nloo` values lead to faster computation, -#' but higher uncertainty in the evaluation part. If `NULL`, all observations -#' are used (as by default). +#' LOO-CV (i.e., PSIS-LOO CV with `validate_search = TRUE` and with `nloo = n` +#' where `n` denotes the number of all observations) is approximated by +#' subsampled LOO-CV, i.e., by combining the fast (i.e., `validate_search = +#' FALSE`) LOO result for the selected models and `nloo` leave-one-out +#' searches using the difference estimator with simple random sampling (SRS) +#' without replacement (WOR) (Magnusson et al., 2020). Smaller `nloo` values +#' lead to faster computation, but higher uncertainty in the evaluation part. +#' If `NULL`, all observations are used (as by default). Note that performance +#' statistic `"auc"` (see argument `stats` of [summary.vsel()] and +#' [plot.vsel()]) is not supported in case of subsampled LOO-CV. #' @param K Only relevant if `cv_method = "kfold"` and if `cvfits` is `NULL` #' (which is the case for reference model objects created by #' [get_refmodel.stanreg()] or [brms::get_refmodel.brmsfit()]). Number of diff --git a/R/methods.R b/R/methods.R index 9fea3697f..fc6ceea25 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1186,7 +1186,9 @@ plot.vsel <- function( #' ("classification") for an observation. #' * `"auc"`: area under the ROC curve (only available in the situations #' mentioned in section "Details" below). For the corresponding standard error -#' and lower and upper confidence interval bounds, bootstrapping is used. +#' and lower and upper confidence interval bounds, bootstrapping is used. Not +#' supported in case of subsampled LOO-CV (see argument `nloo` of +#' [cv_varsel()]). #' @param type One or more items from `"mean"`, `"se"`, `"lower"`, `"upper"`, #' `"diff"`, and `"diff.se"` indicating which of these to compute for each #' item from `stats` (mean, standard error, lower and upper confidence @@ -1248,6 +1250,9 @@ plot.vsel <- function( #' latent projection with `resp_oscale = TRUE` in combination with #' `$family$cats` being `NULL`. #' +#' Note that the `stats` option `"auc"` is not supported in case of subsampled +#' LOO-CV (see argument `nloo` of [cv_varsel()]). +#' #' @return An object of class `vselsummary`. The elements of this object are not #' meant to be accessed directly but instead via helper functions #' ([print.vselsummary()] and [performances.vselsummary()]). diff --git a/man/cv_varsel.Rd b/man/cv_varsel.Rd index ac7328ee5..6890de022 100644 --- a/man/cv_varsel.Rd +++ b/man/cv_varsel.Rd @@ -68,13 +68,15 @@ contrast to a standard LOO-CV). In the \code{"kfold"} case, a \eqn{K}-fold-CV is performed. See also section "Note" below.} \item{nloo}{Only relevant if \code{cv_method = "LOO"} and \code{validate_search = TRUE}. If \code{nloo > 0} is smaller than the number of all observations, full -LOO-CV (i.e., PSIS-LOO CV with \code{validate_search = TRUE} and with \code{nloo = n} where \code{n} denotes the number of all observations) is approximated by -combining the fast (i.e., \code{validate_search = FALSE}) LOO result for the -selected models and \code{nloo} leave-one-out searches using the difference -estimator with simple random sampling (SRS) without replacement (WOR) -(Magnusson et al., 2020). Smaller \code{nloo} values lead to faster computation, -but higher uncertainty in the evaluation part. If \code{NULL}, all observations -are used (as by default).} +LOO-CV (i.e., PSIS-LOO CV with \code{validate_search = TRUE} and with \code{nloo = n} +where \code{n} denotes the number of all observations) is approximated by +subsampled LOO-CV, i.e., by combining the fast (i.e., \code{validate_search = FALSE}) LOO result for the selected models and \code{nloo} leave-one-out +searches using the difference estimator with simple random sampling (SRS) +without replacement (WOR) (Magnusson et al., 2020). Smaller \code{nloo} values +lead to faster computation, but higher uncertainty in the evaluation part. +If \code{NULL}, all observations are used (as by default). Note that performance +statistic \code{"auc"} (see argument \code{stats} of \code{\link[=summary.vsel]{summary.vsel()}} and +\code{\link[=plot.vsel]{plot.vsel()}}) is not supported in case of subsampled LOO-CV.} \item{K}{Only relevant if \code{cv_method = "kfold"} and if \code{cvfits} is \code{NULL} (which is the case for reference model objects created by diff --git a/man/plot.vsel.Rd b/man/plot.vsel.Rd index ce96ee898..6edc4fbd2 100644 --- a/man/plot.vsel.Rd +++ b/man/plot.vsel.Rd @@ -74,7 +74,9 @@ probability (the probabilities are model-based) is taken as the prediction ("classification") for an observation. \item \code{"auc"}: area under the ROC curve (only available in the situations mentioned in section "Details" below). For the corresponding standard error -and lower and upper confidence interval bounds, bootstrapping is used. +and lower and upper confidence interval bounds, bootstrapping is used. Not +supported in case of subsampled LOO-CV (see argument \code{nloo} of +\code{\link[=cv_varsel]{cv_varsel()}}). }} \item{deltas}{If \code{TRUE}, the submodel statistics are estimated relatively to @@ -222,6 +224,9 @@ The \code{stats} option \code{"auc"} is only available for: latent projection with \code{resp_oscale = TRUE} in combination with \verb{$family$cats} being \code{NULL}. } + +Note that the \code{stats} option \code{"auc"} is not supported in case of subsampled +LOO-CV (see argument \code{nloo} of \code{\link[=cv_varsel]{cv_varsel()}}). } \section{Horizontal lines}{ As long as the reference model's performance is computable, it is always diff --git a/man/summary.vsel.Rd b/man/summary.vsel.Rd index 61ec97e1d..5db51d0a9 100644 --- a/man/summary.vsel.Rd +++ b/man/summary.vsel.Rd @@ -64,7 +64,9 @@ probability (the probabilities are model-based) is taken as the prediction ("classification") for an observation. \item \code{"auc"}: area under the ROC curve (only available in the situations mentioned in section "Details" below). For the corresponding standard error -and lower and upper confidence interval bounds, bootstrapping is used. +and lower and upper confidence interval bounds, bootstrapping is used. Not +supported in case of subsampled LOO-CV (see argument \code{nloo} of +\code{\link[=cv_varsel]{cv_varsel()}}). }} \item{type}{One or more items from \code{"mean"}, \code{"se"}, \code{"lower"}, \code{"upper"}, @@ -156,6 +158,9 @@ The \code{stats} option \code{"auc"} is only available for: latent projection with \code{resp_oscale = TRUE} in combination with \verb{$family$cats} being \code{NULL}. } + +Note that the \code{stats} option \code{"auc"} is not supported in case of subsampled +LOO-CV (see argument \code{nloo} of \code{\link[=cv_varsel]{cv_varsel()}}). } \examples{ \dontshow{if (requireNamespace("rstanarm", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} From f9fa760df1d31e257075b6ed4d9156ce1f1313cd Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 31 Jan 2025 21:21:37 +0100 Subject: [PATCH 125/134] docs: mention log-normal approximation for MSE and RMSE, see --- R/methods.R | 46 ++++++++++++++++++++++----------------------- man/plot.vsel.Rd | 13 ++++++++----- man/suggest_size.Rd | 26 ++++++++++++------------- man/summary.vsel.Rd | 19 ++++++++++--------- 4 files changed, 54 insertions(+), 50 deletions(-) diff --git a/R/methods.R b/R/methods.R index fc6ceea25..393d56701 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1171,10 +1171,14 @@ plot.vsel <- function( #' confidence interval bounds are the exponentiated confidence interval bounds #' of the MLPD. #' * `"mse"`: mean squared error (only available in the situations mentioned -#' in section "Details" below). +#' in section "Details" below). For the corresponding confidence interval, a +#' log-normal approximation is used if `deltas` is `FALSE` and a normal +#' approximation is used if `deltas` is `TRUE`. #' * `"rmse"`: root mean squared error (only available in the situations #' mentioned in section "Details" below). For the corresponding standard -#' error, the delta method is used. +#' error, the delta method is used. For the corresponding confidence interval, +#' a log-normal approximation is used if `deltas` is `FALSE` and a normal +#' approximation is used if `deltas` is `TRUE`. #' * `"R2"`: R-squared, i.e., coefficient of determination (only available in #' the situations mentioned in section "Details" below). For the corresponding #' standard error, the delta method is used. @@ -1196,10 +1200,8 @@ plot.vsel <- function( #' reference model, and standard error of this difference, respectively; note #' that for the GMPD, `"diff"`, and `"diff.se"` actually refer to the ratio #' vs. the reference model, not the difference). The confidence interval -#' bounds belong to normal-approximation (or bootstrap or exponentiated -#' normal-approximation; see argument `stats`) confidence intervals with -#' (nominal) coverage `1 - alpha`. Items `"diff"` and `"diff.se"` are only -#' supported if `deltas` is `FALSE`. +#' bounds belong to confidence intervals with (nominal) coverage `1 - alpha`. +#' Items `"diff"` and `"diff.se"` are only supported if `deltas` is `FALSE`. #' @param deltas If `TRUE`, the submodel statistics are estimated relatively to #' the baseline model (see argument `baseline`). For the GMPD, the term #' "relatively" refers to the ratio vs. the baseline model (i.e., the submodel @@ -1207,9 +1209,8 @@ plot.vsel <- function( #' "relatively" refers to the difference from the baseline model (i.e., the #' submodel statistic minus the baseline model statistic). #' @param alpha A number determining the (nominal) coverage `1 - alpha` of the -#' normal-approximation (or bootstrap or exponentiated normal-approximation; -#' see argument `stats`) confidence intervals. For example, in case of the -#' normal approximation, `alpha = 2 * pnorm(-1)` corresponds to a confidence +#' confidence intervals. For example, in case of a normal-approximation +#' confidence interval, `alpha = 2 * pnorm(-1)` corresponds to a confidence #' interval stretching by one standard error on either side of the point #' estimate. #' @param baseline For [summary.vsel()]: Only relevant if `deltas` is `TRUE`. @@ -1551,7 +1552,8 @@ print.vsel <- function(x, digits = getOption("projpred.digits", 2), ...) { #' @param object An object of class `vsel` (returned by [varsel()] or #' [cv_varsel()]). #' @param stat Performance statistic (i.e., utility or loss) used for the -#' decision. See argument `stats` of [summary.vsel()] for possible choices. +#' decision. See argument `stats` of [summary.vsel()] and [plot.vsel()] for +#' possible choices. #' @param pct A number giving the proportion (*not* percents) of the *relative* #' null model utility one is willing to sacrifice. See section "Details" below #' for more information. @@ -1575,13 +1577,11 @@ print.vsel <- function(x, digits = getOption("projpred.digits", 2), ...) { #' @details In general (beware of special cases below), the suggested model #' size is the smallest model size \eqn{j \in \{0, 1, ..., #' \texttt{nterms\_max}\}}{{j = 0, 1, ..., nterms_max}} for which either the -#' lower or upper bound (depending on argument `type`) of the -#' normal-approximation (or bootstrap or exponentiated normal-approximation; -#' see argument `stat`) confidence interval (with nominal coverage `1 - -#' alpha`; see argument `alpha` of [summary.vsel()]) for \eqn{U_j - -#' U_{\mathrm{base}}}{U_j - U_base} (with \eqn{U_j} denoting the \eqn{j}-th -#' submodel's true utility and \eqn{U_{\mathrm{base}}}{U_base} denoting the -#' baseline model's true utility) +#' lower or upper bound (depending on argument `type`) of the confidence +#' interval (with nominal coverage `1 - alpha`; see argument `alpha` of +#' [summary.vsel()]) for \eqn{U_j - U_{\mathrm{base}}}{U_j - U_base} (with +#' \eqn{U_j} denoting the \eqn{j}-th submodel's true utility and +#' \eqn{U_{\mathrm{base}}}{U_base} denoting the baseline model's true utility) #' falls above (or is equal to) \deqn{\texttt{pct} \cdot (u_0 - #' u_{\mathrm{base}})}{pct * (u_0 - u_base)} where \eqn{u_0} denotes the null #' model's estimated utility and \eqn{u_{\mathrm{base}}}{u_base} the baseline @@ -1631,15 +1631,15 @@ print.vsel <- function(x, digits = getOption("projpred.digits", 2), ...) { #' `!is.na(thres_elpd)` with `stat %in% c("elpd", "mlpd", "gmpd")`), `alpha = #' 2 * pnorm(-1)`, `pct = 0`, and `type = "upper"` means that we select the #' smallest model size for which the upper bound of the `1 - 2 * pnorm(-1)` -#' (approximately 68.3%) confidence interval for \eqn{U_j - +#' (approximately 68.3 %) confidence interval for \eqn{U_j - #' U_{\mathrm{base}}}{U_j - U_base} #' (\eqn{\frac{U^\ast_j}{U^\ast_{\mathrm{base}}}}{U^*_j / U^*_base} in case of #' the GMPD) exceeds (or is equal to) zero (one in case of the GMPD), that is -#' (if `stat` is a performance statistic for which the normal approximation is -#' used, not the bootstrap and not the exponentiated normal approximation), -#' for which the submodel's utility estimate is at most one standard error -#' smaller than the baseline model's utility estimate (with that standard -#' error referring to the utility *difference*). +#' (if `stat` is a performance statistic for which a normal-approximation +#' confidence interval is used, see argument `stats` of [summary.vsel()] and +#' [plot.vsel()]), for which the submodel's utility estimate is at most one +#' standard error smaller than the baseline model's utility estimate (with +#' that standard error referring to the utility *difference*). #' #' Apart from the two [summary.vsel()] arguments mentioned above (`alpha` and #' `baseline`), `resp_oscale` is another important [summary.vsel()] argument diff --git a/man/plot.vsel.Rd b/man/plot.vsel.Rd index 6edc4fbd2..69d318d96 100644 --- a/man/plot.vsel.Rd +++ b/man/plot.vsel.Rd @@ -59,10 +59,14 @@ interval type is "exponentiated normal approximation" because the confidence interval bounds are the exponentiated confidence interval bounds of the MLPD. \item \code{"mse"}: mean squared error (only available in the situations mentioned -in section "Details" below). +in section "Details" below). For the corresponding confidence interval, a +log-normal approximation is used if \code{deltas} is \code{FALSE} and a normal +approximation is used if \code{deltas} is \code{TRUE}. \item \code{"rmse"}: root mean squared error (only available in the situations mentioned in section "Details" below). For the corresponding standard -error, the delta method is used. +error, the delta method is used. For the corresponding confidence interval, +a log-normal approximation is used if \code{deltas} is \code{FALSE} and a normal +approximation is used if \code{deltas} is \code{TRUE}. \item \code{"R2"}: R-squared, i.e., coefficient of determination (only available in the situations mentioned in section "Details" below). For the corresponding standard error, the delta method is used. @@ -87,9 +91,8 @@ statistic divided by the baseline model statistic). For all other \code{stats}, submodel statistic minus the baseline model statistic).} \item{alpha}{A number determining the (nominal) coverage \code{1 - alpha} of the -normal-approximation (or bootstrap or exponentiated normal-approximation; -see argument \code{stats}) confidence intervals. For example, in case of the -normal approximation, \code{alpha = 2 * pnorm(-1)} corresponds to a confidence +confidence intervals. For example, in case of a normal-approximation +confidence interval, \code{alpha = 2 * pnorm(-1)} corresponds to a confidence interval stretching by one standard error on either side of the point estimate.} diff --git a/man/suggest_size.Rd b/man/suggest_size.Rd index 3353a2358..460b5801e 100644 --- a/man/suggest_size.Rd +++ b/man/suggest_size.Rd @@ -27,7 +27,8 @@ See section "Details" below for some important arguments which may be passed here.} \item{stat}{Performance statistic (i.e., utility or loss) used for the -decision. See argument \code{stats} of \code{\link[=summary.vsel]{summary.vsel()}} for possible choices.} +decision. See argument \code{stats} of \code{\link[=summary.vsel]{summary.vsel()}} and \code{\link[=plot.vsel]{plot.vsel()}} for +possible choices.} \item{pct}{A number giving the proportion (\emph{not} percents) of the \emph{relative} null model utility one is willing to sacrifice. See section "Details" below @@ -67,12 +68,11 @@ decision based on what is most appropriate for the problem at hand. In general (beware of special cases below), the suggested model size is the smallest model size \eqn{j \in \{0, 1, ..., \texttt{nterms\_max}\}}{{j = 0, 1, ..., nterms_max}} for which either the -lower or upper bound (depending on argument \code{type}) of the -normal-approximation (or bootstrap or exponentiated normal-approximation; -see argument \code{stat}) confidence interval (with nominal coverage \code{1 - alpha}; see argument \code{alpha} of \code{\link[=summary.vsel]{summary.vsel()}}) for \eqn{U_j - - U_{\mathrm{base}}}{U_j - U_base} (with \eqn{U_j} denoting the \eqn{j}-th -submodel's true utility and \eqn{U_{\mathrm{base}}}{U_base} denoting the -baseline model's true utility) +lower or upper bound (depending on argument \code{type}) of the confidence +interval (with nominal coverage \code{1 - alpha}; see argument \code{alpha} of +\code{\link[=summary.vsel]{summary.vsel()}}) for \eqn{U_j - U_{\mathrm{base}}}{U_j - U_base} (with +\eqn{U_j} denoting the \eqn{j}-th submodel's true utility and +\eqn{U_{\mathrm{base}}}{U_base} denoting the baseline model's true utility) falls above (or is equal to) \deqn{\texttt{pct} \cdot (u_0 - u_{\mathrm{base}})}{pct * (u_0 - u_base)} where \eqn{u_0} denotes the null model's estimated utility and \eqn{u_{\mathrm{base}}}{u_base} the baseline @@ -120,15 +120,15 @@ above \emph{or} \eqn{\frac{u^\ast_j}{u^\ast_{\mathrm{base}}} > For example (disregarding the special extensions in case of \code{!is.na(thres_elpd)} with \code{stat \%in\% c("elpd", "mlpd", "gmpd")}), \code{alpha = 2 * pnorm(-1)}, \code{pct = 0}, and \code{type = "upper"} means that we select the smallest model size for which the upper bound of the \code{1 - 2 * pnorm(-1)} -(approximately 68.3\%) confidence interval for \eqn{U_j - +(approximately 68.3 \%) confidence interval for \eqn{U_j - U_{\mathrm{base}}}{U_j - U_base} (\eqn{\frac{U^\ast_j}{U^\ast_{\mathrm{base}}}}{U^*_j / U^*_base} in case of the GMPD) exceeds (or is equal to) zero (one in case of the GMPD), that is -(if \code{stat} is a performance statistic for which the normal approximation is -used, not the bootstrap and not the exponentiated normal approximation), -for which the submodel's utility estimate is at most one standard error -smaller than the baseline model's utility estimate (with that standard -error referring to the utility \emph{difference}). +(if \code{stat} is a performance statistic for which a normal-approximation +confidence interval is used, see argument \code{stats} of \code{\link[=summary.vsel]{summary.vsel()}} and +\code{\link[=plot.vsel]{plot.vsel()}}), for which the submodel's utility estimate is at most one +standard error smaller than the baseline model's utility estimate (with +that standard error referring to the utility \emph{difference}). Apart from the two \code{\link[=summary.vsel]{summary.vsel()}} arguments mentioned above (\code{alpha} and \code{baseline}), \code{resp_oscale} is another important \code{\link[=summary.vsel]{summary.vsel()}} argument diff --git a/man/summary.vsel.Rd b/man/summary.vsel.Rd index 5db51d0a9..5534f4142 100644 --- a/man/summary.vsel.Rd +++ b/man/summary.vsel.Rd @@ -49,10 +49,14 @@ interval type is "exponentiated normal approximation" because the confidence interval bounds are the exponentiated confidence interval bounds of the MLPD. \item \code{"mse"}: mean squared error (only available in the situations mentioned -in section "Details" below). +in section "Details" below). For the corresponding confidence interval, a +log-normal approximation is used if \code{deltas} is \code{FALSE} and a normal +approximation is used if \code{deltas} is \code{TRUE}. \item \code{"rmse"}: root mean squared error (only available in the situations mentioned in section "Details" below). For the corresponding standard -error, the delta method is used. +error, the delta method is used. For the corresponding confidence interval, +a log-normal approximation is used if \code{deltas} is \code{FALSE} and a normal +approximation is used if \code{deltas} is \code{TRUE}. \item \code{"R2"}: R-squared, i.e., coefficient of determination (only available in the situations mentioned in section "Details" below). For the corresponding standard error, the delta method is used. @@ -76,10 +80,8 @@ interval bounds, mean difference to the corresponding statistic of the reference model, and standard error of this difference, respectively; note that for the GMPD, \code{"diff"}, and \code{"diff.se"} actually refer to the ratio vs. the reference model, not the difference). The confidence interval -bounds belong to normal-approximation (or bootstrap or exponentiated -normal-approximation; see argument \code{stats}) confidence intervals with -(nominal) coverage \code{1 - alpha}. Items \code{"diff"} and \code{"diff.se"} are only -supported if \code{deltas} is \code{FALSE}.} +bounds belong to confidence intervals with (nominal) coverage \code{1 - alpha}. +Items \code{"diff"} and \code{"diff.se"} are only supported if \code{deltas} is \code{FALSE}.} \item{deltas}{If \code{TRUE}, the submodel statistics are estimated relatively to the baseline model (see argument \code{baseline}). For the GMPD, the term @@ -89,9 +91,8 @@ statistic divided by the baseline model statistic). For all other \code{stats}, submodel statistic minus the baseline model statistic).} \item{alpha}{A number determining the (nominal) coverage \code{1 - alpha} of the -normal-approximation (or bootstrap or exponentiated normal-approximation; -see argument \code{stats}) confidence intervals. For example, in case of the -normal approximation, \code{alpha = 2 * pnorm(-1)} corresponds to a confidence +confidence intervals. For example, in case of a normal-approximation +confidence interval, \code{alpha = 2 * pnorm(-1)} corresponds to a confidence interval stretching by one standard error on either side of the point estimate.} From b92cc189da03d2851705097a37524642e0cc44ba Mon Sep 17 00:00:00 2001 From: fweber144 Date: Fri, 31 Jan 2025 21:30:44 +0100 Subject: [PATCH 126/134] `plot.vsel()`: mention log-normal approximation for MSE and RMSE, see --- R/methods.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/R/methods.R b/R/methods.R index 393d56701..d4f76a406 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1069,7 +1069,10 @@ plot.vsel <- function( ci_type <- "bootstrap " } else if (all(stats %in% c("gmpd"))) { ci_type <- "exponentiated normal-approximation " - } else if (all(!stats %in% c("auc", "gmpd"))) { + } else if (all(stats %in% c("mse", "rmse")) && !deltas) { + ci_type <- "log-normal-approximation " + } else if (all(!stats %in% c("auc", "gmpd", "mse", "rmse")) || + (all(!stats %in% c("auc", "gmpd")) && deltas)) { ci_type <- "normal-approximation " } else { ci_type <- "" From b9af6c56d43d42ace5f2148d625015fa0272ad4b Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sat, 1 Feb 2025 06:45:24 +0100 Subject: [PATCH 127/134] docs: `baseline = "best"` is not supported in case of subsampled LOO-CV --- R/cv_varsel.R | 4 +++- R/methods.R | 3 ++- man/cv_varsel.Rd | 4 +++- man/plot.vsel.Rd | 2 +- man/summary.vsel.Rd | 2 +- 5 files changed, 10 insertions(+), 5 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index df704200f..182309a92 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -31,7 +31,9 @@ #' lead to faster computation, but higher uncertainty in the evaluation part. #' If `NULL`, all observations are used (as by default). Note that performance #' statistic `"auc"` (see argument `stats` of [summary.vsel()] and -#' [plot.vsel()]) is not supported in case of subsampled LOO-CV. +#' [plot.vsel()]) is not supported in case of subsampled LOO-CV. Furthermore, +#' option `"best"` for argument `baseline` of [summary.vsel()] and +#' [plot.vsel()] is not supported in case of subsampled LOO-CV. #' @param K Only relevant if `cv_method = "kfold"` and if `cvfits` is `NULL` #' (which is the case for reference model objects created by #' [get_refmodel.stanreg()] or [brms::get_refmodel.brmsfit()]). Number of diff --git a/R/methods.R b/R/methods.R index d4f76a406..2ea886961 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1219,7 +1219,8 @@ plot.vsel <- function( #' @param baseline For [summary.vsel()]: Only relevant if `deltas` is `TRUE`. #' For [plot.vsel()]: Always relevant. Either `"ref"` or `"best"`, indicating #' whether the baseline is the reference model or the best submodel found (in -#' terms of `stats[1]`), respectively. +#' terms of `stats[1]`), respectively. In case of subsampled LOO-CV, `baseline +#' = "best"` is not supported. #' @param resp_oscale Only relevant for the latent projection. A single logical #' value indicating whether to calculate the performance statistics on the #' original response scale (`TRUE`) or on latent scale (`FALSE`). diff --git a/man/cv_varsel.Rd b/man/cv_varsel.Rd index 6890de022..085607111 100644 --- a/man/cv_varsel.Rd +++ b/man/cv_varsel.Rd @@ -76,7 +76,9 @@ without replacement (WOR) (Magnusson et al., 2020). Smaller \code{nloo} values lead to faster computation, but higher uncertainty in the evaluation part. If \code{NULL}, all observations are used (as by default). Note that performance statistic \code{"auc"} (see argument \code{stats} of \code{\link[=summary.vsel]{summary.vsel()}} and -\code{\link[=plot.vsel]{plot.vsel()}}) is not supported in case of subsampled LOO-CV.} +\code{\link[=plot.vsel]{plot.vsel()}}) is not supported in case of subsampled LOO-CV. Furthermore, +option \code{"best"} for argument \code{baseline} of \code{\link[=summary.vsel]{summary.vsel()}} and +\code{\link[=plot.vsel]{plot.vsel()}} is not supported in case of subsampled LOO-CV.} \item{K}{Only relevant if \code{cv_method = "kfold"} and if \code{cvfits} is \code{NULL} (which is the case for reference model objects created by diff --git a/man/plot.vsel.Rd b/man/plot.vsel.Rd index 69d318d96..89aeb43c8 100644 --- a/man/plot.vsel.Rd +++ b/man/plot.vsel.Rd @@ -99,7 +99,7 @@ estimate.} \item{baseline}{For \code{\link[=summary.vsel]{summary.vsel()}}: Only relevant if \code{deltas} is \code{TRUE}. For \code{\link[=plot.vsel]{plot.vsel()}}: Always relevant. Either \code{"ref"} or \code{"best"}, indicating whether the baseline is the reference model or the best submodel found (in -terms of \code{stats[1]}), respectively.} +terms of \code{stats[1]}), respectively. In case of subsampled LOO-CV, \code{baseline = "best"} is not supported.} \item{thres_elpd}{Only relevant if \code{any(stats \%in\% c("elpd", "mlpd", "gmpd"))}. The threshold for the ELPD difference (taking the submodel's ELPD minus the baseline model's ELPD) above which the submodel's ELPD is diff --git a/man/summary.vsel.Rd b/man/summary.vsel.Rd index 5534f4142..336d91eb6 100644 --- a/man/summary.vsel.Rd +++ b/man/summary.vsel.Rd @@ -99,7 +99,7 @@ estimate.} \item{baseline}{For \code{\link[=summary.vsel]{summary.vsel()}}: Only relevant if \code{deltas} is \code{TRUE}. For \code{\link[=plot.vsel]{plot.vsel()}}: Always relevant. Either \code{"ref"} or \code{"best"}, indicating whether the baseline is the reference model or the best submodel found (in -terms of \code{stats[1]}), respectively.} +terms of \code{stats[1]}), respectively. In case of subsampled LOO-CV, \code{baseline = "best"} is not supported.} \item{resp_oscale}{Only relevant for the latent projection. A single logical value indicating whether to calculate the performance statistics on the From 75b1ac915c4c481f6a01ebba68bbc3a6c90231be Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sat, 1 Feb 2025 07:03:44 +0100 Subject: [PATCH 128/134] vignettes: mention subsampled LOO --- vignettes/projpred.Rmd | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/vignettes/projpred.Rmd b/vignettes/projpred.Rmd index 39c7aded2..b770434c4 100755 --- a/vignettes/projpred.Rmd +++ b/vignettes/projpred.Rmd @@ -123,7 +123,7 @@ The search part determines the predictor ranking (also known as solution path), The evaluation part determines the predictive performance of the increasingly complex submodels along the predictor ranking. There are two functions for running the combination of search and evaluation: `varsel()` and `cv_varsel()`. -In contrast to `varsel()`, `cv_varsel()` performs a cross-validation (CV). With `cv_method = "LOO"` (the default), `cv_varsel()` runs a Pareto-smoothed importance sampling leave-one-out CV [PSIS-LOO CV, see @vehtari_practical_2017; @vehtari_pareto_2022]. With `cv_method = "kfold"`, `cv_varsel()` runs a $K$-fold CV. The extent of the CV depends on `cv_varsel()`'s argument `validate_search`: If `validate_search = TRUE` (the default), the search part is run with the training data of each CV fold separately and the evaluation part is run with the corresponding test data of each CV fold. +In contrast to `varsel()`, `cv_varsel()` performs a cross-validation (CV). With `cv_method = "LOO"` (the default), `cv_varsel()` runs a Pareto-smoothed importance sampling leave-one-out CV [PSIS-LOO CV, see @vehtari_practical_2017; @vehtari_pareto_2022]. With `cv_method = "kfold"`, `cv_varsel()` runs a $K$-fold CV. The extent of the CV mainly depends on `cv_varsel()`'s argument `validate_search`: If `validate_search = TRUE` (the default), the search part is run with the training data of each CV fold separately and the evaluation part is run with the corresponding test data of each CV fold. If `validate_search = FALSE`, the search is excluded from the CV so that only a single full-data search is run. Because of its most thorough protection against overfitting^[Currently, neither `varsel()` nor `cv_varsel()` (not even `cv_varsel()` with `validate_search = TRUE`) guard against overfitting in the selection of the submodel *size*. This is why we added "approximately" to "valid post-selection inference" in section ["Introduction"](#intro). Typically, however, the overfitting induced by the size selection should be comparatively small [@piironen_comparison_2017].], `cv_varsel()` with `validate_search = TRUE` is recommended over `varsel()` and `cv_varsel()` with `validate_search = FALSE`. Nonetheless, a preliminary and comparatively fast run of `varsel()` or `cv_varsel()` with `validate_search = FALSE` can give a rough idea of the performance of the submodels and can be used for finding a suitable value for argument `nterms_max` in subsequent runs (argument `nterms_max` imposes a limit on the submodel size up to which the search is continued and is thus able to reduce the runtime considerably). @@ -190,7 +190,7 @@ Here, we skip this for the sake of brevity and instead head over to the final `c ### Final `cv_varsel()` run For this final `cv_varsel()` run (with `validate_search = TRUE`, as recommended), we use a $K$-fold CV with a small number of folds (`K = 2`) to make this vignette build faster. -In practice, we recommend using either the default of `cv_method = "LOO"` or a larger value for `K` if this is possible in terms of computation time. +In practice, we recommend using either the default of `cv_method = "LOO"` (possibly subsampled, see argument `nloo` of `cv_varsel()`) or a larger value for `K` if this is possible in terms of computation time. Here, we also perform the $K$ reference model refits outside of `cv_varsel()`. Although not strictly necessary here, this is helpful in practice because often, `cv_varsel()` needs to be re-run multiple times in order to try out different argument settings. @@ -554,9 +554,11 @@ Some speed-up possibilities are: In case of `cv_method = "LOO"`^[In case of `cv_method = "kfold"`, the runtime advantage of `validate_search = FALSE` compared to `validate_search = TRUE` is not as large as in case of `cv_method = "LOO"`, but even for `cv_method = "kfold"`, such a runtime advantage still exists.], `cv_varsel()` with `validate_search = FALSE` has comparable runtime to `varsel()`, but accounts for some overfitting, namely that induced by `varsel()`'s in-sample predictions during the predictive performance evaluation. However, as explained in section ["Variable selection"](#variableselection) (see also section ["Overfitting"](#overfitting)), `cv_varsel()` with `validate_search = FALSE` is more prone to overfitting than `cv_varsel()` with `validate_search = TRUE`. +1. Using `cv_varsel()` with subsampled PSIS-LOO CV, see argument `nloo` of `cv_varsel()`. + 1. Using `cv_varsel()` with $K$-fold CV instead of PSIS-LOO CV. - Whether this provides a speed improvement mainly depends on the number of observations and the complexity of the reference model. - Note that PSIS-LOO CV is often more accurate than $K$-fold CV if argument `K` is (much) smaller than the number of observations. + Whether this provides a speed improvement mainly depends on the number of observations, argument `nloo` of `cv_varsel()`, and the complexity of the reference model. + Note that PSIS-LOO CV is often more accurate than $K$-fold CV if argument `K` is (much) smaller than argument `nloo` of `cv_varsel()`. 1. Using a "custom" reference model object with a dimension reduction technique for the predictor data (e.g., by computing principal components from the original predictors, using these principal components as predictors when fitting the reference model, and then performing the variable selection in terms of the *original* predictor terms). Examples are given in @piironen_projective_2020 and @pavone_using_2022. From a57f3a8cdf3bf930b68924cd98467e5f96536ed0 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 2 Feb 2025 21:08:26 +0100 Subject: [PATCH 129/134] update `NEWS.md` --- NEWS.md | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 400383f95..38bc390f8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,9 +4,16 @@ If you read this from a place other than ). This threshold depends on the Monte Carlo sample size and is often close to the former fixed threshold of 0.7 (a short introduction may also be found in the [LOO glossary](https://mc-stan.org/loo/reference/loo-glossary.html)). Correspondingly, the former "secondary" threshold of 0.5 is not used anymore either. +* Use the updated threshold for high Pareto-$\hat{k}$ values presented by Vehtari et al. (2024, "Pareto smoothed importance sampling", *Journal of Machine Learning Research*, 25(72):1-58, ). This threshold depends on the Monte Carlo sample size and is often close to the former fixed threshold of 0.7 (a short introduction may also be found in the [LOO glossary](https://mc-stan.org/loo/reference/loo-glossary.html)). Correspondingly, the former "secondary" threshold of 0.5 is not used anymore either. (GitHub: #490, #498) # projpred 2.8.0 From ba1736c890bf96ac07f3b13150f2a1957769ad21 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 2 Feb 2025 21:10:27 +0100 Subject: [PATCH 130/134] fixup! docs: mention log-normal approximation for MSE and RMSE, see --- R/methods.R | 12 ++++++++---- man/plot.vsel.Rd | 12 ++++++++---- man/summary.vsel.Rd | 12 ++++++++---- 3 files changed, 24 insertions(+), 12 deletions(-) diff --git a/R/methods.R b/R/methods.R index 2ea886961..5dc9a2442 100644 --- a/R/methods.R +++ b/R/methods.R @@ -1163,9 +1163,11 @@ plot.vsel <- function( #' * `"elpd"`: expected log (pointwise) predictive density (for a new #' dataset) (ELPD). Estimated by the sum of the observation-specific log #' predictive density values (with each of these predictive density values -#' being a---possibly weighted---average across the parameter draws). +#' being a---possibly weighted---average across the parameter draws). For the +#' corresponding confidence interval, a normal approximation is used. #' * `"mlpd"`: mean log predictive density (MLPD), that is, the ELPD divided -#' by the number of observations. +#' by the number of observations. For the corresponding confidence interval, a +#' normal approximation is used. #' * `"gmpd"`: geometric mean predictive density (GMPD), that is, [exp()] of #' the MLPD. The GMPD is especially helpful for discrete response families #' (because there, the GMPD is bounded by zero and one). For the corresponding @@ -1184,13 +1186,15 @@ plot.vsel <- function( #' approximation is used if `deltas` is `TRUE`. #' * `"R2"`: R-squared, i.e., coefficient of determination (only available in #' the situations mentioned in section "Details" below). For the corresponding -#' standard error, the delta method is used. +#' standard error, the delta method is used. For the corresponding confidence +#' interval, a normal approximation is used. #' * `"acc"` (or its alias, `"pctcorr"`): classification accuracy (only #' available in the situations mentioned in section "Details" below). By #' "classification accuracy", we mean the proportion of correctly classified #' observations. For this, the response category ("class") with highest #' probability (the probabilities are model-based) is taken as the prediction -#' ("classification") for an observation. +#' ("classification") for an observation. For the corresponding confidence +#' interval, a normal approximation is used. #' * `"auc"`: area under the ROC curve (only available in the situations #' mentioned in section "Details" below). For the corresponding standard error #' and lower and upper confidence interval bounds, bootstrapping is used. Not diff --git a/man/plot.vsel.Rd b/man/plot.vsel.Rd index 89aeb43c8..ee30aab2d 100644 --- a/man/plot.vsel.Rd +++ b/man/plot.vsel.Rd @@ -48,9 +48,11 @@ set). Available statistics are: \item \code{"elpd"}: expected log (pointwise) predictive density (for a new dataset) (ELPD). Estimated by the sum of the observation-specific log predictive density values (with each of these predictive density values -being a---possibly weighted---average across the parameter draws). +being a---possibly weighted---average across the parameter draws). For the +corresponding confidence interval, a normal approximation is used. \item \code{"mlpd"}: mean log predictive density (MLPD), that is, the ELPD divided -by the number of observations. +by the number of observations. For the corresponding confidence interval, a +normal approximation is used. \item \code{"gmpd"}: geometric mean predictive density (GMPD), that is, \code{\link[=exp]{exp()}} of the MLPD. The GMPD is especially helpful for discrete response families (because there, the GMPD is bounded by zero and one). For the corresponding @@ -69,13 +71,15 @@ a log-normal approximation is used if \code{deltas} is \code{FALSE} and a normal approximation is used if \code{deltas} is \code{TRUE}. \item \code{"R2"}: R-squared, i.e., coefficient of determination (only available in the situations mentioned in section "Details" below). For the corresponding -standard error, the delta method is used. +standard error, the delta method is used. For the corresponding confidence +interval, a normal approximation is used. \item \code{"acc"} (or its alias, \code{"pctcorr"}): classification accuracy (only available in the situations mentioned in section "Details" below). By "classification accuracy", we mean the proportion of correctly classified observations. For this, the response category ("class") with highest probability (the probabilities are model-based) is taken as the prediction -("classification") for an observation. +("classification") for an observation. For the corresponding confidence +interval, a normal approximation is used. \item \code{"auc"}: area under the ROC curve (only available in the situations mentioned in section "Details" below). For the corresponding standard error and lower and upper confidence interval bounds, bootstrapping is used. Not diff --git a/man/summary.vsel.Rd b/man/summary.vsel.Rd index 336d91eb6..cc131e62d 100644 --- a/man/summary.vsel.Rd +++ b/man/summary.vsel.Rd @@ -38,9 +38,11 @@ set). Available statistics are: \item \code{"elpd"}: expected log (pointwise) predictive density (for a new dataset) (ELPD). Estimated by the sum of the observation-specific log predictive density values (with each of these predictive density values -being a---possibly weighted---average across the parameter draws). +being a---possibly weighted---average across the parameter draws). For the +corresponding confidence interval, a normal approximation is used. \item \code{"mlpd"}: mean log predictive density (MLPD), that is, the ELPD divided -by the number of observations. +by the number of observations. For the corresponding confidence interval, a +normal approximation is used. \item \code{"gmpd"}: geometric mean predictive density (GMPD), that is, \code{\link[=exp]{exp()}} of the MLPD. The GMPD is especially helpful for discrete response families (because there, the GMPD is bounded by zero and one). For the corresponding @@ -59,13 +61,15 @@ a log-normal approximation is used if \code{deltas} is \code{FALSE} and a normal approximation is used if \code{deltas} is \code{TRUE}. \item \code{"R2"}: R-squared, i.e., coefficient of determination (only available in the situations mentioned in section "Details" below). For the corresponding -standard error, the delta method is used. +standard error, the delta method is used. For the corresponding confidence +interval, a normal approximation is used. \item \code{"acc"} (or its alias, \code{"pctcorr"}): classification accuracy (only available in the situations mentioned in section "Details" below). By "classification accuracy", we mean the proportion of correctly classified observations. For this, the response category ("class") with highest probability (the probabilities are model-based) is taken as the prediction -("classification") for an observation. +("classification") for an observation. For the corresponding confidence +interval, a normal approximation is used. \item \code{"auc"}: area under the ROC curve (only available in the situations mentioned in section "Details" below). For the corresponding standard error and lower and upper confidence interval bounds, bootstrapping is used. Not From dea473298cd32961b152cadb15d14830732d1a79 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Sun, 2 Feb 2025 21:23:24 +0100 Subject: [PATCH 131/134] fixup! subsampled LOO and AUC: switch from warning to error, see --- R/summary_funs.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/R/summary_funs.R b/R/summary_funs.R index 1f5992ece..e15256825 100644 --- a/R/summary_funs.R +++ b/R/summary_funs.R @@ -528,8 +528,9 @@ get_stat <- function(summaries, summaries_baseline = NULL, } } else if (stat == "auc") { if (n_loo < n_full) { - # subsampling LOO with AUC not implemented. Using fast LOO result. - mu <- mu_fast + # Note: Previously, subsampled LOO with AUC caused the fast LOO results + # to be used automatically (via `mu <- mu_fast`), see PR #496. + stop("Subsampled LOO-CV with AUC not implemented.") } if (!is.null(mu_baseline)) { auc_data <- cbind(y, mu, wobs) From fcee136bf8ea1719b7717ed2d3ab99db933d8219 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Tue, 4 Feb 2025 20:58:17 +0100 Subject: [PATCH 132/134] set `nloo` to `NULL` in case of K-fold CV --- R/cv_varsel.R | 3 ++- man/cv_varsel.Rd | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/R/cv_varsel.R b/R/cv_varsel.R index 182309a92..629ff98e7 100644 --- a/R/cv_varsel.R +++ b/R/cv_varsel.R @@ -265,7 +265,7 @@ cv_varsel.refmodel <- function( nterms_max = NULL, penalty = NULL, verbose = TRUE, - nloo = object$nobs, + nloo = if (cv_method == "LOO") object$nobs else NULL, K = if (!inherits(object, "datafit")) 5 else 10, cvfits = object$cvfits, search_control = NULL, @@ -545,6 +545,7 @@ parse_args_cv_varsel <- function(refmodel, cv_method, nloo, K, cvfits, stop("For K-fold-CV, `validate_search = FALSE` may not be combined with ", "`refit_prj = FALSE`.") } + nloo <- NULL } else { stopifnot(!is.null(refmodel[["nobs"]])) nloo <- min(nloo, refmodel[["nobs"]]) diff --git a/man/cv_varsel.Rd b/man/cv_varsel.Rd index 085607111..46196c9b5 100644 --- a/man/cv_varsel.Rd +++ b/man/cv_varsel.Rd @@ -33,7 +33,7 @@ cv_varsel(object, ...) nterms_max = NULL, penalty = NULL, verbose = TRUE, - nloo = object$nobs, + nloo = if (cv_method == "LOO") object$nobs else NULL, K = if (!inherits(object, "datafit")) 5 else 10, cvfits = object$cvfits, search_control = NULL, From 1a0604d8cf08312c972e44cdc9e0fb60cb495c08 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Mon, 3 Feb 2025 20:11:57 +0100 Subject: [PATCH 133/134] modify the tests so that subsampled LOO is tested more thoroughly --- tests/testthat/helpers/testers.R | 11 +- tests/testthat/setup.R | 35 +++-- tests/testthat/test_datafit.R | 5 + tests/testthat/test_varsel.R | 211 ++++++------------------------- 4 files changed, 80 insertions(+), 182 deletions(-) diff --git a/tests/testthat/helpers/testers.R b/tests/testthat/helpers/testers.R index 9ca1d8fd1..b746b8f83 100644 --- a/tests/testthat/helpers/testers.R +++ b/tests/testthat/helpers/testers.R @@ -1968,7 +1968,11 @@ vsel_tester <- function( nclusters_pred_tst }, seed_expected = seed_tst, - nloo_expected = if (with_cv) refmod_expected$nobs else NULL, + nloo_expected = if (with_cv && !identical(cv_method_expected, "kfold")) { + refmod_expected$nobs + } else { + NULL + }, K_expected = NULL, penalty_expected = NULL, search_terms_expected = NULL, @@ -2000,7 +2004,6 @@ vsel_tester <- function( # size (see issue #307): prd_trms_len_expected <- prd_trms_len_expected - 1L } - nloo_expected_orig <- nloo_expected # Test the general structure of the object: expect_s3_class(vs, "vsel") @@ -2249,7 +2252,7 @@ vsel_tester <- function( expect_named(vs$summaries, c("sub", "ref"), info = info_str) expect_type(vs$summaries$sub, "list") expect_length(vs$summaries$sub, prd_trms_len_expected + 1) - if (with_cv) { + if (with_cv && identical(cv_method_expected, "LOO")) { if (is.null(nloo_expected) || nloo_expected > nobsv) { nloo_expected <- nobsv } @@ -2372,7 +2375,7 @@ vsel_tester <- function( expect_identical(vs$cv_method, cv_method_expected, info = info_str) # nloo - expect_identical(vs$nloo, nloo_expected_orig, info = info_str) + expect_identical(vs$nloo, nloo_expected, info = info_str) # K if (!is.null(K_expected)) { diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 623a33ba5..5f562e3aa 100755 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -937,6 +937,11 @@ cvmeth_tst <- list( kfold = list(cv_method = "kfold") ) +nloo_tst <- list( + default_nloo = list(), + subsmpl = list(nloo = as.integer(nobsv %/% 10)) +) + resp_oscale_tst <- list( default_r_oscale = list(), r_oscale_F = list(resp_oscale = FALSE) @@ -1233,6 +1238,14 @@ if (run_cvvs) { !run_valsearch_aug_lat))) { cvmeth_i <- c(cvmeth_i, list(validate_search = FALSE)) } + if (identical(cvmeth_i$cv_method, "kfold")) { + nloo_tst <- nloo_tst["default_nloo"] + } else if (!((prj_crr == "trad" && mod_crr == "glm" && + fam_crr == "gauss") || + (prj_crr %in% c("augdat", "latent") && mod_crr == "glm" && + fam_crr == "cumul"))) { + nloo_tst <- nloo_tst["subsmpl"] + } if (run_more && mod_crr == "glm" && fam_crr == "gauss" && grepl("\\.stdformul\\.", tstsetup_ref)) { # Here, we also test non-NULL `search_terms`: @@ -1247,14 +1260,20 @@ if (run_cvvs) { nterms_max_tst <- count_terms_chosen(search_trms_i$search_terms) - 1L } - return(c( - nlist(tstsetup_ref), only_nonargs(args_ref[[tstsetup_ref]]), - list( - nclusters = nclusters_tst, nclusters_pred = nclusters_pred_tst, - nterms_max = nterms_max_tst, verbose = FALSE, seed = seed_tst - ), - meth_i, cvmeth_i, search_trms_i - )) + lapply(nloo_tst, function(nloo_i) { + if (!is.null(nloo_i$nloo) && nloo_i$nloo < nobsv && + identical(cvmeth_i$validate_search, FALSE)) { + cvmeth_i$validate_search <- NULL + } + return(c( + nlist(tstsetup_ref), only_nonargs(args_ref[[tstsetup_ref]]), + list( + nclusters = nclusters_tst, nclusters_pred = nclusters_pred_tst, + nterms_max = nterms_max_tst, verbose = FALSE, seed = seed_tst + ), + meth_i, cvmeth_i, nloo_i, search_trms_i + )) + }) }) }) }) diff --git a/tests/testthat/test_datafit.R b/tests/testthat/test_datafit.R index 0859ae027..68f119851 100644 --- a/tests/testthat/test_datafit.R +++ b/tests/testthat/test_datafit.R @@ -114,12 +114,17 @@ if (run_cvvs) { args_cvvs_datafit <- lapply(args_cvvs_datafit, function(args_cvvs_i) { args_cvvs_i$cv_method <- NULL args_cvvs_i$K <- NULL + args_cvvs_i$nloo <- NULL args_cvvs_i$validate_search <- TRUE return(c(args_cvvs_i, list(cv_method = "kfold"))) }) + names(args_cvvs_datafit) <- gsub("(\\.default_cvmeth\\..*)\\.default_nloo", + "\\1.subsmpl", names(args_cvvs_datafit)) names(args_cvvs_datafit) <- gsub("default_cvmeth", "kfold", names(args_cvvs_datafit)) args_cvvs_datafit <- args_cvvs_datafit[unique(names(args_cvvs_datafit))] + names(args_cvvs_datafit) <- gsub("\\.subsmpl", "\\.default_nloo", + names(args_cvvs_datafit)) # For `datafit`s, we always have 1 cluster by default, so omit related # arguments: args_cvvs_datafit <- lapply(args_cvvs_datafit, function(args_cvvs_i) { diff --git a/tests/testthat/test_varsel.R b/tests/testthat/test_varsel.R index 6db89b676..dc35ba87b 100644 --- a/tests/testthat/test_varsel.R +++ b/tests/testthat/test_varsel.R @@ -1195,6 +1195,7 @@ test_that(paste( prd_trms_len_expected = args_cvvs[[tstsetup]]$nterms_max, method_expected = meth_exp_crr, cv_method_expected = args_cvvs[[tstsetup]]$cv_method, + nloo_expected = args_cvvs[[tstsetup]]$nloo, valsearch_expected = args_cvvs[[tstsetup]]$validate_search, search_terms_expected = args_cvvs[[tstsetup]]$search_terms, search_trms_empty_size = @@ -1321,6 +1322,7 @@ test_that("`refit_prj` works", { method_expected = meth_exp_crr, refit_prj_expected = FALSE, cv_method_expected = args_cvvs_i$cv_method, + nloo_expected = args_cvvs_i$nloo, valsearch_expected = args_cvvs_i$validate_search, search_terms_expected = args_cvvs_i$search_terms, search_trms_empty_size = @@ -1396,7 +1398,7 @@ test_that("invalid `nloo` fails", { suppressWarnings(do.call(cv_varsel, c( list(object = refmods[[args_cvvs_i$tstsetup_ref]], nloo = -1), - excl_nonargs(args_cvvs_i) + excl_nonargs(args_cvvs_i, nms_excl_add = "nloo") ))), "^nloo must be at least 1$", info = tstsetup @@ -1411,7 +1413,7 @@ test_that(paste( skip_if_not(run_cvvs) nloo_tst <- nobsv + 1L tstsetups <- grep( - "\\.glm\\.gauss\\..*\\.default_cvmeth\\.default_search_trms", + "\\.glm\\.gauss\\..*\\.default_cvmeth\\.default_search_trms\\.default_nloo", names(cvvss), value = TRUE ) valsearch_arg <- lapply(args_cvvs[tstsetups], "[[", "validate_search") @@ -1426,26 +1428,23 @@ test_that(paste( nloo = nloo_tst), excl_nonargs(args_cvvs_i) ))) - cvvs_nloo[["nloo"]] <- nobsv expect_equal(cvvs_nloo, cvvss[[tstsetup]], info = tstsetup) } }) test_that("setting `nloo` smaller than the number of observations works", { skip_if_not(run_cvvs) - nloo_tst <- nobsv %/% 5L # Output elements of `vsel` objects that may be influenced by `nloo`: - vsel_nms_nloo <- c("summaries", "summaries_fast","predictor_ranking_cv", + vsel_nms_nloo <- c("summaries", "summaries_fast", "predictor_ranking_cv", "nloo", "loo_inds", "ce") # In general, element `ce` is affected as well (because the PRNG state when # doing the clustering for the performance evaluation is different when `nloo` # is smaller than the number of observations compared to when `nloo` is equal - # to the number of observations), but the changes in `ce` may be so small that - # they are not detected by all.equal(): + # to the number of observations): vsel_nms_nloo_opt <- c("ce") # The setups that should be tested: tstsetups <- grep( - "\\.glm\\.gauss\\..*\\.default_cvmeth\\.default_search_trms", + "\\.default_cvmeth\\.default_search_trms\\.default_nloo", names(cvvss), value = TRUE ) valsearch_arg <- lapply(args_cvvs[tstsetups], "[[", "validate_search") @@ -1453,34 +1452,9 @@ test_that("setting `nloo` smaller than the number of observations works", { skip_if(length(tstsetups) == 0) for (tstsetup in tstsetups) { args_cvvs_i <- args_cvvs[[tstsetup]] - tstsetup_ref <- args_cvvs_i$tstsetup_ref - mod_crr <- args_cvvs_i$mod_nm - fam_crr <- args_cvvs_i$fam_nm - prj_crr <- args_cvvs_i$prj_nm - meth_exp_crr <- args_cvvs_i$method %||% "forward" - # Use suppressWarnings() because test_that() somehow redirects stderr() and - # so throws warnings that projpred wants to capture internally: - cvvs_nloo <- suppressWarnings(do.call(cv_varsel, c( - list(object = refmods[[args_cvvs_i$tstsetup_ref]], - nloo = nloo_tst), - excl_nonargs(args_cvvs_i) - ))) - vsel_tester( - cvvs_nloo, - with_cv = TRUE, - refmod_expected = refmods[[tstsetup_ref]], - prd_trms_len_expected = args_cvvs_i$nterms_max, - method_expected = meth_exp_crr, - cv_method_expected = "LOO", - valsearch_expected = TRUE, - nloo_expected = nloo_tst, - search_terms_expected = args_cvvs_i$search_terms, - search_trms_empty_size = - length(args_cvvs_i$search_terms) && - all(grepl("\\+", args_cvvs_i$search_terms)), - search_control_expected = args_cvvs_i[c("avoid.increase")], - info_str = tstsetup - ) + tstsetup_nloo <- sub("\\.default_nloo", "\\.subsmpl", tstsetup) + stopifnot(tstsetup_nloo %in% names(cvvss)) + cvvs_nloo <- cvvss[[tstsetup_nloo]] # Expected equality for most elements with a few exceptions: vsel_nms_nloo_crr <- vsel_nms_nloo if (isFALSE(args_cvvs_i$validate_search)) { @@ -1511,7 +1485,8 @@ test_that("`validate_search` works", { tstsetups <- names(cvvss) if (!run_valsearch_always) { has_valsearch_true <- sapply(tstsetups, function(tstsetup_cvvs) { - !isFALSE(args_cvvs[[tstsetup_cvvs]]$validate_search) + !isFALSE(args_cvvs[[tstsetup_cvvs]]$validate_search) && + (args_cvvs[[tstsetup_cvvs]]$nloo %||% nobsv) == nobsv }) tstsetups <- tstsetups[has_valsearch_true] } @@ -1610,7 +1585,9 @@ test_that("`validate_search` works", { suggsize_cond[tstsetup] <- sgg_size_valsearch >= sgg_size } } - expect_true(mean(!suggsize_cond, na.rm = TRUE) <= 0.25) + if (!all(is.na(suggsize_cond))) { + expect_true(mean(!suggsize_cond, na.rm = TRUE) <= 0.25) + } }) ## Arguments specific to K-fold CV ---------------------------------------- @@ -1913,7 +1890,7 @@ test_that(paste( skip_if_not(run_cvvs) tstsetups <- names(cvvss) if (!run_more) { - tstsetups <- head(tstsetups, 1) + tstsetups <- head(tstsetups, 2) } for (tstsetup in tstsetups) { refit_prj_crr <- !identical(args_cvvs[[tstsetup]]$validate_search, FALSE) || @@ -1922,8 +1899,9 @@ test_that(paste( # Use suppressWarnings() because test_that() somehow redirects stderr() and # so throws warnings that projpred wants to capture internally: cvvs_eval <- suppressWarnings(cv_varsel( - cvvss[[tstsetup]], refit_prj = refit_prj_crr, - nclusters_pred = nclusters_pred_crr, verbose = FALSE, seed = seed2_tst + cvvss[[tstsetup]], + refit_prj = refit_prj_crr, nclusters_pred = nclusters_pred_crr, + verbose = FALSE, seed = seed2_tst )) tstsetup_ref <- args_cvvs[[tstsetup]]$tstsetup_ref meth_exp_crr <- args_cvvs[[tstsetup]]$method %||% "forward" @@ -1940,6 +1918,7 @@ test_that(paste( prd_trms_len_expected = args_cvvs[[tstsetup]]$nterms_max, method_expected = meth_exp_crr, cv_method_expected = args_cvvs[[tstsetup]]$cv_method, + nloo_expected = args_cvvs[[tstsetup]]$nloo, valsearch_expected = args_cvvs[[tstsetup]]$validate_search, refit_prj_expected = refit_prj_crr, nprjdraws_eval_expected = if (!refit_prj_crr && meth_exp_crr == "L1") { @@ -2093,8 +2072,8 @@ test_that(paste( )) } else { cvvs_eval <- suppressWarnings(cv_varsel( - cvvss[[tstsetup]], validate_search = FALSE, refit_prj = FALSE, - verbose = FALSE, seed = seed2_tst + cvvss[[tstsetup]], nloo = nobsv, validate_search = FALSE, + refit_prj = FALSE, verbose = FALSE, seed = seed2_tst )) } tstsetup_ref <- args_cvvs[[tstsetup]]$tstsetup_ref @@ -2146,7 +2125,7 @@ test_that(paste( skip_if_not(run_cvvs) tstsetups <- names(cvvss) if (!run_more) { - tstsetups <- head(tstsetups, 8) + tstsetups <- head(tstsetups, 11) } for (tstsetup in tstsetups) { tstsetup_ref <- args_cvvs[[tstsetup]]$tstsetup_ref @@ -2206,7 +2185,7 @@ test_that(paste( skip_if_not(run_cvvs) tstsetups <- names(cvvss) if (!run_more) { - tstsetups <- head(tstsetups, 2) + tstsetups <- head(tstsetups, 3) } for (tstsetup in tstsetups) { tstsetup_ref <- args_cvvs[[tstsetup]]$tstsetup_ref @@ -2269,7 +2248,7 @@ test_that(paste( skip_if_not(run_cvvs) tstsetups <- names(cvvss) if (!run_more) { - tstsetups <- head(tstsetups, 8) + tstsetups <- head(tstsetups, 11) } for (tstsetup in tstsetups) { tstsetup_ref <- args_cvvs[[tstsetup]]$tstsetup_ref @@ -2291,12 +2270,14 @@ test_that(paste( # so throws warnings that projpred wants to capture internally: if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { cv_meth_crr <- "LOO" + nloo_crr <- nloo_tst[["subsmpl"]][["nloo"]] cvvs_eval <- suppressWarnings(cv_varsel( - cvvss[[tstsetup]], cv_method = cv_meth_crr, + cvvss[[tstsetup]], cv_method = cv_meth_crr, nloo = nloo_crr, nclusters_pred = nclusters_pred_crr, verbose = FALSE, seed = seed2_tst )) } else { cv_meth_crr <- "kfold" + nloo_crr <- NULL cvvs_eval <- suppressWarnings(cv_varsel( cvvss[[tstsetup]], cv_method = cv_meth_crr, K = K_tst, cvfits = cvfitss[[tstsetup_ref]], nclusters_pred = nclusters_pred_crr, @@ -2312,6 +2293,7 @@ test_that(paste( prd_trms_len_expected = args_cvvs[[tstsetup]]$nterms_max, method_expected = meth_exp_crr, cv_method_expected = cv_meth_crr, + nloo_expected = nloo_crr, valsearch_expected = TRUE, K_expected = K_tst, nprjdraws_eval_expected = nclusters_pred_crr, @@ -2341,12 +2323,13 @@ test_that(paste( } else { nclusters_pred_crr <- args_vs[[tstsetup]]$nclusters_pred } + nloo_crr <- nloo_tst[["subsmpl"]][["nloo"]] # Use suppressWarnings() because test_that() somehow redirects stderr() and # so throws warnings that projpred wants to capture internally: cvvs_eval <- try( suppressWarnings(cv_varsel( - vss[[tstsetup]], nclusters_pred = nclusters_pred_crr, verbose = FALSE, - seed = seed2_tst + vss[[tstsetup]], nloo = nloo_crr, nclusters_pred = nclusters_pred_crr, + verbose = FALSE, seed = seed2_tst )), silent = TRUE ) @@ -2375,6 +2358,7 @@ test_that(paste( prd_trms_len_expected = args_vs[[tstsetup]]$nterms_max, method_expected = meth_exp_crr, cv_method_expected = "LOO", + nloo_expected = nloo_crr, valsearch_expected = TRUE, nprjdraws_eval_expected = nclusters_pred_crr, search_terms_expected = args_vs[[tstsetup]]$search_terms, @@ -2452,7 +2436,6 @@ test_that(paste( prd_trms_len_expected = args_vs[[tstsetup]]$nterms_max, method_expected = meth_exp_crr, cv_method_expected = "kfold", - nloo_expected = NULL, valsearch_expected = TRUE, nprjdraws_eval_expected = nclusters_pred_crr, search_terms_expected = args_vs[[tstsetup]]$search_terms, @@ -2473,7 +2456,7 @@ test_that(paste( skip_if_not(run_cvvs) tstsetups <- names(cvvss) if (!run_more) { - tstsetups <- head(tstsetups, 2) + tstsetups <- head(tstsetups, 3) } for (tstsetup in tstsetups) { if (run_more && !args_cvvs[[tstsetup]]$mod_nm %in% c("glm", "gam")) { @@ -2487,14 +2470,17 @@ test_that(paste( # Use suppressWarnings() because test_that() somehow redirects stderr() and # so throws warnings that projpred wants to capture internally: if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { + nloo_crr <- nloo_tst[["subsmpl"]][["nloo"]] cvvs_eval <- try( suppressWarnings(cv_varsel( - cvvss[[tstsetup]], cv_method = "LOO", validate_search = TRUE, - nclusters_pred = nclusters_pred_crr, verbose = FALSE, seed = seed2_tst + cvvss[[tstsetup]], cv_method = "LOO", nloo = nloo_crr, + validate_search = TRUE, nclusters_pred = nclusters_pred_crr, + verbose = FALSE, seed = seed2_tst )), silent = TRUE ) } else { + nloo_crr <- cvvss[[tstsetup]][["nloo"]] cvvs_eval <- try( suppressWarnings(cv_varsel( cvvss[[tstsetup]], validate_search = TRUE, @@ -2543,6 +2529,7 @@ test_that(paste( prd_trms_len_expected = args_cvvs[[tstsetup]]$nterms_max, method_expected = meth_exp_crr, cv_method_expected = "LOO", + nloo_expected = nloo_crr, valsearch_expected = TRUE, nprjdraws_eval_expected = nclusters_pred_crr, K_expected = if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { @@ -2568,7 +2555,7 @@ test_that(paste( skip_if_not(run_cvvs) tstsetups <- names(cvvss) if (!run_more) { - tstsetups <- head(tstsetups, 2) + tstsetups <- head(tstsetups, 3) } for (tstsetup in tstsetups) { tstsetup_ref <- args_cvvs[[tstsetup]]$tstsetup_ref @@ -2643,122 +2630,6 @@ test_that(paste( } }) -test_that("cv_varsel.vsel(): `nloo` works for `vsel` objects from varsel()", { - skip_if_not(run_vs) - skip_if_not(run_cvvs) - nloo_tst <- nobsv %/% 5L - tstsetup_counter <- 0L - for (tstsetup in names(vss)) { - if (!run_more && tstsetup_counter > 0L) { - next - } else if (run_more && tstsetup_counter > length(vss) %/% 6) { - next - } else if (run_more) { - refit_prj_crr <- TRUE - nclusters_pred_crr <- args_vs[[tstsetup]]$nclusters_pred - 1L - } else { - refit_prj_crr <- FALSE - nclusters_pred_crr <- args_vs[[tstsetup]]$nclusters_pred - } - # Use suppressWarnings() because test_that() somehow redirects stderr() and - # so throws warnings that projpred wants to capture internally: - cvvs_eval_valT <- suppressWarnings(cv_varsel( - vss[[tstsetup]], nloo = nloo_tst, nclusters_pred = nclusters_pred_crr, - verbose = FALSE, seed = seed2_tst - )) - tstsetup_ref <- args_vs[[tstsetup]]$tstsetup_ref - meth_exp_crr <- args_vs[[tstsetup]]$method %||% "forward" - vsel_tester( - cvvs_eval_valT, - with_cv = TRUE, - refmod_expected = refmods[[tstsetup_ref]], - prd_trms_len_expected = args_vs[[tstsetup]]$nterms_max, - method_expected = meth_exp_crr, - cv_method_expected = "LOO", - nloo_expected = nloo_tst, - valsearch_expected = TRUE, - nprjdraws_eval_expected = nclusters_pred_crr, - search_terms_expected = args_vs[[tstsetup]]$search_terms, - search_trms_empty_size = - length(args_vs[[tstsetup]]$search_terms) && - all(grepl("\\+", args_vs[[tstsetup]]$search_terms)), - search_control_expected = args_vs[[tstsetup]][c("avoid.increase")], - info_str = tstsetup - ) - tstsetup_counter <- tstsetup_counter + 1L - } -}) - -test_that(paste( - "cv_varsel.vsel(): `nloo` works for `vsel` objects from cv_varsel()" -), { - skip_if_not(run_cvvs) - nloo_tst <- nobsv %/% 5L - tstsetups <- names(cvvss) - if (!run_more) { - tstsetups <- head(tstsetups, 1) - } else { - tstsetups <- head(grep("\\.glm\\.|\\.gam\\.", tstsetups, value = TRUE), - length(tstsetups) %/% 6) - # Make sure that in the test setups, we have `validate_search = TRUE` as - # well as `validate_search = FALSE`: - valsearches <- !unlist(lapply( - lapply(args_cvvs[tstsetups], "[[", "validate_search"), - isFALSE - )) - stopifnot(any(valsearches), any(!valsearches)) - } - for (tstsetup in tstsetups) { - # Use suppressWarnings() because test_that() somehow redirects stderr() and - # so throws warnings that projpred wants to capture internally: - if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { - cvvs_eval_valT <- suppressWarnings(cv_varsel( - cvvss[[tstsetup]], cv_method = "LOO", validate_search = TRUE, - nloo = nloo_tst, refit_prj = FALSE, verbose = FALSE, seed = seed2_tst - )) - } else { - cvvs_eval_valT <- suppressWarnings(cv_varsel( - cvvss[[tstsetup]], nloo = nloo_tst, validate_search = TRUE, - refit_prj = FALSE, verbose = FALSE, seed = seed2_tst - )) - } - meth_exp_crr <- args_cvvs[[tstsetup]]$method %||% "forward" - vsel_tester( - cvvs_eval_valT, - with_cv = TRUE, - refmod_expected = refmods[[args_cvvs[[tstsetup]]$tstsetup_ref]], - cvfits_expected = if (identical(args_cvvs[[tstsetup]]$cv_method, - "kfold")) { - cvfitss[[args_cvvs[[tstsetup]]$tstsetup_ref]] - } else { - refmods[[args_cvvs[[tstsetup]]$tstsetup_ref]]$cvfits - }, - prd_trms_len_expected = args_cvvs[[tstsetup]]$nterms_max, - method_expected = meth_exp_crr, - cv_method_expected = "LOO", - nloo_expected = nloo_tst, - valsearch_expected = TRUE, - refit_prj_expected = FALSE, - nprjdraws_eval_expected = if (meth_exp_crr == "L1") { - 1L - } else { - nclusters_tst - }, - K_expected = if (identical(args_cvvs[[tstsetup]]$cv_method, "kfold")) { - K_tst - } else { - NULL - }, - search_terms_expected = args_cvvs[[tstsetup]]$search_terms, - search_trms_empty_size = - length(args_cvvs[[tstsetup]]$search_terms) && - all(grepl("\\+", args_cvvs[[tstsetup]]$search_terms)), - search_control_expected = args_cvvs[[tstsetup]][c("avoid.increase")], - info_str = tstsetup - ) - } -}) - # run_cvfun() ------------------------------------------------------------- test_that("argument `folds` of run_cvfun() works", { From 458012eda66bab929c2b83be166eab6ad97571c9 Mon Sep 17 00:00:00 2001 From: fweber144 Date: Wed, 5 Feb 2025 20:34:38 +0100 Subject: [PATCH 134/134] fix a test (only discovered this now after changing the tests and running with `run_more = TRUE`) --- tests/testthat/test_methods_vsel.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/tests/testthat/test_methods_vsel.R b/tests/testthat/test_methods_vsel.R index d5c0523dc..da92f85c2 100644 --- a/tests/testthat/test_methods_vsel.R +++ b/tests/testthat/test_methods_vsel.R @@ -608,6 +608,12 @@ test_that(paste( nterms_max_expected_crr <- args_rk_cvvs[[tstsetup_rk]][["nterms_max"]] if (is.null(nterms_max_expected_crr)) { nterms_max_expected_crr <- args_cvvs[[tstsetup_cvvs]][["nterms_max"]] + if (length(args_cvvs[[tstsetup_cvvs]]$search_terms) && + all(grepl("\\+", args_cvvs[[tstsetup_cvvs]]$search_terms))) { + # This is the "empty_size" setting, so we have to subtract the skipped + # model size (see issue #307): + nterms_max_expected_crr <- nterms_max_expected_crr - 1L + } } cv_proportions_tester( prs_cvvs[[tstsetup]],