1 |
## #' Page Dimensions
|
|
2 |
## #'
|
|
3 |
## #' Dimensions for mapping page dimensions to text dimensions
|
|
4 |
## #' @references https://www.ietf.org/rfc/rfc0678.txt
|
|
5 |
## #' @export
|
|
6 |
## #' @rdname pagedims
|
|
7 |
## lpi_vert <- 6
|
|
8 |
## #' @export
|
|
9 |
## #' @rdname pagedims
|
|
10 |
## cpi_horiz <- 10
|
|
11 |
## #' @export
|
|
12 |
## #' @rdname pagedims
|
|
13 |
## horiz_margin_chars <- 13
|
|
14 |
## #' @export
|
|
15 |
## #' @rdname pagedims
|
|
16 |
## horiz_margin_inches <- horiz_margin_chars / cpi_horiz
|
|
17 |
## #' @export
|
|
18 |
## #' @rdname pagedims
|
|
19 |
## vert_margin_lines <- 6
|
|
20 |
## #' @export
|
|
21 |
## #' @rdname pagedims
|
|
22 |
## vert_margin_inches <- vert_margin_lines / lpi_vert
|
|
23 | ||
24 |
## #' Physical Page dimensions to chars x lines
|
|
25 |
## #'
|
|
26 |
## #' Calculate number of lines long and characters wide a page size is,
|
|
27 |
## #' after excluding margins
|
|
28 |
## #' @export
|
|
29 |
## #' @examples
|
|
30 |
## #' phys_page_to_lc()
|
|
31 |
## phys_page_to_lc <- function(width = 8.5, len = 11,
|
|
32 |
## h_margin = horiz_margin_inches,
|
|
33 |
## v_margin = vert_margin_inches) {
|
|
34 |
## lgl_width <- width - h_margin
|
|
35 |
## lgl_len <- len - v_margin
|
|
36 |
## c(chars_wide = floor(lgl_width * cpi_horiz),
|
|
37 |
## lines_long = floor(lgl_len * lpi_vert))
|
|
38 |
## }
|
|
39 | ||
40 |
#' Pagination
|
|
41 |
#'
|
|
42 |
#' @section Pagination Algorithm:
|
|
43 |
#'
|
|
44 |
#' Pagination is performed independently in the vertical and horizontal
|
|
45 |
#' directions based solely on a *pagination data frame*, which includes the
|
|
46 |
#' following information for each row/column:
|
|
47 |
#'
|
|
48 |
#' - Number of lines/characters rendering the row will take **after
|
|
49 |
#' word-wrapping** (`self_extent`)
|
|
50 |
#' - The indices (`reprint_inds`) and number of lines (`par_extent`)
|
|
51 |
#' of the rows which act as **context** for the row
|
|
52 |
#' - The row's number of siblings and position within its siblings
|
|
53 |
#'
|
|
54 |
#' Given `lpp` (`cpp`) is already adjusted for rendered elements which
|
|
55 |
#' are not rows/columns and a data frame of pagination information,
|
|
56 |
#' pagination is performed via the following algorithm with `start = 1`.
|
|
57 |
#'
|
|
58 |
#' Core Pagination Algorithm:
|
|
59 |
#'
|
|
60 |
#' 1. Initial guess for pagination position is `start + lpp` (`start + cpp`)
|
|
61 |
#' 2. While the guess is not a valid pagination position, and `guess > start`,
|
|
62 |
#' decrement guess and repeat.
|
|
63 |
#' - An error is thrown if all possible pagination positions between
|
|
64 |
#' `start` and `start + lpp` (`start + cpp`) would be `< start`
|
|
65 |
#' after decrementing
|
|
66 |
#' 3. Retain pagination index
|
|
67 |
#' 4. If pagination point was less than `NROW(tt)` (`ncol(tt)`), set
|
|
68 |
#' `start` to `pos + 1`, and repeat steps (1) - (4).
|
|
69 |
#'
|
|
70 |
#' Validating Pagination Position:
|
|
71 |
#'
|
|
72 |
#' Given an (already adjusted) `lpp` or `cpp` value, a pagination is invalid if:
|
|
73 |
#'
|
|
74 |
#' - The rows/columns on the page would take more than (adjusted) `lpp` lines/`cpp`
|
|
75 |
#' characters to render **including**:
|
|
76 |
#' - word-wrapping
|
|
77 |
#' - (vertical only) context repetition
|
|
78 |
#' - (vertical only) footnote messages and/or section divider lines
|
|
79 |
#' take up too many lines after rendering rows
|
|
80 |
#' - (vertical only) row is a label or content (row-group summary) row
|
|
81 |
#' - (vertical only) row at the pagination point has siblings, and
|
|
82 |
#' it has less than `min_siblings` preceding or following siblings
|
|
83 |
#' - pagination would occur within a sub-table listed in `nosplitin`
|
|
84 |
#'
|
|
85 |
#' @name pagination_algo
|
|
86 |
NULL
|
|
87 | ||
88 |
#' Create a row of a pagination data frame
|
|
89 |
#'
|
|
90 |
#' @param nm (`string`)\cr name.
|
|
91 |
#' @param lab (`string`)\cr label.
|
|
92 |
#' @param rnum (`numeric(1)`)\cr absolute row number.
|
|
93 |
#' @param pth (`character` or `NULL`)\cr path within larger table.
|
|
94 |
#' @param sibpos (`integer(1)`)\cr position among sibling rows.
|
|
95 |
#' @param nsibs (`integer(1)`)\cr number of siblings (including self).
|
|
96 |
#' @param extent (`numeric(1)`)\cr number of lines required to print the row.
|
|
97 |
#' @param colwidths (`numeric`)\cr column widths.
|
|
98 |
#' @param repext (`integer(1)`)\cr number of lines required to reprint all context for this row if it appears directly
|
|
99 |
#' after pagination.
|
|
100 |
#' @param repind (`integer`)\cr vector of row numbers to be reprinted if this row appears directly after pagination.
|
|
101 |
#' @param indent (`integer`)\cr indent.
|
|
102 |
#' @param rclass (`string`)\cr class of row object.
|
|
103 |
#' @param nrowrefs (`integer(1)`)\cr number of row referential footnotes for this row.
|
|
104 |
#' @param ncellrefs (`integer(1)`)\cr number of cell referential footnotes for the cells in this row.
|
|
105 |
#' @param nreflines (`integer(1)`)\cr total number of lines required by all referential footnotes.
|
|
106 |
#' @param force_page (`flag`)\cr currently ignored.
|
|
107 |
#' @param page_title (`flag`)\cr currently ignored.
|
|
108 |
#' @param trailing_sep (`string`)\cr the string to use as a separator below this row during printing.
|
|
109 |
#' If `NA_character_`, no separator is used.
|
|
110 |
#' @param row (`ANY`)\cr object representing the row, which is used for default values of `nm`, `lab`,
|
|
111 |
#' `extent`, and `rclass` if provided. Must have methods for `obj_name`, `obj_label`, and `nlines`, to retrieve
|
|
112 |
#' default values of `nm`, `lab`, and `extent`, respectively.
|
|
113 |
#'
|
|
114 |
#' @return A single row `data.frame` with the appropriate columns for a pagination info data frame.
|
|
115 |
#'
|
|
116 |
#' @export
|
|
117 |
pagdfrow <- function(row, |
|
118 |
nm = obj_name(row), |
|
119 |
lab = obj_label(row), |
|
120 |
rnum,
|
|
121 |
pth,
|
|
122 |
sibpos = NA_integer_, |
|
123 |
nsibs = NA_integer_, |
|
124 |
extent = nlines(row, colwidths), |
|
125 |
colwidths = NULL, |
|
126 |
repext = 0L, |
|
127 |
repind = integer(), |
|
128 |
indent = 0L, |
|
129 |
rclass = class(row), |
|
130 |
nrowrefs = 0L, |
|
131 |
ncellrefs = 0L, |
|
132 |
nreflines = 0L, |
|
133 |
# ref_df = .make_ref_df(NULL, NULL),
|
|
134 |
force_page = FALSE, |
|
135 |
page_title = NA_character_, |
|
136 |
trailing_sep = NA_character_) { |
|
137 | 2206x |
data.frame( |
138 | 2206x |
label = lab, |
139 | 2206x |
name = nm, |
140 | 2206x |
abs_rownumber = rnum, |
141 | 2206x |
path = I(list(pth)), |
142 | 2206x |
pos_in_siblings = sibpos, |
143 | 2206x |
n_siblings = nsibs, |
144 | 2206x |
self_extent = extent, |
145 | 2206x |
par_extent = repext, |
146 | 2206x |
reprint_inds = I(rep(list(unlist(repind)), length.out = length(nm))), |
147 | 2206x |
node_class = rclass, |
148 | 2206x |
indent = max(0L, indent), |
149 | 2206x |
nrowrefs = nrowrefs, |
150 | 2206x |
ncellrefs = ncellrefs, |
151 | 2206x |
nreflines = nreflines, |
152 |
# ref_info_df = I(list(ref_df)),
|
|
153 | 2206x |
force_page = force_page, |
154 | 2206x |
page_title = page_title, |
155 | 2206x |
trailing_sep = trailing_sep, |
156 | 2206x |
stringsAsFactors = FALSE, |
157 | 2206x |
row.names = NULL, |
158 | 2206x |
check.names = FALSE, |
159 | 2206x |
fix.empty.names = FALSE |
160 |
)
|
|
161 |
}
|
|
162 | ||
163 |
calc_ref_nlines_df <- function(pagdf) { |
|
164 |
## XXX XXX XXX this is dangerous and wrong!!!
|
|
165 | 628x |
if (is.null(pagdf$ref_info_df) && sum(pagdf$nreflines) == 0) { |
166 | 221x |
return(ref_df_row()[0, ]) |
167 |
}
|
|
168 | 407x |
refdf <- do.call(rbind.data.frame, pagdf$ref_info_df) |
169 | 407x |
if (NROW(refdf) == 0) { |
170 | 312x |
return(ref_df_row()[0, ]) |
171 |
}
|
|
172 | 95x |
unqsyms <- !duplicated(refdf$symbol) |
173 | 95x |
refdf[unqsyms, , drop = FALSE] |
174 |
}
|
|
175 | ||
176 |
build_fail_msg <- function(row, lines, raw_rowlines, |
|
177 |
allowed_lines, lpp, decoration_lines, |
|
178 |
start, guess, rep_ext, n_reprint, |
|
179 |
reflines, n_refs, sectlines) { |
|
180 | 254x |
if (row) { |
181 | 104x |
spacetype <- "lines" |
182 | 104x |
spacetype_abr <- "lns" |
183 | 104x |
structtype_abr <- "rws" |
184 | 104x |
sprintf( |
185 | 104x |
paste0( |
186 | 104x |
" FAIL: rows selected for pagination require %d %s while only %d are available from ",
|
187 | 104x |
"lpp = %d and %d header/footers lines.\n",
|
188 | 104x |
" details: [raw: %d %s (%d %s), rep. context: %d %s (%d %s), ",
|
189 | 104x |
"refs: %d %s (%d) sect. divs: %d %s]."
|
190 |
),
|
|
191 | 104x |
lines,
|
192 | 104x |
spacetype,
|
193 | 104x |
allowed_lines,
|
194 | 104x |
lpp,
|
195 | 104x |
decoration_lines, # header + footers |
196 | 104x |
raw_rowlines,
|
197 | 104x |
spacetype_abr,
|
198 | 104x |
guess - start + 1, # because it includes both start and guess |
199 | 104x |
structtype_abr,
|
200 | 104x |
rep_ext,
|
201 | 104x |
spacetype_abr,
|
202 | 104x |
n_reprint,
|
203 | 104x |
structtype_abr,
|
204 | 104x |
reflines,
|
205 | 104x |
spacetype_abr,
|
206 | 104x |
n_refs,
|
207 | 104x |
sectlines,
|
208 | 104x |
spacetype_abr
|
209 |
)
|
|
210 |
} else { ## !row |
|
211 | 150x |
spacetype <- "chars" |
212 | 150x |
spacetype_abr <- "chars" |
213 | 150x |
structtype_abr <- "cols" |
214 | 150x |
sprintf( |
215 | 150x |
" FAIL: selected columns require %d %s (%d %s).",
|
216 | 150x |
lines,
|
217 | 150x |
spacetype,
|
218 | 150x |
guess - start + 1, # because it includes both start and guess |
219 | 150x |
structtype_abr
|
220 |
)
|
|
221 |
}
|
|
222 |
}
|
|
223 | ||
224 |
valid_pag <- function(pagdf, |
|
225 |
guess,
|
|
226 |
start,
|
|
227 |
rlpp,
|
|
228 |
lpp, # for informational purposes only |
|
229 |
context_lpp, # for informational purposes only (headers/footers) |
|
230 |
min_sibs,
|
|
231 |
nosplit = NULL, |
|
232 |
div_height = 1L, |
|
233 |
verbose = FALSE, |
|
234 |
row = TRUE, |
|
235 |
have_col_fnotes = FALSE) { |
|
236 |
# FALSE output from this function means that another guess is taken till success or failure
|
|
237 | 628x |
rw <- pagdf[guess, ] |
238 | ||
239 | 628x |
if (verbose) { |
240 | 382x |
message( |
241 | 382x |
"-> Attempting pagination between ", start, " and ", guess, " ", |
242 | 382x |
paste(ifelse(row, "row", "column")) |
243 |
)
|
|
244 |
}
|
|
245 | ||
246 |
# Fix for counting the right number of lines when there is wrapping on a keycols
|
|
247 | 628x |
if (.is_listing_mf(pagdf) && !is.null(pagdf$self_extent_page_break)) { |
248 | 28x |
pagdf$self_extent[start] <- pagdf$self_extent_page_break[start] |
249 |
}
|
|
250 | ||
251 | 628x |
raw_rowlines <- sum(pagdf[start:guess, "self_extent"] - pagdf[start:guess, "nreflines"]) |
252 | ||
253 | 628x |
refdf_ii <- calc_ref_nlines_df(pagdf[start:guess, ]) |
254 | 628x |
reflines <- if (row) sum(refdf_ii$nlines, 0L) else 0L |
255 | 628x |
if (reflines > 0 && !have_col_fnotes) { |
256 | 32x |
reflines <- reflines + div_height + 1L |
257 |
}
|
|
258 | ||
259 |
## reflines <- sum(pagdf[start:guess, "nreflines"])
|
|
260 | 628x |
rowlines <- raw_rowlines + reflines ## sum(pagdf[start:guess, "self_extent"]) - reflines |
261 |
## self extent includes reflines
|
|
262 |
## self extent does ***not*** currently include trailing sep
|
|
263 |
## we don't include the trailing_sep for guess because if we paginate here it won't be printed
|
|
264 | 628x |
sectlines <- if (start == guess) 0L else sum(!is.na(pagdf[start:(guess - 1), "trailing_sep"])) |
265 | 628x |
lines <- rowlines + sectlines # guess - start + 1 because inclusive of start |
266 | 628x |
rep_ext <- pagdf$par_extent[start] |
267 | 628x |
if (lines > rlpp) { |
268 | 382x |
if (verbose) { |
269 | 254x |
structtype <- ifelse(row, "rows", "columns") |
270 | 254x |
structtype_abr <- ifelse(row, "rows", "cols") |
271 | 254x |
spacetype <- ifelse(row, "lines", "chars") |
272 | 254x |
spacetype_abr <- ifelse(row, "lns", "chrs") |
273 | 254x |
msg <- build_fail_msg( |
274 | 254x |
row, lines, raw_rowlines, |
275 | 254x |
allowed_lines = rlpp, lpp = lpp, decoration_lines = context_lpp, |
276 | 254x |
start, guess, rep_ext, length(pagdf$reprint_inds[[start]]), |
277 | 254x |
reflines, NROW(refdf_ii), sectlines |
278 |
)
|
|
279 | 254x |
message(msg) |
280 |
}
|
|
281 | 382x |
return(FALSE) |
282 |
}
|
|
283 | ||
284 |
# Special cases: is it a label or content row?
|
|
285 | 246x |
if (rw[["node_class"]] %in% c("LabelRow", "ContentRow")) { |
286 |
# check if it has children; if no children then valid
|
|
287 | 7x |
has_children <- rw$abs_rownumber %in% unlist(pagdf$reprint_inds) |
288 | 7x |
if (rw$abs_rownumber == nrow(pagdf)) { |
289 | 1x |
if (verbose) { |
290 | 1x |
message(" EXCEPTION: last row is a label or content row but in lpp") |
291 |
}
|
|
292 | 6x |
} else if (!any(has_children)) { |
293 | 6x |
if (verbose) { |
294 | 6x |
message( |
295 | 6x |
" EXCEPTION: last row is a label or content row\n",
|
296 | 6x |
"but does not have rows and row groups depending on it"
|
297 |
)
|
|
298 |
}
|
|
299 |
} else { |
|
300 | ! |
if (verbose) { |
301 | ! |
message(" FAIL: last row is a label or content row") |
302 |
}
|
|
303 | ! |
return(FALSE) |
304 |
}
|
|
305 |
}
|
|
306 | ||
307 |
# Siblings handling
|
|
308 | 246x |
sibpos <- rw[["pos_in_siblings"]] |
309 | 246x |
nsib <- rw[["n_siblings"]] |
310 |
# okpos <- min(min_sibs + 1, rw[["n_siblings"]])
|
|
311 | 246x |
if (sibpos != nsib) { |
312 | 99x |
retfalse <- FALSE |
313 | 99x |
if (sibpos < min_sibs + 1) { |
314 | 25x |
retfalse <- TRUE |
315 | 25x |
if (verbose) { |
316 | 25x |
message( |
317 | 25x |
" FAIL: last row had only ", sibpos - 1, |
318 | 25x |
" preceding siblings, needed ", min_sibs |
319 |
)
|
|
320 |
}
|
|
321 | 74x |
} else if (nsib - sibpos < min_sibs + 1) { |
322 | 7x |
retfalse <- TRUE |
323 | 7x |
if (verbose) { |
324 | 4x |
message( |
325 | 4x |
" FAIL: last row had only ", nsib - sibpos - 1, |
326 | 4x |
" following siblings, needed ", min_sibs |
327 |
)
|
|
328 |
}
|
|
329 |
}
|
|
330 | 99x |
if (retfalse) { |
331 | 32x |
return(FALSE) |
332 |
}
|
|
333 |
}
|
|
334 | 214x |
if (guess < nrow(pagdf) && length(nosplit > 0)) { |
335 |
## paths end at the leaf name which is *always* different
|
|
336 | 16x |
curpth <- head(unlist(rw$path), -1) |
337 | 16x |
nxtpth <- head(unlist(pagdf$path[[guess + 1]]), -1) |
338 | ||
339 | 16x |
inplay <- nosplit[(nosplit %in% intersect(curpth, nxtpth))] |
340 | 16x |
if (length(inplay) > 0) { |
341 | 16x |
ok_split <- vapply(inplay, function(var) { |
342 | 16x |
!identical(curpth[match(var, curpth) + 1], nxtpth[match(var, nxtpth) + 1]) |
343 | 16x |
}, TRUE) |
344 | ||
345 | 16x |
curvals <- curpth[match(inplay, curpth) + 1] |
346 | 16x |
nxtvals <- nxtpth[match(inplay, nxtpth) + 1] |
347 | 16x |
if (!all(ok_split)) { |
348 | 16x |
if (verbose) { |
349 | 16x |
message( |
350 | 16x |
" FAIL: nosplit variable [",
|
351 | 16x |
inplay[min(which(!ok_split))], "] would be constant [", |
352 | 16x |
curvals, "] across this pagebreak." |
353 |
)
|
|
354 |
}
|
|
355 | 16x |
return(FALSE) |
356 |
}
|
|
357 |
}
|
|
358 |
}
|
|
359 | ||
360 |
# Usual output when found
|
|
361 | 198x |
if (verbose) { |
362 | 83x |
message(" OK [", lines + rep_ext, if (row) " lines]" else " chars]") |
363 |
}
|
|
364 | 198x |
TRUE
|
365 |
}
|
|
366 | ||
367 |
find_pag <- function(pagdf, |
|
368 |
current_page,
|
|
369 |
start,
|
|
370 |
guess,
|
|
371 |
rlpp,
|
|
372 |
lpp_or_cpp,
|
|
373 |
context_lpp_or_cpp,
|
|
374 |
min_siblings,
|
|
375 |
nosplitin = character(), |
|
376 |
verbose = FALSE, |
|
377 |
row = TRUE, |
|
378 |
have_col_fnotes = FALSE, |
|
379 |
div_height = 1L, |
|
380 |
do_error = FALSE) { |
|
381 | 204x |
if (verbose) { |
382 | 89x |
if (row) { |
383 | 44x |
message("--------- ROW-WISE: Checking possible pagination for page ", current_page) |
384 |
} else { |
|
385 | 45x |
message("========= COLUMN-WISE: Checking possible pagination for page ", current_page) |
386 |
}
|
|
387 |
}
|
|
388 | ||
389 | 204x |
origuess <- guess |
390 | 204x |
while (guess >= start && !valid_pag( |
391 | 204x |
pagdf, guess, |
392 | 204x |
start = start, |
393 | 204x |
rlpp = rlpp, lpp = lpp_or_cpp, context_lpp = context_lpp_or_cpp, # only lpp goes to row pagination |
394 | 204x |
min_sibs = min_siblings, |
395 | 204x |
nosplit = nosplitin, verbose, row = row, |
396 | 204x |
have_col_fnotes = have_col_fnotes, |
397 | 204x |
div_height = div_height |
398 |
)) { |
|
399 | 430x |
guess <- guess - 1 |
400 |
}
|
|
401 | 204x |
if (guess < start) { |
402 |
# Repeat pagination process to see what went wrong with verbose on
|
|
403 | 6x |
if (isFALSE(do_error) && isFALSE(verbose)) { |
404 | ! |
find_pag( |
405 | ! |
pagdf = pagdf, |
406 | ! |
current_page = current_page, |
407 | ! |
start = start, |
408 | ! |
guess = origuess, |
409 | ! |
rlpp = rlpp, lpp_or_cpp = lpp_or_cpp, context_lpp_or_cpp = context_lpp_or_cpp, |
410 | ! |
min_siblings = min_siblings, |
411 | ! |
nosplitin = nosplitin, |
412 | ! |
verbose = TRUE, |
413 | ! |
row = row, |
414 | ! |
have_col_fnotes = have_col_fnotes, |
415 | ! |
div_height = div_height, |
416 | ! |
do_error = TRUE # only used to avoid loop |
417 |
)
|
|
418 |
}
|
|
419 | 6x |
stop( |
420 | 6x |
"-------------------------------------- Error Summary ----------------------------------------\n",
|
421 | 6x |
"Unable to find any valid pagination split for page ", current_page, " between ", |
422 | 6x |
ifelse(row, "rows ", "columns "), start, " and ", origuess, ". \n", |
423 | 6x |
"Inserted ", ifelse(row, "lpp (row-space, lines per page) ", "cpp (column-space, content per page) "), |
424 | 6x |
": ", lpp_or_cpp, "\n", |
425 | 6x |
"Context-relevant additional ", ifelse(row, "header/footers lines", "fixed column characters"), |
426 | 6x |
": ", context_lpp_or_cpp, "\n", |
427 | 6x |
ifelse(row, |
428 | 6x |
paste("Limit of allowed row lines per page:", rlpp, "\n"), |
429 | 6x |
paste("Check the minimum allowed column characters per page in the last FAIL(ed) attempt. \n") |
430 |
),
|
|
431 | 6x |
"Note: take a look at the last FAIL(ed) attempt above to see what went wrong. It could be, for example, ",
|
432 | 6x |
"that the inserted column width induces some wrapping, hence the inserted number of lines (lpp) is not enough."
|
433 |
)
|
|
434 |
}
|
|
435 | 198x |
guess
|
436 |
}
|
|
437 | ||
438 |
#' Find pagination indices from pagination info data frame
|
|
439 |
#'
|
|
440 |
#' Pagination methods should typically call the `make_row_df` method
|
|
441 |
#' for their object and then call this function on the resulting
|
|
442 |
#' pagination info `data.frame`.
|
|
443 |
#'
|
|
444 |
#' @param pagdf (`data.frame`)\cr a pagination info `data.frame` as created by
|
|
445 |
#' either `make_rows_df` or `make_cols_df`.
|
|
446 |
#' @param rlpp (`numeric`)\cr maximum number of *row* lines per page (not including header materials), including
|
|
447 |
#' (re)printed header and context rows.
|
|
448 |
#' @param lpp_or_cpp (`numeric`)\cr total maximum number of *row* lines or content (column-wise characters) per page
|
|
449 |
#' (including header materials and context rows). This is only for informative results with `verbose = TRUE`.
|
|
450 |
#' It will print `NA` if not specified by the pagination machinery.
|
|
451 |
#' @param context_lpp_or_cpp (`numeric`)\cr total number of context *row* lines or content (column-wise characters)
|
|
452 |
#' per page (including header materials). Uses `NA` if not specified by the pagination machinery and is only
|
|
453 |
#' for informative results with `verbose = TRUE`.
|
|
454 |
#' @param min_siblings (`numeric`)\cr minimum sibling rows which must appear on either side of pagination row for a
|
|
455 |
#' mid-subtable split to be valid. Defaults to 2 for tables. It is automatically turned off (set to 0) for listings.
|
|
456 |
#' @param nosplitin (`character`)\cr list of names of subtables where page breaks are not allowed, regardless of other
|
|
457 |
#' considerations. Defaults to none.
|
|
458 |
#' @param verbose (`flag`)\cr whether additional informative messages about the search for
|
|
459 |
#' pagination breaks should be shown. Defaults to `FALSE`.
|
|
460 |
#' @param row (`flag`)\cr whether pagination is happening in row space (`TRUE`, the default) or column
|
|
461 |
#' space (`FALSE`).
|
|
462 |
#' @param have_col_fnotes (`flag`)\cr whether the table-like object being rendered has column-associated
|
|
463 |
#' referential footnotes.
|
|
464 |
#' @param div_height (`numeric(1)`)\cr the height of the divider line when the associated object is rendered.
|
|
465 |
#' Defaults to `1`.
|
|
466 |
#'
|
|
467 |
#' @details `pab_indices_inner` implements the core pagination algorithm (see below)
|
|
468 |
#' for a single direction (vertical if `row = TRUE` (the default), horizontal otherwise)
|
|
469 |
#' based on the pagination data frame and (already adjusted for non-body rows/columns)
|
|
470 |
#' lines (or characters) per page.
|
|
471 |
#'
|
|
472 |
#' @inheritSection pagination_algo Pagination Algorithm
|
|
473 |
#'
|
|
474 |
#' @return A `list` containing a vector of row numbers, broken up by page.
|
|
475 |
#'
|
|
476 |
#' @examples
|
|
477 |
#' mypgdf <- basic_pagdf(row.names(mtcars))
|
|
478 |
#'
|
|
479 |
#' paginds <- pag_indices_inner(mypgdf, rlpp = 15, min_siblings = 0)
|
|
480 |
#' lapply(paginds, function(x) mtcars[x, ])
|
|
481 |
#'
|
|
482 |
#' @export
|
|
483 |
pag_indices_inner <- function(pagdf, |
|
484 |
rlpp,
|
|
485 |
lpp_or_cpp = NA_integer_, context_lpp_or_cpp = NA_integer_, # Context number of lines |
|
486 |
min_siblings,
|
|
487 |
nosplitin = character(), |
|
488 |
verbose = FALSE, |
|
489 |
row = TRUE, |
|
490 |
have_col_fnotes = FALSE, |
|
491 |
div_height = 1L) { |
|
492 | 95x |
start <- 1 |
493 | 95x |
current_page <- 1 |
494 | 95x |
nr <- nrow(pagdf) |
495 | 95x |
ret <- list() |
496 | 95x |
while (start <= nr) { |
497 | 205x |
adjrlpp <- rlpp - pagdf$par_extent[start] |
498 | 205x |
if (adjrlpp <= 0) { |
499 | 1x |
if (row) { |
500 | 1x |
stop("Lines of repeated context (plus header materials) larger than specified lines per page") |
501 |
} else { |
|
502 | ! |
stop("Width of row labels equal to or larger than specified characters per page.") |
503 |
}
|
|
504 |
}
|
|
505 | 204x |
guess <- min(nr, start + adjrlpp - 1) |
506 | 204x |
end <- find_pag( |
507 | 204x |
pagdf = pagdf, |
508 | 204x |
current_page = current_page, start = start, guess = guess, |
509 | 204x |
rlpp = adjrlpp, lpp_or_cpp = lpp_or_cpp, context_lpp_or_cpp = context_lpp_or_cpp, |
510 | 204x |
min_siblings = min_siblings, |
511 | 204x |
nosplitin = nosplitin, |
512 | 204x |
verbose = verbose, |
513 | 204x |
row = row, |
514 | 204x |
have_col_fnotes = have_col_fnotes, |
515 | 204x |
div_height = div_height |
516 |
)
|
|
517 | 198x |
ret <- c(ret, list(c( |
518 | 198x |
pagdf$reprint_inds[[start]], |
519 | 198x |
start:end |
520 |
))) |
|
521 | 198x |
start <- end + 1 |
522 | 198x |
current_page <- current_page + 1 |
523 |
}
|
|
524 | 88x |
ret
|
525 |
}
|
|
526 | ||
527 |
#' Find column indices for vertical pagination
|
|
528 |
#'
|
|
529 |
#' @inheritParams pag_indices_inner
|
|
530 |
#' @param obj (`ANY`)\cr object to be paginated. Must have a [matrix_form()] method.
|
|
531 |
#' @param cpp (`numeric(1)`)\cr number of characters per page (width).
|
|
532 |
#' @param colwidths (`numeric`)\cr vector of column widths (in characters) for use in vertical pagination.
|
|
533 |
#' @param rep_cols (`numeric(1)`)\cr number of *columns* (not including row labels) to be repeated on every page.
|
|
534 |
#' Defaults to 0.
|
|
535 |
#'
|
|
536 |
#' @return A `list` partitioning the vector of column indices into subsets for 1 or more horizontally paginated pages.
|
|
537 |
#'
|
|
538 |
#' @examples
|
|
539 |
#' mf <- basic_matrix_form(df = mtcars)
|
|
540 |
#' colpaginds <- vert_pag_indices(mf)
|
|
541 |
#' lapply(colpaginds, function(j) mtcars[, j, drop = FALSE])
|
|
542 |
#'
|
|
543 |
#' @export
|
|
544 |
vert_pag_indices <- function(obj, cpp = 40, colwidths = NULL, verbose = FALSE, rep_cols = 0L) { |
|
545 | 45x |
mf <- matrix_form(obj, TRUE) |
546 | 45x |
clwds <- colwidths %||% propose_column_widths(mf) |
547 | 45x |
if (is.null(mf_cinfo(mf))) { ## like always, ugh. |
548 | 2x |
mf <- mpf_infer_cinfo(mf, colwidths = clwds, rep_cols = rep_cols) |
549 |
}
|
|
550 | ||
551 | 45x |
has_rlabs <- mf_has_rlabels(mf) |
552 | 45x |
rlabs_flag <- as.integer(has_rlabs) |
553 | 45x |
rlab_extent <- if (has_rlabs) clwds[1] else 0L |
554 | ||
555 |
# rep_extent <- pdf$par_extent[nrow(pdf)]
|
|
556 | 45x |
rcpp <- cpp - table_inset(mf) - rlab_extent # rep_extent - table_inset(mf) - rlab_extent |
557 | 45x |
if (verbose) { |
558 | 14x |
message( |
559 | 14x |
"Adjusted characters per page: ", rcpp, |
560 | 14x |
" [original: ", cpp, |
561 | 14x |
", table inset: ", table_inset(mf), if (has_rlabs) paste0(", row labels: ", clwds[1]), |
562 |
"]"
|
|
563 |
)
|
|
564 |
}
|
|
565 | 45x |
res <- pag_indices_inner(mf_cinfo(mf), |
566 | 45x |
rlpp = rcpp, lpp_or_cpp = cpp, context_lpp_or_cpp = cpp - rcpp, |
567 |
# cpp - sum(clwds[seq_len(rep_cols)]),
|
|
568 | 45x |
verbose = verbose, |
569 | 45x |
min_siblings = 1, |
570 | 45x |
row = FALSE |
571 |
)
|
|
572 | 44x |
res
|
573 |
}
|
|
574 | ||
575 |
mpf_infer_cinfo <- function(mf, colwidths = NULL, rep_cols = num_rep_cols(mf)) { |
|
576 | 104x |
if (!is(rep_cols, "numeric") || is.na(rep_cols) || rep_cols < 0) { |
577 | ! |
stop("got invalid number of columns to be repeated: ", rep_cols) |
578 |
}
|
|
579 | 104x |
clwds <- (colwidths %||% mf_col_widths(mf)) %||% propose_column_widths(mf) |
580 | 104x |
has_rlabs <- mf_has_rlabels(mf) |
581 | 104x |
rlabs_flag <- as.integer(has_rlabs) |
582 | 104x |
rlab_extent <- if (has_rlabs) clwds[1] else 0L |
583 | 104x |
sqstart <- rlabs_flag + 1L # rep_cols + 1L |
584 | ||
585 | 104x |
pdfrows <- lapply( |
586 | 104x |
(sqstart):ncol(mf$strings), |
587 | 104x |
function(i) { |
588 | 1068x |
rownum <- i - rlabs_flag |
589 | 1068x |
rep_inds <- seq_len(rep_cols)[seq_len(rep_cols) < rownum] |
590 | 1068x |
rep_extent_i <- sum(0L, clwds[rlabs_flag + rep_inds]) + mf$col_gap * length(rep_inds) |
591 | 1068x |
pagdfrow( |
592 | 1068x |
row = NA, |
593 | 1068x |
nm = rownum, |
594 | 1068x |
lab = rownum, |
595 | 1068x |
rnum = rownum, |
596 | 1068x |
pth = NA, |
597 | 1068x |
extent = clwds[i] + mf$col_gap, |
598 | 1068x |
repext = rep_extent_i, # sum(clwds[rep_cols]) + mf$col_gap * max(0, (length(rep_cols) - 1)), |
599 | 1068x |
repind = rep_inds, # rep_cols, |
600 | 1068x |
rclass = "stuff", |
601 | 1068x |
sibpos = 1 - 1, |
602 | 1068x |
nsibs = 1 - 1 |
603 |
)
|
|
604 |
}
|
|
605 |
)
|
|
606 | 104x |
pdf <- do.call(rbind, pdfrows) |
607 | ||
608 | 104x |
refdf <- mf_fnote_df(mf) |
609 | 104x |
pdf <- splice_fnote_info_in(pdf, refdf, row = FALSE) |
610 | 104x |
mf_cinfo(mf) <- pdf |
611 | 104x |
mf
|
612 |
}
|
|
613 | ||
614 |
#' Basic/spoof pagination info data frame
|
|
615 |
#'
|
|
616 |
#' Returns a minimal pagination info `data.frame` (with no info on siblings, footnotes, etc.).
|
|
617 |
#'
|
|
618 |
#' @inheritParams test_matrix_form
|
|
619 |
#' @param rnames (`character`)\cr vector of row names.
|
|
620 |
#' @param labs (`character`)\cr vector of row labels. Defaults to `rnames`.
|
|
621 |
#' @param rnums (`integer`)\cr vector of row numbers. Defaults to `seq_along(rnames)`.
|
|
622 |
#' @param extents (`integer`)\cr number of lines each row requires to print. Defaults to 1 for all rows.
|
|
623 |
#' @param rclass (`character`)\cr class(es) for the rows. Defaults to `"DataRow"`.
|
|
624 |
#' @param paths (`list`)\cr list of paths to the rows. Defaults to `lapply(rnames, function(x) c(parent_path, x))`.
|
|
625 |
#'
|
|
626 |
#' @return A `data.frame` suitable for use in both the `MatrixPrintForm` constructor and the pagination machinery.
|
|
627 |
#'
|
|
628 |
#' @examples
|
|
629 |
#' basic_pagdf(c("hi", "there"))
|
|
630 |
#'
|
|
631 |
#' @export
|
|
632 |
basic_pagdf <- function(rnames, |
|
633 |
labs = rnames, |
|
634 |
rnums = seq_along(rnames), |
|
635 |
extents = 1L, |
|
636 |
rclass = "DataRow", |
|
637 |
parent_path = NULL, |
|
638 |
paths = lapply(rnames, function(x) c(parent_path, x))) { |
|
639 | 49x |
rws <- mapply(pagdfrow, |
640 | 49x |
nm = rnames, lab = labs, extent = extents, |
641 | 49x |
rclass = rclass, rnum = rnums, pth = paths, |
642 | 49x |
SIMPLIFY = FALSE, nsibs = 1, sibpos = 1 |
643 |
)
|
|
644 | 49x |
res <- do.call(rbind.data.frame, rws) |
645 | 49x |
res$n_siblings <- nrow(res) |
646 | 49x |
res$pos_in_siblings <- seq_along(res$n_siblings) |
647 | ||
648 | 49x |
if (!all(rclass == "DataRow")) { |
649 |
# These things are used in the simple case of a split, hence having labels.
|
|
650 |
# To improve and extend to other cases
|
|
651 | 4x |
res$pos_in_siblings <- NA |
652 | 4x |
res$pos_in_siblings[rclass == "DataRow"] <- 1 |
653 | 4x |
res$par_extent[rclass == "DataRow"] <- 1 # the rest is 0 |
654 | 4x |
res$n_siblings <- res$pos_in_siblings |
655 | 4x |
res$reprint_inds[which(rclass == "DataRow")] <- res$abs_rownumber[which(rclass == "DataRow") - 1] |
656 |
}
|
|
657 | 49x |
res
|
658 |
}
|
|
659 | ||
660 |
## write paginate() which operates **solely** on a MatrixPrintForm obj
|
|
661 | ||
662 |
page_size_spec <- function(lpp, cpp, max_width) { |
|
663 | 50x |
structure(list( |
664 | 50x |
lpp = lpp, |
665 | 50x |
cpp = cpp, |
666 | 50x |
max_width = max_width |
667 | 50x |
), class = "page_size_spec") |
668 |
}
|
|
669 | ||
670 | 100x |
non_null_na <- function(x) !is.null(x) && is.na(x) |
671 | ||
672 |
calc_lcpp <- function(page_type = NULL, |
|
673 |
landscape = FALSE, |
|
674 |
pg_width = page_dim(page_type)[if (landscape) 2 else 1], |
|
675 |
pg_height = page_dim(page_type)[if (landscape) 1 else 2], |
|
676 |
font_family = "Courier", |
|
677 |
font_size = 8, # grid parameters |
|
678 |
cpp = NA_integer_, |
|
679 |
lpp = NA_integer_, |
|
680 |
tf_wrap = TRUE, |
|
681 |
max_width = NULL, |
|
682 |
lineheight = 1, |
|
683 |
margins = c(bottom = .5, left = .75, top = .5, right = .75), |
|
684 |
colwidths,
|
|
685 |
col_gap,
|
|
686 |
inset) { |
|
687 | 50x |
pg_lcpp <- page_lcpp( |
688 | 50x |
page_type = page_type, |
689 | 50x |
landscape = landscape, |
690 | 50x |
font_family = font_family, |
691 | 50x |
font_size = font_size, |
692 | 50x |
lineheight = lineheight, |
693 | 50x |
margins = margins, |
694 | 50x |
pg_width = pg_width, |
695 | 50x |
pg_height = pg_height |
696 |
)
|
|
697 | ||
698 | 50x |
if (non_null_na(lpp)) { |
699 | 29x |
lpp <- pg_lcpp$lpp |
700 |
}
|
|
701 | 50x |
if (non_null_na(cpp)) { |
702 | 22x |
cpp <- pg_lcpp$cpp |
703 |
}
|
|
704 | 50x |
stopifnot(!is.na(cpp)) |
705 | ||
706 | 50x |
max_width <- .handle_max_width(tf_wrap, max_width, cpp, colwidths, col_gap, inset) |
707 | ||
708 | 50x |
page_size_spec(lpp = lpp, cpp = cpp, max_width = max_width) |
709 |
}
|
|
710 | ||
711 |
calc_rlpp <- function(pg_size_spec, mf, colwidths, tf_wrap, verbose) { |
|
712 | 48x |
lpp <- pg_size_spec$lpp |
713 | 48x |
max_width <- pg_size_spec$max_width |
714 | ||
715 | 48x |
dh <- divider_height(mf) |
716 | 48x |
if (any(nzchar(all_titles(mf)))) { |
717 |
## +1 is for blank line between subtitles and divider
|
|
718 |
## dh is for divider line **between subtitles and column labels**
|
|
719 |
## other divider line is accounted for in cinfo_lines
|
|
720 | 24x |
if (!tf_wrap) { |
721 | 12x |
tlines <- length(all_titles(mf)) |
722 |
} else { |
|
723 | 12x |
tlines <- sum(nlines(all_titles(mf), colwidths = colwidths, max_width = max_width)) |
724 |
}
|
|
725 | 24x |
tlines <- tlines + dh + 1L |
726 |
} else { |
|
727 | 24x |
tlines <- 0 |
728 |
}
|
|
729 | ||
730 |
## dh for divider line between column labels and table body
|
|
731 | 48x |
cinfo_lines <- mf_nlheader(mf) + dh |
732 | ||
733 | 48x |
if (verbose) { |
734 | 17x |
message( |
735 | 17x |
"Determining lines required for header content: ",
|
736 | 17x |
tlines, " title and ", cinfo_lines, " table header lines" |
737 |
)
|
|
738 |
}
|
|
739 | ||
740 | 48x |
refdf <- mf_fnote_df(mf) |
741 | 48x |
cfn_df <- refdf[is.na(refdf$row) & !is.na(refdf$col), ] |
742 | ||
743 | 48x |
flines <- 0L |
744 | 48x |
mnfoot <- main_footer(mf) |
745 | 48x |
havemn <- length(mnfoot) && any(nzchar(mnfoot)) |
746 | 48x |
if (havemn) { |
747 | 25x |
flines <- nlines( |
748 | 25x |
mnfoot,
|
749 | 25x |
colwidths = colwidths, |
750 | 25x |
max_width = max_width - table_inset(mf) |
751 |
)
|
|
752 |
}
|
|
753 | 48x |
prfoot <- prov_footer(mf) |
754 | 48x |
if (length(prfoot) && any(nzchar(prfoot))) { |
755 | 31x |
flines <- flines + nlines(prov_footer(mf), colwidths = colwidths, max_width = max_width) |
756 | 31x |
if (havemn) { |
757 | 24x |
flines <- flines + 1L |
758 |
} ## space between main and prov footer. |
|
759 |
}
|
|
760 |
## this time its for the divider between the footers and whatever is above them
|
|
761 |
## (either table body or referential footnotes)
|
|
762 | 48x |
if (flines > 0) { |
763 | 32x |
flines <- flines + dh + 1L |
764 |
}
|
|
765 |
## this time its for the divider between the referential footnotes and
|
|
766 |
## the table body IFF we have any, otherwise that divider+blanks pace doesn't get drawn
|
|
767 | 48x |
if (NROW(cfn_df) > 0) { |
768 | ! |
cinfo_lines <- cinfo_lines + sum(cfn_df$nlines) |
769 | ! |
flines <- flines + dh + 1L |
770 |
}
|
|
771 | ||
772 | 48x |
if (verbose) { |
773 | 17x |
message( |
774 | 17x |
"Determining lines required for footer content",
|
775 | 17x |
if (NROW(cfn_df) > 0) " [column fnotes present]", |
776 | 17x |
": ", flines, " lines" |
777 |
)
|
|
778 |
}
|
|
779 | ||
780 | 48x |
ret <- lpp - flines - tlines - cinfo_lines |
781 | ||
782 | 48x |
if (verbose) { |
783 | 17x |
message("Lines per page available for tables rows: ", ret, " (original: ", lpp, ")") |
784 |
}
|
|
785 | 48x |
ret
|
786 |
}
|
|
787 | ||
788 |
calc_rcpp <- function(pg_size_spec, mf, colwidths) { |
|
789 | ! |
cpp <- pg_size_spec$cpp |
790 | ||
791 | ! |
cpp - table_inset(mf) - colwidths[1] - mf_colgap(mf) |
792 |
}
|
|
793 | ||
794 |
splice_idx_lists <- function(lsts) { |
|
795 | ! |
list( |
796 | ! |
pag_row_indices = do.call(c, lapply(lsts, function(xi) xi$pag_row_indices)), |
797 | ! |
pag_col_indices = do.call(c, lapply(lsts, function(yi) yi$pag_col_indices)) |
798 |
)
|
|
799 |
}
|
|
800 | ||
801 |
#' Paginate a table-like object for rendering
|
|
802 |
#'
|
|
803 |
#' These functions perform or diagnose bi-directional pagination on an object.
|
|
804 |
#'
|
|
805 |
#' `paginate_indices` renders `obj` into a `MatrixPrintForm` (MPF), then uses that representation to
|
|
806 |
#' calculate the rows and columns of `obj` corresponding to each page of the pagination of `obj`, but
|
|
807 |
#' simply returns these indices rather than paginating `obj` itself (see Details for an important caveat).
|
|
808 |
#'
|
|
809 |
#' `paginate_to_mpfs` renders `obj` into its MPF intermediate representation, then paginates that MPF into
|
|
810 |
#' component MPFs each corresponding to an individual page and returns those in a `list`.
|
|
811 |
#'
|
|
812 |
#' `diagnose_pagination` attempts pagination via `paginate_to_mpfs`, then returns diagnostic information
|
|
813 |
#' which explains why page breaks were positioned where they were, or alternatively why no valid pagination
|
|
814 |
#' could be found.
|
|
815 |
#'
|
|
816 |
#' @details
|
|
817 |
#' All three of these functions generally support all classes which have a corresponding [matrix_form()]
|
|
818 |
#' method which returns a valid `MatrixPrintForm` object (including `MatrixPrintForm` objects themselves).
|
|
819 |
#'
|
|
820 |
#' `paginate_indices` is directly called by `paginate_to_mpfs` (and thus `diagnose_pagination`). For most
|
|
821 |
#' classes, and most tables represented by supported classes, calling `paginate_to_mpfs` is equivalent to a
|
|
822 |
#' manual `paginate_indices -> subset obj into pages -> matrix_form` workflow.
|
|
823 |
#'
|
|
824 |
#' The exception to this equivalence is objects which support "forced pagination", or pagination logic which
|
|
825 |
#' is built into the object itself rather than being a function of space on a page. Forced pagination
|
|
826 |
#' generally involves the creation of, e.g., page-specific titles which apply to these forced paginations.
|
|
827 |
#' `paginate_to_mpfs` and `diagnose_pagination` support forced pagination by automatically calling the
|
|
828 |
#' [do_forced_paginate()] generic on the object and then paginating each object returned by that generic
|
|
829 |
#' separately. The assumption here, then, is that page-specific titles and such are handled by the class'
|
|
830 |
#' [do_forced_paginate()] method.
|
|
831 |
#'
|
|
832 |
#' `paginate_indices`, on the other hand, *does not support forced pagination*, because it returns only a
|
|
833 |
#' set of indices for row and column subsetting for each page, and thus cannot retain any changes, e.g.,
|
|
834 |
#' to titles, done within [do_forced_paginate()]. `paginate_indices` does call [do_forced_paginate()], but
|
|
835 |
#' instead of continuing it throws an error in the case that the result is larger than a single "page".
|
|
836 |
#'
|
|
837 |
#' @inheritParams vert_pag_indices
|
|
838 |
#' @inheritParams pag_indices_inner
|
|
839 |
#' @inheritParams page_lcpp
|
|
840 |
#' @inheritParams toString
|
|
841 |
#' @inheritParams propose_column_widths
|
|
842 |
#' @param lpp (`numeric(1)` or `NULL`)\cr lines per page. If `NA` (the default), this is calculated automatically
|
|
843 |
#' based on the specified page size). `NULL` indicates no vertical pagination should occur.
|
|
844 |
#' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) per page. If `NA` (the default), this is calculated
|
|
845 |
#' automatically based on the specified page size). `NULL` indicates no horizontal pagination should occur.
|
|
846 |
#' @param pg_size_spec (`page_size_spec`)\cr. a pre-calculated page size specification. Typically this is not set by
|
|
847 |
#' end users.
|
|
848 |
#' @param col_gap (`numeric(1)`)\cr currently ignored.
|
|
849 |
#' @param page_num (`string`)\cr placeholder string for page numbers. See [default_page_number] for more
|
|
850 |
#' information. Defaults to `NULL`.
|
|
851 |
#'
|
|
852 |
#' @return
|
|
853 |
#' * `paginate_indices` returns a `list` with two elements of the same length: `pag_row_indices` and `pag_col_indices`.
|
|
854 |
#' * `paginate_to_mpfs` returns a `list` of `MatrixPrintForm` objects representing each individual page after
|
|
855 |
#' pagination (including forced pagination if necessary).
|
|
856 |
#'
|
|
857 |
#' @examples
|
|
858 |
#' mpf <- basic_matrix_form(mtcars)
|
|
859 |
#'
|
|
860 |
#' paginate_indices(mpf, pg_width = 5, pg_height = 3)
|
|
861 |
#'
|
|
862 |
#' paginate_to_mpfs(mpf, pg_width = 5, pg_height = 3)
|
|
863 |
#'
|
|
864 |
#' @aliases paginate pagination
|
|
865 |
#' @export
|
|
866 |
paginate_indices <- function(obj, |
|
867 |
page_type = "letter", |
|
868 |
font_family = "Courier", |
|
869 |
font_size = 8, |
|
870 |
lineheight = 1, |
|
871 |
landscape = FALSE, |
|
872 |
pg_width = NULL, |
|
873 |
pg_height = NULL, |
|
874 |
margins = c(top = .5, bottom = .5, left = .75, right = .75), |
|
875 |
lpp = NA_integer_, |
|
876 |
cpp = NA_integer_, |
|
877 |
min_siblings = 2, |
|
878 |
nosplitin = character(), |
|
879 |
colwidths = NULL, |
|
880 |
tf_wrap = FALSE, |
|
881 |
max_width = NULL, |
|
882 |
indent_size = 2, |
|
883 |
pg_size_spec = NULL, |
|
884 |
rep_cols = num_rep_cols(obj), |
|
885 |
col_gap = 3, |
|
886 |
verbose = FALSE) { |
|
887 |
## this MUST alsways return a list, inluding list(obj) when
|
|
888 |
## no forced pagination is needed! otherwise stuff breaks for things
|
|
889 |
## based on s3 classes that are lists underneath!!!
|
|
890 | 50x |
fpags <- do_forced_paginate(obj) |
891 | ||
892 |
## if we have more than one forced "page",
|
|
893 |
## paginate each of them individually and return the result.
|
|
894 |
## forced pagination is ***currently*** only vertical, so
|
|
895 |
## we don't have to worry about divying up colwidths here,
|
|
896 |
## but we will if we ever allow force_paginate to do horiz
|
|
897 |
## pagination.
|
|
898 | 50x |
if (length(fpags) > 1) { |
899 | 1x |
stop( |
900 | 1x |
"forced pagination is required for this object (class: ", class(obj)[1], |
901 | 1x |
") this is not supported in paginate_indices. Use paginate_to_mpfs or call ",
|
902 | 1x |
"do_forced_paginate on your object and paginate each returned section separately."
|
903 |
)
|
|
904 |
}
|
|
905 | ||
906 |
## I'm not sure this is worth doing.
|
|
907 |
## ## We can't support forced pagination here, but we can support calls to,
|
|
908 |
## ## e.g., paginate_indices(do_forced_pag(tt))
|
|
909 |
## if(is.list(obj) && !is.object(obj)) {
|
|
910 |
## res <- lapply(obj, paginate_indices,
|
|
911 |
## page_type = page_type,
|
|
912 |
## font_family = font_family,
|
|
913 |
## font_size = font_size,
|
|
914 |
## lineheight = lineheight,
|
|
915 |
## landscape = landscape,
|
|
916 |
## pg_width = pg_width,
|
|
917 |
## pg_height = pg_height,
|
|
918 |
## margins = margins,
|
|
919 |
## lpp = lpp,
|
|
920 |
## cpp = cpp,
|
|
921 |
## tf_wrap = tf_wrap,
|
|
922 |
## max_width = max_width,
|
|
923 |
## colwidths = colwidths,
|
|
924 |
## min_siblings = min_siblings,
|
|
925 |
## nosplitin = nosplitin,
|
|
926 |
## col_gap = col_gap,
|
|
927 |
## ## not setting num_rep_cols here cause it wont' get it right
|
|
928 |
## verbose = verbose)
|
|
929 |
## return(splice_idx_lists(res))
|
|
930 |
## }
|
|
931 |
## order is annoying here, since we won't actually need the mpf if
|
|
932 |
## we run into forced pagination, but life is short and this should work fine.
|
|
933 | 49x |
mpf <- matrix_form(obj, TRUE, TRUE, indent_size = indent_size) |
934 | 49x |
if (is.null(colwidths)) { |
935 | 2x |
colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf) |
936 |
} else { |
|
937 | 47x |
mf_col_widths(mpf) <- colwidths |
938 |
}
|
|
939 | 49x |
if (NROW(mf_cinfo(mpf)) == 0) { |
940 | 49x |
mpf <- mpf_infer_cinfo(mpf, colwidths, rep_cols) |
941 |
}
|
|
942 | ||
943 | 49x |
if (is.null(pg_size_spec)) { |
944 | 2x |
pg_size_spec <- calc_lcpp( |
945 | 2x |
page_type = page_type, |
946 | 2x |
font_family = font_family, |
947 | 2x |
font_size = font_size, |
948 | 2x |
lineheight = lineheight, |
949 | 2x |
landscape = landscape, |
950 | 2x |
pg_width = pg_width, |
951 | 2x |
pg_height = pg_height, |
952 | 2x |
margins = margins, |
953 | 2x |
lpp = lpp, |
954 | 2x |
cpp = cpp, |
955 | 2x |
tf_wrap = tf_wrap, |
956 | 2x |
max_width = max_width, |
957 | 2x |
colwidths = colwidths, |
958 | 2x |
inset = table_inset(mpf), |
959 | 2x |
col_gap = col_gap |
960 |
)
|
|
961 |
}
|
|
962 | ||
963 |
## we can't support forced pagination in paginate_indices because
|
|
964 |
## forced pagination is generally going to set page titles, which
|
|
965 |
## we can't preserve when just returning lists of indices.
|
|
966 |
## Instead we make a hard assumption here that any forced pagination
|
|
967 |
## has already occurred.
|
|
968 | ||
969 |
## this wraps the cell contents AND shoves referential footnote
|
|
970 |
## info mf_rinfo(mpf)
|
|
971 | 49x |
mpf <- do_cell_fnotes_wrap(mpf, colwidths, max_width, tf_wrap = tf_wrap) |
972 | ||
973 |
# rlistings note: if there is a wrapping in a keycol, it is not calculated correctly
|
|
974 |
# in the above call, so we need to keep this information in mf_rinfo
|
|
975 |
# and use it here.
|
|
976 | 49x |
mfri <- mf_rinfo(mpf) |
977 | 49x |
keycols <- .get_keycols_from_listing(obj) |
978 | 49x |
if (NROW(mfri) > 1 && .is_listing_mf(mpf) && length(keycols) > 0) { |
979 |
# Lets determine the groupings created by keycols
|
|
980 | 12x |
keycols_grouping_df <- NULL |
981 | 12x |
for (i in seq_along(keycols)) { |
982 | 24x |
kcol <- keycols[i] |
983 | 24x |
if (is(obj, "MatrixPrintForm")) { |
984 |
# This makes the function work also in the case we have only matrix form (mainly for testing purposes)
|
|
985 | 24x |
kcolvec <- mf_strings(obj)[, mf_strings(obj)[1, , drop = TRUE] == kcol][-1] |
986 | 24x |
while (any(kcolvec == "")) { |
987 | 284x |
kcolvec[which(kcolvec == "")] <- kcolvec[which(kcolvec == "") - 1] |
988 |
}
|
|
989 |
} else { |
|
990 | ! |
kcolvec <- obj[[kcol]] |
991 | ! |
kcolvec <- vapply(kcolvec, format_value, "", format = obj_format(kcolvec), na_str = obj_na_str(kcolvec)) |
992 |
}
|
|
993 | 24x |
groupings <- as.numeric(factor(kcolvec, levels = unique(kcolvec))) |
994 | 24x |
where_they_start <- which(c(1, diff(groupings)) > 0) |
995 | 24x |
keycols_grouping_df <- cbind( |
996 | 24x |
keycols_grouping_df,
|
997 | 24x |
where_they_start[groupings] |
998 | 24x |
) # take the groupings |
999 |
}
|
|
1000 | ||
1001 |
# Creating the real self_extend for mf_rinfo (if the line is chosen for pagination start)
|
|
1002 | 12x |
self_extent_df <- apply(keycols_grouping_df, 2, function(x) mfri$self_extent[x]) |
1003 | 12x |
mf_rinfo(mpf) <- cbind(mfri, "self_extent_page_break" = apply(self_extent_df, 1, max)) |
1004 |
}
|
|
1005 | ||
1006 | 49x |
if (is.null(pg_size_spec$lpp)) { |
1007 | 1x |
pag_row_indices <- list(seq_len(mf_nrow(mpf))) |
1008 |
} else { |
|
1009 | 48x |
rlpp <- calc_rlpp( |
1010 | 48x |
pg_size_spec, mpf, |
1011 | 48x |
colwidths = colwidths, |
1012 | 48x |
tf_wrap = tf_wrap, verbose = verbose |
1013 |
)
|
|
1014 | 48x |
pag_row_indices <- pag_indices_inner( |
1015 | 48x |
pagdf = mf_rinfo(mpf), |
1016 | 48x |
rlpp = rlpp, |
1017 | 48x |
lpp_or_cpp = pg_size_spec$lpp, |
1018 | 48x |
context_lpp_or_cpp = pg_size_spec$lpp - rlpp, |
1019 | 48x |
verbose = verbose, |
1020 | 48x |
min_siblings = min_siblings, |
1021 | 48x |
nosplitin = nosplitin |
1022 |
)
|
|
1023 |
}
|
|
1024 | ||
1025 | 44x |
if (is.null(pg_size_spec$cpp)) { |
1026 | 1x |
pag_col_indices <- list(seq_len(mf_ncol(mpf))) |
1027 |
} else { |
|
1028 | 43x |
pag_col_indices <- vert_pag_indices( |
1029 | 43x |
mpf,
|
1030 | 43x |
cpp = pg_size_spec$cpp, colwidths = colwidths, |
1031 | 43x |
rep_cols = rep_cols, verbose = verbose |
1032 |
)
|
|
1033 |
}
|
|
1034 | ||
1035 | 43x |
list(pag_row_indices = pag_row_indices, pag_col_indices = pag_col_indices) |
1036 |
}
|
|
1037 | ||
1038 | 47x |
setGeneric("has_page_title", function(obj) standardGeneric("has_page_title")) |
1039 | ||
1040 | 47x |
setMethod("has_page_title", "ANY", function(obj) length(page_titles(obj)) > 0) |
1041 | ||
1042 |
#' @rdname paginate_indices
|
|
1043 |
#' @export
|
|
1044 |
paginate_to_mpfs <- function(obj, |
|
1045 |
page_type = "letter", |
|
1046 |
font_family = "Courier", |
|
1047 |
font_size = 8, |
|
1048 |
lineheight = 1, |
|
1049 |
landscape = FALSE, |
|
1050 |
pg_width = NULL, |
|
1051 |
pg_height = NULL, |
|
1052 |
margins = c(top = .5, bottom = .5, left = .75, right = .75), |
|
1053 |
lpp = NA_integer_, |
|
1054 |
cpp = NA_integer_, |
|
1055 |
min_siblings = 2, |
|
1056 |
nosplitin = character(), |
|
1057 |
colwidths = NULL, |
|
1058 |
tf_wrap = FALSE, |
|
1059 |
max_width = NULL, |
|
1060 |
indent_size = 2, |
|
1061 |
pg_size_spec = NULL, |
|
1062 |
page_num = default_page_number(), |
|
1063 |
rep_cols = NULL, |
|
1064 |
col_gap = 2, |
|
1065 |
verbose = FALSE) { |
|
1066 | 57x |
if (isTRUE(page_num)) { |
1067 | 1x |
page_num <- "page {i}/{n}" |
1068 |
}
|
|
1069 | 57x |
checkmate::assert_string(page_num, null.ok = TRUE, min.chars = 1) |
1070 | ||
1071 |
# We can return a list of paginated tables and listings
|
|
1072 | 57x |
if (.is_list_of_tables_or_listings(obj)) { |
1073 | 8x |
cur_call <- match.call(expand.dots = FALSE) |
1074 | 8x |
mpfs <- unlist( |
1075 | 8x |
lapply(obj, function(obj_i) { |
1076 | 15x |
cur_call[["obj"]] <- obj_i |
1077 | 15x |
eval(cur_call, envir = parent.frame(3L)) |
1078 |
}), |
|
1079 | 8x |
recursive = FALSE |
1080 |
)
|
|
1081 | ||
1082 | 7x |
if (!is.null(page_num)) { |
1083 | 3x |
extracted_cpp <- max( |
1084 | 3x |
sapply(mpfs, function(mpf) { |
1085 | 12x |
pf <- prov_footer(mpf) |
1086 | 12x |
nchar(pf[length(pf)]) |
1087 |
}) |
|
1088 |
)
|
|
1089 | 3x |
mpfs <- .modify_footer_for_page_nums(mpfs, page_num, extracted_cpp) |
1090 |
}
|
|
1091 | ||
1092 | 7x |
return(mpfs) |
1093 |
}
|
|
1094 | ||
1095 | 49x |
if (!is.null(page_num)) { |
1096 |
# Only adding a line for pagination -> lpp - 1 would have worked too
|
|
1097 | 14x |
prov_footer(obj) <- c(prov_footer(obj), page_num) |
1098 |
}
|
|
1099 | ||
1100 | 49x |
mpf <- matrix_form(obj, TRUE, TRUE, indent_size = indent_size) |
1101 | ||
1102 |
# Turning off min_siblings for listings
|
|
1103 | 49x |
if (.is_listing_mf(mpf)) { |
1104 | 13x |
min_siblings <- 0 |
1105 |
}
|
|
1106 | ||
1107 |
# Checking colwidths
|
|
1108 | 49x |
if (is.null(colwidths)) { |
1109 | 33x |
colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf) |
1110 |
} else { |
|
1111 | 16x |
cur_ncol <- ncol(mpf) |
1112 | 16x |
if (!.is_listing_mf(mpf)) { |
1113 | 10x |
cur_ncol <- cur_ncol + as.numeric(mf_has_rlabels(mpf)) |
1114 |
}
|
|
1115 | 16x |
if (length(colwidths) != cur_ncol) { |
1116 | 1x |
stop( |
1117 | 1x |
"non-null colwidths argument must have length ncol(x) (+ 1 if row labels are present and if it is a table) [",
|
1118 | 1x |
cur_ncol, "], got length ", length(colwidths) |
1119 |
)
|
|
1120 |
}
|
|
1121 | 15x |
mf_col_widths(mpf) <- colwidths |
1122 |
}
|
|
1123 | ||
1124 |
# For listings, keycols are mandatory rep_num_cols
|
|
1125 | 48x |
if (is.null(rep_cols)) { |
1126 | 45x |
rep_cols <- num_rep_cols(obj) |
1127 |
}
|
|
1128 | ||
1129 | 48x |
if (NROW(mf_cinfo(mpf)) == 0) { |
1130 | 48x |
mpf <- mpf_infer_cinfo(mpf, colwidths, rep_cols) |
1131 |
}
|
|
1132 | ||
1133 | 48x |
if (is.null(pg_size_spec)) { |
1134 | 46x |
pg_size_spec <- calc_lcpp( |
1135 | 46x |
page_type = page_type, |
1136 | 46x |
font_family = font_family, |
1137 | 46x |
font_size = font_size, |
1138 | 46x |
lineheight = lineheight, |
1139 | 46x |
landscape = landscape, |
1140 | 46x |
pg_width = pg_width, |
1141 | 46x |
pg_height = pg_height, |
1142 | 46x |
margins = margins, |
1143 | 46x |
lpp = lpp, |
1144 | 46x |
cpp = cpp, |
1145 | 46x |
tf_wrap = tf_wrap, |
1146 | 46x |
max_width = max_width, |
1147 | 46x |
colwidths = colwidths, |
1148 | 46x |
inset = table_inset(mpf), |
1149 | 46x |
col_gap = col_gap |
1150 |
)
|
|
1151 |
}
|
|
1152 |
## this MUST always return a list, including list(obj) when
|
|
1153 |
## no forced pagination is needed! otherwise stuff breaks for things
|
|
1154 |
## based on s3 classes that are lists underneath!!!
|
|
1155 | 48x |
fpags <- do_forced_paginate(obj) |
1156 | ||
1157 |
## if we have more than one forced "page",
|
|
1158 |
## paginate each of them individually and return the result.
|
|
1159 |
## forced pagination is ***currently*** only vertical, so
|
|
1160 |
## we don't have to worry about divying up colwidths here,
|
|
1161 |
## but we will if we ever allow force_paginate to do horiz
|
|
1162 |
## pagination.
|
|
1163 | 48x |
if (length(fpags) > 1) { |
1164 |
# Correction for case we are entering here (page_by?)
|
|
1165 | 1x |
if (!is.null(page_num)) { |
1166 | ! |
prov_footer(obj) <- head(prov_footer(obj), -1) |
1167 | ! |
fpags <- do_forced_paginate(obj) |
1168 |
}
|
|
1169 | 1x |
deep_pag <- paginate_to_mpfs( # what about the other parameters? |
1170 | 1x |
fpags,
|
1171 | 1x |
pg_size_spec = pg_size_spec, |
1172 | 1x |
colwidths = colwidths, |
1173 | 1x |
min_siblings = min_siblings, |
1174 | 1x |
nosplitin = nosplitin, |
1175 | 1x |
verbose = verbose, |
1176 | 1x |
page_num = page_num |
1177 |
)
|
|
1178 | 1x |
return(deep_pag) |
1179 | 47x |
} else if (has_page_title(fpags[[1]])) { |
1180 | ! |
obj <- fpags[[1]] |
1181 |
}
|
|
1182 | ||
1183 |
## we run into forced pagination, but life is short and this should work fine.
|
|
1184 | 47x |
mpf <- matrix_form(obj, TRUE, TRUE, indent_size = indent_size) |
1185 | 47x |
if (is.null(colwidths)) { |
1186 | ! |
colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf) |
1187 |
}
|
|
1188 | 47x |
mf_col_widths(mpf) <- colwidths |
1189 | ||
1190 | 47x |
page_indices <- paginate_indices( |
1191 | 47x |
obj = obj, |
1192 |
## page_type = page_type,
|
|
1193 |
## font_family = font_family,
|
|
1194 |
## font_size = font_size,
|
|
1195 |
## lineheight = lineheight,
|
|
1196 |
## landscape = landscape,
|
|
1197 |
## pg_width = pg_width,
|
|
1198 |
## pg_height = pg_height,
|
|
1199 |
## margins = margins,
|
|
1200 | 47x |
pg_size_spec = pg_size_spec, |
1201 |
## lpp = lpp,
|
|
1202 |
## cpp = cpp,
|
|
1203 | 47x |
min_siblings = min_siblings, |
1204 | 47x |
nosplitin = nosplitin, |
1205 | 47x |
colwidths = colwidths, |
1206 | 47x |
tf_wrap = tf_wrap, |
1207 |
## max_width = max_width,
|
|
1208 | 47x |
rep_cols = rep_cols, |
1209 | 47x |
verbose = verbose |
1210 |
)
|
|
1211 | ||
1212 | 43x |
pagmats <- lapply(page_indices$pag_row_indices, function(ii) { |
1213 | 89x |
mpf_subset_rows(mpf, ii, keycols = .get_keycols_from_listing(obj)) |
1214 |
}) |
|
1215 |
## these chunks now carry around their (correctly subset) col widths...
|
|
1216 | 43x |
res <- lapply(pagmats, function(matii) { |
1217 | 89x |
lapply(page_indices$pag_col_indices, function(jj) { |
1218 | 220x |
mpf_subset_cols(matii, jj, keycols = .get_keycols_from_listing(obj)) |
1219 |
}) |
|
1220 |
}) |
|
1221 | ||
1222 | 43x |
res <- unlist(res, recursive = FALSE) |
1223 | ||
1224 |
# Adding page numbers if needed
|
|
1225 | 43x |
if (!is.null(page_num)) { |
1226 | 14x |
res <- .modify_footer_for_page_nums( |
1227 | 14x |
mf_list = res, |
1228 | 14x |
page_num_format = page_num, |
1229 | 14x |
current_cpp = pg_size_spec$cpp |
1230 |
)
|
|
1231 |
}
|
|
1232 | ||
1233 | 42x |
res
|
1234 |
}
|
|
1235 | ||
1236 |
.modify_footer_for_page_nums <- function(mf_list, page_num_format, current_cpp) { |
|
1237 | 17x |
total_pages <- length(mf_list) |
1238 | 17x |
page_str <- gsub("\\{n\\}", total_pages, page_num_format) |
1239 | 17x |
page_nums <- vapply( |
1240 | 17x |
seq_len(total_pages), |
1241 | 17x |
function(x) { |
1242 | 135x |
gsub("\\{i\\}", x, page_str) |
1243 |
},
|
|
1244 | 17x |
FUN.VALUE = character(1) |
1245 |
)
|
|
1246 | 17x |
page_footer <- sprintf(paste0("%", current_cpp, "s"), page_nums) |
1247 | 17x |
if (any(nchar(page_footer) > current_cpp)) { |
1248 | 1x |
stop("Page numbering string (page_num) is too wide to fit the desired page size width (cpp).") |
1249 |
}
|
|
1250 | ||
1251 | 16x |
lapply(seq_along(mf_list), function(pg_i) { |
1252 | 69x |
prov_footer(mf_list[[pg_i]]) <- c(head(prov_footer(mf_list[[pg_i]]), -1), page_footer[pg_i]) |
1253 | 69x |
mf_list[[pg_i]] |
1254 |
}) |
|
1255 |
}
|
|
1256 | ||
1257 |
# This works only with matrix_form objects
|
|
1258 |
.is_listing_mf <- function(mf) { |
|
1259 | 1213x |
all(mf_rinfo(mf)$node_class == "listing_df") |
1260 |
}
|
|
1261 | ||
1262 |
# Extended copy of get_keycols
|
|
1263 |
.get_keycols_from_listing <- function(obj) { |
|
1264 | 102x |
if (is(obj, "listing_df")) { |
1265 | ! |
names(which(sapply(obj, is, class2 = "listing_keycol"))) |
1266 | 102x |
} else if (is(obj, "MatrixPrintForm") && .is_listing_mf(obj)) { |
1267 | 66x |
obj$listing_keycols |
1268 |
} else { |
|
1269 | 36x |
NULL # table case |
1270 |
}
|
|
1271 |
}
|
|
1272 | ||
1273 |
#' @importFrom utils capture.output
|
|
1274 |
#' @details
|
|
1275 |
#' `diagnose_pagination` attempts pagination and then, regardless of success or failure, returns diagnostic
|
|
1276 |
#' information about pagination attempts (if any) after each row and column.
|
|
1277 |
#'
|
|
1278 |
#' The diagnostics data reflects the final time the pagination algorithm evaluated a page break at the
|
|
1279 |
#' specified location, regardless of how many times the position was assessed in total.
|
|
1280 |
#'
|
|
1281 |
#' To get information about intermediate attempts, perform pagination with `verbose = TRUE` and inspect
|
|
1282 |
#' the messages in order.
|
|
1283 |
#'
|
|
1284 |
#' @importFrom utils capture.output
|
|
1285 |
#'
|
|
1286 |
#' @return
|
|
1287 |
#' * `diagnose_pagination` returns a `list` containing:
|
|
1288 |
#'
|
|
1289 |
#' \describe{
|
|
1290 |
#' \item{`lpp_diagnostics`}{Diagnostic information regarding lines per page.}
|
|
1291 |
#' \item{`row_diagnostics`}{Basic information about rows, whether pagination was attempted
|
|
1292 |
#' after each row, and the final result of such an attempt, if made.}
|
|
1293 |
#' \item{`cpp_diagnostics`}{Diagnostic information regarding columns per page.}
|
|
1294 |
#' \item{`col_diagnostics`}{Very basic information about leaf columns, whether pagination
|
|
1295 |
#' was attempted after each leaf column, ad the final result of such attempts, if made.}
|
|
1296 |
#' }
|
|
1297 |
#'
|
|
1298 |
#' @note
|
|
1299 |
#' For `diagnose_pagination`, the column labels are not displayed in the `col_diagnostics` element
|
|
1300 |
#' due to certain internal implementation details; rather the diagnostics are reported in terms of
|
|
1301 |
#' absolute (leaf) column position. This is a known limitation, and may eventually be changed, but the
|
|
1302 |
#' information remains useful as it is currently reported.
|
|
1303 |
#'
|
|
1304 |
#' `diagnose_pagination` is intended for interactive debugging use and *should not be programmed against*,
|
|
1305 |
#' as the exact content and form of the verbose messages it captures and returns is subject to change.
|
|
1306 |
#'
|
|
1307 |
#' Because `diagnose_pagination` relies on `capture.output(type = "message")`, it cannot be used within the
|
|
1308 |
#' `testthat` (and likely other) testing frameworks, and likely cannot be used within `knitr`/`rmarkdown`
|
|
1309 |
#' contexts either, as this clashes with those systems' capture of messages.
|
|
1310 |
#'
|
|
1311 |
#' @examples
|
|
1312 |
#' diagnose_pagination(mpf, pg_width = 5, pg_height = 3)
|
|
1313 |
#' clws <- propose_column_widths(mpf)
|
|
1314 |
#' clws[1] <- floor(clws[1] / 3)
|
|
1315 |
#' dgnost <- diagnose_pagination(mpf, pg_width = 5, pg_height = 3, colwidths = clws)
|
|
1316 |
#' try(diagnose_pagination(mpf, pg_width = 1)) # fails
|
|
1317 |
#'
|
|
1318 |
#' @rdname paginate_indices
|
|
1319 |
#' @export
|
|
1320 |
diagnose_pagination <- function(obj, |
|
1321 |
page_type = "letter", |
|
1322 |
font_family = "Courier", |
|
1323 |
font_size = 8, |
|
1324 |
lineheight = 1, |
|
1325 |
landscape = FALSE, |
|
1326 |
pg_width = NULL, |
|
1327 |
pg_height = NULL, |
|
1328 |
margins = c(top = .5, bottom = .5, left = .75, right = .75), |
|
1329 |
lpp = NA_integer_, |
|
1330 |
cpp = NA_integer_, |
|
1331 |
min_siblings = 2, |
|
1332 |
nosplitin = character(), |
|
1333 |
colwidths = propose_column_widths(matrix_form(obj, TRUE)), |
|
1334 |
tf_wrap = FALSE, |
|
1335 |
max_width = NULL, |
|
1336 |
indent_size = 2, |
|
1337 |
pg_size_spec = NULL, |
|
1338 |
rep_cols = num_rep_cols(obj), |
|
1339 |
col_gap = 2, |
|
1340 |
verbose = FALSE, |
|
1341 |
...) { |
|
1342 | 6x |
fpag <- do_forced_paginate(obj) |
1343 | 6x |
if (length(fpag) > 1) { |
1344 | 1x |
return(lapply( |
1345 | 1x |
fpag,
|
1346 | 1x |
diagnose_pagination,
|
1347 | 1x |
page_type = page_type, |
1348 | 1x |
font_family = font_family, |
1349 | 1x |
font_size = font_size, |
1350 | 1x |
lineheight = lineheight, |
1351 | 1x |
landscape = landscape, |
1352 | 1x |
pg_width = pg_width, |
1353 | 1x |
pg_height = pg_height, |
1354 | 1x |
margins = margins, |
1355 | 1x |
lpp = lpp, |
1356 | 1x |
cpp = cpp, |
1357 | 1x |
tf_wrap = tf_wrap, |
1358 | 1x |
max_width = max_width, |
1359 | 1x |
colwidths = colwidths, |
1360 | 1x |
col_gap = col_gap, |
1361 | 1x |
min_siblings = min_siblings, |
1362 | 1x |
nosplitin = nosplitin |
1363 |
)) |
|
1364 |
}
|
|
1365 | ||
1366 | 5x |
mpf <- matrix_form(obj, TRUE) |
1367 | 5x |
msgres <- capture.output( |
1368 |
{
|
|
1369 | 5x |
tmp <- try( |
1370 | 5x |
paginate_to_mpfs( |
1371 | 5x |
obj,
|
1372 | 5x |
page_type = page_type, |
1373 | 5x |
font_family = font_family, |
1374 | 5x |
font_size = font_size, |
1375 | 5x |
lineheight = lineheight, |
1376 | 5x |
landscape = landscape, |
1377 | 5x |
pg_width = pg_width, |
1378 | 5x |
pg_height = pg_height, |
1379 | 5x |
margins = margins, |
1380 | 5x |
lpp = lpp, |
1381 | 5x |
cpp = cpp, |
1382 | 5x |
tf_wrap = tf_wrap, |
1383 | 5x |
max_width = max_width, |
1384 | 5x |
colwidths = colwidths, |
1385 | 5x |
col_gap = col_gap, |
1386 | 5x |
min_siblings = min_siblings, |
1387 | 5x |
nosplitin = nosplitin, |
1388 | 5x |
verbose = TRUE |
1389 |
)
|
|
1390 |
)
|
|
1391 |
},
|
|
1392 | 5x |
type = "message" |
1393 |
)
|
|
1394 | 5x |
if (is(tmp, "try-error") && grepl("Width of row labels equal to or larger", tmp)) { |
1395 | ! |
cond <- attr(tmp, "condition") |
1396 | ! |
stop(conditionMessage(cond), call. = conditionCall(cond)) |
1397 |
}
|
|
1398 | ||
1399 | 5x |
lpp_diagnostic <- grep("^(Determining lines|Lines per page available).*$", msgres, value = TRUE) |
1400 | 5x |
cpp_diagnostic <- unique(grep("^Adjusted characters per page.*$", msgres, value = TRUE)) |
1401 | ||
1402 | 5x |
mpf <- do_cell_fnotes_wrap(mpf, widths = colwidths, max_width = max_width, tf_wrap = tf_wrap) |
1403 | 5x |
mpf <- mpf_infer_cinfo(mpf, colwidths = colwidths) |
1404 | ||
1405 | 5x |
rownls <- grep("Checking pagination after row", msgres, fixed = TRUE) |
1406 | 5x |
rownum <- as.integer(gsub("[^[:digit:]]*(.*)$", "\\1", msgres[rownls])) |
1407 | 5x |
rowmsgs <- vapply(unique(rownum), function(ii) { |
1408 | ! |
idx <- max(which(rownum == ii)) |
1409 | ! |
gsub("\\t[.]*", "", msgres[rownls[idx] + 1]) |
1410 |
}, "") |
|
1411 | ||
1412 | 5x |
msgdf <- data.frame( |
1413 | 5x |
abs_rownumber = unique(rownum), |
1414 | 5x |
final_pag_result = rowmsgs, stringsAsFactors = FALSE |
1415 |
)
|
|
1416 | 5x |
rdf <- mf_rinfo(mpf)[, c("abs_rownumber", "label", "self_extent", "par_extent", "node_class")] |
1417 | 5x |
rdf$pag_attempted <- rdf$abs_rownumber %in% rownum |
1418 | 5x |
row_diagnose <- merge(rdf, msgdf, by = "abs_rownumber", all.x = TRUE) |
1419 | ||
1420 | 5x |
colnls <- grep("Checking pagination after column", msgres, fixed = TRUE) |
1421 | 5x |
colnum <- as.integer(gsub("[^[:digit:]]*(.*)$", "\\1", msgres[colnls])) |
1422 | 5x |
colmsgs <- vapply(unique(colnum), function(ii) { |
1423 | ! |
idx <- max(which(colnum == ii)) |
1424 | ! |
gsub("\\t[.]*", "", msgres[colnls[idx] + 1]) |
1425 |
}, "") |
|
1426 | ||
1427 | 5x |
colmsgdf <- data.frame( |
1428 | 5x |
abs_rownumber = unique(colnum), |
1429 | 5x |
final_pag_result = colmsgs, |
1430 | 5x |
stringsAsFactors = FALSE |
1431 |
)
|
|
1432 | 5x |
cdf <- mf_cinfo(mpf)[, c("abs_rownumber", "self_extent")] |
1433 | 5x |
cdf$pag_attempted <- cdf$abs_rownumber %in% colnum |
1434 | 5x |
col_diagnose <- merge(cdf, colmsgdf, by = "abs_rownumber", all.x = TRUE) |
1435 | 5x |
names(col_diagnose) <- gsub("^abs_rownumber$", "abs_colnumber", names(col_diagnose)) |
1436 | 5x |
list( |
1437 | 5x |
lpp_diagnostics = lpp_diagnostic, |
1438 | 5x |
row_diagnostics = row_diagnose, |
1439 | 5x |
cpp_diagnostics = cpp_diagnostic, |
1440 | 5x |
col_diagnostics = col_diagnose |
1441 |
)
|
|
1442 |
}
|
1 |
.need_pag <- function(page_type, pg_width, pg_height, cpp, lpp) { |
|
2 | ! |
!(is.null(page_type) && is.null(pg_width) && is.null(pg_height) && is.null(cpp) && is.null(lpp)) |
3 |
}
|
|
4 | ||
5 |
#' Export a table-like object to plain (ASCII) text with page breaks
|
|
6 |
#'
|
|
7 |
#' This function converts `x` to a `MatrixPrintForm` object via [matrix_form()], paginates it
|
|
8 |
#' via [paginate_to_mpfs()], converts each page to ASCII text via [toString()], and outputs
|
|
9 |
#' the strings, separated by `page_break`, to `file`.
|
|
10 |
#'
|
|
11 |
#' @inheritParams paginate_indices
|
|
12 |
#' @inheritParams toString
|
|
13 |
#' @inheritParams propose_column_widths
|
|
14 |
#' @param x (`ANY`)\cr a table-like object to export. Must have an applicable `matrix_form` method.
|
|
15 |
#' @param file (`string` or `NULL`)\cr if non-`NULL`, the path to write a text file to
|
|
16 |
#' containing `x` rendered as ASCII text.
|
|
17 |
#' @param page_break (`string`)\cr page break symbol (defaults to `"\\n\\s"`).
|
|
18 |
#' @param paginate (`flag`)\cr whether pagination should be performed. Defaults to `TRUE`
|
|
19 |
#' if page size is specified (including the default).
|
|
20 |
#' @param ... additional parameters passed to [paginate_to_mpfs()].
|
|
21 |
#'
|
|
22 |
#' @details
|
|
23 |
#' If `x` has a `num_rep_cols` method, the value returned by it will be used for `rep_cols` by
|
|
24 |
#' default. Otherwise, 0 will be used.
|
|
25 |
#'
|
|
26 |
#' If `x` has an applicable `do_forced_paginate` method, it will be invoked during the
|
|
27 |
#' pagination process.
|
|
28 |
#'
|
|
29 |
#' @return If `file` is `NULL`, the full paginated and concatenated string value is returned,
|
|
30 |
#' otherwise the output is written to `file` and no value (invisible `NULL`) is returned.
|
|
31 |
#'
|
|
32 |
#' @examples
|
|
33 |
#' export_as_txt(basic_matrix_form(mtcars), pg_height = 5, pg_width = 4)
|
|
34 |
#'
|
|
35 |
#' @export
|
|
36 |
export_as_txt <- function(x, |
|
37 |
file = NULL, |
|
38 |
page_type = NULL, |
|
39 |
landscape = FALSE, |
|
40 |
pg_width = page_dim(page_type)[if (landscape) 2 else 1], |
|
41 |
pg_height = page_dim(page_type)[if (landscape) 1 else 2], |
|
42 |
font_family = "Courier", |
|
43 |
font_size = 8, # grid parameters |
|
44 |
lineheight = 1L, |
|
45 |
margins = c(top = .5, bottom = .5, left = .75, right = .75), |
|
46 |
paginate = TRUE, |
|
47 |
cpp = NA_integer_, |
|
48 |
lpp = NA_integer_, |
|
49 |
...,
|
|
50 |
hsep = NULL, |
|
51 |
indent_size = 2, |
|
52 |
tf_wrap = paginate, |
|
53 |
max_width = NULL, |
|
54 |
colwidths = NULL, |
|
55 |
min_siblings = 2, |
|
56 |
nosplitin = character(), |
|
57 |
rep_cols = NULL, |
|
58 |
verbose = FALSE, |
|
59 |
page_break = "\\s\\n", |
|
60 |
page_num = default_page_number()) { |
|
61 |
# Processing lists of tables or listings
|
|
62 | 15x |
if (.is_list_of_tables_or_listings(x)) { |
63 | 5x |
if (isFALSE(paginate)) { |
64 | 1x |
warning( |
65 | 1x |
"paginate is FALSE, but x is a list of tables or listings, ",
|
66 | 1x |
"so paginate will automatically be updated to TRUE"
|
67 |
)
|
|
68 |
}
|
|
69 | 5x |
paginate <- TRUE |
70 |
}
|
|
71 | ||
72 | 15x |
if (paginate) { |
73 | 15x |
pages <- paginate_to_mpfs( |
74 | 15x |
x,
|
75 | 15x |
page_type = page_type, |
76 | 15x |
font_family = font_family, |
77 | 15x |
font_size = font_size, |
78 | 15x |
lineheight = lineheight, |
79 | 15x |
landscape = landscape, |
80 | 15x |
pg_width = pg_width, |
81 | 15x |
pg_height = pg_height, |
82 | 15x |
margins = margins, |
83 | 15x |
lpp = lpp, |
84 | 15x |
cpp = cpp, |
85 | 15x |
min_siblings = min_siblings, |
86 | 15x |
nosplitin = nosplitin, |
87 | 15x |
colwidths = colwidths, |
88 | 15x |
tf_wrap = tf_wrap, |
89 | 15x |
max_width = max_width, |
90 | 15x |
indent_size = indent_size, |
91 | 15x |
verbose = verbose, |
92 | 15x |
rep_cols = rep_cols, |
93 | 15x |
page_num = page_num |
94 |
)
|
|
95 |
} else { |
|
96 | ! |
mf <- matrix_form(x, TRUE, TRUE, indent_size = indent_size) |
97 | ! |
mf_col_widths(mf) <- colwidths %||% propose_column_widths(mf) |
98 | ! |
pages <- list(mf) |
99 |
}
|
|
100 | ||
101 |
# Needs to be here because of adding cpp if it is not "auto"
|
|
102 | 14x |
if (!is.character(max_width)) { |
103 | 14x |
max_width <- .handle_max_width( |
104 | 14x |
tf_wrap = tf_wrap, |
105 | 14x |
max_width = max_width, |
106 | 14x |
cpp = cpp |
107 |
)
|
|
108 |
}
|
|
109 | ||
110 |
## we don't set widths here because we already put that info in mpf
|
|
111 |
## so its on each of the pages.
|
|
112 | 14x |
strings <- vapply( |
113 | 14x |
pages, toString, "", |
114 | 14x |
widths = NULL, |
115 | 14x |
hsep = hsep, tf_wrap = tf_wrap, max_width = max_width |
116 |
)
|
|
117 | ||
118 | 14x |
res <- paste(strings, collapse = page_break) |
119 | ||
120 | 14x |
if (is.null(file)) { |
121 | 12x |
res
|
122 |
} else { |
|
123 | 2x |
cat(res, file = file) |
124 |
}
|
|
125 |
}
|
|
126 | ||
127 |
.is_list_of_tables_or_listings <- function(a_list) { |
|
128 | 80x |
if (is(a_list, "list")) { |
129 | 80x |
all_matrix_forms <- FALSE |
130 | 80x |
obj_are_tables_or_listings <- FALSE |
131 | ||
132 | 80x |
if (is(a_list[[1]], "MatrixPrintForm")) { |
133 | 15x |
all_matrix_forms <- all(sapply(a_list, is, class2 = "MatrixPrintForm")) |
134 |
} else { |
|
135 | 65x |
obj_are_tables_or_listings <- all( |
136 | 65x |
sapply(a_list, function(list_i) { |
137 | 1430x |
is(list_i, "listing_df") || is(list_i, "VTableTree") |
138 |
}) |
|
139 |
)
|
|
140 |
}
|
|
141 | 80x |
out <- obj_are_tables_or_listings || all_matrix_forms |
142 |
} else { |
|
143 | ! |
out <- FALSE |
144 |
}
|
|
145 | ||
146 | 80x |
out
|
147 |
}
|
|
148 | ||
149 |
# RTF support ------------------------------------------------------------------
|
|
150 | ||
151 |
## In use, must be tested
|
|
152 |
prep_header_line <- function(mf, i) { |
|
153 | 4x |
ret <- mf$strings[i, mf$display[i, , drop = TRUE], drop = TRUE] |
154 | 4x |
ret
|
155 |
}
|
|
156 | ||
157 |
## margin_lines_to_in <- function(margins, font_size, font_family) {
|
|
158 |
## tmpfile <- tempfile(fileext = ".pdf")
|
|
159 |
## gp_plot <- gpar(fontsize = font_size, fontfamily = font_family)
|
|
160 |
## pdf(file = tmpfile, width = 20, height = 20)
|
|
161 |
## on.exit({
|
|
162 |
## dev.off()
|
|
163 |
## file.remove(tmpfile)
|
|
164 |
## })
|
|
165 |
## grid.newpage()
|
|
166 |
## pushViewport(plotViewport(margins = margins, gp = gp_plot))
|
|
167 |
## c(
|
|
168 |
## bottom = convertHeight(unit(margins["bottom"], "lines"), "inches", valueOnly = TRUE),
|
|
169 |
## left = convertWidth(unit(1, "strwidth", strrep("m", margins["left"])), "inches", valueOnly = TRUE),
|
|
170 |
## top = convertHeight(unit(margins["top"], "lines"), "inches", valueOnly = TRUE),
|
|
171 |
## right = convertWidth(unit(1, "strwidth", strrep("m", margins["right"])), "inches", valueOnly = TRUE)
|
|
172 |
## )
|
|
173 |
## }
|
|
174 | ||
175 |
mpf_to_dfbody <- function(mpf, colwidths) { |
|
176 | 4x |
mf <- matrix_form(mpf, indent_rownames = TRUE) |
177 | 4x |
nlr <- mf_nlheader(mf) |
178 | 4x |
if (is.null(colwidths)) { |
179 | ! |
colwidths <- propose_column_widths(mf) |
180 |
}
|
|
181 | 4x |
mf$strings[1:nlr, 1] <- ifelse(nzchar(mf$strings[1:nlr, 1, drop = TRUE]), |
182 | 4x |
mf$strings[1:nlr, 1, drop = TRUE], |
183 | 4x |
strrep(" ", colwidths) |
184 |
)
|
|
185 | ||
186 | ||
187 | 4x |
myfakedf <- as.data.frame(tail(mf$strings, -nlr)) |
188 | 4x |
myfakedf
|
189 |
}
|
|
190 | ||
191 |
#' Transform `MatrixPrintForm` to RTF
|
|
192 |
#'
|
|
193 |
#' Experimental export to rich text format (RTF) via the `r2rtf` package.
|
|
194 |
#'
|
|
195 |
#' @inheritParams page_lcpp
|
|
196 |
#' @inheritParams toString
|
|
197 |
#' @inheritParams grid::plotViewport
|
|
198 |
#' @param mpf (`MatrixPrintForm`)\cr a `MatrixPrintForm` object.
|
|
199 |
#' @param colwidths (`numeric`)\cr column widths.
|
|
200 |
#'
|
|
201 |
#' @details
|
|
202 |
#' This function provides a low-level coercion of a `MatrixPrintForm` object into
|
|
203 |
#' text containing the corresponding table in RTF. Currently, no pagination is done
|
|
204 |
#' at this level, and should be done prior to calling this function, though that
|
|
205 |
#' may change in the future.
|
|
206 |
#'
|
|
207 |
#' @return An RTF object.
|
|
208 |
#'
|
|
209 |
#' @export
|
|
210 |
mpf_to_rtf <- function(mpf, |
|
211 |
colwidths = NULL, |
|
212 |
page_type = "letter", |
|
213 |
pg_width = page_dim(page_type)[if (landscape) 2 else 1], |
|
214 |
pg_height = page_dim(page_type)[if (landscape) 1 else 2], |
|
215 |
landscape = FALSE, |
|
216 |
margins = c(4, 4, 4, 4), |
|
217 |
font_size = 8, |
|
218 |
...) { |
|
219 | 4x |
if (!requireNamespace("r2rtf")) { |
220 | ! |
stop("RTF export requires the 'r2rtf' package, please install it.") |
221 |
}
|
|
222 | 4x |
mpf <- matrix_form(mpf, indent_rownames = TRUE) |
223 | 4x |
nlr <- mf_nlheader(mpf) |
224 | 4x |
if (is.null(colwidths)) { |
225 | ! |
colwidths <- propose_column_widths(mpf) |
226 |
}
|
|
227 | 4x |
mpf$strings[1:nlr, 1] <- ifelse(nzchar(mpf$strings[1:nlr, 1, drop = TRUE]), |
228 | 4x |
mpf$strings[1:nlr, 1, drop = TRUE], |
229 | 4x |
strrep(" ", colwidths) |
230 |
)
|
|
231 | ||
232 | 4x |
myfakedf <- mpf_to_dfbody(mpf, colwidths) |
233 | ||
234 | 4x |
rtfpg <- r2rtf::rtf_page(myfakedf, |
235 | 4x |
width = pg_width, |
236 | 4x |
height = pg_height, |
237 | 4x |
orientation = if (landscape) "landscape" else "portrait", |
238 | 4x |
margin = c(0.1, 0.1, 0.1, 0.1, 0.1, 0.1), |
239 | 4x |
nrow = 10000L |
240 | 4x |
) ## dont allow r2rtf to restrict lines per page beyond actual real eastate |
241 | 4x |
rtfpg <- r2rtf::rtf_title(rtfpg, main_title(mpf), subtitles(mpf), text_font = 1) |
242 | 4x |
for (i in seq_len(nlr)) { |
243 | 4x |
hdrlndat <- prep_header_line(mpf, i) |
244 | 4x |
rtfpg <- r2rtf::rtf_colheader(rtfpg, |
245 | 4x |
paste(hdrlndat, collapse = " | "), |
246 | 4x |
col_rel_width = unlist(tapply(colwidths, |
247 | 4x |
cumsum(mpf$display[i, , drop = TRUE]), |
248 | 4x |
sum,
|
249 | 4x |
simplify = FALSE |
250 |
)), |
|
251 | 4x |
border_top = c("", rep(if (i > 1) "single" else "", length(hdrlndat) - 1)), |
252 | 4x |
text_font = 9, ## this means Courier New for some insane reason |
253 | 4x |
text_font_size = font_size |
254 |
)
|
|
255 |
}
|
|
256 | ||
257 | 4x |
rtfpg <- r2rtf::rtf_body(rtfpg, |
258 | 4x |
col_rel_width = colwidths, |
259 | 4x |
text_justification = c("l", rep("c", ncol(myfakedf) - 1)), |
260 | 4x |
text_format = "", |
261 | 4x |
text_font = 9, |
262 | 4x |
text_font_size = font_size |
263 |
)
|
|
264 | ||
265 | 4x |
for (i in seq_along(mpf$ref_footnotes)) { |
266 | 4x |
rtfpg <- r2rtf::rtf_footnote(rtfpg, |
267 | 4x |
mpf$ref_footnotes[i], |
268 | 4x |
border_top = if (i == 1) "single" else "", |
269 | 4x |
border_bottom = if (i == length(mpf$ref_footnotes)) "single" else "", |
270 | 4x |
text_font = 9 |
271 |
)
|
|
272 |
}
|
|
273 | ||
274 | 4x |
if (length(main_footer(mpf)) > 0) { |
275 | 4x |
rtfpg <- r2rtf::rtf_footnote(rtfpg, main_footer(mpf), text_font = 9) |
276 |
}
|
|
277 | 4x |
if (length(prov_footer(mpf)) > 0) { |
278 | 4x |
rtfpg <- r2rtf::rtf_source(rtfpg, prov_footer(mpf), text_font = 9) |
279 |
}
|
|
280 | ||
281 | 4x |
rtfpg
|
282 |
}
|
|
283 | ||
284 |
## Not currently in use, previous alternate ways to get to RTF
|
|
285 | ||
286 |
## ## XXX Experimental. Not to be exported without approval
|
|
287 |
## mpf_to_huxtable <- function(obj) {
|
|
288 |
## if (!requireNamespace("huxtable")) {
|
|
289 |
## stop("mpf_to_huxtable requires the huxtable package")
|
|
290 |
## }
|
|
291 |
## mf <- matrix_form(obj, indent_rownames = TRUE)
|
|
292 |
## nlr <- mf_nlheader(mf)
|
|
293 |
## myfakedf <- as.data.frame(tail(mf$strings, -nlr))
|
|
294 |
## ret <- huxtable::as_hux(myfakedf, add_colnames = FALSE)
|
|
295 |
## mf$strings[!mf$display] <- ""
|
|
296 |
## for (i in seq_len(nlr)) {
|
|
297 |
## arglist <- c(
|
|
298 |
## list(ht = ret, after = i - 1),
|
|
299 |
## as.list(mf$strings[i, ])
|
|
300 |
## )
|
|
301 |
## ret <- do.call(huxtable::insert_row, arglist)
|
|
302 | ||
303 |
## spanspl <- split(
|
|
304 |
## seq_len(ncol(mf$strings)),
|
|
305 |
## cumsum(mf$display[i, ])
|
|
306 |
## )
|
|
307 | ||
308 |
## for (j in seq_along(spanspl)) {
|
|
309 |
## if (length(spanspl[[j]]) > 1) {
|
|
310 |
## ret <- huxtable::merge_cells(ret, row = i, col = spanspl[[j]])
|
|
311 |
## }
|
|
312 |
## }
|
|
313 |
## }
|
|
314 |
## ret <- huxtable::set_header_rows(ret, seq_len(nlr), TRUE)
|
|
315 |
## huxtable::font(ret) <- "courier"
|
|
316 |
## huxtable::font_size(ret) <- 6
|
|
317 |
## huxtable::align(ret)[
|
|
318 |
## seq_len(nrow(ret)),
|
|
319 |
## seq_len(ncol(ret))
|
|
320 |
## ] <- mf$aligns
|
|
321 |
## ret
|
|
322 |
## }
|
|
323 | ||
324 |
## ## XXX Experimental. Not to be exported without approval
|
|
325 |
## mpf_to_rtf <- function(obj, ..., file) {
|
|
326 |
## huxt <- mpf_to_huxtable(obj)
|
|
327 |
## ## a bunch more stuff here
|
|
328 |
## huxtable::quick_rtf(huxt, ..., file = file)
|
|
329 |
## }
|
|
330 | ||
331 |
## ## XXX Experimental. Not to be exported without approval
|
|
332 |
## mpf_to_gt <- function(obj) {
|
|
333 |
## requireNamespace("gt")
|
|
334 |
## mf <- matrix_form(obj, indent_rownames = TRUE)
|
|
335 |
## nlh <- mf_nlheader(mf)
|
|
336 |
## body_df <- as.data.frame(mf$strings[-1 * seq_len(nlh), ])
|
|
337 |
## varnamerow <- mf_nrheader(mf)
|
|
338 |
## ## detect if we have counts
|
|
339 |
## if (any(nzchar(mf$formats[seq_len(nlh), ]))) {
|
|
340 |
## varnamerow <- varnamerow - 1
|
|
341 |
## }
|
|
342 | ||
343 |
## rlbl_lst <- as.list(mf$strings[nlh, , drop = TRUE])
|
|
344 |
## names(rlbl_lst) <- names(body_df)
|
|
345 | ||
346 |
## ret <- gt::gt(body_df, rowname_col = "V1")
|
|
347 |
## ret <- gt::cols_label(ret, .list = rlbl_lst)
|
|
348 |
## if (nlh > 1) {
|
|
349 |
## for (i in 1:(nlh - 1)) {
|
|
350 |
## linedat <- mf$strings[i, , drop = TRUE]
|
|
351 |
## splvec <- cumsum(mf$display[i, , drop = TRUE])
|
|
352 |
## spl <- split(seq_along(linedat), splvec)
|
|
353 |
## for (j in seq_along(spl)) {
|
|
354 |
## vns <- names(body_df)[spl[[j]]]
|
|
355 |
## labval <- linedat[spl[[j]][1]]
|
|
356 |
## ret <- gt::tab_spanner(ret,
|
|
357 |
## label = labval,
|
|
358 |
## columns = {{ vns }},
|
|
359 |
## level = nlh - i,
|
|
360 |
## id = paste0(labval, j)
|
|
361 |
## )
|
|
362 |
## }
|
|
363 |
## }
|
|
364 |
## }
|
|
365 | ||
366 |
## ret <- gt::opt_css(ret, css = "th.gt_left { white-space:pre;}")
|
|
367 | ||
368 |
## ret
|
|
369 |
## }
|
|
370 | ||
371 |
#' Export as RTF
|
|
372 |
#'
|
|
373 |
#' Experimental export to the rich text format (RTF) format.
|
|
374 |
#'
|
|
375 |
#' @details RTF export occurs via the following steps:
|
|
376 |
#' * The table is paginated to the specified page size (vertically and horizontally).
|
|
377 |
#' * Each separate page is converted to a `MatrixPrintForm` object and then to
|
|
378 |
#' RTF-encoded text.
|
|
379 |
#' * Separate RTF text chunks are combined and written to a single RTF file.
|
|
380 |
#'
|
|
381 |
#' Conversion of `MatrixPrintForm` objects to RTF is done via [mpf_to_rtf()].
|
|
382 |
#'
|
|
383 |
#' @inheritParams export_as_txt
|
|
384 |
#' @inheritParams toString
|
|
385 |
#' @inheritParams grid::plotViewport
|
|
386 |
#' @inheritParams paginate_to_mpfs
|
|
387 |
#'
|
|
388 |
#' @export
|
|
389 |
export_as_rtf <- function(x, |
|
390 |
file = NULL, |
|
391 |
colwidths = NULL, |
|
392 |
page_type = "letter", |
|
393 |
pg_width = page_dim(page_type)[if (landscape) 2 else 1], |
|
394 |
pg_height = page_dim(page_type)[if (landscape) 1 else 2], |
|
395 |
landscape = FALSE, |
|
396 |
margins = c(bottom = .5, left = .75, top = .5, right = .75), |
|
397 |
font_size = 8, |
|
398 |
font_family = "Courier", |
|
399 |
...) { |
|
400 |
# Processing lists of tables or listings
|
|
401 | 2x |
if (.is_list_of_tables_or_listings(x)) { |
402 | ! |
if (isFALSE(paginate)) { |
403 | ! |
warning( |
404 | ! |
"paginate is FALSE, but x is a list of tables or listings, ",
|
405 | ! |
"so paginate will automatically be updated to TRUE"
|
406 |
)
|
|
407 |
}
|
|
408 | ! |
paginate <- TRUE |
409 |
}
|
|
410 | ||
411 | 2x |
if (!requireNamespace("r2rtf")) { |
412 | ! |
stop("RTF export requires the r2rtf package, please install it.") |
413 |
}
|
|
414 | 2x |
if (is.null(names(margins))) { |
415 | ! |
names(margins) <- marg_order |
416 |
}
|
|
417 | ||
418 | 2x |
true_width <- pg_width - sum(margins[c("left", "right")]) |
419 | 2x |
true_height <- pg_height - sum(margins[c("top", "bottom")]) |
420 | ||
421 | 2x |
mpfs <- paginate_to_mpfs( |
422 | 2x |
x,
|
423 | 2x |
font_family = font_family, font_size = font_size, |
424 | 2x |
pg_width = true_width, |
425 | 2x |
pg_height = true_height, |
426 | 2x |
margins = c(bottom = 0, left = 0, top = 0, right = 0), |
427 | 2x |
lineheight = 1.25, |
428 | 2x |
colwidths = colwidths, |
429 |
...
|
|
430 |
)
|
|
431 | ||
432 | 2x |
rtftxts <- lapply(mpfs, function(mf) { |
433 | 4x |
r2rtf::rtf_encode(mpf_to_rtf(mf, |
434 | 4x |
colwidths = mf_col_widths(mf), |
435 | 4x |
page_type = page_type, |
436 | 4x |
pg_width = pg_width, |
437 | 4x |
pg_height = pg_height, |
438 | 4x |
font_size = font_size, |
439 | 4x |
margins = c(top = 0, left = 0, bottom = 0, right = 0) |
440 |
)) |
|
441 |
}) |
|
442 | 2x |
restxt <- paste( |
443 | 2x |
rtftxts[[1]]$start, |
444 | 2x |
paste( |
445 | 2x |
sapply(rtftxts, function(x) x$body), |
446 | 2x |
collapse = "\n{\\pard\\fs2\\par}\\page{\\pard\\fs2\\par}\n" |
447 |
),
|
|
448 | 2x |
rtftxts[[1]]$end |
449 |
)
|
|
450 | 2x |
if (!is.null(file)) { |
451 | 2x |
cat(restxt, file = file) |
452 |
} else { |
|
453 | ! |
restxt
|
454 |
}
|
|
455 |
}
|
|
456 | ||
457 | ||
458 |
# PDF support ------------------------------------------------------------------
|
|
459 | ||
460 |
#' Export as PDF
|
|
461 |
#'
|
|
462 |
#' The PDF output from this function is based on the ASCII output created with [toString()].
|
|
463 |
#'
|
|
464 |
#' @inheritParams export_as_txt
|
|
465 |
#' @param file (`string`)\cr file to write to, must have `.pdf` extension.
|
|
466 |
#' @param width `r lifecycle::badge("deprecated")` Please use the `pg_width` argument or specify
|
|
467 |
#' `page_type` instead.
|
|
468 |
#' @param height `r lifecycle::badge("deprecated")` Please use the `pg_height` argument or
|
|
469 |
#' specify `page_type` instead.
|
|
470 |
#' @param fontsize `r lifecycle::badge("deprecated")` Please use the `font_size` argument instead.
|
|
471 |
#' @param margins (`numeric(4)`)\cr the number of lines/characters of the margin on the bottom,
|
|
472 |
#' left, top, and right sides of the page, respectively.
|
|
473 |
#'
|
|
474 |
#' @importFrom grDevices pdf
|
|
475 |
#' @importFrom grid textGrob grid.newpage gpar pushViewport plotViewport unit grid.draw
|
|
476 |
#' convertWidth convertHeight grobHeight grobWidth
|
|
477 |
#' @importFrom grid textGrob get.gpar
|
|
478 |
#' @importFrom grDevices dev.off
|
|
479 |
#' @importFrom tools file_ext
|
|
480 |
#'
|
|
481 |
#' @details
|
|
482 |
#' By default, pagination is performed with default `cpp` and `lpp` defined by specified page
|
|
483 |
#' dimensions and margins. User-specified `lpp` and `cpp` values override this, and should
|
|
484 |
#' be used with caution.
|
|
485 |
#'
|
|
486 |
#' Title and footer materials are also word-wrapped by default (unlike when printed to the
|
|
487 |
#' terminal), with `cpp` (as defined above) as the default `max_width`.
|
|
488 |
#'
|
|
489 |
#' @seealso [export_as_txt()]
|
|
490 |
#'
|
|
491 |
#' @examples
|
|
492 |
#' \dontrun{
|
|
493 |
#' tf <- tempfile(fileext = ".pdf")
|
|
494 |
#' export_as_pdf(basic_matrix_form(mtcars), file = tf, pg_height = 4)
|
|
495 |
#'
|
|
496 |
#' tf <- tempfile(fileext = ".pdf")
|
|
497 |
#' export_as_pdf(basic_matrix_form(mtcars), file = tf, lpp = 8)
|
|
498 |
#' }
|
|
499 |
#'
|
|
500 |
#' @export
|
|
501 |
export_as_pdf <- function(x, |
|
502 |
file,
|
|
503 |
page_type = "letter", |
|
504 |
landscape = FALSE, |
|
505 |
pg_width = page_dim(page_type)[if (landscape) 2 else 1], |
|
506 |
pg_height = page_dim(page_type)[if (landscape) 1 else 2], |
|
507 |
width = lifecycle::deprecated(), |
|
508 |
height = lifecycle::deprecated(), |
|
509 |
margins = c(4, 4, 4, 4), |
|
510 |
min_siblings = 2, |
|
511 |
font_family = "Courier", |
|
512 |
font_size = 8, |
|
513 |
fontsize = lifecycle::deprecated(), |
|
514 |
paginate = TRUE, |
|
515 |
page_num = default_page_number(), |
|
516 |
lpp = NULL, |
|
517 |
cpp = NULL, |
|
518 |
hsep = "-", |
|
519 |
indent_size = 2, |
|
520 |
rep_cols = NULL, |
|
521 |
tf_wrap = TRUE, |
|
522 |
max_width = NULL, |
|
523 |
colwidths = NULL) { |
|
524 | 6x |
stopifnot(tools::file_ext(file) != ".pdf") |
525 | ||
526 |
# Processing lists of tables or listings
|
|
527 | 6x |
if (.is_list_of_tables_or_listings(x)) { |
528 | 2x |
if (isFALSE(paginate)) { |
529 | 2x |
warning( |
530 | 2x |
"paginate is FALSE, but x is a list of tables or listings, ",
|
531 | 2x |
"so paginate will automatically be updated to TRUE"
|
532 |
)
|
|
533 |
}
|
|
534 | 2x |
paginate <- TRUE |
535 |
}
|
|
536 | ||
537 | 6x |
if (lifecycle::is_present(width)) { |
538 | 1x |
lifecycle::deprecate_warn("0.5.5", "export_as_pdf(width)", "export_as_pdf(pg_width)") |
539 | 1x |
pg_width <- width |
540 |
}
|
|
541 | 6x |
if (lifecycle::is_present(height)) { |
542 | 1x |
lifecycle::deprecate_warn("0.5.5", "export_as_pdf(height)", "export_as_pdf(pg_height)") |
543 | 1x |
pg_height <- height |
544 |
}
|
|
545 | 6x |
if (lifecycle::is_present(fontsize)) { |
546 | ! |
lifecycle::deprecate_warn("0.5.5", "export_as_pdf(fontsize)", "export_as_pdf(font_size)") |
547 | ! |
font_size <- fontsize |
548 |
}
|
|
549 | ||
550 | 6x |
gp_plot <- grid::gpar(fontsize = font_size, fontfamily = font_family) |
551 | ||
552 | 6x |
pdf(file = file, width = pg_width, height = pg_height) |
553 | 6x |
on.exit(dev.off()) |
554 | 6x |
grid::grid.newpage() |
555 | 6x |
grid::pushViewport(grid::plotViewport(margins = margins, gp = gp_plot)) |
556 | ||
557 | 6x |
cur_gpar <- grid::get.gpar() |
558 | 6x |
if (is.null(lpp)) { |
559 | 6x |
lpp <- floor(grid::convertHeight(grid::unit(1, "npc"), "lines", valueOnly = TRUE) / |
560 | 6x |
(cur_gpar$cex * cur_gpar$lineheight)) - sum(margins[c(1, 3)]) # bottom, top # nolint |
561 |
}
|
|
562 | 6x |
if (is.null(cpp)) { |
563 | 4x |
cpp <- floor(grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE) * |
564 | 4x |
font_lcpi(font_family, font_size, cur_gpar$lineheight)$cpi) - sum(margins[c(2, 4)]) # left, right # nolint |
565 |
}
|
|
566 | 6x |
if (tf_wrap && is.null(max_width)) { |
567 | 6x |
max_width <- cpp |
568 |
}
|
|
569 | ||
570 | 6x |
if (paginate) { |
571 | 4x |
tbls <- paginate_to_mpfs( |
572 | 4x |
x,
|
573 | 4x |
page_type = page_type, |
574 | 4x |
font_family = font_family, |
575 | 4x |
font_size = font_size, |
576 | 4x |
lineheight = cur_gpar$lineheight, |
577 | 4x |
landscape = landscape, |
578 | 4x |
pg_width = pg_width, |
579 | 4x |
pg_height = pg_height, |
580 | 4x |
margins = margins, |
581 | 4x |
lpp = lpp, |
582 | 4x |
cpp = cpp, |
583 | 4x |
min_siblings = min_siblings, |
584 | 4x |
nosplitin = character(), |
585 | 4x |
colwidths = colwidths, |
586 | 4x |
tf_wrap = tf_wrap, |
587 | 4x |
max_width = max_width, |
588 | 4x |
indent_size = indent_size, |
589 | 4x |
verbose = FALSE, |
590 | 4x |
rep_cols = rep_cols, |
591 | 4x |
page_num = page_num |
592 |
)
|
|
593 |
} else { |
|
594 | 2x |
mf <- matrix_form(x, TRUE, TRUE, indent_size = indent_size) |
595 | 2x |
mf_col_widths(mf) <- colwidths %||% propose_column_widths(mf) |
596 | 2x |
tbls <- list(mf) |
597 |
}
|
|
598 | ||
599 |
# Needs to be here because of adding cpp if it is not "auto"
|
|
600 | 6x |
if (!is.character(max_width)) { |
601 | 6x |
max_width <- .handle_max_width( |
602 | 6x |
tf_wrap = tf_wrap, |
603 | 6x |
max_width = max_width, |
604 | 6x |
cpp = cpp |
605 |
)
|
|
606 |
}
|
|
607 | ||
608 | 6x |
gtbls <- lapply(tbls, function(txt) { |
609 | 10x |
grid::textGrob( |
610 | 10x |
label = toString(txt, |
611 | 10x |
widths = txt$col_widths + 1, hsep = hsep, |
612 | 10x |
tf_wrap = tf_wrap, max_width = max_width |
613 |
),
|
|
614 | 10x |
x = grid::unit(0, "npc"), y = grid::unit(1, "npc"), |
615 | 10x |
just = c("left", "top") |
616 |
)
|
|
617 |
}) |
|
618 | ||
619 | 6x |
npages <- length(gtbls) |
620 | 6x |
exceeds_width <- rep(FALSE, npages) |
621 | 6x |
exceeds_height <- rep(FALSE, npages) |
622 | ||
623 | 6x |
for (i in seq_along(gtbls)) { |
624 | 10x |
g <- gtbls[[i]] |
625 | ||
626 | 10x |
if (i > 1) { |
627 | 4x |
grid::grid.newpage() |
628 | 4x |
grid::pushViewport(grid::plotViewport(margins = margins, gp = gp_plot)) |
629 |
}
|
|
630 | ||
631 | 10x |
if (grid::convertHeight(grid::grobHeight(g), "inches", valueOnly = TRUE) > |
632 | 10x |
grid::convertHeight(grid::unit(1, "npc"), "inches", valueOnly = TRUE)) { # nolint |
633 | 2x |
exceeds_height[i] <- TRUE |
634 | 2x |
warning("height of page ", i, " exceeds the available space") |
635 |
}
|
|
636 | 10x |
if (grid::convertWidth(grid::grobWidth(g), "inches", valueOnly = TRUE) > |
637 | 10x |
grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE)) { # nolint |
638 | 4x |
exceeds_width[i] <- TRUE |
639 | 4x |
warning("width of page ", i, " exceeds the available space") |
640 |
}
|
|
641 | ||
642 | 10x |
grid::grid.draw(g) |
643 |
}
|
|
644 | 6x |
list( |
645 | 6x |
file = file, npages = npages, exceeds_width = exceeds_width, exceeds_height = exceeds_height, |
646 | 6x |
lpp = lpp, cpp = cpp |
647 |
)
|
|
648 |
}
|
1 |
## until we do it for real
|
|
2 | ||
3 |
#' Class for Matrix Print Form
|
|
4 |
#'
|
|
5 |
#' The `MatrixPrintForm` class, an intermediate representation for ASCII table printing.
|
|
6 |
#'
|
|
7 |
#' @name MatrixPrintForm-class
|
|
8 |
#' @rdname MatrixPrintForm_class
|
|
9 |
#' @exportClass MatrixPrintForm
|
|
10 |
setOldClass(c("MatrixPrintForm", "list")) |
|
11 | ||
12 |
mform_handle_newlines <- function(matform) { |
|
13 |
# Retrieving relevant information
|
|
14 | 259x |
has_topleft <- mf_has_topleft(matform) |
15 | 259x |
strmat <- mf_strings(matform) |
16 | 259x |
frmmat <- mf_formats(matform) |
17 | 259x |
spamat <- mf_spans(matform) |
18 | 259x |
alimat <- mf_aligns(matform) |
19 | 259x |
nr_header <- mf_nrheader(matform) |
20 | 259x |
nl_inds_header <- seq(1, mf_nlheader(matform)) |
21 | 259x |
hdr_inds <- 1:nr_header |
22 | ||
23 |
# hack that is necessary only if top-left is bottom aligned (default)
|
|
24 | 259x |
topleft_has_nl_char <- FALSE |
25 | 259x |
if (has_topleft) { |
26 | 3x |
tl <- strmat[nl_inds_header, 1, drop = TRUE] |
27 | 3x |
strmat[nl_inds_header, 1] <- "" |
28 | 3x |
tl <- tl[nzchar(tl)] # we are not interested in initial "" but we cover initial \n |
29 | 3x |
topleft_has_nl_char <- any(grepl("\n", tl)) |
30 | 3x |
tl_to_add_back <- strsplit(paste0(tl, collapse = "\n"), split = "\n", fixed = TRUE)[[1]] |
31 | 3x |
how_many_nl <- length(tl_to_add_back) |
32 |
}
|
|
33 | ||
34 |
# pre-proc in case of wrapping and \n
|
|
35 | 259x |
line_grouping <- mf_lgrouping(matform) |
36 | 259x |
strmat <- .compress_mat(strmat, line_grouping, "nl") |
37 | 259x |
frmmat <- .compress_mat(frmmat, line_grouping, "unique") # never not unique |
38 | 259x |
spamat <- .compress_mat(spamat, line_grouping, "unique") |
39 | 259x |
alimat <- .compress_mat(alimat, line_grouping, "unique") |
40 | 259x |
line_grouping <- unique(line_grouping) |
41 | ||
42 |
# nlines detects if there is a newline character
|
|
43 | 259x |
row_nlines <- apply(strmat, 1, function(x) max(vapply(x, nlines, 1L), 1L)) |
44 | ||
45 |
# Correction for the case where there are more lines for topleft material than for cols
|
|
46 | 259x |
if (has_topleft && (sum(row_nlines[nl_inds_header]) < how_many_nl)) { |
47 | 1x |
row_nlines[1] <- row_nlines[1] + how_many_nl - sum(row_nlines[nl_inds_header]) |
48 |
}
|
|
49 | ||
50 |
# There is something to change
|
|
51 | 259x |
if (any(row_nlines > 1) || topleft_has_nl_char) { |
52 |
# False: Padder should be bottom aligned if no topleft (case of rlistings)
|
|
53 |
# It is always bottom: tl_padder <- ifelse(has_topleft, pad_vert_top, pad_vert_bottom)
|
|
54 | ||
55 | 34x |
newstrmat <- rbind( |
56 | 34x |
cbind( |
57 | 34x |
expand_mat_rows(strmat[hdr_inds, 1, drop = FALSE], |
58 | 34x |
row_nlines[hdr_inds], |
59 | 34x |
cpadder = pad_vert_bottom # topleft info is NOT top aligned |
60 |
),
|
|
61 | 34x |
expand_mat_rows(strmat[hdr_inds, -1, drop = FALSE], |
62 | 34x |
row_nlines[hdr_inds], |
63 | 34x |
cpadder = pad_vert_bottom # colnames are bottom aligned |
64 |
)
|
|
65 |
),
|
|
66 | 34x |
expand_mat_rows(strmat[-1 * hdr_inds, , drop = FALSE], row_nlines[-hdr_inds]) |
67 |
)
|
|
68 | ||
69 | 34x |
newfrmmat <- rbind( |
70 | 34x |
expand_mat_rows( |
71 | 34x |
frmmat[hdr_inds, , drop = FALSE], |
72 | 34x |
row_nlines[hdr_inds], |
73 | 34x |
cpadder = pad_vert_bottom |
74 |
),
|
|
75 | 34x |
expand_mat_rows(frmmat[-1 * hdr_inds, , drop = FALSE], row_nlines[-hdr_inds]) |
76 |
)
|
|
77 | ||
78 | 34x |
if (has_topleft) { |
79 | 3x |
starts_from_ind <- if (sum(row_nlines[hdr_inds]) - how_many_nl > 0) { |
80 | 2x |
sum(row_nlines[hdr_inds]) - how_many_nl |
81 |
} else { |
|
82 | 1x |
0
|
83 |
}
|
|
84 | 3x |
newstrmat[starts_from_ind + seq_along(tl_to_add_back), 1] <- tl_to_add_back |
85 |
}
|
|
86 | ||
87 | 34x |
mf_strings(matform) <- newstrmat |
88 | 34x |
mf_formats(matform) <- newfrmmat |
89 | 34x |
mf_spans(matform) <- expand_mat_rows(spamat, row_nlines, rep_vec_to_len) |
90 | 34x |
mf_aligns(matform) <- expand_mat_rows(alimat, row_nlines, rep_vec_to_len) |
91 |
## mf_display(matform) <- expand_mat_rows(mf_display(matform), row_nlines, rep_vec_to_len)
|
|
92 | 34x |
mf_lgrouping(matform) <- rep(line_grouping, times = row_nlines) |
93 |
}
|
|
94 | ||
95 |
# Solve \n in titles
|
|
96 | 259x |
if (any(grepl("\n", all_titles(matform)))) { |
97 | 2x |
if (any(grepl("\n", main_title(matform)))) { |
98 | 2x |
tmp_title_vec <- .quick_handle_nl(main_title(matform)) |
99 | 2x |
main_title(matform) <- tmp_title_vec[1] |
100 | 2x |
subtitles(matform) <- c(tmp_title_vec[-1], .quick_handle_nl(subtitles(matform))) |
101 |
} else { |
|
102 | ! |
subtitles(matform) <- .quick_handle_nl(subtitles(matform)) |
103 |
}
|
|
104 |
}
|
|
105 | ||
106 |
# Solve \n in footers
|
|
107 | 259x |
main_footer(matform) <- .quick_handle_nl(main_footer(matform)) |
108 | 259x |
prov_footer(matform) <- .quick_handle_nl(prov_footer(matform)) |
109 | ||
110 |
# xxx \n in page titles are not working atm (I think)
|
|
111 | ||
112 | 259x |
matform
|
113 |
}
|
|
114 | ||
115 |
.quick_handle_nl <- function(str_v) { |
|
116 | 522x |
if (any(grepl("\n", str_v))) { |
117 | 4x |
return(unlist(strsplit(str_v, "\n", fixed = TRUE))) |
118 |
} else { |
|
119 | 518x |
return(str_v) |
120 |
}
|
|
121 |
}
|
|
122 | ||
123 |
# Helper function to recompact the lines following line groupings to then have them expanded again
|
|
124 |
.compress_mat <- function(mat, line_grouping, collapse_method = c("nl", "unique")) { |
|
125 | 1036x |
list_compacted_mat <- lapply(unique(line_grouping), function(lg) { |
126 | 20436x |
apply(mat, 2, function(mat_cols) { |
127 | 175676x |
col_vec <- mat_cols[which(line_grouping == lg)] |
128 | 175676x |
if (collapse_method[1] == "nl") { |
129 | 43919x |
paste0(col_vec, collapse = "\n") |
130 |
} else { |
|
131 | 131757x |
val <- unique(col_vec) |
132 | 131757x |
val <- val[nzchar(val)] |
133 | 131757x |
if (length(val) > 1) { |
134 | 20436x |
stop("Problem in linegroupings! Some do not have the same values.") # nocov |
135 | 131757x |
} else if (length(val) < 1) { |
136 | 5110x |
val <- "" # Case in which it is only "" |
137 |
}
|
|
138 | 131757x |
val[[1]] |
139 |
}
|
|
140 |
}) |
|
141 |
}) |
|
142 | 1036x |
do.call("rbind", list_compacted_mat) |
143 |
}
|
|
144 | ||
145 |
disp_from_spans <- function(spans) { |
|
146 | 401x |
display <- matrix(rep(TRUE, length(spans)), ncol = ncol(spans)) |
147 | ||
148 | 401x |
print_cells_mat <- spans == 1L |
149 | 401x |
if (!all(print_cells_mat)) { |
150 | 1x |
display_rws <- lapply( |
151 | 1x |
seq_len(nrow(spans)), |
152 | 1x |
function(i) { |
153 | 2x |
print_cells <- print_cells_mat[i, ] |
154 | 2x |
row <- spans[i, ] |
155 |
## display <- t(apply(spans, 1, function(row) {
|
|
156 |
## print_cells <- row == 1
|
|
157 | ||
158 | 2x |
if (!all(print_cells)) { |
159 |
## need to calculate which cell need to be printed
|
|
160 | 1x |
print_cells <- spans_to_viscell(row) |
161 |
}
|
|
162 | 2x |
print_cells
|
163 |
}
|
|
164 |
)
|
|
165 | 1x |
display <- do.call(rbind, display_rws) |
166 |
}
|
|
167 | 401x |
display
|
168 |
}
|
|
169 | ||
170 |
#' Constructor for Matrix Print Form
|
|
171 |
#'
|
|
172 |
#' Constructor for `MatrixPrintForm`, an intermediate representation for ASCII table printing.
|
|
173 |
#'
|
|
174 |
#' @param strings (`character matrix`)\cr matrix of formatted, ready-to-display strings
|
|
175 |
#' organized as they will be positioned when rendered. Elements that span more than one
|
|
176 |
#' column must be followed by the correct number of placeholders (typically either empty
|
|
177 |
#' strings or repeats of the value).
|
|
178 |
#' @param spans (`numeric matrix`)\cr matrix of same dimension as `strings` giving the
|
|
179 |
#' spanning information for each element. Must be repeated to match placeholders in `strings`.
|
|
180 |
#' @param aligns (`character matrix`)\cr matrix of same dimension as `strings` giving the text
|
|
181 |
#' alignment information for each element. Must be repeated to match placeholders in `strings`.
|
|
182 |
#' Must be a supported text alignment. See [decimal_align] for allowed values.
|
|
183 |
#' @param formats (`matrix`)\cr matrix of same dimension as `strings` giving the text format
|
|
184 |
#' information for each element. Must be repeated to match placeholders in `strings`.
|
|
185 |
#' @param row_info (`data.frame`)\cr data frame with row-information necessary for pagination (see
|
|
186 |
#' [basic_pagdf()] for more details).
|
|
187 |
#' @param line_grouping (`integer`)\cr sequence of integers indicating how print lines correspond
|
|
188 |
#' to semantic rows in the object. Typically this should not be set manually unless
|
|
189 |
#' `expand_newlines` is set to `FALSE`.
|
|
190 |
#' @param ref_fnotes (`list`)\cr referential footnote information, if applicable.
|
|
191 |
#' @param nlines_header (`numeric(1)`)\cr number of lines taken up by the values of the header
|
|
192 |
#' (i.e. not including the divider).
|
|
193 |
#' @param nrow_header (`numeric(1)`)\cr number of *rows* corresponding to the header.
|
|
194 |
#' @param has_topleft (`flag`)\cr does the corresponding table have "top left information"
|
|
195 |
#' which should be treated differently when expanding newlines. Ignored if `expand_newlines`
|
|
196 |
#' is `FALSE`.
|
|
197 |
#' @param has_rowlabs (`flag`)\cr do the matrices (`strings`, `spans`, `aligns`) each contain a
|
|
198 |
#' column that corresponds with row labels (rather than with table cell values). Defaults to `TRUE`.
|
|
199 |
#' @param main_title (`string`)\cr main title as a string.
|
|
200 |
#' @param subtitles (`character`)\cr subtitles, as a character vector.
|
|
201 |
#' @param page_titles (`character`)\cr page-specific titles, as a character vector.
|
|
202 |
#' @param main_footer (`character`)\cr main footer, as a character vector.
|
|
203 |
#' @param prov_footer (`character`)\cr provenance footer information, as a character vector.
|
|
204 |
#' @param listing_keycols (`character`)\cr. if matrix form of a listing, this contains
|
|
205 |
#' the key columns as a character vector.
|
|
206 |
#' @param header_section_div (`string`)\cr divider to be used between header and body sections.
|
|
207 |
#' @param horizontal_sep (`string`)\cr horizontal separator to be used for printing divisors
|
|
208 |
#' between header and table body and between different footers.
|
|
209 |
#' @param expand_newlines (`flag`)\cr whether the matrix form generated should expand rows whose
|
|
210 |
#' values contain newlines into multiple 'physical' rows (as they will appear when rendered into
|
|
211 |
#' ASCII). Defaults to `TRUE`.
|
|
212 |
#' @param col_gap (`numeric(1)`)\cr space (in characters) between columns.
|
|
213 |
#' @param table_inset (`numeric(1)`)\cr table inset. See [table_inset()].
|
|
214 |
#' @param colwidths (`numeric` or `NULL`)\cr column rendering widths. If non-`NULL`, must have length
|
|
215 |
#' equal to `ncol(strings)`.
|
|
216 |
#' @param indent_size (`numeric(1)`)\cr number of spaces to be used per level of indent (if supported by
|
|
217 |
#' the relevant method). Defaults to 2.
|
|
218 |
#'
|
|
219 |
#' @return An object of class `MatrixPrintForm`. Currently this is implemented as an S3 class inheriting
|
|
220 |
#' from list with the following elements:
|
|
221 |
#' \describe{
|
|
222 |
#' \item{`strings`}{see argument.}
|
|
223 |
#' \item{`spans`}{see argument.}
|
|
224 |
#' \item{`aligns`}{see argument.}
|
|
225 |
#' \item{`display`}{logical matrix of same dimension as `strings` that specifies whether an element
|
|
226 |
#' in `strings` will be displayed when the table is rendered.}
|
|
227 |
#' \item{`formats`}{see argument.}
|
|
228 |
#' \item{`row_info`}{see argument.}
|
|
229 |
#' \item{`line_grouping`}{see argument.}
|
|
230 |
#' \item{`ref_footnotes`}{see argument.}
|
|
231 |
#' \item{`main_title`}{see argument.}
|
|
232 |
#' \item{`subtitles`}{see argument.}
|
|
233 |
#' \item{`page_titles`}{see argument.}
|
|
234 |
#' \item{`main_footer`}{see argument.}
|
|
235 |
#' \item{`prov_footer`}{see argument.}
|
|
236 |
#' \item{`header_section_div`}{see argument.}
|
|
237 |
#' \item{`horizontal_sep`}{see argument.}
|
|
238 |
#' \item{`col_gap`}{see argument.}
|
|
239 |
#' \item{`table_inset`}{see argument.}
|
|
240 |
#' }
|
|
241 |
#'
|
|
242 |
#' as well as the following attributes:
|
|
243 |
#'
|
|
244 |
#' \describe{
|
|
245 |
#' \item{`nlines_header`}{see argument.}
|
|
246 |
#' \item{`nrow_header`}{see argument.}
|
|
247 |
#' \item{`ncols`}{number of columns *of the table*, not including any row names/row labels}
|
|
248 |
#' }
|
|
249 |
#'
|
|
250 |
#' @note The bare constructor for the `MatrixPrintForm` should generally
|
|
251 |
#' only be called by `matrix_form` custom methods, and almost never from other code.
|
|
252 |
#'
|
|
253 |
#' @examples
|
|
254 |
#' basic_matrix_form(iris) # calls matrix_form which calls this constructor
|
|
255 |
#'
|
|
256 |
#' @export
|
|
257 |
MatrixPrintForm <- function(strings = NULL, |
|
258 |
spans,
|
|
259 |
aligns,
|
|
260 |
formats,
|
|
261 |
row_info,
|
|
262 |
line_grouping = seq_len(NROW(strings)), |
|
263 |
ref_fnotes = list(), |
|
264 |
nlines_header,
|
|
265 |
nrow_header,
|
|
266 |
has_topleft = TRUE, |
|
267 |
has_rowlabs = has_topleft, |
|
268 |
expand_newlines = TRUE, |
|
269 |
main_title = "", |
|
270 |
subtitles = character(), |
|
271 |
page_titles = character(), |
|
272 |
listing_keycols = NULL, |
|
273 |
main_footer = "", |
|
274 |
prov_footer = character(), |
|
275 |
header_section_div = NA_character_, |
|
276 |
horizontal_sep = default_hsep(), |
|
277 |
col_gap = 3, |
|
278 |
table_inset = 0L, |
|
279 |
colwidths = NULL, |
|
280 |
indent_size = 2) { |
|
281 | 50x |
display <- disp_from_spans(spans) |
282 | ||
283 | 50x |
ncs <- if (has_rowlabs) ncol(strings) - 1 else ncol(strings) |
284 | 50x |
ret <- structure( |
285 | 50x |
list( |
286 | 50x |
strings = strings, |
287 | 50x |
spans = spans, |
288 | 50x |
aligns = aligns, |
289 | 50x |
display = display, |
290 | 50x |
formats = formats, |
291 | 50x |
row_info = row_info, |
292 | 50x |
line_grouping = line_grouping, |
293 | 50x |
ref_footnotes = ref_fnotes, |
294 | 50x |
main_title = main_title, |
295 | 50x |
subtitles = subtitles, |
296 | 50x |
page_titles = page_titles, |
297 | 50x |
main_footer = main_footer, |
298 | 50x |
prov_footer = prov_footer, |
299 | 50x |
header_section_div = header_section_div, |
300 | 50x |
horizontal_sep = horizontal_sep, |
301 | 50x |
col_gap = col_gap, |
302 | 50x |
listing_keycols = listing_keycols, |
303 | 50x |
table_inset = as.integer(table_inset), |
304 | 50x |
has_topleft = has_topleft, |
305 | 50x |
indent_size = indent_size, |
306 | 50x |
col_widths = colwidths |
307 |
),
|
|
308 | 50x |
nrow_header = nrow_header, |
309 | 50x |
ncols = ncs, |
310 | 50x |
class = c("MatrixPrintForm", "list") |
311 |
)
|
|
312 | ||
313 |
## .do_mat_expand(ret)
|
|
314 | 50x |
if (expand_newlines) { |
315 | 50x |
ret <- mform_handle_newlines(ret) |
316 |
}
|
|
317 | ||
318 |
## ret <- shove_refdf_into_rowinfo(ret)
|
|
319 | 50x |
if (is.null(colwidths)) { |
320 | 50x |
colwidths <- propose_column_widths(ret) |
321 |
}
|
|
322 | 50x |
mf_col_widths(ret) <- colwidths |
323 | 50x |
ret <- mform_build_refdf(ret) |
324 | 50x |
ret
|
325 |
}
|
|
326 | ||
327 |
#' Create a row for a referential footnote information data frame
|
|
328 |
#'
|
|
329 |
#' @inheritParams nlines
|
|
330 |
#' @param row_path (`character`)\cr row path (or `NA_character_` for none).
|
|
331 |
#' @param col_path (`character`)\cr column path (or `NA_character_` for none).
|
|
332 |
#' @param row (`integer(1)`)\cr integer position of the row.
|
|
333 |
#' @param col (`integer(1)`)\cr integer position of the column.
|
|
334 |
#' @param symbol (`string`)\cr symbol for the reference. `NA_character_` to use the
|
|
335 |
#' `ref_index` automatically.
|
|
336 |
#' @param ref_index (`integer(1)`)\cr index of the footnote, used for ordering even when
|
|
337 |
#' symbol is not `NA`.
|
|
338 |
#' @param msg (`string`)\cr the string message, not including the symbol portion (`{symbol} - `)
|
|
339 |
#'
|
|
340 |
#' @return A single row data frame with the appropriate columns.
|
|
341 |
#'
|
|
342 |
#' @export
|
|
343 |
ref_df_row <- function(row_path = NA_character_, |
|
344 |
col_path = NA_character_, |
|
345 |
row = NA_integer_, |
|
346 |
col = NA_integer_, |
|
347 |
symbol = NA_character_, |
|
348 |
ref_index = NA_integer_, |
|
349 |
msg = NA_character_, |
|
350 |
max_width = NULL) { |
|
351 | 7042x |
nlines <- nlines(msg, max_width = max_width) |
352 | 7042x |
data.frame( |
353 | 7042x |
row_path = I(list(row_path)), |
354 | 7042x |
col_path = I(list(col_path)), |
355 | 7042x |
row = row, |
356 | 7042x |
col = col, |
357 | 7042x |
symbol = symbol, |
358 | 7042x |
ref_index = ref_index, |
359 | 7042x |
msg = msg, |
360 | 7042x |
nlines = nlines, |
361 | 7042x |
stringsAsFactors = FALSE |
362 |
)
|
|
363 |
}
|
|
364 | ||
365 |
## this entire thing is a hatchetjob of a hack which should not be necessary.
|
|
366 |
## mf_rinfo(mform) should have the relevant info in it and
|
|
367 |
## mf_cinfo(mform) should be non-null (!!!) and have the info in it
|
|
368 |
## in which case this becomes silly and dumb, but here we are, so here we go.
|
|
369 |
infer_ref_info <- function(mform, colspace_only) { |
|
370 | 200x |
if (colspace_only) { |
371 | 100x |
idx <- seq_len(mf_nlheader(mform)) |
372 |
} else { |
|
373 | 100x |
idx <- seq_len(nrow(mf_strings(mform))) |
374 |
}
|
|
375 | ||
376 | 200x |
hasrlbs <- mf_has_rlabels(mform) |
377 | ||
378 | 200x |
strs <- mf_strings(mform)[idx, , drop = FALSE] |
379 | ||
380 |
## they're nested so \\2 is the inner one, without the brackets
|
|
381 | 200x |
refs <- gsub("^[^{]*([{]([^}]+)[}]){0,1}$", "\\2", strs) |
382 |
## handle spanned values
|
|
383 | 200x |
refs[!mf_display(mform)[idx, ]] <- "" |
384 | ||
385 |
## we want to count across rows first, not down columns, cause
|
|
386 |
## thats how footnote numbering works
|
|
387 | 200x |
refs_inorder <- as.vector(t(refs)) |
388 | 200x |
keepem <- nzchar(refs_inorder) |
389 | 200x |
if (sum(keepem) == 0) { |
390 | 198x |
return(ref_df_row()[0, ]) |
391 |
}
|
|
392 | ||
393 | 2x |
refs_spl <- strsplit(refs_inorder[keepem], ", ", fixed = TRUE) |
394 | 2x |
runvec <- vapply(refs_spl, length, 1L) |
395 | ||
396 | 2x |
row_index <- as.vector( |
397 | 2x |
t(do.call(cbind, replicate(ncol(strs), list(mf_lgrouping(mform)[idx] - mf_nlheader(mform))))) |
398 | 2x |
)[keepem] |
399 | 2x |
row_index[row_index < 1] <- NA_integer_ |
400 | 2x |
c_torep <- if (hasrlbs) c(NA_integer_, seq(1, ncol(strs) - 1)) else seq_len(ncol(strs)) |
401 | 2x |
col_index <- rep(c_torep, nrow(strs))[keepem] |
402 | ||
403 | 2x |
ret <- data.frame( |
404 | 2x |
symbol = unlist(refs_spl), |
405 | 2x |
row_path = I(mf_rinfo(mform)$path[rep(row_index, times = runvec)]), |
406 | 2x |
row = rep(row_index, times = runvec), |
407 | 2x |
col = rep(col_index, times = runvec) |
408 |
)
|
|
409 | 2x |
ret$msg <- vapply(ret$symbol, function(sym) { |
410 | 16x |
fullmsg <- unique(grep(paste0("{", sym, "}"), fixed = TRUE, mf_rfnotes(mform), value = TRUE)) |
411 | 16x |
gsub("^[{][^}]+[}] - ", "", fullmsg) |
412 |
}, "") |
|
413 | ||
414 | 2x |
col_pths <- mf_col_paths(mform) |
415 | 2x |
ret$col_path <- replicate(nrow(ret), list(NA_character_)) |
416 | 2x |
non_na_col <- !is.na(ret$col) |
417 | 2x |
ret$col_path[non_na_col] <- col_pths[ret$col[non_na_col]] |
418 | 2x |
ret$ref_index <- match(ret$symbol, unique(ret$symbol)) |
419 |
##
|
|
420 | 2x |
ret$nlines <- vapply(paste0("{", ret$symbol, "} - ", ret$msg), nlines, 1L) |
421 | 2x |
ret <- ret[, names(ref_df_row())] |
422 | 2x |
ret
|
423 |
}
|
|
424 | ||
425 |
mform_build_refdf <- function(mform) { |
|
426 | 100x |
rdf <- mf_rinfo(mform) |
427 | 100x |
cref_rows <- infer_ref_info(mform, colspace_only = TRUE) |
428 |
## this will recheck sometimes but its safer and shouldn't
|
|
429 |
## be too prohibitively costly
|
|
430 | 100x |
if (NROW(rdf$ref_info_df) > 0 && sum(sapply(rdf$ref_info_df, NROW)) > 0) { |
431 | ! |
cref_rows <- infer_ref_info(mform, colspace_only = TRUE) |
432 | ! |
rref_rows <- rdf$ref_info_df |
433 |
} else { |
|
434 | 100x |
cref_rows <- infer_ref_info(mform, colspace_only = FALSE) |
435 | 100x |
rref_rows <- list() |
436 |
}
|
|
437 | 100x |
mf_fnote_df(mform) <- do.call(rbind.data.frame, c(list(cref_rows), rref_rows)) |
438 | 100x |
update_mf_nlines(mform, colwidths = mf_col_widths(mform), max_width = NULL) |
439 |
}
|
|
440 | ||
441 |
## hide the implementation behind abstraction in case we decide we want a real class someday
|
|
442 |
#' Getters and setters for aspects of `MatrixPrintForm` objects
|
|
443 |
#'
|
|
444 |
#' Most of these functions, particularly the setters, are intended almost exclusively for
|
|
445 |
#' internal use in, e.g., [`matrix_form`] methods, and should generally not be called by end users.
|
|
446 |
#'
|
|
447 |
#' @param mf (`MatrixPrintForm`)\cr a `MatrixPrintForm` object.
|
|
448 |
#' @param value (`ANY`)\cr the new value for the component in question.
|
|
449 |
#'
|
|
450 |
#' @return
|
|
451 |
#' * Getters return the associated element of `mf`.
|
|
452 |
#' * Setters return the modified `mf` object.
|
|
453 |
#'
|
|
454 |
#' @export
|
|
455 |
#' @rdname mpf_accessors
|
|
456 | 4802x |
mf_strings <- function(mf) mf$strings |
457 | ||
458 |
#' @export
|
|
459 |
#' @rdname mpf_accessors
|
|
460 | ||
461 | 669x |
mf_spans <- function(mf) mf$spans |
462 |
#' @export
|
|
463 |
#' @rdname mpf_accessors
|
|
464 | ||
465 | 996x |
mf_aligns <- function(mf) mf$aligns |
466 | ||
467 |
#' @export
|
|
468 |
#' @rdname mpf_accessors
|
|
469 | 445x |
mf_display <- function(mf) mf$display |
470 | ||
471 |
#' @export
|
|
472 |
#' @rdname mpf_accessors
|
|
473 | 577x |
mf_formats <- function(mf) mf$formats |
474 | ||
475 |
#' @export
|
|
476 |
#' @rdname mpf_accessors
|
|
477 | 4733x |
mf_rinfo <- function(mf) mf$row_info |
478 | ||
479 |
#' @export
|
|
480 |
#' @rdname mpf_accessors
|
|
481 | 194x |
mf_cinfo <- function(mf) mf$col_info |
482 | ||
483 | ||
484 |
#' @export
|
|
485 |
#' @rdname mpf_accessors
|
|
486 | 261x |
mf_has_topleft <- function(mf) mf$has_topleft |
487 | ||
488 |
#' @export
|
|
489 |
#' @rdname mpf_accessors
|
|
490 | 5743x |
mf_lgrouping <- function(mf) mf$line_grouping |
491 | ||
492 |
#' @export
|
|
493 |
#' @rdname mpf_accessors
|
|
494 | 170x |
mf_rfnotes <- function(mf) mf$ref_footnotes |
495 | ||
496 |
#' @export
|
|
497 |
#' @rdname mpf_accessors
|
|
498 | 2698x |
mf_nlheader <- function(mf) sum(mf_lgrouping(mf) <= mf_nrheader(mf)) |
499 | ||
500 |
#' @export
|
|
501 |
#' @rdname mpf_accessors
|
|
502 | 4591x |
mf_nrheader <- function(mf) attr(mf, "nrow_header", exact = TRUE) |
503 | ||
504 |
#' @export
|
|
505 |
#' @rdname mpf_accessors
|
|
506 | 366x |
mf_colgap <- function(mf) mf$col_gap |
507 | ||
508 |
## XXX should this be exported? not sure if there's a point
|
|
509 |
mf_col_paths <- function(mf) { |
|
510 | 2x |
if (!is.null(mf_cinfo(mf))) { |
511 | ! |
mf_cinfo(mf)$path |
512 |
} else { |
|
513 | 2x |
as.list(paste0("col", seq_len(nrow(mf_strings(mf)) - mf_has_topleft(mf)))) |
514 |
}
|
|
515 |
}
|
|
516 | ||
517 |
mf_col_widths <- function(mf) { |
|
518 | 609x |
mf$col_widths |
519 |
}
|
|
520 | ||
521 |
`mf_col_widths<-` <- function(mf, value) { |
|
522 | 411x |
if (!is.null(value) && length(value) != NCOL(mf_strings(mf))) { |
523 | ! |
stop( |
524 | ! |
"Number of column widths (", length(value), ") does not match ", |
525 | ! |
"number of columns in strings matrix (", NCOL(mf_strings(mf)), ")." |
526 |
)
|
|
527 |
}
|
|
528 | 411x |
mf$col_widths <- value |
529 | 411x |
mf
|
530 |
}
|
|
531 | ||
532 |
mf_fnote_df <- function(mf) { |
|
533 | 1743x |
mf$ref_fnote_df |
534 |
}
|
|
535 | ||
536 |
`mf_fnote_df<-` <- function(mf, value) { |
|
537 | 443x |
stopifnot(is.null(value) || (is.data.frame(value) && identical(names(value), names(ref_df_row())))) |
538 | 443x |
mf$ref_fnote_df <- value |
539 | 443x |
mf
|
540 |
}
|
|
541 | ||
542 |
splice_fnote_info_in <- function(df, refdf, row = TRUE) { |
|
543 | 447x |
if (NROW(df) == 0) { |
544 | ! |
return(df) |
545 |
}
|
|
546 | ||
547 | 447x |
colnm <- ifelse(row, "row", "col") |
548 | 447x |
refdf <- refdf[!is.na(refdf[[colnm]]), ] |
549 | ||
550 | 447x |
refdf_spl <- split(refdf, refdf[[colnm]]) |
551 | 447x |
df$ref_info_df <- replicate(nrow(df), list(ref_df_row()[0, ])) |
552 | 447x |
df$ref_info_df[as.integer(names(refdf_spl))] <- refdf_spl |
553 | 447x |
df
|
554 |
}
|
|
555 | ||
556 |
shove_refdf_into_rowinfo <- function(mform) { |
|
557 | 343x |
refdf <- mf_fnote_df(mform) |
558 | 343x |
rowinfo <- mf_rinfo(mform) |
559 | 343x |
mf_rinfo(mform) <- splice_fnote_info_in(rowinfo, refdf) |
560 | 343x |
mform
|
561 |
}
|
|
562 | ||
563 |
update_mf_nlines <- function(mform, colwidths, max_width) { |
|
564 | 307x |
mform <- update_mf_ref_nlines(mform, max_width = max_width) |
565 | 307x |
mform <- update_mf_rinfo_extents(mform) |
566 | ||
567 | 307x |
mform
|
568 |
}
|
|
569 | ||
570 |
update_mf_rinfo_extents <- function(mform) { |
|
571 | 307x |
rinfo <- mf_rinfo(mform) |
572 | 307x |
refdf_all <- mf_fnote_df(mform) |
573 | 307x |
refdf_rows <- refdf_all[!is.na(refdf_all$row), ] |
574 | 307x |
if (NROW(rinfo) == 0) { |
575 | ! |
return(mform) |
576 |
}
|
|
577 | 307x |
lgrp <- mf_lgrouping(mform) - mf_nrheader(mform) |
578 | 307x |
lgrp <- lgrp[lgrp > 0] |
579 | 307x |
rf_nlines <- vapply(seq_len(max(lgrp)), function(ii) { |
580 | 5950x |
refdfii <- refdf_rows[refdf_rows$row == ii, ] |
581 | 5950x |
refdfii <- refdfii[!duplicated(refdfii$symbol), ] |
582 | 5950x |
if (NROW(refdfii) == 0L) { |
583 | 5854x |
return(0L) |
584 |
}
|
|
585 | 96x |
sum(refdfii$nlines) |
586 | 307x |
}, 1L) |
587 | ||
588 | 307x |
raw_self_exts <- vapply(split(lgrp, lgrp), length, 0L) |
589 | 307x |
stopifnot(length(raw_self_exts) == length(rf_nlines)) |
590 | 307x |
new_exts <- raw_self_exts + rf_nlines |
591 | ||
592 | 307x |
mapdf <- data.frame( |
593 | 307x |
row_num = as.integer(names(new_exts)), |
594 | 307x |
raw_extent = raw_self_exts |
595 |
)
|
|
596 | 307x |
stopifnot(all(mapdf$row_num == rinfo$abs_rownumber)) |
597 | ||
598 | 307x |
new_par_exts <- vapply(rinfo$reprint_inds, function(idx) { |
599 | 5950x |
sum(0L, mapdf$raw_extent[mapdf$row_num %in% idx]) |
600 | 307x |
}, 1L) |
601 | ||
602 | 307x |
rinfo$self_extent <- new_exts |
603 | 307x |
rinfo$par_extent <- new_par_exts |
604 | 307x |
rinfo$nreflines <- rf_nlines |
605 | 307x |
mf_rinfo(mform) <- rinfo |
606 | 307x |
mform
|
607 |
}
|
|
608 | ||
609 |
update_mf_ref_nlines <- function(mform, max_width) { |
|
610 | 307x |
refdf <- mf_fnote_df(mform) |
611 | 307x |
if (NROW(refdf) == 0) { |
612 | 280x |
return(mform) |
613 |
}
|
|
614 | ||
615 | 27x |
refdf$nlines <- vapply( |
616 | 27x |
paste0("{", refdf$symbol, "} - ", refdf$msg), |
617 | 27x |
nlines,
|
618 | 27x |
max_width = max_width, |
619 | 27x |
1L
|
620 |
)
|
|
621 | 27x |
mf_fnote_df(mform) <- refdf |
622 | 27x |
shove_refdf_into_rowinfo(mform) |
623 |
}
|
|
624 | ||
625 |
#' @export
|
|
626 |
#' @rdname mpf_accessors
|
|
627 |
`mf_strings<-` <- function(mf, value) { |
|
628 | 793x |
mf$strings <- value |
629 | 793x |
mf
|
630 |
}
|
|
631 | ||
632 |
.chkdim_and_replace <- function(mf, value, component) { |
|
633 | 1068x |
strdim <- dim(mf_strings(mf)) |
634 | 1068x |
vdim <- dim(value) |
635 | 1068x |
if (!is.null(strdim) && !identical(strdim, vdim)) { |
636 | 1x |
stop( |
637 | 1x |
"Dimensions of new '", component, "' value (", |
638 | 1x |
vdim[1], ", ", vdim[2], # nocov |
639 | 1x |
") do not match dimensions of existing 'strings' component (", # nocov |
640 | 1x |
strdim[1], ", ", strdim[2], ")." # nocov |
641 |
)
|
|
642 |
}
|
|
643 | 1067x |
mf[[component]] <- value |
644 | 1067x |
mf
|
645 |
}
|
|
646 | ||
647 |
#' @export
|
|
648 |
#' @rdname mpf_accessors
|
|
649 |
`mf_spans<-` <- function(mf, value) { |
|
650 | 352x |
mf <- .chkdim_and_replace(mf, value, component = "spans") |
651 | 351x |
mf$display <- disp_from_spans(value) |
652 | 351x |
mf
|
653 |
}
|
|
654 | ||
655 |
#' @export
|
|
656 |
#' @rdname mpf_accessors
|
|
657 |
`mf_aligns<-` <- function(mf, value) { |
|
658 | 365x |
.chkdim_and_replace(mf, value, component = "aligns") |
659 |
}
|
|
660 | ||
661 |
#' @export
|
|
662 |
#' @rdname mpf_accessors
|
|
663 |
`mf_display<-` <- function(mf, value) { |
|
664 | ! |
stop("display is now a derived element of the matrix print form, modify it via `mf_spans<-`") |
665 | ! |
.chkdim_and_replace(mf, value, component = "display") |
666 |
}
|
|
667 | ||
668 |
#' @export
|
|
669 |
#' @rdname mpf_accessors
|
|
670 |
`mf_formats<-` <- function(mf, value) { |
|
671 | 351x |
.chkdim_and_replace(mf, value, component = "formats") |
672 |
}
|
|
673 | ||
674 |
## NB NROW(v) == length(v) for atomic vectors so this is ok for lgrouping as wellas rinfo
|
|
675 |
.chknrow_and_replace <- function(mf, value, component, noheader = FALSE) { |
|
676 | 351x |
strdim <- NROW(mf_strings(mf)) - if (noheader) mf_nlheader(mf) else 0L |
677 | 351x |
vdim <- NROW(value) |
678 | 351x |
if (!is.null(strdim) && !identical(strdim, vdim)) { |
679 | ! |
stop( |
680 | ! |
"Number of rows/length of new '", component, "' value (", |
681 | ! |
vdim[1], |
682 | ! |
") does not match existing 'strings' component (",
|
683 | ! |
strdim[1], ")." |
684 |
)
|
|
685 |
}
|
|
686 | 351x |
mf[[component]] <- value |
687 | 351x |
mf
|
688 |
}
|
|
689 | ||
690 |
#' @export
|
|
691 |
#' @rdname mpf_accessors
|
|
692 |
`mf_rinfo<-` <- function(mf, value) { |
|
693 |
## this can someijtmes be called after expanding newlines so in general
|
|
694 |
## we should not expect it to match the number of rows in the strings matrix
|
|
695 |
## .chknrow_and_replace(mf, value, component = "row_info", noheader = TRUE)
|
|
696 | 766x |
lgrps <- mf_lgrouping(mf) |
697 | 766x |
nrs <- length(unique(lgrps[-seq_len(mf_nlheader(mf))])) |
698 | 766x |
if (NROW(value) != nrs) { |
699 | 1x |
stop( |
700 | 1x |
"Rows in new row_info component (",
|
701 | 1x |
NROW(value), |
702 | 1x |
") does not match number of rows reflected in line_grouping component (",
|
703 | 1x |
nrs, ")" |
704 |
)
|
|
705 |
}
|
|
706 | 765x |
mf$row_info <- value |
707 | 765x |
mf
|
708 |
}
|
|
709 | ||
710 |
#' @export
|
|
711 |
#' @rdname mpf_accessors
|
|
712 |
`mf_cinfo<-` <- function(mf, value) { |
|
713 | 104x |
if (NROW(value) > 0 && NROW(value) != mf_ncol(mf)) { |
714 | ! |
stop( |
715 | ! |
"Number of rows in new cinfo (", NROW(value), ") does not match ", |
716 | ! |
"number of columns (", mf_ncol(mf), ")" |
717 |
)
|
|
718 |
}
|
|
719 | 104x |
mf$col_info <- value |
720 | 104x |
mf
|
721 |
}
|
|
722 | ||
723 |
#' @export
|
|
724 |
#' @rdname mpf_accessors
|
|
725 |
`mf_lgrouping<-` <- function(mf, value) { |
|
726 | 351x |
.chknrow_and_replace(mf, value, component = "line_grouping") |
727 |
}
|
|
728 | ||
729 |
#' @export
|
|
730 |
#' @rdname mpf_accessors
|
|
731 |
`mf_rfnotes<-` <- function(mf, value) { |
|
732 | 321x |
mf$ref_footnotes <- value |
733 | 321x |
mf
|
734 |
}
|
|
735 | ||
736 |
#' @export
|
|
737 |
#' @rdname mpf_accessors
|
|
738 |
`mf_nrheader<-` <- function(mf, value) { |
|
739 | 2x |
attr(mf, "nrow_header") <- value |
740 | 2x |
mf
|
741 |
}
|
|
742 | ||
743 |
#' @export
|
|
744 |
#' @rdname mpf_accessors
|
|
745 |
`mf_colgap<-` <- function(mf, value) { |
|
746 | ! |
mf$col_gap <- value |
747 | ! |
mf
|
748 |
}
|
|
749 | ||
750 |
#' @export
|
|
751 |
#' @rdname mpf_accessors
|
|
752 | 1295x |
mf_ncol <- function(mf) attr(mf, "ncols", exact = TRUE) |
753 | ||
754 |
#' @export
|
|
755 |
#' @rdname mpf_accessors
|
|
756 | 10x |
mf_nrow <- function(mf) max(mf_lgrouping(mf)) - mf_nrheader(mf) |
757 | ||
758 |
#' @export
|
|
759 |
#' @rdname mpf_accessors
|
|
760 |
`mf_ncol<-` <- function(mf, value) { |
|
761 | 440x |
stopifnot(is.numeric(value)) |
762 | 440x |
attr(mf, "ncols") <- value |
763 | 440x |
mf
|
764 |
}
|
|
765 | ||
766 |
#' @param x `MatrixPrintForm`. The object.
|
|
767 |
#' @export
|
|
768 |
#' @rdname mpf_accessors
|
|
769 |
setMethod( |
|
770 |
"ncol", "MatrixPrintForm", |
|
771 | 27x |
function(x) mf_ncol(x) |
772 |
)
|
|
773 | ||
774 |
#' @export
|
|
775 |
#' @rdname mpf_accessors
|
|
776 |
mpf_has_rlabels <- function(mf) { |
|
777 | ! |
.Deprecated("mf_has_rlabels") |
778 | ! |
mf_has_rlabels(mf) |
779 |
}
|
|
780 | ||
781 |
#' @export
|
|
782 |
#' @rdname mpf_accessors
|
|
783 | 627x |
mf_has_rlabels <- function(mf) ncol(mf$strings) > mf_ncol(mf) |
784 | ||
785 |
#' Create spoof matrix form from a data frame
|
|
786 |
#'
|
|
787 |
#' Useful functions for writing tests and examples, and a starting point for
|
|
788 |
#' more sophisticated custom `matrix_form` methods.
|
|
789 |
#'
|
|
790 |
#' @param df (`data.frame`)\cr a data frame.
|
|
791 |
#' @param indent_rownames (`flag`)\cr whether row names should be indented. Being this
|
|
792 |
#' used for testing purposes, it defaults to `FALSE`. If `TRUE`, it assigns label rows
|
|
793 |
#' on even lines (also format is `"-"` and value strings are `""`). Indentation works
|
|
794 |
#' only if split labels are used (see parameters `split_labels` and `data_labels`).
|
|
795 |
#' @param parent_path (`string`)\cr parent path that all rows should be "children of".
|
|
796 |
#' Defaults to `NULL`, as usually this is not needed. It may be necessary to use `"root"`,
|
|
797 |
#' for some specific scenarios.
|
|
798 |
#' @param ignore_rownames (`flag`)\cr whether row names should be ignored.
|
|
799 |
#' @param add_decoration (`flag`)\cr whether adds title and footer decorations should
|
|
800 |
#' be added to the matrix form.
|
|
801 |
#' @param split_labels (`string`)\cr indicates which column to use as split labels. If
|
|
802 |
#' `NULL`, no split labels are used.
|
|
803 |
#' @param data_labels (`string`)\cr indicates which column to use as data labels. It is
|
|
804 |
#' ignored if no `split_labels` is present and is automatically assigned to
|
|
805 |
#' `"Analysis method"` when `split_labels` is present, but `data_labels` is `NULL`.
|
|
806 |
#' Its direct column name is used as node name in `"DataRow"` pathing. See [mf_rinfo()]
|
|
807 |
#' for more information.
|
|
808 |
#'
|
|
809 |
#' @return A valid `MatrixPrintForm` object representing `df` that is ready for
|
|
810 |
#' ASCII rendering.
|
|
811 |
#'
|
|
812 |
#' @details
|
|
813 |
#' If some of the column has a [obj_format] assigned, it will be respected for all column
|
|
814 |
#' values except for label rows, if present (see parameter `split_labels`).
|
|
815 |
#'
|
|
816 |
#' @examples
|
|
817 |
#' mform <- basic_matrix_form(mtcars)
|
|
818 |
#' cat(toString(mform))
|
|
819 |
#'
|
|
820 |
#' # Advanced test case with label rows
|
|
821 |
#' library(dplyr)
|
|
822 |
#' iris_output <- iris %>%
|
|
823 |
#' group_by(Species) %>%
|
|
824 |
#' summarize("all obs" = round(mean(Petal.Length), 2)) %>%
|
|
825 |
#' mutate("DataRow_label" = "Mean")
|
|
826 |
#' mf <- basic_matrix_form(iris_output,
|
|
827 |
#' indent_rownames = TRUE,
|
|
828 |
#' split_labels = "Species", data_labels = "DataRow_label"
|
|
829 |
#' )
|
|
830 |
#' cat(toString(mf))
|
|
831 |
#'
|
|
832 |
#' @name test_matrix_form
|
|
833 |
#' @export
|
|
834 |
basic_matrix_form <- function(df, |
|
835 |
indent_rownames = FALSE, |
|
836 |
parent_path = NULL, |
|
837 |
ignore_rownames = FALSE, |
|
838 |
add_decoration = FALSE, |
|
839 |
split_labels = NULL, |
|
840 |
data_labels = NULL) { |
|
841 | 48x |
checkmate::assert_data_frame(df) |
842 | 48x |
checkmate::assert_flag(indent_rownames) |
843 | 48x |
checkmate::assert_character(parent_path, null.ok = TRUE) |
844 | 48x |
checkmate::assert_flag(ignore_rownames) |
845 | 48x |
checkmate::assert_flag(add_decoration) |
846 | 48x |
checkmate::assert_character(split_labels, null.ok = TRUE) |
847 | 48x |
checkmate::assert_character(data_labels, null.ok = TRUE) |
848 | ||
849 |
# Some defaults
|
|
850 | 48x |
row_classes <- "DataRow" # Default for all rows |
851 | 48x |
data_row_format <- "xx" # Default if no labels are used |
852 | 48x |
indent_size <- 2 |
853 | 48x |
indent_space <- paste0(rep(" ", indent_size), collapse = "") |
854 | ||
855 |
# Pre-processing the fake split
|
|
856 | 48x |
if (!is.null(split_labels)) { |
857 | 4x |
checkmate::assert_choice(split_labels, colnames(df)) |
858 | 4x |
label_rows <- as.character(df[[split_labels]]) |
859 | 4x |
if (is.null(data_labels)) { |
860 | ! |
data_rows <- rep("Analysis Method", nrow(df)) |
861 | ! |
data_labels <- "Analyzed Variable" |
862 |
} else { |
|
863 | 4x |
checkmate::assert_choice(data_labels, colnames(df)) |
864 | 4x |
data_rows <- as.character(df[[data_labels]]) |
865 |
}
|
|
866 | 4x |
rnms_special <- c(rbind(label_rows, data_rows)) |
867 | 4x |
row_classes <- c(rbind( |
868 | 4x |
rep("LabelRow", length(label_rows)), |
869 | 4x |
rep("DataRow", length(data_rows)) |
870 |
)) |
|
871 | 4x |
data_colnm <- setdiff(colnames(df), c(split_labels, data_labels)) |
872 | 4x |
tmp_df <- NULL |
873 | 4x |
for (col_i in seq_along(data_colnm)) { |
874 | 8x |
lbl_and_dt <- c(rbind(rep("", length(label_rows)), df[[data_colnm[col_i]]])) |
875 | 8x |
tmp_df <- cbind(tmp_df, lbl_and_dt) |
876 |
}
|
|
877 | 4x |
colnames(tmp_df) <- data_colnm |
878 | 4x |
rownames(tmp_df) <- NULL |
879 | 4x |
df <- as.data.frame(tmp_df) |
880 | 4x |
ignore_rownames <- FALSE |
881 |
}
|
|
882 | ||
883 |
# Formats
|
|
884 | 48x |
fmts <- lapply(df, function(x) { |
885 | 288x |
if (is.null(obj_format(x))) { |
886 | 288x |
fmt_tmp <- data_row_format |
887 |
} else { |
|
888 | ! |
fmt_tmp <- obj_format(x) # Can be assigned for each column |
889 |
}
|
|
890 | 288x |
out <- rep(fmt_tmp, NROW(df)) |
891 | 288x |
if (!is.null(split_labels)) { |
892 | 8x |
out[row_classes == "LabelRow"] <- "-" |
893 |
}
|
|
894 | 288x |
out
|
895 |
}) |
|
896 | ||
897 | 48x |
formats <- rbind("", data.frame(fmts)) |
898 | 48x |
if (!ignore_rownames) { |
899 | 38x |
formats <- cbind("rnms" = "", formats) |
900 |
}
|
|
901 | ||
902 |
# Strings
|
|
903 | 48x |
bodystrs <- mapply(function(x, coli_fmt) { |
904 | 288x |
coli_fmt[coli_fmt == "-"] <- "xx" |
905 | 288x |
sapply(seq_along(x), function(y) { |
906 | 8685x |
format_value(x[y], format = coli_fmt[y]) |
907 |
}) |
|
908 | 48x |
}, x = df, coli_fmt = fmts) |
909 | ||
910 | 48x |
if (!ignore_rownames) { |
911 | 38x |
rnms <- row.names(df) |
912 | 38x |
if (!is.null(split_labels)) { |
913 |
# This overload is done because identical rownames not allowed (e.g. Mean.1 Mean.2)
|
|
914 | 4x |
rnms <- rnms_special |
915 | 34x |
} else if (is.null(rnms)) { |
916 | ! |
rnms <- as.character(seq_len(NROW(df))) |
917 |
}
|
|
918 |
}
|
|
919 | ||
920 | 48x |
strings <- rbind(colnames(df), bodystrs) |
921 | 48x |
rownames(strings) <- NULL |
922 | 48x |
if (!ignore_rownames) { |
923 | 38x |
strings <- cbind("rnms" = c("", rnms), strings) |
924 |
}
|
|
925 |
# colnames(strings) <- NULL # to add after fixing basic_mf for listings
|
|
926 | ||
927 |
# Spans
|
|
928 | 48x |
spans <- matrix(1, nrow = nrow(strings), ncol = ncol(strings)) |
929 | ||
930 |
# Aligns
|
|
931 |
# Default alignment is left for rownames column and center for the rest
|
|
932 | 48x |
aligns <- matrix("center", |
933 | 48x |
nrow = NROW(strings), |
934 | 48x |
ncol = NCOL(strings) - as.numeric(!ignore_rownames) |
935 |
)
|
|
936 | 48x |
if (!ignore_rownames) { |
937 | 38x |
aligns <- cbind("left", aligns) |
938 |
}
|
|
939 | ||
940 |
# Row Info: build up fake pagination df
|
|
941 | 48x |
charcols <- which(sapply(df, is.character)) |
942 | 48x |
if (length(charcols) > 0) { |
943 | 11x |
exts <- apply(df[, charcols, drop = FALSE], 1, function(x) max(vapply(x, nlines, 1L))) |
944 |
} else { |
|
945 | 37x |
exts <- rep(1L, NROW(df)) |
946 |
}
|
|
947 |
# Constructing path roughly
|
|
948 | 48x |
if (!is.null(split_labels)) { |
949 | 4x |
paths <- lapply( |
950 | 4x |
seq_along(rnms), |
951 | 4x |
function(row_path_i) { |
952 | 24x |
if (row_classes[row_path_i] == "DataRow") { |
953 | 12x |
c( |
954 | 12x |
split_labels,
|
955 | 12x |
rnms[row_path_i - 1], # LabelRow before |
956 | 12x |
data_labels,
|
957 | 12x |
rnms[row_path_i] |
958 |
)
|
|
959 |
} else { |
|
960 | 12x |
c(split_labels, rnms[row_path_i]) |
961 |
}
|
|
962 |
}
|
|
963 |
)
|
|
964 |
} else { |
|
965 | 44x |
rnms <- row.names(df) |
966 | 44x |
if (is.null(rnms)) { |
967 | ! |
rnms <- as.character(seq_len(NROW(df))) |
968 |
}
|
|
969 | 44x |
paths <- lapply(rnms, function(x) c(parent_path, x)) |
970 |
}
|
|
971 | 48x |
rowdf <- basic_pagdf( |
972 | 48x |
rnames = rnms, |
973 | 48x |
extents = exts, |
974 | 48x |
rclass = row_classes, |
975 | 48x |
parent_path = NULL, # Overloaded by above parent_path lapply |
976 | 48x |
paths = paths |
977 |
)
|
|
978 | ||
979 |
# Indentation happens last so to be sure we have all ready (only strings and formats change)
|
|
980 | 48x |
if (indent_rownames && !is.null(split_labels)) { |
981 | 2x |
where_to_indent <- which(row_classes == "DataRow") + 1 # +1 because of colnames |
982 | 2x |
strings[where_to_indent, 1] <- paste0(indent_space, strings[where_to_indent, 1]) |
983 | 2x |
formats[where_to_indent, 1] <- paste0(indent_space, formats[where_to_indent, 1]) # Needs fixing |
984 | 2x |
rowdf$indent[where_to_indent - 1] <- 1 # -1 because only rows |
985 |
}
|
|
986 | ||
987 | 48x |
ret <- MatrixPrintForm( |
988 | 48x |
strings = strings, |
989 | 48x |
aligns = aligns, |
990 | 48x |
spans = spans, |
991 | 48x |
formats = formats, ## matrix("xx", nrow = fnr, ncol = fnc), |
992 | 48x |
row_info = rowdf, |
993 | 48x |
has_topleft = FALSE, |
994 | 48x |
nlines_header = 1, |
995 | 48x |
nrow_header = 1, |
996 | 48x |
has_rowlabs = isFALSE(ignore_rownames), |
997 | 48x |
indent_size = indent_size, |
998 |
)
|
|
999 | ||
1000 |
# Check for ncols
|
|
1001 | 48x |
stopifnot(mf_has_rlabels(ret) == isFALSE(ignore_rownames)) |
1002 | ||
1003 | 48x |
ret <- mform_build_refdf(ret) |
1004 | ||
1005 | 48x |
if (add_decoration) { |
1006 | 7x |
main_title(ret) <- "main title" |
1007 | 7x |
main_footer(ret) <- c("main", " footer") |
1008 | 7x |
prov_footer(ret) <- "prov footer" |
1009 | 7x |
subtitles(ret) <- c("sub", "titles") |
1010 |
}
|
|
1011 | ||
1012 | 48x |
ret
|
1013 |
}
|
|
1014 | ||
1015 |
#' @describeIn test_matrix_form Create a `MatrixPrintForm` object from data frame `df` that
|
|
1016 |
#' respects the default formats for a listing object.
|
|
1017 |
#'
|
|
1018 |
#' @param keycols (`character`)\cr a vector of `df` column names that are printed first and for which
|
|
1019 |
#' repeated values are assigned `""`. This format is characteristic of a listing matrix form.
|
|
1020 |
#'
|
|
1021 |
#' @return A valid `MatrixPrintForm` object representing `df` as a listing that is ready for ASCII
|
|
1022 |
#' rendering.
|
|
1023 |
#'
|
|
1024 |
#' @examples
|
|
1025 |
#' mform <- basic_listing_mf(mtcars)
|
|
1026 |
#' cat(toString(mform))
|
|
1027 |
#'
|
|
1028 |
#' @export
|
|
1029 |
basic_listing_mf <- function(df, |
|
1030 |
keycols = names(df)[1], |
|
1031 |
add_decoration = TRUE) { |
|
1032 | 8x |
checkmate::assert_data_frame(df) |
1033 | 8x |
checkmate::assert_subset(keycols, colnames(df)) |
1034 | ||
1035 | 8x |
dfmf <- basic_matrix_form( |
1036 | 8x |
df = df, |
1037 | 8x |
indent_rownames = FALSE, |
1038 | 8x |
ignore_rownames = TRUE, |
1039 | 8x |
add_decoration = add_decoration |
1040 |
)
|
|
1041 | ||
1042 |
# keycols addition to MatrixPrintForm (should happen in the constructor)
|
|
1043 | 8x |
dfmf$listing_keycols <- keycols |
1044 | ||
1045 |
# Modifications needed for making it a listings
|
|
1046 | 8x |
mf_strings(dfmf)[1, ] <- colnames(mf_strings(dfmf)) # set colnames |
1047 | ||
1048 | 8x |
if (!is.null(keycols)) { |
1049 | 8x |
str_dfmf <- mf_strings(dfmf)[-1, ] |
1050 |
# Ordering
|
|
1051 | 8x |
ord <- do.call( |
1052 | 8x |
order,
|
1053 | 8x |
as.list( |
1054 | 8x |
data.frame( |
1055 | 8x |
str_dfmf[, keycols] |
1056 |
)
|
|
1057 |
)
|
|
1058 |
)
|
|
1059 | 8x |
str_dfmf <- str_dfmf[ord, ] |
1060 |
# Making keycols with empties
|
|
1061 | 8x |
curkey <- "" |
1062 | 8x |
for (i in seq_along(keycols)) { |
1063 | 15x |
kcol <- keycols[i] |
1064 | 15x |
kcolvec <- str_dfmf[, kcol] # -1 is col label row |
1065 | 15x |
str_dfmf[, kcol] <- "" |
1066 | 15x |
kcolvec <- vapply(kcolvec, format_value, "", format = NULL, na_str = "NA") |
1067 | 15x |
curkey <- paste0(curkey, kcolvec) |
1068 | 15x |
disp <- c(TRUE, tail(curkey, -1) != head(curkey, -1)) |
1069 | 15x |
str_dfmf[disp, kcol] <- kcolvec[disp] |
1070 |
}
|
|
1071 | 8x |
mf_strings(dfmf)[-1, ] <- str_dfmf |
1072 |
# keycols as first
|
|
1073 | 8x |
mf_strings(dfmf) <- cbind( |
1074 | 8x |
mf_strings(dfmf)[, keycols, drop = FALSE], |
1075 | 8x |
mf_strings(dfmf)[, !colnames(mf_strings(dfmf)) %in% keycols, drop = FALSE] |
1076 |
)
|
|
1077 |
}
|
|
1078 | ||
1079 | 8x |
dfmf$aligns[seq(2, nrow(dfmf$aligns)), ] <- "center" # the default for listings |
1080 | ||
1081 |
# the default for listings is a 1 double??
|
|
1082 | 8x |
dfmf$formats <- matrix(1, nrow = nrow(dfmf$formats), ncol = ncol(dfmf$formats)) |
1083 | ||
1084 |
# row info
|
|
1085 | 8x |
ri <- dfmf$row_info |
1086 | 8x |
rownames(ri) <- ri$abs_rownumber |
1087 | 8x |
ri$label <- ri$name <- "" |
1088 | 8x |
ri$path <- as.list(NA_character_) # same format of listings |
1089 | 8x |
ri$node_class <- "listing_df" |
1090 |
# l_ri$pos_in_siblings # why is it like this in rlistings?? also n_siblings
|
|
1091 | 8x |
class(ri$path) <- "AsIs" # Artifact from I() |
1092 | 8x |
dfmf$row_info <- ri |
1093 | ||
1094 |
# colwidths need to be sorted too!!
|
|
1095 | 8x |
dfmf$col_widths <- dfmf$col_widths[colnames(mf_strings(dfmf))] |
1096 | ||
1097 | 8x |
if (!add_decoration) { |
1098 |
# This is probably a forced behavior in the original matrix_form in rlistings
|
|
1099 | 2x |
main_title(dfmf) <- character() |
1100 | 2x |
main_footer(dfmf) <- character() |
1101 |
}
|
|
1102 | ||
1103 | 8x |
dfmf
|
1104 |
}
|
|
1105 | ||
1106 |
map_to_new <- function(old, map) { |
|
1107 | 412x |
inds <- match(old, map$old_idx) |
1108 | 412x |
map$new_idx[inds] |
1109 |
}
|
|
1110 | ||
1111 |
reconstruct_basic_fnote_list <- function(mf) { |
|
1112 | 318x |
refdf <- mf_fnote_df(mf) |
1113 | 318x |
if (NROW(refdf) == 0) { |
1114 | 278x |
return(NULL) |
1115 |
}
|
|
1116 | 40x |
refdf <- refdf[!duplicated(refdf$symbol), ] |
1117 | 40x |
paste0("{", refdf$symbol, "} - ", refdf$msg) |
1118 |
}
|
|
1119 | ||
1120 |
.mf_subset_core_mats <- function(mf, i, keycols = NULL, row = TRUE) { |
|
1121 | 316x |
fillnum <- if (row) nrow(mf_strings(mf)) - mf_nlheader(mf) else mf_ncol(mf) |
1122 | 316x |
if (is.logical(i) || all(i < 0)) { |
1123 | ! |
i <- seq_len(fillnum)[i] |
1124 |
}
|
|
1125 | 316x |
nlh <- mf_nlheader(mf) |
1126 | ||
1127 | 316x |
if (row) { |
1128 | 96x |
ncolrows <- mf_nrheader(mf) |
1129 | 96x |
i_mat <- c(seq_len(nlh), which(mf_lgrouping(mf) %in% (i + ncolrows))) |
1130 | 96x |
j_mat <- seq_len(ncol(mf_strings(mf))) |
1131 |
} else { |
|
1132 | 220x |
nlabcol <- as.integer(mf_has_rlabels(mf)) |
1133 | 220x |
i_mat <- seq_len(nrow(mf_strings(mf))) |
1134 | 220x |
j_mat <- c(seq_len(nlabcol), i + nlabcol) |
1135 |
}
|
|
1136 | ||
1137 | 316x |
tmp_strmat <- mf_strings(mf)[i_mat, j_mat, drop = FALSE] |
1138 | ||
1139 |
# Only for listings - Fix pagination with empty values in key columns
|
|
1140 | 316x |
if (nrow(tmp_strmat) > 0 && .is_listing_mf(mf)) { # safe check for empty listings |
1141 | 39x |
ind_keycols <- which(colnames(tmp_strmat) %in% keycols) |
1142 | ||
1143 |
# Fix for missing labels in key columns (only for rlistings)
|
|
1144 | 39x |
empty_keycols <- !nzchar(tmp_strmat[-seq_len(nlh), ind_keycols, drop = FALSE][1, ]) |
1145 | ||
1146 | 39x |
if (any(empty_keycols)) { # only if there are missing keycol labels |
1147 |
# find the first non-empty label in the key columns
|
|
1148 | 6x |
keycols_needed <- mf_strings(mf)[, empty_keycols, drop = FALSE] |
1149 | 6x |
first_nonempty <- apply(keycols_needed, 2, function(x) { |
1150 | 16x |
section_ind <- i_mat[-seq_len(nlh)][1] |
1151 | 16x |
sec_ind_no_header <- seq_len(section_ind)[-seq_len(nlh)] |
1152 | 16x |
tail(x[sec_ind_no_header][nzchar(x[sec_ind_no_header])], 1) |
1153 |
}) |
|
1154 | ||
1155 |
# if there are only "" the previous returns character()
|
|
1156 | 6x |
any_chr_empty <- if (length(first_nonempty) > 1) { |
1157 | 6x |
vapply(first_nonempty, length, numeric(1)) |
1158 |
} else { |
|
1159 | ! |
length(first_nonempty) |
1160 |
}
|
|
1161 | 6x |
if (any(any_chr_empty == 0L)) { |
1162 | ! |
warning( |
1163 | ! |
"There are empty key columns in the listing. ",
|
1164 | ! |
"We keep empty strings for each page."
|
1165 |
)
|
|
1166 | ! |
first_nonempty[any_chr_empty == 0L] <- "" |
1167 |
}
|
|
1168 | ||
1169 |
# replace the empty labels with the first non-empty label
|
|
1170 | 6x |
tmp_strmat[nlh + 1, empty_keycols] <- unlist(first_nonempty) |
1171 |
}
|
|
1172 |
}
|
|
1173 | ||
1174 | 316x |
mf_strings(mf) <- tmp_strmat |
1175 | ||
1176 | 316x |
mf_lgrouping(mf) <- as.integer(as.factor(mf_lgrouping(mf)[i_mat])) |
1177 | ||
1178 | 316x |
if (!row) { |
1179 | 220x |
newspans <- truncate_spans(mf_spans(mf), j_mat) # 'i' is the columns here, bc row is FALSE |
1180 |
} else { |
|
1181 | 96x |
newspans <- mf_spans(mf)[i_mat, j_mat, drop = FALSE] |
1182 |
}
|
|
1183 | ||
1184 | 316x |
mf_spans(mf) <- newspans |
1185 | 316x |
mf_formats(mf) <- mf_formats(mf)[i_mat, j_mat, drop = FALSE] |
1186 | ||
1187 | 316x |
mf_aligns(mf) <- mf_aligns(mf)[i_mat, j_mat, drop = FALSE] |
1188 | 316x |
if (!row) { |
1189 | 220x |
mf_ncol(mf) <- length(i) |
1190 | 220x |
if (!is.null(mf_col_widths(mf))) { |
1191 | 220x |
mf_col_widths(mf) <- mf_col_widths(mf)[j_mat] |
1192 |
}
|
|
1193 |
}
|
|
1194 | 316x |
mf
|
1195 |
}
|
|
1196 | ||
1197 |
## ugh. spans are **way** more of a pain than I expected x.x
|
|
1198 |
truncate_one_span <- function(spanrow, j) { |
|
1199 | 3793x |
i <- 1 |
1200 | 3793x |
len <- length(spanrow) |
1201 | 3793x |
while (i < len) { |
1202 | 41757x |
spnlen <- spanrow[i] |
1203 | 41757x |
inds <- seq(i, i + spnlen - 1) |
1204 | 41757x |
newspnlen <- sum(inds %in% j) |
1205 | 41757x |
spanrow[inds] <- newspnlen |
1206 | 41757x |
i <- i + spnlen |
1207 |
}
|
|
1208 | 3793x |
spanrow[j] |
1209 |
}
|
|
1210 | ||
1211 |
truncate_spans <- function(spans, j) { |
|
1212 | 220x |
if (length(spans[1, ]) == 1) { |
1213 | ! |
as.matrix(apply(spans, 1, truncate_one_span, j = j)) |
1214 |
} else { |
|
1215 | 220x |
t(apply(spans, 1, truncate_one_span, j = j)) |
1216 |
}
|
|
1217 |
}
|
|
1218 | ||
1219 |
mpf_subset_rows <- function(mf, i, keycols = NULL) { |
|
1220 | 96x |
nlh <- mf_nlheader(mf) |
1221 | 96x |
lgrps <- mf_lgrouping(mf) |
1222 | 96x |
row_lgrps <- tail(lgrps, -1 * nlh) |
1223 | 96x |
nrs <- length(unique(row_lgrps)) |
1224 | 96x |
ncolrows <- length(unique(lgrps[seq_len(nlh)])) |
1225 | ||
1226 | 96x |
ncs <- mf_ncol(mf) |
1227 | 96x |
mf <- .mf_subset_core_mats(mf, i, keycols = keycols, row = TRUE) |
1228 | 96x |
map <- data.frame( |
1229 | 96x |
old_idx = c(seq_len(ncolrows), i + ncolrows), |
1230 | 96x |
new_idx = c(seq_len(ncolrows), ncolrows + order(i)) |
1231 |
)
|
|
1232 | ||
1233 | 96x |
row_map <- data.frame(old_idx = i, new_idx = order(i)) |
1234 | ||
1235 | 96x |
refdf <- mf_fnote_df(mf) |
1236 | ||
1237 | 96x |
old_nas <- is.na(refdf$row) |
1238 | 96x |
refdf$row <- map_to_new(refdf$row, row_map) |
1239 | 96x |
refdf <- refdf[old_nas | !is.na(refdf$row), ] |
1240 | 96x |
mf_fnote_df(mf) <- refdf |
1241 | ||
1242 | 96x |
rinfo <- mf_rinfo(mf) |
1243 | ||
1244 | 96x |
rinfo <- rinfo[rinfo$abs_rownumber %in% i, ] |
1245 | ||
1246 | 96x |
rinfo$abs_rownumber <- map_to_new(rinfo$abs_rownumber, row_map) |
1247 | 96x |
mf_rinfo(mf) <- rinfo |
1248 | ||
1249 | 96x |
mf <- shove_refdf_into_rowinfo(mf) |
1250 | 96x |
mf_rfnotes(mf) <- reconstruct_basic_fnote_list(mf) |
1251 | 96x |
mf
|
1252 |
}
|
|
1253 | ||
1254 |
## we only care about referential footnotes, cause
|
|
1255 |
## they are currently the only place we're tracking
|
|
1256 |
## column information that will need to be touched up
|
|
1257 |
## but lets be careful and do a bit more anyway
|
|
1258 |
mpf_subset_cols <- function(mf, j, keycols = NULL) { |
|
1259 | 220x |
nc <- mf_ncol(mf) |
1260 | 220x |
if (is.logical(j) || all(j < 0)) { |
1261 | ! |
j <- seq_len(nc)[j] |
1262 |
}
|
|
1263 | 220x |
if (any(j < 0)) { |
1264 | ! |
stop("cannot mix negative and positive indices") |
1265 |
}
|
|
1266 | ||
1267 | 220x |
if (length(unique(j)) != length(j)) { |
1268 | ! |
stop("duplicated columns are not allowed when subsetting a matrix print form objects") |
1269 |
}
|
|
1270 | ||
1271 |
# j_mat <- c(if(mf_has_topleft(mf)) seq_len(nlabcol), j + nlabcol)
|
|
1272 | 220x |
map <- data.frame(old_idx = j, new_idx = order(j)) |
1273 | ||
1274 |
## this has to happen before the remap inher
|
|
1275 | 220x |
refdf <- mf_fnote_df(mf) |
1276 | ||
1277 | 220x |
mf <- .mf_subset_core_mats(mf, j, keycols = keycols, row = FALSE) |
1278 | ||
1279 |
## future proofing (pipe dreams)
|
|
1280 |
## uncomment if we ever manage to have col info information on MPFs
|
|
1281 |
## if(!is.null(mf_cinfo(mf))) {
|
|
1282 |
## cinfo <- mf_cinfo(mf)
|
|
1283 |
## cinfo <- cinfo[j, , drop = FALSE]
|
|
1284 |
## cinfo$abs_pos <- map_to_new(cinfo$abs_pos, map)
|
|
1285 |
## mf_cinfo(mf) <- mf
|
|
1286 |
## }
|
|
1287 | ||
1288 | 220x |
keep <- is.na(refdf$col) | refdf$col %in% j |
1289 | 220x |
refdf <- refdf[keep, , drop = FALSE] |
1290 | ||
1291 | 220x |
refdf$col <- map_to_new(refdf$col, map) |
1292 | 220x |
mf_fnote_df(mf) <- refdf |
1293 | 220x |
mf <- shove_refdf_into_rowinfo(mf) |
1294 | 220x |
mf_rfnotes(mf) <- reconstruct_basic_fnote_list(mf) |
1295 | 220x |
mf_ncol(mf) <- length(j) |
1296 | 220x |
mf
|
1297 |
}
|
1 |
### This file defines the generics which make up the interface `formatters` offers.
|
|
2 |
### Defining methods for these generics for a new table-like class should be fully
|
|
3 |
### sufficient for hooking that class up to the `formatters` pagination and rendering
|
|
4 |
### machinery.
|
|
5 | ||
6 |
#' Make row layout summary data frames for use during pagination
|
|
7 |
#'
|
|
8 |
#' All relevant information about table rows (e.g. indentations) is summarized in a `data.frame`.
|
|
9 |
#' This function works **only** on `rtables` and `rlistings` objects, and not on their `print` counterparts
|
|
10 |
#' (like [`MatrixPrintForm`]).
|
|
11 |
#'
|
|
12 |
#' @param tt (`ANY`)\cr object representing the table-like object to be summarized.
|
|
13 |
#' @param visible_only (`flag`)\cr should only visible aspects of the table structure be reflected
|
|
14 |
#' in this summary. Defaults to `TRUE`. May not be supported by all methods.
|
|
15 |
#' @param incontent (`flag`)\cr internal detail, do not set manually.
|
|
16 |
#' @param repr_ext (`integer(1)`)\cr internal detail, do not set manually.
|
|
17 |
#' @param repr_inds (`integer`)\cr internal detail, do not set manually.
|
|
18 |
#' @param sibpos (`integer(1)`)\cr internal detail, do not set manually.
|
|
19 |
#' @param nsibs (`integer(1)`)\cr internal detail, do not set manually.
|
|
20 |
#' @param rownum (`numeric(1)`)\cr internal detail, do not set manually.
|
|
21 |
#' @param indent (`integer(1)`)\cr internal detail, do not set manually.
|
|
22 |
#' @param colwidths (`numeric`)\cr internal detail, do not set manually.
|
|
23 |
#' @param path (`character`)\cr path to the (sub)table represented by `tt`. Defaults to `character()`.
|
|
24 |
#' @param max_width (`numeric(1)` or `NULL`)\cr maximum width for title/footer materials.
|
|
25 |
#'
|
|
26 |
#' @import methods
|
|
27 |
#' @include matrix_form.R
|
|
28 |
#'
|
|
29 |
#' @details
|
|
30 |
#' When `visible_only` is `TRUE` (the default), methods should return a `data.frame` with exactly one
|
|
31 |
#' row per visible row in the table-like object. This is useful when reasoning about how a table will
|
|
32 |
#' print, but does not reflect the full pathing space of the structure (though the paths which are given
|
|
33 |
#' will all work as is).
|
|
34 |
#'
|
|
35 |
#' If supported, when `visible_only` is `FALSE`, every structural element of the table (in row-space)
|
|
36 |
#' will be reflected in the returned `data.frame`, meaning the full pathing-space will be represented
|
|
37 |
#' but some rows in the layout summary will not represent printed rows in the table as it is displayed.
|
|
38 |
#'
|
|
39 |
#' Most arguments beyond `tt` and `visible_only` are present so that `make_row_df` methods can call
|
|
40 |
#' `make_row_df` recursively and retain information, and should not be set during a top-level call.
|
|
41 |
#'
|
|
42 |
#' @return A `data.frame` of row/column-structure information used by the pagination machinery.
|
|
43 |
#'
|
|
44 |
#' @note The technically present root tree node is excluded from the summary returned by
|
|
45 |
#' both `make_row_df` and `make_col_df` (see [rtables::make_col_df()]), as it is simply the
|
|
46 |
#' row/column structure of `tt` and thus not useful for pathing or pagination.
|
|
47 |
#'
|
|
48 |
#' @examples
|
|
49 |
#' # Expected error with matrix_form. For real case examples consult {rtables} documentation
|
|
50 |
#' mf <- basic_matrix_form(iris)
|
|
51 |
#' # make_row_df(mf) # Use table obj instead
|
|
52 |
#'
|
|
53 |
#' @export
|
|
54 |
#' @name make_row_df
|
|
55 |
setGeneric("make_row_df", function(tt, colwidths = NULL, visible_only = TRUE, |
|
56 |
rownum = 0, |
|
57 |
indent = 0L, |
|
58 |
path = character(), |
|
59 |
incontent = FALSE, |
|
60 |
repr_ext = 0L, |
|
61 |
repr_inds = integer(), |
|
62 |
sibpos = NA_integer_, |
|
63 |
nsibs = NA_integer_, |
|
64 |
max_width = NULL) { |
|
65 | 1x |
standardGeneric("make_row_df") |
66 |
}) |
|
67 | ||
68 |
#' @rdname make_row_df
|
|
69 |
setMethod("make_row_df", "MatrixPrintForm", function(tt, colwidths = NULL, visible_only = TRUE, |
|
70 |
rownum = 0, |
|
71 |
indent = 0L, |
|
72 |
path = character(), |
|
73 |
incontent = FALSE, |
|
74 |
repr_ext = 0L, |
|
75 |
repr_inds = integer(), |
|
76 |
sibpos = NA_integer_, |
|
77 |
nsibs = NA_integer_, |
|
78 |
max_width = NULL) { |
|
79 | 1x |
msg <- paste0( |
80 | 1x |
"make_row_df can be used only on {rtables} table objects, and not on `matrix_form`-",
|
81 | 1x |
"generated objects (MatrixPrintForm)."
|
82 |
)
|
|
83 | 1x |
stop(msg) |
84 |
}) |
|
85 | ||
86 |
#' Transform `rtable` to a list of matrices which can be used for outputting
|
|
87 |
#'
|
|
88 |
#' Although `rtable`s are represented as a tree data structure when outputting the table to ASCII or HTML,
|
|
89 |
#' it is useful to map the `rtable` to an in-between state with the formatted cells in a matrix form.
|
|
90 |
#'
|
|
91 |
#' @param obj (`ANY`)\cr object to be transformed into a ready-to-render form (a [`MatrixPrintForm`] object).
|
|
92 |
#' @param indent_rownames (`flag`)\cr if `TRUE`, the row names column in the `strings` matrix of `obj`
|
|
93 |
#' will have indented row names (strings pre-fixed).
|
|
94 |
#' @param expand_newlines (`flag`)\cr whether the generated matrix form should expand rows whose values
|
|
95 |
#' contain newlines into multiple 'physical' rows (as they will appear when rendered into ASCII). Defaults
|
|
96 |
#' to `TRUE`.
|
|
97 |
#' @param indent_size (`numeric(1)`)\cr number of spaces to be used per level of indent (if supported by
|
|
98 |
#' the relevant method). Defaults to 2.
|
|
99 |
#'
|
|
100 |
#' @return A [`MatrixPrintForm`] classed list with an additional `nrow_header` attribute indicating the
|
|
101 |
#' number of pseudo "rows" the column structure defines, with the following elements:
|
|
102 |
#' \describe{
|
|
103 |
#' \item{`strings`}{The content, as it should be printed, of the top-left material, column headers, row
|
|
104 |
#' labels, and cell values of `tt`.}
|
|
105 |
#' \item{`spans`}{The column-span information for each print-string in the strings matrix.}
|
|
106 |
#' \item{`aligns`}{The text alignment for each print-string in the strings matrix.}
|
|
107 |
#' \item{`display`}{Whether each print-string in the strings matrix should be printed or not.}
|
|
108 |
#' \item{`row_info`}{The `data.frame` generated by [basic_pagdf()].}
|
|
109 |
#' }
|
|
110 |
#'
|
|
111 |
#' @export
|
|
112 |
setGeneric("matrix_form", function(obj, |
|
113 |
indent_rownames = FALSE, |
|
114 |
expand_newlines = TRUE, |
|
115 |
indent_size = 2) { |
|
116 | 370x |
standardGeneric("matrix_form") |
117 |
}) |
|
118 | ||
119 | ||
120 |
#' @rdname matrix_form
|
|
121 |
#' @export
|
|
122 |
setMethod("matrix_form", "MatrixPrintForm", function(obj, |
|
123 |
indent_rownames = FALSE, |
|
124 |
expand_newlines = TRUE, |
|
125 |
indent_size = 2) { |
|
126 | 370x |
obj
|
127 |
}) |
|
128 | ||
129 |
# Generics for `toString` and helper functions -----------------------------------------------------------
|
|
130 | ||
131 |
## this is where we will take word wrapping
|
|
132 |
## into account when it is added
|
|
133 |
##
|
|
134 |
## ALL calculations of vertical space for pagination
|
|
135 |
## purposes must go through nlines and divider_height!!!!!!!!
|
|
136 | ||
137 |
## this will be customizable someday. I have foreseen it (spooky noises)
|
|
138 |
#' Divider height
|
|
139 |
#'
|
|
140 |
#' @param obj (`ANY`)\cr object.
|
|
141 |
#'
|
|
142 |
#' @return The height, in lines of text, of the divider between header and body. Currently
|
|
143 |
#' returns `1L` for the default method.
|
|
144 |
#'
|
|
145 |
#' @examples
|
|
146 |
#' divider_height(mtcars)
|
|
147 |
#'
|
|
148 |
#' @export
|
|
149 | 49x |
setGeneric("divider_height", function(obj) standardGeneric("divider_height")) |
150 | ||
151 |
#' @rdname divider_height
|
|
152 |
#' @export
|
|
153 |
setMethod( |
|
154 |
"divider_height", "ANY", |
|
155 | 49x |
function(obj) 1L |
156 |
)
|
|
157 | ||
158 |
# nlines ---------------------------------------------------------------
|
|
159 | ||
160 |
#' Number of lines required to print a value
|
|
161 |
#'
|
|
162 |
#' @param x (`ANY`)\cr the object to be printed.
|
|
163 |
#' @param colwidths (`numeric`)\cr column widths (if necessary).
|
|
164 |
#' @param max_width (`numeric(1)`)\cr width that strings should be wrapped to when
|
|
165 |
#' determining how many lines they require.
|
|
166 |
#'
|
|
167 |
#' @return The number of lines needed to render the object `x`.
|
|
168 |
#'
|
|
169 |
#' @export
|
|
170 |
setGeneric( |
|
171 |
"nlines",
|
|
172 | 51369x |
function(x, colwidths = NULL, max_width = NULL) standardGeneric("nlines") |
173 |
)
|
|
174 | ||
175 |
## XXX beware. I think it is dangerous
|
|
176 |
#' @export
|
|
177 |
#' @rdname nlines
|
|
178 |
setMethod( |
|
179 |
"nlines", "list", |
|
180 |
function(x, colwidths, max_width) { |
|
181 | 2x |
if (length(x) == 0) { |
182 | 1x |
0L
|
183 |
} else { |
|
184 | 1x |
sum(unlist(vapply(x, nlines, NA_integer_, colwidths = colwidths, max_width = max_width))) |
185 |
}
|
|
186 |
}
|
|
187 |
)
|
|
188 | ||
189 |
#' @export
|
|
190 |
#' @rdname nlines
|
|
191 |
setMethod("nlines", "NULL", function(x, colwidths, max_width) 0L) |
|
192 | ||
193 |
#' @export
|
|
194 |
#' @rdname nlines
|
|
195 |
setMethod("nlines", "character", function(x, colwidths, max_width) { |
|
196 | 51366x |
if (length(x) == 0) { |
197 | 1x |
return(0L) |
198 |
}
|
|
199 | ||
200 | 51365x |
sum(vapply(strsplit(x, "\n", fixed = TRUE), |
201 | 51365x |
function(xi, max_width) { |
202 | 51414x |
if (length(xi) == 0) { |
203 | 1522x |
1L
|
204 | 49892x |
} else if (length(max_width) == 0) { ## this happens with strsplit("", "\n") |
205 | 49770x |
length(xi) |
206 |
} else { |
|
207 | 122x |
length(wrap_txt(xi, max_width)) |
208 |
}
|
|
209 | 51365x |
}, 1L, |
210 | 51365x |
max_width = max_width |
211 |
)) |
|
212 |
}) |
|
213 | ||
214 |
#' Transform objects into string representations
|
|
215 |
#'
|
|
216 |
#' Transform a complex object into a string representation ready to be printed or written
|
|
217 |
#' to a plain-text file.
|
|
218 |
#'
|
|
219 |
#' @param x (`ANY`)\cr object to be prepared for rendering.
|
|
220 |
#' @param ... additional parameters passed to individual methods.
|
|
221 |
#'
|
|
222 |
#' @export
|
|
223 |
#' @rdname tostring
|
|
224 |
setGeneric("toString", function(x, ...) standardGeneric("toString")) |
|
225 | ||
226 |
## preserve S3 behavior
|
|
227 |
setMethod("toString", "ANY", base::toString) |
|
228 | ||
229 |
#' Print
|
|
230 |
#'
|
|
231 |
#' Print an R object. See [print()].
|
|
232 |
#'
|
|
233 |
#' @inheritParams base::print
|
|
234 |
#'
|
|
235 |
#' @rdname basemethods
|
|
236 |
setMethod("print", "ANY", base::print) |
|
237 | ||
238 |
# General/"universal" property getter and setter generics and stubs --------------------------------------
|
|
239 | ||
240 |
#' Label, name, and format accessor generics
|
|
241 |
#'
|
|
242 |
#' Getters and setters for basic, relatively universal attributes of "table-like" objects.
|
|
243 |
#'
|
|
244 |
#' @param obj (`ANY`)\cr the object.
|
|
245 |
#' @param value (`string` or `FormatSpec`)\cr the new value of the attribute.
|
|
246 |
#'
|
|
247 |
#' @return The name, format, or label of `obj` for getters, or `obj` after modification for setters.
|
|
248 |
#'
|
|
249 |
#' @export
|
|
250 |
#' @name lab_name
|
|
251 |
#' @aliases obj_name
|
|
252 | ||
253 |
# obj_name ---------------------------------------------------------------
|
|
254 | ||
255 | ! |
setGeneric("obj_name", function(obj) standardGeneric("obj_name")) |
256 | ||
257 |
#' @rdname lab_name
|
|
258 |
#' @export
|
|
259 | ! |
setGeneric("obj_name<-", function(obj, value) standardGeneric("obj_name<-")) |
260 | ||
261 |
# obj_label ---------------------------------------------------------------
|
|
262 | ||
263 |
#' @seealso with_label
|
|
264 |
#' @rdname lab_name
|
|
265 |
#' @export
|
|
266 | 3x |
setGeneric("obj_label", function(obj) standardGeneric("obj_label")) |
267 | ||
268 |
#' @rdname lab_name
|
|
269 |
#' @param value character(1). The new label
|
|
270 |
#' @export
|
|
271 | 2x |
setGeneric("obj_label<-", function(obj, value) standardGeneric("obj_label<-")) |
272 | ||
273 |
#' @rdname lab_name
|
|
274 |
#' @exportMethod obj_label
|
|
275 | 3x |
setMethod("obj_label", "ANY", function(obj) attr(obj, "label")) |
276 | ||
277 |
#' @rdname lab_name
|
|
278 |
#' @exportMethod obj_label<-
|
|
279 |
setMethod( |
|
280 |
"obj_label<-", "ANY", |
|
281 |
function(obj, value) { |
|
282 | 2x |
attr(obj, "label") <- value |
283 | 2x |
obj
|
284 |
}
|
|
285 |
)
|
|
286 | ||
287 |
# obj_format ---------------------------------------------------------------
|
|
288 | ||
289 |
#' @rdname lab_name
|
|
290 |
#' @export
|
|
291 | 292x |
setGeneric("obj_format", function(obj) standardGeneric("obj_format")) |
292 | ||
293 |
## this covers rcell, etc
|
|
294 |
#' @rdname lab_name
|
|
295 |
#' @exportMethod obj_format
|
|
296 | 290x |
setMethod("obj_format", "ANY", function(obj) attr(obj, "format", exact = TRUE)) |
297 | ||
298 |
#' @rdname lab_name
|
|
299 |
#' @export
|
|
300 | 2x |
setMethod("obj_format", "fmt_config", function(obj) obj@format) |
301 | ||
302 |
#' @export
|
|
303 |
#' @rdname lab_name
|
|
304 | 3x |
setGeneric("obj_format<-", function(obj, value) standardGeneric("obj_format<-")) |
305 | ||
306 |
## this covers rcell, etc
|
|
307 |
#' @exportMethod obj_format<-
|
|
308 |
#' @rdname lab_name
|
|
309 |
setMethod("obj_format<-", "ANY", function(obj, value) { |
|
310 | 2x |
attr(obj, "format") <- value |
311 | 2x |
obj
|
312 |
}) |
|
313 | ||
314 |
#' @rdname lab_name
|
|
315 |
#' @export
|
|
316 |
setMethod("obj_format<-", "fmt_config", function(obj, value) { |
|
317 | 1x |
obj@format <- value |
318 | 1x |
obj
|
319 |
}) |
|
320 | ||
321 |
# obj_na_str ---------------------------------------------------------------
|
|
322 | ||
323 |
#' @rdname lab_name
|
|
324 |
#' @export
|
|
325 | 3x |
setGeneric("obj_na_str", function(obj) standardGeneric("obj_na_str")) |
326 | ||
327 |
#' @rdname lab_name
|
|
328 |
#' @exportMethod obj_na_str
|
|
329 | 1x |
setMethod("obj_na_str", "ANY", function(obj) attr(obj, "format_na_str", exact = TRUE)) |
330 | ||
331 |
#' @rdname lab_name
|
|
332 |
#' @export
|
|
333 | 2x |
setMethod("obj_na_str", "fmt_config", function(obj) obj@format_na_str) |
334 | ||
335 |
#' @rdname lab_name
|
|
336 |
#' @export
|
|
337 | 2x |
setGeneric("obj_na_str<-", function(obj, value) standardGeneric("obj_na_str<-")) |
338 | ||
339 |
#' @exportMethod obj_na_str<-
|
|
340 |
#' @rdname lab_name
|
|
341 |
setMethod("obj_na_str<-", "ANY", function(obj, value) { |
|
342 | 1x |
attr(obj, "format_na_str") <- value |
343 | 1x |
obj
|
344 |
}) |
|
345 | ||
346 |
#' @rdname lab_name
|
|
347 |
#' @export
|
|
348 |
setMethod("obj_na_str<-", "fmt_config", function(obj, value) { |
|
349 | 1x |
obj@format_na_str <- value |
350 | 1x |
obj
|
351 |
}) |
|
352 | ||
353 |
# obj_align ---------------------------------------------------------------
|
|
354 | ||
355 |
#' @rdname lab_name
|
|
356 |
#' @export
|
|
357 | 3x |
setGeneric("obj_align", function(obj) standardGeneric("obj_align")) |
358 | ||
359 |
#' @rdname lab_name
|
|
360 |
#' @exportMethod obj_align
|
|
361 | 1x |
setMethod("obj_align", "ANY", function(obj) attr(obj, "align", exact = TRUE)) |
362 | ||
363 |
#' @rdname lab_name
|
|
364 |
#' @export
|
|
365 | 2x |
setMethod("obj_align", "fmt_config", function(obj) obj@align) |
366 | ||
367 |
#' @rdname lab_name
|
|
368 |
#' @export
|
|
369 | 2x |
setGeneric("obj_align<-", function(obj, value) standardGeneric("obj_align<-")) |
370 | ||
371 |
#' @exportMethod obj_align<-
|
|
372 |
#' @rdname lab_name
|
|
373 |
setMethod("obj_align<-", "ANY", function(obj, value) { |
|
374 | 1x |
attr(obj, "align") <- value |
375 | 1x |
obj
|
376 |
}) |
|
377 | ||
378 |
#' @rdname lab_name
|
|
379 |
#' @export
|
|
380 |
setMethod("obj_align<-", "fmt_config", function(obj, value) { |
|
381 | 1x |
obj@align <- value |
382 | 1x |
obj
|
383 |
}) |
|
384 | ||
385 |
# main_title ---------------------------------------------------------------
|
|
386 | ||
387 |
#' General title and footer accessors
|
|
388 |
#'
|
|
389 |
#' @param obj (`ANY`)\cr object to extract information from.
|
|
390 |
#'
|
|
391 |
#' @return A character scalar (`main_title`), character vector (`main_footer`), or
|
|
392 |
#' vector of length zero or more (`subtitles`, `page_titles`, `prov_footer`) containing
|
|
393 |
#' the relevant title/footer contents.
|
|
394 |
#'
|
|
395 |
#' @export
|
|
396 |
#' @rdname title_footer
|
|
397 | 492x |
setGeneric("main_title", function(obj) standardGeneric("main_title")) |
398 | ||
399 |
#' @export
|
|
400 |
#' @rdname title_footer
|
|
401 |
setMethod( |
|
402 |
"main_title", "MatrixPrintForm", |
|
403 | 492x |
function(obj) obj$main_title |
404 |
)
|
|
405 | ||
406 |
##' @rdname title_footer
|
|
407 |
##' @export
|
|
408 | 17x |
setGeneric("main_title<-", function(obj, value) standardGeneric("main_title<-")) |
409 | ||
410 |
##' @rdname title_footer
|
|
411 |
##' @export
|
|
412 |
setMethod( |
|
413 |
"main_title<-", "MatrixPrintForm", |
|
414 |
function(obj, value) { |
|
415 | 17x |
obj$main_title <- value |
416 | 17x |
obj
|
417 |
}
|
|
418 |
)
|
|
419 | ||
420 |
# subtitles ---------------------------------------------------------------
|
|
421 | ||
422 |
#' @export
|
|
423 |
#' @rdname title_footer
|
|
424 | 491x |
setGeneric("subtitles", function(obj) standardGeneric("subtitles")) |
425 | ||
426 |
#' @export
|
|
427 |
#' @rdname title_footer
|
|
428 |
setMethod( |
|
429 |
"subtitles", "MatrixPrintForm", |
|
430 | 491x |
function(obj) obj$subtitles |
431 |
)
|
|
432 | ||
433 |
##' @rdname title_footer
|
|
434 |
##' @export
|
|
435 | 14x |
setGeneric("subtitles<-", function(obj, value) standardGeneric("subtitles<-")) |
436 | ||
437 |
##' @rdname title_footer
|
|
438 |
##' @export
|
|
439 |
setMethod( |
|
440 |
"subtitles<-", "MatrixPrintForm", |
|
441 |
function(obj, value) { |
|
442 | 14x |
obj$subtitles <- value |
443 | 14x |
obj
|
444 |
}
|
|
445 |
)
|
|
446 | ||
447 |
# page_titles ---------------------------------------------------------------
|
|
448 | ||
449 |
#' @export
|
|
450 |
#' @rdname title_footer
|
|
451 | 532x |
setGeneric("page_titles", function(obj) standardGeneric("page_titles")) |
452 | ||
453 |
#' @export
|
|
454 |
#' @rdname title_footer
|
|
455 |
setMethod( |
|
456 |
"page_titles", "MatrixPrintForm", |
|
457 | 532x |
function(obj) obj$page_titles |
458 |
)
|
|
459 |
#' @rdname title_footer
|
|
460 |
#' @export
|
|
461 | ! |
setMethod("page_titles", "ANY", function(obj) NULL) |
462 | ||
463 |
##' @rdname title_footer
|
|
464 |
##' @export
|
|
465 | 2x |
setGeneric("page_titles<-", function(obj, value) standardGeneric("page_titles<-")) |
466 | ||
467 |
#' @export
|
|
468 |
#' @rdname title_footer
|
|
469 |
setMethod( |
|
470 |
"page_titles<-", "MatrixPrintForm", |
|
471 |
function(obj, value) { |
|
472 | 2x |
if (!is.character(value)) { |
473 | ! |
stop("page titles must be in the form of a character vector, got object of class ", class(value)) |
474 |
}
|
|
475 | 2x |
obj$page_titles <- value |
476 | 2x |
obj
|
477 |
}
|
|
478 |
)
|
|
479 | ||
480 |
# main_footer ---------------------------------------------------------------
|
|
481 | ||
482 |
#' @export
|
|
483 |
#' @rdname title_footer
|
|
484 | 472x |
setGeneric("main_footer", function(obj) standardGeneric("main_footer")) |
485 | ||
486 |
#' @export
|
|
487 |
#' @rdname title_footer
|
|
488 |
setMethod( |
|
489 |
"main_footer", "MatrixPrintForm", |
|
490 | 472x |
function(obj) obj$main_footer |
491 |
)
|
|
492 | ||
493 |
#' @rdname title_footer
|
|
494 |
#' @param value character. New value.
|
|
495 |
#' @export
|
|
496 | 274x |
setGeneric("main_footer<-", function(obj, value) standardGeneric("main_footer<-")) |
497 | ||
498 |
#' @export
|
|
499 |
#' @rdname title_footer
|
|
500 |
setMethod( |
|
501 |
"main_footer<-", "MatrixPrintForm", |
|
502 |
function(obj, value) { |
|
503 | 274x |
if (!is.character(value)) { |
504 | ! |
stop("main footer must be a character vector. Got object of class ", class(value)) |
505 |
}
|
|
506 | 274x |
obj$main_footer <- value |
507 | 274x |
obj
|
508 |
}
|
|
509 |
)
|
|
510 | ||
511 |
# prov_footer ---------------------------------------------------------------
|
|
512 | ||
513 |
#' @export
|
|
514 |
#' @rdname title_footer
|
|
515 | 597x |
setGeneric("prov_footer", function(obj) standardGeneric("prov_footer")) |
516 | ||
517 |
#' @export
|
|
518 |
#' @rdname title_footer
|
|
519 |
setMethod( |
|
520 |
"prov_footer", "MatrixPrintForm", |
|
521 | 597x |
function(obj) obj$prov_footer |
522 |
)
|
|
523 | ||
524 |
#' @rdname title_footer
|
|
525 |
#' @export
|
|
526 | 357x |
setGeneric("prov_footer<-", function(obj, value) standardGeneric("prov_footer<-")) |
527 | ||
528 |
#' @export
|
|
529 |
#' @rdname title_footer
|
|
530 |
setMethod( |
|
531 |
"prov_footer<-", "MatrixPrintForm", |
|
532 |
function(obj, value) { |
|
533 | 357x |
if (!is.character(value)) { |
534 | ! |
stop("provenance footer must be a character vector. Got object of class ", class(value)) |
535 |
}
|
|
536 | 357x |
obj$prov_footer <- value |
537 | 357x |
obj
|
538 |
}
|
|
539 |
)
|
|
540 | ||
541 |
#' @rdname title_footer
|
|
542 |
#' @export
|
|
543 | 1x |
all_footers <- function(obj) c(main_footer(obj), prov_footer(obj)) |
544 | ||
545 |
#' @rdname title_footer
|
|
546 |
#' @export
|
|
547 | 484x |
all_titles <- function(obj) c(main_title(obj), subtitles(obj), page_titles(obj)) |
548 | ||
549 |
# table_inset ---------------------------------------------------------------
|
|
550 | ||
551 |
#' Access or (recursively) set table inset
|
|
552 |
#'
|
|
553 |
#' Table inset is the amount of characters that the body of a table, referential footnotes, and
|
|
554 |
#' main footer material are inset from the left-alignment of the titles and provenance
|
|
555 |
#' footer materials.
|
|
556 |
#'
|
|
557 |
#' @param obj (`ANY`)\cr object to get or (recursively if necessary) set table inset for.
|
|
558 |
#' @param value (`string`)\cr string to use as new header/body separator.
|
|
559 |
#'
|
|
560 |
#' @return
|
|
561 |
#' * `table_inset` returns the integer value that the table body (including column heading
|
|
562 |
#' information and section dividers), referential footnotes, and main footer should be inset
|
|
563 |
#' from the left alignment of the titles and provenance footers during rendering.
|
|
564 |
#' * `table_inset<-` returns `obj` with the new table_inset value applied recursively to it and
|
|
565 |
#' all its subtables.
|
|
566 |
#'
|
|
567 |
#' @export
|
|
568 | 454x |
setGeneric("table_inset", function(obj) standardGeneric("table_inset")) |
569 | ||
570 |
#' @rdname table_inset
|
|
571 |
#' @export
|
|
572 |
setMethod( |
|
573 |
"table_inset", "MatrixPrintForm", |
|
574 | 454x |
function(obj) obj$table_inset |
575 |
)
|
|
576 | ||
577 |
#' @rdname table_inset
|
|
578 |
#' @export
|
|
579 | 4x |
setGeneric("table_inset<-", function(obj, value) standardGeneric("table_inset<-")) |
580 | ||
581 |
#' @rdname table_inset
|
|
582 |
#' @export
|
|
583 |
setMethod( |
|
584 |
"table_inset<-", "MatrixPrintForm", |
|
585 |
function(obj, value) { |
|
586 | 4x |
newval <- as.integer(value) |
587 | 4x |
if (is.na(newval) || newval < 0) { |
588 | 1x |
stop("Got invalid value for table_inset: ", newval) |
589 |
}
|
|
590 | 3x |
obj$table_inset <- newval |
591 | 3x |
obj
|
592 |
}
|
|
593 |
)
|
|
594 | ||
595 |
# do_forced_paginate ---------------------------------------------------------------
|
|
596 | ||
597 |
#' Generic for performing "forced" pagination
|
|
598 |
#'
|
|
599 |
#' Forced pagination is pagination which happens regardless of position on page. The object
|
|
600 |
#' is expected to have all information necessary to locate such page breaks, and the
|
|
601 |
#' `do_forced_pag` method is expected to fully perform those paginations.
|
|
602 |
#'
|
|
603 |
#' @param obj (`ANY`)\cr object to be paginated. The `ANY` method simply returns a list of
|
|
604 |
#' length one, containing `obj`.
|
|
605 |
#'
|
|
606 |
#' @return A list of sub-objects, which will be further paginated by the standard pagination
|
|
607 |
#' algorithm.
|
|
608 |
#'
|
|
609 |
#' @export
|
|
610 | 104x |
setGeneric("do_forced_paginate", function(obj) standardGeneric("do_forced_paginate")) |
611 | ||
612 |
#' @export
|
|
613 |
#' @rdname do_forced_paginate
|
|
614 | 101x |
setMethod("do_forced_paginate", "ANY", function(obj) list(obj)) |
615 | ||
616 |
# num_rep_cols ---------------------------------------------------------------
|
|
617 | ||
618 |
#' Number of repeated columns
|
|
619 |
#'
|
|
620 |
#' When called on a table-like object using the formatters framework, this method returns the
|
|
621 |
#' number of columns which are mandatorily repeated after each horizontal pagination.
|
|
622 |
#'
|
|
623 |
#' Absent a class-specific method, this function returns 0, indicating no always-repeated columns.
|
|
624 |
#'
|
|
625 |
#' @param obj (`ANY`)\cr a table-like object.
|
|
626 |
#'
|
|
627 |
#' @return An integer.
|
|
628 |
#'
|
|
629 |
#' @note This number *does not* include row labels, the repetition of which is handled separately.
|
|
630 |
#'
|
|
631 |
#' @examples
|
|
632 |
#' mpf <- basic_matrix_form(mtcars)
|
|
633 |
#' num_rep_cols(mpf)
|
|
634 |
#' lmpf <- basic_listing_mf(mtcars)
|
|
635 |
#' num_rep_cols(lmpf)
|
|
636 |
#'
|
|
637 |
#' @export
|
|
638 | 56x |
setGeneric("num_rep_cols", function(obj) standardGeneric("num_rep_cols")) |
639 | ||
640 |
#' @export
|
|
641 |
#' @rdname num_rep_cols
|
|
642 | ! |
setMethod("num_rep_cols", "ANY", function(obj) 0L) |
643 | ||
644 |
#' @export
|
|
645 |
#' @rdname num_rep_cols
|
|
646 |
setMethod("num_rep_cols", "MatrixPrintForm", function(obj) { |
|
647 | 56x |
if (.is_listing_mf(obj)) { |
648 | 14x |
return(length(.get_keycols_from_listing(obj))) |
649 |
} else { |
|
650 | 42x |
return(0L) # same as ANY for non-listing objects |
651 |
}
|
|
652 |
}) |
|
653 | ||
654 |
# header_section_div -----------------------------------------------------------
|
|
655 | ||
656 |
#' @keywords internal
|
|
657 | 153x |
setGeneric("header_section_div", function(obj) standardGeneric("header_section_div")) |
658 | ||
659 |
#' @keywords internal
|
|
660 |
setMethod( |
|
661 |
"header_section_div", "MatrixPrintForm", |
|
662 | 153x |
function(obj) obj$header_section_div |
663 |
)
|
|
664 | ||
665 |
#' @keywords internal
|
|
666 | ! |
setGeneric("header_section_div<-", function(obj, value) standardGeneric("header_section_div<-")) |
667 | ||
668 |
#' @keywords internal
|
|
669 |
setMethod( |
|
670 |
"header_section_div<-", "MatrixPrintForm", |
|
671 |
function(obj, value) { |
|
672 | ! |
obj$header_section_div <- value |
673 | ! |
obj
|
674 |
}
|
|
675 |
)
|
|
676 | ||
677 |
# horizontal_sep ---------------------------------------------------------------
|
|
678 | ||
679 |
#' @keywords internal
|
|
680 | 122x |
setGeneric("horizontal_sep", function(obj) standardGeneric("horizontal_sep")) |
681 | ||
682 |
#' @keywords internal
|
|
683 |
setMethod( |
|
684 |
"horizontal_sep", "MatrixPrintForm", |
|
685 | 122x |
function(obj) obj$horizontal_sep |
686 |
)
|
|
687 | ||
688 |
#' @keywords internal
|
|
689 | 1x |
setGeneric("horizontal_sep<-", function(obj, value) standardGeneric("horizontal_sep<-")) |
690 | ||
691 |
#' @keywords internal
|
|
692 |
setMethod( |
|
693 |
"horizontal_sep<-", "MatrixPrintForm", |
|
694 |
function(obj, value) { |
|
695 | 1x |
obj$horizontal_sep <- value |
696 | 1x |
obj
|
697 |
}
|
|
698 |
)
|
1 |
.calc_cell_widths <- function(mat, colwidths, col_gap) { |
|
2 | 363x |
spans <- mat$spans |
3 | 363x |
keep_mat <- mat$display |
4 | 363x |
body <- mat$strings |
5 | ||
6 | 363x |
nr <- nrow(body) |
7 | ||
8 | 363x |
cell_widths_mat <- matrix(rep(colwidths, nr), nrow = nr, byrow = TRUE) |
9 | 363x |
nc <- ncol(cell_widths_mat) |
10 | ||
11 | 363x |
for (i in seq_len(nrow(body))) { |
12 | 6517x |
if (any(!keep_mat[i, ])) { # any spans? |
13 | 6x |
j <- 1 |
14 | 6x |
while (j <= nc) { |
15 | 10x |
nj <- spans[i, j] |
16 | 10x |
j <- if (nj > 1) { |
17 | 6x |
js <- seq(j, j + nj - 1) |
18 | 6x |
cell_widths_mat[i, js] <- sum(cell_widths_mat[i, js]) + col_gap * (nj - 1) |
19 | 6x |
j + nj |
20 |
} else { |
|
21 | 4x |
j + 1 |
22 |
}
|
|
23 |
}
|
|
24 |
}
|
|
25 |
}
|
|
26 | 363x |
cell_widths_mat
|
27 |
}
|
|
28 | ||
29 |
# Main function that does the wrapping
|
|
30 |
do_cell_fnotes_wrap <- function(mat, widths, max_width, tf_wrap) { |
|
31 | 210x |
col_gap <- mf_colgap(mat) |
32 | 210x |
ncchar <- sum(widths) + (length(widths) - 1) * col_gap |
33 | 210x |
inset <- table_inset(mat) |
34 | ||
35 |
## Text wrapping checks
|
|
36 | 210x |
if (tf_wrap) { |
37 | 92x |
if (is.null(max_width)) { |
38 | 24x |
max_width <- getOption("width", 80L) |
39 | 68x |
} else if (is.character(max_width) && identical(max_width, "auto")) { |
40 | ! |
max_width <- ncchar + inset |
41 |
}
|
|
42 | 92x |
assert_number(max_width, lower = 0) |
43 |
}
|
|
44 | ||
45 |
## Check for having the right number of widths
|
|
46 | 210x |
stopifnot(length(widths) == ncol(mat$strings)) |
47 | ||
48 |
## format the to ASCII
|
|
49 | 210x |
cell_widths_mat <- .calc_cell_widths(mat, widths, col_gap) |
50 | ||
51 |
# Check that indentation is correct (it works only for body)
|
|
52 | 210x |
.check_indentation(mat, row_col_width = cell_widths_mat[, 1, drop = TRUE]) |
53 | 207x |
mod_ind_list <- .modify_indentation(mat, cell_widths_mat, do_what = "remove") |
54 | 207x |
mfs <- mod_ind_list[["mfs"]] |
55 | 207x |
cell_widths_mat <- mod_ind_list[["cell_widths_mat"]] |
56 | ||
57 |
# Main wrapper
|
|
58 | 207x |
mf_strings(mat) <- matrix( |
59 | 207x |
unlist(mapply(wrap_string, |
60 | 207x |
str = mfs, |
61 | 207x |
width = cell_widths_mat, |
62 | 207x |
collapse = "\n" |
63 |
)), |
|
64 | 207x |
ncol = ncol(mfs) |
65 |
)
|
|
66 | ||
67 |
## XXXXX this is wrong and will break for listings cause we don't know when
|
|
68 |
## we need has_topleft to be FALSE!!!!!!!!!!
|
|
69 | 207x |
mat <- mform_handle_newlines(mat) |
70 | ||
71 |
## this updates extents in rinfo AND nlines in ref_fnotes_df
|
|
72 | 207x |
mat <- update_mf_nlines(mat, max_width = max_width) |
73 | ||
74 |
# Re-indenting
|
|
75 | 207x |
mf_strings(mat) <- .modify_indentation(mat, cell_widths_mat, do_what = "add")[["mfs"]] |
76 | 207x |
.check_indentation(mat) # all went well |
77 | ||
78 | 207x |
mat
|
79 |
}
|
|
80 | ||
81 |
# Helper function to see if body indentation matches (minimum)
|
|
82 |
# It sees if there is AT LEAST the indentation contained in rinfo
|
|
83 |
.check_indentation <- function(mat, row_col_width = NULL) { |
|
84 |
# mf_nrheader(mat) # not useful
|
|
85 | 418x |
mf_nlh <- mf_nlheader(mat) |
86 | 418x |
mf_lgrp <- mf_lgrouping(mat) |
87 | 418x |
mf_str <- mf_strings(mat) |
88 |
# we base everything on the groupings -> unique indentation identifiers
|
|
89 | 418x |
if (!is.null(mf_rinfo(mat))) { # this happens in rare cases with rtables::rtable() |
90 | 418x |
mf_ind <- c(rep(0, mf_nrheader(mat)), mf_rinfo(mat)$indent) # XXX to fix with topleft |
91 |
} else { |
|
92 | ! |
mf_ind <- rep(0, mf_nrheader(mat)) |
93 |
}
|
|
94 | 418x |
ind_std <- paste0(rep(" ", mat$indent_size), collapse = "") |
95 | ||
96 |
# Expected indent (-x negative numbers should not appear at this stage)
|
|
97 | 418x |
stopifnot(all(mf_ind >= 0)) |
98 | 418x |
real_indent <- vapply(mf_ind, function(ii) { |
99 | 7821x |
paste0(rep(ind_std, ii), collapse = "") |
100 | 418x |
}, character(1)) |
101 | ||
102 | 418x |
if (!is.null(row_col_width) && any(row_col_width > 0) && !is.null(mf_rinfo(mat))) { # third is rare case |
103 |
# Self consistency test for row_col_width (same groups should have same width)
|
|
104 |
# This should not be necessary (nocov)
|
|
105 | 210x |
consistency_check <- vapply(unique(mf_lgrp), function(ii) { |
106 | 3929x |
width_per_grp <- row_col_width[which(mf_lgrp == ii)] |
107 | 3929x |
all(width_per_grp == width_per_grp[1]) |
108 | 210x |
}, logical(1)) |
109 | 210x |
stopifnot(all(consistency_check)) |
110 | ||
111 |
# Taking only one width for each indentation grouping
|
|
112 | 210x |
unique_row_col_width <- row_col_width[match(unique(mf_lgrp), mf_lgrp)] |
113 | ||
114 |
# Exception for check: case with summarize_row_groups and (hence) content_rows
|
|
115 | 210x |
nchar_real_indent <- nchar(real_indent) |
116 | 210x |
body_rows <- seq(mf_nrheader(mat) + 1, length(nchar_real_indent)) |
117 | 210x |
nchar_real_indent[body_rows] <- nchar_real_indent[body_rows] + |
118 | 210x |
as.numeric(mf_rinfo(mat)$node_class != "ContentRow") |
119 |
# xxx I think all of the above is a bit buggy honestly (check ContentRows!!!)
|
|
120 | ||
121 | 210x |
if (any(nchar_real_indent > unique_row_col_width)) { |
122 | 2x |
stop( |
123 | 2x |
"Inserted width for row label column is not wide enough. ",
|
124 | 2x |
"We found the following rows that do not have at least indentation * ind_size + 1",
|
125 | 2x |
" characters to allow text to be shown after indentation: ",
|
126 | 2x |
paste0(which(nchar(real_indent) + 1 > unique_row_col_width), collapse = " ") |
127 |
)
|
|
128 |
}
|
|
129 |
}
|
|
130 | ||
131 |
# Main detector
|
|
132 | 416x |
correct_indentation <- vapply(seq_along(mf_lgrp), function(xx) { |
133 | 8249x |
grouping <- mf_lgrp[xx] |
134 | 8249x |
if (nzchar(real_indent[grouping])) { |
135 | 33x |
has_correct_indentation <- stringi::stri_detect( |
136 | 33x |
mf_str[xx, 1], |
137 | 33x |
regex = paste0("^", real_indent[grouping]) |
138 |
)
|
|
139 | 33x |
return(has_correct_indentation || !nzchar(mf_str[xx, 1])) # "" is still an ok indentation |
140 |
}
|
|
141 |
# Cases where no indent are true by definition
|
|
142 | 8216x |
return(TRUE) |
143 | 416x |
}, logical(1)) |
144 | ||
145 | 416x |
if (any(!correct_indentation)) { |
146 | 1x |
stop( |
147 | 1x |
"We discovered indentation mismatches between the matrix_form and the indentation",
|
148 | 1x |
" predefined in mf_rinfo. This should not happen. Contact the maintainer."
|
149 | 1x |
) # nocov |
150 |
}
|
|
151 |
}
|
|
152 | ||
153 |
# Helper function that takes out or adds the proper indentation
|
|
154 |
.modify_indentation <- function(mat, cell_widths_mat, do_what = c("remove", "add")) { |
|
155 |
# Extract info
|
|
156 | 414x |
mfs <- mf_strings(mat) # we work on mfs |
157 | 414x |
mf_nlh <- mf_nlheader(mat) |
158 | 414x |
mf_l <- mf_lgrouping(mat) |
159 | 414x |
if (!is.null(mf_rinfo(mat))) { # this happens in rare cases with rtables::rtable() |
160 | 414x |
mf_ind <- c(rep(0, mf_nrheader(mat)), mf_rinfo(mat)$indent) # XXX to fix with topleft |
161 |
} else { |
|
162 | ! |
mf_ind <- rep(0, mf_nrheader(mat)) |
163 |
}
|
|
164 | 414x |
stopifnot(length(mf_ind) == length(unique(mf_l))) # Check for indentation and grouping |
165 | 414x |
ind_std <- paste0(rep(" ", mat$indent_size), collapse = "") # standard size of indent 1 |
166 | ||
167 |
# Create real indentation
|
|
168 | 414x |
real_indent <- sapply(mf_ind, function(ii) paste0(rep(ind_std, ii), collapse = "")) |
169 | ||
170 |
# Use groupings to add or remove proper indentation
|
|
171 | 414x |
lbl_row <- mfs[, 1, drop = TRUE] |
172 | 414x |
for (ii in seq_along(lbl_row)) { |
173 | 8240x |
grp <- mf_l[ii] |
174 | 8240x |
if (nzchar(real_indent[grp])) { |
175 |
# Update also the widths!!
|
|
176 | 29x |
if (do_what[1] == "remove") { |
177 | 9x |
cell_widths_mat[ii, 1] <- cell_widths_mat[ii, 1] - nchar(real_indent[grp]) |
178 | 9x |
mfs[ii, 1] <- stringi::stri_replace(lbl_row[ii], "", regex = paste0("^", real_indent[grp])) |
179 | 20x |
} else if (do_what[1] == "add") { |
180 | 20x |
mfs[ii, 1] <- paste0(real_indent[grp], lbl_row[ii]) |
181 |
} else { |
|
182 |
stop("do_what needs to be remove or add.") # nocov |
|
183 |
}
|
|
184 |
} else { |
|
185 | 8211x |
mfs[ii, 1] <- lbl_row[ii] |
186 |
}
|
|
187 |
}
|
|
188 |
# Final return
|
|
189 | 414x |
return(list("mfs" = mfs, "cell_widths_mat" = cell_widths_mat)) |
190 |
}
|
|
191 | ||
192 |
## take a character vector and return whether the value is
|
|
193 |
## a string version of a number or not
|
|
194 |
is_number_str <- function(vec) { |
|
195 | ! |
is.na(as.numeric(vec)) |
196 |
}
|
|
197 | ||
198 |
is_dec_align <- function(vec) { |
|
199 |
# "c" is not an alignment method we define in `formatters`,
|
|
200 |
# but the reverse dependency package `tables` will need
|
|
201 | 595x |
sdiff <- setdiff(vec, c(list_valid_aligns(), "c")) |
202 | 595x |
if (length(sdiff) > 0) { |
203 | ! |
stop("Invalid text-alignment(s): ", paste(sdiff, collapse = ", ")) |
204 |
}
|
|
205 | 595x |
grepl("dec", vec) |
206 |
}
|
|
207 | ||
208 | 450x |
any_dec_align <- function(vec) any(is_dec_align(vec)) |
209 | ||
210 |
#' Decimal alignment
|
|
211 |
#'
|
|
212 |
#' Aligning decimal values of string matrix. Allowed alignments are: `dec_left`, `dec_right`,
|
|
213 |
#' and `decimal`.
|
|
214 |
#'
|
|
215 |
#' @param string_mat (`character matrix`)\cr "string" matrix component of `MatrixPrintForm` object.
|
|
216 |
#' @param align_mat (`character matrix`)\cr "aligns" matrix component of `MatrixPrintForm` object.
|
|
217 |
#' Should contain either `dec_left`, `dec_right`, or `decimal` for values to be decimal aligned.
|
|
218 |
#'
|
|
219 |
#' @details Left and right decimal alignment (`dec_left` and `dec_right`) differ from center decimal
|
|
220 |
#' alignment (`decimal`) only when there is padding present. This may occur if column widths are
|
|
221 |
#' set wider via parameters `widths` in `toString` or `colwidths` in `paginate_*`. More commonly,
|
|
222 |
#' it also occurs when column names are wider. Cell wrapping is not supported when decimal
|
|
223 |
#' alignment is used.
|
|
224 |
#'
|
|
225 |
#' @return A processed string matrix of class `MatrixPrintForm` with decimal-aligned values.
|
|
226 |
#'
|
|
227 |
#' @seealso [toString()], [MatrixPrintForm()]
|
|
228 |
#'
|
|
229 |
#' @examples
|
|
230 |
#' dfmf <- basic_matrix_form(mtcars[1:5, ])
|
|
231 |
#' aligns <- mf_aligns(dfmf)
|
|
232 |
#' aligns[, -c(1)] <- "dec_left"
|
|
233 |
#' decimal_align(mf_strings(dfmf), aligns)
|
|
234 |
#'
|
|
235 |
#' @export
|
|
236 |
decimal_align <- function(string_mat, align_mat) { |
|
237 |
## Evaluate if any values are to be decimal aligned
|
|
238 | 45x |
if (!any_dec_align(align_mat)) { |
239 | ! |
return(string_mat) |
240 |
}
|
|
241 | 45x |
for (i in seq(1, ncol(string_mat))) { |
242 |
## Take a column and its decimal alignments
|
|
243 | 145x |
col_i <- as.character(string_mat[, i]) |
244 | 145x |
align_col_i <- is_dec_align(align_mat[, i]) |
245 | ||
246 |
## !( A || B) -> !A && !B DeMorgan's Law
|
|
247 |
## Are there any values to be decimal aligned? safe if
|
|
248 | 145x |
if (any(align_col_i) && any(!grepl("^[0-9]\\.", col_i))) { |
249 |
## Extract values not to be aligned (NAs, non-numbers,
|
|
250 |
## doesn't say "decimal" in alignment matrix)
|
|
251 |
## XXX FIXME because this happens after formatting, we can't tell the difference between
|
|
252 |
## non-number strings which come from na_str+ NA value and strings which just aren't numbers.
|
|
253 |
## this is a problem that should eventually be fixed.
|
|
254 | 82x |
nas <- vapply(col_i, is.na, FUN.VALUE = logical(1)) |
255 | 82x |
nonnum <- !grepl("[0-9]", col_i) |
256 |
## No grepl("[a-zA-Z]", col_i) because this excludes N=xx, e.g.
|
|
257 | 82x |
nonalign <- nas | nonnum | !align_col_i |
258 | 82x |
col_ia <- col_i[!nonalign] |
259 | ||
260 |
## Do decimal alignment
|
|
261 | 82x |
if (length(col_ia) > 0) { |
262 |
# Special case: scientific notation
|
|
263 | 82x |
has_sc_not <- grepl("\\d+[e|E][\\+|\\-]\\d+", col_ia) |
264 | 82x |
if (any(has_sc_not)) { |
265 | 1x |
stop( |
266 | 1x |
"Found values using scientific notation between the ones that",
|
267 | 1x |
" needs to be decimal aligned (aligns is decimal, dec_left or dec_right).",
|
268 | 1x |
" Please consider using format functions to get a complete decimal ",
|
269 | 1x |
"(e.g. formatC)."
|
270 |
)
|
|
271 |
}
|
|
272 | ||
273 |
## Count the number of numbers in the string
|
|
274 | 81x |
matches <- gregexpr("\\d+\\.\\d+|\\d+", col_ia) |
275 | 81x |
more_than_one <- vapply(matches, function(x) { |
276 | 692x |
sum(attr(x, "match.length") > 0) > 1 |
277 | 81x |
}, logical(1)) |
278 |
## Throw error in case any have more than 1 numbers
|
|
279 | 81x |
if (any(more_than_one)) { |
280 | 2x |
stop( |
281 | 2x |
"Decimal alignment is not supported for multiple values. ",
|
282 | 2x |
"Found the following string with multiple numbers ",
|
283 | 2x |
"(first 3 selected from column ", col_i[1], "): '", |
284 | 2x |
paste0(col_ia[more_than_one][seq(1, 3)], collapse = "', '"), |
285 |
"'"
|
|
286 |
)
|
|
287 |
}
|
|
288 |
## General split (only one match -> the first)
|
|
289 | 79x |
main_regexp <- regexpr("\\d+", col_ia) |
290 | 79x |
left <- regmatches(col_ia, main_regexp, invert = FALSE) |
291 | 79x |
right <- regmatches(col_ia, main_regexp, invert = TRUE) |
292 | 79x |
right <- sapply(right, "[[", 2) |
293 | 79x |
something_left <- sapply(strsplit(col_ia, "\\d+"), "[[", 1) |
294 | 79x |
left <- paste0(something_left, left) |
295 | 79x |
if (!checkmate::test_set_equal(paste0(left, right), col_ia)) { |
296 | ! |
stop( |
297 | ! |
"Split string list lost some piece along the way. This ",
|
298 | ! |
"should not have happened. Please contact the maintainer."
|
299 |
)
|
|
300 |
} # nocov |
|
301 | 79x |
separator <- sapply(right, function(x) { |
302 | 645x |
if (nzchar(x)) { |
303 | 349x |
substr(x, 1, 1) |
304 |
} else { |
|
305 | 296x |
c(" ") |
306 |
}
|
|
307 | 79x |
}, USE.NAMES = FALSE) |
308 | 79x |
right <- sapply(right, function(x) { |
309 | 645x |
if (nchar(x) > 1) { |
310 | 317x |
substr(x, 2, nchar(x)) |
311 |
} else { |
|
312 | 328x |
c("") |
313 |
}
|
|
314 | 79x |
}, USE.NAMES = FALSE) |
315 |
## figure out whether we need space separators (at least one had a "." or not)
|
|
316 | 79x |
if (!any(grepl("[^[:space:]]", separator))) { |
317 | 26x |
separator <- gsub("[[:space:]]*", "", separator) |
318 |
}
|
|
319 |
## modify the piece with spaces
|
|
320 | 79x |
left_mod <- paste0(spaces(max(nchar(left), na.rm = TRUE) - nchar(left)), left) |
321 | 79x |
right_mod <- paste0(right, spaces(max(nchar(right), na.rm = TRUE) - nchar(right))) |
322 |
# Put everything together
|
|
323 | 79x |
aligned <- paste(left_mod, separator, right_mod, sep = "") |
324 | 79x |
string_mat[!nonalign, i] <- aligned |
325 |
}
|
|
326 |
}
|
|
327 |
}
|
|
328 | 42x |
string_mat
|
329 |
}
|
|
330 | ||
331 |
## toString ---------------------------------------------------------------------
|
|
332 |
## main printing method for MatrixPrintForm
|
|
333 | ||
334 |
#' @description
|
|
335 |
#' All objects that are printed to console pass via `toString`. This function allows
|
|
336 |
#' fundamental formatting specifications to be applied to final output, like column widths
|
|
337 |
#' and relative wrapping (`width`), title and footer wrapping (`tf_wrap = TRUE` and
|
|
338 |
#' `max_width`), and horizontal separator character (e.g. `hsep = "+"`).
|
|
339 |
#'
|
|
340 |
#' @inheritParams MatrixPrintForm
|
|
341 |
#' @param widths (`numeric` or `NULL`)\cr Proposed widths for the columns of `x`. The expected
|
|
342 |
#' length of this numeric vector can be retrieved with `ncol(x) + 1` as the column of row names
|
|
343 |
#' must also be considered.
|
|
344 |
#' @param hsep (`string`)\cr character to repeat to create header/body separator line. If
|
|
345 |
#' `NULL`, the object value will be used. If `" "`, an empty separator will be printed. See
|
|
346 |
#' [default_hsep()] for more information.
|
|
347 |
#' @param tf_wrap (`flag`)\cr whether the text for title, subtitles, and footnotes should be wrapped.
|
|
348 |
#' @param max_width (`integer(1)`, `string` or `NULL`)\cr width that title and footer (including
|
|
349 |
#' footnotes) materials should be word-wrapped to. If `NULL`, it is set to the current print width of the
|
|
350 |
#' session (`getOption("width")`). If set to `"auto"`, the width of the table (plus any table inset) is
|
|
351 |
#' used. Parameter is ignored if `tf_wrap = FALSE`.
|
|
352 |
#'
|
|
353 |
#' @details
|
|
354 |
#' Manual insertion of newlines is not supported when `tf_wrap = TRUE` and will result in a warning and
|
|
355 |
#' undefined wrapping behavior. Passing vectors of already split strings remains supported, however in this
|
|
356 |
#' case each string is word-wrapped separately with the behavior described above.
|
|
357 |
#'
|
|
358 |
#' @return A character string containing the ASCII rendering of the table-like object represented by `x`.
|
|
359 |
#'
|
|
360 |
#' @seealso [wrap_string()]
|
|
361 |
#'
|
|
362 |
#' @examples
|
|
363 |
#' mform <- basic_matrix_form(mtcars)
|
|
364 |
#' cat(toString(mform))
|
|
365 |
#'
|
|
366 |
#' @rdname tostring
|
|
367 |
#' @exportMethod toString
|
|
368 |
setMethod("toString", "MatrixPrintForm", function(x, |
|
369 |
widths = NULL, |
|
370 |
tf_wrap = FALSE, |
|
371 |
max_width = NULL, |
|
372 |
col_gap = mf_colgap(x), |
|
373 |
hsep = NULL) { |
|
374 | 160x |
checkmate::assert_flag(tf_wrap) |
375 | ||
376 | 160x |
mat <- matrix_form(x, indent_rownames = TRUE) |
377 | ||
378 |
# Check for \n in mat strings -> if there are any, matrix_form did not work
|
|
379 | 160x |
if (any(grepl("\n", mf_strings(mat)))) { |
380 | ! |
stop( |
381 | ! |
"Found newline characters (\\n) in string matrix produced by matrix_form. ",
|
382 | ! |
"This is not supported and implies missbehavior on the first parsing (in matrix_form). ",
|
383 | ! |
"Please contact the maintainer or file an issue."
|
384 | ! |
) # nocov |
385 |
}
|
|
386 | 160x |
if (any(grepl("\r", mf_strings(mat)))) { |
387 | ! |
stop( |
388 | ! |
"Found recursive special characters (\\r) in string matrix produced by matrix_form. ",
|
389 | ! |
"This special character is not supported and should be removed."
|
390 | ! |
) # nocov |
391 |
}
|
|
392 | ||
393 |
# Check that expansion worked for header -> should not happen
|
|
394 | 160x |
if (!is.null(mf_rinfo(mat)) && # rare case of rtables::rtable() |
395 | 160x |
(length(mf_lgrouping(mat)) != nrow(mf_strings(mat)) || # non-unique grouping test # nolint |
396 | 160x |
mf_nrheader(mat) + nrow(mf_rinfo(mat)) != length(unique(mf_lgrouping(mat))))) { # nolint |
397 | ! |
stop( |
398 | ! |
"The sum of the expected nrows header and nrows of content table does ",
|
399 | ! |
"not match the number of rows in the string matrix. To our knowledge, ",
|
400 | ! |
"this is usually of a problem in solving newline characters (\\n) in the header. ",
|
401 | ! |
"Please contact the maintaner or file an issue."
|
402 | ! |
) # nocov |
403 |
}
|
|
404 | ||
405 | 160x |
inset <- table_inset(mat) |
406 | ||
407 |
# if cells are decimal aligned, run propose column widths
|
|
408 |
# if the provided widths is less than proposed width, return an error
|
|
409 | 160x |
if (any_dec_align(mf_aligns(mat))) { |
410 | 22x |
aligned <- propose_column_widths(x) |
411 | ||
412 |
# catch any columns that require widths more than what is provided
|
|
413 | 20x |
if (!is.null(widths)) { |
414 | 9x |
how_wide <- sapply(seq_along(widths), function(i) c(widths[i] - aligned[i])) |
415 | 9x |
too_wide <- how_wide < 0 |
416 | 9x |
if (any(too_wide)) { |
417 | 2x |
desc_width <- paste(paste( |
418 | 2x |
names(which(too_wide)), |
419 | 2x |
paste0("(", how_wide[too_wide], ")") |
420 | 2x |
), collapse = ", ") |
421 | 2x |
stop( |
422 | 2x |
"Inserted width(s) for column(s) ", desc_width, |
423 | 2x |
" is(are) not wide enough for the desired alignment."
|
424 |
)
|
|
425 |
}
|
|
426 |
}
|
|
427 |
}
|
|
428 | ||
429 |
# Column widths are fixed here
|
|
430 | 156x |
if (is.null(widths)) { |
431 |
# if mf does not have widths -> propose them
|
|
432 | 130x |
widths <- mf_col_widths(x) %||% propose_column_widths(x) |
433 |
} else { |
|
434 | 26x |
mf_col_widths(x) <- widths |
435 |
}
|
|
436 | ||
437 |
# Total number of characters for the table
|
|
438 | 156x |
ncchar <- sum(widths) + (length(widths) - 1) * col_gap |
439 | ||
440 |
## max_width for wrapping titles and footers (not related to ncchar if not indirectly)
|
|
441 | 156x |
max_width <- .handle_max_width( |
442 | 156x |
tf_wrap = tf_wrap, |
443 | 156x |
max_width = max_width, |
444 | 156x |
colwidths = widths, |
445 | 156x |
col_gap = col_gap, |
446 | 156x |
inset = inset |
447 |
)
|
|
448 | ||
449 |
# Main wrapper function for table core
|
|
450 | 156x |
mat <- do_cell_fnotes_wrap(mat, widths, max_width = max_width, tf_wrap = tf_wrap) |
451 | ||
452 | 153x |
body <- mf_strings(mat) |
453 | 153x |
aligns <- mf_aligns(mat) |
454 | 153x |
keep_mat <- mf_display(mat) |
455 |
## spans <- mat$spans
|
|
456 | 153x |
mf_ri <- mf_rinfo(mat) |
457 | 153x |
ref_fnotes <- mf_rfnotes(mat) |
458 | 153x |
nl_header <- mf_nlheader(mat) |
459 | ||
460 | 153x |
cell_widths_mat <- .calc_cell_widths(mat, widths, col_gap) |
461 | ||
462 |
# decimal alignment
|
|
463 | 153x |
if (any_dec_align(aligns)) { |
464 | 18x |
body <- decimal_align(body, aligns) |
465 |
}
|
|
466 | ||
467 |
# Content is a matrix of cells with the right amount of spaces
|
|
468 | 153x |
content <- matrix(mapply(padstr, body, cell_widths_mat, aligns), ncol = ncol(body)) |
469 | 153x |
content[!keep_mat] <- NA |
470 | ||
471 |
# Define gap string and divisor string
|
|
472 | 153x |
gap_str <- strrep(" ", col_gap) |
473 | 153x |
if (is.null(hsep)) { |
474 | 122x |
hsep <- horizontal_sep(mat) |
475 |
}
|
|
476 | 153x |
div <- substr(strrep(hsep, ncchar), 1, ncchar) |
477 | 153x |
hsd <- header_section_div(mat) |
478 | 153x |
if (!is.na(hsd)) { |
479 | ! |
hsd <- substr(strrep(hsd, ncchar), 1, ncchar) |
480 |
} else { |
|
481 | 153x |
hsd <- NULL # no divisor |
482 |
}
|
|
483 | ||
484 |
# text head (paste w/o NA content header and gap string)
|
|
485 | 153x |
txt_head <- apply(head(content, nl_header), 1, .paste_no_na, collapse = gap_str) |
486 | ||
487 |
# txt body
|
|
488 | 153x |
sec_seps_df <- mf_ri[, c("abs_rownumber", "trailing_sep"), drop = FALSE] |
489 | 153x |
if (!is.null(sec_seps_df) && any(!is.na(sec_seps_df$trailing_sep))) { |
490 | 2x |
bdy_cont <- tail(content, -nl_header) |
491 |
## unfortunately we count "header rows" wrt line grouping so it
|
|
492 |
## doesn't match the real (i.e. body) rows as is
|
|
493 | 2x |
row_grouping <- tail(mf_lgrouping(mat), -nl_header) - mf_nrheader(mat) |
494 | 2x |
nrbody <- NROW(bdy_cont) |
495 | 2x |
stopifnot(length(row_grouping) == nrbody) |
496 |
## all rows with non-NA section divs and the final row (regardless of NA status)
|
|
497 |
## fixes #77
|
|
498 | 2x |
sec_seps_df <- sec_seps_df[unique(c( |
499 | 2x |
which(!is.na(sec_seps_df$trailing_sep)), |
500 | 2x |
NROW(sec_seps_df) |
501 |
)), ] |
|
502 | 2x |
txt_body <- character() |
503 | 2x |
sec_strt <- 1 |
504 | 2x |
section_rws <- sec_seps_df$abs_rownumber |
505 | 2x |
for (i in seq_len(NROW(section_rws))) { |
506 | 6x |
cur_rownum <- section_rws[i] |
507 | 6x |
sec_end <- max(which(row_grouping == cur_rownum)) |
508 | 6x |
txt_body <- c( |
509 | 6x |
txt_body,
|
510 | 6x |
apply(bdy_cont[seq(sec_strt, sec_end), , drop = FALSE], |
511 | 6x |
1,
|
512 | 6x |
.paste_no_na,
|
513 | 6x |
collapse = gap_str |
514 |
),
|
|
515 |
## don't print section dividers if they would be the last thing before the
|
|
516 |
## footer divider
|
|
517 |
## this also ensures an extraneous sec div won't be printed if we have non-sec-div
|
|
518 |
## rows after the last sec div row (#77)
|
|
519 | 6x |
if (sec_end < nrbody) { |
520 | 4x |
substr( |
521 | 4x |
strrep(sec_seps_df$trailing_sep[i], ncchar), 1, |
522 | 4x |
ncchar - inset |
523 |
)
|
|
524 |
}
|
|
525 |
)
|
|
526 | 6x |
sec_strt <- sec_end + 1 |
527 |
}
|
|
528 |
} else { |
|
529 |
# This is the usual default pasting
|
|
530 | 151x |
txt_body <- apply(tail(content, -nl_header), 1, .paste_no_na, collapse = gap_str) |
531 |
}
|
|
532 | ||
533 |
# retrieving titles and footers
|
|
534 | 153x |
allts <- all_titles(mat) |
535 | ||
536 | 153x |
ref_fnotes <- reorder_ref_fnotes(ref_fnotes) |
537 |
# Fix for ref_fnotes with \n characters XXX this does not count in the pagination
|
|
538 | 153x |
if (any(grepl("\n", ref_fnotes))) { |
539 | 2x |
ref_fnotes <- unlist(strsplit(ref_fnotes, "\n", fixed = TRUE)) |
540 |
}
|
|
541 | ||
542 | 153x |
allfoots <- list( |
543 | 153x |
"main_footer" = main_footer(mat), |
544 | 153x |
"prov_footer" = prov_footer(mat), |
545 | 153x |
"ref_footnotes" = ref_fnotes |
546 |
)
|
|
547 | 153x |
allfoots <- allfoots[!sapply(allfoots, is.null)] |
548 | ||
549 |
## Wrapping titles if they go beyond the horizontally allowed space
|
|
550 | 153x |
if (tf_wrap) { |
551 | 68x |
new_line_warning(allts) |
552 | 68x |
allts <- wrap_txt(allts, max_width) |
553 |
}
|
|
554 | 153x |
titles_txt <- if (any(nzchar(allts))) c(allts, "", .do_inset(div, inset)) else NULL |
555 | ||
556 |
# Wrapping footers if they go beyond the horizontally allowed space
|
|
557 | 153x |
if (tf_wrap) { |
558 | 68x |
new_line_warning(allfoots) |
559 | 68x |
allfoots$main_footer <- wrap_txt(allfoots$main_footer, max_width - inset) |
560 | 68x |
allfoots$ref_footnotes <- wrap_txt(allfoots$ref_footnotes, max_width - inset) |
561 |
## no - inset here because the prov_footer is not inset
|
|
562 | 68x |
allfoots$prov_footer <- wrap_txt(allfoots$prov_footer, max_width) |
563 |
}
|
|
564 | ||
565 |
# Final return
|
|
566 | 153x |
paste0( |
567 | 153x |
paste(c( |
568 | 153x |
titles_txt, # .do_inset(div, inset) happens if there are any titles |
569 | 153x |
.do_inset(txt_head, inset), |
570 | 153x |
.do_inset(div, inset), |
571 | 153x |
.do_inset(hsd, inset), # header_section_div if present |
572 | 153x |
.do_inset(txt_body, inset), |
573 | 153x |
.footer_inset_helper(allfoots, div, inset) |
574 | 153x |
), collapse = "\n"), |
575 | 153x |
"\n"
|
576 |
)
|
|
577 |
}) |
|
578 | ||
579 |
# Switcher for the 3 options for max_width (NULL, numeric, "auto"))
|
|
580 |
.handle_max_width <- function(tf_wrap, max_width, |
|
581 |
cpp = NULL, # Defaults to getOption("width", 80L) |
|
582 |
# Things for auto
|
|
583 |
inset = NULL, colwidths = NULL, col_gap = NULL) { |
|
584 | 234x |
max_width <- if (!tf_wrap) { |
585 | 114x |
if (!is.null(max_width)) { |
586 | 1x |
warning("tf_wrap is FALSE - ignoring non-null max_width value.") |
587 |
}
|
|
588 | 114x |
NULL
|
589 | 234x |
} else if (tf_wrap) { |
590 | 120x |
if (is.null(max_width)) { |
591 | 36x |
if (is.null(cpp) || is.na(cpp)) { |
592 | 7x |
getOption("width", 80L) |
593 |
} else { |
|
594 | 29x |
cpp
|
595 |
}
|
|
596 | 84x |
} else if (is.numeric(max_width)) { |
597 | 79x |
max_width
|
598 | 5x |
} else if (is.character(max_width) && identical(max_width, "auto")) { |
599 |
# This should not happen, but just in case
|
|
600 | 4x |
if (any(sapply(list(inset, colwidths, col_gap), is.null))) { |
601 | 1x |
stop("inset, colwidths, and col_gap must all be non-null when max_width is \"auto\".") |
602 |
}
|
|
603 | 3x |
inset + sum(colwidths) + (length(colwidths) - 1) * col_gap |
604 |
} else { |
|
605 | 1x |
stop("max_width must be NULL, a numeric value, or \"auto\".") |
606 |
}
|
|
607 |
}
|
|
608 | 232x |
return(max_width) |
609 |
}
|
|
610 | ||
611 |
.do_inset <- function(x, inset) { |
|
612 | 1038x |
if (inset == 0 || !any(nzchar(x))) { |
613 | 1019x |
return(x) |
614 |
}
|
|
615 | 19x |
padding <- strrep(" ", inset) |
616 | 19x |
if (is.character(x)) { |
617 | 19x |
x <- paste0(padding, x) |
618 | ! |
} else if (is(x, "matrix")) { |
619 | ! |
x[, 1] <- .do_inset(x[, 1, drop = TRUE], inset) |
620 |
}
|
|
621 | 19x |
x
|
622 |
}
|
|
623 | ||
624 |
.inset_div <- function(txt, div, inset) { |
|
625 | 105x |
c(.do_inset(div, inset), "", txt) |
626 |
}
|
|
627 | ||
628 |
.footer_inset_helper <- function(footers_v, div, inset) { |
|
629 | 153x |
div_done <- FALSE # nolint |
630 | 153x |
fter <- footers_v$main_footer |
631 | 153x |
prvf <- footers_v$prov_footer |
632 | 153x |
rfn <- footers_v$ref_footnotes |
633 | 153x |
footer_txt <- .do_inset(rfn, inset) |
634 | 153x |
if (any(nzchar(footer_txt))) { |
635 | 14x |
footer_txt <- .inset_div(footer_txt, div, inset) |
636 |
}
|
|
637 | 153x |
if (any(vapply( |
638 | 153x |
footers_v, function(x) any(nzchar(x)), |
639 | 153x |
TRUE
|
640 |
))) { |
|
641 | 91x |
if (any(nzchar(prvf))) { |
642 | 89x |
provtxt <- c( |
643 | 89x |
if (any(nzchar(fter))) "", |
644 | 89x |
prvf
|
645 |
)
|
|
646 |
} else { |
|
647 | 2x |
provtxt <- character() |
648 |
}
|
|
649 | 91x |
footer_txt <- c( |
650 | 91x |
footer_txt,
|
651 | 91x |
.inset_div( |
652 | 91x |
c( |
653 | 91x |
.do_inset(fter, inset), |
654 | 91x |
provtxt
|
655 |
),
|
|
656 | 91x |
div,
|
657 | 91x |
inset
|
658 |
)
|
|
659 |
)
|
|
660 |
}
|
|
661 | 153x |
footer_txt
|
662 |
}
|
|
663 | ||
664 |
reorder_ref_fnotes <- function(fns) { |
|
665 | 156x |
ind <- gsub("\\{(.*)\\}.*", "\\1", fns) |
666 | 156x |
ind_num <- suppressWarnings(as.numeric(ind)) |
667 | 156x |
is_num <- !is.na(ind_num) |
668 | 156x |
is_asis <- ind == fns |
669 | ||
670 | 156x |
if (all(is_num)) { |
671 | 140x |
ord_num <- order(ind_num) |
672 | 140x |
ord_char <- NULL |
673 | 140x |
ord_other <- NULL |
674 |
} else { |
|
675 | 16x |
ord_num <- order(ind_num[is_num]) |
676 | 16x |
ord_char <- order(ind[!is_num & !is_asis]) |
677 | 16x |
ord_other <- order(ind[is_asis]) |
678 |
}
|
|
679 | 156x |
c(fns[is_num][ord_num], fns[!is_num & !is_asis][ord_char], ind[is_asis][ord_other]) |
680 |
}
|
|
681 | ||
682 |
new_line_warning <- function(str_v) { |
|
683 | 136x |
if (any(unlist(sapply(str_v, grepl, pattern = "\n")))) { |
684 | ! |
msg <- c( |
685 | ! |
"Detected manual newlines when automatic title/footer word-wrapping is on.",
|
686 | ! |
"This is unsupported and will result in undefined behavior. Please either ",
|
687 | ! |
"utilize automatic word-wrapping with newline characters inserted, or ",
|
688 | ! |
"turn off automatic wrapping and wordwrap all contents manually by inserting ",
|
689 | ! |
"newlines."
|
690 |
)
|
|
691 | ! |
warning(paste0(msg, collapse = "")) |
692 |
}
|
|
693 |
}
|
|
694 | ||
695 |
#' Wrap a string to a precise width
|
|
696 |
#'
|
|
697 |
#' Core wrapping functionality that preserves whitespace. Newline character `"\n"` is not supported
|
|
698 |
#' by core functionality [stringi::stri_wrap()]. This is usually solved beforehand by [matrix_form()].
|
|
699 |
#' If the width is smaller than any large word, these will be truncated after `width` characters. If
|
|
700 |
#' the split leaves trailing groups of empty spaces, they will be dropped.
|
|
701 |
#'
|
|
702 |
#' @param str (`string`, `character`, or `list`)\cr string to be wrapped. If it is a `vector` or
|
|
703 |
#' a `list`, it will be looped as a `list` and returned with `unlist(use.names = FALSE)`.
|
|
704 |
#' @param width (`numeric(1)`)\cr width, in characters, that the text should be wrapped to.
|
|
705 |
#' @param collapse (`string` or `NULL`)\cr collapse character used to separate segments of words that
|
|
706 |
#' have been split and should be pasted together. This is usually done internally with `"\n"` to update
|
|
707 |
#' the wrapping along with other internal values.
|
|
708 |
#'
|
|
709 |
#' @details Word wrapping happens similarly to [stringi::stri_wrap()] with the following difference: individual
|
|
710 |
#' words which are longer than `max_width` are broken up in a way that fits with other word wrapping.
|
|
711 |
#'
|
|
712 |
#' @return A string if `str` is one element and if `collapse = NULL`. Otherwise, a list of elements
|
|
713 |
#' (if `length(str) > 1`) that can contain strings or vectors of characters (if `collapse = NULL`).
|
|
714 |
#'
|
|
715 |
#' @examples
|
|
716 |
#' str <- list(
|
|
717 |
#' " , something really \\tnot very good", # \t needs to be escaped
|
|
718 |
#' " but I keep it12 "
|
|
719 |
#' )
|
|
720 |
#' wrap_string(str, 5, collapse = "\n")
|
|
721 |
#'
|
|
722 |
#' @export
|
|
723 |
wrap_string <- function(str, width, collapse = NULL) { |
|
724 | 36443x |
if (length(str) > 1) { |
725 | 114x |
return( |
726 | 114x |
unlist( |
727 | 114x |
lapply(str, wrap_string, width = width, collapse = collapse), |
728 | 114x |
use.names = FALSE |
729 |
)
|
|
730 |
)
|
|
731 |
}
|
|
732 | 36329x |
str <- unlist(str, use.names = FALSE) # it happens is one list element |
733 | 36329x |
if (!length(str) || !nzchar(str) || is.na(str)) { |
734 | 3855x |
return(str) |
735 |
}
|
|
736 | 32474x |
checkmate::assert_character(str) |
737 | 32474x |
checkmate::assert_int(width, lower = 1) |
738 | ||
739 | 32474x |
if (any(grepl("\\n", str))) { |
740 | ! |
stop( |
741 | ! |
"Found \\n in a string that was meant to be wrapped. This should not happen ",
|
742 | ! |
"because matrix_form should take care of them before this step (toString, ",
|
743 | ! |
"i.e. the printing machinery). Please contact the maintaner or file an issue."
|
744 |
)
|
|
745 |
}
|
|
746 | ||
747 |
# str can be also a vector or list. In this case simplify manages the output
|
|
748 | 32474x |
ret <- .go_stri_wrap(str, width) |
749 | ||
750 |
# Check if it went fine
|
|
751 | 32474x |
if (any(nchar(ret) > width)) { |
752 | 68x |
which_exceeded <- which(nchar(ret) > width) |
753 | ||
754 |
# Recursive for loop to take word interval
|
|
755 | 68x |
while (length(which_exceeded) > 0) { |
756 | 75x |
we_i <- which_exceeded[1] |
757 |
# Is there space for some part of the next word?
|
|
758 | 75x |
char_threshold <- width * (2 / 3) + 0.01 # if too little space -> no previous word |
759 | 75x |
smart_condition <- nchar(ret[we_i - 1]) + 1 < char_threshold # +1 is for spaces |
760 | 75x |
if (we_i - 1 > 0 && smart_condition) { |
761 | 6x |
we_interval <- unique(c(we_i - 1, we_i)) |
762 | 6x |
we_interval <- we_interval[ |
763 | 6x |
(we_interval < (length(ret) + 1)) & |
764 | 6x |
(we_interval > 0) |
765 |
]
|
|
766 |
} else { |
|
767 | 69x |
we_interval <- we_i |
768 |
}
|
|
769 |
# Split words and collapse (needs unique afterwards)
|
|
770 | 75x |
ret[we_interval] <- split_words_by( |
771 | 75x |
paste0(ret[we_interval], collapse = " "), |
772 | 75x |
width
|
773 |
)
|
|
774 |
# Taking out repetitions if there are more than one
|
|
775 | 75x |
if (length(we_interval) > 1) { |
776 | 6x |
ret <- ret[-we_interval[-1]] |
777 | 6x |
we_interval <- we_interval[1] |
778 |
}
|
|
779 |
# Paste together and rerun if it is not the same as original ret
|
|
780 | 75x |
ret_collapse <- paste0(ret, collapse = " ") |
781 | ||
782 |
# Checking if we are stuck in a loop
|
|
783 | 75x |
ori_wrapped_txt_v <- .go_stri_wrap(str, width) |
784 | 75x |
cur_wrapped_txt_v <- .go_stri_wrap(ret_collapse, width) |
785 | 75x |
broken_char_ori <- sum(nchar(ori_wrapped_txt_v) > width) # how many issues there were |
786 | 75x |
broken_char_cur <- sum(nchar(cur_wrapped_txt_v) > width) # how many issues there are |
787 | ||
788 |
# if still broken, we did not solve the current issue!
|
|
789 | 75x |
if (setequal(ori_wrapped_txt_v, cur_wrapped_txt_v) || broken_char_cur >= broken_char_ori) { |
790 |
# help function: Very rare case where the recursion is stuck in a loop
|
|
791 | 14x |
ret_tmp <- force_split_words_by(ret[we_interval], width) # here we_interval is only one ind |
792 | 14x |
ret <- append(ret, ret_tmp, we_interval)[-we_interval] |
793 | 14x |
which_exceeded <- which(nchar(ret) > width) |
794 |
} else { |
|
795 | 61x |
return(wrap_string(str = ret_collapse, width = width, collapse = collapse)) |
796 |
}
|
|
797 |
}
|
|
798 |
}
|
|
799 | ||
800 | 32413x |
if (!is.null(collapse)) { |
801 | 31962x |
return(paste0(ret, collapse = collapse)) |
802 |
}
|
|
803 | ||
804 | 451x |
return(ret) |
805 |
}
|
|
806 | ||
807 |
.go_stri_wrap <- function(str, w) { |
|
808 | 32624x |
stringi::stri_wrap(str, |
809 | 32624x |
width = w, |
810 | 32624x |
normalize = FALSE, # keeps spaces |
811 | 32624x |
simplify = TRUE, # If FALSE makes it a list with str elements |
812 | 32624x |
indent = 0 |
813 |
)
|
|
814 |
}
|
|
815 | ||
816 |
# help function: Very rare case where the recursion is stuck in a loop
|
|
817 |
force_split_words_by <- function(ret, width) { |
|
818 | 14x |
which_exceeded <- which(nchar(ret) > width) |
819 | 14x |
ret_tmp <- NULL |
820 | 14x |
for (ii in seq_along(ret)) { |
821 | 14x |
if (ii %in% which_exceeded) { |
822 | 14x |
wrd_i <- ret[ii] |
823 | 14x |
init_v <- seq(1, nchar(wrd_i), by = width) |
824 | 14x |
end_v <- c(init_v[-1] - 1, nchar(wrd_i)) |
825 | 14x |
str_v_tmp <- stringi::stri_sub(wrd_i, from = init_v, to = end_v) |
826 | 14x |
ret_tmp <- c(ret_tmp, str_v_tmp[!grepl("^\\s+$", str_v_tmp) & nzchar(str_v_tmp)]) |
827 |
} else { |
|
828 | ! |
ret_tmp <- c(ret_tmp, ret[ii]) |
829 |
}
|
|
830 |
}
|
|
831 | 14x |
ret_tmp
|
832 |
}
|
|
833 | ||
834 |
# Helper fnc to split the words and collapse them with space
|
|
835 |
split_words_by <- function(wrd, width) { |
|
836 | 75x |
vapply(wrd, function(wrd_i) { |
837 | 75x |
init_v <- seq(1, nchar(wrd_i), by = width) |
838 | 75x |
end_v <- c(init_v[-1] - 1, nchar(wrd_i)) |
839 | 75x |
fin_str_v <- substring(wrd_i, init_v, end_v) |
840 | 75x |
is_only_spaces <- grepl("^\\s+$", fin_str_v) |
841 |
# We pop only spaces at this point
|
|
842 | 75x |
if (all(is_only_spaces)) { |
843 | ! |
fin_str_v <- fin_str_v[1] # keep only one width-sized empty |
844 |
} else { |
|
845 | 75x |
fin_str_v <- fin_str_v[!is_only_spaces] # hybrid text + \s |
846 |
}
|
|
847 | ||
848 |
# Collapse the string
|
|
849 | 75x |
paste0(fin_str_v, collapse = " ") |
850 | 75x |
}, character(1), USE.NAMES = FALSE) |
851 |
}
|
|
852 | ||
853 |
#' @describeIn wrap_string Deprecated function. Please use [wrap_string()] instead.
|
|
854 |
#'
|
|
855 |
#' @examples
|
|
856 |
#' wrap_txt(str, 5, collapse = NULL)
|
|
857 |
#'
|
|
858 |
#' @export
|
|
859 |
wrap_txt <- function(str, width, collapse = NULL) { |
|
860 | 396x |
unlist(wrap_string(str, width, collapse), use.names = FALSE) |
861 |
}
|
|
862 | ||
863 |
pad_vert_top <- function(x, len, default = "") { |
|
864 | 5510x |
c(x, rep(default, len - length(x))) |
865 |
}
|
|
866 | ||
867 |
pad_vert_bottom <- function(x, len, default = "") { |
|
868 | 326x |
c(rep(default, len - length(x)), x) |
869 |
}
|
|
870 | ||
871 |
pad_vec_to_len <- function(vec, len, cpadder = pad_vert_top, rlpadder = cpadder) { |
|
872 | 711x |
dat <- unlist(lapply(vec[-1], cpadder, len = len)) |
873 | 711x |
dat <- c(rlpadder(vec[[1]], len = len), dat) |
874 | 711x |
matrix(dat, nrow = len) |
875 |
}
|
|
876 | ||
877 |
rep_vec_to_len <- function(vec, len, ...) { |
|
878 | 674x |
matrix(unlist(lapply(vec, rep, times = len)), |
879 | 674x |
nrow = len |
880 |
)
|
|
881 |
}
|
|
882 | ||
883 |
safe_strsplit <- function(x, split, ...) { |
|
884 | 948x |
ret <- strsplit(x, split, ...) |
885 | 948x |
lapply(ret, function(reti) if (length(reti) == 0) "" else reti) |
886 |
}
|
|
887 | ||
888 |
.expand_mat_rows_inner <- function(i, mat, row_nlines, expfun, ...) { |
|
889 | 1385x |
leni <- row_nlines[i] |
890 | 1385x |
rw <- mat[i, ] |
891 | 1385x |
if (is.character(rw)) { |
892 | 948x |
rw <- safe_strsplit(rw, "\n", fixed = TRUE) |
893 |
}
|
|
894 | 1385x |
expfun(rw, len = leni, ...) |
895 |
}
|
|
896 | ||
897 |
expand_mat_rows <- function(mat, row_nlines = apply(mat, 1, nlines), expfun = pad_vec_to_len, ...) { |
|
898 | 238x |
rinds <- seq_len(nrow(mat)) |
899 | 238x |
exprows <- lapply(rinds, .expand_mat_rows_inner, |
900 | 238x |
mat = mat, |
901 | 238x |
row_nlines = row_nlines, |
902 | 238x |
expfun = expfun, |
903 |
...
|
|
904 |
)
|
|
905 | 238x |
do.call(rbind, exprows) |
906 |
}
|
|
907 | ||
908 |
#' Transform a vector of spans (with duplication) into a visibility vector
|
|
909 |
#'
|
|
910 |
#' @param spans (`numeric`)\cr a vector of spans, with each span value repeated
|
|
911 |
#' for the cells it covers.
|
|
912 |
#'
|
|
913 |
#' @details
|
|
914 |
#' The values of `spans` are assumed to be repeated such that each individual position covered by the
|
|
915 |
#' span has the repeated value.
|
|
916 |
#'
|
|
917 |
#' This means that each block of values in `spans` must be of a length at least equal to its value
|
|
918 |
#' (i.e. two 2s, three 3s, etc).
|
|
919 |
#'
|
|
920 |
#' This function correctly handles cases where two spans of the same size are next to each other;
|
|
921 |
#' i.e., a block of four 2s represents two large cells each of which spans two individual cells.
|
|
922 |
#'
|
|
923 |
#' @return A logical vector the same length as `spans` indicating whether the contents of a string vector
|
|
924 |
#' with those spans is valid.
|
|
925 |
#'
|
|
926 |
#' @note
|
|
927 |
#' Currently no checking or enforcement is done to verify that the vector of spans is valid according to
|
|
928 |
#' the specifications described in the Details section above.
|
|
929 |
#'
|
|
930 |
#' @examples
|
|
931 |
#' spans_to_viscell(c(2, 2, 2, 2, 1, 3, 3, 3))
|
|
932 |
#'
|
|
933 |
#' @export
|
|
934 |
spans_to_viscell <- function(spans) { |
|
935 | 2x |
if (!is.vector(spans)) { |
936 | ! |
spans <- as.vector(spans) |
937 |
}
|
|
938 | 2x |
myrle <- rle(spans) |
939 | 2x |
unlist( |
940 | 2x |
mapply( |
941 | 2x |
function(vl, ln) { |
942 | 4x |
rep(c(TRUE, rep(FALSE, vl - 1L)), times = ln / vl) |
943 |
},
|
|
944 | 2x |
SIMPLIFY = FALSE, |
945 | 2x |
vl = myrle$values, |
946 | 2x |
ln = myrle$lengths |
947 |
),
|
|
948 | 2x |
recursive = FALSE |
949 |
)
|
|
950 |
}
|
|
951 | ||
952 |
#' Propose column widths based on the `MatrixPrintForm` of an object
|
|
953 |
#'
|
|
954 |
#' Row names are also considered a column for the output.
|
|
955 |
#'
|
|
956 |
#' @param x (`ANY`)\cr a `MatrixPrintForm` object, or an object with a `matrix_form` method.
|
|
957 |
#' @param indent_size (`numeric(1)`)\cr indent size, in characters. Ignored when `x` is already
|
|
958 |
#' a `MatrixPrintForm` object in favor of information there.
|
|
959 |
#'
|
|
960 |
#' @return A vector of column widths based on the content of `x` for use in printing and pagination.
|
|
961 |
#'
|
|
962 |
#' @examples
|
|
963 |
#' mf <- basic_matrix_form(mtcars)
|
|
964 |
#' propose_column_widths(mf)
|
|
965 |
#'
|
|
966 |
#' @export
|
|
967 |
propose_column_widths <- function(x, indent_size = 2) { |
|
968 | 92x |
if (!is(x, "MatrixPrintForm")) { |
969 | ! |
x <- matrix_form(x, indent_rownames = TRUE, indent_size = indent_size) |
970 |
}
|
|
971 | 92x |
body <- mf_strings(x) |
972 | 92x |
spans <- mf_spans(x) |
973 | 92x |
aligns <- mf_aligns(x) |
974 | 92x |
display <- mf_display(x) |
975 | ||
976 |
# compute decimal alignment if asked in alignment matrix
|
|
977 | 92x |
if (any_dec_align(aligns)) { |
978 | 27x |
body <- decimal_align(body, aligns) |
979 |
}
|
|
980 | ||
981 | 89x |
chars <- nchar(body) |
982 | ||
983 |
# first check column widths without colspan
|
|
984 | 89x |
has_spans <- spans != 1 |
985 | 89x |
chars_ns <- chars |
986 | 89x |
chars_ns[has_spans] <- 0 |
987 | 89x |
widths <- apply(chars_ns, 2, max) |
988 | ||
989 |
# now check if the colspans require extra width
|
|
990 | 89x |
if (any(has_spans)) { |
991 | 1x |
has_row_spans <- apply(has_spans, 1, any) |
992 | ||
993 | 1x |
chars_sp <- chars[has_row_spans, , drop = FALSE] |
994 | 1x |
spans_sp <- spans[has_row_spans, , drop = FALSE] |
995 | 1x |
disp_sp <- display[has_row_spans, , drop = FALSE] |
996 | ||
997 | 1x |
nc <- ncol(spans) |
998 | 1x |
for (i in seq_len(nrow(chars_sp))) { |
999 | 1x |
for (j in seq_len(nc)) { |
1000 | 2x |
if (disp_sp[i, j] && spans_sp[i, j] != 1) { |
1001 | 1x |
i_cols <- seq(j, j + spans_sp[i, j] - 1) |
1002 | ||
1003 | 1x |
nchar_i <- chars_sp[i, j] |
1004 | 1x |
cw_i <- widths[i_cols] |
1005 | 1x |
available_width <- sum(cw_i) |
1006 | ||
1007 | 1x |
if (nchar_i > available_width) { |
1008 |
# need to update widths to fit content with colspans
|
|
1009 |
# spread width among columns
|
|
1010 | ! |
widths[i_cols] <- cw_i + spread_integer(nchar_i - available_width, length(cw_i)) |
1011 |
}
|
|
1012 |
}
|
|
1013 |
}
|
|
1014 |
}
|
|
1015 |
}
|
|
1016 | 89x |
widths
|
1017 |
}
|
|
1018 | ||
1019 |
#' Pad a string and align within string
|
|
1020 |
#'
|
|
1021 |
#' @param x (`string`)\cr a string.
|
|
1022 |
#' @param n (`integer(1)`)\cr number of characters in the output string. If `n < nchar(x)`, an error is thrown.
|
|
1023 |
#' @param just (`string`)\cr text alignment justification to use. Defaults to `"center"`. Must be one of
|
|
1024 |
#' `"center"`, `"right"`, `"left"`, `"dec_right"`, `"dec_left"`, or `"decimal"`.
|
|
1025 |
#'
|
|
1026 |
#' @return `x`, padded to be a string of length `n`.
|
|
1027 |
#'
|
|
1028 |
#' @examples
|
|
1029 |
#' padstr("abc", 3)
|
|
1030 |
#' padstr("abc", 4)
|
|
1031 |
#' padstr("abc", 5)
|
|
1032 |
#' padstr("abc", 5, "left")
|
|
1033 |
#' padstr("abc", 5, "right")
|
|
1034 |
#'
|
|
1035 |
#' \dontrun{
|
|
1036 |
#' # Expect error: "abc" has more than 1 characters
|
|
1037 |
#' padstr("abc", 1)
|
|
1038 |
#' }
|
|
1039 |
#'
|
|
1040 |
#' @export
|
|
1041 |
padstr <- function(x, n, just = list_valid_aligns()) { |
|
1042 | 15607x |
just <- match.arg(just) |
1043 | ||
1044 | 1x |
if (length(x) != 1) stop("length of x needs to be 1 and not", length(x)) |
1045 | 1x |
if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0") |
1046 | ||
1047 | 2x |
if (is.na(x)) x <- "<NA>" |
1048 | ||
1049 | 15605x |
nc <- nchar(x) |
1050 | ||
1051 | ! |
if (n < nc) stop("\"", x, "\" has more than ", n, " characters") |
1052 | ||
1053 | 15605x |
switch(just, |
1054 |
center = { |
|
1055 | 13706x |
pad <- (n - nc) / 2 |
1056 | 13706x |
paste0(spaces(floor(pad)), x, spaces(ceiling(pad))) |
1057 |
},
|
|
1058 | 1748x |
left = paste0(x, spaces(n - nc)), |
1059 | 10x |
right = paste0(spaces(n - nc), x), |
1060 |
decimal = { |
|
1061 | 61x |
pad <- (n - nc) / 2 |
1062 | 61x |
paste0(spaces(floor(pad)), x, spaces(ceiling(pad))) |
1063 |
},
|
|
1064 | 45x |
dec_left = paste0(x, spaces(n - nc)), |
1065 | 35x |
dec_right = paste0(spaces(n - nc), x) |
1066 |
)
|
|
1067 |
}
|
|
1068 | ||
1069 |
spaces <- function(n) { |
|
1070 | 29530x |
strrep(" ", n) |
1071 |
}
|
|
1072 | ||
1073 |
.paste_no_na <- function(x, ...) { |
|
1074 | 2394x |
paste(na.omit(x), ...) |
1075 |
}
|
|
1076 | ||
1077 |
#' Spread an integer to a given length
|
|
1078 |
#'
|
|
1079 |
#' @param x (`integer(1)`)\cr number to spread.
|
|
1080 |
#' @param len (`integer(1)`)\cr number of times to repeat `x`.
|
|
1081 |
#'
|
|
1082 |
#' @return If `x` is a scalar whole number value (see [is.wholenumber()]), the value `x` is repeated `len` times.
|
|
1083 |
#' Otherwise, an error is thrown.
|
|
1084 |
#'
|
|
1085 |
#' @examples
|
|
1086 |
#' spread_integer(3, 1)
|
|
1087 |
#' spread_integer(0, 3)
|
|
1088 |
#' spread_integer(1, 3)
|
|
1089 |
#' spread_integer(2, 3)
|
|
1090 |
#' spread_integer(3, 3)
|
|
1091 |
#' spread_integer(4, 3)
|
|
1092 |
#' spread_integer(5, 3)
|
|
1093 |
#' spread_integer(6, 3)
|
|
1094 |
#' spread_integer(7, 3)
|
|
1095 |
#'
|
|
1096 |
#' @export
|
|
1097 |
spread_integer <- function(x, len) { |
|
1098 | 2x |
stopifnot( |
1099 | 2x |
is.wholenumber(x), length(x) == 1, x >= 0, |
1100 | 2x |
is.wholenumber(len), length(len) == 1, len >= 0, |
1101 | 2x |
!(len == 0 && x > 0) |
1102 |
)
|
|
1103 | ||
1104 | 1x |
if (len == 0) { |
1105 | ! |
integer(0) |
1106 |
} else { |
|
1107 | 1x |
y <- rep(floor(x / len), len) |
1108 | 1x |
i <- 1 |
1109 | 1x |
while (sum(y) < x) { |
1110 | 1x |
y[i] <- y[i] + 1 |
1111 | 1x |
if (i == len) { |
1112 | ! |
i <- 1 |
1113 |
} else { |
|
1114 | 1x |
i <- i + 1 |
1115 |
}
|
|
1116 |
}
|
|
1117 | 1x |
y
|
1118 |
}
|
|
1119 |
}
|
|
1120 | ||
1121 |
#' Check if a value is a whole number
|
|
1122 |
#'
|
|
1123 |
#' @param x (`numeric(1)`)\cr a numeric value.
|
|
1124 |
#' @param tol (`numeric(1)`)\cr a precision tolerance.
|
|
1125 |
#'
|
|
1126 |
#' @return `TRUE` if `x` is within `tol` of zero, `FALSE` otherwise.
|
|
1127 |
#'
|
|
1128 |
#' @examples
|
|
1129 |
#' is.wholenumber(5)
|
|
1130 |
#' is.wholenumber(5.00000000000000001)
|
|
1131 |
#' is.wholenumber(.5)
|
|
1132 |
#'
|
|
1133 |
#' @export
|
|
1134 |
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) { |
|
1135 | 3x |
abs(x - round(x)) < tol |
1136 |
}
|
1 |
formats_1d <- c( |
|
2 |
"xx", "xx.", "xx.x", "xx.xx", "xx.xxx", "xx.xxxx", |
|
3 |
"xx%", "xx.%", "xx.x%", "xx.xx%", "xx.xxx%", "(N=xx)", "N=xx", ">999.9", ">999.99", |
|
4 |
"x.xxxx | (<0.0001)"
|
|
5 |
)
|
|
6 | ||
7 |
formats_2d <- c( |
|
8 |
"xx / xx", "xx. / xx.", "xx.x / xx.x", "xx.xx / xx.xx", "xx.xxx / xx.xxx", |
|
9 |
"N=xx (xx%)", "xx (xx%)", "xx (xx.%)", "xx (xx.x%)", "xx (xx.xx%)", |
|
10 |
"xx. (xx.%)", "xx.x (xx.x%)", "xx.xx (xx.xx%)", |
|
11 |
"(xx, xx)", "(xx., xx.)", "(xx.x, xx.x)", "(xx.xx, xx.xx)", |
|
12 |
"(xx.xxx, xx.xxx)", "(xx.xxxx, xx.xxxx)", |
|
13 |
"xx - xx", "xx.x - xx.x", "xx.xx - xx.xx", |
|
14 |
"xx (xx)", "xx. (xx.)", "xx.x (xx.x)", "xx.xx (xx.xx)", |
|
15 |
"xx (xx.)", "xx (xx.x)", "xx (xx.xx)", |
|
16 |
"xx.x, xx.x",
|
|
17 |
"xx.x to xx.x"
|
|
18 |
)
|
|
19 | ||
20 |
formats_3d <- c( |
|
21 |
"xx. (xx. - xx.)",
|
|
22 |
"xx.x (xx.x - xx.x)",
|
|
23 |
"xx.xx (xx.xx - xx.xx)",
|
|
24 |
"xx.xxx (xx.xxx - xx.xxx)"
|
|
25 |
)
|
|
26 | ||
27 |
#' List of currently supported formats and vertical alignments
|
|
28 |
#'
|
|
29 |
#' @description We support `xx` style format labels grouped by 1d, 2d, and 3d.
|
|
30 |
#' Currently valid format labels cannot be added dynamically. Format functions
|
|
31 |
#' must be used for special cases.
|
|
32 |
#'
|
|
33 |
#' @return
|
|
34 |
#' * `list_valid_format_labels()` returns a nested list, with elements listing the supported 1d, 2d,
|
|
35 |
#' and 3d format strings.
|
|
36 |
#'
|
|
37 |
#' @examples
|
|
38 |
#' list_valid_format_labels()
|
|
39 |
#'
|
|
40 |
#' @name list_formats
|
|
41 |
#' @export
|
|
42 |
list_valid_format_labels <- function() { |
|
43 | 55x |
structure( |
44 | 55x |
list( |
45 | 55x |
"1d" = formats_1d, |
46 | 55x |
"2d" = formats_2d, |
47 | 55x |
"3d" = formats_3d |
48 |
),
|
|
49 | 55x |
info = "xx does not modify the element, and xx. rounds a number to 0 digits" |
50 |
)
|
|
51 |
}
|
|
52 | ||
53 |
#' @return
|
|
54 |
#' * `list_valid_aligns()` returns a character vector of valid vertical alignments.
|
|
55 |
#'
|
|
56 |
#' @examples
|
|
57 |
#' list_valid_aligns()
|
|
58 |
#'
|
|
59 |
#' @name list_formats
|
|
60 |
#' @export
|
|
61 |
list_valid_aligns <- function() { |
|
62 | 16205x |
c("left", "right", "center", "decimal", "dec_right", "dec_left") |
63 |
}
|
|
64 | ||
65 |
#' Check if a format or alignment is supported
|
|
66 |
#'
|
|
67 |
#' @description Utility functions for checking formats and alignments.
|
|
68 |
#'
|
|
69 |
#' @param x (`string` or `function`)\cr format string or an object returned by [sprintf_format()]
|
|
70 |
#' @param stop_otherwise (`flag`)\cr whether an error should be thrown if `x` is not a valid format.
|
|
71 |
#'
|
|
72 |
#' @return
|
|
73 |
#' * `is_valid_format` returns `TRUE` if `x` is `NULL`, a supported format string, or a function, and
|
|
74 |
#' `FALSE` otherwise.
|
|
75 |
#'
|
|
76 |
#' @note If `x` is a function, no check is performed to verify that it returns a valid format.
|
|
77 |
#'
|
|
78 |
#' @examples
|
|
79 |
#' is_valid_format("xx.x")
|
|
80 |
#' is_valid_format("fakeyfake")
|
|
81 |
#'
|
|
82 |
#' @name check_formats
|
|
83 |
#' @export
|
|
84 |
is_valid_format <- function(x, stop_otherwise = FALSE) { |
|
85 | 52x |
is_valid <- is.null(x) || (length(x) == 1 && (is.function(x) || x %in% unlist(list_valid_format_labels()))) |
86 | ||
87 | 52x |
if (stop_otherwise && !is_valid) { |
88 | ! |
stop("format needs to be a format label, sprintf_format object, a function, or NULL") |
89 |
}
|
|
90 | ||
91 | 52x |
is_valid
|
92 |
}
|
|
93 | ||
94 |
#' @param algn (`character`)\cr a character vector that indicates the requested cell alignments.
|
|
95 |
#'
|
|
96 |
#' @return
|
|
97 |
#' * `check_aligns` returns `TRUE` if the provided alignments are supported, otherwise, an error is thrown.
|
|
98 |
#'
|
|
99 |
#' @examples
|
|
100 |
#' check_aligns(c("decimal", "dec_right"))
|
|
101 |
#'
|
|
102 |
#' @name check_formats
|
|
103 |
#' @export
|
|
104 |
check_aligns <- function(algn) { |
|
105 | ! |
if (anyNA(algn)) { |
106 | ! |
stop("Got missing-value for text alignment.") |
107 |
}
|
|
108 | ! |
invalid <- setdiff(algn, list_valid_aligns()) |
109 | ! |
if (length(invalid) > 0) { |
110 | ! |
stop("Unsupported text-alignment(s): ", paste(invalid, collapse = ", ")) |
111 |
}
|
|
112 | ! |
invisible(TRUE) |
113 |
}
|
|
114 | ||
115 |
#' Specify text format via a `sprintf` format string
|
|
116 |
#'
|
|
117 |
#' @param format (`string`)\cr a format string passed to [sprintf()].
|
|
118 |
#'
|
|
119 |
#' @return A formatting function which wraps and applies the specified `sprintf`-style format
|
|
120 |
#' to string `format`.
|
|
121 |
#'
|
|
122 |
#' @seealso [sprintf()]
|
|
123 |
#'
|
|
124 |
#' @examples
|
|
125 |
#' fmtfun <- sprintf_format("(N=%i")
|
|
126 |
#' format_value(100, format = fmtfun)
|
|
127 |
#'
|
|
128 |
#' fmtfun2 <- sprintf_format("%.4f - %.2f")
|
|
129 |
#' format_value(list(12.23456, 2.724))
|
|
130 |
#'
|
|
131 |
#' @export
|
|
132 |
sprintf_format <- function(format) { |
|
133 | 1x |
function(x, ...) { |
134 | 1x |
do.call(sprintf, c(list(fmt = format), x)) |
135 |
}
|
|
136 |
}
|
|
137 | ||
138 |
#' Round and prepare a value for display
|
|
139 |
#'
|
|
140 |
#' This function is used within [format_value()] to prepare numeric values within
|
|
141 |
#' cells for formatting and display.
|
|
142 |
#'
|
|
143 |
#' @param x (`numeric(1)`)\cr value to format.
|
|
144 |
#' @param digits (`numeric(1)`)\cr number of digits to round to, or `NA` to convert to a
|
|
145 |
#' character value with no rounding.
|
|
146 |
#' @param na_str (`string`)\cr the value to return if `x` is `NA`.
|
|
147 |
#'
|
|
148 |
#' @details
|
|
149 |
#' This function combines the rounding behavior of R's standards-compliant [round()]
|
|
150 |
#' function (see the Details section of that documentation) with the strict decimal display
|
|
151 |
#' of [sprintf()]. The exact behavior is as follows:
|
|
152 |
#'
|
|
153 |
#' \enumerate{
|
|
154 |
#' \item{If `x` is `NA`, the value of `na_str` is returned.}
|
|
155 |
#' \item{If `x` is non-`NA` but `digits` is `NA`, `x` is converted to a character and returned.}
|
|
156 |
#' \item{If `x` and `digits` are both non-NA, [round()] is called first, and then [sprintf()]
|
|
157 |
#' is used to convert the rounded value to a character with the appropriate number of trailing
|
|
158 |
#' zeros enforced.}
|
|
159 |
#' }
|
|
160 |
#'
|
|
161 |
#' @return A character value representing the value after rounding, containing any trailing zeros
|
|
162 |
#' required to display *exactly* `digits` elements.
|
|
163 |
#'
|
|
164 |
#' @note
|
|
165 |
#' This differs from the base R [round()] function in that `NA` digits indicate `x` should be converted
|
|
166 |
#' to character and returned unchanged whereas `round(x, digits=NA)` returns `NA` for all values of `x`.
|
|
167 |
#'
|
|
168 |
#' This behavior will differ from `as.character(round(x, digits = digits))` in the case where there are
|
|
169 |
#' not at least `digits` significant digits after the decimal that remain after rounding. It *may* differ from
|
|
170 |
#' `sprintf("\%.Nf", x)` for values ending in `5` after the decimal place on many popular operating systems
|
|
171 |
#' due to `round`'s stricter adherence to the IEC 60559 standard, particularly for R versions > 4.0.0 (see
|
|
172 |
#' warning in [round()] documentation).
|
|
173 |
#'
|
|
174 |
#' @seealso [format_value()], [round()], [sprintf()]
|
|
175 |
#'
|
|
176 |
#' @examples
|
|
177 |
#' round_fmt(0, digits = 3)
|
|
178 |
#' round_fmt(.395, digits = 2)
|
|
179 |
#' round_fmt(NA, digits = 1)
|
|
180 |
#' round_fmt(NA, digits = 1, na_str = "-")
|
|
181 |
#' round_fmt(2.765923, digits = NA)
|
|
182 |
#'
|
|
183 |
#' @export
|
|
184 |
#' @aliases rounding
|
|
185 |
round_fmt <- function(x, digits, na_str = "NA") { |
|
186 | 196x |
if (!is.na(digits) && digits < 0) { |
187 | ! |
stop("round_fmt currentlyd does not support non-missing values of digits <0") |
188 |
}
|
|
189 | 196x |
if (is.na(x)) { |
190 | 4x |
na_str
|
191 | 192x |
} else if (is.na(digits)) { |
192 | 44x |
paste0(x) |
193 |
} else { |
|
194 | 148x |
sprfmt <- paste0("%.", digits, "f") |
195 | 148x |
sprintf(fmt = sprfmt, round(x, digits = digits)) |
196 |
}
|
|
197 |
}
|
|
198 | ||
199 |
val_pct_helper <- function(x, dig1, dig2, na_str, pct = TRUE) { |
|
200 | 32x |
if (pct) { |
201 | 18x |
x[2] <- x[2] * 100 |
202 |
}
|
|
203 | 32x |
if (length(na_str) == 1) { |
204 | 32x |
na_str <- rep(na_str, 2) |
205 |
}
|
|
206 | 32x |
paste0( |
207 | 32x |
round_fmt(x[1], digits = dig1, na_str = na_str[1]), |
208 |
" (",
|
|
209 | 32x |
round_fmt(x[2], digits = dig2, na_str = na_str[2]), |
210 | 32x |
if (pct) "%", ")" |
211 |
)
|
|
212 |
}
|
|
213 | ||
214 |
sep_2d_helper <- function(x, dig1, dig2, sep, na_str, wrap = NULL) { |
|
215 | 43x |
ret <- paste(mapply(round_fmt, x = x, digits = c(dig1, dig2), na_str = na_str), |
216 | 43x |
collapse = sep |
217 |
)
|
|
218 | 43x |
if (!is.null(wrap)) { |
219 | 20x |
ret <- paste(c(wrap[1], ret, wrap[2]), collapse = "") |
220 |
}
|
|
221 | 43x |
ret
|
222 |
}
|
|
223 | ||
224 |
## na_or_round <- function(x, digits, na_str) {
|
|
225 |
## if(is.na(x))
|
|
226 |
## na_str
|
|
227 |
## else
|
|
228 |
## round(x, digits = digits)
|
|
229 |
## }
|
|
230 | ||
231 |
#' Converts a (possibly compound) value into a string using the `format` information
|
|
232 |
#'
|
|
233 |
#' @param x (`ANY`)\cr the value to be formatted.
|
|
234 |
#' @param format (`string` or `function`)\cr the format label (string) or formatter function to
|
|
235 |
#' apply to `x`.
|
|
236 |
#' @param na_str (`string`)\cr string to display when the value of `x` is missing. Defaults to `"NA"`.
|
|
237 |
#' @param output (`string`)\cr output type.
|
|
238 |
#'
|
|
239 |
#' @details A length-zero value for `na_str` will be interpreted as `"NA"`, as will any
|
|
240 |
#' missing values within a non-length-zero `na_str` vector.
|
|
241 |
#'
|
|
242 |
#' @return Formatted text representing the cell `x`.
|
|
243 |
#'
|
|
244 |
#' @seealso [round_fmt()]
|
|
245 |
#'
|
|
246 |
#' @examples
|
|
247 |
#' x <- format_value(pi, format = "xx.xx")
|
|
248 |
#' x
|
|
249 |
#'
|
|
250 |
#' format_value(x, output = "ascii")
|
|
251 |
#'
|
|
252 |
#' @export
|
|
253 |
format_value <- function(x, format = NULL, output = c("ascii", "html"), na_str = "NA") { |
|
254 |
## if(is(x, "CellValue"))
|
|
255 |
## x = x[[1]]
|
|
256 | ||
257 | 9133x |
if (length(x) == 0) { |
258 | 1x |
return("") |
259 |
}
|
|
260 | ||
261 | 9132x |
output <- match.arg(output) |
262 | 9132x |
if (length(na_str) == 0) { |
263 | 1x |
na_str <- "NA" |
264 |
}
|
|
265 | 9132x |
if (any(is.na(na_str))) { |
266 | 1x |
na_str[is.na(na_str)] <- "NA" |
267 |
}
|
|
268 |
## format <- if (!missing(format)) format else obj_format(x)
|
|
269 | ||
270 | 9132x |
txt <- if (all(is.na(x)) && length(na_str) == 1L) { |
271 | 22x |
na_str
|
272 | 9132x |
} else if (is.null(format)) { |
273 | 302x |
toString(x) |
274 | 9132x |
} else if (is.function(format)) { |
275 | 1x |
format(x, output = output) |
276 | 9132x |
} else if (is.character(format)) { |
277 | 8807x |
l <- if (format %in% formats_1d) { |
278 | 8729x |
1
|
279 | 8807x |
} else if (format %in% formats_2d) { |
280 | 69x |
2
|
281 | 8807x |
} else if (format %in% formats_3d) { |
282 | 8x |
3
|
283 |
} else { |
|
284 | 1x |
stop( |
285 | 1x |
"unknown format label: ", format, |
286 | 1x |
". use list_valid_format_labels() to get a list of all formats"
|
287 |
)
|
|
288 |
}
|
|
289 | 8806x |
if (format != "xx" && length(x) != l) { |
290 | 2x |
stop( |
291 | 2x |
"cell <", paste(x), "> and format ", |
292 | 2x |
format, " are of different length" |
293 |
)
|
|
294 |
}
|
|
295 | 8804x |
if (length(na_str) < sum(is.na(x))) { |
296 | ! |
na_str <- rep(na_str, length.out = sum(is.na(x))) |
297 |
}
|
|
298 | 8804x |
switch(format, |
299 | 8688x |
"xx" = as.character(x), |
300 | 3x |
"xx." = round_fmt(x, digits = 0, na_str = na_str), |
301 | 6x |
"xx.x" = round_fmt(x, digits = 1, na_str = na_str), |
302 | 3x |
"xx.xx" = round_fmt(x, digits = 2, na_str = na_str), |
303 | 3x |
"xx.xxx" = round_fmt(x, digits = 3, na_str = na_str), |
304 | 3x |
"xx.xxxx" = round_fmt(x, digits = 4, na_str = na_str), |
305 | 2x |
"xx%" = paste0(round_fmt(x * 100, digits = NA, na_str = na_str), "%"), |
306 | 2x |
"xx.%" = paste0(round_fmt(x * 100, digits = 0, na_str = na_str), "%"), |
307 | 2x |
"xx.x%" = paste0(round_fmt(x * 100, digits = 1, na_str = na_str), "%"), |
308 | 2x |
"xx.xx%" = paste0(round_fmt(x * 100, digits = 2, na_str = na_str), "%"), |
309 | 2x |
"xx.xxx%" = paste0(round_fmt(x * 100, digits = 3, na_str = na_str), "%"), |
310 | 2x |
"(N=xx)" = paste0("(N=", round_fmt(x, digits = NA, na_str = na_str), ")"), |
311 | 2x |
"N=xx" = paste0("N=", round_fmt(x, digits = NA, na_str = na_str)), |
312 | 3x |
">999.9" = ifelse(x > 999.9, ">999.9", round_fmt(x, digits = 1, na_str = na_str)), |
313 | 3x |
">999.99" = ifelse(x > 999.99, ">999.99", round_fmt(x, digits = 2, na_str = na_str)), |
314 | 3x |
"x.xxxx | (<0.0001)" = ifelse(x < 0.0001, "<0.0001", round_fmt(x, digits = 4, na_str = na_str)), |
315 | 2x |
"xx / xx" = sep_2d_helper(x, dig1 = NA, dig2 = NA, sep = " / ", na_str = na_str), |
316 | 2x |
"xx. / xx." = sep_2d_helper(x, dig1 = 0, dig2 = 0, sep = " / ", na_str = na_str), |
317 | 2x |
"xx.x / xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " / ", na_str = na_str), |
318 | 2x |
"xx.xx / xx.xx" = sep_2d_helper(x, dig1 = 2, dig2 = 2, sep = " / ", na_str = na_str), |
319 | 2x |
"xx.xxx / xx.xxx" = sep_2d_helper(x, dig1 = 3, dig2 = 3, sep = " / ", na_str = na_str), |
320 | 2x |
"N=xx (xx%)" = paste0("N=", val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str)), |
321 | 3x |
"xx (xx%)" = val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str), |
322 | 2x |
"xx (xx.%)" = val_pct_helper(x, dig1 = NA, dig2 = 0, na_str = na_str), |
323 | 2x |
"xx (xx.x%)" = val_pct_helper(x, dig1 = NA, dig2 = 1, na_str = na_str), |
324 | 2x |
"xx (xx.xx%)" = val_pct_helper(x, dig1 = NA, dig2 = 2, na_str = na_str), |
325 | 2x |
"xx. (xx.%)" = val_pct_helper(x, dig1 = 0, dig2 = 0, na_str = na_str), |
326 | 3x |
"xx.x (xx.x%)" = val_pct_helper(x, dig1 = 1, dig2 = 1, na_str = na_str), |
327 | 2x |
"xx.xx (xx.xx%)" = val_pct_helper(x, dig1 = 2, dig2 = 2, na_str = na_str), |
328 | 2x |
"(xx, xx)" = sep_2d_helper(x, |
329 | 2x |
dig1 = NA, dig2 = NA, sep = ", ", |
330 | 2x |
na_str = na_str, wrap = c("(", ")") |
331 |
),
|
|
332 | 2x |
"(xx., xx.)" = sep_2d_helper(x, |
333 | 2x |
dig1 = 0, dig2 = 0, sep = ", ", |
334 | 2x |
na_str = na_str, wrap = c("(", ")") |
335 |
),
|
|
336 | 2x |
"(xx.x, xx.x)" = sep_2d_helper(x, |
337 | 2x |
dig1 = 1, dig2 = 1, sep = ", ", |
338 | 2x |
na_str = na_str, wrap = c("(", ")") |
339 |
),
|
|
340 | 2x |
"(xx.xx, xx.xx)" = sep_2d_helper(x, |
341 | 2x |
dig1 = 2, dig2 = 2, sep = ", ", |
342 | 2x |
na_str = na_str, wrap = c("(", ")") |
343 |
),
|
|
344 | 2x |
"(xx.xxx, xx.xxx)" = sep_2d_helper(x, |
345 | 2x |
dig1 = 3, dig2 = 3, sep = ", ", |
346 | 2x |
na_str = na_str, wrap = c("(", ")") |
347 |
),
|
|
348 | 2x |
"(xx.xxxx, xx.xxxx)" = sep_2d_helper(x, |
349 | 2x |
dig1 = 4, dig2 = 4, sep = ", ", |
350 | 2x |
na_str = na_str, wrap = c("(", ")") |
351 |
),
|
|
352 | 2x |
"xx - xx" = sep_2d_helper(x, dig1 = NA, dig2 = NA, sep = " - ", na_str = na_str), |
353 | 5x |
"xx.x - xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " - ", na_str = na_str), |
354 | 2x |
"xx.xx - xx.xx" = sep_2d_helper(x, dig1 = 2, dig2 = 2, sep = " - ", na_str = na_str), |
355 | 2x |
"xx (xx)" = val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str, pct = FALSE), |
356 | 2x |
"xx. (xx.)" = val_pct_helper(x, dig1 = 0, dig2 = 0, na_str = na_str, pct = FALSE), |
357 | 2x |
"xx.x (xx.x)" = val_pct_helper(x, dig1 = 1, dig2 = 1, na_str = na_str, pct = FALSE), |
358 | 2x |
"xx.xx (xx.xx)" = val_pct_helper(x, dig1 = 2, dig2 = 2, na_str = na_str, pct = FALSE), |
359 | 2x |
"xx (xx.)" = val_pct_helper(x, dig1 = NA, dig2 = 0, na_str = na_str, pct = FALSE), |
360 | 2x |
"xx (xx.x)" = val_pct_helper(x, dig1 = NA, dig2 = 1, na_str = na_str, pct = FALSE), |
361 | 2x |
"xx (xx.xx)" = val_pct_helper(x, dig1 = NA, dig2 = 2, na_str = na_str, pct = FALSE), |
362 | 2x |
"xx.x, xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = ", ", na_str = na_str), |
363 | 2x |
"xx.x to xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " to ", na_str = na_str), |
364 | 2x |
"xx.xx (xx.xx - xx.xx)" = paste0( |
365 | 2x |
round_fmt(x[1], digits = 2, na_str = na_str[1]), " ", |
366 | 2x |
sep_2d_helper(x[2:3], |
367 | 2x |
dig1 = 2, dig2 = 2, |
368 | 2x |
sep = " - ", na_str = na_str[2:3], |
369 | 2x |
wrap = c("(", ")") |
370 |
)
|
|
371 |
),
|
|
372 | 2x |
"xx. (xx. - xx.)" = paste0( |
373 | 2x |
round_fmt(x[1], digits = 0, na_str = na_str[1]), " ", |
374 | 2x |
sep_2d_helper(x[2:3], |
375 | 2x |
dig1 = 0, dig2 = 0, |
376 | 2x |
sep = " - ", na_str = na_str[2:3], |
377 | 2x |
wrap = c("(", ")") |
378 |
)
|
|
379 |
),
|
|
380 | 2x |
"xx.x (xx.x - xx.x)" = paste0( |
381 | 2x |
round_fmt(x[1], digits = 1, na_str = na_str[1]), " ", |
382 | 2x |
sep_2d_helper(x[2:3], |
383 | 2x |
dig1 = 1, dig2 = 1, |
384 | 2x |
sep = " - ", na_str = na_str[2:3], |
385 | 2x |
wrap = c("(", ")") |
386 |
)
|
|
387 |
),
|
|
388 | 2x |
"xx.xxx (xx.xxx - xx.xxx)" = paste0( |
389 | 2x |
round_fmt(x[1], digits = 3, na_str = na_str[1]), " ", |
390 | 2x |
sep_2d_helper(x[2:3], |
391 | 2x |
dig1 = 3, dig2 = 3, |
392 | 2x |
sep = " - ", na_str = na_str[2:3], |
393 | 2x |
wrap = c("(", ")") |
394 |
)
|
|
395 |
),
|
|
396 | ! |
paste("format string", format, "not found") |
397 |
)
|
|
398 |
}
|
|
399 | 9129x |
txt[is.na(txt)] <- na_str |
400 | 9129x |
if (output == "ascii") { |
401 | 9128x |
txt
|
402 | 1x |
} else if (output == "html") { |
403 |
## convert to tagList
|
|
404 |
## convert \n to <br/>
|
|
405 | ||
406 | 1x |
if (identical(txt, "")) { |
407 | ! |
txt
|
408 |
} else { |
|
409 | 1x |
els <- unlist(strsplit(txt, "\n", fixed = TRUE)) |
410 | 1x |
Map(function(el, is.last) { |
411 | 1x |
tagList(el, if (!is.last) tags$br() else NULL) |
412 | 1x |
}, els, c(rep(FALSE, length(els) - 1), TRUE)) |
413 |
}
|
|
414 |
} else { |
|
415 | ! |
txt
|
416 |
}
|
|
417 |
}
|
|
418 | ||
419 |
setClassUnion("FormatSpec", c("NULL", "character", "function", "list")) |
|
420 |
setClassUnion("characterOrNULL", c("NULL", "character")) |
|
421 |
setClass("fmt_config", |
|
422 |
slots = c( |
|
423 |
format = "FormatSpec", |
|
424 |
format_na_str = "characterOrNULL", |
|
425 |
align = "characterOrNULL" |
|
426 |
)
|
|
427 |
)
|
|
428 | ||
429 |
#' Format configuration
|
|
430 |
#'
|
|
431 |
#' @param format (`string` or `function`)\cr a format label (string) or formatter function.
|
|
432 |
#' @param na_str (`string`)\cr string that should be displayed in place of missing values.
|
|
433 |
#' @param align (`string`)\cr alignment values should be rendered with.
|
|
434 |
#'
|
|
435 |
#' @return An object of class `fmt_config` which contains the following elements:
|
|
436 |
#' * `format`
|
|
437 |
#' * `na_str`
|
|
438 |
#' * `align`
|
|
439 |
#'
|
|
440 |
#' @examples
|
|
441 |
#' fmt_config(format = "xx.xx", na_str = "-", align = "left")
|
|
442 |
#' fmt_config(format = "xx.xx - xx.xx", align = "right")
|
|
443 |
#'
|
|
444 |
#' @export
|
|
445 |
fmt_config <- function(format = NULL, na_str = "NA", align = "center") { |
|
446 | 2x |
new("fmt_config", format = format, format_na_str = na_str, align = align) |
447 |
}
|
1 |
#' Return an object with a label attribute
|
|
2 |
#'
|
|
3 |
#' @param x (`ANY`)\cr an object.
|
|
4 |
#' @param label (`string`)\cr label attribute to attach to `x`.
|
|
5 |
#'
|
|
6 |
#' @return `x` labeled by `label`. Note that the exact mechanism of labeling should be considered
|
|
7 |
#' an internal implementation detail, but the label can always be retrieved via `obj_label`.
|
|
8 |
#'
|
|
9 |
#' @examples
|
|
10 |
#' x <- with_label(c(1, 2, 3), label = "Test")
|
|
11 |
#' obj_label(x)
|
|
12 |
#'
|
|
13 |
#' @export
|
|
14 |
with_label <- function(x, label) { |
|
15 | 1x |
obj_label(x) <- label |
16 | 1x |
x
|
17 |
}
|
|
18 | ||
19 |
#' Get label attributes of variables in a `data.frame`
|
|
20 |
#'
|
|
21 |
#' Variable labels can be stored as a `label` attribute for each variable.
|
|
22 |
#' This functions returns a named character vector with the variable labels
|
|
23 |
#' (or empty strings if not specified).
|
|
24 |
#'
|
|
25 |
#' @param x (`data.frame`)\cr a data frame object.
|
|
26 |
#' @param fill (`flag`)\cr whether variable names should be returned for variables for
|
|
27 |
#' which the `label` attribute does not exist. If `FALSE`, these variables are filled with
|
|
28 |
#' `NA`s instead.
|
|
29 |
#'
|
|
30 |
#' @return a named character vector of variable labels from `x`, with names corresponding
|
|
31 |
#' to variable names.
|
|
32 |
#'
|
|
33 |
#' @examples
|
|
34 |
#' x <- iris
|
|
35 |
#' var_labels(x)
|
|
36 |
#' var_labels(x) <- paste("label for", names(iris))
|
|
37 |
#' var_labels(x)
|
|
38 |
#'
|
|
39 |
#' @export
|
|
40 |
var_labels <- function(x, fill = FALSE) { |
|
41 | 5x |
stopifnot(is.data.frame(x)) |
42 | 5x |
if (NCOL(x) == 0) { |
43 | 1x |
return(character()) |
44 |
}
|
|
45 | ||
46 | 4x |
y <- Map(function(col, colname) { |
47 | 38x |
label <- attr(col, "label") |
48 | ||
49 | 38x |
if (is.null(label)) { |
50 | 11x |
if (fill) { |
51 | ! |
colname
|
52 |
} else { |
|
53 | 4x |
NA_character_
|
54 |
}
|
|
55 |
} else { |
|
56 | 27x |
if (!is.character(label) && !(length(label) == 1)) { |
57 | ! |
stop("label for variable ", colname, "is not a character string") |
58 |
}
|
|
59 | 27x |
as.vector(label) |
60 |
}
|
|
61 | 4x |
}, x, colnames(x)) |
62 | ||
63 | 4x |
labels <- unlist(y, recursive = FALSE, use.names = TRUE) |
64 | ||
65 | 4x |
if (!is.character(labels)) { |
66 | ! |
stop("label extraction failed") |
67 |
}
|
|
68 | ||
69 | 4x |
labels
|
70 |
}
|
|
71 | ||
72 |
#' Set label attributes of all variables in a `data.frame`
|
|
73 |
#'
|
|
74 |
#' Variable labels can be stored as the `label` attribute for each variable.
|
|
75 |
#' This functions sets all non-missing (non-`NA`) variable labels in a `data.frame`.
|
|
76 |
#'
|
|
77 |
#' @inheritParams var_labels
|
|
78 |
#' @param value (`character`)\cr a vector of new variable labels. If any values are `NA`,
|
|
79 |
#' the label for that variable is removed.
|
|
80 |
#'
|
|
81 |
#' @return `x` with modified variable labels.
|
|
82 |
#'
|
|
83 |
#' @examples
|
|
84 |
#' x <- iris
|
|
85 |
#' var_labels(x)
|
|
86 |
#' var_labels(x) <- paste("label for", names(iris))
|
|
87 |
#' var_labels(x)
|
|
88 |
#'
|
|
89 |
#' if (interactive()) {
|
|
90 |
#' View(x) # in RStudio data viewer labels are displayed
|
|
91 |
#' }
|
|
92 |
#'
|
|
93 |
#' @export
|
|
94 |
`var_labels<-` <- function(x, value) { |
|
95 | 3x |
stopifnot( |
96 | 3x |
is.data.frame(x), |
97 | 3x |
is.character(value), |
98 | 3x |
ncol(x) == length(value) |
99 |
)
|
|
100 | ||
101 | 3x |
theseq <- if (!is.null(names(value))) names(value) else seq_along(x) |
102 |
# across columns of x
|
|
103 | 3x |
for (j in theseq) { |
104 | 21x |
attr(x[[j]], "label") <- if (!is.na(value[j])) { |
105 | 21x |
unname(value[j]) |
106 |
} else { |
|
107 | ! |
NULL
|
108 |
}
|
|
109 |
}
|
|
110 | ||
111 | 3x |
x
|
112 |
}
|
|
113 | ||
114 |
#' Copy and change variable labels of a `data.frame`
|
|
115 |
#'
|
|
116 |
#' Relabel a subset of the variables.
|
|
117 |
#'
|
|
118 |
#' @inheritParams var_labels<-
|
|
119 |
#' @param ... name-value pairs, where each name corresponds to a variable name in
|
|
120 |
#' `x` and the value to the new variable label.
|
|
121 |
#'
|
|
122 |
#' @return A copy of `x` with labels modified according to `...`
|
|
123 |
#'
|
|
124 |
#' @examples
|
|
125 |
#' x <- var_relabel(iris, Sepal.Length = "Sepal Length of iris flower")
|
|
126 |
#' var_labels(x)
|
|
127 |
#'
|
|
128 |
#' @export
|
|
129 |
var_relabel <- function(x, ...) { |
|
130 |
# todo: make this function more readable / code easier
|
|
131 | 1x |
stopifnot(is.data.frame(x)) |
132 | 1x |
if (missing(...)) { |
133 | ! |
return(x) |
134 |
}
|
|
135 | 1x |
dots <- list(...) |
136 | 1x |
varnames <- names(dots) |
137 | 1x |
stopifnot(!is.null(varnames)) |
138 | ||
139 | 1x |
map_varnames <- match(varnames, colnames(x)) |
140 | ||
141 | 1x |
if (any(is.na(map_varnames))) { |
142 | ! |
stop("variables: ", paste(varnames[is.na(map_varnames)], collapse = ", "), " not found") |
143 |
}
|
|
144 | ||
145 | 1x |
if (any(vapply(dots, Negate(is.character), logical(1)))) { |
146 | ! |
stop("all variable labels must be of type character") |
147 |
}
|
|
148 | ||
149 | 1x |
for (i in seq_along(map_varnames)) { |
150 | 1x |
attr(x[[map_varnames[[i]]]], "label") <- dots[[i]] |
151 |
}
|
|
152 | ||
153 | 1x |
x
|
154 |
}
|
|
155 | ||
156 |
#' Remove variable labels of a `data.frame`
|
|
157 |
#'
|
|
158 |
#' Remove `label` attribute from all variables in a data frame.
|
|
159 |
#'
|
|
160 |
#' @param x (`data.frame`)\cr a `data.frame` object.
|
|
161 |
#'
|
|
162 |
#' @return `x` with its variable labels stripped.
|
|
163 |
#'
|
|
164 |
#' @examples
|
|
165 |
#' x <- var_labels_remove(iris)
|
|
166 |
#'
|
|
167 |
#' @export
|
|
168 |
var_labels_remove <- function(x) { |
|
169 | 1x |
stopifnot(is.data.frame(x)) |
170 | ||
171 | 1x |
for (i in seq_len(ncol(x))) { |
172 | 11x |
attr(x[[i]], "label") <- NULL |
173 |
}
|
|
174 | ||
175 | 1x |
x
|
176 |
}
|
1 |
#' @import grid
|
|
2 |
#' @import grDevices
|
|
3 |
NULL
|
|
4 |
## https://www.ietf.org/rfc/rfc0678.txt
|
|
5 | ||
6 |
## This assumes fixed font size, monospaced font
|
|
7 | ||
8 |
std_cpi <- 10L |
|
9 |
std_lpi <- 6L |
|
10 | ||
11 |
std_full_pg_wd_in <- 8.5 |
|
12 | ||
13 |
std_full_pg_ht_in <- 11 |
|
14 | ||
15 |
std_log_pg_wd_chars <- 72 |
|
16 | ||
17 |
std_log_pg_ht_lines <- 60 |
|
18 | ||
19 |
std_marg_ht <- round((std_full_pg_ht_in - std_log_pg_ht_lines / std_lpi) / 2, 2) |
|
20 |
std_marg_wd <- round((std_full_pg_wd_in - std_log_pg_wd_chars / std_cpi) / 2, 2) |
|
21 | ||
22 |
std_margins <- list( |
|
23 |
top = std_marg_ht, |
|
24 |
bottom = std_marg_ht, |
|
25 |
left = std_marg_wd, |
|
26 |
right = std_marg_wd |
|
27 |
)
|
|
28 | ||
29 |
## does not appear to be used anywhere
|
|
30 |
## to_inches_num <- function(x) {
|
|
31 |
## if (is(x, "unit")) {
|
|
32 |
## x <- unclass(convertUnit(x, "inches"))
|
|
33 |
## }
|
|
34 |
## x
|
|
35 |
## }
|
|
36 | ||
37 |
## Physical size, does not take margins into account
|
|
38 |
pg_dim_names <- list( |
|
39 |
letter = c(8.5, 11), |
|
40 |
a4 = c(8.27, 11.69), |
|
41 |
legal = c(8.5, 14) |
|
42 |
)
|
|
43 | ||
44 |
#' Supported named page types
|
|
45 |
#'
|
|
46 |
#' List supported named page types.
|
|
47 |
#'
|
|
48 |
#' @return
|
|
49 |
#' * `page_types` returns a character vector of supported page types
|
|
50 |
#' * `page_dim` returns the dimensions (width, then height) of the selected page type.
|
|
51 |
#'
|
|
52 |
#' @export
|
|
53 |
#' @examples
|
|
54 |
#' page_types()
|
|
55 |
#' page_dim("a4")
|
|
56 |
page_types <- function() { |
|
57 | 76x |
names(pg_dim_names) |
58 |
}
|
|
59 | ||
60 |
#' @param page_type (`string`)\cr the name of a page size specification. Call
|
|
61 |
#' [page_types()] for supported values.
|
|
62 |
#'
|
|
63 |
#' @export
|
|
64 |
#' @rdname page_types
|
|
65 |
page_dim <- function(page_type) { |
|
66 | 45x |
if (is.null(page_type)) { |
67 | 28x |
return(NULL) |
68 |
}
|
|
69 | 17x |
if (!page_type %in% page_types()) { |
70 | 1x |
stop("Unrecognized page-size specification: ", page_type) |
71 |
}
|
|
72 | 16x |
pg_dim_names[[page_type]] |
73 |
}
|
|
74 | ||
75 |
#' Calculate lines per inch and characters per inch for font
|
|
76 |
#'
|
|
77 |
#' @inheritParams page_lcpp
|
|
78 |
#'
|
|
79 |
#' @details
|
|
80 |
#' This function opens a PDF graphics device, writes to a temporary file, then
|
|
81 |
#' utilizes [grid::convertWidth()] and [grid::convertHeight()] to calculate lines
|
|
82 |
#' per inch and characters per inch for the specified font family, size, and
|
|
83 |
#' line height.
|
|
84 |
#'
|
|
85 |
#' An error is thrown if the font is not monospaced (determined by comparing
|
|
86 |
#' the effective widths of the `M` and `.` glyphs).
|
|
87 |
#'
|
|
88 |
#' @return A named list with `cpi` and `lpi`, the characters and lines per
|
|
89 |
#' inch, respectively.
|
|
90 |
#'
|
|
91 |
#' @examples
|
|
92 |
#' font_lcpi <- getFromNamespace("font_lcpi", "formatters")
|
|
93 |
#'
|
|
94 |
#' font_lcpi()
|
|
95 |
#' font_lcpi(font_size = 8)
|
|
96 |
#' font_lcpi(font_size = 8, lineheight = 1.1)
|
|
97 |
#'
|
|
98 |
#' @keywords internal
|
|
99 |
font_lcpi <- function(font_family = "Courier", font_size = 8, lineheight = 1) { |
|
100 | 59x |
tmppdf <- tempfile(fileext = ".pdf") |
101 | 59x |
pdf(tmppdf) |
102 | 59x |
on.exit(dev.off()) |
103 | 59x |
grid.newpage() |
104 | 59x |
gp <- gpar(fontfamily = font_family, fontsize = font_size, lineheight = lineheight) |
105 | 59x |
pushViewport(plotViewport(gp = gp)) |
106 | 59x |
if (convertWidth(unit(1, "strwidth", "."), "inches", valueOnly = TRUE) != |
107 | 59x |
convertWidth(unit(1, "strwidth", "M"), "inches", valueOnly = TRUE)) { # nolint |
108 | 1x |
stop( |
109 | 1x |
"The font family you selected - ",
|
110 | 1x |
font_family,
|
111 | 1x |
" - does not appear to be monospaced. This is not supported."
|
112 |
)
|
|
113 |
}
|
|
114 | 58x |
list( |
115 | 58x |
cpi = 1 / convertWidth(unit(1, "strwidth", "h"), "inches", valueOnly = TRUE), |
116 | 58x |
lpi = convertHeight(unit(1, "inches"), "lines", valueOnly = TRUE) |
117 |
)
|
|
118 |
}
|
|
119 | ||
120 |
marg_order <- c("bottom", "left", "top", "right") |
|
121 | ||
122 |
#' Determine lines per page (LPP) and characters per page (CPP) based on font and page type
|
|
123 |
#'
|
|
124 |
#' @param page_type (`string`)\cr name of a page type. See [`page_types`]. Ignored
|
|
125 |
#' when `pg_width` and `pg_height` are set directly.
|
|
126 |
#' @param landscape (`flag`)\cr whether the dimensions of `page_type` should be
|
|
127 |
#' inverted for landscape orientation. Defaults to `FALSE`, ignored when `pg_width` and
|
|
128 |
#' `pg_height` are set directly.
|
|
129 |
#' @param font_family (`string`)\cr name of a font family. An error will be thrown
|
|
130 |
#' if the family named is not monospaced. Defaults to `"Courier"`.
|
|
131 |
#' @param font_size (`numeric(1)`)\cr font size. Defaults to `12`.
|
|
132 |
#' @param lineheight (`numeric(1)`)\cr line height. Defaults to `1`.
|
|
133 |
#' @param margins (`numeric(4)`)\cr named numeric vector containing `"bottom"`, `"left"`,
|
|
134 |
#' `"top"`, and `"right"` margins in inches. Defaults to `.5` inches for both vertical
|
|
135 |
#' margins and `.75` for both horizontal margins.
|
|
136 |
#' @param pg_width (`numeric(1)`)\cr page width in inches.
|
|
137 |
#' @param pg_height (`numeric(1)`)\cr page height in inches.
|
|
138 |
#'
|
|
139 |
#' @return A named list containing LPP (lines per page) and CPP (characters per page)
|
|
140 |
#' elements suitable for use by the pagination machinery.
|
|
141 |
#'
|
|
142 |
#' @examples
|
|
143 |
#' page_lcpp()
|
|
144 |
#' page_lcpp(font_size = 10)
|
|
145 |
#' page_lcpp("a4", font_size = 10)
|
|
146 |
#'
|
|
147 |
#' page_lcpp(margins = c(top = 1, bottom = 1, left = 1, right = 1))
|
|
148 |
#' page_lcpp(pg_width = 10, pg_height = 15)
|
|
149 |
#'
|
|
150 |
#' @export
|
|
151 |
page_lcpp <- function(page_type = page_types(), |
|
152 |
landscape = FALSE, |
|
153 |
font_family = "Courier", |
|
154 |
font_size = 8, |
|
155 |
lineheight = 1, |
|
156 |
margins = c(top = .5, bottom = .5, left = .75, right = .75), |
|
157 |
pg_width = NULL, |
|
158 |
pg_height = NULL) { |
|
159 | 55x |
if (is.null(page_type)) { |
160 | 19x |
page_type <- page_types()[1] |
161 |
} else { |
|
162 | 36x |
page_type <- match.arg(page_type) |
163 |
}
|
|
164 | ||
165 | 55x |
if (is.null(names(margins))) { |
166 | 12x |
names(margins) <- marg_order |
167 |
} else { |
|
168 | 43x |
margins <- margins[marg_order] |
169 |
}
|
|
170 | 55x |
if (any(is.na(margins))) { |
171 | ! |
stop("margins argument must have names 'bottom', 'left', 'top' and 'right'.") |
172 |
}
|
|
173 | 55x |
lcpi <- font_lcpi( |
174 | 55x |
font_family = font_family, |
175 | 55x |
font_size = font_size, |
176 | 55x |
lineheight = lineheight |
177 |
)
|
|
178 | ||
179 | 54x |
wdpos <- ifelse(landscape, 2, 1) |
180 | 54x |
pg_width <- pg_width %||% pg_dim_names[[page_type]][wdpos] |
181 | 54x |
pg_height <- pg_height %||% pg_dim_names[[page_type]][-wdpos] |
182 | ||
183 | 54x |
pg_width <- pg_width - sum(margins[c("left", "right")]) |
184 | 54x |
pg_height <- pg_height - sum(margins[c("top", "bottom")]) |
185 | ||
186 | 54x |
list( |
187 | 54x |
cpp = floor(lcpi[["cpi"]] * pg_width), |
188 | 54x |
lpp = floor(lcpi[["lpi"]] * pg_height) |
189 |
)
|
|
190 |
}
|
|
191 | ||
192 |
## pg_types <- list(
|
|
193 |
## "fsrp" = c(cpp = 110, lpp = 66),
|
|
194 |
## "fsrp8" = c(cpp = 110, lpp = 66),
|
|
195 |
## "fsrp7" = c(cpp = 110, lpp = 75),
|
|
196 |
## "fsrl" = c(cpp = 149, lpp = 51),
|
|
197 |
## "fsrl8" = c(cpp = 149, lpp = 51),
|
|
198 |
## "fsrl7" = c(cpp = 150, lpp = 59),
|
|
199 |
## "erp" = c(cpp = 96, lpp = 66),
|
|
200 |
## "erp8" = c(cpp = 96, lpp = 66),
|
|
201 |
## "erl" = c(cpp = 149, lpp = 45),
|
|
202 |
## "erl8" = c(cpp = 149, lpp = 45),
|
|
203 |
## "sasp" = c(cpp = 93, lpp = 73),
|
|
204 |
## "sasp8" = c(cpp = 93, lpp = 73),
|
|
205 |
## "sasl" = c(cpp = 134, lpp = 52),
|
|
206 |
## "sasl8" = c(cpp = 134, lpp = 52),
|
|
207 |
## "sasp7" = c(cpp = 107, lpp = 92),
|
|
208 |
## "sasl7" = c(cpp = 154, lpp = 64),
|
|
209 |
## "sasp6" = c(cpp = 125, lpp = 108),
|
|
210 |
## "sasl6" = c(cpp = 180, lpp = 75),
|
|
211 |
## "sasp10" = c(cpp = 78, lpp = 64),
|
|
212 |
## "sasl10" = c(cpp = 108, lpp = 45),
|
|
213 |
## "sasp9" = c(cpp = 87, lpp = 71),
|
|
214 |
## "sasl9" = c(cpp = 120, lpp = 51),
|
|
215 |
## "rapidp10" = c(cpp = 78, lpp = 64),
|
|
216 |
## "rapidl10" = c(cpp = 108, lpp = 45),
|
|
217 |
## "rapidp9" = c(cpp = 87, lpp = 71),
|
|
218 |
## "rapidl9" = c(cpp = 120, lpp = 51),
|
|
219 |
## "rapidp" = c(cpp = 93, lpp = 73),
|
|
220 |
## "rapidp8" = c(cpp = 93, lpp = 73),
|
|
221 |
## "rapidl" = c(cpp = 134, lpp = 52),
|
|
222 |
## "rapidl8" = c(cpp = 134, lpp = 52),
|
|
223 |
## "rapidp7" = c(cpp = 107, lpp = 92),
|
|
224 |
## "rapidl7" = c(cpp = 154, lpp = 64),
|
|
225 |
## "rapidp6" = c(cpp = 125, lpp = 108),
|
|
226 |
## "rapidl6" = c(cpp = 180, lpp = 75),
|
|
227 |
## "shibal" = c(cpp = 170, lpp = 48),
|
|
228 |
## "shibal10" = c(cpp = 137, lpp = 39),
|
|
229 |
## "shibal8" = c(cpp = 170, lpp = 48),
|
|
230 |
## "shibal7" = c(cpp = 194, lpp = 56),
|
|
231 |
## "shibal6" = c(cpp = 225, lpp = 65),
|
|
232 |
## "shibap" = c(cpp = 112, lpp = 78),
|
|
233 |
## "shibap10" = c(cpp = 89, lpp = 64),
|
|
234 |
## "shibap8" = c(cpp = 112, lpp = 78),
|
|
235 |
## "shibap7" = c(cpp = 127, lpp = 92),
|
|
236 |
## "shibap6" = c(cpp = 148, lpp = 108))
|
|
237 | ||
238 |
## ~courier_size, ~cpi, ~lpi,
|
|
239 |
## 6, floor(129 / pg_dim_names[["letter"]][1]), floor(85 / pg_dim_names[["letter"]][2]),
|
|
240 |
## 7, floor(110 / pg_dim_names[["letter"]][1]), floor(76 / pg_dim_names[["letter"]][2]),
|
|
241 |
## 8, floor(95 / pg_dim_names[["letter"]][1]), floor(68 / pg_dim_names[["letter"]][2]),
|
|
242 |
## 9, floor(84 / pg_dim_names[["letter"]][1]), floor(61 / pg_dim_names[["letter"]][2]),
|
|
243 |
## 10, floor(75 / pg_dim_names[["letter"]][1]), floor(56 / pg_dim_names[["letter"]][2])
|
|
244 |
## )
|
|
245 | ||
246 |
## courier_lcpi <- function(size) {
|
|
247 |
## grid.newpage()
|
|
248 |
## gp <- gpar(fontfamily="Courier New", fontsize = size, lineheight = 1)
|
|
249 |
## pushViewport(plotViewport( gp = gp))
|
|
250 |
## list(cpi = round(1/convertWidth(unit(1, "strwidth", "h"), "inches", valueOnly = TRUE), 0),
|
|
251 |
## lpi = round(convertHeight(unit(1, "inches"), "lines", valueOnly = TRUE), 0))
|
|
252 |
## }
|
1 |
## credit: rlang, Henry and Wickham.
|
|
2 |
## this one tiny utility function is NOT worth a dependency.
|
|
3 |
## modified it so any length 0 x grabs y
|
|
4 | ||
5 |
#' `%||%` (if length-0) alternative operator
|
|
6 |
#'
|
|
7 |
#' @param a (`ANY`)\cr element to select *only* if it is not of length 0.
|
|
8 |
#' @param b (`ANY`)\cr element to select if `a` has length 0.
|
|
9 |
#'
|
|
10 |
#' @return `a` if it is not of length 0, otherwise `b`.
|
|
11 |
#'
|
|
12 |
#' @examples
|
|
13 |
#' 6 %||% 10
|
|
14 |
#'
|
|
15 |
#' character() %||% "hi"
|
|
16 |
#'
|
|
17 |
#' NULL %||% "hi"
|
|
18 |
#'
|
|
19 |
#' @export
|
|
20 |
#' @name ifnotlen0
|
|
21 |
`%||%` <- function(a, b) { |
|
22 | 528x |
if (length(a) == 0) { |
23 | 78x |
b
|
24 |
} else { |
|
25 | 450x |
a
|
26 |
}
|
|
27 |
}
|
1 |
#' Default horizontal separator
|
|
2 |
#'
|
|
3 |
#' The default horizontal separator character which can be displayed in the current
|
|
4 |
#' charset for use in rendering table-like objects.
|
|
5 |
#'
|
|
6 |
#' @param hsep_char (`string`)\cr character that will be set in the R environment
|
|
7 |
#' options as the default horizontal separator. Must be a single character. Use
|
|
8 |
#' `getOption("formatters_default_hsep")` to get its current value (`NULL` if not set).
|
|
9 |
#'
|
|
10 |
#' @return unicode 2014 (long dash for generating solid horizontal line) if in a
|
|
11 |
#' locale that uses a UTF character set, otherwise an ASCII hyphen with a
|
|
12 |
#' once-per-session warning.
|
|
13 |
#'
|
|
14 |
#' @examples
|
|
15 |
#' default_hsep()
|
|
16 |
#' set_default_hsep("o")
|
|
17 |
#' default_hsep()
|
|
18 |
#'
|
|
19 |
#' @name default_horizontal_sep
|
|
20 |
#' @export
|
|
21 |
default_hsep <- function() { |
|
22 | 52x |
system_default_hsep <- getOption("formatters_default_hsep") |
23 | ||
24 | 52x |
if (is.null(system_default_hsep)) { |
25 | 51x |
if (any(grepl("^UTF", utils::localeToCharset()))) { |
26 | 51x |
hsep <- "\u2014" |
27 |
} else { |
|
28 | ! |
if (interactive()) { |
29 | ! |
warning( |
30 | ! |
"Detected non-UTF charset. Falling back to '-' ",
|
31 | ! |
"as default header/body separator. This warning ",
|
32 | ! |
"will only be shown once per R session."
|
33 | ! |
) # nocov |
34 |
} # nocov |
|
35 |
hsep <- "-" # nocov |
|
36 |
}
|
|
37 |
} else { |
|
38 | 1x |
hsep <- system_default_hsep |
39 |
}
|
|
40 | 52x |
hsep
|
41 |
}
|
|
42 | ||
43 |
#' @name default_horizontal_sep
|
|
44 |
#' @export
|
|
45 |
set_default_hsep <- function(hsep_char) { |
|
46 | 3x |
checkmate::assert_string(hsep_char, n.chars = 1, null.ok = TRUE) |
47 | 2x |
options("formatters_default_hsep" = hsep_char) |
48 |
}
|
|
49 | ||
50 |
#' Default page number format
|
|
51 |
#'
|
|
52 |
#' If set, the default page number string will appear on the bottom right of
|
|
53 |
#' every page of a paginated table. The current `cpp` is used to position the string.
|
|
54 |
#'
|
|
55 |
#' @param page_number (`string`)\cr single string value to set the page number format.
|
|
56 |
#' It should be formatted similarly to the following format: `"page {i}/{n}"`.
|
|
57 |
#' `{i}` will be replaced with the current page number, and `{n}` will be replaced with the
|
|
58 |
#' total page number. Current `cpp` is used to position the string in the bottom right corner.
|
|
59 |
#'
|
|
60 |
#' @return The page number format string (`NULL` if not set).
|
|
61 |
#'
|
|
62 |
#' @examples
|
|
63 |
#' default_page_number()
|
|
64 |
#' set_default_page_number("page {i} of {n}")
|
|
65 |
#' default_page_number()
|
|
66 |
#'
|
|
67 |
#' @name default_page_number
|
|
68 |
#' @export
|
|
69 |
default_page_number <- function() { |
|
70 | 35x |
getOption("formatter_default_page_number", default = NULL) |
71 |
}
|
|
72 | ||
73 |
#' @name default_page_number
|
|
74 |
#' @export
|
|
75 |
set_default_page_number <- function(page_number) { |
|
76 | 6x |
checkmate::assert_string(page_number, null.ok = TRUE) |
77 | 6x |
options("formatter_default_page_number" = page_number) |
78 |
}
|