Use tinytable for print_md.compare_parameters()

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: parameters
 Title: Processing of Model Parameters
-Version: 0.21.5.6
+Version: 0.21.5.7
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",
@@ -182,7 +182,7 @@ Suggests:
     PMCMRplus,
     poorman,
     posterior,
-    PROreg,
+    PROreg (>= 1.3.0),
     pscl,
     psych,
     pvclust,
@@ -199,7 +199,7 @@ Suggests:
     survival,
     testthat (>= 3.2.1),
     tidyselect,
-    tinytable,
+    tinytable (>= 0.1.0),
     TMB,
     truncreg,
     VGAM,

NEWS.md

@@ -9,6 +9,13 @@
 * `include_reference` can now directly be set to `TRUE` in `model_parameters()`
   and doesn't require a call to `print()` anymore.
 
+* `compare_parameters()` gains a `include_reference` argument, to add the
+  reference category of categorical predictors to the parameters table.
+
+* `print_md()` for `compare_parameters()` now by default uses the *tinytable*
+  package to create markdown tables. This allows better control for column
+  heading spanning over multiple columns.
+
 ## Bug fixes
 
 * Fixed issue with parameter names for `model_parameters()` and objects from

R/compare_parameters.R

@@ -83,6 +83,8 @@
                                coefficient_names = NULL,
                                keep = NULL,
                                drop = NULL,
+                               include_reference = FALSE,
+                               groups = NULL,
                                verbose = TRUE) {
   models <- list(...)
 
@@ -186,6 +188,7 @@
         keep = keep,
         drop = drop,
         wb_component = FALSE,
+        include_reference = include_reference,
         verbose = verbose
       )
     }
@@ -214,7 +217,7 @@
 
     # add zi-suffix to parameter names
     if (any(dat$Component == "zero_inflated")) {
       dat$Parameter[dat$Component == "zero_inflated"] <- paste0(dat$Parameter[dat$Component == "zero_inflated"], " (zi)")
     }
 
     # add suffix
@@ -253,6 +256,7 @@
   attr(all_models, "model_names") <- gsub("\"", "", unlist(lapply(model_names, insight::safe_deparse)), fixed = TRUE)
   attr(all_models, "output_style") <- select
   attr(all_models, "all_attributes") <- object_attributes
+  attr(all_models, "parameter_groups") <- groups
   class(all_models) <- c("compare_parameters", "see_compare_parameters", unique(class(all_models)))
 
   all_models

R/display.R

@@ -53,7 +53,8 @@
 #' 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'.
+#' 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()]
 #'
@@ -205,7 +206,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

