Improve efficiency of clean_parameters() for more complex *brms* models (#1082)

* Improve efficiency of `clean_parameters()` for more complex *brms* models

* fix

Author: strengejacke

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: insight
 Title: Easy Access to Model Information for Various Model Objects
-Version: 1.3.0.5
+Version: 1.3.0.6
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",

NEWS.md

@@ -14,6 +14,8 @@
 
 * Better support for models of class `sdmTMB`.
 
+* Improve efficiency of `clean_parameters()` for more complex *brms* models.
+
 ## Bug fixes
 
 * Fixed issue in `clean_names()` for *brms* models with `mm()` in formula.

R/clean_parameters.R

@@ -502,6 +502,20 @@ clean_parameters.mlm <- function(x, ...) {
     }
   }
 
+  # multimembership / mixture?
+  model_fam <- get_family(x)
+  if (inherits(model_fam, "brmsfamily") && model_fam$family == "mixture") {
+    class_params <- grepl("^b_mu\\d+_(.*)", out$Parameter)
+    if (any(class_params)) {
+      out$Group[class_params] <- paste(
+        "Class",
+        gsub("^b_mu(\\d+)_(.*)", "\\1", out$Parameter[class_params])
+      )
+    }
+  } else {
+    class_params <- NULL
+  }
+
   # retrieve auxiliary components
   dpars <- find_auxiliary(x)
 
@@ -524,6 +538,15 @@ clean_parameters.mlm <- function(x, ...) {
   out$Cleaned_Parameter <- gsub(pattern = "^(b_|bs_|bsp_|bcs_)(?!zi_)(.*)", "\\2", out$Cleaned_Parameter, perl = TRUE)
   out$Cleaned_Parameter <- gsub(pattern = "^(b_zi_|bs_zi_|bsp_zi_|bcs_zi_)(.*)", "\\2", out$Cleaned_Parameter) # nolint
 
+  if (!is.null(class_params)) {
+    # remove "mu<number>_" from parameters
+    out$Cleaned_Parameter[class_params] <- gsub(
+      "^mu(\\d+)_(.*)",
+      "\\2",
+      out$Cleaned_Parameter[class_params]
+    )
+  }
+
   # correlation and sd
 
   cor_sd <- grepl("(sd_|cor_)(.*)", out$Cleaned_Parameter)
@@ -620,7 +643,11 @@ clean_parameters.mlm <- function(x, ...) {
     out$Cleaned_Parameter[intercepts] <- "(Intercept)"
   }
 
-  interaction_terms <- grep(".", out$Cleaned_Parameter, fixed = TRUE)
+  interaction_terms <- grep(
+    ".",
+    out$Cleaned_Parameter[out$Effects != "random"],
+    fixed = TRUE
+  )
 
   if (length(interaction_terms)) {
     for (i in interaction_terms) {

R/get_predicted_bayesian.R

@@ -1,19 +1,19 @@
 # Bayesian --------------------------------------------------------------
 # =======================================================================
 
-
 #' @rdname get_predicted
 #' @export
-get_predicted.stanreg <- function(x,
-                                  data = NULL,
-                                  predict = "expectation",
-                                  iterations = NULL,
-                                  ci = NULL,
-                                  ci_method = NULL,
-                                  include_random = "default",
-                                  include_smooth = TRUE,
-                                  verbose = TRUE,
-                                  ...) {
+get_predicted.stanreg <- function(
+    x,
+    data = NULL,
+    predict = "expectation",
+    iterations = NULL,
+    ci = NULL,
+    ci_method = NULL,
+    include_random = "default",
+    include_smooth = TRUE,
+    verbose = TRUE,
+    ...) {
   check_if_installed("rstantools")
 
   if (is.null(ci_method)) {
@@ -51,7 +51,8 @@ get_predicted.stanreg <- function(x,
   # }
 
   # prepare arguments, avoid possible matching by multiple actual arguments
-  fun_args <- list(x,
+  fun_args <- list(
+    x,
     newdata = my_args$data,
     re.form = my_args$re.form,
     dpar = my_args$distributional_parameter,
@@ -82,8 +83,10 @@ get_predicted.stanreg <- function(x,
   model_family <- get_family(x)
   # exceptions
   is_wiener <- inherits(model_family, "brmsfamily") && model_family$family == "wiener"
-  is_rtchoice <- model_family$family == "custom" && model_family$name == "lnr"
-  is_mixture <- model_family$family == "mixture"
+  is_rtchoice <- inherits(model_family, "brmsfamily") &&
+    model_family$family == "custom" &&
+    model_family$name == "lnr"
+  is_mixture <- inherits(model_family, "brmsfamily") && model_family$family == "mixture"
 
   # Special case for rwiener (get choice 1 as negative values)
   # Note that for mv models, x$family returns a list of families
@@ -101,7 +104,10 @@ get_predicted.stanreg <- function(x,
   }
 
   # Handle special cases
-  if (!my_args$predict %in% c("expectation", "response", "link") && inherits(model_family, "brmsfamily")) {
+  if (
+    !my_args$predict %in% c("expectation", "response", "link") &&
+      inherits(model_family, "brmsfamily")
+  ) {
     if (is_wiener) {
       # Wiener (Drift Diffusion) Models --------------------
       # ----------------------------------------------------
@@ -146,7 +152,7 @@ get_predicted.stanreg <- function(x,
         # pp_mixture returns an array with probs, SE and intervals.
         # if requested, we extract the intervals here for the "ci_data"
         # data.frame
-        res <- lapply (seq_len(nrow(mixture_output)), function(i) {
+        res <- lapply(seq_len(nrow(mixture_output)), function(i) {
           max_prob <- which.max(mixture_output[i, 1, ])
           data.frame(
             Probability = mixture_output[i, 1, max_prob],