|
| 1 | +# rtables.R — S3 method and conversion for rtables VTableTree objects |
| 2 | +# |
| 3 | +# Functions: |
| 4 | +# export_tfl.VTableTree() — S3 method dispatched by export_tfl() |
| 5 | +# rtables_to_pagelist() — convert a VTableTree to a list of page specs |
| 6 | +# .extract_rtables_annotations() — extract title/subtitles/footers |
| 7 | +# .clean_rtables() — strip annotations from rtables object |
| 8 | +# .rtables_content_height() — compute available content height |
| 9 | +# .rtables_lpp_cpp() — convert inches to lines/chars per page |
| 10 | +# .rtables_to_grob() — render a single page to textGrob |
| 11 | + |
| 12 | +#' @export |
| 13 | +export_tfl.VTableTree <- function( |
| 14 | + x, |
| 15 | + file = NULL, |
| 16 | + pg_width = 11, |
| 17 | + pg_height = 8.5, |
| 18 | + page_num = "Page {i} of {n}", |
| 19 | + preview = FALSE, |
| 20 | + ... |
| 21 | +) { |
| 22 | + rlang::check_installed("rtables", reason = "to export rtables tables") |
| 23 | + dots <- list(...) |
| 24 | + .validate_export_args(page_num, preview, file) |
| 25 | + pages <- rtables_to_pagelist(x, pg_width, pg_height, dots, page_num) |
| 26 | + .export_tfl_pages(pages, file, pg_width, pg_height, page_num, preview, dots) |
| 27 | +} |
| 28 | + |
| 29 | +#' Convert a VTableTree object to a list of page specification lists |
| 30 | +#' |
| 31 | +#' Extracts main title + subtitles as caption and main footer + provenance |
| 32 | +#' footer as footnote, strips them from the rtables object to avoid |
| 33 | +#' duplication, then renders via `toString()` into a `textGrob`. |
| 34 | +#' |
| 35 | +#' When the table exceeds the available content height, rtables' built-in |
| 36 | +#' `paginate_table()` splits it across pages respecting row group boundaries. |
| 37 | +#' |
| 38 | +#' @param rt_obj A `VTableTree` object. |
| 39 | +#' @param pg_width,pg_height Page dimensions in inches. |
| 40 | +#' @param dots Named list of additional arguments from `...`. |
| 41 | +#' @param page_num Glue template for page numbering (used for height calc). |
| 42 | +#' @return A list of page spec lists, each with at least `$content`. |
| 43 | +#' @keywords internal |
| 44 | +rtables_to_pagelist <- function(rt_obj, pg_width = 11, pg_height = 8.5, |
| 45 | + dots = list(), page_num = "Page {i} of {n}") { |
| 46 | + annot <- .extract_rtables_annotations(rt_obj) |
| 47 | + cleaned <- .clean_rtables(rt_obj) |
| 48 | + |
| 49 | + # Font parameters from dots or defaults |
| 50 | + font_family <- dots$rtables_font_family %||% "Courier" |
| 51 | + font_size <- dots$rtables_font_size %||% 8 |
| 52 | + lineheight <- dots$rtables_lineheight %||% 1 |
| 53 | + |
| 54 | + # Measure available content area |
| 55 | + content_h <- .rtables_content_height(pg_width, pg_height, dots, page_num, |
| 56 | + annot) |
| 57 | + content_w <- .rtables_content_width(pg_width, dots) |
| 58 | + |
| 59 | + # Compute lines-per-page and chars-per-page |
| 60 | + lpp_cpp <- .rtables_lpp_cpp(content_h, content_w, font_family, font_size, |
| 61 | + lineheight) |
| 62 | + |
| 63 | + # Paginate using rtables' built-in pagination |
| 64 | + pages <- rtables::paginate_table( |
| 65 | + cleaned, |
| 66 | + lpp = lpp_cpp$lpp, |
| 67 | + cpp = lpp_cpp$cpp, |
| 68 | + font_family = font_family, |
| 69 | + font_size = font_size, |
| 70 | + lineheight = lineheight, |
| 71 | + verbose = FALSE |
| 72 | + ) |
| 73 | + |
| 74 | + # Convert each page to a grob and assemble page specs |
| 75 | + lapply(pages, function(page) { |
| 76 | + grob <- .rtables_to_grob(page, font_family, font_size, lineheight) |
| 77 | + page_spec <- list(content = 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 VTableTree object |
| 85 | +#' |
| 86 | +#' Extracts main title + subtitles as caption and main footer + provenance |
| 87 | +#' footer as footnote text. |
| 88 | +#' |
| 89 | +#' @param rt_obj A `VTableTree` object. |
| 90 | +#' @return A list with `$caption` (character or NULL) and `$footnote` |
| 91 | +#' (character or NULL). |
| 92 | +#' @keywords internal |
| 93 | +.extract_rtables_annotations <- function(rt_obj) { |
| 94 | + # Caption: main_title + subtitles |
| 95 | + mt <- formatters::main_title(rt_obj) |
| 96 | + st <- formatters::subtitles(rt_obj) |
| 97 | + |
| 98 | + caption_parts <- c( |
| 99 | + if (length(mt) > 0L && nzchar(mt)) mt, |
| 100 | + st[nzchar(st)] |
| 101 | + ) |
| 102 | + caption <- if (length(caption_parts) > 0L) { |
| 103 | + paste(caption_parts, collapse = "\n") |
| 104 | + } |
| 105 | + |
| 106 | + # Footnote: main_footer + prov_footer |
| 107 | + mf <- formatters::main_footer(rt_obj) |
| 108 | + pf <- formatters::prov_footer(rt_obj) |
| 109 | + |
| 110 | + fn_parts <- c(mf[nzchar(mf)], pf[nzchar(pf)]) |
| 111 | + footnote <- if (length(fn_parts) > 0L) { |
| 112 | + paste(fn_parts, collapse = "\n") |
| 113 | + } |
| 114 | + |
| 115 | + list(caption = caption, footnote = footnote) |
| 116 | +} |
| 117 | + |
| 118 | +#' Remove annotations from a VTableTree object |
| 119 | +#' |
| 120 | +#' Strips main title, subtitles, main footer, and provenance footer so that |
| 121 | +#' `toString()` renders only the table body. |
| 122 | +#' |
| 123 | +#' @param rt_obj A `VTableTree` object. |
| 124 | +#' @return A cleaned `VTableTree` object. |
| 125 | +#' @keywords internal |
| 126 | +.clean_rtables <- function(rt_obj) { |
| 127 | + formatters::main_title(rt_obj) <- "" |
| 128 | + formatters::subtitles(rt_obj) <- character(0L) |
| 129 | + formatters::main_footer(rt_obj) <- character(0L) |
| 130 | + formatters::prov_footer(rt_obj) <- character(0L) |
| 131 | + rt_obj |
| 132 | +} |
| 133 | + |
| 134 | +#' Compute available content height for rtables pagination |
| 135 | +#' |
| 136 | +#' Reuses [compute_table_content_area()] to measure how much vertical space |
| 137 | +#' the content gets after header, caption, footnote, and footer sections are |
| 138 | +#' accounted for. |
| 139 | +#' |
| 140 | +#' @param pg_width,pg_height Page dimensions in inches. |
| 141 | +#' @param dots Named list of additional page-layout arguments. |
| 142 | +#' @param page_num Glue template for page numbering. |
| 143 | +#' @param annot Annotation list from [.extract_rtables_annotations()]. |
| 144 | +#' @return Numeric scalar: available content height in inches. |
| 145 | +#' @keywords internal |
| 146 | +.rtables_content_height <- function(pg_width, pg_height, dots, page_num, |
| 147 | + annot) { |
| 148 | + .dot <- function(key) { |
| 149 | + if (!is.null(dots[[key]])) dots[[key]] else .tfl_page_defaults[[key]] |
| 150 | + } |
| 151 | + |
| 152 | + annot_args <- list( |
| 153 | + header_left = dots$header_left, |
| 154 | + header_center = dots$header_center, |
| 155 | + header_right = dots$header_right, |
| 156 | + caption = annot$caption %||% dots$caption, |
| 157 | + footnote = annot$footnote %||% dots$footnote, |
| 158 | + footer_left = dots$footer_left, |
| 159 | + footer_center = dots$footer_center, |
| 160 | + footer_right = dots$footer_right |
| 161 | + ) |
| 162 | + |
| 163 | + # Account for page_num in footer if footer_right is absent |
| 164 | + if (is.null(annot_args$footer_right) && !is.null(page_num)) { |
| 165 | + annot_args$footer_right <- "Page 1 of 1" |
| 166 | + } |
| 167 | + |
| 168 | + dims <- compute_table_content_area( |
| 169 | + pg_width, pg_height, |
| 170 | + .dot("margins"), .dot("padding"), |
| 171 | + .dot("header_rule"), .dot("footer_rule"), |
| 172 | + annot_args, .dot("gp"), |
| 173 | + .dot("caption_just"), .dot("footnote_just") |
| 174 | + ) |
| 175 | + dims$height |
| 176 | +} |
| 177 | + |
| 178 | +#' Compute available content width |
| 179 | +#' |
| 180 | +#' @param pg_width Page width in inches. |
| 181 | +#' @param dots Named list of additional page-layout arguments. |
| 182 | +#' @return Numeric scalar: available content width in inches. |
| 183 | +#' @keywords internal |
| 184 | +.rtables_content_width <- function(pg_width, dots) { |
| 185 | + margins <- if (!is.null(dots$margins)) { |
| 186 | + dots$margins |
| 187 | + } else { |
| 188 | + .tfl_page_defaults$margins |
| 189 | + } |
| 190 | + margin_vals <- grid::convertWidth(margins, "inches", valueOnly = TRUE) |
| 191 | + # margins are c(top, right, bottom, left) |
| 192 | + pg_width - margin_vals[2] - margin_vals[4] |
| 193 | +} |
| 194 | + |
| 195 | +#' Convert content dimensions to lines-per-page and chars-per-page |
| 196 | +#' |
| 197 | +#' @param content_h Available content height in inches. |
| 198 | +#' @param content_w Available content width in inches. |
| 199 | +#' @param font_family Font family name. |
| 200 | +#' @param font_size Font size in points. |
| 201 | +#' @param lineheight Line height multiplier. |
| 202 | +#' @return A list with `$lpp` and `$cpp` (positive integers). |
| 203 | +#' @keywords internal |
| 204 | +.rtables_lpp_cpp <- function(content_h, content_w, font_family = "Courier", |
| 205 | + font_size = 8, lineheight = 1) { |
| 206 | + # Line height in inches |
| 207 | + line_h_in <- (font_size / 72) * lineheight |
| 208 | + lpp <- floor(content_h / line_h_in) |
| 209 | + |
| 210 | + # Character width: measure "M" in the target font using a scratch device |
| 211 | + scratch <- tempfile(fileext = ".pdf") |
| 212 | + grDevices::pdf(scratch, width = 10, height = 10) |
| 213 | + on.exit({ |
| 214 | + grDevices::dev.off() |
| 215 | + unlink(scratch) |
| 216 | + }) |
| 217 | + grid::pushViewport(grid::viewport( |
| 218 | + gp = grid::gpar(fontfamily = font_family, fontsize = font_size) |
| 219 | + )) |
| 220 | + char_w_in <- grid::convertWidth(grid::stringWidth("M"), "inches", |
| 221 | + valueOnly = TRUE) |
| 222 | + grid::popViewport() |
| 223 | + |
| 224 | + cpp <- floor(content_w / char_w_in) |
| 225 | + |
| 226 | + list(lpp = max(as.integer(lpp), 1L), cpp = max(as.integer(cpp), 1L)) |
| 227 | +} |
| 228 | + |
| 229 | +#' Convert a single rtables page to a textGrob |
| 230 | +#' |
| 231 | +#' @param rt_page A `VTableTree` object (one paginated page). |
| 232 | +#' @param font_family Font family name. |
| 233 | +#' @param font_size Font size in points. |
| 234 | +#' @param lineheight Line height multiplier. |
| 235 | +#' @return A grid `textGrob`. |
| 236 | +#' @keywords internal |
| 237 | +.rtables_to_grob <- function(rt_page, font_family = "Courier", |
| 238 | + font_size = 8, lineheight = 1) { |
| 239 | + txt <- formatters::toString(rt_page) |
| 240 | + grid::textGrob( |
| 241 | + txt, |
| 242 | + x = grid::unit(0, "npc"), |
| 243 | + y = grid::unit(1, "npc"), |
| 244 | + just = c("left", "top"), |
| 245 | + gp = grid::gpar(fontfamily = font_family, fontsize = font_size, |
| 246 | + lineheight = lineheight) |
| 247 | + ) |
| 248 | +} |
0 commit comments