add gt_split into utils (#433)

* add gt_split into utils

* remove header from gt and add function dependencies in gt_split

* update documentation for gt_split in export

* update create_tables_doc to reference asar::gt_split and not gt

Author: Schiano-NOAA

NAMESPACE

@@ -20,4 +20,5 @@ export(create_titlepage_tex)
 export(create_yaml)
 export(export_split_tbls)
 export(format_quarto)
+export(gt_split)
 export(render_lg_table)

R/create_tables_doc.R

@@ -266,7 +266,7 @@ load(file.path(tables_dir, '", stringr::str_remove(tab, "_split"), "'))\n
                 "  gt::cols_width(\n",
                 "    everything() ~ pct(20)\n",
                 "  ) |> \n",
-                " gt::gt_split(row_every_n = ", max_rows, ") |>\n",
+                " asar::gt_split(row_every_n = ", max_rows, ") |>\n",
                 " gt::grp_pull(", i, ")\n"
               ),
               label = glue::glue("tbl-{tab_shortname}", i),
@@ -435,7 +435,7 @@ load(file.path(tables_dir, '", stringr::str_remove(tab, "_split"), "'))\n
               "  gt::cols_width(\n",
               "    everything() ~ pct(20)\n",
               "  ) |> \n",
-              " gt::gt_split(row_every_n = ", max_rows, ") |>\n",
+              " asar::gt_split(row_every_n = ", max_rows, ") |>\n",
               " gt::grp_pull(", j, ")\n"
             ),
             label = glue::glue("tbl-{tab_shortname}", i, "-", j),

R/utils.R