@@ -3,7 +3,7 @@
 #' @inheritParams print.parameters_model
 #' @rdname display.parameters_model
 #' @export
 format.parameters_model <- function(x,
                                     pretty_names = TRUE,
                                     split_components = TRUE,
                                     select = NULL,
@@ -242,7 +242,7 @@
 
 #' @inheritParams print.parameters_model
 #' @export
 format.compare_parameters <- function(x,
                                       split_components = TRUE,
                                       select = NULL,
                                       digits = 2,
@@ -253,6 +253,7 @@
                                       zap_small = FALSE,
                                       format = NULL,
                                       groups = NULL,
+                                      engine = NULL,
                                       ...) {
   m_class <- attributes(x)$model_class
   x$Method <- NULL
@@ -393,7 +394,7 @@
   # 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)) {
+  if (!is.null(groups) && !identical(engine, "tt")) {
     out <- .parameter_groups(out, groups)
   }
   indent_groups <- attributes(x)$indent_groups
@@ -807,7 +808,7 @@
 
 
 # footer: type of uncertainty interval
 .print_footer_cimethod <- function(x) {
   if (isTRUE(getOption("parameters_cimethod", TRUE))) {
     # get attributes
     ci_method <- .additional_arguments(x, "ci_method", NULL)

R/print.compare_parameters.R

@@ -31,6 +31,9 @@ print.compare_parameters <- function(x,
   if (missing(select)) {
     select <- attributes(x)$output_style
   }
+  if (missing(groups)) {
+    groups <- attributes(x)$parameter_groups
+  }
 
   formatted_table <- format(
     x,

R/print.parameters_model.R

@@ -137,6 +137,10 @@
 #' default for the `select` argument. See argument's documentation for available
 #' options.
 #'
+#' - `easystats_html_engine`: `options(easystats_html_engine = "gt")` will set
+#' the default HTML engine for tables to `gt`, i.e. the _gt_ package is used to
+#' create HTML tables. If set to `tt`, the _tinytable_ package is used.
+#'
 #' @details `summary()` is a convenient shortcut for
 #'   `print(object, select = "minimal", show_sigma = TRUE, show_formula = TRUE)`.
 #'
@@ -308,10 +312,10 @@
     footer <- ""
   }
   if (!identical(footer, "")) {
-    if (!is.null(footer)) {
-      footer <- paste0("\n", footer, "\n", footer_stats)
-    } else {
+    if (is.null(footer)) {
       footer <- footer_stats
+    } else {
+      footer <- paste0("\n", footer, "\n", footer_stats)
     }
   }
 
@@ -412,7 +416,7 @@
                           show_formula = FALSE,
                           format = "text") {
   # get attributes
-  sigma <- attributes(x)$sigma
+  model_sigma <- attributes(x)$sigma
   show_summary <- isTRUE(attributes(x)$show_summary)
   verbose <- .additional_arguments(x, "verbose", TRUE)
 
@@ -423,7 +427,7 @@
   show_r2 <- .additional_arguments(x, "show_summary", FALSE)
 
   # set defaults, if necessary
-  if (is.null(sigma)) {
+  if (is.null(model_sigma)) {
     show_sigma <- FALSE
   }
 
@@ -522,10 +526,10 @@
   random_params$Term[is.na(random_params$Term)] <- ""
   random_params$SD[is.na(random_params$SD)] <- ""
 
-  non_empty <- random_params$Term != "" & random_params$Type != ""
+  non_empty <- random_params$Term != "" & random_params$Type != "" # nolint
   random_params$Line[non_empty] <- sprintf("%s (%s)", random_params$Type[non_empty], random_params$Term[non_empty])
 
-  non_empty <- random_params$Term != "" & random_params$Type == ""
+  non_empty <- random_params$Term != "" & random_params$Type == "" # nolint
   random_params$Line[non_empty] <- sprintf("%s", random_params$Term[non_empty])
 
   # final fix, indentions
@@ -567,11 +571,11 @@
   col_width <- rep(NA, length(shared_cols))
   for (i in seq_along(shared_cols)) {
     col_width[i] <- max(unlist(lapply(formatted_table, function(j) {
-      col <- j[[shared_cols[i]]]
-      if (!is.null(col)) {
-        max(nchar(col))
-      } else {
+      column <- j[[shared_cols[i]]]
+      if (is.null(column)) {
         NA
+      } else {
+        max(nchar(column))
       }
     })))
   }

R/print_html.R

@@ -46,6 +46,9 @@
   if (missing(select) || is.null(select)) {
     select <- attributes(x)$output_style
   }
+  if (missing(groups)) {
+    groups <- attributes(x)$parameter_groups
+  }
 
   # we need glue-like syntax right now...
   if (!is.null(select)) {
@@ -150,6 +153,7 @@
                                           font_size = "100%",
                                           line_padding = 4,
                                           column_labels = NULL,
+                                          engine = "gt",
                                           ...) {
   # check if user supplied digits attributes
   if (missing(digits)) {
@@ -169,6 +173,29 @@
     select <- attributes(x)$output_style
   }
 
+  # markdown engine?
+  engine <- match.arg(getOption("easystats_html_engine", engine), c("gt", "default", "tt"))
+
+  # for tiny table, we can just call print_md()
+  if (engine == "tt") {
+    return(print_md(
+      x,
+      digits = digits,
+      ci_digits = ci_digits,
+      p_digits = p_digits,
+      caption = caption,
+      subtitle = subtitle,
+      footer = footer,
+      select = select,
+      split_components = TRUE,
+      ci_brackets = ci_brackets,
+      zap_small = zap_small,
+      groups = groups,
+      engine = "tt",
+      outformat = "html"
+    ))
+  }
+
   # we need glue-like syntax right now...
   select <- .convert_to_glue_syntax(style = select, "<br>")