Harmonize footers (#340)

* Add clearer footnote for special comparisons (#339)
* Add clearer footnote for special comparisons
Fixes #338

* fix

* update snapshot

* add tests

* lintr

* test

* Revert "test"

This reverts commit 2e5aad5.

* minor

* fix

* fix

* revise

* fix

* simplify

* oops

* fix

* Delete print.new.md

* Update get_marginalmeans.R

* Update modelbased.Rproj

* update snapshots

* update snapshots

* Update format.R

* update snapshots

* Update estimate_contrasts.md

* Update estimate_means_counterfactuals.md

* Update table_footer.R

* Update table_footer.R

* Update print.md

* Update estimate_contrasts.md

* fix test

* styler

Author: strengejacke

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: modelbased
 Title: Estimation of Model-Based Predictions, Contrasts and Means
-Version: 0.8.9.27
+Version: 0.8.9.28
 Authors@R:
     c(person(given = "Dominique",
              family = "Makowski",

R/estimate_contrasts.R

@@ -149,15 +149,12 @@ estimate_contrasts <- function(model,
 
   # Table formatting
   attr(out, "table_title") <- c("Marginal Contrasts Analysis", "blue")
-  attr(out, "table_footer") <- .estimate_means_footer(
+  attr(out, "table_footer") <- .table_footer(
     out,
-    info$contrast,
+    by = info$contrast,
     type = "contrasts",
-    p_adjust = p_adjust,
-    predict = attributes(estimated)$predict,
-    model_info = insight::model_info(model),
-    comparison = info$comparison,
-    datagrid = info$datagrid
+    model = model,
+    info = info
   )
 
   # Add attributes
@@ -168,10 +165,7 @@ estimate_contrasts <- function(model,
   attr(out, "backend") <- backend
 
   # add attributes from workhorse function
-  attributes(out) <- utils::modifyList(
-    attributes(out),
-    info[c("at", "by", "contrast", "predict", "p_adjust", "preserve_range")]
-  )
+  attributes(out) <- utils::modifyList(attributes(out), info[.info_elements()])
 
   # Output
   class(out) <- c("estimate_contrasts", "see_estimate_contrasts", class(out))

R/estimate_means.R

@@ -156,11 +156,11 @@ estimate_means <- function(model,
 
   # Table formatting
   attr(means, "table_title") <- c("Estimated Marginal Means", "blue")
-  attr(means, "table_footer") <- .estimate_means_footer(
+  attr(means, "table_footer") <- .table_footer(
     means,
-    type = ifelse(marginalize == "population", "counterfactuals", "means"),
-    predict = attributes(estimated)$predict,
-    model_info = insight::model_info(model)
+    by = info$by,
+    model = model,
+    info = info
   )
 
   # Add attributes
@@ -171,100 +171,9 @@ estimate_means <- function(model,
   attr(means, "coef_name") <- intersect(.valid_coefficient_names(), colnames(means))
 
   # add attributes from workhorse function
-  attributes(means) <- utils::modifyList(
-    attributes(means),
-    info[c("at", "by", "datagrid", "predict", "focal_terms", "preserve_range")]
-  )
+  attributes(means) <- utils::modifyList(attributes(means), info[.info_elements()])
 
   # Output
   class(means) <- unique(c("estimate_means", class(means)))
   means
 }
-
-
-# Table footer ===============================================================
-
-
-.estimate_means_footer <- function(x,
-                                   by = NULL,
-                                   type = "means",
-                                   p_adjust = NULL,
-                                   predict = NULL,
-                                   model_info = NULL,
-                                   comparison = NULL,
-                                   datagrid = NULL) {
-  table_footer <- switch(type,
-    counterfactuals = "Average",
-    "Marginal"
-  )
-  table_footer <- paste0("\n", table_footer, " ", type)
-
-  # Levels
-  if (!is.null(by) && length(by) > 0) {
-    table_footer <- paste0(table_footer, " estimated at ", toString(by))
-  } else {
-    table_footer <- paste0(table_footer, " estimated at ", attr(x, "by"))
-  }
-
-  # P-value adjustment footer
-  if (!is.null(p_adjust) && "p" %in% names(x)) {
-    if (p_adjust == "none") {
-      table_footer <- paste0(table_footer, "\np-values are uncorrected.")
-    } else {
-      table_footer <- paste0(table_footer, "\np-value adjustment method: ", parameters::format_p_adjust(p_adjust))
-    }
-  }
-
-  # tell user about scale of predictions / contrasts
-  if (!is.null(predict) && isFALSE(model_info$is_linear)) {
-    result_type <- switch(type,
-      counterfactuals = ,
-      means = "Predictions",
-      contrasts = "Contrasts"
-    )
-    # exceptions
-    predict <- switch(predict,
-      none = "link",
-      `invlink(link)` = "response",
-      predict
-    )
-    table_footer <- paste0(table_footer, "\n", result_type, " are on the ", predict, "-scale.")
-  }
-
-  # for special hypothesis testing, like "(b1 - b2) = (b4 - b3)", we want to
-  # add information about the parameter names
-  if (!is.null(comparison) && is.character(comparison) && grepl("=", comparison, fixed = TRUE) && grepl("\\bb\\d+\\b", comparison)) { # nolint
-    # find all "b" strings
-    matches <- gregexpr("\\bb\\d+\\b", comparison)[[1]]
-    match_lengths <- attr(matches, "match.length")
-
-    # extract all "b" strings, so we have a vector of all "b" used in the comparison
-    parameter_names <- unlist(lapply(seq_along(matches), function(i) {
-      substr(comparison, matches[i], matches[i] + match_lengths[i] - 1)
-    }), use.names = FALSE)
-
-    # datagrid contains all parameters, so we just need to find out the rows
-    # and combine column names with row values
-    if (!is.null(datagrid)) {
-      # transpose, so we can easier extract information
-      transposed_dg <- t(datagrid)
-      # interate over all parameters and create labels with proper names
-      hypothesis_labels <- unlist(lapply(parameter_names, function(i) {
-        rows <- as.numeric(sub(".", "", i))
-        paste0(i, " = ", toString(paste0(colnames(datagrid), " [", transposed_dg[, rows], "]")))
-      }), use.names = FALSE)
-      # add all names to the footer
-      table_footer <- paste0(
-        table_footer,
-        "\n",
-        paste0("Parameters:\n", paste(unlist(hypothesis_labels), collapse = "\n"))
-      )
-    }
-  }
-
-  if (all(table_footer == "")) { # nolint
-    return(NULL)
-  }
-
-  c(paste0(table_footer, "\n"), "blue")
-}

R/estimate_predicted.R

@@ -444,44 +444,18 @@ estimate_relation <- function(model,
   attr(out, "focal_terms") <- grid_specs$at_specs$varname
   attr(out, "preserve_range") <- grid_specs$preserve_range
   attr(out, "table_title") <- c(paste0("Model-based ", tools::toTitleCase(predict)), "blue")
-  attr(out, "table_footer") <- .estimate_predicted_footer(model, grid_specs, out)
+  attr(out, "table_footer") <- .table_footer(
+    out,
+    by = grid_specs$at,
+    type = "predictions",
+    model = model,
+    info = c(grid_specs, list(predict = predict))
+  )
+
   attributes(out) <- c(attributes(out), grid_specs[!names(grid_specs) %in% names(attributes(out))])
 
   # Class
   class(out) <- c(paste0("estimate_", predict), "estimate_predicted", "see_estimate_predicted", class(out))
 
   out
 }
-
-
-# Utils -------------------------------------------------------------------
-
-#' @keywords internal
-.estimate_predicted_footer <- function(model, grid_specs, predictions) {
-  footer <- paste0("\nVariable predicted: ", insight::find_response(model), "\n")
-
-  if ("at" %in% names(grid_specs)) {
-    footer <- paste0(footer, "Predictors modulated: ", toString(grid_specs$at), "\n")
-  }
-
-  if ("adjusted_for" %in% names(grid_specs) &&
-    length(grid_specs$adjusted_for) >= 1 &&
-    !(length(grid_specs$adjusted_for) == 1 && is.na(grid_specs$adjusted_for))) {
-    # if we have values of adjusted terms, add these here
-    if (all(grid_specs$adjusted_for %in% colnames(predictions))) {
-      # get values at which non-focal terms are hold constant
-      adjusted_values <- sapply(grid_specs$adjusted_for, function(i) {
-        predictions[[i]][1]
-      })
-      # at values to names of non-focal terms (footer)
-      if (is.numeric(adjusted_values)) {
-        grid_specs$adjusted_for <- sprintf("%s (%.2g)", grid_specs$adjusted_for, adjusted_values)
-      } else {
-        grid_specs$adjusted_for <- sprintf("%s (%s)", grid_specs$adjusted_for, adjusted_values)
-      }
-    }
-    footer <- paste0(footer, "Predictors controlled: ", toString(grid_specs$adjusted_for), "\n")
-  }
-
-  c(footer, "blue")
-}

R/estimate_slopes.R

@@ -138,10 +138,7 @@ estimate_slopes <- function(model,
   attr(trends, "ci") <- ci
 
   # add attributes from workhorse function
-  attributes(trends) <- utils::modifyList(
-    attributes(trends),
-    info[c("at", "by", "datagrid", "focal_terms", "trend", "coef_name", "preserve_range")]
-  )
+  attributes(trends) <- utils::modifyList(attributes(trends), info[.info_elements()])
 
   # Output
   class(trends) <- c("estimate_slopes_summary", "estimate_slopes", class(trends))

R/format.R

@@ -231,6 +231,11 @@ format.marginaleffects_contrasts <- function(x, model, p_adjust, comparison, ...
 
       # add back new columns
       x <- cbind(params[c(contrast, by)], x)
+
+      # make sure terms are factors, for data_arrange later
+      for (i in focal_terms) {
+        x[[i]] <- factor(x[[i]], levels = unique(x[[i]]))
+      }
     }
   }
 
@@ -315,7 +320,7 @@ format.marginaleffects_contrasts <- function(x, model, p_adjust, comparison, ...
 .set_back_attributes <- function(x, formatted_params) {
   attributes(formatted_params) <- utils::modifyList(
     attributes(formatted_params),
-    attributes(x)[c("by", "at", "predict", "contrast", "trend", "datagrid", "focal_terms")]
+    attributes(x)[.info_elements()]
   )
   formatted_params
 }

R/get_emcontrasts.R

@@ -65,6 +65,7 @@ get_emcontrasts <- function(model,
   attr(out, "at") <- my_args$by
   attr(out, "by") <- my_args$by
   attr(out, "focal_terms") <- emm_by
+  attr(out, "p_adjust") <- list(...)$adjust
   attr(out, "comparison") <- comparison
   out
 }

R/get_marginalcontrasts.R

@@ -74,12 +74,18 @@ get_marginalcontrasts <- function(model,
   # Last step: Save information in attributes  --------------------------------
   # ---------------------------------------------------------------------------
 
-  attr(out, "contrast") <- my_args$contrast
-  attr(out, "predict") <- predict
-  attr(out, "p_adjust") <- p_adjust
-  attr(out, "at") <- my_args$by
-  attr(out, "by") <- my_args$by
-  attr(out, "comparison") <- comparison
+  out <- .add_attributes(
+    out,
+    by = my_args$by,
+    info = list(
+      contrast = my_args$contrast,
+      predict = predict,
+      comparison = comparison,
+      marginalize = marginalize,
+      p_adjust = p_adjust
+    )
+  )
+
   class(out) <- unique(c("marginaleffects_contrasts", class(out)))
   out
 }

R/get_marginalmeans.R

@@ -52,7 +52,7 @@ get_marginalmeans <- function(model,
 
   # exception: by = NULL computes overall mean
   if (is.null(by)) {
-    datagrid <- at_specs <- NULL
+    datagrid <- datagrid_info <- NULL
   } else {
     # setup arguments to create the data grid
     dg_args <- list(
@@ -72,7 +72,7 @@ get_marginalmeans <- function(model,
 
     # Get corresponding datagrid (and deal with particular ats)
     datagrid <- do.call(insight::get_datagrid, dg_args)
-    at_specs <- attributes(datagrid)$at_specs
+    datagrid_info <- attributes(datagrid)
 
     # restore data types -  if we have defined numbers in `by`, like
     # `by = "predictor = 5"`, and `predictor` was a factor, it is returned as
@@ -109,11 +109,11 @@ get_marginalmeans <- function(model,
     if (is.null(datagrid)) {
       insight::format_error("Could not create data grid based on variables selected in `by`. Please check if all `by` variables are present in the data set.") # nolint
     }
-    fun_args$variables <- lapply(datagrid, unique)[at_specs$varname]
+    fun_args$variables <- lapply(datagrid, unique)[datagrid_info$at_specs$varname]
   } else {
     # all other "marginalizations"
     fun_args$newdata <- datagrid
-    fun_args$by <- at_specs$varname
+    fun_args$by <- datagrid_info$at_specs$varname
   }
 
   # handle distributional parameters
@@ -144,18 +144,51 @@ get_marginalmeans <- function(model,
   # Last step: Save information in attributes  --------------------------------
   # ---------------------------------------------------------------------------
 
-  attr(means, "at") <- my_args$by
-  attr(means, "by") <- my_args$by
-  attr(means, "focal_terms") <- at_specs$varname
-  attr(means, "datagrid") <- datagrid
-  attr(means, "preserve_range") <- attributes(datagrid)$preserve_range
-  attr(means, "predict") <- predict
+  means <- .add_attributes(
+    means,
+    by = my_args$by,
+    info = c(
+      datagrid_info,
+      list(predict = predict, marginalize = marginalize, datagrid = datagrid)
+    )
+  )
   class(means) <- unique(c("marginaleffects_means", class(means)))
 
   means
 }
 
 
+# handle attributes -----------------------------------------------------------
+
+#' @keywords internal
+.add_attributes <- function(x, by = NULL, info = NULL) {
+  attr(x, "at") <- by
+  attr(x, "by") <- by
+
+  # compact list
+  info <- insight::compact_list(info)
+
+  if (!is.null(info) && length(info)) {
+    if (!is.null(info$at_specs$varname)) {
+      attr(x, "focal_terms") <- info$at_specs$varname
+    }
+    for (i in .info_elements()) {
+      if (!is.null(info[[i]])) {
+        attr(x, i) <- info[[i]]
+      }
+    }
+  }
+  x
+}
+
+.info_elements <- function() {
+  c(
+    "at", "by", "focal_terms", "adjusted_for", "predict", "trend", "comparison",
+    "contrast", "marginalize", "p_adjust", "datagrid", "preserve_range", "coef_name"
+  )
+}
+
+
 # Guess -------------------------------------------------------------------
 
 #' @keywords internal