Allow export_table() to split to more than 3 tables

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: insight
 Title: Easy Access to Model Information for Various Model Objects
-Version: 0.99.0.1
+Version: 0.99.0.2
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",

NEWS.md

@@ -23,6 +23,9 @@
 * The function to calculate the corrections for likelihood-values when the
   response-variable is transformed is now exported as `get_likelihood_adjustment()`.
 
+* `export_table()` can now split tables into more than three tables when
+  `table_width` is used (formerly, the maximum number of split tables was three).
+
 ## Bug fix
 
 * `clean_parameters()` now uses the correct labels for the random effects

R/export_table.R

@@ -44,9 +44,10 @@
 #' @param table_width Numeric, or `"auto"`, indicating the width of the complete
 #'   table. If `table_width = "auto"` and the table is wider than the current
 #'   width (i.e. line length) of the console (or any other source for textual
-#'   output, like markdown files), the table is split into two parts. Else,
+#'   output, like markdown files), the table is split into multiple parts. Else,
 #'   if `table_width` is numeric and table rows are larger than `table_width`,
-#'   the table is split into two parts.
+#'   the table is split into multiple parts. For each new table, the first
+#'   column is repeated for better orientation.
 #' @param ... Currently not used.
 #' @inheritParams format_value
 #' @inheritParams get_data
