Merge pull request #148 from matthieu-bruneaux/fix-tidy-brmsfit

Fix tidy.brmsfit() output for model without a `ran_pars` component
bbolker · Mar 30, 2024 · c6037eb · c6037eb
2 parents 62fa7d8 + f17e221
commit c6037eb
Show file tree

Hide file tree

Showing 4 changed files with 57 additions and 5 deletions.
diff --git a/R/brms_tidiers.R b/R/brms_tidiers.R
@@ -137,14 +137,14 @@ tidy.brmsfit <- function(x, parameters = NA,
       ## don't want to remove these pieces, so use look*behind*
       ran_pars =   sprintf("(?<=(%s))", c("sd_", "cor_", "sigma")),
       components = sprintf("(?<=%s)", c("zi_","disp_"))
-    )
-    prefs <- list(
+  )
+  prefs <- list(
       fixed = "b_", ran_vals = "r_",
       ## no lookahead (doesn't work with grep[l])
       ran_pars = c("sd_", "cor_", "sigma"),
       components = c("zi_", "disp_")
-    )
-    pref_RE <- mkRE(prefs[effects])
+  )
+  pref_RE <- mkRE(prefs[effects])
   if (use_effects) {
     ## prefixes distinguishing fixed, random effects
 
@@ -240,6 +240,14 @@ tidy.brmsfit <- function(x, parameters = NA,
 
     }
     out <- dplyr::bind_rows(res_list, .id = "effect")
+    # In the case where nrow(res_list$fixed) > 0 but nrow(res_list$ran_pars) == 0,
+    # the out object needs to be fixed a bit (replace columns with unexpected
+    # lists of NULL by expected vectors of NA).
+    for (col in c("group", "term")) {
+      if (is.list(out[[col]]) && all(sapply(out[[col]], is.null))) {
+        out[[col]] <- rep(NA, nrow(out))
+      }
+    }
     v <- if (fixed.only) seq(nrow(out)) else is.na(out$term)
     newterms <- stringr::str_remove(terms[v], mkRE(prefs[c("fixed")]))
     if (fixed.only) {

diff --git a/inst/extdata/brms_example.rda b/inst/extdata/brms_example.rda
diff --git a/inst/extdata/run_examples.R b/inst/extdata/run_examples.R
@@ -220,8 +220,20 @@ if (run_brms) {
                    iter=200)
     brms_RE <- hack_size(brms_RE)
 
+    # Example taken from ?brms::brm
+    ## Probit regression using the binomial family
+    ntrials <- sample(1:10, 100, TRUE)
+    success <- rbinom(100, size = ntrials, prob = 0.4)
+    x <- rnorm(100)
+    data4 <- data.frame(ntrials, success, x)
+    fit4 <- brm(success | trials(ntrials) ~ x, data = data4,
+                family = binomial("probit"))
+    brms_brm_fit4 <- hack_size(fit4)
+
+
     save_file(brms_crossedRE, brms_zip, brms_multi, brms_noran,
-              brms_multi_RE, brms_RE, pkg = pkg, type = "rda")
+              brms_multi_RE, brms_RE, brms_brm_fit4,
+              pkg = pkg, type = "rda")
   })
 }
 

diff --git a/tests/testthat/test-brms.R b/tests/testthat/test-brms.R
@@ -17,4 +17,36 @@ if (require(brms, quietly = TRUE) && require(rstanarm, quietly=TRUE)) {
   ## GH #101
   gg <- glance(brms_noran)
   expect_equal(names(gg),c("algorithm","pss","nobs","sigma"))
+
+  ## Check the descriptive columns of tidy summaries
+  ### brms_RE
+  expected <- tibble::tribble(
+     ~effect, ~component,     ~group,                         ~term,
+     "fixed",     "cond",         NA,                 "(Intercept)",
+     "fixed",     "cond",         NA,                  "Days_extra",
+  "ran_pars",     "cond",  "Subject",             "sd__(Intercept)",
+  "ran_pars",     "cond",  "Subject",              "sd__Days_extra",
+  "ran_pars",     "cond",  "Subject", "cor__(Intercept).Days_extra",
+  "ran_pars",     "cond", "Residual",             "sd__Observation"
+  )
+  observed <- suppressWarnings(tidy(brms_RE))
+  expect_equal(observed[, 1:4], expected)
+  ### brms_noran
+  expected <- tibble::tribble(
+     ~effect, ~component,     ~group,             ~term,
+     "fixed",     "cond",         NA,     "(Intercept)",
+     "fixed",     "cond",         NA,              "wt",
+  "ran_pars",     "cond", "Residual", "sd__Observation"
+  )
+  observed <- suppressWarnings(tidy(brms_noran))
+  expect_equal(observed[, 1:4], expected)
+  ### brms_brm_fit4
+  expected <- tibble::tribble(
+  ~effect, ~component, ~group,         ~term,
+  "fixed",     "cond",     NA, "(Intercept)",
+  "fixed",     "cond",     NA,           "x"
+  )
+  observed <- suppressWarnings(tidy(brms_brm_fit4))
+  expect_equal(observed[, 1:4], expected)
+
 }