Feature/sub tfl

CLAUDE.md

@@ -98,6 +98,31 @@ export_tfl_page(
 
 `...` in `export_tfl()` is forwarded to `export_tfl_page()`.
 
+`tfl_table()` also accepts (in its signature, not via `...`):
+
+```r
+sub_tfl          = NULL,        # character vector of column names; splits
+                                # the data into one sub-table per unique
+                                # combination, dropping the columns from the
+                                # body and appending them to the caption.
+sub_tfl_sep      = ": ",        # between label and value
+sub_tfl_collapse = "; ",        # between successive label:value pairs
+sub_tfl_prefix   = "\n",        # between the existing caption and the suffix
+```
+
+`export_tfl.ggtibble()` accepts the same four arguments to add a per-row
+caption suffix to figure pages (labels are raw column names; no colspec
+system).
+
+When `sub_tfl` is set on a `tfl_table`:
+- columns named in `sub_tfl` are removed from the rendered body, including
+  removal from `group_vars` if they overlap (a common case);
+- one sub-table is produced per unique combination of values, ordered by
+  factor levels for factor columns and first-appearance order otherwise;
+- the first column of `sub_tfl` varies outermost;
+- when the global `caption` is `NULL`, the suffix becomes the entire caption
+  (no leading prefix).
+
 ---
 
 ## Key behavioral rules (implement exactly as specified)
@@ -306,6 +331,11 @@ writetfl/
 │   ├── export_tfl_page.R             ← exported; single-page layout and draw
 │   ├── ggtibble.R                    ← export_tfl.ggtibble(), ggtibble_to_pagelist()
 │   ├── tfl_table.R                   ← exported; tfl_table(), tfl_colspec()
+│   ├── sub_tfl.R                     ← .compute_sub_tfl_groups(),
+│   │                                    .resolve_col_label(),
+│   │                                    .format_sub_tfl_caption(),
+│   │                                    .apply_sub_tfl_caption(),
+│   │                                    .strip_sub_tfl_cols()
 │   ├── normalize.R                   ← normalize_text(), normalize_rule()
 │   ├── grob_builders.R               ← build_section_grobs(), build_text_grob()
 │   ├── measure.R                     ← measure_grob_height(), measure_section_heights(),
@@ -358,6 +388,7 @@ writetfl/
 │       ├── test-table_utils.R
 │       ├── test-table_draw.R
 │       ├── test-tfl_table.R
+│       ├── test-sub_tfl.R
 │       ├── test-ggtibble.R
 │       ├── test-gt.R
 │       ├── test-rtables.R

R/ggtibble.R

@@ -7,47 +7,99 @@
 #' @export
 export_tfl.ggtibble <- function(
   x,
-  file      = NULL,
-  pg_width  = 11,
-  pg_height = 8.5,
-  page_num  = "Page {i} of {n}",
-  preview   = FALSE,
+  file             = NULL,
+  pg_width         = 11,
+  pg_height        = 8.5,
+  page_num         = "Page {i} of {n}",
+  preview          = FALSE,
+  sub_tfl          = NULL,
+  sub_tfl_sep      = ": ",
+  sub_tfl_collapse = "; ",
+  sub_tfl_prefix   = "\n",
   ...
 ) {
   dots <- list(...)
   .validate_export_args(page_num, preview, file)
-  x <- ggtibble_to_pagelist(x)
+  x <- ggtibble_to_pagelist(x, sub_tfl = sub_tfl, sub_tfl_sep = sub_tfl_sep,
+                            sub_tfl_collapse = sub_tfl_collapse,
+                            sub_tfl_prefix = sub_tfl_prefix)
   .export_tfl_pages(x, file, pg_width, pg_height, page_num, preview, dots)
 }
 
+# Page-spec arg names recognised on a ggtibble row.
+.ggtibble_page_arg_names <- c(
+  "caption", "footnote",
+  "header_left", "header_center", "header_right",
+  "footer_left", "footer_center", "footer_right"
+)
+
+# Build one page spec from a single ggtibble row.
+#' @keywords internal
+.ggtibble_row_pagespec <- function(i, x, present_args, sub_tfl,
+                                    sub_tfl_sep, sub_tfl_collapse,
+                                    sub_tfl_prefix) {
+  # Extract the ggplot from the figure cell. gglist[[i]] returns the ggplot
+  # directly; for plain list columns, unwrap one level if needed.
+  fig <- x$figure[[i]]
+  if (!inherits(fig, "gg") && is.list(fig)) fig <- fig[[1L]]
+  spec <- list(content = fig)
+  for (col in present_args) {
+    spec[[col]] <- x[[col]][[i]]
+  }
+  if (!is.null(sub_tfl)) {
+    pairs <- vapply(sub_tfl, .format_ggtibble_sub_tfl_pair,
+                    character(1L), x = x, i = i, sep = sub_tfl_sep)
+    suffix <- paste(pairs, collapse = sub_tfl_collapse)
+    spec$caption <- .apply_sub_tfl_caption(spec$caption, suffix,
+                                           sub_tfl_prefix)
+  }
+  spec
+}
+
 #' Convert a ggtibble object to a list of page specification lists
 #'
 #' Each row of the ggtibble becomes one page spec. The `figure` column
 #' provides the content (ggplot). Any columns whose names match
-#' [export_tfl_page()] text arguments are used as per-page values.
+#' [export_tfl_page()] text arguments are used as per-page values. When
+#' `sub_tfl` is supplied, those columns' values are appended to each row's
+#' caption.
 #'
 #' @param x A `ggtibble` object.
+#' @param sub_tfl Character vector of column names in `x`, or `NULL`.
+#' @param sub_tfl_sep,sub_tfl_collapse,sub_tfl_prefix Formatting controls for
+#'   the appended `label: value` suffix. See [tfl_table()].
 #' @return A list of page spec lists, each with at least `$content`.
 #' @keywords internal
-ggtibble_to_pagelist <- function(x) {
-  # Column names that map to export_tfl_page() text arguments
-  page_arg_names <- c(
-    "caption", "footnote",
-    "header_left", "header_center", "header_right",
-    "footer_left", "footer_center", "footer_right"
-  )
-  present_args <- intersect(page_arg_names, names(x))
+ggtibble_to_pagelist <- function(x, sub_tfl = NULL, sub_tfl_sep = ": ",
+                                 sub_tfl_collapse = "; ",
+                                 sub_tfl_prefix = "\n") {
+  present_args <- intersect(.ggtibble_page_arg_names, names(x))
 
-  lapply(seq_len(nrow(x)), function(i) {
-    # Extract the ggplot from the figure cell.
-    # gglist[[i]] returns the ggplot directly; for plain list columns,
-    # unwrap one level if needed.
-    fig <- x$figure[[i]]
-    if (!inherits(fig, "gg") && is.list(fig)) fig <- fig[[1L]]
-    spec <- list(content = fig)
-    for (col in present_args) {
-      spec[[col]] <- x[[col]][[i]]
+  if (!is.null(sub_tfl)) {
+    if (!is.character(sub_tfl) || length(sub_tfl) == 0L ||
+        anyNA(sub_tfl) || any(!nzchar(sub_tfl))) {
+      rlang::abort("`sub_tfl` must be NULL or a non-empty character vector.")
+    }
+    bad <- setdiff(sub_tfl, names(x))
+    if (length(bad) > 0L) {
+      rlang::abort(paste0(
+        "`sub_tfl` columns not found in the ggtibble: ",
+        paste(bad, collapse = ", ")
+      ))
     }
-    spec
-  })
+    checkmate::assert_character(sub_tfl_sep,      len = 1L,
+                                any.missing = FALSE,
+                                .var.name = "sub_tfl_sep")
+    checkmate::assert_character(sub_tfl_collapse, len = 1L,
+                                any.missing = FALSE,
+                                .var.name = "sub_tfl_collapse")
+    checkmate::assert_character(sub_tfl_prefix,   len = 1L,
+                                any.missing = FALSE,
+                                .var.name = "sub_tfl_prefix")
+  }
+
+  lapply(seq_len(nrow(x)), .ggtibble_row_pagespec,
+         x = x, present_args = present_args, sub_tfl = sub_tfl,
+         sub_tfl_sep = sub_tfl_sep, sub_tfl_collapse = sub_tfl_collapse,
+         sub_tfl_prefix = sub_tfl_prefix)
 }

R/sub_tfl.R

@@ -0,0 +1,167 @@
+# sub_tfl.R — Sub-table support for tfl_table and ggtibble.
+#
+# When `sub_tfl` is set on a tfl_table (or export_tfl.ggtibble), the data is
+# split into one sub-table per unique combination of values in the named
+# columns.  The values are removed from the rendered body and appended to the
+# caption as "label: value; label: value".
+
+# ---------------------------------------------------------------------------
+# Top-level helpers (no nested function definitions)
+# ---------------------------------------------------------------------------
+
+# Ordered unique values of a single column. Factor columns drive their level
+# order (filtered to present values); other columns use first-appearance.
+#' @keywords internal
+.ordered_unique_values <- function(col_data) {
+  v_nona <- col_data[!is.na(col_data)]
+  if (is.factor(col_data)) {
+    lv <- levels(col_data)
+    lv[lv %in% as.character(v_nona)]
+  } else {
+    unique(v_nona)
+  }
+}
+
+# Wrap a single column's value as a one-element named list — the seed for the
+# Cartesian-product accumulator in .compute_sub_tfl_groups().
+#' @keywords internal
+.named_one_value <- function(value, name) {
+  stats::setNames(list(value), name)
+}
+
+# Logical predicate used by .strip_sub_tfl_cols() to filter colspec entries.
+#' @keywords internal
+.colspec_not_in <- function(cs, drop) {
+  !cs$col %in% drop
+}
+
+# Build a single "label: value" pair for one sub_tfl column.
+#' @keywords internal
+.format_sub_tfl_pair <- function(col, tbl, values) {
+  label <- .resolve_col_label(tbl, col)
+  paste(label, format(values[[col]]), sep = tbl$sub_tfl_sep)
+}
+
+# Build a single "col: value" pair for ggtibble (raw column names, no colspec).
+#' @keywords internal
+.format_ggtibble_sub_tfl_pair <- function(col, x, i, sep) {
+  paste(col, format(x[[col]][[i]]), sep = sep)
+}
+
+# ---------------------------------------------------------------------------
+# .compute_sub_tfl_groups()
+# ---------------------------------------------------------------------------
+
+# Returns an ordered list of sub-group specs:
+#   list(list(values = named-list, row_idx = integer), ...)
+# Order: factor columns drive their level order; character/numeric columns use
+# first-appearance order. sub_tfl[1] varies outermost (slowest).
+#' @keywords internal
+.compute_sub_tfl_groups <- function(data, sub_tfl) {
+  ord_vals <- lapply(data[sub_tfl], .ordered_unique_values)
+  names(ord_vals) <- sub_tfl
+
+  # Build combos with sub_tfl[1] outermost.
+  combos <- lapply(ord_vals[[1L]], .named_one_value, name = sub_tfl[[1L]])
+  for (k in seq_along(sub_tfl)[-1L]) {
+    new_combos <- list()
+    for (rc in combos) {
+      for (v in ord_vals[[k]]) {
+        rc_new <- rc
+        rc_new[[sub_tfl[[k]]]] <- v
+        new_combos[[length(new_combos) + 1L]] <- rc_new
+      }
+    }
+    combos <- new_combos
+  }
+
+  # For each combo, find row indices in `data`. Skip combinations that are
+  # not present in any row (Cartesian product may produce them).
+  groups <- list()
+  for (combo in combos) {
+    matches <- rep(TRUE, nrow(data))
+    for (col in sub_tfl) {
+      v      <- data[[col]]
+      target <- combo[[col]]
+      m      <- v == target
+      m[is.na(m)] <- FALSE
+      matches <- matches & m
+    }
+    idx <- which(matches)
+    if (length(idx) > 0L) {
+      groups[[length(groups) + 1L]] <- list(values = combo, row_idx = idx)
+    }
+  }
+  groups
+}
+
+# ---------------------------------------------------------------------------
+# .resolve_col_label() — single source of truth for label fallback
+# ---------------------------------------------------------------------------
+
+# Priority: tfl_colspec$label > tbl$col_labels[col] > col itself.
+#' @keywords internal
+.resolve_col_label <- function(tbl, col_name) {
+  if (!is.null(tbl$cols)) {
+    for (cs in tbl$cols) {
+      if (identical(cs$col, col_name) && !is.null(cs$label)) {
+        return(cs$label)
+      }
+    }
+  }
+  flat <- .nlookup(tbl$col_labels, col_name)
+  if (!is.null(flat)) return(flat)
+  col_name
+}
+
+# ---------------------------------------------------------------------------
+# .format_sub_tfl_caption()
+# ---------------------------------------------------------------------------
+
+# Build the per-page caption suffix from a named list of values.
+#' @keywords internal
+.format_sub_tfl_caption <- function(tbl, values) {
+  pairs <- vapply(names(values), .format_sub_tfl_pair,
+                  character(1L), tbl = tbl, values = values)
+  paste(pairs, collapse = tbl$sub_tfl_collapse)
+}
+
+# ---------------------------------------------------------------------------
+# .apply_sub_tfl_caption()
+# ---------------------------------------------------------------------------
+
+# Combine a base caption with the sub_tfl suffix using prefix rules.
+# Returns the suffix alone when base is NULL.
+#' @keywords internal
+.apply_sub_tfl_caption <- function(base, suffix, prefix) {
+  if (is.null(base)) return(suffix)
+  paste0(base, prefix, suffix)
+}
+
+# ---------------------------------------------------------------------------
+# .strip_sub_tfl_cols()
+# ---------------------------------------------------------------------------
+
+# Remove sub_tfl entries from cols / col_widths / col_labels / col_align /
+# wrap_cols. The caller is responsible for filtering tbl$data and updating
+# tbl$group_vars.
+#' @keywords internal
+.strip_sub_tfl_cols <- function(tbl) {
+  drop <- tbl$sub_tfl
+  if (!is.null(tbl$cols)) {
+    keep <- vapply(tbl$cols, .colspec_not_in, logical(1L), drop = drop)
+    tbl$cols <- tbl$cols[keep]
+    if (length(tbl$cols) == 0L) tbl$cols <- NULL
+  }
+  for (fld in c("col_widths", "col_labels", "col_align")) {
+    v <- tbl[[fld]]
+    if (!is.null(v) && !is.null(names(v))) {
+      tbl[[fld]] <- v[!names(v) %in% drop]
+      if (length(tbl[[fld]]) == 0L) tbl[[fld]] <- NULL
+    }
+  }
+  if (is.character(tbl$wrap_cols)) {
+    tbl$wrap_cols <- setdiff(tbl$wrap_cols, drop)
+  }
+  tbl
+}