|
| 1 | +# table1.R — S3 method and conversion for table1 objects |
| 2 | +# |
| 3 | +# Functions: |
| 4 | +# export_tfl.table1() — S3 method dispatched by export_tfl() |
| 5 | +# table1_to_pagelist() — convert a table1 to a list of page specs |
| 6 | +# .extract_table1_annotations() — extract caption and footnote |
| 7 | +# .table1_variable_groups() — identify variable-group row boundaries |
| 8 | +# .paginate_table1() — group-aware greedy pagination |
| 9 | + |
| 10 | +#' @export |
| 11 | +export_tfl.table1 <- function( |
| 12 | + x, |
| 13 | + file = NULL, |
| 14 | + pg_width = 11, |
| 15 | + pg_height = 8.5, |
| 16 | + page_num = "Page {i} of {n}", |
| 17 | + preview = FALSE, |
| 18 | + ... |
| 19 | +) { |
| 20 | + rlang::check_installed("table1", reason = "to export table1 tables") |
| 21 | + rlang::check_installed("flextable", reason = "to export table1 tables") |
| 22 | + dots <- list(...) |
| 23 | + .validate_export_args(page_num, preview, file) |
| 24 | + pages <- table1_to_pagelist(x, pg_width, pg_height, dots, page_num) |
| 25 | + .export_tfl_pages(pages, file, pg_width, pg_height, page_num, preview, dots) |
| 26 | +} |
| 27 | + |
| 28 | +#' Convert a table1 object to a list of page specification lists |
| 29 | +#' |
| 30 | +#' Extracts caption and footnote from the table1 object's internal structure, |
| 31 | +#' converts to a flextable via [table1::t1flex()], then renders via |
| 32 | +#' [flextable::gen_grob()]. When the rendered table exceeds the available |
| 33 | +#' content height, rows are split across multiple pages using group-aware |
| 34 | +#' pagination that keeps each variable's label and summary statistics together. |
| 35 | +#' |
| 36 | +#' @param t1_obj A `table1` object. |
| 37 | +#' @param pg_width,pg_height Page dimensions in inches. |
| 38 | +#' @param dots Named list of additional arguments from `...`. |
| 39 | +#' @param page_num Glue template for page numbering (used for height calc). |
| 40 | +#' @return A list of page spec lists, each with at least `$content`. |
| 41 | +#' @keywords internal |
| 42 | +table1_to_pagelist <- function(t1_obj, pg_width = 11, pg_height = 8.5, |
| 43 | + dots = list(), page_num = "Page {i} of {n}") { |
| 44 | + annot <- .extract_table1_annotations(t1_obj) |
| 45 | + groups <- .table1_variable_groups(t1_obj) |
| 46 | + |
| 47 | + # Convert to flextable — t1flex() preserves bold labels, indentation, etc. |
| 48 | + ft <- table1::t1flex(t1_obj) |
| 49 | + |
| 50 | + # Clean: remove footer rows (we already extracted footnote) |
| 51 | + ft <- .clean_flextable(ft) |
| 52 | + # Clear caption (we already extracted it) |
| 53 | + ft$caption <- list(value = NULL) |
| 54 | + |
| 55 | + # Measure available content area |
| 56 | + content_h <- .flextable_content_height(pg_width, pg_height, dots, page_num, |
| 57 | + annot) |
| 58 | + content_w <- .flextable_content_width(pg_width, dots) |
| 59 | + |
| 60 | + # Convert to grob and measure height |
| 61 | + grob <- .flextable_to_grob(ft, content_w) |
| 62 | + grob_h <- .flextable_grob_height(grob) |
| 63 | + |
| 64 | + # If the table fits on a single page, return immediately |
| 65 | + if (grob_h <= content_h) { |
| 66 | + page_spec <- list(content = grob) |
| 67 | + if (!is.null(annot$caption)) page_spec$caption <- annot$caption |
| 68 | + if (!is.null(annot$footnote)) page_spec$footnote <- annot$footnote |
| 69 | + return(list(page_spec)) |
| 70 | + } |
| 71 | + |
| 72 | + # Paginate: group-aware splitting |
| 73 | + ft_pages <- .paginate_table1(ft, groups, content_h, content_w) |
| 74 | + |
| 75 | + lapply(ft_pages, function(ft_page) { |
| 76 | + page_grob <- .flextable_to_grob(ft_page, content_w) |
| 77 | + page_spec <- list(content = page_grob) |
| 78 | + if (!is.null(annot$caption)) page_spec$caption <- annot$caption |
| 79 | + if (!is.null(annot$footnote)) page_spec$footnote <- annot$footnote |
| 80 | + page_spec |
| 81 | + }) |
| 82 | +} |
| 83 | + |
| 84 | +#' Extract annotations from a table1 object |
| 85 | +#' |
| 86 | +#' Extracts caption and footnote from the internal `"obj"` attribute of a |
| 87 | +#' table1 object. |
| 88 | +#' |
| 89 | +#' @param t1_obj A `table1` object. |
| 90 | +#' @return A list with `$caption` (character or NULL) and `$footnote` |
| 91 | +#' (character or NULL). |
| 92 | +#' @keywords internal |
| 93 | +.extract_table1_annotations <- function(t1_obj) { |
| 94 | + obj <- attr(t1_obj, "obj", exact = TRUE) |
| 95 | + |
| 96 | + caption <- obj$caption |
| 97 | + if (!is.null(caption) && (!nzchar(caption) || all(is.na(caption)))) { |
| 98 | + caption <- NULL |
| 99 | + } |
| 100 | + |
| 101 | + footnote <- obj$footnote |
| 102 | + if (!is.null(footnote)) { |
| 103 | + footnote <- footnote[nzchar(footnote) & !is.na(footnote)] |
| 104 | + if (length(footnote) == 0L) { |
| 105 | + footnote <- NULL |
| 106 | + } else { |
| 107 | + footnote <- paste(footnote, collapse = "\n") |
| 108 | + } |
| 109 | + } |
| 110 | + |
| 111 | + list(caption = caption, footnote = footnote) |
| 112 | +} |
| 113 | + |
| 114 | +#' Identify variable-group row boundaries in a table1 object |
| 115 | +#' |
| 116 | +#' Each variable in a table1 output forms a "group" consisting of a bold |
| 117 | +#' variable-label row followed by indented summary-statistic rows. This |
| 118 | +#' function returns the flextable body row indices for each group, derived |
| 119 | +#' from the `contents` matrices in the table1 object's internal structure. |
| 120 | +#' |
| 121 | +#' @param t1_obj A `table1` object. |
| 122 | +#' @return A list of integer vectors, each containing the body row indices |
| 123 | +#' for one variable group (label row + summary rows). |
| 124 | +#' @keywords internal |
| 125 | +.table1_variable_groups <- function(t1_obj) { |
| 126 | + obj <- attr(t1_obj, "obj", exact = TRUE) |
| 127 | + contents <- obj$contents |
| 128 | + |
| 129 | + groups <- list() |
| 130 | + cumrow <- 0L |
| 131 | + for (i in seq_along(contents)) { |
| 132 | + nr <- nrow(contents[[i]]) |
| 133 | + rows <- seq(cumrow + 1L, cumrow + nr) |
| 134 | + groups <- c(groups, list(rows)) |
| 135 | + cumrow <- cumrow + nr |
| 136 | + } |
| 137 | + groups |
| 138 | +} |
| 139 | + |
| 140 | +#' Group-aware greedy pagination for table1 flextables |
| 141 | +#' |
| 142 | +#' Splits a table1-derived flextable across pages, keeping each variable's |
| 143 | +#' label and summary statistic rows together. If a single variable group |
| 144 | +#' exceeds the page height, falls back to row-by-row splitting within that |
| 145 | +#' group. |
| 146 | +#' |
| 147 | +#' @param ft_obj A cleaned `flextable` (converted from table1, no footer rows). |
| 148 | +#' @param groups List of integer vectors from [.table1_variable_groups()]. |
| 149 | +#' @param content_h Available content height in inches. |
| 150 | +#' @param content_w Available content width in inches. |
| 151 | +#' @return A list of `flextable` objects (one per page). |
| 152 | +#' @keywords internal |
| 153 | +.paginate_table1 <- function(ft_obj, groups, content_h, content_w) { |
| 154 | + pages <- list() |
| 155 | + current_rows <- integer(0L) |
| 156 | + |
| 157 | + for (grp_idx in seq_along(groups)) { |
| 158 | + candidate_rows <- c(current_rows, groups[[grp_idx]]) |
| 159 | + sub_ft <- .rebuild_flextable_subset(ft_obj, candidate_rows) |
| 160 | + sub_grob <- .flextable_to_grob(sub_ft, content_w) |
| 161 | + h <- .flextable_grob_height(sub_grob) |
| 162 | + |
| 163 | + if (h > content_h && length(current_rows) > 0L) { |
| 164 | + # Current group doesn't fit — finalize current page |
| 165 | + pages <- c(pages, list(.rebuild_flextable_subset(ft_obj, current_rows))) |
| 166 | + # Try the group alone |
| 167 | + grp_ft <- .rebuild_flextable_subset(ft_obj, groups[[grp_idx]]) |
| 168 | + grp_grob <- .flextable_to_grob(grp_ft, content_w) |
| 169 | + grp_h <- .flextable_grob_height(grp_grob) |
| 170 | + |
| 171 | + if (grp_h > content_h) { |
| 172 | + # Oversized group: fall back to row-by-row within this group |
| 173 | + row_pages <- .paginate_oversized_group(ft_obj, groups[[grp_idx]], |
| 174 | + content_h, content_w) |
| 175 | + # All but the last sub-page are complete pages |
| 176 | + for (rp_idx in seq_along(row_pages)) { |
| 177 | + if (rp_idx < length(row_pages)) { |
| 178 | + pages <- c(pages, list(row_pages[[rp_idx]])) |
| 179 | + } else { |
| 180 | + # Last sub-page becomes the start of the next accumulation |
| 181 | + current_rows <- row_pages[[rp_idx]]$body_rows |
| 182 | + } |
| 183 | + } |
| 184 | + } else { |
| 185 | + current_rows <- groups[[grp_idx]] |
| 186 | + } |
| 187 | + } else if (h > content_h && length(current_rows) == 0L) { |
| 188 | + # First group on an empty page and it still doesn't fit |
| 189 | + row_pages <- .paginate_oversized_group(ft_obj, groups[[grp_idx]], |
| 190 | + content_h, content_w) |
| 191 | + for (rp_idx in seq_along(row_pages)) { |
| 192 | + if (rp_idx < length(row_pages)) { |
| 193 | + pages <- c(pages, list(row_pages[[rp_idx]])) |
| 194 | + } else { |
| 195 | + current_rows <- row_pages[[rp_idx]]$body_rows |
| 196 | + } |
| 197 | + } |
| 198 | + } else { |
| 199 | + current_rows <- candidate_rows |
| 200 | + } |
| 201 | + } |
| 202 | + |
| 203 | + if (length(current_rows) > 0L) { |
| 204 | + pages <- c(pages, list(.rebuild_flextable_subset(ft_obj, current_rows))) |
| 205 | + } |
| 206 | + |
| 207 | + pages |
| 208 | +} |
| 209 | + |
| 210 | +#' Paginate an oversized variable group row-by-row |
| 211 | +#' |
| 212 | +#' When a single variable group (label + summary rows) exceeds the available |
| 213 | +#' content height, falls back to row-by-row greedy splitting. |
| 214 | +#' |
| 215 | +#' @param ft_obj The full flextable object. |
| 216 | +#' @param grp_rows Integer vector of body row indices for the oversized group. |
| 217 | +#' @param content_h Available content height in inches. |
| 218 | +#' @param content_w Available content width in inches. |
| 219 | +#' @return A list of objects. Complete sub-pages are `flextable` objects. |
| 220 | +#' The last element is a list with `$body_rows` (integer vector of remaining |
| 221 | +#' row indices) for further accumulation. |
| 222 | +#' @keywords internal |
| 223 | +.paginate_oversized_group <- function(ft_obj, grp_rows, content_h, content_w) { |
| 224 | + results <- list() |
| 225 | + current_rows <- integer(0L) |
| 226 | + |
| 227 | + for (row_idx in grp_rows) { |
| 228 | + candidate <- c(current_rows, row_idx) |
| 229 | + sub_ft <- .rebuild_flextable_subset(ft_obj, candidate) |
| 230 | + sub_grob <- .flextable_to_grob(sub_ft, content_w) |
| 231 | + h <- .flextable_grob_height(sub_grob) |
| 232 | + |
| 233 | + if (h > content_h && length(current_rows) > 0L) { |
| 234 | + results <- c(results, list(.rebuild_flextable_subset(ft_obj, |
| 235 | + current_rows))) |
| 236 | + current_rows <- row_idx |
| 237 | + } else { |
| 238 | + current_rows <- candidate |
| 239 | + } |
| 240 | + } |
| 241 | + |
| 242 | + # Last batch: return as a list with body_rows for further accumulation |
| 243 | + if (length(current_rows) > 0L) { |
| 244 | + results <- c(results, list(list(body_rows = current_rows))) |
| 245 | + } |
| 246 | + |
| 247 | + results |
| 248 | +} |
0 commit comments