make parameters() show fixed effects restricted to 0

DESCRIPTION

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

NEWS.md

@@ -8,6 +8,10 @@
 * `model_parameters()` for objects from package *marginaleffects*  now also
   accepts the `exponentiate` argument.
 
+* The `print()`, `print_html()`, `print_md()` and `format()` methods for
+  `model_parameters()` get an `add_reference` argument, to add the reference
+  category of categorical predictors to the parameters table.
+
 ## Bug fixes
 
 * Fixed issue with wrong calculation of test-statistic and p-values in

R/1_model_parameters.R

@@ -181,7 +181,7 @@
 #'
 #' Compared to fixed effects (or single-level) models, determining appropriate
 #' df for Wald-based inference in mixed models is more difficult.
 #' See [the R GLMM FAQ](https://bbolker.github.io/mixedmodels-misc/glmmFAQ.html#what-are-the-p-values-listed-by-summaryglmerfit-etc.-are-they-reliable)
 #' for a discussion.
 #'
 #' Several approximate methods for computing df are available, but you should
@@ -692,7 +692,7 @@
   # tell user that profiled CIs don't respect vcov-args
   if (identical(ci_method, "profile") && (!is.null(vcov) || !is.null(vcov_args)) && isTRUE(verbose)) {
     insight::format_alert(
       "When `ci_method=\"profile\"`, `vcov` only modifies standard errors, test-statistic and p-values, but not confidence intervals.",
       "Use `ci_method=\"wald\"` to return confidence intervals based on robust standard errors."
     )
   }
@@ -711,7 +711,8 @@
     keep_parameters = keep,
     drop_parameters = drop,
     vcov = vcov,
-    vcov_args = vcov_args
+    vcov_args = vcov_args,
+    verbose = verbose
   )
   args <- c(args, dots)
   out <- do.call(".model_parameters_generic", args)

R/display.R

@@ -91,6 +91,7 @@
                                      font_size = "100%",
                                      line_padding = 4,
                                      column_labels = NULL,
+                                     add_reference = FALSE,
                                      verbose = TRUE,
                                      ...) {
   if (identical(format, "html")) {
@@ -192,7 +193,7 @@
 #' @inheritParams model_parameters.principal
 #' @rdname display.parameters_model
 #' @export
 display.parameters_efa <- function(object, format = "markdown", digits = 2, sort = FALSE, threshold = NULL, labels = NULL, ...) {
   print_md(x = object, digits = digits, sort = sort, threshold = threshold, labels = labels, ...)
 }
 

R/format.R

@@ -15,6 +15,7 @@
                                     zap_small = FALSE,
                                     format = NULL,
                                     groups = NULL,
+                                    add_reference = FALSE,
                                     ...) {
   # save attributes
   coef_name <- attributes(x)$coefficient_name
@@ -167,6 +168,7 @@
       ci_width = ci_width,
       ci_brackets = ci_brackets,
       zap_small = zap_small,
+      add_reference = add_reference,
       ...
     )
   } else {
@@ -183,6 +185,7 @@
       format = format,
       coef_name = coef_name,
       zap_small = zap_small,
+      add_reference = add_reference,
       ...
     )
   }
