include_reference not working in model_parameters with glmmTMB object (#1093)

* include_reference not working in model_parameters with glmmTMB object
Fixes #1092

* revert

* fix

* fix

* news

* update

* lintr

Author: strengejacke

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: parameters
 Title: Processing of Model Parameters
-Version: 0.24.2.20
+Version: 0.24.2.21
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",

NEWS.md

@@ -18,6 +18,9 @@
 * Fixed printing issue with `model_parameters()` for `htest` objects when
   printing into markdown or HTML format.
 
+* Fixed printing issue with `model_parameters()` for mixed models when
+  `include_reference = TRUE`.
+
 # parameters 0.24.2
 
 ## Changes

R/utils.R

@@ -116,6 +116,14 @@
   # match column order
   row <- row[match(colnames(data), colnames(row))]
 
+  # modify effects and component column - required for printing
+  if ("Effects" %in% colnames(row)) {
+    row$Effects <- data$Effects[1]
+  }
+  if ("Component" %in% colnames(row)) {
+    row$Component <- data$Component[1]
+  }
+
   # insert row
   if (index == 1) {
     rbind(row, data)

R/utils_format.R

@@ -480,11 +480,24 @@
       out <- .insert_row_at(out, row_data, min(found))
     }
   }
-  # update pretty_names attribute
-  attr(out, "pretty_names") <- pretty_names
-  # update pretty_labels attribute
-  pretty_names[match(names(attr(out, "pretty_labels")), names(pretty_names))] <- attr(out, "pretty_labels")
-  attr(out, "pretty_labels") <- pretty_names
+
+  if (length(pretty_names)) {
+    # update pretty_names attribute
+    attr(out, "pretty_names") <- pretty_names
+    # update pretty_labels attribute - for mixed models, we need to add the random
+    # effects stuff from pretty_labels to pretty_names first, else, matching will
+    # fail
+    pretty_labels <- attributes(out)$pretty_labels
+    if (!is.null(pretty_labels)) {
+      re_labels <- startsWith(names(pretty_labels), "SD (") | startsWith(names(pretty_labels), "Cor (")
+      if (any(re_labels)) {
+        pretty_names <- c(pretty_names, pretty_labels[re_labels])
+      }
+      pretty_names[stats::na.omit(match(names(pretty_labels), names(pretty_names)))] <- pretty_labels
+      pretty_names <- pretty_names[!re_labels]
+    }
+    attr(out, "pretty_labels") <- pretty_names
+  }
 
   out
 }
@@ -703,9 +716,9 @@
   }
 
   # clean some special parameter names
-  component_name <- gsub("zi", "Zero-Inflation", component_name)
-  component_name <- gsub("zoi", "Zero-One-Inflation", component_name)
-  component_name <- gsub("coi", "Conditional-One-Inflation", component_name)
+  component_name <- gsub("zi", "Zero-Inflation", component_name, fixed = TRUE)
+  component_name <- gsub("zoi", "Zero-One-Inflation", component_name, fixed = TRUE)
+  component_name <- gsub("coi", "Conditional-One-Inflation", component_name, fixed = TRUE)
 
   # if we show ZI component only, make sure this appears in header
   if (!grepl("(Zero-Inflation Component)", component_name, fixed = TRUE) &&

tests/testthat/_snaps/include_reference.md

@@ -155,3 +155,72 @@
       Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
         using a Wald t-distribution approximation.
 
+# include_reference, random effects models
+
+    Code
+      print(out)
+    Output
+      # Fixed Effects
+      
+      Parameter          | Odds Ratio |       SE |       95% CI |     z |      p
+      --------------------------------------------------------------------------
+      (Intercept)        |   1.81e-06 | 4.52e-06 | [0.00, 0.00] | -5.29 | < .001
+      flipper len        |       1.07 |     0.01 | [1.04, 1.09] |  5.33 | < .001
+      island [Biscoe]    |       1.00 |          |              |       |       
+      island [Dream]     |       2.84 |     0.93 | [1.49, 5.41] |  3.18 | 0.001 
+      island [Torgersen] |       2.97 |     1.22 | [1.32, 6.65] |  2.64 | 0.008 
+      
+      # Random Effects
+      
+      Parameter            | Coefficient |      95% CI
+      ------------------------------------------------
+      SD (Intercept: year) |    3.05e-05 | [0.00, Inf]
+    Message
+      
+      Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
+        using a Wald z-distribution approximation.
+
+---
+
+    Code
+      print(out, include_reference = TRUE)
+    Output
+      # Fixed Effects
+      
+      Parameter          | Odds Ratio |       SE |       95% CI |     z |      p
+      --------------------------------------------------------------------------
+      (Intercept)        |   1.81e-06 | 4.52e-06 | [0.00, 0.00] | -5.29 | < .001
+      flipper len        |       1.07 |     0.01 | [1.04, 1.09] |  5.33 | < .001
+      island [Biscoe]    |       1.00 |          |              |       |       
+      island [Dream]     |       2.84 |     0.93 | [1.49, 5.41] |  3.18 | 0.001 
+      island [Torgersen] |       2.97 |     1.22 | [1.32, 6.65] |  2.64 | 0.008 
+      
+      # Random Effects
+      
+      Parameter            | Coefficient |      95% CI
+      ------------------------------------------------
+      SD (Intercept: year) |    3.05e-05 | [0.00, Inf]
+    Message
+      
+      Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
+        using a Wald z-distribution approximation.
+
+---
+
+    Code
+      print(out)
+    Output
+      # Fixed Effects
+      
+      Parameter          | Odds Ratio |       SE |       95% CI |     z |      p
+      --------------------------------------------------------------------------
+      (Intercept)        |   1.81e-06 | 4.52e-06 | [0.00, 0.00] | -5.29 | < .001
+      flipper len        |       1.07 |     0.01 | [1.04, 1.09] |  5.33 | < .001
+      island [Biscoe]    |       1.00 |          |              |       |       
+      island [Dream]     |       2.84 |     0.93 | [1.49, 5.41] |  3.18 | 0.001 
+      island [Torgersen] |       2.97 |     1.22 | [1.32, 6.65] |  2.64 | 0.008 
+    Message
+      
+      Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
+        using a Wald z-distribution approximation.
+

tests/testthat/test-include_reference.R

@@ -103,3 +103,24 @@ test_that("include_reference, different contrasts", {
   out <- model_parameters(m, include_reference = TRUE)
   expect_snapshot(print(out))
 })
+
+
+test_that("include_reference, random effects models", {
+  skip_if_not_installed("glmmTMB")
+  skip_if(getRversion() < "4.5")
+  data(penguins, package = "datasets")
+  fit_penguins <- glmmTMB::glmmTMB(
+    sex ~ flipper_len + island + (1 | year),
+    family = binomial(),
+    data = penguins
+  )
+
+  out <- model_parameters(fit_penguins, exponentiate = TRUE, include_reference = TRUE)
+  expect_snapshot(print(out))
+
+  out <- model_parameters(fit_penguins, exponentiate = TRUE)
+  expect_snapshot(print(out, include_reference = TRUE))
+
+  out <- model_parameters(fit_penguins, effects = "fixed", exponentiate = TRUE, include_reference = TRUE)
+  expect_snapshot(print(out))
+})