@@ -101,7 +102,7 @@
 #' export_table(d, width = c(x = 5, z = 10))
 #' export_table(d, width = c(x = 5, y = 5, z = 10), align = "lcr")
 #' @export
 export_table <- function(x,
                          sep = " | ",
                          header = "-",
                          cross = NULL,
@@ -118,7 +119,7 @@
                          align = NULL,
                          by = NULL,
                          zap_small = FALSE,
-                         table_width = NULL,
+                         table_width = "auto",
                          verbose = TRUE,
                          ...) {
   # check args
@@ -466,7 +467,7 @@
 # plain text formatting ------------------------
 
 
 .format_basic_table <- function(final,
                                 header,
                                 sep,
                                 cross = NULL,
@@ -545,12 +546,8 @@
   }
 
 
-  # we can split very wide table into maximum three parts
-  # this is currently hardcoded, not flexible, so we cannot allow
-  # more than three parts of one wide table
-  final2 <- NULL
-  final3 <- NULL
-
+  # we can split very wide tables
+  final_extra <- NULL
 
   # check if user requested automatic width-adjustment of tables, or if a
   # given width is required
@@ -569,56 +566,50 @@
 
     # width of first table row of complete table. Currently, "final" is still
     # a matrix, so we need to paste the columns of the first row into a string
-    row_width <- nchar(paste0(final[1, ], collapse = sep), type = "width")
+    row_width <- nchar(paste(final[1, ], collapse = sep), type = "width")
 
     # possibly first split - all table columns longer than "line_width"
     # (i.e. first table row) go into a second string
     if (row_width > line_width) {
-      i <- 1
-      # determine how many columns fit into the first line
-      while (nchar(paste0(final[1, 1:i], collapse = sep), type = "width") < line_width) {
-        i <- i + 1
-      }
-      # copy first column, and all columns that did not fit into the first line
-      # into the second table matrix
-      if (i > 2 && i < ncol(final)) {
-        final2 <- final[, c(1, i:ncol(final))]
-        final <- final[, 1:(i - 1)]
+      final_extra <- list(final)
+      e <- 1
+      while (nchar(paste(utils::tail(final_extra, 1)[[1]][1, ], collapse = sep), type = "width") > line_width && e <= length(final_extra)) { # nolint
+        .final_temp <- final_extra[[e]]
+
+        i <- 1
+        # determine how many columns fit into the first line
+        while (nchar(paste(.final_temp[1, 1:i], collapse = sep), type = "width") < line_width) {
+          i <- i + 1
+        }
+        # copy first column, and all columns that did not fit into the first line
+        # into the second table matrix
+        if (i < ncol(.final_temp)) {
+          final_extra[[e]] <- .final_temp[, 1:(i - 1), drop = FALSE]
+          final_extra[[e + 1]] <- .final_temp[, c(1, i:ncol(.final_temp)), drop = FALSE]
+        }
+        e <- e + 1
       }
-    }
-
-    # width of first table row of remaing second table part
-    row_width <- nchar(paste0(final2[1, ], collapse = sep), type = "width")
 
-    # possibly second split - all table columns longer than "line_width"
-    # (i.e. first table row) go into a third string - we repeat the same
-    # procedure as above
-    if (row_width > line_width) {
-      i <- 1
-      while (nchar(paste0(final2[1, 1:i], collapse = sep), type = "width") < line_width) {
-        i <- i + 1
-      }
-      if (i > 2 && i < ncol(final2)) {
-        final3 <- final2[, c(1, i:ncol(final2))]
-        final2 <- final2[, 1:(i - 1)]
+      final <- final_extra[[1]]
+      if (length(final_extra) > 1) {
+        final_extra <- final_extra[-1]
+      } else {
+        final_extra <- NULL
       }
     }
   }
 
   # Transform table matrix into a string value that can be printed
   rows <- .table_parts(NULL, final, header, sep, cross, empty_line)
 
-  # if we have over-lengthy tables that are split into two parts,
-  # print second table here
-  if (!is.null(final2)) {
-    rows <- .table_parts(paste0(rows, "\n"), final2, header, sep, cross, empty_line)
+  # if we have over-lengthy tables that are split into parts,
+  # print extra table here
+  if (!is.null(final_extra)) {
+    for (fex in final_extra) {
+      rows <- .table_parts(paste0(rows, "\n"), fex, header, sep, cross, empty_line)
+    }
   }
 
-  # if we have over-lengthy tables that are split into two parts,
-  # print second table here
-  if (!is.null(final3)) {
-    rows <- .table_parts(paste0(rows, "\n"), final3, header, sep, cross, empty_line)
-  }
 
   # if caption is available, add a row with a headline
   if (!is.null(caption) && caption[1] != "") {
@@ -666,7 +657,7 @@
   for (row in seq_len(nrow(final))) {
     # create a string for each row, where cells from original matrix are
     # separated by the separator char
-    final_row <- paste0(final[row, ], collapse = sep)
+    final_row <- paste(final[row, ], collapse = sep)
     # check if we have an empty row, and if so, fill with an
     # "empty line separator", if requested by user
     if (!is.null(empty_line) && !any(nzchar(trim_ws(final[row, ])))) {
@@ -677,7 +668,7 @@
         # the empty line, which is just empty cells with separator char,
         # will now be replaced by the "empty line char", so we have a
         # clean separator line
-        paste0(rep_len(empty_line, nchar(final_row, type = "width")), collapse = ""),
+        paste(rep_len(empty_line, nchar(final_row, type = "width")), collapse = ""),
         cross, sep, final_row,
         is_last_row = row == nrow(final)
       )
@@ -691,7 +682,7 @@
       # check whether user wants to have a "cross" char where vertical and
       # horizontal lines (from header line) cross.
       header_line <- .insert_cross(
-        paste0(rep_len(header, nchar(final_row, type = "width")), collapse = ""),
+        paste(rep_len(header, nchar(final_row, type = "width")), collapse = ""),
         cross, sep, final_row,
         is_last_row = row == nrow(final)
       )
@@ -809,7 +800,7 @@
 
 # markdown formatting -------------------
 
 .format_markdown_table <- function(final,
                                    x,
                                    caption = NULL,
                                    subtitle = NULL,
@@ -832,7 +823,7 @@
   # go through all columns of the data frame
   for (i in 1:n_columns) {
     # create separator line for current column
     tablecol <- paste0(rep_len("-", column_width[i]), collapse = "")
 
     # check if user-defined alignment is requested, and if so, extract
     # alignment direction and save to "align_char"
@@ -883,7 +874,7 @@
   # Transform to character
   rows <- NULL
   for (row in seq_len(nrow(final))) {
     final_row <- paste0("|", paste0(final[row, ], collapse = "|"), "|", collapse = "")
     rows <- c(rows, final_row)
 
     # First row separation

tests/testthat/_snaps/windows/export_table.md

@@ -0,0 +1,95 @@
+# export_table, table_width
+
+    Code
+      print(out, table_width = 50)
+    Output
+      # Comparison of Model Performance Indices
+
+      Name   |  Model | Chi2(24) | p (Chi2)
+      -------------------------------------
+      model1 | lavaan |   85.306 |   < .001
+      model2 | lavaan |   85.306 |   < .001
+
+      Name   | Baseline(36) | p (Baseline) |   GFI
+      --------------------------------------------
+      model1 |      918.852 |       < .001 | 0.943
+      model2 |      918.852 |       < .001 | 0.943
+
+      Name   |  AGFI |   NFI |  NNFI |   CFI | RMSEA
+      ----------------------------------------------
+      model1 | 0.894 | 0.907 | 0.896 | 0.931 | 0.092
+      model2 | 0.894 | 0.907 | 0.896 | 0.931 | 0.092
+
+      Name   |    RMSEA  CI | p (RMSEA) |   RMR |  SRMR
+      -------------------------------------------------
+      model1 | [0.07, 0.11] |    < .001 | 0.082 | 0.065
+      model2 | [0.07, 0.11] |    < .001 | 0.082 | 0.065
+
+      Name   |   RFI |  PNFI |   IFI |   RNI
+      --------------------------------------
+      model1 | 0.861 | 0.605 | 0.931 | 0.931
+      model2 | 0.861 | 0.605 | 0.931 | 0.931
+
+      Name   | Loglikelihood |  AIC (weights)
+      ---------------------------------------
+      model1 |     -3737.745 | 7517.5 (0.500)
+      model2 |     -3737.745 | 7517.5 (0.500)
+
+      Name   |  BIC (weights) | BIC_adjusted
+      --------------------------------------
+      model1 | 7595.3 (0.500) |     7528.739
+      model2 | 7595.3 (0.500) |     7528.739
+
+---
+
+    Code
+      print(tab, table_width = 80)
+    Output
+      Parameter                           |               lm1 |                  lm2
+      ------------------------------------------------------------------------------
+      (Intercept)                         | 5.01 (4.86, 5.15) |  3.68 ( 3.47,  3.89)
+      Species [versicolor]                | 0.93 (0.73, 1.13) | -1.60 (-1.98, -1.22)
+      Species [virginica]                 | 1.58 (1.38, 1.79) | -2.12 (-2.66, -1.58)
+      Petal Length                        |                   |  0.90 ( 0.78,  1.03)
+      Species [versicolor] × Petal Length |                   |                     
+      Species [virginica] × Petal Length  |                   |                     
+      Petal Width                         |                   |                     
+      ------------------------------------------------------------------------------
+      Observations                        |               150 |                  150
+
+      Parameter                           |                  lm3
+      ----------------------------------------------------------
+      (Intercept)                         |  4.21 ( 3.41,  5.02)
+      Species [versicolor]                | -1.81 (-2.99, -0.62)
+      Species [virginica]                 | -3.15 (-4.41, -1.90)
+      Petal Length                        |  0.54 ( 0.00,  1.09)
+      Species [versicolor] × Petal Length |  0.29 (-0.30,  0.87)
+      Species [virginica] × Petal Length  |  0.45 (-0.12,  1.03)
+      Petal Width                         |                     
+      ----------------------------------------------------------
+      Observations                        |                  150
+
+      Parameter                           |                  lm4
+      ----------------------------------------------------------
+      (Intercept)                         |  4.21 ( 3.41,  5.02)
+      Species [versicolor]                | -1.80 (-2.99, -0.62)
+      Species [virginica]                 | -3.19 (-4.50, -1.88)
+      Petal Length                        |  0.54 (-0.02,  1.09)
+      Species [versicolor] × Petal Length |  0.28 (-0.30,  0.87)
+      Species [virginica] × Petal Length  |  0.45 (-0.12,  1.03)
+      Petal Width                         |  0.03 (-0.28,  0.34)
+      ----------------------------------------------------------
+      Observations                        |                  150
+
+      Parameter                           |                  lm5 |                  lm6
+      ---------------------------------------------------------------------------------
+      (Intercept)                         |  4.21 ( 3.41,  5.02) |  4.21 ( 3.41,  5.02)
+      Species [versicolor]                | -1.80 (-2.99, -0.62) | -1.80 (-2.99, -0.62)
+      Species [virginica]                 | -3.19 (-4.50, -1.88) | -3.19 (-4.50, -1.88)
+      Petal Length                        |  0.54 (-0.02,  1.09) |  0.54 (-0.02,  1.09)
+      Species [versicolor] × Petal Length |  0.28 (-0.30,  0.87) |  0.28 (-0.30,  0.87)
+      Species [virginica] × Petal Length  |  0.45 (-0.12,  1.03) |  0.45 (-0.12,  1.03)
+      Petal Width                         |  0.03 (-0.28,  0.34) |  0.03 (-0.28,  0.34)
+      ---------------------------------------------------------------------------------
+      Observations                        |                  150 |                  150
+

tests/testthat/test-export_table.R

@@ -100,3 +100,30 @@ test_that("export_table", {
     ignore_attr = TRUE
   )
 })
+
+
+test_that("export_table, table_width", {
+  skip_on_cran()
+  skip_if_not_installed("lavaan")
+  skip_if_not_installed("performance")
+  skip_if_not_installed("parameters")
+
+  data(HolzingerSwineford1939, package = "lavaan")
+  structure <- " visual  =~ x1 + x2 + x3
+                 textual =~ x4 + x5 + x6
+                 speed   =~ x7 + x8 + x9 "
+  model1 <- lavaan::cfa(structure, data = HolzingerSwineford1939)
+  model2 <- lavaan::cfa(structure, data = HolzingerSwineford1939)
+
+  out <- performance::compare_performance(model1, model2)
+  expect_snapshot(print(out, table_width = 50), variant = "windows")
+
+  data(iris)
+  lm1 <- lm(Sepal.Length ~ Species, data = iris)
+  lm2 <- lm(Sepal.Length ~ Species + Petal.Length, data = iris)
+  lm3 <- lm(Sepal.Length ~ Species * Petal.Length, data = iris)
+  lm6 <- lm5 <- lm4 <- lm(Sepal.Length ~ Species * Petal.Length + Petal.Width, data = iris)
+
+  tab <- parameters::compare_parameters(lm1, lm2, lm3, lm4, lm5, lm6)
+  expect_snapshot(print(tab, table_width = 80), variant = "windows")
+})