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)", ">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 |
#' @title List with 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 can not be added dynamically. Format functions |
|
31 |
#' must be used for special cases. |
|
32 |
#' |
|
33 |
#' @return |
|
34 |
#' * `list_valid_format_labels()`: 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 | 54x |
structure( |
44 | 54x |
list( |
45 | 54x |
"1d" = formats_1d, |
46 | 54x |
"2d" = formats_2d, |
47 | 54x |
"3d" = formats_3d |
48 |
), |
|
49 | 54x |
info = "xx does not modify the element, and xx. rounds a number to 0 digits" |
50 |
) |
|
51 |
} |
|
52 |
#' @return |
|
53 |
#' * `list_valid_aligns()`: a character vector of valid vertical alignments |
|
54 |
#' |
|
55 |
#' @examples |
|
56 |
#' list_valid_aligns() |
|
57 |
#' |
|
58 |
#' @name list_formats |
|
59 |
#' @export |
|
60 |
list_valid_aligns <- function() { |
|
61 | 5916x |
c("left", "right", "center", "decimal", "dec_right", "dec_left") |
62 |
} |
|
63 | ||
64 |
#' @title Check if a format or alignment is supported |
|
65 |
#' |
|
66 |
#' @description Utility functions for checking formats and alignments. |
|
67 |
#' |
|
68 |
#' @param x either format string or an object returned by \code{sprintf_format} |
|
69 |
#' @param stop_otherwise logical, if \code{x} is not a format should an error be |
|
70 |
#' thrown |
|
71 |
#' |
|
72 |
#' @note No check if the function is actually a `formatter` is performed. |
|
73 |
#' |
|
74 |
#' @return |
|
75 |
#' * `is_valid_format`: \code{TRUE} if \code{x} is \code{NULL}, a supported |
|
76 |
#' format string, or a function; \code{FALSE} otherwise. |
|
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 | 51x |
is_valid <- is.null(x) || (length(x) == 1 && (is.function(x) || x %in% unlist(list_valid_format_labels()))) |
86 | ||
87 | 51x |
if (stop_otherwise && !is_valid) { |
88 | ! |
stop("format needs to be a format label, sprintf_format object, a function, or NULL") |
89 |
} |
|
90 | ||
91 | 51x |
is_valid |
92 |
} |
|
93 |
#' @param algn vector of characters that indicates the requested cell alignments. |
|
94 |
#' |
|
95 |
#' @return |
|
96 |
#' * `check_aligns`: `TRUE` if it passes the check. |
|
97 |
#' |
|
98 |
#' @examples |
|
99 |
#' check_aligns(c("decimal", "dec_right")) |
|
100 |
#' |
|
101 |
#' @name check_formats |
|
102 |
#' @export |
|
103 |
check_aligns <- function(algn) { |
|
104 | ! |
if (anyNA(algn)) { |
105 | ! |
stop("Got missing-value for text alignment.") |
106 |
} |
|
107 | ! |
invalid <- setdiff(algn, list_valid_aligns()) |
108 | ! |
if (length(invalid) > 0) { |
109 | ! |
stop("Unsupported text-alignment(s): ", paste(invalid, collapse = ", ")) |
110 |
} |
|
111 | ! |
invisible(TRUE) |
112 |
} |
|
113 | ||
114 |
#' Specify text format via a `sprintf` format string |
|
115 |
#' |
|
116 |
#' |
|
117 |
#' @param format character(1). A format string passed to `sprintf`. |
|
118 |
#' |
|
119 |
#' @export |
|
120 |
#' @return A formatting function which wraps and will apply the specified \code{printf} style format |
|
121 |
#' string \code{format}. |
|
122 |
#' @seealso \code{\link[base]{sprintf}} |
|
123 |
#' |
|
124 |
#' @examples |
|
125 |
#' |
|
126 |
#' fmtfun <- sprintf_format("(N=%i") |
|
127 |
#' format_value(100, format = fmtfun) |
|
128 |
#' |
|
129 |
#' fmtfun2 <- sprintf_format("%.4f - %.2f") |
|
130 |
#' format_value(list(12.23456, 2.724)) |
|
131 |
sprintf_format <- function(format) { |
|
132 | 1x |
function(x, ...) { |
133 | 1x |
do.call(sprintf, c(list(fmt = format), x)) |
134 |
} |
|
135 |
} |
|
136 | ||
137 | ||
138 |
#' Round and prepare a value for display |
|
139 |
#' |
|
140 |
#' This function is used within \code{\link{format_value}} to prepare numeric values within |
|
141 |
#' cells for formatting and display. |
|
142 |
#' |
|
143 |
#' @aliases rounding |
|
144 |
#' @param x numeric(1). Value to format |
|
145 |
#' @param digits numeric(1). Number of digits to round to, or \code{NA} to convert to a |
|
146 |
#' character value with no rounding. |
|
147 |
#' @param na_str character(1). The value to return if \code{x} is \code{NA}. |
|
148 |
#' |
|
149 |
#' @details |
|
150 |
#' This function combines the rounding behavior of R's standards-complaint |
|
151 |
#' \code{\link{round}} function (see the Details section of that documentation) |
|
152 |
#' with the strict decimal display of \code{\link{sprintf}}. The exact behavior |
|
153 |
#' is as follows: |
|
154 |
#' |
|
155 |
#' \enumerate{ |
|
156 |
#' \item{If \code{x} is NA, the value of \code{na_str} is returned} |
|
157 |
#' \item{If \code{x} is non-NA but \code{digits} is NA, \code{x} is converted to a character |
|
158 |
#' and returned} |
|
159 |
#' \item{If \code{x} and \code{digits} are both non-NA, \code{round} is called first, |
|
160 |
#' and then \code{sprintf} is used to convert the rounded value to a character with the |
|
161 |
#' appropriate number of trailing zeros enforced.} |
|
162 |
#' } |
|
163 |
#' |
|
164 |
#' @return A character value representing the value after rounding, containing |
|
165 |
#' containing any trailling zeros required to display \emph{exactly} \code{digits} |
|
166 |
#' elements. |
|
167 |
#' @note |
|
168 |
#' This differs from the base R \code{\link{round}} function in that \code{NA} |
|
169 |
#' digits indicate x should be passed converted to character and returned unchanged |
|
170 |
#' whereas \code{round(x, digits =NA)} returns \code{NA} for all values of \code{x}. |
|
171 |
#' |
|
172 |
#' This behavior will differ from \code{as.character(round(x, digits = digits))} |
|
173 |
#' in the case where there are not at least \code{digits} significant digits |
|
174 |
#' after the decimal that remain after rounding. It \emph{may} differ from |
|
175 |
#' \code{sprintf("\%.Nf", x)} for values ending in \code{5} after the decimal place |
|
176 |
#' on many popular operating systems due to \code{round}'s stricter adherence to the |
|
177 |
#' `IEC 60559` standard, particularly for R versions > 4.0.0 (see Warning in \code{\link[base:round]{round}} |
|
178 |
#' documentation). |
|
179 |
#' |
|
180 |
#' @export |
|
181 |
#' @seealso \code{link{format_value}} \code{\link[base:round]{round}} \code{\link[base:sprintf]{sprintf}} |
|
182 |
#' @examples |
|
183 |
#' |
|
184 |
#' round_fmt(0, digits = 3) |
|
185 |
#' round_fmt(.395, digits = 2) |
|
186 |
#' round_fmt(NA, digits = 1) |
|
187 |
#' round_fmt(NA, digits = 1, na_str = "-") |
|
188 |
#' round_fmt(2.765923, digits = NA) |
|
189 |
round_fmt <- function(x, digits, na_str = "NA") { |
|
190 | 193x |
if (!is.na(digits) && digits < 0) { |
191 | ! |
stop("round_fmt currentlyd does not support non-missing values of digits <0") |
192 |
} |
|
193 | 193x |
if (is.na(x)) { |
194 | 4x |
na_str |
195 | 189x |
} else if (is.na(digits)) { |
196 | 41x |
paste0(x) |
197 |
} else { |
|
198 | 148x |
sprfmt <- paste0("%.", digits, "f") |
199 | 148x |
sprintf(fmt = sprfmt, round(x, digits = digits)) |
200 |
} |
|
201 |
} |
|
202 | ||
203 | ||
204 | ||
205 |
val_pct_helper <- function(x, dig1, dig2, na_str, pct = TRUE) { |
|
206 | 32x |
if (pct) { |
207 | 18x |
x[2] <- x[2] * 100 |
208 |
} |
|
209 | 32x |
if (length(na_str) == 1) { |
210 | ! |
na_str <- rep(na_str, 2) |
211 |
} |
|
212 | 32x |
paste0( |
213 | 32x |
round_fmt(x[1], digits = dig1, na_str = na_str[1]), |
214 |
" (", |
|
215 | 32x |
round_fmt(x[2], digits = dig2, na_str = na_str[2]), |
216 | 32x |
if (pct) "%", ")" |
217 |
) |
|
218 |
} |
|
219 | ||
220 |
sep_2d_helper <- function(x, dig1, dig2, sep, na_str, wrap = NULL) { |
|
221 | 43x |
ret <- paste(mapply(round_fmt, x = x, digits = c(dig1, dig2), na_str = na_str), |
222 | 43x |
collapse = sep |
223 |
) |
|
224 | 43x |
if (!is.null(wrap)) { |
225 | 20x |
ret <- paste(c(wrap[1], ret, wrap[2]), collapse = "") |
226 |
} |
|
227 | 43x |
ret |
228 |
} |
|
229 | ||
230 |
## na_or_round <- function(x, digits, na_str) { |
|
231 |
## if(is.na(x)) |
|
232 |
## na_str |
|
233 |
## else |
|
234 |
## round(x, digits = digits) |
|
235 | ||
236 |
## } |
|
237 | ||
238 |
#' Converts a (possibly compound) value into a string using the \code{format} information |
|
239 |
#' |
|
240 |
#' @details A length-zero value for `na_str` will be interpreted as `"NA"`, as will any |
|
241 |
#' missing values within a non-length-zero `na_str` vector. |
|
242 |
#' |
|
243 |
#' @param x ANY. The value to be formatted |
|
244 |
#' @param format character(1) or function. The format label (string) or `formatter` function to apply to \code{x}. |
|
245 |
#' @param na_str character(1). String that should be displayed when the value of \code{x} is missing. |
|
246 |
#' Defaults to \code{"NA"}. |
|
247 |
#' @param output character(1). output type |
|
248 |
#' |
|
249 |
#' @return formatted text representing the cell \code{x}. |
|
250 |
#' @export |
|
251 |
#' |
|
252 |
#' @seealso [round_fmt()] |
|
253 |
#' @examples |
|
254 |
#' |
|
255 |
#' x <- format_value(pi, format = "xx.xx") |
|
256 |
#' x |
|
257 |
#' |
|
258 |
#' format_value(x, output = "ascii") |
|
259 |
#' |
|
260 |
format_value <- function(x, format = NULL, output = c("ascii", "html"), na_str = "NA") { |
|
261 |
## if(is(x, "CellValue")) |
|
262 |
## x = x[[1]] |
|
263 | ||
264 | 5073x |
if (length(x) == 0) { |
265 | 1x |
return("") |
266 |
} |
|
267 | ||
268 | 5072x |
output <- match.arg(output) |
269 | 5072x |
if (length(na_str) == 0) { |
270 | 1x |
na_str <- "NA" |
271 |
} |
|
272 | 5072x |
if (any(is.na(na_str))) { |
273 | 1x |
na_str[is.na(na_str)] <- "NA" |
274 |
} |
|
275 |
## format <- if (!missing(format)) format else obj_format(x) |
|
276 | ||
277 | ||
278 | 5072x |
txt <- if (all(is.na(x)) && length(na_str) == 1L) { |
279 | 21x |
na_str |
280 | 5072x |
} else if (is.null(format)) { |
281 | ! |
toString(x) |
282 | 5072x |
} else if (is.function(format)) { |
283 | 1x |
format(x, output = output) |
284 | 5072x |
} else if (is.character(format)) { |
285 | 5050x |
l <- if (format %in% formats_1d) { |
286 | 4972x |
1 |
287 | 5050x |
} else if (format %in% formats_2d) { |
288 | 69x |
2 |
289 | 5050x |
} else if (format %in% formats_3d) { |
290 | 8x |
3 |
291 |
} else { |
|
292 | 1x |
stop( |
293 | 1x |
"unknown format label: ", format, |
294 | 1x |
". use list_valid_format_labels() to get a list of all formats" |
295 |
) |
|
296 |
} |
|
297 | 5049x |
if (format != "xx" && length(x) != l) { |
298 | 2x |
stop( |
299 | 2x |
"cell <", paste(x), "> and format ", |
300 | 2x |
format, " are of different length" |
301 |
) |
|
302 |
} |
|
303 | 5047x |
if (length(na_str) < length(x)) { |
304 | 73x |
na_str <- rep(na_str, length.out = length(x)) |
305 |
} |
|
306 | 5047x |
switch(format, |
307 | 4934x |
"xx" = as.character(x), |
308 | 3x |
"xx." = round_fmt(x, digits = 0, na_str = na_str), |
309 | 6x |
"xx.x" = round_fmt(x, digits = 1, na_str = na_str), |
310 | 3x |
"xx.xx" = round_fmt(x, digits = 2, na_str = na_str), |
311 | 3x |
"xx.xxx" = round_fmt(x, digits = 3, na_str = na_str), |
312 | 3x |
"xx.xxxx" = round_fmt(x, digits = 4, na_str = na_str), |
313 | 2x |
"xx%" = paste0(round_fmt(x * 100, digits = NA, na_str = na_str), "%"), |
314 | 2x |
"xx.%" = paste0(round_fmt(x * 100, digits = 0, na_str = na_str), "%"), |
315 | 2x |
"xx.x%" = paste0(round_fmt(x * 100, digits = 1, na_str = na_str), "%"), |
316 | 2x |
"xx.xx%" = paste0(round_fmt(x * 100, digits = 2, na_str = na_str), "%"), |
317 | 2x |
"xx.xxx%" = paste0(round_fmt(x * 100, digits = 3, na_str = na_str), "%"), |
318 | 1x |
"(N=xx)" = paste0("(N=", round_fmt(x, digits = NA, na_str = na_str), ")"), |
319 | 3x |
">999.9" = ifelse(x > 999.9, ">999.9", round_fmt(x, digits = 1, na_str = na_str)), |
320 | 3x |
">999.99" = ifelse(x > 999.99, ">999.99", round_fmt(x, digits = 2, na_str = na_str)), |
321 | 3x |
"x.xxxx | (<0.0001)" = ifelse(x < 0.0001, "<0.0001", round_fmt(x, digits = 4, na_str = na_str)), |
322 | 2x |
"xx / xx" = sep_2d_helper(x, dig1 = NA, dig2 = NA, sep = " / ", na_str = na_str), |
323 | 2x |
"xx. / xx." = sep_2d_helper(x, dig1 = 0, dig2 = 0, sep = " / ", na_str = na_str), |
324 | 2x |
"xx.x / xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " / ", na_str = na_str), |
325 | 2x |
"xx.xx / xx.xx" = sep_2d_helper(x, dig1 = 2, dig2 = 2, sep = " / ", na_str = na_str), |
326 | 2x |
"xx.xxx / xx.xxx" = sep_2d_helper(x, dig1 = 3, dig2 = 3, sep = " / ", na_str = na_str), |
327 | 2x |
"N=xx (xx%)" = paste0("N=", val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str)), |
328 | 3x |
"xx (xx%)" = val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str), |
329 | 2x |
"xx (xx.%)" = val_pct_helper(x, dig1 = NA, dig2 = 0, na_str = na_str), |
330 | 2x |
"xx (xx.x%)" = val_pct_helper(x, dig1 = NA, dig2 = 1, na_str = na_str), |
331 | 2x |
"xx (xx.xx%)" = val_pct_helper(x, dig1 = NA, dig2 = 2, na_str = na_str), |
332 | 2x |
"xx. (xx.%)" = val_pct_helper(x, dig1 = 0, dig2 = 0, na_str = na_str), |
333 | 3x |
"xx.x (xx.x%)" = val_pct_helper(x, dig1 = 1, dig2 = 1, na_str = na_str), |
334 | 2x |
"xx.xx (xx.xx%)" = val_pct_helper(x, dig1 = 2, dig2 = 2, na_str = na_str), |
335 | 2x |
"(xx, xx)" = sep_2d_helper(x, |
336 | 2x |
dig1 = NA, dig2 = NA, sep = ", ", |
337 | 2x |
na_str = na_str, wrap = c("(", ")") |
338 |
), |
|
339 | 2x |
"(xx., xx.)" = sep_2d_helper(x, |
340 | 2x |
dig1 = 0, dig2 = 0, sep = ", ", |
341 | 2x |
na_str = na_str, wrap = c("(", ")") |
342 |
), |
|
343 | 2x |
"(xx.x, xx.x)" = sep_2d_helper(x, |
344 | 2x |
dig1 = 1, dig2 = 1, sep = ", ", |
345 | 2x |
na_str = na_str, wrap = c("(", ")") |
346 |
), |
|
347 | 2x |
"(xx.xx, xx.xx)" = sep_2d_helper(x, |
348 | 2x |
dig1 = 2, dig2 = 2, sep = ", ", |
349 | 2x |
na_str = na_str, wrap = c("(", ")") |
350 |
), |
|
351 | 2x |
"(xx.xxx, xx.xxx)" = sep_2d_helper(x, |
352 | 2x |
dig1 = 3, dig2 = 3, sep = ", ", |
353 | 2x |
na_str = na_str, wrap = c("(", ")") |
354 |
), |
|
355 | 2x |
"(xx.xxxx, xx.xxxx)" = sep_2d_helper(x, |
356 | 2x |
dig1 = 4, dig2 = 4, sep = ", ", |
357 | 2x |
na_str = na_str, wrap = c("(", ")") |
358 |
), |
|
359 | 2x |
"xx - xx" = sep_2d_helper(x, dig1 = NA, dig2 = NA, sep = " - ", na_str = na_str), |
360 | 5x |
"xx.x - xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " - ", na_str = na_str), |
361 | 2x |
"xx.xx - xx.xx" = sep_2d_helper(x, dig1 = 2, dig2 = 2, sep = " - ", na_str = na_str), |
362 | 2x |
"xx (xx)" = val_pct_helper(x, dig1 = NA, dig2 = NA, na_str = na_str, pct = FALSE), |
363 | 2x |
"xx. (xx.)" = val_pct_helper(x, dig1 = 0, dig2 = 0, na_str = na_str, pct = FALSE), |
364 | 2x |
"xx.x (xx.x)" = val_pct_helper(x, dig1 = 1, dig2 = 1, na_str = na_str, pct = FALSE), |
365 | 2x |
"xx.xx (xx.xx)" = val_pct_helper(x, dig1 = 2, dig2 = 2, na_str = na_str, pct = FALSE), |
366 | 2x |
"xx (xx.)" = val_pct_helper(x, dig1 = NA, dig2 = 0, na_str = na_str, pct = FALSE), |
367 | 2x |
"xx (xx.x)" = val_pct_helper(x, dig1 = NA, dig2 = 1, na_str = na_str, pct = FALSE), |
368 | 2x |
"xx (xx.xx)" = val_pct_helper(x, dig1 = NA, dig2 = 2, na_str = na_str, pct = FALSE), |
369 | 2x |
"xx.x, xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = ", ", na_str = na_str), |
370 | 2x |
"xx.x to xx.x" = sep_2d_helper(x, dig1 = 1, dig2 = 1, sep = " to ", na_str = na_str), |
371 | 2x |
"xx.xx (xx.xx - xx.xx)" = paste0( |
372 | 2x |
round_fmt(x[1], digits = 2, na_str = na_str[1]), " ", |
373 | 2x |
sep_2d_helper(x[2:3], |
374 | 2x |
dig1 = 2, dig2 = 2, |
375 | 2x |
sep = " - ", na_str = na_str[2:3], |
376 | 2x |
wrap = c("(", ")") |
377 |
) |
|
378 |
), |
|
379 | 2x |
"xx. (xx. - xx.)" = paste0( |
380 | 2x |
round_fmt(x[1], digits = 0, na_str = na_str[1]), " ", |
381 | 2x |
sep_2d_helper(x[2:3], |
382 | 2x |
dig1 = 0, dig2 = 0, |
383 | 2x |
sep = " - ", na_str = na_str[2:3], |
384 | 2x |
wrap = c("(", ")") |
385 |
) |
|
386 |
), |
|
387 | 2x |
"xx.x (xx.x - xx.x)" = paste0( |
388 | 2x |
round_fmt(x[1], digits = 1, na_str = na_str[1]), " ", |
389 | 2x |
sep_2d_helper(x[2:3], |
390 | 2x |
dig1 = 1, dig2 = 1, |
391 | 2x |
sep = " - ", na_str = na_str[2:3], |
392 | 2x |
wrap = c("(", ")") |
393 |
) |
|
394 |
), |
|
395 | 2x |
"xx.xxx (xx.xxx - xx.xxx)" = paste0( |
396 | 2x |
round_fmt(x[1], digits = 3, na_str = na_str[1]), " ", |
397 | 2x |
sep_2d_helper(x[2:3], |
398 | 2x |
dig1 = 3, dig2 = 3, |
399 | 2x |
sep = " - ", na_str = na_str[2:3], |
400 | 2x |
wrap = c("(", ")") |
401 |
) |
|
402 |
), |
|
403 | ! |
paste("format string", format, "not found") |
404 |
) |
|
405 |
} |
|
406 | 5069x |
txt[is.na(txt)] <- na_str |
407 | 5069x |
if (output == "ascii") { |
408 | 5068x |
txt |
409 | 1x |
} else if (output == "html") { |
410 |
## convert to tagList |
|
411 |
## convert \n to <br/> |
|
412 | ||
413 | 1x |
if (identical(txt, "")) { |
414 | ! |
txt |
415 |
} else { |
|
416 | 1x |
els <- unlist(strsplit(txt, "\n", fixed = TRUE)) |
417 | 1x |
Map(function(el, is.last) { |
418 | 1x |
tagList(el, if (!is.last) tags$br() else NULL) |
419 | 1x |
}, els, c(rep(FALSE, length(els) - 1), TRUE)) |
420 |
} |
|
421 |
} else { |
|
422 | ! |
txt |
423 |
} |
|
424 |
} |
|
425 | ||
426 |
setClassUnion("FormatSpec", c("NULL", "character", "function", "list")) |
|
427 |
setClassUnion("characterOrNULL", c("NULL", "character")) |
|
428 |
setClass("fmt_config", |
|
429 |
slots = c( |
|
430 |
format = "FormatSpec", |
|
431 |
format_na_str = "characterOrNULL", |
|
432 |
align = "characterOrNULL" |
|
433 |
) |
|
434 |
) |
|
435 | ||
436 |
#' Format Configuration |
|
437 |
#' |
|
438 |
#' @param format character(1) or function. A format label (string) or `formatter` function. |
|
439 |
#' @param na_str character(1). String that should be displayed in place of missing values. |
|
440 |
#' @param align character(1). Alignment values should be rendered with. |
|
441 |
#' |
|
442 |
#' @return An object of class `fmt_config` which contains the following elements: |
|
443 |
#' * `format` |
|
444 |
#' * `na_str` |
|
445 |
#' * `align` |
|
446 |
#' |
|
447 |
#' @examples |
|
448 |
#' fmt_config(format = "xx.xx", na_str = "-", align = "left") |
|
449 |
#' fmt_config(format = "xx.xx - xx.xx", align = "right") |
|
450 |
#' |
|
451 |
#' @export |
|
452 |
fmt_config <- function(format = NULL, na_str = "NA", align = "center") { |
|
453 | 2x |
new("fmt_config", format = format, format_na_str = na_str, align = align) |
454 |
} |
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 |
#' @name pagination_algo |
|
41 |
#' @rdname pagination_algo |
|
42 |
#' @title Pagination |
|
43 |
#' @section Pagination Algorithm: |
|
44 |
#' |
|
45 |
#' Pagination is performed independently in the vertical and horizontal |
|
46 |
#' directions based solely on a *pagination data.frame*, which includes the |
|
47 |
#' following information for each row/column: |
|
48 |
#' |
|
49 |
#' - number of lines/characters rendering the row will take **after |
|
50 |
#' word-wrapping** (`self_extent`) |
|
51 |
#' - the indices (`reprint_inds`) and number of lines (`par_extent`) |
|
52 |
#' of the rows which act as **context** for the row |
|
53 |
#' - the row's number of siblings and position within its siblings |
|
54 |
#' |
|
55 |
#' Given `lpp` (`cpp`) already adjusted for rendered elements which |
|
56 |
#' are not rows/columns and a dataframe of pagination information, |
|
57 |
#' pagination is performed via the following algorithm, and with a |
|
58 |
#' `start = 1`: |
|
59 |
#' |
|
60 |
#' Core Pagination Algorithm: |
|
61 |
#' 1. Initial guess for pagination point is `start + lpp` (`start + cpp`) |
|
62 |
#' |
|
63 |
#' 2. While the guess is not a valid pagination position, and `guess > |
|
64 |
#' start`, decrement guess and repeat |
|
65 |
#' - an error is thrown if all possible pagination positions between |
|
66 |
#' `start` and `start + lpp` (`start + cpp`) would ever be `< start` |
|
67 |
#' after decrementing |
|
68 |
#' 3. Retain pagination index |
|
69 |
#' 4. if pagination point was less than `NROW(tt)` (`ncol(tt)`), set |
|
70 |
#' `start` to `pos + 1`, and repeat steps (1) - (4). |
|
71 |
#' |
|
72 |
#' Validating pagination position: |
|
73 |
#' |
|
74 |
#' Given an (already adjusted) `lpp` or `cpp` value, a pagination is invalid if: |
|
75 |
#' |
|
76 |
#' - The rows/columns on the page would take more than (adjusted) `lpp` lines/`cpp` |
|
77 |
#' characters to render **including** |
|
78 |
#' - word-wrapping |
|
79 |
#' - (vertical only) context repetition |
|
80 |
#' - (vertical only) footnote messages and or section divider lines |
|
81 |
#' take up too many lines after rendering rows |
|
82 |
#' - (vertical only) row is a label or content (row-group summary) row |
|
83 |
#' - (vertical only) row at the pagination point has siblings, and |
|
84 |
#' it has less than `min_siblings` preceding or following siblings |
|
85 |
#' - pagination would occur within a sub-table listed in `nosplitin` |
|
86 |
#' |
|
87 |
NULL |
|
88 | ||
89 |
#' Create row of pagination data frame |
|
90 |
#' @param nm character(1). Name |
|
91 |
#' @param lab character(1). Label |
|
92 |
#' @param rnum numeric(1). Absolute row number |
|
93 |
#' @param pth character or NULL. Path within larger table |
|
94 |
#' @param sibpos integer(1). Position among sibling rows |
|
95 |
#' @param nsibs integer(1). Number of siblings (including self). |
|
96 |
#' @param extent numeric(1). Number of lines required to print the row |
|
97 |
#' @param colwidths numeric. Column widths |
|
98 |
#' @param repext integer(1). Number of lines required to reprint all context for this row if it appears directly |
|
99 |
#' after pagination. |
|
100 |
#' @param repind integer. Vector of row numbers to be reprinted if this row appears directly after pagination. |
|
101 |
#' @param indent integer. Indent |
|
102 |
#' @param rclass character(1). Class of row object. |
|
103 |
#' @param nrowrefs integer(1). Number of row referential footnotes for this row |
|
104 |
#' @param ncellrefs integer(1). Number of cell referential footnotes for the cells in this row |
|
105 |
#' @param nreflines integer(1). Total number of lines required by all referential footnotes |
|
106 |
#' @param force_page logical(1). Currently Ignored. |
|
107 |
#' @param page_title logical(1). Currently Ignored. |
|
108 |
#' @param trailing_sep character(1). The string to used as a separator below this row during printing (or |
|
109 |
#' `NA_character_` for no separator). |
|
110 |
#' @param row ANY. Object representing the row, which is used for default values of \code{nm}, \code{lab}, |
|
111 |
#' \code{extent} and \code{rclass} if provided. Must have methods for \code{obj_name}, \code{obj_label}, |
|
112 |
#' and \code{nlines}, respectively, for default values of \code{nm}, \code{lab} and \code{extent} to |
|
113 |
#' be retrieved, respectively. |
|
114 |
#' |
|
115 |
#' @return a single row data.frame with the columns appropriate for a pagination info data frame. |
|
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 | 1265x |
data.frame( |
138 | 1265x |
label = lab, |
139 | 1265x |
name = nm, |
140 | 1265x |
abs_rownumber = rnum, |
141 | 1265x |
path = I(list(pth)), |
142 | 1265x |
pos_in_siblings = sibpos, |
143 | 1265x |
n_siblings = nsibs, |
144 | 1265x |
self_extent = extent, |
145 | 1265x |
par_extent = repext, |
146 | 1265x |
reprint_inds = I(rep(list(unlist(repind)), length.out = length(nm))), |
147 | 1265x |
node_class = rclass, |
148 | 1265x |
indent = max(0L, indent), |
149 | 1265x |
nrowrefs = nrowrefs, |
150 | 1265x |
ncellrefs = ncellrefs, |
151 | 1265x |
nreflines = nreflines, |
152 |
# ref_info_df = I(list(ref_df)), |
|
153 | 1265x |
force_page = force_page, |
154 | 1265x |
page_title = page_title, |
155 | 1265x |
trailing_sep = trailing_sep, |
156 | 1265x |
stringsAsFactors = FALSE, |
157 | 1265x |
row.names = NULL, |
158 | 1265x |
check.names = FALSE, |
159 | 1265x |
fix.empty.names = FALSE |
160 |
) |
|
161 |
} |
|
162 | ||
163 | ||
164 |
calc_ref_nlines_df <- function(pagdf) { |
|
165 |
## XXX XXX XXX this is dangerous and wrong!!! |
|
166 | 452x |
if (is.null(pagdf$ref_info_df) && sum(pagdf$nreflines) == 0) { |
167 | 203x |
return(ref_df_row()[0, ]) |
168 |
} |
|
169 | 249x |
refdf <- do.call(rbind.data.frame, pagdf$ref_info_df) |
170 | 249x |
if (NROW(refdf) == 0) { |
171 | 151x |
return(ref_df_row()[0, ]) |
172 |
} |
|
173 | 98x |
unqsyms <- !duplicated(refdf$symbol) |
174 | 98x |
refdf[unqsyms, , drop = FALSE] |
175 |
} |
|
176 | ||
177 | ||
178 |
build_fail_msg <- function(row, lines, raw_rowlines, |
|
179 |
start, guess, rep_ext, n_reprint, |
|
180 |
reflines, n_refs, sectlines) { |
|
181 | 252x |
if (row) { |
182 | 105x |
spacetype <- "lines" |
183 | 105x |
spacetype_abr <- "lns" |
184 | 105x |
structtype_abr <- "rws" |
185 | 105x |
sprintf( |
186 | 105x |
paste( |
187 | 105x |
"\t....................... FAIL: requires %d %s [raw: %d %s (%d %s), rep.", |
188 | 105x |
"context: %d %s (%d %s), refs: %d %s (%d) sect. divs: %d %s]." |
189 |
), |
|
190 | 105x |
lines, |
191 | 105x |
spacetype, |
192 | 105x |
raw_rowlines, |
193 | 105x |
spacetype_abr, |
194 | 105x |
guess - start + 1, # because it includes both start and guess |
195 | 105x |
structtype_abr, |
196 | 105x |
rep_ext, |
197 | 105x |
spacetype_abr, |
198 | 105x |
n_reprint, |
199 | 105x |
structtype_abr, |
200 | 105x |
reflines, |
201 | 105x |
spacetype_abr, |
202 | 105x |
n_refs, |
203 | 105x |
sectlines, |
204 | 105x |
spacetype_abr |
205 |
) |
|
206 |
} else { ## !row |
|
207 | 147x |
spacetype <- "chars" |
208 | 147x |
spacetype_abr <- "chars" |
209 | 147x |
structtype_abr <- "cols" |
210 | 147x |
sprintf( |
211 | 147x |
"\t....................... FAIL: requires %d %s (%d %s).", |
212 | 147x |
lines, |
213 | 147x |
spacetype, |
214 | 147x |
guess - start + 1, # because it includes both start and guess |
215 | 147x |
structtype_abr |
216 |
) |
|
217 |
} |
|
218 |
} |
|
219 | ||
220 |
valid_pag <- function(pagdf, |
|
221 |
guess, |
|
222 |
start, |
|
223 |
rlpp, |
|
224 |
min_sibs, |
|
225 |
nosplit = NULL, |
|
226 |
div_height = 1L, |
|
227 |
verbose = FALSE, |
|
228 |
row = TRUE, |
|
229 |
have_col_fnotes = FALSE) { |
|
230 | 452x |
rw <- pagdf[guess, ] |
231 | ||
232 | ||
233 | 452x |
if (verbose) { |
234 | 421x |
message( |
235 | 421x |
"Checking pagination after ", |
236 | 421x |
paste(ifelse(row, "row", "column"), guess) |
237 |
) |
|
238 |
} |
|
239 | 452x |
raw_rowlines <- sum(pagdf[start:guess, "self_extent"] - pagdf[start:guess, "nreflines"]) |
240 | ||
241 | 452x |
refdf_ii <- calc_ref_nlines_df(pagdf[start:guess, ]) |
242 | 452x |
reflines <- if (row) sum(refdf_ii$nlines, 0L) else 0L |
243 | 452x |
if (reflines > 0 && !have_col_fnotes) { |
244 | 35x |
reflines <- reflines + div_height + 1L |
245 |
} |
|
246 | ||
247 |
## reflines <- sum(pagdf[start:guess, "nreflines"]) |
|
248 | 452x |
rowlines <- raw_rowlines + reflines ## sum(pagdf[start:guess, "self_extent"]) - reflines |
249 |
## self extent includes reflines |
|
250 |
## self extent does ***not*** currently include trailing sep |
|
251 |
## we don't include the trailing_sep for guess because if we paginate here it won't be printed |
|
252 | 452x |
sectlines <- if (start == guess) 0L else sum(!is.na(pagdf[start:(guess - 1), "trailing_sep"])) |
253 | 452x |
lines <- rowlines + sectlines # guess - start + 1 because inclusive of start |
254 | 452x |
rep_ext <- pagdf$par_extent[start] |
255 | 452x |
if (lines > rlpp) { |
256 | 268x |
if (verbose) { |
257 | 252x |
structtype <- ifelse(row, "rows", "columns") |
258 | 252x |
structtype_abr <- ifelse(row, "rows", "cols") |
259 | 252x |
spacetype <- ifelse(row, "lines", "chars") |
260 | 252x |
spacetype_abr <- ifelse(row, "lns", "chrs") |
261 | 252x |
msg <- build_fail_msg( |
262 | 252x |
row, lines, raw_rowlines, start, guess, rep_ext, length(pagdf$reprint_inds[[start]]), |
263 | 252x |
reflines, NROW(refdf_ii), sectlines |
264 |
) |
|
265 | 252x |
message(msg) |
266 |
} |
|
267 | 268x |
return(FALSE) |
268 |
} |
|
269 | 184x |
if (rw[["node_class"]] %in% c("LabelRow", "ContentRow")) { |
270 | 10x |
if (verbose) { |
271 | 10x |
message("\t....................... FAIL: last row is a label or content row") |
272 |
} |
|
273 | 10x |
return(FALSE) |
274 |
} |
|
275 | ||
276 | 174x |
sibpos <- rw[["pos_in_siblings"]] |
277 | 174x |
nsib <- rw[["n_siblings"]] |
278 |
# okpos <- min(min_sibs + 1, rw[["n_siblings"]]) |
|
279 | 174x |
if (sibpos != nsib) { |
280 | 108x |
retfalse <- FALSE |
281 | 108x |
if (sibpos < min_sibs + 1) { |
282 | 50x |
retfalse <- TRUE |
283 | 50x |
if (verbose) { |
284 | 50x |
message( |
285 | 50x |
"\t....................... FAIL: last row had only ", sibpos - 1, |
286 | 50x |
" preceding siblings, needed ", min_sibs |
287 |
) |
|
288 |
} |
|
289 | 58x |
} else if (nsib - sibpos < min_sibs + 1) { |
290 | 4x |
retfalse <- TRUE |
291 | 4x |
if (verbose) { |
292 | 4x |
message( |
293 | 4x |
"\t....................... FAIL: last row had only ", nsib - sibpos - 1, |
294 | 4x |
" following siblings, needed ", min_sibs |
295 |
) |
|
296 |
} |
|
297 |
} |
|
298 | 108x |
if (retfalse) { |
299 | 54x |
return(FALSE) |
300 |
} |
|
301 |
} |
|
302 | 120x |
if (guess < nrow(pagdf) && length(nosplit > 0)) { |
303 |
## paths end at the leaf name which is *always* different |
|
304 | 32x |
curpth <- head(unlist(rw$path), -1) |
305 | 32x |
nxtpth <- head(unlist(pagdf$path[[guess + 1]]), -1) |
306 | ||
307 | 32x |
inplay <- nosplit[(nosplit %in% intersect(curpth, nxtpth))] |
308 | 32x |
if (length(inplay) > 0) { |
309 | 32x |
ok_split <- vapply(inplay, function(var) { |
310 | 32x |
!identical(curpth[match(var, curpth) + 1], nxtpth[match(var, nxtpth) + 1]) |
311 | 32x |
}, TRUE) |
312 | ||
313 | 32x |
curvals <- curpth[match(inplay, curpth) + 1] |
314 | 32x |
nxtvals <- nxtpth[match(inplay, nxtpth) + 1] |
315 | 32x |
if (!all(ok_split)) { |
316 | 32x |
if (verbose) { |
317 | 32x |
message( |
318 | 32x |
"\t....................... FAIL: nosplit variable [", |
319 | 32x |
inplay[min(which(!ok_split))], "] would be constant [", |
320 | 32x |
curvals, "] across this pagebreak." |
321 |
) |
|
322 |
} |
|
323 | 32x |
return(FALSE) |
324 |
} |
|
325 |
} |
|
326 |
} |
|
327 | 88x |
if (verbose) { |
328 | 73x |
message("\t....................... OK [", lines + rep_ext, if (row) " lines]" else " chars]") |
329 |
} |
|
330 | 88x |
TRUE |
331 |
} |
|
332 | ||
333 | ||
334 |
find_pag <- function(pagdf, |
|
335 |
start, |
|
336 |
guess, |
|
337 |
rlpp, |
|
338 |
min_siblings, |
|
339 |
nosplitin = character(), |
|
340 |
verbose = FALSE, |
|
341 |
row = TRUE, |
|
342 |
have_col_fnotes = FALSE, |
|
343 |
div_height = 1L, |
|
344 |
do_error = FALSE) { |
|
345 | 98x |
origuess <- guess |
346 | 98x |
while (guess >= start && !valid_pag( |
347 | 98x |
pagdf, guess, |
348 | 98x |
start = start, rlpp = rlpp, min_sibs = min_siblings, |
349 | 98x |
nosplit = nosplitin, verbose, row = row, have_col_fnotes = have_col_fnotes, |
350 | 98x |
div_height = div_height |
351 |
)) { |
|
352 | 364x |
guess <- guess - 1 |
353 |
} |
|
354 | 98x |
if (guess < start) { |
355 | 10x |
if (isFALSE(do_error)) { |
356 | 5x |
find_pag( |
357 | 5x |
pagdf = pagdf, |
358 | 5x |
start = start, |
359 | 5x |
guess = origuess, |
360 | 5x |
rlpp = rlpp, |
361 | 5x |
min_siblings = min_siblings, |
362 | 5x |
nosplitin = nosplitin, |
363 | 5x |
verbose = TRUE, |
364 | 5x |
row = row, |
365 | 5x |
have_col_fnotes = have_col_fnotes, |
366 | 5x |
div_height = div_height, |
367 | 5x |
do_error = TRUE |
368 |
) |
|
369 |
} |
|
370 | 5x |
stop( |
371 | 5x |
"Unable to find any valid pagination split\ between ", |
372 | 5x |
ifelse(row, "rows ", "columns "), start, " and ", origuess, ". \n", |
373 | 5x |
"Inserted ", ifelse(row, "cpp (column-space, content per page) ", "lpp (row-space, lines per page) "), |
374 | 5x |
": ", pagdf$par_extent[start] + rlpp, "\n", |
375 | 5x |
"Need-to-repeat-in-each-page space (key values): ", pagdf$par_extent[start], "\n", |
376 | 5x |
"Remaining space: ", rlpp, "\n", |
377 | 5x |
"Current space needed (with padding): ", pagdf$self_extent[start] |
378 |
) |
|
379 |
} |
|
380 | 88x |
guess |
381 |
} |
|
382 | ||
383 | ||
384 |
#' Find Pagination Indices From Pagination Info Dataframe |
|
385 |
#' |
|
386 |
#' Pagination methods should typically call the `make_row_df` method |
|
387 |
#' for their object and then call this function on the resulting |
|
388 |
#' pagination info data.frame. |
|
389 |
#' |
|
390 |
#' @details `pab_indices_inner` implements the Core Pagination Algorithm |
|
391 |
#' for a single direction (vertical if `row = TRUE`, the default, horizontal otherwise) |
|
392 |
#' based on the pagination dataframe and (already adjusted for non-body rows/columns) |
|
393 |
#' lines (or characters) per page. |
|
394 |
#' |
|
395 |
#' @inheritSection pagination_algo Pagination Algorithm |
|
396 |
#' @param pagdf data.frame. A pagination info data.frame as created by |
|
397 |
#' either `make_rows_df` or `make_cols_df`. |
|
398 |
#' @param rlpp numeric. Maximum number of \emph{row} lines per page (not including header materials), including |
|
399 |
#' (re)printed header and context rows |
|
400 |
#' @param min_siblings numeric. Minimum sibling rows which must appear on either side of pagination row for a |
|
401 |
#' mid-subtable split to be valid. Defaults to 2. |
|
402 |
#' @param nosplitin character. List of names of sub-tables where page-breaks are not allowed, regardless of other |
|
403 |
#' considerations. Defaults to none. |
|
404 |
#' @param verbose logical(1). Should additional informative messages about the search for |
|
405 |
#' pagination breaks be shown. Defaults to \code{FALSE}. |
|
406 |
#' @param row logical(1). Is pagination happening in row |
|
407 |
#' space (`TRUE`, the default) or column space (`FALSE`) |
|
408 |
#' @param have_col_fnotes logical(1). Does the table-like object being rendered have |
|
409 |
#' column-associated referential footnotes. |
|
410 |
#' @param div_height numeric(1). The height of the divider line when the |
|
411 |
#' associated object is rendered. Defaults to `1`. |
|
412 |
#' @return A list containing the vector of row numbers, broken up by page |
|
413 |
#' |
|
414 |
#' @examples |
|
415 |
#' mypgdf <- basic_pagdf(row.names(mtcars)) |
|
416 |
#' |
|
417 |
#' paginds <- pag_indices_inner(mypgdf, rlpp = 15, min_siblings = 0) |
|
418 |
#' lapply(paginds, function(x) mtcars[x, ]) |
|
419 |
#' |
|
420 |
#' @export |
|
421 |
pag_indices_inner <- function(pagdf, rlpp, |
|
422 |
min_siblings, |
|
423 |
nosplitin = character(), |
|
424 |
verbose = FALSE, |
|
425 |
row = TRUE, |
|
426 |
have_col_fnotes = FALSE, |
|
427 |
div_height = 1L) { |
|
428 | 39x |
start <- 1 |
429 | 39x |
nr <- nrow(pagdf) |
430 | 39x |
ret <- list() |
431 | 39x |
while (start <= nr) { |
432 | 94x |
adjrlpp <- rlpp - pagdf$par_extent[start] |
433 | 94x |
if (adjrlpp <= 0) { |
434 | 1x |
if (row) { |
435 | 1x |
stop("Lines of repeated context (plus header materials) larger than specified lines per page") |
436 |
} else { |
|
437 | ! |
stop("Width of row labels equal to or larger than specified characters per page.") |
438 |
} |
|
439 |
} |
|
440 | 93x |
guess <- min(nr, start + adjrlpp - 1) |
441 | 93x |
end <- find_pag(pagdf, start, guess, |
442 | 93x |
rlpp = adjrlpp, |
443 | 93x |
min_siblings = min_siblings, |
444 | 93x |
nosplitin = nosplitin, |
445 | 93x |
verbose = verbose, |
446 | 93x |
row = row, |
447 | 93x |
have_col_fnotes = have_col_fnotes, |
448 | 93x |
div_height = div_height |
449 |
) |
|
450 | 88x |
ret <- c(ret, list(c( |
451 | 88x |
pagdf$reprint_inds[[start]], |
452 | 88x |
start:end |
453 |
))) |
|
454 | 88x |
start <- end + 1 |
455 |
} |
|
456 | 33x |
ret |
457 |
} |
|
458 | ||
459 |
#' Find Column Indices for Vertical Pagination |
|
460 |
#' @param obj ANY. object to be paginated. Must have a |
|
461 |
#' \code{\link{matrix_form}} method. |
|
462 |
#' @param cpp numeric(1). Number of characters per page (width) |
|
463 |
#' @param colwidths numeric vector. Column widths (in characters) for |
|
464 |
#' use with vertical pagination. |
|
465 |
#' @param rep_cols numeric(1). Number of \emph{columns} (not including |
|
466 |
#' row labels) to be repeated on every page. Defaults to 0 |
|
467 |
#' @inheritParams pag_indices_inner |
|
468 |
#' |
|
469 |
#' @return A list partitioning the vector of column indices |
|
470 |
#' into subsets for 1 or more horizontally paginated pages. |
|
471 |
#' |
|
472 |
#' @examples |
|
473 |
#' mf <- basic_matrix_form(df = mtcars) |
|
474 |
#' colpaginds <- vert_pag_indices(mf) |
|
475 |
#' lapply(colpaginds, function(j) mtcars[, j, drop = FALSE]) |
|
476 |
#' @export |
|
477 |
vert_pag_indices <- function(obj, cpp = 40, colwidths = NULL, verbose = FALSE, rep_cols = 0L) { |
|
478 | 17x |
mf <- matrix_form(obj, TRUE) |
479 | 17x |
clwds <- colwidths %||% propose_column_widths(mf) |
480 | 17x |
if (is.null(mf_cinfo(mf))) { ## like always, ugh. |
481 | 2x |
mf <- mpf_infer_cinfo(mf, colwidths = clwds, rep_cols = rep_cols) |
482 |
} |
|
483 | ||
484 | 17x |
has_rlabs <- mf_has_rlabels(mf) |
485 | 17x |
rlabs_flag <- as.integer(has_rlabs) |
486 | 17x |
rlab_extent <- if (has_rlabs) clwds[1] else 0L |
487 | ||
488 |
# rep_extent <- pdf$par_extent[nrow(pdf)] |
|
489 | 17x |
rcpp <- cpp - table_inset(mf) - rlab_extent # rep_extent - table_inset(mf) - rlab_extent |
490 | 17x |
if (verbose) { |
491 | 12x |
message( |
492 | 12x |
"Adjusted characters per page: ", rcpp, |
493 | 12x |
" [original: ", cpp, |
494 | 12x |
", table inset: ", table_inset(mf), if (has_rlabs) paste0(", row labels: ", clwds[1]), |
495 |
"]" |
|
496 |
) |
|
497 |
} |
|
498 | 17x |
res <- pag_indices_inner(mf_cinfo(mf), |
499 | 17x |
rlpp = rcpp, # cpp - sum(clwds[seq_len(rep_cols)]), |
500 | 17x |
verbose = verbose, |
501 | 17x |
min_siblings = 1, |
502 | 17x |
row = FALSE |
503 |
) |
|
504 | 17x |
res |
505 |
} |
|
506 | ||
507 |
mpf_infer_cinfo <- function(mf, colwidths = NULL, rep_cols = num_rep_cols(mf)) { |
|
508 | 48x |
if (!is(rep_cols, "numeric") || is.na(rep_cols) || rep_cols < 0) { |
509 | ! |
stop("got invalid number of columns to be repeated: ", rep_cols) |
510 |
} |
|
511 | 48x |
clwds <- (colwidths %||% mf_col_widths(mf)) %||% propose_column_widths(mf) |
512 | 48x |
has_rlabs <- mf_has_rlabels(mf) |
513 | 48x |
rlabs_flag <- as.integer(has_rlabs) |
514 | 48x |
rlab_extent <- if (has_rlabs) clwds[1] else 0L |
515 | 48x |
sqstart <- rlabs_flag + 1L # rep_cols + 1L |
516 | ||
517 | 48x |
pdfrows <- lapply( |
518 | 48x |
(sqstart):ncol(mf$strings), |
519 | 48x |
function(i) { |
520 | 516x |
rownum <- i - rlabs_flag |
521 | 516x |
rep_inds <- seq_len(rep_cols)[seq_len(rep_cols) < rownum] |
522 | 516x |
rep_extent_i <- sum(0L, clwds[rlabs_flag + rep_inds]) + mf$col_gap * length(rep_inds) |
523 | 516x |
pagdfrow( |
524 | 516x |
row = NA, |
525 | 516x |
nm = rownum, |
526 | 516x |
lab = rownum, |
527 | 516x |
rnum = rownum, |
528 | 516x |
pth = NA, |
529 | 516x |
extent = clwds[i] + mf$col_gap, |
530 | 516x |
repext = rep_extent_i, # sum(clwds[rep_cols]) + mf$col_gap * max(0, (length(rep_cols) - 1)), |
531 | 516x |
repind = rep_inds, # rep_cols, |
532 | 516x |
rclass = "stuff", |
533 | 516x |
sibpos = 1 - 1, |
534 | 516x |
nsibs = 1 - 1 |
535 |
) |
|
536 |
} |
|
537 |
) |
|
538 | 48x |
pdf <- do.call(rbind, pdfrows) |
539 | ||
540 | 48x |
refdf <- mf_fnote_df(mf) |
541 | 48x |
pdf <- splice_fnote_info_in(pdf, refdf, row = FALSE) |
542 | 48x |
mf_cinfo(mf) <- pdf |
543 | 48x |
mf |
544 |
} |
|
545 | ||
546 | ||
547 |
#' Basic/spoof pagination info dataframe |
|
548 |
#' |
|
549 |
#' Returns a minimal pagination info data.frame (with no sibling/footnote/etc info). |
|
550 |
#' @inheritParams basic_matrix_form |
|
551 |
#' @param rnames character. Vector of row names |
|
552 |
#' @param labs character. Vector of row labels (defaults to names) |
|
553 |
#' @param rnums integer. Vector of row numbers. Defaults to `seq_along(rnames)`. |
|
554 |
#' @param extents integer. Number of lines each row will take to print, defaults to 1 for all rows |
|
555 |
#' @param rclass character. Class(es) for the rows. Defaults to "NA" |
|
556 |
#' |
|
557 |
#' @return A data.frame suitable for use in both the `matrix_print_form` constructor and the pagination machinery |
|
558 |
#' |
|
559 |
#' @examples |
|
560 |
#' |
|
561 |
#' basic_pagdf(c("hi", "there")) |
|
562 |
#' @export |
|
563 |
basic_pagdf <- function(rnames, labs = rnames, rnums = seq_along(rnames), |
|
564 |
extents = 1L, |
|
565 |
rclass = "NA", |
|
566 |
parent_path = "root") { |
|
567 | 29x |
rws <- mapply(pagdfrow, |
568 | 29x |
nm = rnames, lab = labs, extent = extents, |
569 | 29x |
rclass = rclass, rnum = rnums, pth = lapply(rnames, function(x) c(parent_path, x)), |
570 | 29x |
SIMPLIFY = FALSE, nsibs = 1, sibpos = 1 |
571 |
) |
|
572 | 29x |
res <- do.call(rbind.data.frame, rws) |
573 | 29x |
res$n_siblings <- nrow(res) |
574 | 29x |
res$pos_in_siblings <- seq_along(res$n_siblings) |
575 | 29x |
res |
576 |
} |
|
577 | ||
578 | ||
579 | ||
580 | ||
581 |
## write paginate() which operates **solely** on a MatrixPrintForm obj |
|
582 | ||
583 | ||
584 |
page_size_spec <- function(lpp, cpp, max_width) { |
|
585 | 22x |
structure(list( |
586 | 22x |
lpp = lpp, |
587 | 22x |
cpp = cpp, |
588 | 22x |
max_width = max_width |
589 | 22x |
), class = "page_size_spec") |
590 |
} |
|
591 | ||
592 | ||
593 | 44x |
non_null_na <- function(x) !is.null(x) && is.na(x) |
594 | ||
595 | ||
596 |
calc_lcpp <- function(page_type = NULL, |
|
597 |
landscape = FALSE, |
|
598 |
pg_width = page_dim(page_type)[if (landscape) 2 else 1], |
|
599 |
pg_height = page_dim(page_type)[if (landscape) 1 else 2], |
|
600 |
font_family = "Courier", |
|
601 |
font_size = 8, # grid parameters |
|
602 |
cpp = NA_integer_, |
|
603 |
lpp = NA_integer_, |
|
604 |
tf_wrap = TRUE, |
|
605 |
max_width = NULL, |
|
606 |
lineheight = 1, |
|
607 |
margins = c(bottom = .5, left = .75, top = .5, right = .75), |
|
608 |
colwidths, |
|
609 |
col_gap, |
|
610 |
inset) { |
|
611 | 22x |
pg_lcpp <- page_lcpp( |
612 | 22x |
page_type = page_type, |
613 | 22x |
landscape = landscape, |
614 | 22x |
font_family = font_family, |
615 | 22x |
font_size = font_size, |
616 | 22x |
lineheight = lineheight, |
617 | 22x |
margins = margins, |
618 | 22x |
pg_width = pg_width, |
619 | 22x |
pg_height = pg_height |
620 |
) |
|
621 | ||
622 | 22x |
if (non_null_na(lpp)) { |
623 | 14x |
lpp <- pg_lcpp$lpp |
624 |
} |
|
625 | 22x |
if (non_null_na(cpp)) { |
626 | 15x |
cpp <- pg_lcpp$cpp |
627 |
} |
|
628 | 22x |
stopifnot(!is.na(cpp)) |
629 | 22x |
if (!tf_wrap && !is.null(max_width)) { |
630 | ! |
warning("tf_wrap is FALSE - ignoring non-null max_width value.") |
631 | ! |
max_width <- NULL |
632 | 22x |
} else if (tf_wrap && is.null(max_width)) { |
633 | 6x |
max_width <- cpp |
634 |
} |
|
635 | 22x |
if (is.character(max_width) && identical(max_width, "auto")) { |
636 | ! |
max_width <- inset + sum(colwidths) + (length(colwidths) - 1) * col_gap |
637 |
} |
|
638 | 22x |
page_size_spec(lpp = lpp, cpp = cpp, max_width = max_width) |
639 |
} |
|
640 | ||
641 | ||
642 |
calc_rlpp <- function(pg_size_spec, mf, colwidths, tf_wrap, verbose) { |
|
643 | 20x |
lpp <- pg_size_spec$lpp |
644 | 20x |
max_width <- pg_size_spec$max_width |
645 | ||
646 | 20x |
dh <- divider_height(mf) |
647 | 20x |
if (any(nzchar(all_titles(mf)))) { |
648 |
## +1 is for blank line between subtitles and divider |
|
649 |
## dh is for divider line **between subtitles and column labels** |
|
650 |
## other divider line is accounted for in cinfo_lines |
|
651 | 11x |
if (!tf_wrap) { |
652 | 9x |
tlines <- length(all_titles(mf)) |
653 |
} else { |
|
654 | 2x |
tlines <- sum(nlines(all_titles(mf), colwidths = colwidths, max_width = max_width)) |
655 |
} |
|
656 | 11x |
tlines <- tlines + dh + 1L |
657 |
} else { |
|
658 | 9x |
tlines <- 0 |
659 |
} |
|
660 | ||
661 |
## dh for divider line between column labels and table body |
|
662 | 20x |
cinfo_lines <- mf_nlheader(mf) + dh |
663 | ||
664 | 20x |
if (verbose) { |
665 | 15x |
message( |
666 | 15x |
"Determining lines required for header content: ", |
667 | 15x |
tlines, " title and ", cinfo_lines, " table header lines" |
668 |
) |
|
669 |
} |
|
670 | ||
671 | 20x |
refdf <- mf_fnote_df(mf) |
672 | 20x |
cfn_df <- refdf[is.na(refdf$row) & !is.na(refdf$col), ] |
673 | ||
674 | 20x |
flines <- 0L |
675 | 20x |
mnfoot <- main_footer(mf) |
676 | 20x |
havemn <- length(mnfoot) && any(nzchar(mnfoot)) |
677 | 20x |
if (havemn) { |
678 | 12x |
flines <- nlines( |
679 | 12x |
mnfoot, |
680 | 12x |
colwidths = colwidths, |
681 | 12x |
max_width = max_width - table_inset(mf) |
682 |
) |
|
683 |
} |
|
684 | 20x |
prfoot <- prov_footer(mf) |
685 | 20x |
if (length(prfoot) && any(nzchar(prfoot))) { |
686 | 11x |
flines <- flines + nlines(prov_footer(mf), colwidths = colwidths, max_width = max_width) |
687 | 11x |
if (havemn) { |
688 | 11x |
flines <- flines + 1L |
689 |
} ## space between main and prov footer. |
|
690 |
} |
|
691 |
## this time its for the divider between the footers and whatever is above them |
|
692 |
## (either table body or referential footnotes) |
|
693 | 20x |
if (flines > 0) { |
694 | 12x |
flines <- flines + dh + 1L |
695 |
} |
|
696 |
## this time its for the divider between the referential footnotes and |
|
697 |
## the table body IFF we have any, otherwise that divider+blanks pace doesn't get drawn |
|
698 | 20x |
if (NROW(cfn_df) > 0) { |
699 | ! |
cinfo_lines <- cinfo_lines + sum(cfn_df$nlines) |
700 | ! |
flines <- flines + dh + 1L |
701 |
} |
|
702 | ||
703 | 20x |
if (verbose) { |
704 | 15x |
message( |
705 | 15x |
"Determining lines required for footer content", |
706 | 15x |
if (NROW(cfn_df) > 0) " [column fnotes present]", |
707 | 15x |
": ", flines, " lines" |
708 |
) |
|
709 |
} |
|
710 | ||
711 | 20x |
ret <- lpp - flines - tlines - cinfo_lines |
712 | ||
713 | 20x |
if (verbose) { |
714 | 15x |
message("Lines per page available for tables rows: ", ret, " (original: ", lpp, ")") |
715 |
} |
|
716 | 20x |
ret |
717 |
} |
|
718 | ||
719 | ||
720 |
calc_rcpp <- function(pg_size_spec, mf, colwidths) { |
|
721 | ! |
cpp <- pg_size_spec$cpp |
722 | ||
723 | ! |
cpp - table_inset(mf) - colwidths[1] - mf_colgap(mf) |
724 |
} |
|
725 | ||
726 | ||
727 |
splice_idx_lists <- function(lsts) { |
|
728 | ! |
list( |
729 | ! |
pag_row_indices = do.call(c, lapply(lsts, function(xi) xi$pag_row_indices)), |
730 | ! |
pag_col_indices = do.call(c, lapply(lsts, function(yi) yi$pag_col_indices)) |
731 |
) |
|
732 |
} |
|
733 | ||
734 | ||
735 | ||
736 |
#' @title Paginate a table-like object for rendering |
|
737 |
#' |
|
738 |
#' @description |
|
739 |
#' These functions perform or diagnose bi-directional pagination on |
|
740 |
#' an object. |
|
741 |
#' |
|
742 |
#' `paginate_to_mpfs` renders `obj` into the `MatrixPrintForm` (`MPF`) |
|
743 |
#' intermediate representation, and then paginates that `MPF` into |
|
744 |
#' component `MPF`s each corresponding to an individual page and |
|
745 |
#' returns those in a list. |
|
746 |
#' |
|
747 |
#' `paginate_indices` renders `obj` into an `MPF`, then uses |
|
748 |
#' that representation to calculate the rows and columns of |
|
749 |
#' `obj` corresponding to each page of the pagination of `obj`, |
|
750 |
#' but simply returns these indices rather than paginating |
|
751 |
#' \code{obj} itself (see details for an important caveat). |
|
752 |
#' |
|
753 |
#' `diagnose_pagination` attempts pagination via `paginate_to_mpfs` |
|
754 |
#' and then returns diagnostic information which explains why page |
|
755 |
#' breaks were positioned where they were, or alternatively why |
|
756 |
#' no valid paginations could be found. |
|
757 |
#' |
|
758 |
#' @details |
|
759 |
#' |
|
760 |
#' All three of these functions generally support all classes which have |
|
761 |
#' a corresponding `matrix_form` method which returns a valid `MatrixPrintForm` |
|
762 |
#' object (including `MatrixPrintForm` objects themselves). |
|
763 |
#' |
|
764 |
#' `paginate_indices` is directly called by `paginate_to_mpfs` (and thus |
|
765 |
#' `diagnose_pagination`). For most classes, and most tables represented |
|
766 |
#' by supported classes, calling `paginate_to_mpfs` is equivalent to a |
|
767 |
#' manual `paginate_indices -> subset obj into pages -> matrix_form` |
|
768 |
#' workflow. |
|
769 |
#' |
|
770 |
#' The exception to this equivalence is objects which support 'forced pagination', |
|
771 |
#' or pagination logic which built into the object itself rather than being a |
|
772 |
#' function of space on a page. Forced pagination generally involves the creation |
|
773 |
#' of, e.g., page-specific titles which apply to these forced paginations. |
|
774 |
#' `paginate_to_mpfs` and `diagnose_pagination` support forced pagination by |
|
775 |
#' automatically calling the `do_forced_pagination` generic on the object |
|
776 |
#' and then paginating each object returned by that generic separately. The |
|
777 |
#' assumption here, then, is that page-specific titles and such are |
|
778 |
#' handled by the class' `do_forced_pagination` method. |
|
779 |
#' |
|
780 |
#' `paginate_indices`, on the other hand, \emph{does not support forced pagination}, |
|
781 |
#' because it returns only a set of indices for row and column subsetting for each page, |
|
782 |
#' and thus cannot retain any changes, e.g., to titles, done within `do_forced_paginate`. |
|
783 |
#' `paginate_indices` does call `do_forced_paginate`, but instead of continuing, it |
|
784 |
#' throws an error in the case that the result is more than a single "page". |
|
785 |
#' |
|
786 |
#' @inheritParams vert_pag_indices |
|
787 |
#' @inheritParams pag_indices_inner |
|
788 |
#' @inheritParams page_lcpp |
|
789 |
#' @inheritParams toString |
|
790 |
#' @inheritParams propose_column_widths |
|
791 |
#' @param lpp numeric(1) or NULL. Lines per page. if NA (the default, |
|
792 |
#' this is calculated automatically based on the specified page |
|
793 |
#' size). `NULL` indicates no vertical pagination should occur. |
|
794 |
#' @param cpp numeric(1) or NULL. Width in characters per page. if NA (the default, |
|
795 |
#' this is calculated automatically based on the specified page |
|
796 |
#' size). `NULL` indicates no horizontal pagination should occur. |
|
797 | ||
798 |
#' @param pg_size_spec page_size_spec. A pre-calculated page |
|
799 |
#' size specification. Typically this is not set in end user code. |
|
800 |
#' @param col_gap numeric(1). Currently unused. |
|
801 |
#' @return for `paginate_indices` a list with two elements of the same |
|
802 |
#' length: `pag_row_indices`, and `pag_col_indices`. For |
|
803 |
#' `paginate_to_mpfs`, a list of `MatrixPrintForm` objects |
|
804 |
#' representing each individual page after pagination (including |
|
805 |
#' forced pagination if necessary). |
|
806 |
#' @export |
|
807 |
#' @aliases paginate pagination |
|
808 |
#' @examples |
|
809 |
#' mpf <- basic_matrix_form(mtcars) |
|
810 |
#' |
|
811 |
#' paginate_indices(mpf, pg_width = 5, pg_height = 3) |
|
812 |
#' |
|
813 |
#' paginate_to_mpfs(mpf, pg_width = 5, pg_height = 3) |
|
814 |
paginate_indices <- function(obj, |
|
815 |
page_type = "letter", |
|
816 |
font_family = "Courier", |
|
817 |
font_size = 8, |
|
818 |
lineheight = 1, |
|
819 |
landscape = FALSE, |
|
820 |
pg_width = NULL, |
|
821 |
pg_height = NULL, |
|
822 |
margins = c(top = .5, bottom = .5, left = .75, right = .75), |
|
823 |
lpp = NA_integer_, |
|
824 |
cpp = NA_integer_, |
|
825 |
min_siblings = 2, |
|
826 |
nosplitin = character(), |
|
827 |
colwidths = NULL, |
|
828 |
tf_wrap = FALSE, |
|
829 |
max_width = NULL, |
|
830 |
indent_size = 2, |
|
831 |
pg_size_spec = NULL, |
|
832 |
rep_cols = num_rep_cols(obj), |
|
833 |
col_gap = 3, |
|
834 |
verbose = FALSE) { |
|
835 |
## this MUST alsways return a list, inluding list(obj) when |
|
836 |
## no forced pagination is needed! otherwise stuff breaks for things |
|
837 |
## based on s3 classes that are lists underneath!!! |
|
838 | 22x |
fpags <- do_forced_paginate(obj) |
839 | ||
840 |
## if we have more than one forced "page", |
|
841 |
## paginate each of them individually and return the result. |
|
842 |
## forced pagination is ***currently*** only vertical, so |
|
843 |
## we don't have to worry about divying up colwidths here, |
|
844 |
## but we will if we ever allow force_paginate to do horiz |
|
845 |
## pagination. |
|
846 | 22x |
if (length(fpags) > 1) { |
847 | 1x |
stop( |
848 | 1x |
"forced pagination is required for this object (class: ", class(obj)[1], |
849 | 1x |
") this is not supported in paginate_indices. Use paginate_to_mpfs or call ", |
850 | 1x |
"do_forced_paginate on your object and paginate each returned section separately." |
851 |
) |
|
852 |
} |
|
853 | ||
854 | ||
855 |
## I'm not sure this is worth doing. |
|
856 |
## ## We can't support forced pagination here, but we can support calls to, |
|
857 |
## ## e.g., paginate_indices(do_forced_pag(tt)) |
|
858 |
## if(is.list(obj) && !is.object(obj)) { |
|
859 |
## res <- lapply(obj, paginate_indices, |
|
860 |
## page_type = page_type, |
|
861 |
## font_family = font_family, |
|
862 |
## font_size = font_size, |
|
863 |
## lineheight = lineheight, |
|
864 |
## landscape = landscape, |
|
865 |
## pg_width = pg_width, |
|
866 |
## pg_height = pg_height, |
|
867 |
## margins = margins, |
|
868 |
## lpp = lpp, |
|
869 |
## cpp = cpp, |
|
870 |
## tf_wrap = tf_wrap, |
|
871 |
## max_width = max_width, |
|
872 |
## colwidths = colwidths, |
|
873 |
## min_siblings = min_siblings, |
|
874 |
## nosplitin = nosplitin, |
|
875 |
## col_gap = col_gap, |
|
876 |
## ## not setting num_rep_cols here cause it wont' get it right |
|
877 |
## verbose = verbose) |
|
878 |
## return(splice_idx_lists(res)) |
|
879 |
## } |
|
880 |
## order is annoying here, since we won't actually need the mpf if |
|
881 |
## we run into forced pagination, but life is short and this should work fine. |
|
882 | 21x |
mpf <- matrix_form(obj, TRUE, TRUE, indent_size = indent_size) |
883 | 21x |
if (is.null(colwidths)) { |
884 | 2x |
colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf) |
885 |
} else { |
|
886 | 19x |
mf_col_widths(mpf) <- colwidths |
887 |
} |
|
888 | 21x |
if (NROW(mf_cinfo(mpf)) == 0) { |
889 | 21x |
mpf <- mpf_infer_cinfo(mpf, colwidths, rep_cols) |
890 |
} |
|
891 | ||
892 | ||
893 | 21x |
if (is.null(pg_size_spec)) { |
894 | 2x |
pg_size_spec <- calc_lcpp( |
895 | 2x |
page_type = page_type, |
896 | 2x |
font_family = font_family, |
897 | 2x |
font_size = font_size, |
898 | 2x |
lineheight = lineheight, |
899 | 2x |
landscape = landscape, |
900 | 2x |
pg_width = pg_width, |
901 | 2x |
pg_height = pg_height, |
902 | 2x |
margins = margins, |
903 | 2x |
lpp = lpp, |
904 | 2x |
cpp = cpp, |
905 | 2x |
tf_wrap = tf_wrap, |
906 | 2x |
max_width = max_width, |
907 | 2x |
colwidths = colwidths, |
908 | 2x |
inset = table_inset(mpf), |
909 | 2x |
col_gap = col_gap |
910 |
) |
|
911 |
} |
|
912 | ||
913 |
## we can't support forced pagination in paginate_indices because |
|
914 |
## forced pagination is generally going to set page titles, which |
|
915 |
## we can't preserve when just returning lists of indices. |
|
916 |
## Instead we make a hard assumption here that any forced pagination |
|
917 |
## has already occured. |
|
918 | ||
919 | ||
920 | ||
921 | ||
922 | ||
923 |
## this wraps the cell contents AND shoves referential footnote |
|
924 |
## info into mf_rinfo(mpf) |
|
925 | 21x |
mpf <- do_cell_fnotes_wrap(mpf, colwidths, max_width, tf_wrap = tf_wrap) |
926 | ||
927 | 21x |
if (is.null(pg_size_spec$lpp)) { |
928 | 1x |
pag_row_indices <- list(seq_len(mf_nrow(mpf))) |
929 |
} else { |
|
930 | 20x |
pag_row_indices <- pag_indices_inner( |
931 | 20x |
pagdf = mf_rinfo(mpf), |
932 | 20x |
rlpp = calc_rlpp( |
933 | 20x |
pg_size_spec, mpf, |
934 | 20x |
colwidths = colwidths, |
935 | 20x |
tf_wrap = tf_wrap, verbose = verbose |
936 |
), |
|
937 | 20x |
verbose = verbose, |
938 | 20x |
min_siblings = min_siblings, |
939 | 20x |
nosplitin = nosplitin |
940 |
) |
|
941 |
} |
|
942 | ||
943 | 16x |
if (is.null(pg_size_spec$cpp)) { |
944 | 1x |
pag_col_indices <- list(seq_len(mf_ncol(mpf))) |
945 |
} else { |
|
946 | 15x |
pag_col_indices <- vert_pag_indices( |
947 | 15x |
mpf, |
948 | 15x |
cpp = pg_size_spec$cpp, colwidths = colwidths, |
949 | 15x |
rep_cols = rep_cols, verbose = verbose |
950 |
) |
|
951 |
} |
|
952 | ||
953 | 16x |
list(pag_row_indices = pag_row_indices, pag_col_indices = pag_col_indices) |
954 |
} |
|
955 | ||
956 | 19x |
setGeneric("has_page_title", function(obj) standardGeneric("has_page_title")) |
957 | ||
958 | 19x |
setMethod("has_page_title", "ANY", function(obj) length(page_titles(obj)) > 0) |
959 | ||
960 |
#' @rdname paginate_indices |
|
961 |
#' @export |
|
962 |
paginate_to_mpfs <- function(obj, |
|
963 |
page_type = "letter", |
|
964 |
font_family = "Courier", |
|
965 |
font_size = 8, |
|
966 |
lineheight = 1, |
|
967 |
landscape = FALSE, |
|
968 |
pg_width = NULL, |
|
969 |
pg_height = NULL, |
|
970 |
margins = c(top = .5, bottom = .5, left = .75, right = .75), |
|
971 |
lpp = NA_integer_, |
|
972 |
cpp = NA_integer_, |
|
973 |
min_siblings = 2, |
|
974 |
nosplitin = character(), |
|
975 |
colwidths = NULL, |
|
976 |
tf_wrap = FALSE, |
|
977 |
max_width = NULL, |
|
978 |
indent_size = 2, |
|
979 |
pg_size_spec = NULL, |
|
980 |
rep_cols = num_rep_cols(obj), |
|
981 |
col_gap = 2, |
|
982 |
verbose = FALSE) { |
|
983 | 20x |
mpf <- matrix_form(obj, TRUE, TRUE, indent_size = indent_size) |
984 | 20x |
if (is.null(colwidths)) { |
985 | 12x |
colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf) |
986 |
} else { |
|
987 | 8x |
mf_col_widths(mpf) <- colwidths |
988 |
} |
|
989 | 20x |
if (NROW(mf_cinfo(mpf)) == 0) { |
990 | 20x |
mpf <- mpf_infer_cinfo(mpf, colwidths, rep_cols) |
991 |
} |
|
992 | ||
993 | ||
994 | 20x |
if (is.null(pg_size_spec)) { |
995 | 18x |
pg_size_spec <- calc_lcpp( |
996 | 18x |
page_type = page_type, |
997 | 18x |
font_family = font_family, |
998 | 18x |
font_size = font_size, |
999 | 18x |
lineheight = lineheight, |
1000 | 18x |
landscape = landscape, |
1001 | 18x |
pg_width = pg_width, |
1002 | 18x |
pg_height = pg_height, |
1003 | 18x |
margins = margins, |
1004 | 18x |
lpp = lpp, |
1005 | 18x |
cpp = cpp, |
1006 | 18x |
tf_wrap = tf_wrap, |
1007 | 18x |
max_width = max_width, |
1008 | 18x |
colwidths = colwidths, |
1009 | 18x |
inset = table_inset(mpf), |
1010 | 18x |
col_gap = col_gap |
1011 |
) |
|
1012 |
} |
|
1013 |
## this MUST alsways return a list, inluding list(obj) when |
|
1014 |
## no forced pagination is needed! otherwise stuff breaks for things |
|
1015 |
## based on s3 classes that are lists underneath!!! |
|
1016 | 20x |
fpags <- do_forced_paginate(obj) |
1017 | ||
1018 |
## if we have more than one forced "page", |
|
1019 |
## paginate each of them individually and return the result. |
|
1020 |
## forced pagination is ***currently*** only vertical, so |
|
1021 |
## we don't have to worry about divying up colwidths here, |
|
1022 |
## but we will if we ever allow force_paginate to do horiz |
|
1023 |
## pagination. |
|
1024 | 20x |
if (length(fpags) > 1) { |
1025 | 1x |
deep_pag <- lapply( |
1026 | 1x |
fpags, paginate_to_mpfs, |
1027 | 1x |
pg_size_spec = pg_size_spec, |
1028 | 1x |
colwidths = colwidths, |
1029 | 1x |
min_siblings = min_siblings, |
1030 | 1x |
nosplitin = nosplitin, |
1031 | 1x |
verbose = verbose |
1032 |
) |
|
1033 | 1x |
return(unlist(deep_pag, recursive = FALSE)) |
1034 | 19x |
} else if (has_page_title(fpags[[1]])) { |
1035 | ! |
obj <- fpags[[1]] |
1036 |
} |
|
1037 | ||
1038 | ||
1039 |
## we run into forced pagination, but life is short and this should work fine. |
|
1040 | 19x |
mpf <- matrix_form(obj, TRUE, TRUE, indent_size = indent_size) |
1041 | 19x |
if (is.null(colwidths)) { |
1042 | ! |
colwidths <- mf_col_widths(mpf) %||% propose_column_widths(mpf) |
1043 |
} |
|
1044 | 19x |
mf_col_widths(mpf) <- colwidths |
1045 | ||
1046 | 19x |
page_indices <- paginate_indices( |
1047 | 19x |
obj = obj, |
1048 |
## page_type = page_type, |
|
1049 |
## font_family = font_family, |
|
1050 |
## font_size = font_size, |
|
1051 |
## lineheight = lineheight, |
|
1052 |
## landscape = landscape, |
|
1053 |
## pg_width = pg_width, |
|
1054 |
## pg_height = pg_height, |
|
1055 |
## margins = margins, |
|
1056 | 19x |
pg_size_spec = pg_size_spec, |
1057 |
## lpp = lpp, |
|
1058 |
## cpp = cpp, |
|
1059 | 19x |
min_siblings = min_siblings, |
1060 | 19x |
nosplitin = nosplitin, |
1061 | 19x |
colwidths = colwidths, |
1062 | 19x |
tf_wrap = tf_wrap, |
1063 |
## max_width = max_width, |
|
1064 | 19x |
rep_cols = rep_cols, |
1065 | 19x |
verbose = verbose |
1066 |
) |
|
1067 | ||
1068 |
# This needs to be fixed better |
|
1069 | 16x |
if (inherits(fpags[[1]], "listing_df") && length(fpags) < 2) { |
1070 | ! |
pagmats <- lapply( |
1071 | ! |
page_indices$pag_row_indices, |
1072 | ! |
function(ii) { |
1073 | ! |
mf_tmp <- matrix_form(obj[ii, ], TRUE, TRUE, indent_size = indent_size) |
1074 | ! |
mf_col_widths(mf_tmp) <- colwidths |
1075 | ! |
mf_tmp |
1076 |
} |
|
1077 |
) |
|
1078 |
} else { |
|
1079 | 16x |
pagmats <- lapply(page_indices$pag_row_indices, function(ii) { |
1080 | 35x |
mpf_subset_rows(mpf, ii) |
1081 |
}) |
|
1082 |
} |
|
1083 | ||
1084 |
## these chunks now carry around their (correctly subset) col widths... |
|
1085 | 16x |
res <- lapply(pagmats, function(matii) { |
1086 | 35x |
lapply(page_indices$pag_col_indices, function(jj) { |
1087 | 69x |
mpf_subset_cols(matii, jj) |
1088 |
}) |
|
1089 |
}) |
|
1090 | ||
1091 | 16x |
unlist(res, recursive = FALSE) |
1092 |
} |
|
1093 | ||
1094 | ||
1095 |
#' @importFrom utils capture.output |
|
1096 |
#' @details |
|
1097 |
#' |
|
1098 |
#' `diagnose_pagination` attempts pagination and then, regardless of success |
|
1099 |
#' or failure, returns diagnostic information about pagination |
|
1100 |
#' attempts (if any) after each row and column. |
|
1101 |
#' |
|
1102 |
#' The diagnostics data reflects the final time the pagination algorithm |
|
1103 |
#' evaluated a page break at the specified location, regardless of how |
|
1104 |
#' many times the position was assessed total. |
|
1105 |
#' |
|
1106 |
#' To get information about intermediate attempts, perform pagination |
|
1107 |
#' with `verbose = TRUE` and inspect the messages in order. |
|
1108 |
#' |
|
1109 |
#' @return For `diagnose_pagination` a list containing: |
|
1110 |
#' |
|
1111 |
#' \describe{ |
|
1112 |
#' \item{`lpp_diagnostics`}{diagnostic information regarding lines per page} |
|
1113 |
#' \item{`row_diagnostics`}{basic information about rows, whether pagination was attempted |
|
1114 |
#' after each row, and the final result of such an attempt, if made} |
|
1115 |
#' \item{`cpp_diagnostics}{diagnostic information regarding columns per page} |
|
1116 |
#' \item{`col_diagnostics`}{(very) basic information about leaf columns, whether pagination |
|
1117 |
#' was attempted after each leaf column, ad the final result of such attempts, if made} |
|
1118 |
#' } |
|
1119 |
#' |
|
1120 |
#' @note For `diagnose_pagination`, the column labels are not |
|
1121 |
#' displayed in the `col_diagnostics` element due to certain |
|
1122 |
#' internal implementation details; rather the diagnostics are |
|
1123 |
#' reported in terms of absolute (leaf) column position. This is a |
|
1124 |
#' known limitation, and may eventually be changed, but the |
|
1125 |
#' information remains useful as it is currently reported. |
|
1126 |
#' |
|
1127 |
#' @note `diagnose_pagination` is intended for interactive debugging |
|
1128 |
#' use and \emph{should not be programmed against}, as the exact |
|
1129 |
#' content and form of the verbose messages it captures and |
|
1130 |
#' returns is subject to change. |
|
1131 |
#' |
|
1132 |
#' @note because `diagnose_pagination` relies on `capture.output(type = "message")`, |
|
1133 |
#' it cannot be used within the `testthat` (and likely other) testing frameworks, |
|
1134 |
#' and likely cannot be used within `knitr`/`rmarkdown` contexts either, |
|
1135 |
#' as this clashes with those systems' capture of messages. |
|
1136 |
#' |
|
1137 |
#' @export |
|
1138 |
#' |
|
1139 |
#' @rdname paginate_indices |
|
1140 |
#' @examples |
|
1141 |
#' |
|
1142 |
#' diagnose_pagination(mpf, pg_width = 5, pg_height = 3) |
|
1143 |
#' clws <- propose_column_widths(mpf) |
|
1144 |
#' clws[1] <- floor(clws[1] / 3) |
|
1145 |
#' dgnost <- diagnose_pagination(mpf, pg_width = 5, pg_height = 3, colwidths = clws) |
|
1146 |
#' try(diagnose_pagination(mpf, pg_width = 1)) # fails |
|
1147 |
#' |
|
1148 |
diagnose_pagination <- function(obj, |
|
1149 |
page_type = "letter", |
|
1150 |
font_family = "Courier", |
|
1151 |
font_size = 8, |
|
1152 |
lineheight = 1, |
|
1153 |
landscape = FALSE, |
|
1154 |
pg_width = NULL, |
|
1155 |
pg_height = NULL, |
|
1156 |
margins = c(top = .5, bottom = .5, left = .75, right = .75), |
|
1157 |
lpp = NA_integer_, |
|
1158 |
cpp = NA_integer_, |
|
1159 |
min_siblings = 2, |
|
1160 |
nosplitin = character(), |
|
1161 |
colwidths = propose_column_widths(matrix_form(obj, TRUE)), |
|
1162 |
tf_wrap = FALSE, |
|
1163 |
max_width = NULL, |
|
1164 |
indent_size = 2, |
|
1165 |
pg_size_spec = NULL, |
|
1166 |
rep_cols = num_rep_cols(obj), |
|
1167 |
col_gap = 2, |
|
1168 |
verbose = FALSE, |
|
1169 |
...) { |
|
1170 | 6x |
fpag <- do_forced_paginate(obj) |
1171 | 6x |
if (length(fpag) > 1) { |
1172 | 1x |
return(lapply( |
1173 | 1x |
fpag, |
1174 | 1x |
diagnose_pagination, |
1175 | 1x |
page_type = page_type, |
1176 | 1x |
font_family = font_family, |
1177 | 1x |
font_size = font_size, |
1178 | 1x |
lineheight = lineheight, |
1179 | 1x |
landscape = landscape, |
1180 | 1x |
pg_width = pg_width, |
1181 | 1x |
pg_height = pg_height, |
1182 | 1x |
margins = margins, |
1183 | 1x |
lpp = lpp, |
1184 | 1x |
cpp = cpp, |
1185 | 1x |
tf_wrap = tf_wrap, |
1186 | 1x |
max_width = max_width, |
1187 | 1x |
colwidths = colwidths, |
1188 | 1x |
col_gap = col_gap, |
1189 | 1x |
min_siblings = min_siblings, |
1190 | 1x |
nosplitin = nosplitin |
1191 |
)) |
|
1192 |
} |
|
1193 | ||
1194 | 5x |
mpf <- matrix_form(obj, TRUE) |
1195 | 5x |
msgres <- capture.output( |
1196 |
{ |
|
1197 | 5x |
tmp <- try( |
1198 | 5x |
paginate_to_mpfs( |
1199 | 5x |
obj, |
1200 | 5x |
page_type = page_type, |
1201 | 5x |
font_family = font_family, |
1202 | 5x |
font_size = font_size, |
1203 | 5x |
lineheight = lineheight, |
1204 | 5x |
landscape = landscape, |
1205 | 5x |
pg_width = pg_width, |
1206 | 5x |
pg_height = pg_height, |
1207 | 5x |
margins = margins, |
1208 | 5x |
lpp = lpp, |
1209 | 5x |
cpp = cpp, |
1210 | 5x |
tf_wrap = tf_wrap, |
1211 | 5x |
max_width = max_width, |
1212 | 5x |
colwidths = colwidths, |
1213 | 5x |
col_gap = col_gap, |
1214 | 5x |
min_siblings = min_siblings, |
1215 | 5x |
nosplitin = nosplitin, |
1216 | 5x |
verbose = TRUE |
1217 |
) |
|
1218 |
) |
|
1219 |
}, |
|
1220 | 5x |
type = "message" |
1221 |
) |
|
1222 | 5x |
if (is(tmp, "try-error") && grepl("Width of row labels equal to or larger", tmp)) { |
1223 | ! |
cond <- attr(tmp, "condition") |
1224 | ! |
stop(conditionMessage(cond), call. = conditionCall(cond)) |
1225 |
} |
|
1226 | ||
1227 | 5x |
lpp_diagnostic <- grep("^(Determining lines|Lines per page available).*$", msgres, value = TRUE) |
1228 | 5x |
cpp_diagnostic <- unique(grep("^Adjusted characters per page.*$", msgres, value = TRUE)) |
1229 | ||
1230 | 5x |
mpf <- do_cell_fnotes_wrap(mpf, widths = colwidths, max_width = max_width, tf_wrap = tf_wrap) |
1231 | 5x |
mpf <- mpf_infer_cinfo(mpf, colwidths = colwidths) |
1232 | ||
1233 | 5x |
rownls <- grep("Checking pagination after row", msgres, fixed = TRUE) |
1234 | 5x |
rownum <- as.integer(gsub("[^[:digit:]]*(.*)$", "\\1", msgres[rownls])) |
1235 | 5x |
rowmsgs <- vapply(unique(rownum), function(ii) { |
1236 | ! |
idx <- max(which(rownum == ii)) |
1237 | ! |
gsub("\\t[.]*", "", msgres[rownls[idx] + 1]) |
1238 |
}, "") |
|
1239 | ||
1240 | 5x |
msgdf <- data.frame( |
1241 | 5x |
abs_rownumber = unique(rownum), |
1242 | 5x |
final_pag_result = rowmsgs, stringsAsFactors = FALSE |
1243 |
) |
|
1244 | 5x |
rdf <- mf_rinfo(mpf)[, c("abs_rownumber", "label", "self_extent", "par_extent", "node_class")] |
1245 | 5x |
rdf$pag_attempted <- rdf$abs_rownumber %in% rownum |
1246 | 5x |
row_diagnose <- merge(rdf, msgdf, by = "abs_rownumber", all.x = TRUE) |
1247 | ||
1248 | 5x |
colnls <- grep("Checking pagination after column", msgres, fixed = TRUE) |
1249 | 5x |
colnum <- as.integer(gsub("[^[:digit:]]*(.*)$", "\\1", msgres[colnls])) |
1250 | 5x |
colmsgs <- vapply(unique(colnum), function(ii) { |
1251 | ! |
idx <- max(which(colnum == ii)) |
1252 | ! |
gsub("\\t[.]*", "", msgres[colnls[idx] + 1]) |
1253 |
}, "") |
|
1254 | ||
1255 | 5x |
colmsgdf <- data.frame( |
1256 | 5x |
abs_rownumber = unique(colnum), |
1257 | 5x |
final_pag_result = colmsgs, |
1258 | 5x |
stringsAsFactors = FALSE |
1259 |
) |
|
1260 | 5x |
cdf <- mf_cinfo(mpf)[, c("abs_rownumber", "self_extent")] |
1261 | 5x |
cdf$pag_attempted <- cdf$abs_rownumber %in% colnum |
1262 | 5x |
col_diagnose <- merge(cdf, colmsgdf, by = "abs_rownumber", all.x = TRUE) |
1263 | 5x |
names(col_diagnose) <- gsub("^abs_rownumber$", "abs_colnumber", names(col_diagnose)) |
1264 | 5x |
list( |
1265 | 5x |
lpp_diagnostics = lpp_diagnostic, |
1266 | 5x |
row_diagnostics = row_diagnose, |
1267 | 5x |
cpp_diagnostics = cpp_diagnostic, |
1268 | 5x |
col_diagnostics = col_diagnose |
1269 |
) |
|
1270 |
} |
1 |
#' Return an object with a label attribute |
|
2 |
#' |
|
3 |
#' @param x an object |
|
4 |
#' @param label label attribute to to attached to \code{x} |
|
5 |
#' |
|
6 |
#' @export |
|
7 |
#' @return \code{x} labeled by \code{label}. Note: the exact mechanism of labeling should be |
|
8 |
#' considered an internal implementation detail, but the label will always be retrieved via \code{obj_label}. |
|
9 |
#' @examples |
|
10 |
#' x <- with_label(c(1, 2, 3), label = "Test") |
|
11 |
#' obj_label(x) |
|
12 |
with_label <- function(x, label) { |
|
13 | 1x |
obj_label(x) <- label |
14 | 1x |
x |
15 |
} |
|
16 | ||
17 | ||
18 |
#' Get Label Attributes of Variables in a \code{data.frame} |
|
19 |
#' |
|
20 |
#' Variable labels can be stored as a \code{label} attribute for each variable. |
|
21 |
#' This functions returns a named character vector with the variable labels |
|
22 |
#' (empty sting if not specified) |
|
23 |
#' |
|
24 |
#' @param x a \code{data.frame} object |
|
25 |
#' @param fill boolean in case the \code{label} attribute does not exist if |
|
26 |
#' \code{TRUE} the variable names is returned, otherwise \code{NA} |
|
27 |
#' |
|
28 |
#' @return a named character vector with the variable labels, the names |
|
29 |
#' correspond to the variable names |
|
30 |
#' |
|
31 |
#' @export |
|
32 |
#' |
|
33 |
#' @examples |
|
34 |
#' x <- iris |
|
35 |
#' var_labels(x) |
|
36 |
#' var_labels(x) <- paste("label for", names(iris)) |
|
37 |
#' var_labels(x) |
|
38 |
var_labels <- function(x, fill = FALSE) { |
|
39 | 4x |
stopifnot(is.data.frame(x)) |
40 | 4x |
if (NCOL(x) == 0) { |
41 | 1x |
return(character()) |
42 |
} |
|
43 | ||
44 | 3x |
y <- Map(function(col, colname) { |
45 | 33x |
label <- attr(col, "label") |
46 | ||
47 | 33x |
if (is.null(label)) { |
48 | 11x |
if (fill) { |
49 | ! |
colname |
50 |
} else { |
|
51 | 3x |
NA_character_ |
52 |
} |
|
53 |
} else { |
|
54 | 22x |
if (!is.character(label) && !(length(label) == 1)) { |
55 | ! |
stop("label for variable ", colname, "is not a character string") |
56 |
} |
|
57 | 22x |
as.vector(label) |
58 |
} |
|
59 | 3x |
}, x, colnames(x)) |
60 | ||
61 | 3x |
labels <- unlist(y, recursive = FALSE, use.names = TRUE) |
62 | ||
63 | 3x |
if (!is.character(labels)) { |
64 | ! |
stop("label extraction failed") |
65 |
} |
|
66 | ||
67 | 3x |
labels |
68 |
} |
|
69 | ||
70 | ||
71 |
#' Set Label Attributes of All Variables in a \code{data.frame} |
|
72 |
#' |
|
73 |
#' Variable labels can be stored as a \code{label} attribute for each variable. |
|
74 |
#' This functions sets all non-missing (non-NA) variable labels in a \code{data.frame} |
|
75 |
#' |
|
76 |
#' @inheritParams var_labels |
|
77 |
#' @param value new variable labels, \code{NA} removes the variable label |
|
78 |
#' |
|
79 |
#' @return modifies the variable labels of \code{x} |
|
80 |
#' |
|
81 |
#' @export |
|
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 |
`var_labels<-` <- function(x, value) { |
|
93 | 1x |
stopifnot( |
94 | 1x |
is.data.frame(x), |
95 | 1x |
is.character(value), |
96 | 1x |
ncol(x) == length(value) |
97 |
) |
|
98 | ||
99 | 1x |
theseq <- if (!is.null(names(value))) names(value) else seq_along(x) |
100 |
# across columns of x |
|
101 | 1x |
for (j in theseq) { |
102 | 11x |
attr(x[[j]], "label") <- if (!is.na(value[j])) { |
103 | 11x |
value[j] |
104 |
} else { |
|
105 | ! |
NULL |
106 |
} |
|
107 |
} |
|
108 | ||
109 | 1x |
x |
110 |
} |
|
111 | ||
112 | ||
113 |
#' Copy and Change Variable Labels of a \code{data.frame} |
|
114 |
#' |
|
115 |
#' Relabel a subset of the variables |
|
116 |
#' |
|
117 |
#' @inheritParams var_labels<- |
|
118 |
#' @param ... name-value pairs, where name corresponds to a variable name in |
|
119 |
#' \code{x} and the value to the new variable label |
|
120 |
#' |
|
121 |
#' @return a copy of \code{x} with changed labels according to \code{...} |
|
122 |
#' |
|
123 |
#' @export |
|
124 |
#' |
|
125 |
#' @examples |
|
126 |
#' x <- var_relabel(iris, Sepal.Length = "Sepal Length of iris flower") |
|
127 |
#' var_labels(x) |
|
128 |
#' |
|
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 | ||
157 |
#' Remove Variable Labels of a \code{data.frame} |
|
158 |
#' |
|
159 |
#' Removing labels attributes from a variables in a data frame |
|
160 |
#' |
|
161 |
#' @param x a \code{data.frame} object |
|
162 |
#' |
|
163 |
#' @return the same data frame as \code{x} stripped of variable labels |
|
164 |
#' |
|
165 |
#' @export |
|
166 |
#' |
|
167 |
#' @examples |
|
168 |
#' x <- var_labels_remove(iris) |
|
169 |
var_labels_remove <- function(x) { |
|
170 | 1x |
stopifnot(is.data.frame(x)) |
171 | ||
172 | 1x |
for (i in seq_len(ncol(x))) { |
173 | 11x |
attr(x[[i]], "label") <- NULL |
174 |
} |
|
175 | ||
176 | 1x |
x |
177 |
} |
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 break |
|
6 |
#' |
|
7 |
#' This function converts \code{x} to a \code{MatrixPrintForm} object via |
|
8 |
#' \code{matrix_form}, paginates it via \code{paginate}, converts each |
|
9 |
#' page to ASCII text via \code{toString}, and emits the strings to \code{file}, |
|
10 |
#' separated by \code{page_break}. |
|
11 |
#' |
|
12 |
#' @inheritParams paginate_indices |
|
13 |
#' @inheritParams toString |
|
14 |
#' @inheritParams propose_column_widths |
|
15 |
#' @param x ANY. The table-like object to export. Must have an |
|
16 |
#' applicable \code{matrix_form} method. |
|
17 |
#' @param file character(1) or NULL. If non-NULL, the path to write a |
|
18 |
#' text file to containing the \code{x} rendered as ASCII text, |
|
19 |
#' @param page_break character(1). Page break symbol (defaults to |
|
20 |
#' outputting \code{"\\n\\s"}). |
|
21 |
#' @param paginate logical(1). Whether pagination should be performed, |
|
22 |
#' defaults to \code{TRUE} if page size is specified (including |
|
23 |
#' the default). |
|
24 |
#' @details if \code{x} has an \code{num_rep_cols} method, the value |
|
25 |
#' returned by it will be used for \code{rep_cols} by default, if |
|
26 |
#' not, 0 will be used. |
|
27 |
#' |
|
28 |
#' If \code{x} has an applicable \code{do_mand_paginate} method, it will be invoked |
|
29 |
#' during the pagination process. |
|
30 |
#' |
|
31 |
#' @return if \code{file} is NULL, the total paginated and then concatenated |
|
32 |
#' string value, otherwise the file that was written. |
|
33 |
#' @export |
|
34 |
#' @examples |
|
35 |
#' export_as_txt(basic_matrix_form(mtcars), pg_height = 5, pg_width = 4) |
|
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 = num_rep_cols(x), |
|
58 |
verbose = FALSE, |
|
59 |
page_break = "\\s\\n") { |
|
60 | 4x |
if (paginate) { |
61 | 4x |
pages <- paginate_to_mpfs( |
62 | 4x |
x, |
63 | 4x |
page_type = page_type, |
64 | 4x |
font_family = font_family, |
65 | 4x |
font_size = font_size, |
66 | 4x |
lineheight = lineheight, |
67 | 4x |
landscape = landscape, |
68 | 4x |
pg_width = pg_width, |
69 | 4x |
pg_height = pg_height, |
70 | 4x |
margins = margins, |
71 | 4x |
lpp = lpp, |
72 | 4x |
cpp = cpp, |
73 | 4x |
min_siblings = min_siblings, |
74 | 4x |
nosplitin = nosplitin, |
75 | 4x |
colwidths = colwidths, |
76 | 4x |
tf_wrap = tf_wrap, |
77 | 4x |
max_width = max_width, |
78 | 4x |
indent_size = indent_size, |
79 | 4x |
verbose = verbose, |
80 | 4x |
rep_cols = rep_cols |
81 |
) |
|
82 |
} else { |
|
83 | ! |
mf <- matrix_form(x, TRUE, TRUE, indent_size = indent_size) |
84 | ! |
mf_col_widths(mf) <- colwidths %||% propose_column_widths(mf) |
85 | ! |
pages <- list(mf) |
86 |
} |
|
87 |
## we dont' set widths here because we already but that info on mpf |
|
88 |
## so its on each of the pages. |
|
89 | 4x |
strings <- vapply( |
90 | 4x |
pages, toString, "", |
91 | 4x |
widths = NULL, |
92 | 4x |
hsep = hsep, tf_wrap = tf_wrap, max_width = max_width |
93 |
) |
|
94 | 4x |
res <- paste(strings, collapse = page_break) |
95 | ||
96 | 4x |
if (is.null(file)) { |
97 | 2x |
res |
98 |
} else { |
|
99 | 2x |
cat(res, file = file) |
100 |
} |
|
101 |
} |
|
102 | ||
103 | ||
104 | ||
105 |
## ## TODO this needs to be in terms of a MPF, so ncol(tt) needs to change |
|
106 | ||
107 |
## ## if(!is.null(colwidths) && length(colwidths) != ncol(tt) + 1) |
|
108 |
## ## stop("non-null colwidths argument must have length ncol(tt) + 1 [", |
|
109 |
## ## ncol(tt) + 1, "], got length ", length(colwidths)) |
|
110 | ||
111 |
## mpf <- matrix_form(x, indent_rownames = TRUE) |
|
112 | ||
113 |
## ps_spec <- calc_lcpp(page_type = page_type, |
|
114 |
## landscape = landscape, |
|
115 |
## pg_width = pg_width, |
|
116 |
## pg_height = pg_height, |
|
117 |
## font_family = font_family, |
|
118 |
## cpp = cpp, |
|
119 |
## lpp = lpp) |
|
120 | ||
121 |
## ## This needs to return list(x) in cases where no pagination was necessary |
|
122 |
## idx_lst <- paginate(mpf, .page_size_spec = ps_spec, colwidths = colwidths, |
|
123 |
## tf_wrap = tf_wrap, ## XXX I think we don't need this |
|
124 |
## ...) |
|
125 | ||
126 |
## tbls <- lapply(idx_lst, function(ii) |
|
127 |
## ## XXX how do we partition the colwidths ??? |
|
128 |
## ## Also this is gross make it a function!!! |
|
129 |
## res <- paste(mapply(function(tb, cwidths, ...) { |
|
130 |
## ## 1 and +1 are because cwidths includes rowlabel 'column' |
|
131 |
## cinds <- c(1, .figure_out_colinds(tb, tt) + 1L) |
|
132 |
## toString(tb, widths = cwidths[cinds], ...) |
|
133 |
## }, |
|
134 |
## MoreArgs = list(hsep = hsep, |
|
135 |
## indent_size = indent_size, |
|
136 |
## tf_wrap = tf_wrap, |
|
137 |
## max_width = max_width, |
|
138 |
## cwidths = colwidths), |
|
139 |
## SIMPLIFY = FALSE, |
|
140 |
## tb = tbls), |
|
141 |
## collapse = page_break) |
|
142 | ||
143 |
## if(!is.null(file)) |
|
144 |
## cat(res, file = file) |
|
145 |
## else |
|
146 |
## res |
|
147 |
## } |
|
148 | ||
149 | ||
150 | ||
151 | ||
152 |
## In use, must be tested |
|
153 |
prep_header_line <- function(mf, i) { |
|
154 | 2x |
ret <- mf$strings[i, mf$display[i, , drop = TRUE], drop = TRUE] |
155 | 2x |
ret |
156 |
} |
|
157 | ||
158 |
## margin_lines_to_in <- function(margins, font_size, font_family) { |
|
159 |
## tmpfile <- tempfile(fileext = ".pdf") |
|
160 |
## gp_plot <- gpar(fontsize = font_size, fontfamily = font_family) |
|
161 |
## pdf(file = tmpfile, width = 20, height = 20) |
|
162 |
## on.exit({ |
|
163 |
## dev.off() |
|
164 |
## file.remove(tmpfile) |
|
165 |
## }) |
|
166 |
## grid.newpage() |
|
167 |
## pushViewport(plotViewport(margins = margins, gp = gp_plot)) |
|
168 |
## c( |
|
169 |
## bottom = convertHeight(unit(margins["bottom"], "lines"), "inches", valueOnly = TRUE), |
|
170 |
## left = convertWidth(unit(1, "strwidth", strrep("m", margins["left"])), "inches", valueOnly = TRUE), |
|
171 |
## top = convertHeight(unit(margins["top"], "lines"), "inches", valueOnly = TRUE), |
|
172 |
## right = convertWidth(unit(1, "strwidth", strrep("m", margins["right"])), "inches", valueOnly = TRUE) |
|
173 |
## ) |
|
174 |
## } |
|
175 | ||
176 | ||
177 | ||
178 | ||
179 |
mpf_to_dfbody <- function(mpf, colwidths) { |
|
180 | 2x |
mf <- matrix_form(mpf, indent_rownames = TRUE) |
181 | 2x |
nlr <- mf_nlheader(mf) |
182 | 2x |
if (is.null(colwidths)) { |
183 | ! |
colwidths <- propose_column_widths(mf) |
184 |
} |
|
185 | 2x |
mf$strings[1:nlr, 1] <- ifelse(nzchar(mf$strings[1:nlr, 1, drop = TRUE]), |
186 | 2x |
mf$strings[1:nlr, 1, drop = TRUE], |
187 | 2x |
strrep(" ", colwidths) |
188 |
) |
|
189 | ||
190 | ||
191 | 2x |
myfakedf <- as.data.frame(tail(mf$strings, -nlr)) |
192 | 2x |
myfakedf |
193 |
} |
|
194 | ||
195 | ||
196 |
#' Transform `MPF` to `RTF` |
|
197 |
#' |
|
198 |
#' Experimental export to `RTF` via the `r2rtf` package |
|
199 |
#' |
|
200 |
#' @inheritParams page_lcpp |
|
201 |
#' @inheritParams toString |
|
202 |
#' @inheritParams grid::plotViewport |
|
203 |
#' @param mpf `MatrixPrintForm`. `MatrixPrintForm` object. |
|
204 |
#' @param colwidths character(1). Column widths. |
|
205 |
#' @details This function provides a low-level coercion of a |
|
206 |
#' `MatrixPrintForm` object into text containing the corresponding |
|
207 |
#' table in `RTF`. Currently, no pagination is done at this level, |
|
208 |
#' and should be done prior to calling this function, though that |
|
209 |
#' may change in the future. |
|
210 |
#' |
|
211 |
#' @return An `RTF` object |
|
212 |
#' @export |
|
213 |
mpf_to_rtf <- function(mpf, |
|
214 |
colwidths = NULL, |
|
215 |
page_type = "letter", |
|
216 |
pg_width = page_dim(page_type)[if (landscape) 2 else 1], |
|
217 |
pg_height = page_dim(page_type)[if (landscape) 1 else 2], |
|
218 |
landscape = FALSE, |
|
219 |
margins = c(4, 4, 4, 4), |
|
220 |
font_size = 8, |
|
221 |
...) { |
|
222 | 2x |
if (!requireNamespace("r2rtf")) { |
223 | ! |
stop("RTF export requires the 'r2rtf' package, please install it.") |
224 |
} |
|
225 | 2x |
mpf <- matrix_form(mpf, indent_rownames = TRUE) |
226 | 2x |
nlr <- mf_nlheader(mpf) |
227 | 2x |
if (is.null(colwidths)) { |
228 | ! |
colwidths <- propose_column_widths(mpf) |
229 |
} |
|
230 | 2x |
mpf$strings[1:nlr, 1] <- ifelse(nzchar(mpf$strings[1:nlr, 1, drop = TRUE]), |
231 | 2x |
mpf$strings[1:nlr, 1, drop = TRUE], |
232 | 2x |
strrep(" ", colwidths) |
233 |
) |
|
234 | ||
235 | 2x |
myfakedf <- mpf_to_dfbody(mpf, colwidths) |
236 | ||
237 | 2x |
rtfpg <- r2rtf::rtf_page(myfakedf, |
238 | 2x |
width = pg_width, |
239 | 2x |
height = pg_height, |
240 | 2x |
orientation = if (landscape) "landscape" else "portrait", |
241 | 2x |
margin = c(0.1, 0.1, 0.1, 0.1, 0.1, 0.1), |
242 | 2x |
nrow = 10000L |
243 | 2x |
) ## dont allow r2rtf to restrict lines per page beyond actual real eastate |
244 | 2x |
rtfpg <- r2rtf::rtf_title(rtfpg, main_title(mpf), subtitles(mpf), text_font = 1) |
245 | 2x |
for (i in seq_len(nlr)) { |
246 | 2x |
hdrlndat <- prep_header_line(mpf, i) |
247 | 2x |
rtfpg <- r2rtf::rtf_colheader(rtfpg, |
248 | 2x |
paste(hdrlndat, collapse = " | "), |
249 | 2x |
col_rel_width = unlist(tapply(colwidths, |
250 | 2x |
cumsum(mpf$display[i, , drop = TRUE]), |
251 | 2x |
sum, |
252 | 2x |
simplify = FALSE |
253 |
)), |
|
254 | 2x |
border_top = c("", rep(if (i > 1) "single" else "", length(hdrlndat) - 1)), |
255 | 2x |
text_font = 9, ## this means Courier New for some insane reason |
256 | 2x |
text_font_size = font_size |
257 |
) |
|
258 |
} |
|
259 | ||
260 | 2x |
rtfpg <- r2rtf::rtf_body(rtfpg, |
261 | 2x |
col_rel_width = colwidths, |
262 | 2x |
text_justification = c("l", rep("c", ncol(myfakedf) - 1)), |
263 | 2x |
text_format = "", |
264 | 2x |
text_font = 9, |
265 | 2x |
text_font_size = font_size |
266 |
) |
|
267 | ||
268 | 2x |
for (i in seq_along(mpf$ref_footnotes)) { |
269 | 4x |
rtfpg <- r2rtf::rtf_footnote(rtfpg, |
270 | 4x |
mpf$ref_footnotes[i], |
271 | 4x |
border_top = if (i == 1) "single" else "", |
272 | 4x |
border_bottom = if (i == length(mpf$ref_footnotes)) "single" else "", |
273 | 4x |
text_font = 9 |
274 |
) |
|
275 |
} |
|
276 | ||
277 | 2x |
if (length(main_footer(mpf)) > 0) { |
278 | 2x |
rtfpg <- r2rtf::rtf_footnote(rtfpg, main_footer(mpf), text_font = 9) |
279 |
} |
|
280 | 2x |
if (length(prov_footer(mpf)) > 0) { |
281 | 2x |
rtfpg <- r2rtf::rtf_source(rtfpg, prov_footer(mpf), text_font = 9) |
282 |
} |
|
283 | ||
284 | 2x |
rtfpg |
285 |
} |
|
286 | ||
287 |
## Not currently in use, previous alternate ways to get to RTF |
|
288 | ||
289 |
## ## XXX Experimental. Not to be exported without approval |
|
290 |
## mpf_to_huxtable <- function(obj) { |
|
291 |
## if (!requireNamespace("huxtable")) { |
|
292 |
## stop("mpf_to_huxtable requires the huxtable package") |
|
293 |
## } |
|
294 |
## mf <- matrix_form(obj, indent_rownames = TRUE) |
|
295 |
## nlr <- mf_nlheader(mf) |
|
296 |
## myfakedf <- as.data.frame(tail(mf$strings, -nlr)) |
|
297 |
## ret <- huxtable::as_hux(myfakedf, add_colnames = FALSE) |
|
298 |
## mf$strings[!mf$display] <- "" |
|
299 |
## for (i in seq_len(nlr)) { |
|
300 |
## arglist <- c( |
|
301 |
## list(ht = ret, after = i - 1), |
|
302 |
## as.list(mf$strings[i, ]) |
|
303 |
## ) |
|
304 |
## ret <- do.call(huxtable::insert_row, arglist) |
|
305 | ||
306 |
## spanspl <- split( |
|
307 |
## seq_len(ncol(mf$strings)), |
|
308 |
## cumsum(mf$display[i, ]) |
|
309 |
## ) |
|
310 | ||
311 | ||
312 |
## for (j in seq_along(spanspl)) { |
|
313 |
## if (length(spanspl[[j]]) > 1) { |
|
314 |
## ret <- huxtable::merge_cells(ret, row = i, col = spanspl[[j]]) |
|
315 |
## } |
|
316 |
## } |
|
317 |
## } |
|
318 |
## ret <- huxtable::set_header_rows(ret, seq_len(nlr), TRUE) |
|
319 |
## huxtable::font(ret) <- "courier" |
|
320 |
## huxtable::font_size(ret) <- 6 |
|
321 |
## huxtable::align(ret)[ |
|
322 |
## seq_len(nrow(ret)), |
|
323 |
## seq_len(ncol(ret)) |
|
324 |
## ] <- mf$aligns |
|
325 |
## ret |
|
326 |
## } |
|
327 | ||
328 |
## ## XXX Experimental. Not to be exported without approval |
|
329 |
## mpf_to_rtf <- function(obj, ..., file) { |
|
330 |
## huxt <- mpf_to_huxtable(obj) |
|
331 |
## ## a bunch more stuff here |
|
332 |
## huxtable::quick_rtf(huxt, ..., file = file) |
|
333 |
## } |
|
334 | ||
335 | ||
336 | ||
337 | ||
338 |
## ## XXX Experimental. Not to be exported without approval |
|
339 |
## mpf_to_gt <- function(obj) { |
|
340 |
## requireNamespace("gt") |
|
341 |
## mf <- matrix_form(obj, indent_rownames = TRUE) |
|
342 |
## nlh <- mf_nlheader(mf) |
|
343 |
## body_df <- as.data.frame(mf$strings[-1 * seq_len(nlh), ]) |
|
344 |
## varnamerow <- mf_nrheader(mf) |
|
345 |
## ## detect if we have counts |
|
346 |
## if (any(nzchar(mf$formats[seq_len(nlh), ]))) { |
|
347 |
## varnamerow <- varnamerow - 1 |
|
348 |
## } |
|
349 | ||
350 |
## rlbl_lst <- as.list(mf$strings[nlh, , drop = TRUE]) |
|
351 |
## names(rlbl_lst) <- names(body_df) |
|
352 | ||
353 |
## ret <- gt::gt(body_df, rowname_col = "V1") |
|
354 |
## ret <- gt::cols_label(ret, .list = rlbl_lst) |
|
355 |
## if (nlh > 1) { |
|
356 |
## for (i in 1:(nlh - 1)) { |
|
357 |
## linedat <- mf$strings[i, , drop = TRUE] |
|
358 |
## splvec <- cumsum(mf$display[i, , drop = TRUE]) |
|
359 |
## spl <- split(seq_along(linedat), splvec) |
|
360 |
## for (j in seq_along(spl)) { |
|
361 |
## vns <- names(body_df)[spl[[j]]] |
|
362 |
## labval <- linedat[spl[[j]][1]] |
|
363 |
## ret <- gt::tab_spanner(ret, |
|
364 |
## label = labval, |
|
365 |
## columns = {{ vns }}, |
|
366 |
## level = nlh - i, |
|
367 |
## id = paste0(labval, j) |
|
368 |
## ) |
|
369 |
## } |
|
370 |
## } |
|
371 |
## } |
|
372 | ||
373 |
## ret <- gt::opt_css(ret, css = "th.gt_left { white-space:pre;}") |
|
374 | ||
375 |
## ret |
|
376 |
## } |
|
377 | ||
378 | ||
379 | ||
380 |
#' Export table to `RTF` |
|
381 |
#' |
|
382 |
#' Experimental export to the `RTF` format. |
|
383 |
#' |
|
384 |
#' @details `RTF` export occurs by via the following steps |
|
385 |
#' |
|
386 |
#' \itemize{ |
|
387 |
#' \item{the table is paginated to the page size (Vertically and horizontally)} |
|
388 |
#' \item{Each separate page is converted to a `MatrixPrintForm` and from there to `RTF`-encoded text} |
|
389 |
#' \item{Separate `RTFs` text chunks are combined and written out as a single `RTF` file} |
|
390 |
#' } |
|
391 |
#' |
|
392 |
#' Conversion of `MatrixPrintForm` objects to `RTF` is done via [formatters::mpf_to_rtf()]. |
|
393 |
#' @inheritParams export_as_txt |
|
394 |
#' @inheritParams toString |
|
395 |
#' @inheritParams grid::plotViewport |
|
396 |
#' @inheritParams paginate_to_mpfs |
|
397 |
#' @export |
|
398 | ||
399 |
export_as_rtf <- function(x, |
|
400 |
file = NULL, |
|
401 |
colwidths = propose_column_widths(matrix_form(x, TRUE)), |
|
402 |
page_type = "letter", |
|
403 |
pg_width = page_dim(page_type)[if (landscape) 2 else 1], |
|
404 |
pg_height = page_dim(page_type)[if (landscape) 1 else 2], |
|
405 |
landscape = FALSE, |
|
406 |
margins = c(bottom = .5, left = .75, top = .5, right = .75), |
|
407 |
font_size = 8, |
|
408 |
font_family = "Courier", |
|
409 |
...) { |
|
410 | 1x |
if (!requireNamespace("r2rtf")) { |
411 | ! |
stop("RTF export requires the r2rtf package, please install it.") |
412 |
} |
|
413 | 1x |
if (is.null(names(margins))) { |
414 | ! |
names(margins) <- marg_order |
415 |
} |
|
416 | ||
417 | 1x |
fullmf <- matrix_form(x, indent_rownames = TRUE) |
418 | 1x |
req_ncols <- ncol(fullmf) + as.numeric(mf_has_rlabels(fullmf)) |
419 | 1x |
if (!is.null(colwidths) && length(colwidths) != req_ncols) { |
420 | ! |
stop( |
421 | ! |
"non-null colwidths argument must have length ncol(x) (+ 1 if row labels are present) [", |
422 | ! |
req_ncols, "], got length ", length(colwidths) |
423 |
) |
|
424 |
} |
|
425 | ||
426 | 1x |
true_width <- pg_width - sum(margins[c("left", "right")]) |
427 | 1x |
true_height <- pg_height - sum(margins[c("top", "bottom")]) |
428 | ||
429 | 1x |
mpfs <- paginate_to_mpfs( |
430 | 1x |
fullmf, |
431 | 1x |
font_family = font_family, font_size = font_size, |
432 | 1x |
pg_width = true_width, |
433 | 1x |
pg_height = true_height, |
434 | 1x |
margins = c(bottom = 0, left = 0, top = 0, right = 0), |
435 | 1x |
lineheight = 1.25, |
436 | 1x |
colwidths = colwidths, |
437 |
... |
|
438 |
) |
|
439 | ||
440 | 1x |
rtftxts <- lapply(mpfs, function(mf) { |
441 | 2x |
r2rtf::rtf_encode(mpf_to_rtf(mf, |
442 | 2x |
colwidths = mf_col_widths(mf), |
443 | 2x |
page_type = page_type, |
444 | 2x |
pg_width = pg_width, |
445 | 2x |
pg_height = pg_height, |
446 | 2x |
font_size = font_size, |
447 | 2x |
margins = c(top = 0, left = 0, bottom = 0, right = 0) |
448 |
)) |
|
449 |
}) |
|
450 | 1x |
restxt <- paste( |
451 | 1x |
rtftxts[[1]]$start, |
452 | 1x |
paste( |
453 | 1x |
sapply(rtftxts, function(x) x$body), |
454 | 1x |
collapse = "\n{\\pard\\fs2\\par}\\page{\\pard\\fs2\\par}\n" |
455 |
), |
|
456 | 1x |
rtftxts[[1]]$end |
457 |
) |
|
458 | 1x |
if (!is.null(file)) { |
459 | 1x |
cat(restxt, file = file) |
460 |
} else { |
|
461 | ! |
restxt |
462 |
} |
|
463 |
} |
|
464 | ||
465 | ||
466 |
#' Export as PDF |
|
467 |
#' |
|
468 |
#' The PDF output is based on the ASCII output created with [toString()] |
|
469 |
#' |
|
470 |
#' @inheritParams export_as_txt |
|
471 |
#' @param file file to write, must have `.pdf` extension |
|
472 |
#' @param width Deprecated, please use `pg_width` or specify |
|
473 |
#' `page_type`. The width of the graphics region in inches |
|
474 |
#' @param height Deprecated, please use `pg_height` or specify |
|
475 |
#' `page_type`. The height of the graphics region in inches |
|
476 |
#' @param fontsize Deprecated, please use `font_size`. The size of |
|
477 |
#' text (in points) |
|
478 |
#' @param margins numeric(4). The number of lines/characters of margin on the |
|
479 |
#' bottom, left, top, and right sides of the page. |
|
480 |
#' |
|
481 |
#' @importFrom grDevices pdf |
|
482 |
#' @importFrom grid textGrob grid.newpage gpar pushViewport plotViewport unit grid.draw |
|
483 |
#' convertWidth convertHeight grobHeight grobWidth |
|
484 |
#' |
|
485 |
#' @details By default, pagination is performed with default |
|
486 |
#' `cpp` and `lpp` defined by specified page dimensions and margins. |
|
487 |
#' User-specified `lpp` and `cpp` values override this, and should |
|
488 |
#' be used with caution. |
|
489 |
#' |
|
490 |
#' Title and footer materials are also word-wrapped by default |
|
491 |
#' (unlike when printed to the terminal), with `cpp`, as |
|
492 |
#' defined above, as the default `max_width`. |
|
493 |
#' |
|
494 |
#' @seealso [export_as_txt()] |
|
495 |
#' |
|
496 |
#' @importFrom grid textGrob get.gpar |
|
497 |
#' @importFrom grDevices dev.off |
|
498 |
#' @importFrom tools file_ext |
|
499 |
#' @export |
|
500 |
#' |
|
501 |
#' @examples |
|
502 |
#' \dontrun{ |
|
503 |
#' tf <- tempfile(fileext = ".pdf") |
|
504 |
#' export_as_pdf(basic_matrix_form(mtcars), file = tf, pg_height = 4) |
|
505 |
#' |
|
506 |
#' tf <- tempfile(fileext = ".pdf") |
|
507 |
#' export_as_pdf(basic_matrix_form(mtcars), file = tf, lpp = 8) |
|
508 |
#' } |
|
509 |
export_as_pdf <- function(x, |
|
510 |
file, |
|
511 |
page_type = "letter", |
|
512 |
landscape = FALSE, |
|
513 |
pg_width = page_dim(page_type)[if (landscape) 2 else 1], |
|
514 |
pg_height = page_dim(page_type)[if (landscape) 1 else 2], |
|
515 |
width = NULL, |
|
516 |
height = NULL, # passed to pdf() |
|
517 |
margins = c(4, 4, 4, 4), |
|
518 |
min_siblings = 2, |
|
519 |
font_family = "Courier", |
|
520 |
font_size = 8, |
|
521 |
fontsize = font_size, |
|
522 |
paginate = TRUE, |
|
523 |
lpp = NULL, |
|
524 |
cpp = NULL, |
|
525 |
hsep = "-", |
|
526 |
indent_size = 2, |
|
527 |
tf_wrap = TRUE, |
|
528 |
max_width = NULL, |
|
529 |
colwidths = propose_column_widths(x)) { |
|
530 | ! |
stopifnot(tools::file_ext(file) != ".pdf") |
531 | ! |
if (!is.null(colwidths) && length(colwidths) != ncol(x) + 1) { |
532 | ! |
stop( |
533 | ! |
"non-null colwidths argument must have length ncol(x) + 1 [", |
534 | ! |
ncol(x) + 1, "], got length ", length(colwidths) |
535 |
) |
|
536 |
} |
|
537 | ! |
gp_plot <- grid::gpar(fontsize = font_size, fontfamily = font_family) |
538 | ||
539 | ! |
if (!is.null(height)) { |
540 | ! |
pg_height <- height |
541 |
} |
|
542 | ||
543 | ! |
if (!is.null(width)) { |
544 | ! |
pg_width <- width |
545 |
} |
|
546 | ||
547 | ! |
if (missing(font_size) && !missing(fontsize)) { |
548 | ! |
font_size <- fontsize |
549 |
} |
|
550 | ! |
pdf(file = file, width = pg_width, height = pg_height) |
551 | ! |
on.exit(dev.off()) |
552 | ! |
grid::grid.newpage() |
553 | ! |
grid::pushViewport(grid::plotViewport(margins = margins, gp = gp_plot)) |
554 | ||
555 | ! |
cur_gpar <- grid::get.gpar() |
556 | ! |
if (is.null(lpp)) { |
557 | ! |
lpp <- floor(grid::convertHeight(grid::unit(1, "npc"), "lines", valueOnly = TRUE) / |
558 | ! |
(cur_gpar$cex * cur_gpar$lineheight)) - sum(margins[c(1, 3)]) # bottom, top # nolint |
559 |
} |
|
560 | ! |
if (is.null(cpp)) { |
561 | ! |
cpp <- floor(grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE) * |
562 | ! |
font_lcpi(font_family, font_size, cur_gpar$lineheight)$cpi) - sum(margins[c(2, 4)]) # left, right # nolint |
563 |
} |
|
564 | ! |
if (tf_wrap && is.null(max_width)) { |
565 | ! |
max_width <- cpp |
566 |
} |
|
567 | ||
568 | ! |
if (paginate) { |
569 | ! |
tbls <- paginate_to_mpfs( |
570 | ! |
x, |
571 | ! |
page_type = page_type, |
572 | ! |
font_family = font_family, |
573 | ! |
font_size = font_size, |
574 | ! |
lineheight = cur_gpar$lineheight, |
575 | ! |
landscape = landscape, |
576 | ! |
pg_width = pg_width, |
577 | ! |
pg_height = pg_height, |
578 | ! |
margins = margins, |
579 | ! |
lpp = lpp, |
580 | ! |
cpp = cpp, |
581 | ! |
min_siblings = min_siblings, |
582 | ! |
nosplitin = character(), |
583 | ! |
colwidths = colwidths, |
584 | ! |
tf_wrap = tf_wrap, |
585 | ! |
max_width = max_width, |
586 | ! |
indent_size = indent_size, |
587 | ! |
verbose = FALSE, |
588 | ! |
rep_cols = num_rep_cols(x) |
589 |
) |
|
590 |
} else { |
|
591 | ! |
mf <- matrix_form(x, TRUE, TRUE, indent_size = indent_size) |
592 | ! |
mf_col_widths(mf) <- colwidths %||% propose_column_widths(mf) |
593 | ! |
tbls <- list(mf) |
594 |
} |
|
595 | ||
596 | ! |
gtbls <- lapply(tbls, function(txt) { |
597 | ! |
grid::textGrob( |
598 | ! |
label = toString(txt, |
599 | ! |
widths = txt$col_widths + 1, hsep = hsep, |
600 | ! |
tf_wrap = tf_wrap, max_width = max_width |
601 |
), |
|
602 | ! |
x = grid::unit(0, "npc"), y = grid::unit(1, "npc"), |
603 | ! |
just = c("left", "top") |
604 |
) |
|
605 |
}) |
|
606 | ||
607 | ! |
npages <- length(gtbls) |
608 | ! |
exceeds_width <- rep(FALSE, npages) |
609 | ! |
exceeds_height <- rep(FALSE, npages) |
610 | ||
611 | ! |
for (i in seq_along(gtbls)) { |
612 | ! |
g <- gtbls[[i]] |
613 | ||
614 | ! |
if (i > 1) { |
615 | ! |
grid::grid.newpage() |
616 | ! |
grid::pushViewport(grid::plotViewport(margins = margins, gp = gp_plot)) |
617 |
} |
|
618 | ||
619 | ! |
if (grid::convertHeight(grid::grobHeight(g), "inches", valueOnly = TRUE) > |
620 | ! |
grid::convertHeight(grid::unit(1, "npc"), "inches", valueOnly = TRUE)) { # nolint |
621 | ! |
exceeds_height[i] <- TRUE |
622 | ! |
warning("height of page ", i, " exceeds the available space") |
623 |
} |
|
624 | ! |
if (grid::convertWidth(grid::grobWidth(g), "inches", valueOnly = TRUE) > |
625 | ! |
grid::convertWidth(grid::unit(1, "npc"), "inches", valueOnly = TRUE)) { # nolint |
626 | ! |
exceeds_width[i] <- TRUE |
627 | ! |
warning("width of page ", i, " exceeds the available space") |
628 |
} |
|
629 | ||
630 | ! |
grid::grid.draw(g) |
631 |
} |
|
632 | ! |
list( |
633 | ! |
file = file, npages = npages, exceeds_width = exceeds_width, exceeds_height = exceeds_height, |
634 | ! |
lpp = lpp, cpp = cpp |
635 |
) |
|
636 |
} |
1 |
#' @title Default horizontal separator |
|
2 |
#' |
|
3 |
#' @description The default horizontal separator character which can be |
|
4 |
#' displayed in the current `charset` for use in rendering table-likes. |
|
5 |
#' |
|
6 |
#' @param hsep_char character(1). Character that will be set in the R environment |
|
7 |
#' options as default for creating the horizontal separator. It needs to be |
|
8 |
#' single character. Use `getOption("formatters_default_hsep")` to get its current |
|
9 |
#' value (`NULL` if not set). |
|
10 |
#' |
|
11 |
#' @return `unicode` 2014 (long dash for generating solid horizontal line) |
|
12 |
#' if in a locale that uses a UTF character set, otherwise an ASCII hyphen |
|
13 |
#' with a once-per-session warning. |
|
14 |
#' |
|
15 |
#' @examples |
|
16 |
#' default_hsep() |
|
17 |
#' set_default_hsep("o") |
|
18 |
#' default_hsep() |
|
19 |
#' |
|
20 |
#' @name default_horizontal_sep |
|
21 |
#' @export |
|
22 |
default_hsep <- function() { |
|
23 | 32x |
system_default_hsep <- getOption("formatters_default_hsep") |
24 | ||
25 | 32x |
if (is.null(system_default_hsep)) { |
26 | 31x |
if (any(grepl("^UTF", utils::localeToCharset()))) { |
27 | 31x |
hsep <- "\u2014" |
28 |
} else { |
|
29 | ! |
if (interactive()) { |
30 | ! |
warning( |
31 | ! |
"Detected non-UTF charset. Falling back to '-' ", |
32 | ! |
"as default header/body separator. This warning ", |
33 | ! |
"will only be shown once per R session." |
34 | ! |
) # nocov |
35 |
} # nocov |
|
36 |
hsep <- "-" # nocov |
|
37 |
} |
|
38 |
} else { |
|
39 | 1x |
hsep <- system_default_hsep |
40 |
} |
|
41 | 32x |
hsep |
42 |
} |
|
43 | ||
44 |
#' @name default_horizontal_sep |
|
45 |
#' @export |
|
46 |
set_default_hsep <- function(hsep_char) { |
|
47 | 3x |
checkmate::assert_character(hsep_char, n.chars = 1, len = 1, null.ok = TRUE) |
48 | 2x |
options("formatters_default_hsep" = hsep_char) |
49 |
} |
|
50 | ||
51 |
.calc_cell_widths <- function(mat, colwidths, col_gap) { |
|
52 | 152x |
spans <- mat$spans |
53 | 152x |
keep_mat <- mat$display |
54 | 152x |
body <- mat$strings |
55 | ||
56 | 152x |
nr <- nrow(body) |
57 | ||
58 | 152x |
cell_widths_mat <- matrix(rep(colwidths, nr), nrow = nr, byrow = TRUE) |
59 | 152x |
nc <- ncol(cell_widths_mat) |
60 | ||
61 | 152x |
for (i in seq_len(nrow(body))) { |
62 | 2848x |
if (any(!keep_mat[i, ])) { # any spans? |
63 | 6x |
j <- 1 |
64 | 6x |
while (j <= nc) { |
65 | 10x |
nj <- spans[i, j] |
66 | 10x |
j <- if (nj > 1) { |
67 | 6x |
js <- seq(j, j + nj - 1) |
68 | 6x |
cell_widths_mat[i, js] <- sum(cell_widths_mat[i, js]) + col_gap * (nj - 1) |
69 | 6x |
j + nj |
70 |
} else { |
|
71 | 4x |
j + 1 |
72 |
} |
|
73 |
} |
|
74 |
} |
|
75 |
} |
|
76 | 152x |
cell_widths_mat |
77 |
} |
|
78 | ||
79 | ||
80 |
# Main function that does the wrapping |
|
81 |
do_cell_fnotes_wrap <- function(mat, widths, max_width, tf_wrap) { |
|
82 | 90x |
col_gap <- mf_colgap(mat) |
83 | 90x |
ncchar <- sum(widths) + (length(widths) - 1) * col_gap |
84 | 90x |
inset <- table_inset(mat) |
85 | ||
86 |
## Text wrapping checks |
|
87 | 90x |
if (tf_wrap) { |
88 | 21x |
if (is.null(max_width)) { |
89 | 4x |
max_width <- getOption("width", 80L) |
90 | 17x |
} else if (is.character(max_width) && identical(max_width, "auto")) { |
91 | ! |
max_width <- ncchar + inset |
92 |
} |
|
93 | 21x |
assert_number(max_width, lower = 0) |
94 |
} |
|
95 | ||
96 |
## Check for having the right number of widths |
|
97 | 90x |
stopifnot(length(widths) == ncol(mat$strings)) |
98 | ||
99 |
## format the to ASCII |
|
100 | 90x |
cell_widths_mat <- .calc_cell_widths(mat, widths, col_gap) |
101 | ||
102 |
# Check that indentation is correct (it works only for body) |
|
103 | 90x |
.check_indentation(mat, row_col_width = cell_widths_mat[, 1, drop = TRUE]) |
104 | 88x |
mod_ind_list <- .modify_indentation(mat, cell_widths_mat, do_what = "remove") |
105 | 88x |
mfs <- mod_ind_list[["mfs"]] |
106 | 88x |
cell_widths_mat <- mod_ind_list[["cell_widths_mat"]] |
107 | ||
108 |
# Main wrapper |
|
109 | 88x |
mf_strings(mat) <- matrix( |
110 | 88x |
unlist(mapply(wrap_string, |
111 | 88x |
str = mfs, |
112 | 88x |
width = cell_widths_mat, |
113 | 88x |
collapse = "\n" |
114 |
)), |
|
115 | 88x |
ncol = ncol(mfs) |
116 |
) |
|
117 | ||
118 |
## XXXXX this is wrong and will break for listings cause we don't know when |
|
119 |
## we need has_topleft to be FALSE!!!!!!!!!! |
|
120 | 88x |
mat <- mform_handle_newlines(mat) |
121 | ||
122 |
## this updates extents in rinfo AND nlines in ref_fnotes_df |
|
123 | 88x |
mat <- update_mf_nlines(mat, max_width = max_width) |
124 | ||
125 |
# Re-indenting |
|
126 | 88x |
mf_strings(mat) <- .modify_indentation(mat, cell_widths_mat, do_what = "add")[["mfs"]] |
127 | 88x |
.check_indentation(mat) # all went well |
128 | ||
129 | 88x |
mat |
130 |
} |
|
131 | ||
132 |
# Helper function to see if body indentation matches (minimum) |
|
133 |
# It sees if there is AT LEAST the indentation contained in rinfo |
|
134 |
.check_indentation <- function(mat, row_col_width = NULL) { |
|
135 |
# mf_nrheader(mat) # not useful |
|
136 | 179x |
mf_nlh <- mf_nlheader(mat) |
137 | 179x |
mf_lgrp <- mf_lgrouping(mat) |
138 | 179x |
mf_str <- mf_strings(mat) |
139 |
# we base everything on the groupings -> unique indentation identifiers |
|
140 | 179x |
if (!is.null(mf_rinfo(mat))) { # this happens in rare cases with rtables::rtable() |
141 | 179x |
mf_ind <- c(rep(0, mf_nrheader(mat)), mf_rinfo(mat)$indent) # XXX to fix with topleft |
142 |
} else { |
|
143 | ! |
mf_ind <- rep(0, mf_nrheader(mat)) |
144 |
} |
|
145 | 179x |
ind_std <- paste0(rep(" ", mat$indent_size), collapse = "") |
146 | ||
147 |
# Expected indent (-x negative numbers should not appear at this stage) |
|
148 | 179x |
stopifnot(all(mf_ind >= 0)) |
149 | 179x |
real_indent <- vapply(mf_ind, function(ii) { |
150 | 3398x |
paste0(rep(ind_std, ii), collapse = "") |
151 | 179x |
}, character(1)) |
152 | ||
153 | 179x |
if (!is.null(row_col_width) && any(row_col_width > 0) && !is.null(mf_rinfo(mat))) { # third is rare case |
154 |
# Self consistency test for row_col_width (same groups should have same width) |
|
155 |
# This should not be necessary (nocov) |
|
156 | 90x |
consistency_check <- vapply(unique(mf_lgrp), function(ii) { |
157 | 1714x |
width_per_grp <- row_col_width[which(mf_lgrp == ii)] |
158 | 1714x |
all(width_per_grp == width_per_grp[1]) |
159 | 90x |
}, logical(1)) |
160 | 90x |
stopifnot(all(consistency_check)) |
161 | ||
162 |
# Taking only one width for each indentation grouping |
|
163 | 90x |
unique_row_col_width <- row_col_width[match(unique(mf_lgrp), mf_lgrp)] |
164 | ||
165 |
# Exception for check: case with summarize_row_groups and (hence) content_rows |
|
166 | 90x |
nchar_real_indent <- nchar(real_indent) |
167 | 90x |
body_rows <- seq(mf_nrheader(mat) + 1, length(nchar_real_indent)) |
168 | 90x |
nchar_real_indent[body_rows] <- nchar_real_indent[body_rows] + |
169 | 90x |
as.numeric(mf_rinfo(mat)$node_class != "ContentRow") |
170 |
# xxx I think all of the above is a bit buggy honestly (check ContentRows!!!) |
|
171 | ||
172 | 90x |
if (any(nchar_real_indent > unique_row_col_width)) { |
173 | 1x |
stop( |
174 | 1x |
"Inserted width for row label column is not wide enough. ", |
175 | 1x |
"We found the following rows that do not have at least indentation * ind_size + 1", |
176 | 1x |
" characters to allow text to be shown after indentation: ", |
177 | 1x |
paste0(which(nchar(real_indent) + 1 > unique_row_col_width), collapse = " ") |
178 |
) |
|
179 |
} |
|
180 |
} |
|
181 | ||
182 |
# Main detector |
|
183 | 178x |
correct_indentation <- vapply(seq_along(mf_lgrp), function(xx) { |
184 | 3775x |
grouping <- mf_lgrp[xx] |
185 | 3775x |
if (nzchar(real_indent[grouping])) { |
186 | 27x |
has_correct_indentation <- stringi::stri_detect( |
187 | 27x |
mf_str[xx, 1], |
188 | 27x |
regex = paste0("^", real_indent[grouping]) |
189 |
) |
|
190 | 27x |
return(has_correct_indentation || !nzchar(mf_str[xx, 1])) # "" is still an ok indentation |
191 |
} |
|
192 |
# Cases where no indent are true by definition |
|
193 | 3748x |
return(TRUE) |
194 | 178x |
}, logical(1)) |
195 | ||
196 | 178x |
if (any(!correct_indentation)) { |
197 | 1x |
stop( |
198 | 1x |
"We discovered indentation mismatches between the matrix_form and the indentation", |
199 | 1x |
" predefined in mf_rinfo. This should not happen. Contact the maintainer." |
200 | 1x |
) # nocov |
201 |
} |
|
202 |
} |
|
203 |
# Helper function that takes out or adds the proper indentation |
|
204 |
.modify_indentation <- function(mat, cell_widths_mat, do_what = c("remove", "add")) { |
|
205 |
# Extract info |
|
206 | 176x |
mfs <- mf_strings(mat) # we work on mfs |
207 | 176x |
mf_nlh <- mf_nlheader(mat) |
208 | 176x |
mf_l <- mf_lgrouping(mat) |
209 | 176x |
if (!is.null(mf_rinfo(mat))) { # this happens in rare cases with rtables::rtable() |
210 | 176x |
mf_ind <- c(rep(0, mf_nrheader(mat)), mf_rinfo(mat)$indent) # XXX to fix with topleft |
211 |
} else { |
|
212 | ! |
mf_ind <- rep(0, mf_nrheader(mat)) |
213 |
} |
|
214 | 176x |
stopifnot(length(mf_ind) == length(unique(mf_l))) # Check for indentation and grouping |
215 | 176x |
ind_std <- paste0(rep(" ", mat$indent_size), collapse = "") # standard size of indent 1 |
216 | ||
217 |
# Create real indentation |
|
218 | 176x |
real_indent <- sapply(mf_ind, function(ii) paste0(rep(ind_std, ii), collapse = "")) |
219 | ||
220 |
# Use groupings to add or remove proper indentation |
|
221 | 176x |
lbl_row <- mfs[, 1, drop = TRUE] |
222 | 176x |
for (ii in seq_along(lbl_row)) { |
223 | 3766x |
grp <- mf_l[ii] |
224 | 3766x |
if (nzchar(real_indent[grp])) { |
225 |
# Update also the widths!! |
|
226 | 23x |
if (do_what[1] == "remove") { |
227 | 6x |
cell_widths_mat[ii, 1] <- cell_widths_mat[ii, 1] - nchar(real_indent[grp]) |
228 | 6x |
mfs[ii, 1] <- stringi::stri_replace(lbl_row[ii], "", regex = paste0("^", real_indent[grp])) |
229 | 17x |
} else if (do_what[1] == "add") { |
230 | 17x |
mfs[ii, 1] <- paste0(real_indent[grp], lbl_row[ii]) |
231 |
} else { |
|
232 |
stop("do_what needs to be remove or add.") # nocov |
|
233 |
} |
|
234 |
} else { |
|
235 | 3743x |
mfs[ii, 1] <- lbl_row[ii] |
236 |
} |
|
237 |
} |
|
238 |
# Final return |
|
239 | 176x |
return(list("mfs" = mfs, "cell_widths_mat" = cell_widths_mat)) |
240 |
} |
|
241 | ||
242 | ||
243 |
## take a character vector and return whether the value is |
|
244 |
## a string version of a number or not |
|
245 |
is_number_str <- function(vec) { |
|
246 | ! |
is.na(as.numeric(vec)) |
247 |
} |
|
248 | ||
249 |
is_dec_align <- function(vec) { |
|
250 |
# "c" is not an alignment method we define in `formatters`, |
|
251 |
# but the reverse dependency package `tables` will need |
|
252 | 391x |
sdiff <- setdiff(vec, c(list_valid_aligns(), "c")) |
253 | 391x |
if (length(sdiff) > 0) { |
254 | ! |
stop("Invalid text-alignment(s): ", paste(sdiff, collapse = ", ")) |
255 |
} |
|
256 | 391x |
grepl("dec", vec) |
257 |
} |
|
258 | ||
259 | 246x |
any_dec_align <- function(vec) any(is_dec_align(vec)) |
260 | ||
261 |
#' Decimal Alignment |
|
262 |
#' |
|
263 |
#' @description Aligning decimal values of string matrix. Allowed alignments are: `dec_left`, |
|
264 |
#' `dec_right` and `decimal`. |
|
265 |
#' |
|
266 |
#' @param string_mat character matrix. String matrix component of matrix print form object. |
|
267 |
#' @param align_mat character matrix. Aligns matrix component of matrix print form object. |
|
268 |
#' Should contain either `dec_left`, `dec_right` or `decimal` for values to be decimal aligned. |
|
269 |
#' |
|
270 |
#' @details Decimal alignment left and right (`dec_left` and `dec_right`) are different to |
|
271 |
#' center decimal alignment `decimal` only in the case some padding is present. This may |
|
272 |
#' happen if column widths are wider by setting parameters `widths` in `toString` or |
|
273 |
#' `colwidths` in `paginate_*` accordingly. It will be also the case (more common) of |
|
274 |
#' wider column names. Decimal alignment is not supported along with cell wrapping. |
|
275 |
#' |
|
276 |
#' @examples |
|
277 |
#' dfmf <- basic_matrix_form(mtcars[1:5, ]) |
|
278 |
#' aligns <- mf_aligns(dfmf) |
|
279 |
#' aligns[, -c(1)] <- "dec_left" |
|
280 |
#' decimal_align(mf_strings(dfmf), aligns) |
|
281 |
#' |
|
282 |
#' @return Processed string matrix of matrix print form with decimal aligned values. |
|
283 |
#' |
|
284 |
#' @seealso [toString] and [MatrixPrintForm] |
|
285 |
#' |
|
286 |
#' @export |
|
287 |
decimal_align <- function(string_mat, align_mat) { |
|
288 |
## Evaluate if any values are to be decimal aligned |
|
289 | 45x |
if (!any_dec_align(align_mat)) { |
290 | ! |
return(string_mat) |
291 |
} |
|
292 | 45x |
for (i in seq(1, ncol(string_mat))) { |
293 |
## Take a column and its decimal alignments |
|
294 | 145x |
col_i <- as.character(string_mat[, i]) |
295 | 145x |
align_col_i <- is_dec_align(align_mat[, i]) |
296 | ||
297 |
## !( A || B) -> !A && !B DeMorgan's Law |
|
298 |
## Are there any values to be decimal aligned? safe if |
|
299 | 145x |
if (any(align_col_i) && any(!grepl("^[0-9]\\.", col_i))) { |
300 |
## Extract values not to be aligned (NAs, non-numbers, |
|
301 |
## doesn't say "decimal" in alignment matrix) |
|
302 |
## XXX FIXME because this happens after formatting, we can't tell the difference between |
|
303 |
## non-number strings which come from na_str+ NA value and strings which just aren't numbers. |
|
304 |
## this is a problem that should eventually be fixed. |
|
305 | 82x |
nas <- vapply(col_i, is.na, FUN.VALUE = logical(1)) |
306 | 82x |
nonnum <- !grepl("[0-9]", col_i) |
307 |
## No grepl("[a-zA-Z]", col_i) because this excludes N=xx, e.g. |
|
308 | 82x |
nonalign <- nas | nonnum | !align_col_i |
309 | 82x |
col_ia <- col_i[!nonalign] |
310 | ||
311 |
## Do decimal alignment |
|
312 | 82x |
if (length(col_ia) > 0) { |
313 |
# Special case: scientific notation |
|
314 | 82x |
has_sc_not <- grepl("\\d+[e|E][\\+|\\-]\\d+", col_ia) |
315 | 82x |
if (any(has_sc_not)) { |
316 | 1x |
stop( |
317 | 1x |
"Found values using scientific notation between the ones that", |
318 | 1x |
" needs to be decimal aligned (aligns is decimal, dec_left or dec_right).", |
319 | 1x |
" Please consider using format functions to get a complete decimal ", |
320 | 1x |
"(e.g. formatC)." |
321 |
) |
|
322 |
} |
|
323 | ||
324 |
## Count the number of numbers in the string |
|
325 | 81x |
matches <- gregexpr("\\d+\\.\\d+|\\d+", col_ia) |
326 | 81x |
more_than_one <- vapply(matches, function(x) { |
327 | 685x |
sum(attr(x, "match.length") > 0) > 1 |
328 | 81x |
}, logical(1)) |
329 |
## Throw error in case any have more than 1 numbers |
|
330 | 81x |
if (any(more_than_one)) { |
331 | 2x |
stop( |
332 | 2x |
"Decimal alignment is not supported for multiple values. ", |
333 | 2x |
"Found the following string with multiple numbers ", |
334 | 2x |
"(first 3 selected from column ", col_i[1], "): '", |
335 | 2x |
paste0(col_ia[more_than_one][seq(1, 3)], collapse = "', '"), |
336 |
"'" |
|
337 |
) |
|
338 |
} |
|
339 |
## General split (only one match -> the first) |
|
340 | 79x |
main_regexp <- regexpr("\\d+", col_ia) |
341 | 79x |
left <- regmatches(col_ia, main_regexp, invert = FALSE) |
342 | 79x |
right <- regmatches(col_ia, main_regexp, invert = TRUE) |
343 | 79x |
right <- sapply(right, "[[", 2) |
344 | 79x |
something_left <- sapply(strsplit(col_ia, "\\d+"), "[[", 1) |
345 | 79x |
left <- paste0(something_left, left) |
346 | 79x |
if (!checkmate::test_set_equal(paste0(left, right), col_ia)) { |
347 | ! |
stop( |
348 | ! |
"Split string list lost some piece along the way. This ", |
349 | ! |
"should not have happened. Please contact the maintainer." |
350 |
) |
|
351 |
} # nocov |
|
352 | 79x |
separator <- sapply(right, function(x) { |
353 | 639x |
if (nzchar(x)) { |
354 | 346x |
substr(x, 1, 1) |
355 |
} else { |
|
356 | 293x |
c(" ") |
357 |
} |
|
358 | 79x |
}, USE.NAMES = FALSE) |
359 | 79x |
right <- sapply(right, function(x) { |
360 | 639x |
if (nchar(x) > 1) { |
361 | 314x |
substr(x, 2, nchar(x)) |
362 |
} else { |
|
363 | 325x |
c("") |
364 |
} |
|
365 | 79x |
}, USE.NAMES = FALSE) |
366 |
## figure out whether we need space separators (at least one had a "." or not) |
|
367 | 79x |
if (!any(grepl("[^[:space:]]", separator))) { |
368 | 26x |
separator <- gsub("[[:space:]]*", "", separator) |
369 |
} |
|
370 |
## modify the piece with spaces |
|
371 | 79x |
left_mod <- paste0(spaces(max(nchar(left), na.rm = TRUE) - nchar(left)), left) |
372 | 79x |
right_mod <- paste0(right, spaces(max(nchar(right), na.rm = TRUE) - nchar(right))) |
373 |
# Put everything together |
|
374 | 79x |
aligned <- paste(left_mod, separator, right_mod, sep = "") |
375 | 79x |
string_mat[!nonalign, i] <- aligned |
376 |
} |
|
377 |
} |
|
378 |
} |
|
379 | 42x |
string_mat |
380 |
} |
|
381 | ||
382 |
# toString --------------------------------------------------------------------- |
|
383 |
# main printing code for MatrixPrintForm |
|
384 |
# |
|
385 | ||
386 |
#' @title Main printing system: `toString` |
|
387 |
#' |
|
388 |
#' @description |
|
389 |
#' All objects that are printed to console pass by `toString`. This function allows |
|
390 |
#' fundamental formatting specifications for the final output, like column widths and |
|
391 |
#' relative wrapping (`width`), title and footer wrapping (`tf_wrap = TRUE` and |
|
392 |
#' `max_width`), or horizontal separator character (e.g. `hsep = "+"`). |
|
393 |
#' |
|
394 |
#' @inheritParams MatrixPrintForm |
|
395 |
#' @param widths numeric (or `NULL`). (proposed) widths for the columns |
|
396 |
#' of \code{x}. The expected length of this numeric vector can be |
|
397 |
#' retrieved with `ncol() + 1` as the column of row names must |
|
398 |
#' also be considered. |
|
399 |
#' @param hsep character(1). Characters to repeat to create |
|
400 |
#' header/body separator line. If `NULL`, the object value will be |
|
401 |
#' used. If `" "`, an empty separator will be printed. Check [default_hsep()] |
|
402 |
#' for more information. |
|
403 |
#' @param tf_wrap logical(1). Should the texts for title, subtitle, |
|
404 |
#' and footnotes be wrapped? |
|
405 |
#' @param max_width integer(1), character(1) or `NULL`. Width that title |
|
406 |
#' and footer (including footnotes) materials should be |
|
407 |
#' word-wrapped to. If `NULL`, it is set to the current print width |
|
408 |
#' of the session (`getOption("width")`). If set to `"auto"`, |
|
409 |
#' the width of the table (plus any table inset) is used. Ignored |
|
410 |
#' completely if `tf_wrap` is `FALSE`. |
|
411 |
#' |
|
412 |
#' @details |
|
413 |
#' |
|
414 |
#' Manual insertion of newlines is not supported when `tf_wrap` is on |
|
415 |
#' and will result in a warning and undefined wrapping behavior. Passing |
|
416 |
#' vectors of already split strings remains supported, however in this |
|
417 |
#' case each string is word-wrapped separately with the behavior |
|
418 |
#' described above. |
|
419 |
#' |
|
420 |
#' @seealso [wrap_string()] |
|
421 |
#' |
|
422 |
#' @examples |
|
423 |
#' mform <- basic_matrix_form(mtcars) |
|
424 |
#' cat(toString(mform)) |
|
425 |
#' |
|
426 |
#' @return A character string containing the ASCII rendering |
|
427 |
#' of the table-like object represented by `x` |
|
428 |
#' |
|
429 |
#' @rdname tostring |
|
430 |
#' @exportMethod toString |
|
431 |
setMethod("toString", "MatrixPrintForm", function(x, |
|
432 |
widths = NULL, |
|
433 |
tf_wrap = FALSE, |
|
434 |
max_width = NULL, |
|
435 |
col_gap = mf_colgap(x), |
|
436 |
hsep = NULL) { |
|
437 | 68x |
checkmate::assert_flag(tf_wrap) |
438 | ||
439 | 68x |
mat <- matrix_form(x, indent_rownames = TRUE) |
440 | ||
441 |
# Check for \n in mat strings -> if there are any, matrix_form did not work |
|
442 | 68x |
if (any(grepl("\n", mf_strings(mat)))) { |
443 | ! |
stop( |
444 | ! |
"Found newline characters (\\n) in string matrix produced by matrix_form. ", |
445 | ! |
"This is not supported and implies missbehavior on the first parsing (in matrix_form). ", |
446 | ! |
"Please contact the maintainer or file an issue." |
447 | ! |
) # nocov |
448 |
} |
|
449 | ||
450 |
# Check that expansion worked for header -> should not happen |
|
451 | 68x |
if (!is.null(mf_rinfo(mat)) && # rare case of rtables::rtable() |
452 | 68x |
(length(mf_lgrouping(mat)) != nrow(mf_strings(mat)) || # non-unique grouping test # nolint |
453 | 68x |
mf_nrheader(mat) + nrow(mf_rinfo(mat)) != length(unique(mf_lgrouping(mat))))) { # nolint |
454 | ! |
stop( |
455 | ! |
"The sum of the expected nrows header and nrows of content table does ", |
456 | ! |
"not match the number of rows in the string matrix. To our knowledge, ", |
457 | ! |
"this is usually of a problem in solving newline characters (\\n) in the header. ", |
458 | ! |
"Please contact the maintaner or file an issue." |
459 | ! |
) # nocov |
460 |
} |
|
461 | ||
462 | 68x |
inset <- table_inset(mat) |
463 | ||
464 |
# if cells are decimal aligned, run propose column widths |
|
465 |
# if the provided widths is less than proposed width, return an error |
|
466 | 68x |
if (any_dec_align(mf_aligns(mat))) { |
467 | 22x |
aligned <- propose_column_widths(x) |
468 | ||
469 |
# catch any columns that require widths more than what is provided |
|
470 | 20x |
if (!is.null(widths)) { |
471 | 9x |
how_wide <- sapply(seq_along(widths), function(i) c(widths[i] - aligned[i])) |
472 | 9x |
too_wide <- how_wide < 0 |
473 | 9x |
if (any(too_wide)) { |
474 | 2x |
desc_width <- paste(paste( |
475 | 2x |
names(which(too_wide)), |
476 | 2x |
paste0("(", how_wide[too_wide], ")") |
477 | 2x |
), collapse = ", ") |
478 | 2x |
stop( |
479 | 2x |
"Inserted width(s) for column(s) ", desc_width, |
480 | 2x |
" is(are) not wide enough for the desired alignment." |
481 |
) |
|
482 |
} |
|
483 |
} |
|
484 |
} |
|
485 | ||
486 |
# Column widths are fixed here |
|
487 | 64x |
if (is.null(widths)) { |
488 |
# if mf does not have widths -> propose them |
|
489 | 50x |
widths <- mf_col_widths(x) %||% propose_column_widths(x) |
490 |
} else { |
|
491 | 14x |
mf_col_widths(x) <- widths |
492 |
} |
|
493 | ||
494 |
# Total number of characters for the table |
|
495 | 64x |
ncchar <- sum(widths) + (length(widths) - 1) * col_gap |
496 | ||
497 |
## Text wrapping checks (widths) |
|
498 | 64x |
if (tf_wrap) { |
499 | 17x |
if (is.null(max_width)) { |
500 | 12x |
max_width <- getOption("width", 80L) |
501 | 5x |
} else if (is.character(max_width) && identical(max_width, "auto")) { |
502 | 2x |
max_width <- ncchar + inset |
503 |
} |
|
504 | 17x |
assert_number(max_width, lower = 0) |
505 |
} |
|
506 | ||
507 |
# Main wrapper function for table core |
|
508 | 64x |
mat <- do_cell_fnotes_wrap(mat, widths, max_width = max_width, tf_wrap = tf_wrap) |
509 | ||
510 | 62x |
body <- mf_strings(mat) |
511 | 62x |
aligns <- mf_aligns(mat) |
512 | 62x |
keep_mat <- mf_display(mat) |
513 |
## spans <- mat$spans |
|
514 | 62x |
mf_ri <- mf_rinfo(mat) |
515 | 62x |
ref_fnotes <- mf_rfnotes(mat) |
516 | 62x |
nl_header <- mf_nlheader(mat) |
517 | ||
518 | 62x |
cell_widths_mat <- .calc_cell_widths(mat, widths, col_gap) |
519 | ||
520 |
# decimal alignment |
|
521 | 62x |
if (any_dec_align(aligns)) { |
522 | 18x |
body <- decimal_align(body, aligns) |
523 |
} |
|
524 | ||
525 |
# Content is a matrix of cells with the right amount of spaces |
|
526 | 62x |
content <- matrix(mapply(padstr, body, cell_widths_mat, aligns), ncol = ncol(body)) |
527 | 62x |
content[!keep_mat] <- NA |
528 | ||
529 |
# Define gap string and divisor string |
|
530 | 62x |
gap_str <- strrep(" ", col_gap) |
531 | 62x |
if (is.null(hsep)) { |
532 | 43x |
hsep <- horizontal_sep(mat) |
533 |
} |
|
534 | 62x |
div <- substr(strrep(hsep, ncchar), 1, ncchar) |
535 | 62x |
hsd <- header_section_div(mat) |
536 | 62x |
if (!is.na(hsd)) { |
537 | ! |
hsd <- substr(strrep(hsd, ncchar), 1, ncchar) |
538 |
} else { |
|
539 | 62x |
hsd <- NULL # no divisor |
540 |
} |
|
541 | ||
542 |
# text head (paste w/o NA content header and gap string) |
|
543 | 62x |
txt_head <- apply(head(content, nl_header), 1, .paste_no_na, collapse = gap_str) |
544 | ||
545 |
# txt body |
|
546 | 62x |
sec_seps_df <- mf_ri[, c("abs_rownumber", "trailing_sep"), drop = FALSE] |
547 | 62x |
if (!is.null(sec_seps_df) && any(!is.na(sec_seps_df$trailing_sep))) { |
548 | 2x |
bdy_cont <- tail(content, -nl_header) |
549 |
## unfortunately we count "header rows" wrt line grouping so it |
|
550 |
## doesn't match the real (i.e. body) rows as is |
|
551 | 2x |
row_grouping <- tail(mf_lgrouping(mat), - nl_header) - mf_nrheader(mat) |
552 | 2x |
nrbody <- NROW(bdy_cont) |
553 | 2x |
stopifnot(length(row_grouping) == nrbody) |
554 |
## all rows with non-NA section divs and the final row (regardless of NA status) |
|
555 |
## fixes #77 |
|
556 | 2x |
sec_seps_df <- sec_seps_df[unique(c( |
557 | 2x |
which(!is.na(sec_seps_df$trailing_sep)), |
558 | 2x |
NROW(sec_seps_df) |
559 |
)), ] |
|
560 | 2x |
txt_body <- character() |
561 | 2x |
sec_strt <- 1 |
562 | 2x |
section_rws <- sec_seps_df$abs_rownumber |
563 | 2x |
for (i in seq_len(NROW(section_rws))) { |
564 | 6x |
cur_rownum <- section_rws[i] |
565 | 6x |
sec_end <- max(which(row_grouping == cur_rownum)) |
566 | 6x |
txt_body <- c( |
567 | 6x |
txt_body, |
568 | 6x |
apply(bdy_cont[seq(sec_strt, sec_end), , drop = FALSE], |
569 | 6x |
1, |
570 | 6x |
.paste_no_na, |
571 | 6x |
collapse = gap_str |
572 |
), |
|
573 |
## don't print section dividers if they would be the last thing before the |
|
574 |
## footer divider |
|
575 |
## this also ensures an extraneous sec div won't be printed if we have non-sec-div |
|
576 |
## rows after the last sec div row (#77) |
|
577 | 6x |
if (sec_end < nrbody) { |
578 | 4x |
substr( |
579 | 4x |
strrep(sec_seps_df$trailing_sep[i], ncchar), 1, |
580 | 4x |
ncchar - inset |
581 |
) |
|
582 |
} |
|
583 |
) |
|
584 | 6x |
sec_strt <- sec_end + 1 |
585 |
} |
|
586 |
} else { |
|
587 |
# This is the usual default pasting |
|
588 | 60x |
txt_body <- apply(tail(content, -nl_header), 1, .paste_no_na, collapse = gap_str) |
589 |
} |
|
590 | ||
591 |
# retrieving titles and footers |
|
592 | 62x |
allts <- all_titles(mat) |
593 | ||
594 | 62x |
ref_fnotes <- reorder_ref_fnotes(ref_fnotes) |
595 |
# Fix for ref_fnotes with \n characters XXX this does not count in the pagination |
|
596 | 62x |
if (any(grepl("\n", ref_fnotes))) { |
597 | 2x |
ref_fnotes <- unlist(strsplit(ref_fnotes, "\n", fixed = TRUE)) |
598 |
} |
|
599 | ||
600 | 62x |
allfoots <- list( |
601 | 62x |
"main_footer" = main_footer(mat), |
602 | 62x |
"prov_footer" = prov_footer(mat), |
603 | 62x |
"ref_footnotes" = ref_fnotes |
604 |
) |
|
605 | 62x |
allfoots <- allfoots[!sapply(allfoots, is.null)] |
606 | ||
607 |
## Wrapping titles if they go beyond the horizontally allowed space |
|
608 | 62x |
if (tf_wrap) { |
609 | 17x |
new_line_warning(allts) |
610 | 17x |
allts <- wrap_txt(allts, max_width) |
611 |
} |
|
612 | 61x |
titles_txt <- if (any(nzchar(allts))) c(allts, "", .do_inset(div, inset)) else NULL |
613 | ||
614 |
# Wrapping footers if they go beyond the horizontally allowed space |
|
615 | 61x |
if (tf_wrap) { |
616 | 16x |
new_line_warning(allfoots) |
617 | 16x |
allfoots$main_footer <- wrap_txt(allfoots$main_footer, max_width - inset) |
618 | 16x |
allfoots$ref_footnotes <- wrap_txt(allfoots$ref_footnotes, max_width - inset) |
619 |
## no - inset here because the prov_footer is not inset |
|
620 | 16x |
allfoots$prov_footer <- wrap_txt(allfoots$prov_footer, max_width) |
621 |
} |
|
622 | ||
623 |
# Final return |
|
624 | 61x |
paste0( |
625 | 61x |
paste(c( |
626 | 61x |
titles_txt, # .do_inset(div, inset) happens if there are any titles |
627 | 61x |
.do_inset(txt_head, inset), |
628 | 61x |
.do_inset(div, inset), |
629 | 61x |
.do_inset(hsd, inset), # header_section_div if present |
630 | 61x |
.do_inset(txt_body, inset), |
631 | 61x |
.footer_inset_helper(allfoots, div, inset) |
632 | 61x |
), collapse = "\n"), |
633 | 61x |
"\n" |
634 |
) |
|
635 |
}) |
|
636 | ||
637 |
.do_inset <- function(x, inset) { |
|
638 | 391x |
if (inset == 0 || !any(nzchar(x))) { |
639 | 372x |
return(x) |
640 |
} |
|
641 | 19x |
padding <- strrep(" ", inset) |
642 | 19x |
if (is.character(x)) { |
643 | 19x |
x <- paste0(padding, x) |
644 | ! |
} else if (is(x, "matrix")) { |
645 | ! |
x[, 1] <- .do_inset(x[, 1, drop = TRUE], inset) |
646 |
} |
|
647 | 19x |
x |
648 |
} |
|
649 | ||
650 | ||
651 |
.inset_div <- function(txt, div, inset) { |
|
652 | 38x |
c(.do_inset(div, inset), "", txt) |
653 |
} |
|
654 | ||
655 |
.footer_inset_helper <- function(footers_v, div, inset) { |
|
656 | 61x |
div_done <- FALSE # nolint |
657 | 61x |
fter <- footers_v$main_footer |
658 | 61x |
prvf <- footers_v$prov_footer |
659 | 61x |
rfn <- footers_v$ref_footnotes |
660 | 61x |
footer_txt <- .do_inset(rfn, inset) |
661 | 61x |
if (any(nzchar(footer_txt))) { |
662 | 13x |
footer_txt <- .inset_div(footer_txt, div, inset) |
663 |
} |
|
664 | 61x |
if (any(vapply( |
665 | 61x |
footers_v, function(x) any(nzchar(x)), |
666 | 61x |
TRUE |
667 |
))) { |
|
668 | 25x |
if (any(nzchar(prvf))) { |
669 | 23x |
provtxt <- c( |
670 | 23x |
if (any(nzchar(fter))) "", |
671 | 23x |
prvf |
672 |
) |
|
673 |
} else { |
|
674 | 2x |
provtxt <- character() |
675 |
} |
|
676 | 25x |
footer_txt <- c( |
677 | 25x |
footer_txt, |
678 | 25x |
.inset_div( |
679 | 25x |
c( |
680 | 25x |
.do_inset(fter, inset), |
681 | 25x |
provtxt |
682 |
), |
|
683 | 25x |
div, |
684 | 25x |
inset |
685 |
) |
|
686 |
) |
|
687 |
} |
|
688 | 61x |
footer_txt |
689 |
} |
|
690 | ||
691 |
reorder_ref_fnotes <- function(fns) { |
|
692 | 65x |
ind <- gsub("\\{(.*)\\}.*", "\\1", fns) |
693 | 65x |
ind_num <- suppressWarnings(as.numeric(ind)) |
694 | 65x |
is_num <- !is.na(ind_num) |
695 | 65x |
is_asis <- ind == fns |
696 | ||
697 | 65x |
if (all(is_num)) { |
698 | 49x |
ord_num <- order(ind_num) |
699 | 49x |
ord_char <- NULL |
700 | 49x |
ord_other <- NULL |
701 |
} else { |
|
702 | 16x |
ord_num <- order(ind_num[is_num]) |
703 | 16x |
ord_char <- order(ind[!is_num & !is_asis]) |
704 | 16x |
ord_other <- order(ind[is_asis]) |
705 |
} |
|
706 | 65x |
c(fns[is_num][ord_num], fns[!is_num & !is_asis][ord_char], ind[is_asis][ord_other]) |
707 |
} |
|
708 | ||
709 |
new_line_warning <- function(str_v) { |
|
710 | 33x |
if (any(unlist(sapply(str_v, grepl, pattern = "\n")))) { |
711 | 1x |
msg <- c( |
712 | 1x |
"Detected manual newlines when automatic title/footer word-wrapping is on.", |
713 | 1x |
"This is unsupported and will result in undefined behavior. Please either ", |
714 | 1x |
"utilize automatic word-wrapping with newline characters inserted, or ", |
715 | 1x |
"turn off automatic wrapping and wordwrap all contents manually by inserting ", |
716 | 1x |
"newlines." |
717 |
) |
|
718 | 1x |
warning(paste0(msg, collapse = "")) |
719 |
} |
|
720 |
} |
|
721 | ||
722 | ||
723 |
#' Wrap a string to within a precise width |
|
724 |
#' |
|
725 |
#' @description |
|
726 |
#' Core wrapping functionality that preserve white spaces. Only `"\n"` is not supported |
|
727 |
#' by core functionality [stringi::stri_wrap()]. This is usually solved before hand by |
|
728 |
#' [matrix_form()]. If the width is smaller than any large word, these will be truncated |
|
729 |
#' after `width` characters. If the split leaves trailing groups of empty spaces, |
|
730 |
#' they will be dropped. |
|
731 |
#' |
|
732 |
#' @param str character. String to be wrapped. If it is a character vector or |
|
733 |
#' a list, it will be looped as a list and returned with `unlist(use.names = FALSE)`. |
|
734 |
#' @param width numeric(1). Width, in characters, that the |
|
735 |
#' text should be wrapped at. |
|
736 |
#' @param collapse character(1) or `NULL`. If the words that have been split should |
|
737 |
#' be pasted together with the collapse character. This is usually done internally |
|
738 |
#' with `"\n"` to have the wrapping updated along with other internal values. |
|
739 |
#' |
|
740 |
#' @details Word wrapping happens as with [stringi::stri_wrap()] |
|
741 |
#' with the following exception: individual words which are longer |
|
742 |
#' than `max_width` are broken up in a way that fits with the rest of the |
|
743 |
#' word wrapping. |
|
744 |
#' |
|
745 |
#' @return A string if `str` is one element and if `collapse = NULL`. Otherwise, is |
|
746 |
#' a list of elements (if `length(str) > 1`) that can contain strings or vector of |
|
747 |
#' characters (if `collapse = NULL`). |
|
748 |
#' |
|
749 |
#' @examples |
|
750 |
#' str <- list( |
|
751 |
#' " , something really \\tnot very good", # \t needs to be escaped |
|
752 |
#' " but I keep it12 " |
|
753 |
#' ) |
|
754 |
#' wrap_string(str, 5, collapse = "\n") |
|
755 |
#' |
|
756 |
#' @name wrap_string |
|
757 |
#' @export |
|
758 |
wrap_string <- function(str, width, collapse = NULL) { |
|
759 | 17090x |
if (length(str) > 1) { |
760 | 21x |
return( |
761 | 21x |
unlist( |
762 | 21x |
lapply(str, wrap_string, width = width, collapse = collapse), |
763 | 21x |
use.names = FALSE |
764 |
) |
|
765 |
) |
|
766 |
} |
|
767 | 17069x |
str <- unlist(str, use.names = FALSE) # it happens is one list element |
768 | 17069x |
if (!length(str) || !nzchar(str) || is.na(str)) { |
769 | 2410x |
return(str) |
770 |
} |
|
771 | 14659x |
checkmate::assert_character(str) |
772 | 14659x |
checkmate::assert_int(width, lower = 1) |
773 | ||
774 | 14659x |
if (any(grepl("\\n", str))) { |
775 | 1x |
stop( |
776 | 1x |
"Found \\n in a string that was meant to be wrapped. This should not happen ", |
777 | 1x |
"because matrix_form should take care of them before this step (toString, ", |
778 | 1x |
"i.e. the printing machinery). Please contact the maintaner or file an issue." |
779 |
) |
|
780 |
} |
|
781 | ||
782 |
# str can be also a vector or list. In this case simplify manages the output |
|
783 |