@@ -614,7 +617,7 @@
 
 
 # footer: generic text
 .add_footer_text <- function(footer = NULL, text, type = "text") {
   if (!is.null(text)) {
     if (type == "text" || type == "markdown") {
       if (is.null(footer)) {
@@ -632,7 +635,7 @@
 
 
 # footer: residual standard deviation
 .add_footer_sigma <- function(footer = NULL, digits, sigma, residual_df = NULL, type = "text") {
   if (!is.null(sigma)) {
     # format residual df
     if (!is.null(residual_df)) {
@@ -657,7 +660,7 @@
 
 
 # footer: r-squared
 .add_footer_r2 <- function(footer = NULL, digits, r2 = NULL, type = "text") {
   if (!is.null(r2)) {
     rsq <- .safe(paste0(unlist(lapply(r2, function(i) {
       paste0(attributes(i)$names, ": ", insight::format_value(i, digits = digits))
@@ -681,7 +684,7 @@
 
 
 # footer: anova type
 .add_footer_anova_type <- function(footer = NULL, aov_type, type = "text") {
   if (!is.null(aov_type)) {
     if (type == "text" || type == "markdown") {
       if (is.null(footer)) {
@@ -699,7 +702,7 @@
 
 
 # footer: marginaleffects::comparisions() prediction_type
 .add_footer_prediction_type <- function(footer = NULL, prediction_type, type = "text") {
   if (!is.null(prediction_type)) {
     if (type == "text" || type == "markdown") {
       if (is.null(footer)) {
@@ -717,7 +720,7 @@
 
 
 # footer: anova test
 .add_footer_anova_test <- function(footer = NULL, test, type = "text") {
   if (!is.null(test)) {
     if (type == "text" || type == "markdown") {
       if (is.null(footer)) {
@@ -925,7 +928,7 @@
     if (!is.null(msg) && isTRUE(getOption("parameters_warning_exponentiate", TRUE))) {
       insight::format_alert(paste0("\n", msg))
       # set flag, so message only displayed once per session
-      options("parameters_warning_exponentiate" = FALSE)
+      options(parameters_warning_exponentiate = FALSE)
     }
   }
 }

R/print.parameters_model.R

@@ -87,6 +87,11 @@
 #'   labels will be used as parameters names. The latter only works for "labelled"
 #'   data, i.e. if the data used to fit the model had `"label"` and `"labels"`
 #'   attributes. See also section _Global Options to Customize Messages when Printing_.
+#' @param add_reference Logical, if `TRUE`, the reference level of factors will
+#'   be added to the parameters table. This is only relevant for models with
+#'   categorical predictors. The coefficient for the reference level is always
+#'   `0` (except when `exponentiate = TRUE`, then the coefficient will be `1`),
+#'   so this is just for completeness.
 #' @inheritParams insight::format_table
 #' @inheritParams compare_parameters
 #'
@@ -233,6 +238,7 @@ print.parameters_model <- function(x,
                                    groups = NULL,
                                    column_width = NULL,
                                    ci_brackets = c("[", "]"),
+                                   add_reference = FALSE,
                                    ...) {
   # save original input
   orig_x <- x
@@ -282,6 +288,7 @@ print.parameters_model <- function(x,
     ci_brackets = ci_brackets,
     format = "text",
     groups = groups,
+    add_reference = add_reference,
     ...
   )
 
@@ -378,6 +385,7 @@ print.parameters_random <- function(x, digits = 2, ...) {
                         ci_brackets = TRUE,
                         format = "text",
                         group = NULL,
+                        add_reference = FALSE,
                         ...) {
   format(
     x,
@@ -392,6 +400,7 @@ print.parameters_random <- function(x, digits = 2, ...) {
     zap_small = zap_small,
     format = format,
     group = group,
+    add_reference = add_reference,
     ...
   )
 }

R/print_html.R

@@ -22,6 +22,7 @@ print_html.parameters_model <- function(x,
                                         font_size = "100%",
                                         line_padding = 4,
                                         column_labels = NULL,
+                                        add_reference = FALSE,
                                         verbose = TRUE,
                                         ...) {
   # check if user supplied digits attributes
@@ -82,6 +83,7 @@ print_html.parameters_model <- function(x,
     ci_brackets = ci_brackets,
     format = "html",
     groups = groups,
+    add_reference = add_reference,
     ...
   )
 

R/print_md.R

@@ -19,6 +19,7 @@ print_md.parameters_model <- function(x,
                                       show_formula = FALSE,
                                       zap_small = FALSE,
                                       groups = NULL,
+                                      add_reference = FALSE,
                                       verbose = TRUE,
                                       ...) {
   # check if user supplied digits attributes
@@ -66,6 +67,7 @@ print_md.parameters_model <- function(x,
     ci_brackets = ci_brackets,
     format = "markdown",
     groups = groups,
+    add_reference = add_reference,
     ...
   )
 

R/utils.R

@@ -99,3 +99,48 @@
 .is_semLme <- function(x) {
   all(inherits(x, c("sem", "lme")))
 }
+
+
+.insert_row_at <- function(data, row, index, default_value = NA) {
+  # add missing columns
+  new_columns <- setdiff(colnames(data), colnames(row))
+  if (length(new_columns) > 0) {
+    row[new_columns] <- default_value
+  }
+  # match column order
+  row <- row[match(colnames(data), colnames(row))]
+
+  # insert row
+  if (index == 1) {
+    rbind(row, data)
+  } else if (index == (nrow(data) + 1)) {
+    rbind(data, row)
+  } else {
+    rbind(data[1:(index - 1), ], row, data[index:nrow(data), ])
+  }
+}
+
+
+.insert_element_at <- function(data, element, index) {
+  if (index == 1) {
+    c(element, data)
+  } else if (index == (length(data) + 1)) {
+    c(data, element)
+  } else {
+    c(data[1:(index - 1)], element, data[index:length(data)])
+  }
+}
+
+
+.find_factor_levels <- function(data) {
+  out <- lapply(colnames(data), function(i) {
+    v <- data[[i]]
+    if (is.factor(v)) {
+      paste0(i, levels(v))
+    } else {
+      NULL
+    }
+  })
+  names(out) <- names(data)
+  insight::compact_list(out)
+}

R/utils_format.R

@@ -280,6 +280,7 @@
                                              format = NULL,
                                              coef_name = NULL,
                                              zap_small = FALSE,
+                                             add_reference = FALSE,
                                              ...) {
   # default brackets are parenthesis for HTML / MD
   if ((is.null(ci_brackets) || isTRUE(ci_brackets)) && (identical(format, "html") || identical(format, "markdown"))) {
@@ -308,6 +309,11 @@
     x$Level <- NULL
   }
 
+  # add the coefficient for the base-(reference)-level of factors?
+  if (add_reference) {
+    x <- .add_reference_level(x)
+  }
+
   insight::format_table(
     x,
     pretty_names = pretty_names,
@@ -322,6 +328,86 @@
 }
 
 
+.add_reference_level <- function(params) {
+  # check if we have a model object, else return parameter table
+  model <- .get_object(params)
+  if (is.null(model)) {
+    params
+  }
+
+  # check if we have model data, else return parameter table
+  model_data <- insight::get_data(model)
+  if (is.null(model_data)) {
+    params
+  }
+
+  # find factors and factor levels and check if we have any factors in the data
+  factors <- .find_factor_levels(model_data)
+  if (!length(factors)) {
+    params
+  }
+
+  # we need some more information about prettified labels etc.
+  pretty_names <- attributes(params)$pretty_names
+  coef_name <- attributes(params)$coefficient_name
+  if (is.null(coef_name)) {
+    coef_name <- "Coefficient"
+  }
+  zi_coef_name <- attributes(params)$zi_coefficient_name
+  if (is.null(zi_coef_name)) {
+    zi_coef_name <- "Coefficient"
+  }
+
+  # copy object, so we save original data
+  out <- params
+
+  # if we use "keep" or "drop", we have less parameters in our data frame,
+  # so we need to make sure we only have those pretty_names, which names match
+  # the parameters in the data frame
+  pretty_names <- pretty_names[names(pretty_names) %in% params$Parameter]
+
+  # iterate all factors in the data and check if any factor was used in the model
+  for (fn in names(factors)) {
+    f <- factors[[fn]]
+    # "f" contains all combinations of factor name and levels from the data,
+    # which we can match with the names of the pretty_names vector
+    found <- which(names(pretty_names) %in% f)
+    # if we have a match, we add the reference level to the pretty_names vector
+    if (length(found)) {
+      # the reference level is *not* in the pretty names yet
+      reference_level <- f[!f %in% names(pretty_names)]
+      # create a pretty level for the reference category
+      pretty_level <- paste0(fn, " [", sub(fn, "", reference_level, fixed = TRUE), "]")
+      # insert new pretty level at the correct position in "pretty_names"
+      pretty_names <- .insert_element_at(
+        pretty_names,
+        stats::setNames(pretty_level, reference_level),
+        min(found)
+      )
+      # now we need to update the data as well (i.e. the parameters table)
+      row_data <- data.frame(
+        Parameter = reference_level,
+        Coefficient = as.numeric(attributes(params)$exponentiate),
+        stringsAsFactors = FALSE
+      )
+      # coefficient name can also be "Odds Ratio" etc., so make sure we
+      # have the correct column name in the data row we want to insert
+      if (coef_name %in% colnames(out)) {
+        colnames(row_data)[2] <- coef_name
+      } else if (zi_coef_name %in% colnames(out)) {
+        colnames(row_data)[2] <- zi_coef_name
+      }
+      out <- .insert_row_at(out, row_data, min(found))
+    }
+  }
+  # update pretty_names attribute
+  attr(out, "pretty_names") <- pretty_names
+  attr(out, "pretty_labels") <- pretty_names
+
+  out
+}
+
+
 # The coefficient column in the printed output is renamed, based on the model.
 # But for instance, for random effects, however, which are on a different scale,
 # we want a different name for this column. Since print.parameters_model() splits
@@ -765,6 +851,7 @@
                                                 ci_width = "auto",
                                                 ci_brackets = TRUE,
                                                 zap_small = FALSE,
+                                                add_reference = FALSE,
                                                 ...) {
   final_table <- list()
 
@@ -964,6 +1051,11 @@
       tables[[type]][[1]] <- insight::format_value(tables[[type]][[1]], digits = digits, protect_integers = TRUE)
     }
 
+    # add the coefficient for the base-(reference)-level of factors?
+    if (add_reference) {
+      tables[[type]] <- .add_reference_level(tables[[type]])
+    }
+
     formatted_table <- insight::format_table(
       tables[[type]],
       digits = digits, ci_digits = ci_digits,