From f054c1fd19218c8bf3a66fb131711d73dc1eb67c Mon Sep 17 00:00:00 2001 From: Daniel Date: Fri, 10 Nov 2023 11:40:19 +0100 Subject: [PATCH] `brms::gr()` is not supported (#832) * `brms::gr()` is not supported Fixes #831 * see if this works * fix * lintr --- DESCRIPTION | 2 +- NEWS.md | 3 ++ R/clean_names.R | 2 +- R/find_formula.R | 8 +---- R/find_predictors.R | 9 +---- R/find_random.R | 10 +++--- R/helper_functions.R | 38 +++++++++++++++----- tests/testthat/test-brms_gr_random_effects.R | 28 +++++++++++++++ 8 files changed, 69 insertions(+), 31 deletions(-) create mode 100644 tests/testthat/test-brms_gr_random_effects.R diff --git a/DESCRIPTION b/DESCRIPTION index 96170961c..ae28c287b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: insight Title: Easy Access to Model Information for Various Model Objects -Version: 0.19.6.6 +Version: 0.19.6.7 Authors@R: c(person(given = "Daniel", family = "Lüdecke", diff --git a/NEWS.md b/NEWS.md index c9d087f4c..b3be32cd0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,9 @@ * Support for objects of class `ggcomparisons` from `ggeffects::hypothesis_test()`. +* `brms::gr()` is now supported, meaning that functions like `get_data()` or + `find_predictors()` now also work for models with group-specific random effects. + ## Changes to functions * `get_varcov()` for models of class `pgmm` (package *plm*) now also supported diff --git a/R/clean_names.R b/R/clean_names.R index 02f6f6306..93a6539ba 100644 --- a/R/clean_names.R +++ b/R/clean_names.R @@ -121,7 +121,7 @@ clean_names.character <- function(x, include_names = FALSE, ...) { "asis", "matrx", "pol", "strata", "strat", "scale", "scored", "interaction", "sqrt", "sin", "cos", "tan", "acos", "asin", "atan", "atan2", "exp", "lsp", "rcs", "pb", "lo", "bs", "ns", "mSpline", "bSpline", "t2", "te", "ti", "tt", # need to be fixed first "mmc", "mm", - "mi", "mo", "gp", "s", "I", "relevel(as.factor", "relevel" + "mi", "mo", "gp", "s", "I", "gr", "relevel(as.factor", "relevel" ) # sometimes needed for panelr models, where we need to preserve "lag()" diff --git a/R/find_formula.R b/R/find_formula.R index 39070f029..8360e54e0 100644 --- a/R/find_formula.R +++ b/R/find_formula.R @@ -194,13 +194,7 @@ find_formula.gamlss <- function(x, verbose = TRUE, ...) { } else if (grepl("random\\((.*)\\)", safe_deparse(f.cond))) { f.cond <- safe_deparse(f.cond) # remove namespace prefixes - if (grepl("::", f.cond, fixed = TRUE)) { - # Here's a regular expression pattern in R that removes any word - # followed by two colons from a string: This pattern matches a word - # boundary (\\b), followed by one or more word characters (\\w+), - # followed by two colons (::) - f.cond <- gsub("\\b\\w+::", "\\2", f.cond) - } + f.cond <- .remove_namespace_from_string(f.cond) re <- gsub("(.*)random\\((.*)\\)", "\\2", f.cond) f.random <- stats::as.formula(paste0("~1|", re)) f.cond <- stats::update.formula( diff --git a/R/find_predictors.R b/R/find_predictors.R index a4283d241..0456cffb0 100644 --- a/R/find_predictors.R +++ b/R/find_predictors.R @@ -296,15 +296,8 @@ find_predictors.afex_aov <- function(x, # for survival models, separate out strata element if (inherits(x, "coxph")) { f_cond <- safe_deparse(f[["conditional"]]) - # remove namespace prefixes - if (grepl("::", f_cond, fixed = TRUE)) { - # Here's a regular expression pattern in R that removes any word - # followed by two colons from a string: This pattern matches a word - # boundary (\\b), followed by one or more word characters (\\w+), - # followed by two colons (::) - f_cond <- gsub("\\b\\w+::", "\\2", f_cond) - } + f_cond <- .remove_namespace_from_string(f_cond) if (grepl("strata(", f_cond, fixed = TRUE)) { # create regular expressions to find strata terms diff --git a/R/find_random.R b/R/find_random.R index 7793ae0b1..98b816358 100644 --- a/R/find_random.R +++ b/R/find_random.R @@ -87,12 +87,12 @@ find_random.afex_aov <- function(x, split_nested = FALSE, flatten = FALSE) { r1 <- unique(unlist(lapply( f$random, .get_model_random, - split_nested, - model = x + model = x, + split_nested = split_nested ), use.names = FALSE)) } else { r1 <- unique(unlist( - .get_model_random(f$random, split_nested, x), + .get_model_random(f$random, model = x, split_nested), use.names = FALSE )) } @@ -104,11 +104,11 @@ find_random.afex_aov <- function(x, split_nested = FALSE, flatten = FALSE) { if (object_has_names(f, "zero_inflated_random")) { if (is.list(f$zero_inflated_random)) { r2 <- unique(unlist( - lapply(f$zero_inflated_random, .get_model_random, split_nested, model = x), + lapply(f$zero_inflated_random, .get_model_random, model = x, split_nested = split_nested), use.names = FALSE )) } else { - r2 <- unique(.get_model_random(f$zero_inflated_random, split_nested, x)) + r2 <- unique(.get_model_random(f$zero_inflated_random, model = x, split_nested)) } } else { r2 <- NULL diff --git a/R/helper_functions.R b/R/helper_functions.R index 9d1e7a35f..9616fa9e5 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -21,7 +21,6 @@ } - # is string empty? .is_empty_string <- function(x) { x <- x[!is.na(x)] @@ -39,6 +38,19 @@ } +.remove_namespace_from_string <- function(x) { + # remove namespace prefixes + if (grepl("::", x, fixed = TRUE)) { + # Here's a regular expression pattern in R that removes any word + # followed by two colons from a string: This pattern matches a word + # boundary (\\b), followed by one or more word characters (\\w+), + # followed by two colons (::) + x <- gsub("\\b\\w+::", "\\2", x) + } + x +} + + # checks if a brms-models is a multi-membership-model .is_multi_membership <- function(x) { if (inherits(x, "brmsfit")) { @@ -109,7 +121,7 @@ # extract random effects from formula -.get_model_random <- function(f, split_nested = FALSE, model) { +.get_model_random <- function(f, model, split_nested = FALSE) { is_special <- inherits( model, c( @@ -135,8 +147,16 @@ } # check for multi-membership models - if (inherits(model, "brmsfit") && grepl("mm\\((.*)\\)", re)) { - re <- trim_ws(unlist(strsplit(gsub("mm\\((.*)\\)", "\\1", re), ",", fixed = TRUE))) + if (inherits(model, "brmsfit")) { + if (grepl("mm\\((.*)\\)", re)) { + re <- trim_ws(unlist(strsplit(gsub("mm\\((.*)\\)", "\\1", re), ",", fixed = TRUE))) + } + if (grepl("gr\\((.*)\\)", re)) { + # remove namespace prefixes + re <- .remove_namespace_from_string(re) + # extract random effects term + re <- trim_ws(gsub("gr\\((\\w+)(,.*|)\\)", "\\1", re)) + } } if (split_nested) { @@ -177,9 +197,9 @@ # .get_model_random() .get_group_factor <- function(x, f) { if (is.list(f)) { - f <- lapply(f, .get_model_random, split_nested = TRUE, model = x) + f <- lapply(f, .get_model_random, model = x, split_nested = TRUE) } else { - f <- .get_model_random(f, split_nested = TRUE, x) + f <- .get_model_random(f, model = x, split_nested = TRUE) } if (is.null(f)) { @@ -629,9 +649,7 @@ } list(slashTerms(x[[2]]), slashTerms(x[[3]])) } - if (!is.list(bb)) { - expandSlash(list(bb)) - } else { + if (is.list(bb)) { unlist(lapply(bb, function(x) { trms <- slashTerms(x[[3]]) if (length(x) > 2 && is.list(trms)) { @@ -642,6 +660,8 @@ x } })) + } else { + expandSlash(list(bb)) } } modterm <- .expandDoubleVerts(if (methods::is(term, "formula")) { diff --git a/tests/testthat/test-brms_gr_random_effects.R b/tests/testthat/test-brms_gr_random_effects.R new file mode 100644 index 000000000..3e7ff5a40 --- /dev/null +++ b/tests/testthat/test-brms_gr_random_effects.R @@ -0,0 +1,28 @@ +skip_on_cran() +skip_on_os("mac") +skip_if_not_installed("brms") +skip_if_not_installed("withr") + +withr::with_environment( + new.env(), + test_that("correctly handle brms::gr()", { + data(epilepsy, package = "brms") + # assign function, without loading the package + gr <- brms::gr + m <- suppressWarnings(suppressMessages( + brms::brm(count ~ Trt + (1 | gr(patient, by = Trt)), data = epilepsy, refresh = 0) + )) + expect_equal( + find_formula(m), + list( + conditional = count ~ Trt, + random = ~ 1 | gr(patient, by = Trt) + ), + ignore_attr = TRUE + ) + expect_identical(find_predictors(m, "all"), list(conditional = "Trt", random = "patient")) + expect_identical(find_random(m), list(random = "patient")) + d <- get_data(m) + expect_named(d, c("count", "Trt", "patient")) + }) +)