@@ -158,3 +158,226 @@ SS3_extract_fleet <- function(dat, vers) {
 
 # create notin operator
 `%notin%` <- Negate(`%in%`)
+
+#----------------------------------------------------------
+
+# gt_split()
+#' Split a table into a group of tables (a `gt_group`)
+#'
+#' @description
+#'
+#' With a **gt** table, you can split it into multiple tables and get that
+#' collection in a `gt_group` object. This function is useful for those cases
+#' where you want to section up a table in a specific way and print those
+#' smaller tables across multiple pages (in RTF and Word outputs, primarily via
+#' \link[gt]{gtsave}, or, with breaks between them when the output context is HTML.
+#'
+#' @param data *The gt table data object*
+#'
+#'   `obj:<gt_tbl>` // **required**
+#'
+#'   This is the **gt** table object that is commonly created through use of the
+#'   [gt()] function.
+#'
+#' @param row_every_n *Split at every n rows*
+#'
+#'   `scalar<numeric|integer>` // *default:* `NULL` (`optional`)
+#'
+#'   A directive to split at every *n* number of rows. This argument expects a
+#'   single numerical value.
+#'
+#' @param row_slice_i *Row-slicing indices*
+#'
+#'   `vector<numeric|integer>` // *default:* `NULL` (`optional`)
+#'
+#'   An argument for splitting at specific row indices. Here, we expect either a
+#'   vector of index values or a function that evaluates to a numeric vector.
+#'
+#' @param col_slice_at *Column-slicing locations*
+#'
+#'   `<column-targeting expression>` // *default:* `NULL` (`optional`)
+#'
+#'   Any columns where vertical splitting across should occur. The splits occur
+#'   to the right of the resolved column names. Can either be a series of column
+#'   names provided in `c()`, a vector of column indices, or a select helper
+#'   function (e.g. \link[gt]{starts_with}, \link[gt]{ends_with}, \link[gt]{contains}, \link[gt]{matches},
+#'   \link[gt]{num_range}, and \link[gt]{everything}).
+#'
+#' @return An object of class `gt_group`.
+#' 
+#' @note
+#' This function is a temporary export of asar, but all development and rights 
+#' belong to `rstudio/gt`. This function provides a fix to the function 
+#' introduced by a bug in gt v1.3.0. Until this is corrected in the package, we
+#' are using the function here. Once this bug is patched, we will deprecate 
+#' and remove this function from asar and direct users to use the gt package 
+#' version of this function.rom
+#'
+#' @section Examples:
+#'
+#' Use a subset of the [`gtcars`] dataset to create a **gt** table. Format the
+#' `msrp` column to display numbers as currency values, set column widths with
+#' \link[gt]{cols_width}, and split the table at every five rows with `gt_split()`.
+#' This creates a `gt_group` object containing two tables. Printing this object
+#' yields two tables separated by a line break.
+#'
+#' ```r
+#' gtcars |>
+#'   dplyr::slice_head(n = 10) |>
+#'   dplyr::select(mfr, model, year, msrp) |>
+#'   gt() |>
+#'   fmt_currency(columns = msrp) |>
+#'   cols_width(
+#'     year ~ px(80),
+#'     everything() ~ px(150)
+#'   ) |>
+#'   gt_split(row_every_n = 5)
+#' ```
+#'
+#' Use a smaller subset of the [`gtcars`] dataset to create a **gt** table.
+#' Format the `msrp` column to display numbers as currency values, set the table
+#' width with [tab_options()] and split the table at the `model` column This
+#' creates a `gt_group` object again containing two tables but this time we get
+#' a vertical split. Printing this object yields two tables of the same width.
+#'
+#' ```r
+#' gtcars |>
+#'   dplyr::slice_head(n = 5) |>
+#'   dplyr::select(mfr, model, year, msrp) |>
+#'   gt() |>
+#'   fmt_currency(columns = msrp) |>
+#'   tab_options(table.width = px(400)) |>
+#'   gt_split(col_slice_at = "model")
+#' ```
+#'
+#' @family table group functions
+#' @section Function ID:
+#' 14-2
+#'
+#' @section Function Introduced:
+#' `v0.9.0` (Mar 31, 2023)
+#'
+#' @export
+gt_split <- function(
+    data,
+    row_every_n = NULL,
+    row_slice_i = NULL,
+    col_slice_at = NULL
+) {
+  
+  # Perform input object validation
+  gt:::stop_if_not_gt_tbl(data = data)
+  
+  # Resolution of columns as character vectors
+  col_slice_at <-
+    gt:::resolve_cols_c(
+      expr = {{ col_slice_at }},
+      data = data,
+      null_means = "nothing"
+    )
+  
+  gt_tbl_built <- gt:::build_data(data = data, context = "html")
+  
+  # Get row count for table (data rows)
+  n_rows_data <- nrow(gt_tbl_built[["_stub_df"]])
+  
+  row_slice_vec <- rep.int(1L, n_rows_data)
+  
+  row_every_n_idx <- NULL
+  if (!is.null(row_every_n)) {
+    row_every_n_idx <- seq_len(n_rows_data)[seq(0, n_rows_data, row_every_n)]
+  }
+  
+  row_slice_i_idx <- NULL
+  if (!is.null(row_slice_i)) {
+    row_slice_i_idx <- row_slice_i
+  }
+  
+  row_idx <- sort(unique(c(row_every_n_idx, row_slice_i_idx)))
+  
+  group_i <- 0L
+  
+  for (i in seq_along(row_slice_vec)) {
+    
+    if (i %in% (row_idx + 1)) {
+      group_i <- group_i + 1L
+    }
+    
+    row_slice_vec[i] <- row_slice_vec[i] + group_i
+  }
+  
+  row_range_list <-
+    split(
+      seq_len(n_rows_data),
+      row_slice_vec
+    )
+  
+  gt_tbl_main <- data
+  
+  gt_group <- gt::gt_group(.use_grp_opts = FALSE)
+  
+  for (i in seq_along(row_range_list)) {
+    
+    gt_tbl_i <- gt_tbl_main
+    
+    gt_tbl_i[["_data"]] <- gt_tbl_i[["_data"]][row_range_list[[i]], ]
+    gt_tbl_i[["_stub_df"]] <- gt_tbl_i[["_stub_df"]][seq_along(row_range_list[[i]]), ]
+    
+    if (!is.null(col_slice_at)) {
+      
+      # Get all visible vars in their finalized order
+      visible_col_vars <- gt:::dt_boxhead_get_vars_default(data = data)
+      
+      # Stop function if any of the columns to split at aren't visible columns
+      if (!all(col_slice_at %in% visible_col_vars)) {
+        cli::cli_abort(
+          "All values provided in `col_slice_at` must correspond to visible columns."
+        )
+      }
+      
+      # Obtain all of the column indices for vertical splitting
+      col_idx <- which(visible_col_vars %in% col_slice_at)
+      
+      col_slice_vec <- rep.int(1L, length(visible_col_vars))
+      
+      group_j <- 0L
+      
+      for (i in seq_along(col_slice_vec)) {
+        
+        if (i %in% (col_idx + 1)) {
+          group_j <- group_j + 1L
+        }
+        
+        col_slice_vec[i] <- col_slice_vec[i] + group_j
+      }
+      
+      col_range_list <-
+        split(
+          seq_along(visible_col_vars),
+          col_slice_vec
+        )
+      
+      for (j in seq_along(col_range_list)) {
+        
+        gt_tbl_j <- gt_tbl_i
+        
+        gt_tbl_j[["_data"]] <-
+          gt_tbl_j[["_data"]][, visible_col_vars[col_range_list[[j]]]]
+        
+        gt_tbl_j[["_boxhead"]] <-
+          gt_tbl_j[["_boxhead"]][
+            gt_tbl_j[["_boxhead"]]$var %in% visible_col_vars[col_range_list[[j]]],
+          ]
+        
+        gt_group <- gt::grp_add(gt_group, gt_tbl_j)
+      }
+      
+      
+    } else {
+      gt_group <- gt::grp_add(gt_group, gt_tbl_i)
+    }
+  }
+  
+  gt_group
+}
+