Merge pull request #2010 from shannonhaughton/gt_group

rich-iannone · web-flow · commit 722eac2ee6cb · 2025-07-08T17:28:53.000-04:00
Enable cols_align and cols_label for gt_group objects
diff --git a/NAMESPACE b/NAMESPACE
@@ -255,6 +255,7 @@ importFrom(dplyr,vars)
 importFrom(htmltools,as.tags)
 importFrom(htmltools,css)
 importFrom(magrittr,"%>%")
+importFrom(rlang,caller_env)
 importFrom(tidyselect,all_of)
 importFrom(tidyselect,any_of)
 importFrom(tidyselect,contains)
diff --git a/NEWS.md b/NEWS.md
@@ -12,6 +12,8 @@
 
 * Fixed an issue where grand summary rows would not be saved properly to Word (@olivroy, #2000).
 
+* Enable `cols_align()` and `cols_label()` functions for gt_group objects (@shannonhaughton, #2005)
+
 # gt 1.0.0
 
 ## Minor improvements and bug fixes
diff --git a/R/cols_align.R b/R/cols_align.R
@@ -33,13 +33,20 @@
 #' allow **gt** to automatically choose the alignment of each column based on
 #' the data type (with the `auto` option).
 #'
-#' @param data *The gt table data object*
+#' @param data *The gt table or gt group data object*
 #'
 #'   `obj:<gt_tbl>` // **required**
 #'
 #'   This is the **gt** table object that is commonly created through use of the
 #'   [gt()] function.
 #'
+#'   OR
+#'
+#'   `obj:<gt_group>` // **required**
+#'
+#'   This is the **gt** group object that is commonly created through use of the
+#'   [gt_group()] function.
+#'
 #' @param align *Alignment type*
 #'
 #'   `singl-kw:[auto|left|center|right]` // *default:* `"auto"`
@@ -111,10 +118,16 @@ cols_align <- function(
 ) {
 
   # Perform input object validation
-  stop_if_not_gt_tbl(data = data)
+  stop_if_not_gt_tbl_or_group(data = data)
+
+  # Handle gt_group
+  if(inherits(data, "gt_group")){
+    arg_list <- as.list(match.call())
+    return(apply_to_grp(data, arg_list))
+  }
 
   # Get the `align` value, this stops the function if there is no match
-  align <- 
+  align <-
     rlang::arg_match0(
       align,
       values = c("auto", "left", "center", "right")
diff --git a/R/cols_align_decimal.R b/R/cols_align_decimal.R
@@ -33,7 +33,7 @@
 #' number of columns (the function will skip over columns that don't require
 #' this type of alignment).
 #'
-#' @inheritParams cols_align
+#' @inheritParams cols_hide
 #'
 #' @param columns *Columns to target*
 #'
diff --git a/R/cols_hide.R b/R/cols_hide.R
@@ -34,7 +34,12 @@
 #' reference during formatting of other columns) but the final display of those
 #' columns is not necessary.
 #'
-#' @inheritParams cols_align
+#' @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 columns *Columns to target*
 #'
@@ -162,7 +167,7 @@ cols_hide <- function(
 #' be important in cases where the user obtains a `gt_tbl` object with hidden
 #' columns and there is motivation to reveal one or more of those.
 #'
-#' @inheritParams cols_align
+#' @inheritParams cols_hide
 #'
 #' @param columns *Columns to target*
 #'
diff --git a/R/cols_label.R b/R/cols_label.R
@@ -35,7 +35,7 @@
 #' we even have the option to use [md()] or [html()] for rendering column labels
 #' from Markdown or using HTML.
 #'
-#' @inheritParams cols_width
+#' @inheritParams cols_align
 #'
 #' @param ... *Column label assignments*
 #'
@@ -336,7 +336,13 @@ cols_label <- function(
 ) {
 
   # Perform input object validation
-  stop_if_not_gt_tbl(data = .data)
+  stop_if_not_gt_tbl_or_group(data = .data)
+
+  # Handle gt_group
+  if(inherits(.data, "gt_group")){
+    arg_list <- as.list(match.call())
+    return(apply_to_grp(.data, arg_list))
+  }
 
   if (!is.null(.process_units) && .process_units) {
 
diff --git a/R/cols_merge.R b/R/cols_merge.R
@@ -37,7 +37,7 @@
 #' columns (i.e., second and subsequent columns given in `columns`). The
 #' formatting of values in different columns will be preserved upon merging.
 #'
-#' @inheritParams cols_align
+#' @inheritParams cols_hide
 #'
 #' @param columns *Columns to target*
 #'
@@ -291,7 +291,7 @@ cols_merge <- function(
 #' uncertainties, and any columns specified in `col_uncert` are hidden from
 #' appearing the output table.
 #'
-#' @inheritParams cols_align
+#' @inheritParams cols_hide
 #'
 #' @param col_val *Column to target for base values*
 #'
@@ -478,7 +478,7 @@ cols_merge_uncert <- function(
 #' containing both values separated by an em dash. The column specified in
 #' `col_end` is dropped from the output table.
 #'
-#' @inheritParams cols_align
+#' @inheritParams cols_hide
 #'
 #' @param col_begin *Column to target for beginning of range*
 #'
@@ -691,7 +691,7 @@ cols_merge_range <- function(
 #' percentages (e.g., `12 (23.2%)`). The column specified in `col_pct` is
 #' dropped from the output table.
 #'
-#' @inheritParams cols_align
+#' @inheritParams cols_hide
 #'
 #' @param col_n *Column to target for counts*
 #'
diff --git a/R/cols_move.R b/R/cols_move.R
@@ -36,7 +36,7 @@
 #' `columns` to be moved is preserved, as is the ordering of all other columns
 #' in the table.
 #'
-#' @inheritParams cols_align
+#' @inheritParams cols_hide
 #'
 #' @param columns *Columns to target*
 #'
@@ -185,7 +185,7 @@ cols_move <- function(
 #' start is preserved (same with the ordering of all other columns in the
 #' table).
 #'
-#' @inheritParams cols_align
+#' @inheritParams cols_hide
 #'
 #' @param columns *Columns to target*
 #'
@@ -311,7 +311,7 @@ cols_move_to_start <- function(
 #' error prone. The ordering of the `columns` that are moved to the end is
 #' preserved (same with the ordering of all other columns in the table).
 #'
-#' @inheritParams cols_align
+#' @inheritParams cols_hide
 #'
 #' @param columns *Columns to target*
 #'
diff --git a/R/modify_rows.R b/R/modify_rows.R
@@ -35,7 +35,7 @@
 #' top of the table and the remaining row groups will follow in their original
 #' ordering.
 #'
-#' @inheritParams cols_align
+#' @inheritParams cols_hide
 #'
 #' @param groups *Specification of row group IDs*
 #'
diff --git a/R/nanoplot.R b/R/nanoplot.R
@@ -76,7 +76,7 @@
 #' helper, layers of the nanoplots can be selectively removed and the aesthetics
 #' of the remaining plot components can be modified.
 #'
-#' @inheritParams cols_align
+#' @inheritParams cols_hide
 #'
 #' @param columns *Columns from which to get data for the dependent variable*
 #'
diff --git a/R/utils.R b/R/utils.R
@@ -2506,3 +2506,39 @@ data_get_image_tag <- function(file, dir = "images") {
 }
 
 #nocov end
+
+#' Function to iterate over the gt_tbls in a gt_group and apply a function
+#' @param data gt_group obj
+#' @param arg_list list of function arguments and function name from match.call in parent function
+#' @param call caller env
+#' @importFrom rlang caller_env
+#' @noRd
+apply_to_grp <- function(data, arg_list, call = caller_env()){
+  func <- as.character(arg_list[[1]])
+  args <- arg_list[-1]
+  # check function is a valid gt exported function
+  if(!(func %in% getNamespaceExports("gt"))){
+    cli::cli_abort("{.val {func}} is not an exported gt function")
+  }
+
+  for (i in seq_len(nrow(data$gt_tbls))) {
+    # pull out gt_tbl, apply function, reinsert into group
+    gt_tbl <- grp_pull(data, i)
+    # replace data arg with current gt_tbl
+    args[[1]] <- gt_tbl
+
+    #make it clear which table if an error occurs
+    gt_tbl <- tryCatch({
+      do.call(func, args, envir = call)
+    },
+    error = function(e) {
+      cli::cli_abort("Failure in Table {i}", parent = e)
+    })
+
+    data <- grp_replace(data, gt_tbl, .which = i)
+  }
+
+  data
+}
+
+
diff --git a/man/cols_align.Rd b/man/cols_align.Rd
diff --git a/man/cols_label.Rd b/man/cols_label.Rd
diff --git a/tests/testthat/_snaps/utils.md b/tests/testthat/_snaps/utils.md
@@ -16,3 +16,14 @@
       Error in `str_substitute()`:
       ! Can't recycle `end` (size 2) to size 4.
 
+# apply_to_grp works
+
+    Code
+      apply_to_grp(gt_group_error, arg_list)
+    Condition
+      Error in `apply_to_grp()`:
+      ! Failure in Table 2
+      Caused by error in `cols_align()`:
+      ! Can't select columns that don't exist.
+      x Column `num` doesn't exist.
+
diff --git a/tests/testthat/test-cols_align.R b/tests/testthat/test-cols_align.R
@@ -216,3 +216,23 @@ test_that("The stub gets its alignment set properly with `cols_align()`", {
     cols_align(align = "center", columns = stub())
   )
 })
+
+
+test_that("check cols_align is applied gt_group", {
+
+  # Create a `gt_group` object of two `gt_tbl`s
+  # create gt group example
+  gt_tbl <- mtcars_short %>% gt()
+  gt_group <- gt_group(gt_tbl, gt_tbl)
+
+  # apply alignment to table and group
+  aligned_gt_tbl <- gt_tbl %>%
+    cols_align(align = "left", columns = c(mpg, cyl, drat))
+
+  aligned_gt_group <- gt_group %>%
+    cols_align(align = "left", columns = c(mpg, cyl, drat))
+
+  # Expect identical if function applied before or after group is constructed
+  expect_identical(aligned_gt_group, gt_group(aligned_gt_tbl, aligned_gt_tbl))
+
+})
diff --git a/tests/testthat/test-cols_label.R b/tests/testthat/test-cols_label.R
@@ -148,7 +148,7 @@ test_that("cols_label() correctly", {
 })
 
 test_that("cols_label() works with md()", {
-  tab <- gt(data.frame(x = 1, y = 2, z = 3)) %>% 
+  tab <- gt(data.frame(x = 1, y = 2, z = 3)) %>%
     cols_label(x = md("*x_1*"), y = md("Time Domain<br/>$\\small{f\\left( t \\right) = {\\mathcal{L}^{\\,\\, - 1}}\\left\\{ {F\\left( s \\right)} \\right\\}}$"))
   expect_equal(
     tab$`_boxhead`$column_label,
@@ -158,5 +158,28 @@ test_that("cols_label() works with md()", {
       "z"
     )
   )
-  
+
+})
+
+test_that("check cols_label is applied gt_group", {
+
+  # Create a `gt_group` object of two `gt_tbl`s
+  # create gt group example
+  gt_tbl <- mtcars_short %>% gt()
+  gt_group <- gt_group(gt_tbl, gt_tbl)
+
+  # apply alignment to table and group
+  label_gt_tbl <- gt_tbl %>%
+    cols_label(
+      mpg = "Miles per gallon"
+    )
+
+  label_gt_group <- gt_group %>%
+    cols_label(
+      mpg = "Miles per gallon"
+    )
+
+  # Expect identical if function applied before or after group is constructed
+  expect_identical(label_gt_group, gt_group(label_gt_tbl, label_gt_tbl))
+
 })
diff --git a/tests/testthat/test-input_data_validation.R b/tests/testthat/test-input_data_validation.R
@@ -1,6 +1,10 @@
 test_that("All exported functions validate the incoming `data` object", {
 
-  regexp_stop <- "`data` must be a `gt_tbl` object"
+  # Stop messages can be either of:
+  # - "`data` must be a `gt_tbl` object, not a tibble."
+  # - "`data` must either be a `gt_tbl` or a `gt_group`, not a tibble."
+  # The regex below handles both adequately
+  regexp_stop <- "`data` must.*?be a `gt_tbl`"
 
   # Test the `exibble` tibble with all exported functions;
   # don't provide values for any arguments and ensure that
diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R
