Support the progressr package

DESCRIPTION

@@ -80,7 +80,8 @@ Suggests:
     doParallel,
     future,
     future.callr,
-    doFuture
+    doFuture,
+    progressr
 LinkingTo: Rcpp, RcppArmadillo
 Additional_repositories:
     https://mc-stan.org/r-packages/

NEWS.md

@@ -14,6 +14,7 @@ If you read this from a place other than <https://mc-stan.org/projpred/news/inde
 ## Minor changes
 
 * 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, <https://www.jmlr.org/papers/v25/19-556.html>). 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)
+* When using the **doFuture** backend for parallelization, progression updates can now be received via the **progressr** package, see `` ?`projpred-package` `` (section "Parallelization"). (GitHub: #504)
 
 # projpred 2.8.0
 

R/cv_varsel.R

@@ -1036,17 +1036,26 @@ 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),
-        .export = c("one_obs", "dot_args"),
+        .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",
                       "loo_sub_oscale", "mu_sub_oscale")
       ) %do_projpred% {
-        do.call(one_obs, c(list(run_index = run_index, verbose_search = FALSE),
-                           dot_args))
+        out_one_obs <- do.call(one_obs, c(list(run_index = run_index,
+                                               verbose_search = FALSE),
+                                          dot_args))
+        if (!is.null(progressor_obj)) progressor_obj()
+        return(out_one_obs)
       }
     }
     # For storing the fold-wise predictor rankings:
@@ -1357,17 +1366,26 @@ 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,
-      .export = c("one_fold", "dot_args"),
+      .packages = c("projpred"),
+      .export = c("one_fold", "dot_args", "progressor_obj"),
       .noexport = c("list_cv", "search_out_rks")
     ) %do_projpred% {
-      do_call(one_fold, c(list(fold = list_cv_k, rk = search_out_rks_k,
-                               verbose_search = FALSE),
-                          dot_args))
+      out_one_fold <- do_call(one_fold, c(list(fold = list_cv_k,
+                                               rk = search_out_rks_k,
+                                               verbose_search = FALSE),
+                                          dot_args))
+      if (!is.null(progressor_obj)) progressor_obj()
+      return(out_one_fold)
     }
   }
   verb_out("-----", verbose = verbose)

R/divergence_minimizers.R

@@ -91,13 +91,19 @@ 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"),
+      .packages = c("projpred"),
+      .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"
@@ -113,6 +119,7 @@ divmin <- function(
             dot_args)
         )
       )
+      if (!is.null(progressor_obj)) progressor_obj()
       return(nlist(soutdmin, mssgs_warns_capt))
     }
   }
@@ -649,13 +656,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"
+        "projpred_random", "dot_args", "progressor_obj"
       ),
       .noexport = c(
         "object", "p_sel", "search_path", "p_ref", "refmodel", "projpred_var",
@@ -674,6 +687,7 @@ divmin_augdat <- function(
             dot_args)
         )
       )
+      if (!is.null(progressor_obj)) progressor_obj()
       return(nlist(soutdmin, mssgs_warns_capt))
     }
   }

R/misc.R

@@ -713,3 +713,10 @@ element_unq <- function(list_obj, nm) {
   }
   return(el_unq)
 }
+
+use_progressr <- function() {
+  getOption("projpred.use_progressr",
+            requireNamespace("progressr", quietly = TRUE) &&
+              interactive() &&
+              identical(foreach::getDoParName(), "doFuture"))
+}

R/projpred-package.R

@@ -135,6 +135,19 @@
 #' (i.e., a parallelization of \pkg{projpred}'s cross-validation) which can be
 #' activated via argument `parallel`.
 #'
+#' During parallelization (either of the projection or the CV), progression
+#' updates can be received via the \pkg{progressr} package. This only works if
+#' the \pkg{doFuture} backend is used for parallelization, e.g., via
+#' `doFuture::registerDoFuture()` and `future::plan(future::multisession,
+#' workers = 4)`. In that case, the \pkg{progressr} package can be used, e.g.,
+#' by calling `progressr::handlers(global = TRUE)` before running the projection
+#' or the CV in parallel. The \pkg{projpred} package also offers the global
+#' option `projpred.use_progressr` for controlling whether to use the
+#' \pkg{progressr} package (`TRUE` or `FALSE`), but since that global option
+#' defaults to `requireNamespace("progressr", quietly = TRUE) && interactive()
+#' && identical(foreach::getDoParName(), "doFuture")`, it usually does not need
+#' to be set by the user.
+#'
 #' # Multilevel models: "Integrating out" group-level effects
 #'
 #' In case of multilevel models, \pkg{projpred} offers two global options for