Skip to content

Commit

Permalink
Merge pull request #148 from matthieu-bruneaux/fix-tidy-brmsfit
Browse files Browse the repository at this point in the history
Fix tidy.brmsfit() output for model without a `ran_pars` component
  • Loading branch information
bbolker committed Mar 30, 2024
2 parents 62fa7d8 + f17e221 commit c6037eb
Show file tree
Hide file tree
Showing 4 changed files with 57 additions and 5 deletions.
16 changes: 12 additions & 4 deletions R/brms_tidiers.R
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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) {
Expand Down
Binary file modified inst/extdata/brms_example.rda
Binary file not shown.
14 changes: 13 additions & 1 deletion inst/extdata/run_examples.R
Original file line number Diff line number Diff line change
Expand Up @@ -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")
})
}

Expand Down
32 changes: 32 additions & 0 deletions tests/testthat/test-brms.R
Original file line number Diff line number Diff line change
Expand Up @@ -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)

}

0 comments on commit c6037eb

Please sign in to comment.