Add support for 'lme4'

Author: HenrikBengtsson

DESCRIPTION

@@ -25,6 +25,7 @@ Suggests:
     future.apply,
     fwb,
     futurize,
+    lme4,
     partykit,
     plyr,
     purrr,

NEWS.md

@@ -15,6 +15,9 @@
  * Add support for domain-specific CRAN package **fwb**, e.g. `res <-
    fwb::fwb(data, statistic, R = 100) |> progressify()`.
 
+ * Add support for domain-specific CRAN package **lme4**, e.g. `res <-
+   lme4::bootMer(fit, statistic, nsim = 100) |> progressify()`.
+
  * Add support for `purrr::imap_vec()`.
 
  * Add support for domain-specific CRAN package **sandwich**, e.g. `v <-

R/builtin-lme4.R

@@ -0,0 +1,111 @@
+# lme4::bootMer(...) =>
+#
+# local({
+#   .progressr_steps <- nsim
+#   .progressr_first <- TRUE
+#   .progressr_progressor <- progressr::progressor(steps = .progressr_steps)
+#   .progressr_FUN <- FUN
+#   lme4::bootMer(
+#     x = x,
+#     FUN = function(...) {
+#       if (.progressr_first) {
+#         .progressr_first <<- FALSE
+#       } else {
+#         on.exit(.progressr_progressor())
+#       }
+#       .progressr_FUN(...)
+#     },
+#     nsim = .progressr_steps
+#   )
+# })
+#
+progressify_lme4 <- local({
+  template_bootMer_outer <- bquote_compile(local({
+    .progressr_steps <- .(STEPS)
+    .progressr_first <- TRUE
+    .progressr_progressor <- progressr::progressor(steps = .progressr_steps)
+    .progressr_FUN <- .(FUN)
+    .(EXPR)
+  }))
+
+  template_bootMer_FUN <- quote(function(...) {
+    if (.progressr_first) {
+      .progressr_first <<- FALSE
+    } else {
+      on.exit(.progressr_progressor())
+    }
+    .progressr_FUN(...)
+  })
+
+  function(expr, fcn_name, fcn, ..., envir = parent.frame()) {
+    names <- names(expr)
+    if (is.null(names)) names <- rep("", length.out = length(expr))
+    names <- names[-1]
+    target_names <- names(formals(fcn))[seq_along(names)]
+    unnamed <- setdiff(target_names, names)
+    ## Handle '...' in formals - only resolve positional args before it
+    ddd <- which(unnamed == "...")
+    if (length(ddd) > 0L) {
+      stopifnot(length(ddd) == 1L)
+      unnamed <- unnamed[seq_len(ddd - 1L)]
+    }
+    empty_idxs <- which(names == "")
+    n <- min(length(empty_idxs), length(unnamed))
+    if (n > 0L) names[empty_idxs[seq_len(n)]] <- unnamed[seq_len(n)]
+    names <- c("", names)
+
+    idx_nsim <- which(names == "nsim")
+    idx_FUN <- which(names == "FUN")
+
+    parts <- as.list(expr)
+
+    if (length(idx_nsim) == 1L) {
+      steps <- parts[[idx_nsim]]
+      parts[[idx_nsim]] <- quote(.progressr_steps)
+    } else {
+      steps <- 1L
+      parts$nsim <- quote(.progressr_steps)
+    }
+
+    stopifnot(length(idx_FUN) == 1L)
+    FUN <- expr[[idx_FUN]]
+    parts[[idx_FUN]] <- template_bootMer_FUN
+
+    bquote_apply(template_bootMer_outer, STEPS = steps, FUN = FUN, EXPR = as.call(parts))
+  } ## progressify_lme4()
+})
+
+
+append_builtin_transpilers_for_lme4 <- local({
+  known_fcns <- list(
+    bootMer = c
+  )
+
+  template <- bquote_compile(function(expr, options) {
+    ns <- getNamespace("lme4")
+    fcn <- get(.(fcn_name), mode = "function", envir = ns)
+    progressify_lme4(expr, fcn_name = .(fcn_name), fcn = fcn, envir = parent.frame())
+  })
+
+  make_transpiler <- function(fcn_name) {
+    transpiler <- eval(bquote_apply(template))
+    eval(transpiler)
+  }
+
+  function() {
+    ## lme4::bootMer()
+    transpilers <- list()
+    for (fcn_name in names(known_fcns)) {
+      transpilers[[fcn_name]] <- list(
+        label = sprintf("lme4::%s() transpiler", fcn_name),
+        transpiler = make_transpiler(fcn_name)
+      )
+    } ## for (fcn_name ...)
+    transpilers <- list(lme4 = transpilers)
+
+    append_transpilers("progressify::built-in", transpilers)
+
+    ## Return required packages
+    c("lme4", "progressr")
+  }
+})

R/register_all_transpilers.R

@@ -15,4 +15,5 @@ register_all_transpilers <- function() {
   append_builtin_transpilers_for_stats()
   append_builtin_transpilers_for_foreach()
   append_builtin_transpilers_for_doFuture()
+  append_builtin_transpilers_for_lme4()
 } ## register_all_transpilers()

README.md

@@ -101,6 +101,7 @@ parallelization.
 |----------------------------|------------------------------------------------------------------------------|
 | **[boot]**                 | `boot()`, `censboot()`, `tsboot()`                                           |
 | **[fwb]**                  | `fwb()`                                                                      |
+| **[lme4]**                 | `bootMer()`                                                                  |
 | **[partykit]**             | `cforest()`                                                                  |
 | **[sandwich]**             | `vcovBS()`, `vcovJK()`                                                       |
 
@@ -113,6 +114,8 @@ res <- boot::boot(data, statistic, R = 100) |> progressify()
 
 res <- fwb::fwb(data, statistic, R = 100) |> progressify()
 
+res <- lme4::bootMer(fit, statistic, nsim = 100) |> progressify()
+
 forest <- partykit::cforest(Survived ~ ., data = as.data.frame(Titanic), ntree = 50L) |> progressify()
 
 v <- sandwich::vcovBS(fit) |> progressify()
@@ -156,6 +159,7 @@ forest <- partykit::cforest(dist ~ speed, data = cars, ntree = 50L) |> progressi
 [futurize]: https://futurize.futureverse.org
 [furrr]: https://furrr.futureverse.org
 [fwb]: https://cran.r-project.org/package=fwb
+[lme4]: https://cran.r-project.org/package=lme4
 [partykit]: https://cran.r-project.org/package=partykit
 [plyr]: https://cran.r-project.org/package=plyr
 [progressr]: https://progressr.futureverse.org

inst/testme/test-progressify-lme4.R

@@ -0,0 +1,45 @@
+#' @tags pkg-lme4
+if (requireNamespace("lme4", quietly = TRUE)) {
+  library(progressify)
+  library(lme4)
+
+  options(progressify.debug = TRUE)
+
+  # 1. Fit standard linear mixed model
+  fm1 <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy)
+  my_stat <- function(fit) {
+    fixef(fit)
+  }
+
+  exprs <- list(
+    bootMer = quote(bootMer(fm1, my_stat, nsim = 10L))
+  )
+
+  for (name in names(exprs)) {
+    message(sprintf("Testing %s ...", name))
+    expr <- exprs[[name]]
+
+    # Ensure reproducible seed
+    set.seed(42)
+    truth <- eval(expr)
+
+    set.seed(42)
+    res <- eval(bquote(.(expr) |> progressify()))
+
+    # Ensure results are equivalent
+    stopifnot(all.equal(res$t, truth$t))
+    stopifnot(all.equal(res$t0, truth$t0))
+
+    # Ensure no stdout leakage
+    output <- utils::capture.output({
+      set.seed(42)
+      res2 <- eval(bquote(.(expr) |> progressify()))
+    })
+    stopifnot(length(output) == 0L)
+
+    # Ensure repeated evaluation is identical
+    stopifnot(all.equal(res2$t, res$t))
+
+    message(sprintf("Testing %s ... done", name))
+  }
+}

pkgdown/_pkgdown.menus.yml

@@ -27,6 +27,8 @@ cran-focus:
     href: articles/progressify-81-boot.html
   - text: Progress updates for 'fwb' functions
     href: articles/progressify-81-fwb.html
+  - text: Progress updates for 'lme4' functions
+    href: articles/progressify-81-lme4.html
   - text: Progress updates for 'partykit' functions
     href: articles/progressify-81-partykit.html
   - text: Progress updates for 'sandwich' functions

pkgdown/_pkgdown.yml

@@ -42,6 +42,8 @@ navbar:
         href: articles/progressify-81-boot.html
       - text: Progress updates for 'fwb' functions
         href: articles/progressify-81-fwb.html
+      - text: Progress updates for 'lme4' functions
+        href: articles/progressify-81-lme4.html
       - text: Progress updates for 'partykit' functions
         href: articles/progressify-81-partykit.html
       - text: Progress updates for 'sandwich' functions

tests/test-progressify-lme4.R

@@ -0,0 +1,4 @@
+#! /usr/bin/env Rscript
+## This runs testme test script inst/testme/test-progressify-lme4.R
+## Don't edit - it was autogenerated by inst/testme/deploy.R
+progressify:::testme("progressify-lme4")

vignettes/progressify-81-lme4.md

@@ -0,0 +1,81 @@
+<!--
+%\VignetteIndexEntry{Progress updates for 'lme4' functions}
+%\VignetteAuthor{Henrik Bengtsson}
+%\VignetteKeyword{R}
+%\VignetteKeyword{package}
+%\VignetteKeyword{lme4}
+%\VignetteKeyword{vignette}
+%\VignetteKeyword{progressify}
+%\VignetteEngine{progressify::selfonly}
+-->
+
+The **progressify** package allows you to easily add progress
+reporting to sequential and parallel map-reduce code by piping to the
+`progressify()` function. Easy!
+
+
+# TL;DR
+
+```r
+library(progressify)
+handlers(global = TRUE)
+library(lme4)
+
+# Fit random-slope model
+fm1 <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy)
+my_stat <- function(fit) {
+  fixef(fit)
+}
+
+# Run bootstrap with progress signaling
+res <- bootMer(fm1, my_stat, nsim = 1000) |> progressify()
+```
+
+
+# Introduction
+
+This vignette demonstrates how to use this approach to add progress
+reporting to **[lme4]** functions such as `bootMer()`. The **lme4**
+package provides functions for fitting linear, generalized linear, and
+nonlinear mixed-effects models. For example, `bootMer()` runs a
+statistic function `nsim` times:
+
+```r
+library(lme4)
+
+# Fit random-slope model
+fm1 <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy)
+my_stat <- function(fit) {
+  fixef(fit)
+}
+
+res <- bootMer(fm1, my_stat, nsim = 1000)
+```
+
+By default, `bootMer()` provides no progress feedback. However, we can
+easily add progress reporting using the `progressify()` function:
+
+```r
+library(lme4)
+library(progressify)
+handlers(global = TRUE)
+
+# Fit random-slope model
+fm1 <- lmer(Reaction ~ Days + (Days | Subject), sleepstudy)
+my_stat <- function(fit) {
+  fixef(fit)
+}
+
+res <- bootMer(fm1, my_stat, nsim = 1000) |> progressify()
+```
+
+
+# Supported Functions
+
+The `progressify()` function supports the following **lme4**
+functions:
+
+ * `bootMer()`
+
+
+[lme4]: https://cran.r-project.org/package=lme4