Implement improved tinytable support (#1141)

Author: strengejacke

DESCRIPTION

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

NAMESPACE

@@ -128,10 +128,12 @@ S3method(display,parameters_efa_summary)
 S3method(display,parameters_model)
 S3method(display,parameters_omega)
 S3method(display,parameters_omega_summary)
+S3method(display,parameters_p_function)
 S3method(display,parameters_pca)
 S3method(display,parameters_pca_summary)
 S3method(display,parameters_sem)
 S3method(display,parameters_simulate)
+S3method(display,parameters_standardized)
 S3method(dof_satterthwaite,lmerMod)
 S3method(equivalence_test,MixMod)
 S3method(equivalence_test,feis)
@@ -981,7 +983,6 @@ export(pool_parameters)
 export(principal_components)
 export(print_html)
 export(print_md)
-export(print_table)
 export(random_parameters)
 export(reduce_data)
 export(reduce_parameters)

NEWS.md

@@ -1,5 +1,21 @@
 # parameters (devel)
 
+## Breaking Changes
+
+* The experimental `print_table()` function was removed. The aim of this function
+  was to test the implementation of the `tinytable` backend for printing. Now,
+  `tinytable` is fully supported by `insight::export_table()` and thereby also
+  by the various `print()` resp. `display()` methods for model parameters.
+
+## Changes
+
+* All `print_html()` methods get an `engine` argument, to either use the `gt`
+  package or the `tinytable` package for printing HTML tables. Since `tinytable`
+  not only produces HTML tables, but rather different formats depending on the
+  environment, `print_html()` may also generate a markdown table. Thus, the
+  generic `display()` method can be used, too, which has a `format` argument that
+  also supports `"tt"` for `tinytable`.
+
 ## Bug fixes
 
 * Fixed issue with models of class `selection` with multiple outcomes.

R/display.R

@@ -3,14 +3,17 @@
 #'
 #' @description Prints tables (i.e. data frame) in different output formats.
 #' `print_md()` is an alias for `display(format = "markdown")`, `print_html()`
-#' is an alias for `display(format = "html")`. `print_table()` is for specific
-#' use cases only, and currently only works for `compare_parameters()` objects.
+#' is an alias for `display(format = "html")`, and `print_html(engine = "tt")`
+#' is an alias for `display(format = "tt")`. The latter is a `tinytable` object,
+#' which is either printed as markdown or HTML table, depending on the environment.
 #'
-#' @param x An object returned by [`model_parameters()`].
-#' @param object An object returned by [`model_parameters()`],[`simulate_parameters()`],
-#' [`equivalence_test()`] or [`principal_components()`].
+#' @param object An object returned by one of the package's function, for example
+#' [`model_parameters()`], [`simulate_parameters()`], [`equivalence_test()`] or
+#' [`principal_components()`].
 #' @param format String, indicating the output format. Can be `"markdown"`
-#' or `"html"`.
+#' `"html"`, or `"tt"`. `format = "tt"` creates a `tinytable` object, which is
+#' either printed as markdown or HTML table, depending on the environment. See
+#' [`insight::export_table()`] for details.
 #' @param align Only applies to HTML tables. May be one of `"left"`,
 #' `"right"` or `"center"`.
 #' @param digits,ci_digits,p_digits Number of digits for rounding or
@@ -27,17 +30,14 @@
 #' @param line_padding For HTML tables, the distance (in pixel) between lines.
 #' @param column_labels Labels of columns for HTML tables. If `NULL`, automatic
 #' column names are generated. See 'Examples'.
-#' @param theme String, indicating the table theme. Can be one of `"default"`,
-#' `"grid"`, `"striped"`, `"bootstrap"` or `"darklines"`.
 #' @inheritParams print.parameters_model
 #' @inheritParams insight::format_table
 #' @inheritParams insight::export_table
 #' @inheritParams compare_parameters
 #'
 #' @return If `format = "markdown"`, the return value will be a character
 #' vector in markdown-table format. If `format = "html"`, an object of
-#' class `gt_tbl`. For `print_table()`, an object of class `tinytable` is
-#' returned.
+#' class `gt_tbl`. If `format = "tt"`, an object of class `tinytable`.
 #'
 #' @details `display()` is useful when the table-output from functions,
 #' which is usually printed as formatted text-table to console, should
@@ -46,14 +46,6 @@
 #' [vignette](https://easystats.github.io/parameters/articles/model_parameters_formatting.html)
 #' for examples.
 #'
-#' `print_table()` is a special function for `compare_parameters()` objects,
-#' which prints the output as a formatted HTML table. It is still somewhat
-#' experimental, thus, only a fixed layout-style is available at the moment
-#' (columns for estimates, confidence intervals and p-values). However, it
-#' is possible to include other model components, like zero-inflation, or random
-#' effects in the table. See 'Examples'. An alternative is to set `engine = "tt"`
-#' in `print_html()` to use the _tinytable_ package for creating HTML tables.
-#'
 #' @seealso [print.parameters_model()] and [print.compare_parameters()]
 #'
 #' @examplesIf require("gt", quietly = TRUE)
@@ -81,6 +73,28 @@
 #'   column_labels = c("Est. (95% CI)")
 #' )
 #' }
+#'
+#' @examplesIf all(insight::check_if_installed(c("glmmTMB", "lme4", "tinytable"), quietly = TRUE))
+#' \donttest{
+#' data(iris)
+#' data(Salamanders, package = "glmmTMB")
+#' m1 <- lm(Sepal.Length ~ Species * Petal.Length, data = iris)
+#' m2 <- lme4::lmer(
+#'   Sepal.Length ~ Petal.Length + Petal.Width + (1 | Species),
+#'   data = iris
+#' )
+#' m3 <- glmmTMB::glmmTMB(
+#'   count ~ spp + mined + (1 | site),
+#'   ziformula = ~mined,
+#'   family = poisson(),
+#'   data = Salamanders
+#' )
+#' out <- compare_parameters(m1, m2, m3, effects = "all", component = "all")
+#'
+#' display(out, format = "tt")
+#'
+#' display(out, select = "{estimate}|{ci}", format = "tt")
+#' }
 #' @export
 display.parameters_model <- function(object,
                                      format = "markdown",
@@ -123,7 +137,8 @@ display.parameters_model <- function(object,
         column_labels = column_labels,
         align = align,
         font_size = font_size,
-        line_padding = line_padding
+        line_padding = line_padding,
+        engine = ifelse(format == "tt", "tt", "gt")
       )
     )
     do.call(print_html, c(fun_args, list(...)))
@@ -173,7 +188,8 @@ display.compare_parameters <- function(object,
       list(
         column_labels = column_labels,
         font_size = font_size,
-        line_padding = line_padding
+        line_padding = line_padding,
+        engine = ifelse(format == "tt", "tt", "gt")
       )
     )
     do.call(print_html, c(fun_args, list(...)))
@@ -202,7 +218,8 @@ display.parameters_sem <- function(object,
     digits = digits,
     ci_digits = ci_digits,
     p_digits = p_digits,
-    ci_brackets = ci_brackets
+    ci_brackets = ci_brackets,
+    engine = ifelse(format == "tt", "tt", "gt")
   )
 
   if (format %in% c("html", "tt")) {
@@ -220,7 +237,7 @@ display.parameters_sem <- function(object,
 #' @export
 display.parameters_efa_summary <- function(object, format = "markdown", digits = 3, ...) {
   format <- insight::validate_argument(format, c("markdown", "html", "md", "tt"))
-  fun_args <- list(x = object, digits = digits)
+  fun_args <- list(x = object, digits = digits, engine = ifelse(format == "tt", "tt", "gt"))
 
   if (format %in% c("html", "tt")) {
     do.call(print_html, c(fun_args, list(...)))
@@ -247,7 +264,8 @@ display.parameters_efa <- function(object, format = "markdown", digits = 2, sort
     digits = digits,
     sort = sort,
     threshold = threshold,
-    labels = labels
+    labels = labels,
+    engine = ifelse(format == "tt", "tt", "gt")
   )
 
   if (format %in% c("html", "tt")) {
@@ -272,3 +290,32 @@ display.parameters_omega <- display.parameters_efa
 display.equivalence_test_lm <- function(object, format = "markdown", digits = 2, ...) {
   print_md(x = object, digits = digits, ...)
 }
+
+
+# p_function ----------------------------
+
+#' @export
+display.parameters_p_function <- function(object,
+                                          format = "markdown",
+                                          digits = 2,
+                                          ci_width = "auto",
+                                          ci_brackets = TRUE,
+                                          pretty_names = TRUE,
+                                          ...) {
+  format <- insight::validate_argument(format, c("markdown", "html", "md", "tt"))
+
+  fun_args <- list(
+    x = object,
+    digits = digits,
+    ci_width = ci_width,
+    ci_brackets = ci_brackets,
+    pretty_names = pretty_names,
+    engine = ifelse(format == "tt", "tt", "gt")
+  )
+
+  if (format %in% c("html", "tt")) {
+    do.call(print_html, c(fun_args, list(...)))
+  } else {
+    do.call(print_md, c(fun_args, list(...)))
+  }
+}

R/format.R

@@ -116,27 +116,13 @@ format.parameters_model <- function(x,
     x <- .format_ranef_parameters(x)
   }
 
-  # group parameters - this function find those parameters that should be
-  # grouped, reorders parameters into groups and indents lines that belong
-  # to one group, adding a header for each group
-  if (!is.null(groups)) {
-    x <- .parameter_groups(x, groups)
-  }
-  indent_groups <- attributes(x)$indent_groups
-  indent_rows <- attributes(x)$indent_rows
-
   # prepare output, to have in shape for printing. this function removes
   # empty columns, or selects only those columns that should be printed
   x <- .prepare_x_for_print(x, select, coef_name, s_value)
 
   # check whether to split table by certain factors/columns (like component, response...)
   split_by <- .prepare_splitby_for_print(x)
 
-  # add p-stars, if we need this for style-argument
-  if (!is.null(style) && grepl("{stars}", style, fixed = TRUE)) {
-    x$p_stars <- insight::format_p(x[["p"]], stars = TRUE, stars_only = TRUE)
-  }
-
   # format everything now...
   if (split_components && !is.null(split_by) && length(split_by)) {
     # this function mainly sets the appropriate column names for each
@@ -158,6 +144,7 @@ format.parameters_model <- function(x,
       ci_brackets = ci_brackets,
       zap_small = zap_small,
       include_reference = include_reference,
+      style = style,
       ...
     )
   } else {
@@ -175,6 +162,7 @@ format.parameters_model <- function(x,
       coef_name = coef_name,
       zap_small = zap_small,
       include_reference = include_reference,
+      style = style,
       ...
     )
   }
@@ -189,33 +177,8 @@ format.parameters_model <- function(x,
     formatted_table$CI <- NULL
   }
 
-  # we also allow style-argument for model parameters. In this case, we need
-  # some small preparation, namely, we need the p_stars column, and we need
-  # to "split" the formatted table, because the glue-function needs the columns
-  # without the parameters-column.
-  if (!is.null(style)) {
-    if (is.data.frame(formatted_table)) {
-      formatted_table <- .style_formatted_table(
-        formatted_table,
-        style = style,
-        format = format
-      )
-    } else {
-      formatted_table[] <- lapply(
-        formatted_table,
-        .style_formatted_table,
-        style = style,
-        format = format
-      )
-    }
-  }
-
-  if (!is.null(indent_rows)) {
-    attr(formatted_table, "indent_rows") <- indent_rows
-    attr(formatted_table, "indent_groups") <- NULL
-  } else if (!is.null(indent_groups)) {
-    attr(formatted_table, "indent_groups") <- indent_groups
-  }
+  # information about indention / row groups
+  attr(formatted_table, "indent_rows") <- groups
 
   # vertical layout possible, if these have just one row
   if (identical(list(...)$layout, "vertical")) {
@@ -375,8 +338,8 @@ format.compare_parameters <- function(x,
       }
       out$Parameter[out$Parameter == "SD (Observations: Residual)"] <- "SD (Residual)"
     }
+    attributes(cols)$coef_name <- colnames(cols)[coef_column]
     # save p-stars in extra column
-    cols$p_stars <- insight::format_p(cols$p, stars = TRUE, stars_only = TRUE)
     cols <- insight::format_table(
       cols,
       digits = digits,
@@ -385,9 +348,20 @@ format.compare_parameters <- function(x,
       ci_digits = ci_digits,
       p_digits = p_digits,
       zap_small = zap_small,
+      select = select,
       ...
     )
-    out <- cbind(out, .format_output_style(cols, style = select, format, i))
+
+    # add modelname to column names; for single column layout per model, we just
+    # need the column name. If the layout contains more than one column per model,
+    # add modelname in parenthesis.
+    if (ncol(cols) > 1) {
+      colnames(cols) <- paste0(colnames(cols), " (", i, ")")
+    } else {
+      colnames(cols) <- i
+    }
+
+    out <- cbind(out, cols)
   }
 
   # remove group column
@@ -399,15 +373,6 @@ format.compare_parameters <- function(x,
     out <- datawizard::data_arrange(out, c("Effects", "Component"))
   }
 
-  # group parameters - this function find those parameters that should be
-  # grouped, reorders parameters into groups and indents lines that belong
-  # to one group, adding a header for each group
-  if (!is.null(groups) && !identical(engine, "tt")) {
-    out <- .parameter_groups(out, groups)
-  }
-  indent_groups <- attributes(x)$indent_groups
-  indent_rows <- attributes(x)$indent_rows
-
   # check whether to split table by certain factors/columns (like component, response...)
   split_by <- split_column <- .prepare_splitby_for_print(x)
 
@@ -469,6 +434,9 @@ format.compare_parameters <- function(x,
     formatted_table <- .add_obs_row(formatted_table, parameters_attributes, style = select)
   }
 
+  # information about indention / row groups
+  attr(formatted_table, "indent_rows") <- groups
+
   formatted_table
 }
 
@@ -510,35 +478,6 @@ format.parameters_sem <- function(x,
 }
 
 
-# helper ---------------------
-
-.style_formatted_table <- function(formtab, style, format) {
-  additional_columns <- intersect(c("Effects", "Group", "Component"), colnames(formtab))
-  if (length(additional_columns)) {
-    additional_columns <- formtab[additional_columns]
-  }
-  # define column names in case the glue-pattern has multiple columns.
-  if (grepl("|", style, fixed = TRUE)) {
-    cn <- NULL
-  } else {
-    cn <- .style_pattern_to_name(style)
-  }
-  formtab <- cbind(
-    formtab[1],
-    .format_output_style(
-      formtab[2:ncol(formtab)],
-      style = style,
-      format = format,
-      modelname = cn
-    )
-  )
-  if (!insight::is_empty_object(additional_columns)) {
-    formtab <- cbind(formtab, additional_columns)
-  }
-  formtab
-}
-
-
 # footer functions ------------------
 
 .format_footer <- function(x,