pretty_labels attribute includes NAs with interactions (#1033)

* `pretty_labels` attribute includes `NA`s with interactions
Fixes #1032

* don't use special char

* update snapshot, too

* fix lintr

DESCRIPTION

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

NEWS.md

@@ -5,6 +5,11 @@
 * The `robust` argument, which was deprecated for a long time, is now no longer
   supported. Please use `vcov` and `vcov_args` instead.
 
+## Bug fixes
+
+* Fixed bug when extracting 'pretty labels' for model parameters, which could
+  fail when predictors were character vectors.
+
 # parameters 0.23.0
 
 ## Breaking Changes

R/format_parameters.R

@@ -412,6 +412,9 @@ format_parameters.parameters_model <- function(model, ...) {
 
     # coefficient names (not labels)
     preds <- lapply(colnames(mf), function(i) {
+      if (is.character(mf[[i]])) {
+        mf[[i]] <- as.factor(mf[[i]])
+      }
       if (is.factor(mf[[i]])) {
         i <- paste0(i, levels(mf[[i]]))
       }

R/utils_model_parameters.R

@@ -51,7 +51,7 @@
   attr(params, "bootstrap") <- bootstrap
   attr(params, "iterations") <- iterations
   attr(params, "p_adjust") <- p_adjust
-  attr(params, "robust_vcov") <- isTRUE(list(...)$robust) || "vcov" %in% names(list(...))
+  attr(params, "robust_vcov") <- "vcov" %in% names(list(...))
   attr(params, "ignore_group") <- isFALSE(group_level)
   attr(params, "ran_pars") <- isFALSE(group_level)
   attr(params, "show_summary") <- isTRUE(include_info)

tests/testthat/_snaps/pretty_names.md

@@ -0,0 +1,21 @@
+# pretty_labels
+
+    Code
+      print(p)
+    Output
+      Parameter   | Log-Odds |   SE |       95% CI |    z |      p
+      ------------------------------------------------------------
+      (Intercept) |     0.44 | 0.07 | [0.30, 0.58] | 6.07 | < .001
+      X           |     0.26 | 0.10 | [0.06, 0.46] | 2.52 | 0.012 
+      M [b]       |     0.57 | 0.11 | [0.36, 0.78] | 5.29 | < .001
+      M [c]       |     0.97 | 0.11 | [0.75, 1.19] | 8.75 | < .001
+      X * M [b]   |     0.89 | 0.17 | [0.56, 1.24] | 5.17 | < .001
+      X * M [c]   |     1.41 | 0.21 | [1.00, 1.84] | 6.58 | < .001
+    Message
+      
+      Uncertainty intervals (profile-likelihood) and p-values (two-tailed)
+        computed using a Wald z-distribution approximation.
+      
+      The model has a log- or logit-link. Consider using `exponentiate =
+        TRUE` to interpret coefficients as ratios.
+

tests/testthat/test-complete_separation.R

@@ -3,41 +3,35 @@ skip_if_not_installed("withr")
 
 withr::with_options(
   list(parameters_warning_exponentiate = TRUE),
-  {
-    test_that("print warning about complete separation", {
-      d_sep <- data.frame(
-        y = c(0, 0, 0, 0, 1, 1, 1, 1),
-        x1 = c(1, 2, 3, 3, 5, 6, 10, 11),
-        x2 = c(3, 2, -1, -1, 2, 4, 1, 0)
-      )
-      m_sep <- suppressWarnings(glm(y ~ x1 + x2, data = d_sep, family = binomial))
-      out <- model_parameters(m_sep)
-      expect_snapshot(print(out))
-    })
-  }
+  test_that("print warning about complete separation", {
+    d_sep <- data.frame(
+      y = c(0, 0, 0, 0, 1, 1, 1, 1),
+      x1 = c(1, 2, 3, 3, 5, 6, 10, 11),
+      x2 = c(3, 2, -1, -1, 2, 4, 1, 0)
+    )
+    m_sep <- suppressWarnings(glm(y ~ x1 + x2, data = d_sep, family = binomial))
+    out <- model_parameters(m_sep)
+    expect_snapshot(print(out))
+  })
 )
 
 withr::with_options(
   list(parameters_warning_exponentiate = TRUE),
-  {
-    test_that("print warning about complete separation", {
-      data(mtcars)
-      m_sep2 <- suppressWarnings(glm(am ~ gear, data = mtcars, family = binomial))
-      out <- model_parameters(m_sep2)
-      expect_snapshot(print(out))
-    })
-  }
+  test_that("print warning about complete separation", {
+    data(mtcars)
+    m_sep2 <- suppressWarnings(glm(am ~ gear, data = mtcars, family = binomial))
+    out <- model_parameters(m_sep2)
+    expect_snapshot(print(out))
+  })
 )
 
 withr::with_options(
   list(parameters_warning_exponentiate = TRUE),
-  {
-    test_that("print warning about quasi complete separation", {
-      data(mtcars)
-      set.seed(323)
-      m_sep3 <- suppressWarnings(glm(vs ~ qsec, data = mtcars[sample(1:32, 15, replace = TRUE), ], family = binomial))
-      out <- model_parameters(m_sep3)
-      expect_snapshot(print(out))
-    })
-  }
+  test_that("print warning about quasi complete separation", {
+    data(mtcars)
+    set.seed(323)
+    m_sep3 <- suppressWarnings(glm(vs ~ qsec, data = mtcars[sample.int(32, 15, replace = TRUE), ], family = binomial)) # nolint
+    out <- model_parameters(m_sep3)
+    expect_snapshot(print(out))
+  })
 )

tests/testthat/test-pretty_namesR.R → tests/testthat/test-pretty_names.R

@@ -33,3 +33,35 @@ test_that("pretty_names", {
     )
   )
 })
+
+skip_if_not_installed("withr")
+
+# make sure we have the correct interaction mark for tests
+withr::with_options(
+  list(parameters_interaction = "*", parameters_warning_exponentiate = TRUE),
+  test_that("pretty_labels", {
+    set.seed(1024)
+    N <- 5000
+    X <- rbinom(N, 1, 0.5)
+    M <- sample(c("a", "b", "c"), N, replace = TRUE)
+    b <- runif(8, -1, 1)
+    Y <- rbinom(N, 1, prob = plogis(
+      b[1] + b[2] * X +
+      b[3] * (M == "b") + b[4] * (M == "b") + b[5] * (M == "c") +
+      b[6] * X * (M == "a") + b[7] * X + (M == "b") +
+      b[8] * X * (M == "c")
+    ))
+    dat <- data.frame(Y, X, M, stringsAsFactors = FALSE)
+    mod <- glm(Y ~ X * M, data = dat, family = binomial)
+
+    p <- parameters(mod)
+    expect_identical(
+      attr(p, "pretty_labels"),
+      c(
+        `(Intercept)` = "(Intercept)", X = "X", Mb = "M [b]", Mc = "M [c]",
+        `X:Mb` = "X * M [b]", `X:Mc` = "X * M [c]"
+      )
+    )
+    expect_snapshot(print(p))
+  })
+)