Merge branch 'main' into pool_functions

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: modelbased
 Title: Estimation of Model-Based Predictions, Contrasts and Means
-Version: 0.9.0.6
+Version: 0.9.0.8
 Authors@R:
     c(person(given = "Dominique",
              family = "Makowski",
@@ -92,3 +92,4 @@ Roxygen: list(markdown = TRUE)
 Config/Needs/check: stan-dev/cmdstanr
 Config/Needs/website: easystats/easystatstemplate
 LazyData: true
+Remotes: easystats/insight

NEWS.md

@@ -7,6 +7,9 @@
 
 ## Changes
 
+* The `print()` method is now explicitly documented and gets some new options
+  to customize the output for tables.
+
 * New option `"esarey"` for the `p_adjust` argument. The `"esarey"` option is
   specifically for the case of Johnson-Neyman intervals, i.e. when calling
   `estimate_slopes()` with two numeric predictors in an interaction term.

R/format.R

@@ -1,12 +1,38 @@
 # Format ------------------------------------------------------------------
 
 #' @export
-format.estimate_contrasts <- function(x, format = NULL, ...) {
+format.estimate_contrasts <- function(x,
+                                      format = NULL,
+                                      select = getOption("modelbased_select", NULL),
+                                      include_grid = getOption("modelbased_include_grid", FALSE),
+                                      ...) {
   # don't print columns of adjusted_for variables
   adjusted_for <- attr(x, "adjusted_for", exact = TRUE)
-  if (!is.null(adjusted_for) && all(adjusted_for %in% colnames(x))) {
+  if (!is.null(adjusted_for) && all(adjusted_for %in% colnames(x)) && !isTRUE(include_grid)) {
     # remove non-focal terms from data frame
     x[adjusted_for] <- NULL
+  } else if (isTRUE(include_grid)) {
+    # we include the data grid, so we don't need to add the same information
+    # to the footer
+    table_footer <- attributes(x)$table_footer
+    if (!is.null(table_footer)) {
+      # (Predictors controlled.*?): This is the first capturing group.
+      # - `Predictors controlled`: Matches the literal string "Predictors controlled".
+      # - `.*?`: Matches any character (.) zero or more times (*), but as few
+      #    times as possible (?). This is important to avoid matching across
+      #    multiple lines. This is a non-greedy quantifier.
+      # `(\n|$)`: This is the second capturing group.
+      # - \n: Matches a newline character.
+      # - $: Matches the end of the string.
+      # - |: Acts as an "OR" operator. So, this part matches either a newline
+      #   or the end of the string. This is necessary to capture the last match
+      #   if it's at the very end of the string and not followed by a newline.
+      # (powered by Gemini)
+      pattern <- "(Predictors controlled.*?)(\n|$)"
+      table_footer[1] <- gsub(pattern, "", table_footer[1])
+      # add back modified footer
+      attr(x, "table_footer") <- table_footer
+    }
   }
 
   # arrange columns (not for contrast now)
@@ -34,10 +60,15 @@ format.estimate_contrasts <- function(x, format = NULL, ...) {
   # remove all-NA columns
   x <- datawizard::remove_empty_columns(x)
 
+  # add back adjusted_for variables when we have custom column layouts
+  if (!is.null(select)) {
+    attr(x, "focal_terms") <- unique(c(attr(x, "focal_terms"), adjusted_for))
+  }
+
   if (!is.null(format) && format %in% c("md", "markdown", "html")) {
-    insight::format_table(x, ci_brackets = c("(", ")"), ...)
+    insight::format_table(x, ci_brackets = c("(", ")"), select = select, format = "html", ...)
   } else {
-    insight::format_table(x, ...)
+    insight::format_table(x, select = select, ...)
   }
 }
 

R/print.R

@@ -1,7 +1,71 @@
+#' Printing modelbased-objects
+#'
+#' `print()` method for **modelbased** objects. Can be used to tweak the output
+#' of tables.
+#'
+#' @param x An object returned by the different `estimate_*()` functions.
+#' @param include_grid Logical, if `TRUE`, the data grid is included in the
+#' table output. Only applies to prediction-functions like `estimate_relation()`
+#' or `estimate_link()`.
+#' @param full_labels Logical, if `TRUE` (default), all labels for focal terms
+#' are shown. If `FALSE`, redundant (duplicated) labels are removed from rows.
+#' @param ... Arguments passed to `insight::format_table()` or
+#' `insight::export_table()`.
+#'
+#' @inheritParams insight::format_table
+#'
+#' @return Invisibly returns `x`.
+#'
+#' @section Global Options to Customize Tables when Printing:
+#' Columns and table layout can be customized using `options()`:
+#'
+#' - `modelbased_select`: `options(modelbased_select = <string>)` will set a
+#'   default value for the `select` argument and can be used to define a custom
+#'   default layout for printing.
+#'
+#' - `modelbased_include_grid`: `options(modelbased_include_grid = TRUE)` will
+#'   set a default value for the `include_grid` argument and can be used to
+#'   include data grids in the output by default or not.
+#'
+#' - `modelbased_full_labels`: `options(modelbased_full_labels = FALSE)` will
+#'   remove redundant (duplicated) labels from rows.
+#'
+#' @note Use `print_html()` and `print_md()` to create tables in HTML or
+#' markdown format, respectively.
+#'
+#' @examplesIf insight::check_if_installed("marginaleffects", quietly = TRUE)
+#' model <- lm(Petal.Length ~ Species, data = iris)
+#' out <- estimate_means(model, "Species")
+#'
+#' # default
+#' print(out)
+#'
+#' # smaller set of columns
+#' print(out, select = "minimal")
+#'
+#' # remove redundant labels
+#' data(efc, package = "modelbased")
+#' efc <- datawizard::to_factor(efc, c("c161sex", "c172code", "e16sex"))
+#' levels(efc$c172code) <- c("low", "mid", "high")
+#' fit <- lm(neg_c_7 ~ c161sex * c172code * e16sex , data = efc)
+#' out <- estimate_means(fit, c("c161sex", "c172code", "e16sex"))
+#' print(out, full_labels = FALSE, select = "{estimate} ({se})")
+#'
 #' @export
-print.estimate_contrasts <- function(x, full_labels = TRUE, ...) {
+print.estimate_contrasts <- function(x,
+                                     select = getOption("modelbased_select", NULL),
+                                     include_grid = getOption("modelbased_include_grid", FALSE),
+                                     full_labels = getOption("modelbased_full_labels", TRUE),
+                                     ...) {
+  # copy original
+  out <- x
+  # get attributes, but remove some of them - else, matching attribute fails
+  attr <- attributes(x)
+  attr <- attr[setdiff(names(attr), c("names", "row.names"))]
+
   # format table
-  out <- format(x, ...)
+  out <- format(out, select = select, include_grid = include_grid, ...)
+  attributes(out) <- utils::modifyList(attributes(out), attr)
 
   # remove redundant labels, for "by" variables
   out <- .remove_redundant_labels(x, out, full_labels)
@@ -69,3 +133,42 @@ print.estimate_grouplevel <- print.estimate_contrasts
   }
   align
 }
+
+
+.format_layout <- function(x, select) {
+  # possible names for estimate column
+  estimate_names <- unique(
+    attributes(x)$coef_name,
+    c("Coefficient", "Slope", "Predicted", "Median", "Mean", "MAP", "Difference", "Ratio")
+  )
+  # define column name for estimates
+  estimate_col <- estimate_names[which.min(estimate_names == colnames(x))]
+  # focal terms
+  focal_terms <- intersect(
+    c("Level1", "Level2", attributes(x)$focal_terms),
+    colnames(x)
+  )
+
+  # do we have shortcuts for "select"?
+  select <- switch(select,
+    # basic output, only focal terms, estimate, CI and p
+    basic = {
+      out <- c(focal_terms, estimate_col, "CI_low", "CI_high")
+      if ("p" %in% colnames(x)) {
+        out <- c(out, "p")
+      }
+      out
+    },
+    select
+  )
+
+  # if "select" refers to column names, return selected columns
+  if (all(select %in% colnames(x))) {
+    return(x[select])
+  }
+
+  # add significant stars, in case it's requested
+  x$stars <- insight::format_p(x$p, stars = TRUE, stars_only = TRUE)
+
+  x
+}

R/print_html.R

@@ -1,6 +1,22 @@
 #' @export
-print_html.estimate_contrasts <- function(x, full_labels = TRUE, ...) {
-  formatted_table <- format(x, format = "html", ...)
+print_html.estimate_contrasts <- function(x,
+                                          select = getOption("modelbased_select", NULL),
+                                          include_grid = getOption("modelbased_include_grid", FALSE),
+                                          full_labels = TRUE,
+                                          ...) {
+  # copy original
+  out <- x
+  # get attributes, but remove some of them - else, matching attribute fails
+  attr <- attributes(x)
+  attr <- attr[setdiff(names(attr), c("names", "row.names"))]
+
+  # select columns to print
+  if (!is.null(select)) {
+    out <- .format_layout(out, select)
+    attributes(out) <- utils::modifyList(attributes(out), attr)
+  }
+
+  formatted_table <- format(out, format = "html", include_grid = include_grid, ...)
 
   # remove redundant labels, for "by" variables
   formatted_table <- .remove_redundant_labels(x, formatted_table, full_labels)

R/print_md.R

@@ -1,6 +1,22 @@
 #' @export
-print_md.estimate_contrasts <- function(x, full_labels = TRUE, ...) {
-  formatted_table <- format(x, format = "markdown", ...)
+print_md.estimate_contrasts <- function(x,
+                                        select = getOption("modelbased_select", NULL),
+                                        include_grid = getOption("modelbased_include_grid", FALSE),
+                                        full_labels = TRUE,
+                                        ...) {
+  # copy original
+  out <- x
+  # get attributes, but remove some of them - else, matching attribute fails
+  attr <- attributes(x)
+  attr <- attr[setdiff(names(attr), c("names", "row.names"))]
+
+  # select columns to print
+  if (!is.null(select)) {
+    out <- .format_layout(out, select)
+    attributes(out) <- utils::modifyList(attributes(out), attr)
+  }
+
+  formatted_table <- format(out, format = "markdown", include_grid = include_grid, ...)
 
   # remove redundant labels, for "by" variables
   formatted_table <- .remove_redundant_labels(x, formatted_table, full_labels)

pkgdown/_pkgdown.yml

@@ -16,6 +16,7 @@ reference:
       - starts_with("pool_")
   - title: "Miscellaenous"
     contents:
+      - print.estimate_contrasts
       - describe_nonlinear
       - get_emmeans
       - get_marginalmeans