1 |
## XXX Do we want add.labrows here or no? |
|
2 |
## we have to choose one and stick to it. |
|
3 | ||
4 |
#' Internal generics and methods |
|
5 |
#' |
|
6 |
#' These are internal methods that are documented only to satisfy `R CMD check`. End users should pay no |
|
7 |
#' attention to this documentation. |
|
8 |
#' |
|
9 |
#' @param x (`ANY`)\cr the object. |
|
10 |
#' @param obj (`ANY`)\cr the object. |
|
11 |
#' |
|
12 |
#' @name internal_methods |
|
13 |
#' @rdname int_methods |
|
14 |
#' @aliases int_methods |
|
15 |
NULL |
|
16 | ||
17 |
#' @return The number of rows (`nrow`), columns (`ncol`), or both (`dim`) of the object. |
|
18 |
#' |
|
19 |
#' @rdname dimensions |
|
20 |
#' @exportMethod nrow |
|
21 |
setMethod( |
|
22 |
"nrow", "VTableTree", |
|
23 | 2311x |
function(x) length(collect_leaves(x, TRUE, TRUE)) |
24 |
) |
|
25 | ||
26 |
#' @rdname int_methods |
|
27 |
#' @exportMethod nrow |
|
28 |
setMethod( |
|
29 |
"nrow", "TableRow", |
|
30 | 979x |
function(x) 1L |
31 |
) |
|
32 | ||
33 |
#' Table dimensions |
|
34 |
#' |
|
35 |
#' @param x (`TableTree` or `ElementaryTable`)\cr a table object. |
|
36 |
#' |
|
37 |
#' @examples |
|
38 |
#' lyt <- basic_table() %>% |
|
39 |
#' split_cols_by("ARM") %>% |
|
40 |
#' analyze(c("SEX", "AGE")) |
|
41 |
#' |
|
42 |
#' tbl <- build_table(lyt, ex_adsl) |
|
43 |
#' |
|
44 |
#' dim(tbl) |
|
45 |
#' nrow(tbl) |
|
46 |
#' ncol(tbl) |
|
47 |
#' |
|
48 |
#' NROW(tbl) |
|
49 |
#' NCOL(tbl) |
|
50 |
#' |
|
51 |
#' @rdname dimensions |
|
52 |
#' @exportMethod ncol |
|
53 |
setMethod( |
|
54 |
"ncol", "VTableNodeInfo", |
|
55 |
function(x) { |
|
56 | 22436x |
ncol(col_info(x)) |
57 |
} |
|
58 |
) |
|
59 | ||
60 |
#' @rdname int_methods |
|
61 |
#' @exportMethod ncol |
|
62 |
setMethod( |
|
63 |
"ncol", "TableRow", |
|
64 |
function(x) { |
|
65 | 60310x |
if (!no_colinfo(x)) { |
66 | 59893x |
ncol(col_info(x)) |
67 |
} else { |
|
68 | 417x |
length(spanned_values(x)) |
69 |
} |
|
70 |
} |
|
71 |
) |
|
72 | ||
73 |
#' @rdname int_methods |
|
74 |
#' @exportMethod ncol |
|
75 |
setMethod( |
|
76 |
"ncol", "LabelRow", |
|
77 |
function(x) { |
|
78 | 20484x |
ncol(col_info(x)) |
79 |
} |
|
80 |
) |
|
81 | ||
82 |
#' @rdname int_methods |
|
83 |
#' @exportMethod ncol |
|
84 |
setMethod( |
|
85 |
"ncol", "InstantiatedColumnInfo", |
|
86 |
function(x) { |
|
87 | 104831x |
length(col_exprs(x)) |
88 |
} |
|
89 |
) |
|
90 | ||
91 |
#' @rdname dimensions |
|
92 |
#' @exportMethod dim |
|
93 |
setMethod( |
|
94 |
"dim", "VTableNodeInfo", |
|
95 | 18950x |
function(x) c(nrow(x), ncol(x)) |
96 |
) |
|
97 | ||
98 |
#' Retrieve or set the direct children of a tree-style object |
|
99 |
#' |
|
100 |
#' @param x (`TableTree` or `ElementaryTable`)\cr an object with a tree structure. |
|
101 |
#' @param value (`list`)\cr new list of children. |
|
102 |
#' |
|
103 |
#' @return A list of direct children of `x`. |
|
104 |
#' |
|
105 |
#' @export |
|
106 |
#' @rdname tree_children |
|
107 | 224153x |
setGeneric("tree_children", function(x) standardGeneric("tree_children")) |
108 | ||
109 |
#' @exportMethod tree_children |
|
110 |
#' @rdname int_methods |
|
111 |
setMethod( |
|
112 |
"tree_children", c(x = "VTree"), |
|
113 | ! |
function(x) x@children |
114 |
) |
|
115 | ||
116 |
#' @exportMethod tree_children |
|
117 |
#' @rdname int_methods |
|
118 |
setMethod( |
|
119 |
"tree_children", c(x = "VTableTree"), |
|
120 | 64147x |
function(x) x@children |
121 |
) |
|
122 | ||
123 |
## this includes VLeaf but also allows for general methods |
|
124 |
## needed for table_inset being carried around by rows and |
|
125 |
## such. |
|
126 |
#' @exportMethod tree_children |
|
127 |
#' @rdname int_methods |
|
128 |
setMethod( |
|
129 |
"tree_children", c(x = "ANY"), ## "VLeaf"), |
|
130 | 10917x |
function(x) list() |
131 |
) |
|
132 | ||
133 |
#' @export |
|
134 |
#' @rdname tree_children |
|
135 | 50199x |
setGeneric("tree_children<-", function(x, value) standardGeneric("tree_children<-")) |
136 | ||
137 |
#' @exportMethod tree_children<- |
|
138 |
#' @rdname int_methods |
|
139 |
setMethod( |
|
140 |
"tree_children<-", c(x = "VTree"), |
|
141 |
function(x, value) { |
|
142 | 1136x |
x@children <- value |
143 | 1136x |
x |
144 |
} |
|
145 |
) |
|
146 | ||
147 |
#' @exportMethod tree_children<- |
|
148 |
#' @rdname int_methods |
|
149 |
setMethod( |
|
150 |
"tree_children<-", c(x = "VTableTree"), |
|
151 |
function(x, value) { |
|
152 | 49063x |
x@children <- value |
153 | 49063x |
x |
154 |
} |
|
155 |
) |
|
156 | ||
157 |
#' Retrieve or set content table from a `TableTree` |
|
158 |
#' |
|
159 |
#' Returns the content table of `obj` if it is a `TableTree` object, or `NULL` otherwise. |
|
160 |
#' |
|
161 |
#' @param obj (`TableTree`)\cr the table object. |
|
162 |
#' |
|
163 |
#' @return the `ElementaryTable` containing the (top level) *content rows* of `obj` (or `NULL` if `obj` is not |
|
164 |
#' a formal table object). |
|
165 |
#' |
|
166 |
#' @export |
|
167 |
#' @rdname content_table |
|
168 | 89619x |
setGeneric("content_table", function(obj) standardGeneric("content_table")) |
169 | ||
170 |
#' @exportMethod content_table |
|
171 |
#' @rdname int_methods |
|
172 |
setMethod( |
|
173 |
"content_table", "TableTree", |
|
174 | 58421x |
function(obj) obj@content |
175 |
) |
|
176 | ||
177 |
#' @exportMethod content_table |
|
178 |
#' @rdname int_methods |
|
179 |
setMethod( |
|
180 |
"content_table", "ANY", |
|
181 | 10869x |
function(obj) NULL |
182 |
) |
|
183 | ||
184 |
#' @param value (`ElementaryTable`)\cr the new content table for `obj`. |
|
185 |
#' |
|
186 |
#' @export |
|
187 |
#' @rdname content_table |
|
188 | 6105x |
setGeneric("content_table<-", function(obj, value) standardGeneric("content_table<-")) |
189 | ||
190 |
#' @exportMethod "content_table<-" |
|
191 |
#' @rdname int_methods |
|
192 |
setMethod( |
|
193 |
"content_table<-", c("TableTree", "ElementaryTable"), |
|
194 |
function(obj, value) { |
|
195 | 6105x |
obj@content <- value |
196 | 6105x |
obj |
197 |
} |
|
198 |
) |
|
199 | ||
200 |
#' @param for_analyze (`flag`) whether split is an analyze split. |
|
201 |
#' @rdname int_methods |
|
202 | 1079x |
setGeneric("next_rpos", function(obj, nested = TRUE, for_analyze = FALSE) standardGeneric("next_rpos")) |
203 | ||
204 |
#' @rdname int_methods |
|
205 |
setMethod( |
|
206 |
"next_rpos", "PreDataTableLayouts", |
|
207 |
function(obj, nested, for_analyze = FALSE) next_rpos(rlayout(obj), nested, for_analyze = for_analyze) |
|
208 |
) |
|
209 | ||
210 |
.check_if_nest <- function(obj, nested, for_analyze) { |
|
211 | 257x |
if (!nested) { |
212 | 17x |
FALSE |
213 |
} else { |
|
214 |
## can always nest analyze splits (almost? what about colvars noncolvars mixing? prolly ok?) |
|
215 | 240x |
for_analyze || |
216 |
## If its not an analyze split it can't go under an analyze split |
|
217 | 240x |
!(is(last_rowsplit(obj), "VAnalyzeSplit") || |
218 | 240x |
is(last_rowsplit(obj), "AnalyzeMultiVars")) ## should this be CompoundSplit? # nolint |
219 |
} |
|
220 |
} |
|
221 | ||
222 |
#' @rdname int_methods |
|
223 |
setMethod( |
|
224 |
"next_rpos", "PreDataRowLayout", |
|
225 |
function(obj, nested, for_analyze) { |
|
226 | 539x |
l <- length(obj) |
227 | 539x |
if (length(obj[[l]]) > 0L && !.check_if_nest(obj, nested, for_analyze)) { |
228 | 26x |
l <- l + 1L |
229 |
} |
|
230 | 539x |
l |
231 |
} |
|
232 |
) |
|
233 | ||
234 |
#' @rdname int_methods |
|
235 | 1x |
setMethod("next_rpos", "ANY", function(obj, nested) 1L) |
236 | ||
237 |
#' @rdname int_methods |
|
238 | 575x |
setGeneric("next_cpos", function(obj, nested = TRUE) standardGeneric("next_cpos")) |
239 | ||
240 |
#' @rdname int_methods |
|
241 |
setMethod( |
|
242 |
"next_cpos", "PreDataTableLayouts", |
|
243 |
function(obj, nested) next_cpos(clayout(obj), nested) |
|
244 |
) |
|
245 | ||
246 |
#' @rdname int_methods |
|
247 |
setMethod( |
|
248 |
"next_cpos", "PreDataColLayout", |
|
249 |
function(obj, nested) { |
|
250 | 287x |
if (nested || length(obj[[length(obj)]]) == 0) { |
251 | 282x |
length(obj) |
252 |
} else { |
|
253 | 5x |
length(obj) + 1L |
254 |
} |
|
255 |
} |
|
256 |
) |
|
257 | ||
258 |
#' @rdname int_methods |
|
259 |
setMethod("next_cpos", "ANY", function(obj, nested) 1L) |
|
260 | ||
261 |
#' @rdname int_methods |
|
262 | 2556x |
setGeneric("last_rowsplit", function(obj) standardGeneric("last_rowsplit")) |
263 | ||
264 |
#' @rdname int_methods |
|
265 |
setMethod( |
|
266 |
"last_rowsplit", "NULL", |
|
267 | ! |
function(obj) NULL |
268 |
) |
|
269 | ||
270 |
#' @rdname int_methods |
|
271 |
setMethod( |
|
272 |
"last_rowsplit", "SplitVector", |
|
273 |
function(obj) { |
|
274 | 1006x |
if (length(obj) == 0) { |
275 | 202x |
NULL |
276 |
} else { |
|
277 | 804x |
obj[[length(obj)]] |
278 |
} |
|
279 |
} |
|
280 |
) |
|
281 | ||
282 |
#' @rdname int_methods |
|
283 |
setMethod( |
|
284 |
"last_rowsplit", "PreDataRowLayout", |
|
285 |
function(obj) { |
|
286 | 1006x |
if (length(obj) == 0) { |
287 | ! |
NULL |
288 |
} else { |
|
289 | 1006x |
last_rowsplit(obj[[length(obj)]]) |
290 |
} |
|
291 |
} |
|
292 |
) |
|
293 | ||
294 |
#' @rdname int_methods |
|
295 |
setMethod( |
|
296 |
"last_rowsplit", "PreDataTableLayouts", |
|
297 | 542x |
function(obj) last_rowsplit(rlayout(obj)) |
298 |
) |
|
299 | ||
300 |
# rlayout ---- |
|
301 |
## TODO maybe export these? |
|
302 | ||
303 |
#' @rdname int_methods |
|
304 | 3643x |
setGeneric("rlayout", function(obj) standardGeneric("rlayout")) |
305 | ||
306 |
#' @rdname int_methods |
|
307 |
setMethod( |
|
308 |
"rlayout", "PreDataTableLayouts", |
|
309 | 3643x |
function(obj) obj@row_layout |
310 |
) |
|
311 | ||
312 |
#' @rdname int_methods |
|
313 | ! |
setMethod("rlayout", "ANY", function(obj) PreDataRowLayout()) |
314 | ||
315 |
#' @rdname int_methods |
|
316 | 1621x |
setGeneric("rlayout<-", function(object, value) standardGeneric("rlayout<-")) |
317 | ||
318 |
#' @rdname int_methods |
|
319 |
setMethod( |
|
320 |
"rlayout<-", "PreDataTableLayouts", |
|
321 |
function(object, value) { |
|
322 | 1621x |
object@row_layout <- value |
323 | 1621x |
object |
324 |
} |
|
325 |
) |
|
326 | ||
327 |
#' @rdname int_methods |
|
328 | 19109x |
setGeneric("tree_pos", function(obj) standardGeneric("tree_pos")) |
329 | ||
330 |
## setMethod("tree_pos", "VNodeInfo", |
|
331 |
## function(obj) obj@pos_in_tree) |
|
332 | ||
333 |
#' @rdname int_methods |
|
334 |
setMethod( |
|
335 |
"tree_pos", "VLayoutNode", |
|
336 | 19109x |
function(obj) obj@pos_in_tree |
337 |
) |
|
338 | ||
339 |
#' @rdname int_methods |
|
340 | 1227x |
setGeneric("pos_subset", function(obj) standardGeneric("pos_subset")) |
341 | ||
342 |
#' @rdname int_methods |
|
343 |
setMethod( |
|
344 |
"pos_subset", "TreePos", |
|
345 | 1227x |
function(obj) obj@subset |
346 |
) |
|
347 | ||
348 |
## setMethod("pos_subset", "VNodeInfo", |
|
349 |
## function(obj) pos_subset(tree_pos(obj))) |
|
350 | ||
351 |
#' @rdname int_methods |
|
352 |
setMethod( |
|
353 |
"pos_subset", "VLayoutNode", |
|
354 | ! |
function(obj) pos_subset(tree_pos(obj)) |
355 |
) |
|
356 | ||
357 |
#' @rdname int_methods |
|
358 | 19425x |
setGeneric("pos_splits", function(obj) standardGeneric("pos_splits")) |
359 | ||
360 |
#' @rdname int_methods |
|
361 |
setMethod( |
|
362 |
"pos_splits", "TreePos", |
|
363 | 19425x |
function(obj) obj@splits |
364 |
) |
|
365 | ||
366 |
## setMethod("pos_splits", "VNodeInfo", |
|
367 |
## function(obj) pos_splits(tree_pos(obj))) |
|
368 | ||
369 |
#' @rdname int_methods |
|
370 |
setMethod( |
|
371 |
"pos_splits", "VLayoutNode", |
|
372 | ! |
function(obj) pos_splits(tree_pos(obj)) |
373 |
) |
|
374 | ||
375 |
#' @rdname int_methods |
|
376 | 21780x |
setGeneric("pos_splvals", function(obj) standardGeneric("pos_splvals")) |
377 | ||
378 |
#' @rdname int_methods |
|
379 |
setMethod( |
|
380 |
"pos_splvals", "TreePos", |
|
381 | 21780x |
function(obj) obj@s_values |
382 |
) |
|
383 | ||
384 |
## setMethod("pos_splvals", "VNodeInfo", |
|
385 |
## function(obj) pos_splvals(tree_pos(obj))) |
|
386 | ||
387 |
#' @rdname int_methods |
|
388 |
setMethod( |
|
389 |
"pos_splvals", "VLayoutNode", |
|
390 | ! |
function(obj) pos_splvals(tree_pos(obj)) |
391 |
) |
|
392 | ||
393 |
#' @rdname int_methods |
|
394 | 1227x |
setGeneric("pos_splval_labels", function(obj) standardGeneric("pos_splval_labels")) |
395 | ||
396 |
#' @rdname int_methods |
|
397 |
setMethod( |
|
398 |
"pos_splval_labels", "TreePos", |
|
399 | 1227x |
function(obj) obj@sval_labels |
400 |
) |
|
401 |
## no longer used |
|
402 | ||
403 |
## setMethod("pos_splval_labels", "VNodeInfo", |
|
404 |
## function(obj) pos_splval_labels(tree_pos(obj))) |
|
405 |
## #' @rdname int_methods |
|
406 |
## setMethod("pos_splval_labels", "VLayoutNode", |
|
407 |
## function(obj) pos_splval_labels(tree_pos(obj))) |
|
408 | ||
409 |
#' @rdname int_methods |
|
410 | 13068x |
setGeneric("spl_payload", function(obj) standardGeneric("spl_payload")) |
411 | ||
412 |
#' @rdname int_methods |
|
413 | 13068x |
setMethod("spl_payload", "Split", function(obj) obj@payload) |
414 | ||
415 |
#' @rdname int_methods |
|
416 | 3x |
setGeneric("spl_payload<-", function(obj, value) standardGeneric("spl_payload<-")) |
417 | ||
418 |
#' @rdname int_methods |
|
419 |
setMethod("spl_payload<-", "Split", function(obj, value) { |
|
420 | 3x |
obj@payload <- value |
421 | 3x |
obj |
422 |
}) |
|
423 | ||
424 |
#' @rdname int_methods |
|
425 | 687x |
setGeneric("spl_label_var", function(obj) standardGeneric("spl_label_var")) |
426 | ||
427 |
#' @rdname int_methods |
|
428 | 684x |
setMethod("spl_label_var", "VarLevelSplit", function(obj) obj@value_label_var) |
429 | ||
430 |
## TODO revisit. do we want to do this? used in vars_in_layout, but only |
|
431 |
## for convenience. |
|
432 |
#' @rdname int_methods |
|
433 | 3x |
setMethod("spl_label_var", "Split", function(obj) NULL) |
434 | ||
435 |
### name related things |
|
436 |
# #' @inherit formatters::formatter_methods |
|
437 |
#' Methods for generics in the `formatters` package |
|
438 |
#' |
|
439 |
#' See the `formatters` documentation for descriptions of these generics. |
|
440 |
#' |
|
441 |
#' @inheritParams gen_args |
|
442 |
#' |
|
443 |
#' @return |
|
444 |
#' * Accessor functions return the current value of the component being accessed of `obj` |
|
445 |
#' * Setter functions return a modified copy of `obj` with the new value. |
|
446 |
#' |
|
447 |
#' @rdname formatters_methods |
|
448 |
#' @aliases formatters_methods |
|
449 |
#' @exportMethod obj_name |
|
450 |
setMethod( |
|
451 |
"obj_name", "VNodeInfo", |
|
452 | 59946x |
function(obj) obj@name |
453 |
) |
|
454 | ||
455 |
#' @rdname formatters_methods |
|
456 |
#' @exportMethod obj_name |
|
457 |
setMethod( |
|
458 |
"obj_name", "Split", |
|
459 | 28727x |
function(obj) obj@name |
460 |
) |
|
461 | ||
462 |
#' @rdname formatters_methods |
|
463 |
#' @exportMethod obj_name<- |
|
464 |
setMethod( |
|
465 |
"obj_name<-", "VNodeInfo", |
|
466 |
function(obj, value) { |
|
467 | 2x |
obj@name <- value |
468 | 2x |
obj |
469 |
} |
|
470 |
) |
|
471 | ||
472 |
#' @rdname formatters_methods |
|
473 |
#' @exportMethod obj_name<- |
|
474 |
setMethod( |
|
475 |
"obj_name<-", "Split", |
|
476 |
function(obj, value) { |
|
477 | 3x |
obj@name <- value |
478 | 3x |
obj |
479 |
} |
|
480 |
) |
|
481 | ||
482 |
### Label related things |
|
483 |
#' @rdname formatters_methods |
|
484 |
#' @exportMethod obj_label |
|
485 | 2087x |
setMethod("obj_label", "Split", function(obj) obj@split_label) |
486 | ||
487 |
#' @rdname formatters_methods |
|
488 |
#' @exportMethod obj_label |
|
489 | 28627x |
setMethod("obj_label", "TableRow", function(obj) obj@label) |
490 | ||
491 |
## XXX Do we want a convenience for VTableTree that |
|
492 |
## grabs the label from the LabelRow or will |
|
493 |
## that just muddy the waters? |
|
494 |
#' @rdname formatters_methods |
|
495 |
#' @exportMethod obj_label |
|
496 |
setMethod( |
|
497 |
"obj_label", "VTableTree", |
|
498 | 270x |
function(obj) obj_label(tt_labelrow(obj)) |
499 |
) |
|
500 | ||
501 |
#' @rdname formatters_methods |
|
502 |
#' @exportMethod obj_label |
|
503 | ! |
setMethod("obj_label", "ValueWrapper", function(obj) obj@label) |
504 | ||
505 |
#' @rdname formatters_methods |
|
506 |
#' @exportMethod obj_label<- |
|
507 |
setMethod( |
|
508 |
"obj_label<-", "Split", |
|
509 |
function(obj, value) { |
|
510 | 1x |
obj@split_label <- value |
511 | 1x |
obj |
512 |
} |
|
513 |
) |
|
514 | ||
515 |
#' @rdname formatters_methods |
|
516 |
#' @exportMethod obj_label<- |
|
517 |
setMethod( |
|
518 |
"obj_label<-", "TableRow", |
|
519 |
function(obj, value) { |
|
520 | 32x |
obj@label <- value |
521 | 32x |
obj |
522 |
} |
|
523 |
) |
|
524 | ||
525 |
#' @rdname formatters_methods |
|
526 |
#' @exportMethod obj_label<- |
|
527 |
setMethod( |
|
528 |
"obj_label<-", "ValueWrapper", |
|
529 |
function(obj, value) { |
|
530 | ! |
obj@label <- value |
531 | ! |
obj |
532 |
} |
|
533 |
) |
|
534 | ||
535 |
#' @rdname formatters_methods |
|
536 |
#' @exportMethod obj_label<- |
|
537 |
setMethod( |
|
538 |
"obj_label<-", "VTableTree", |
|
539 |
function(obj, value) { |
|
540 | 11x |
lr <- tt_labelrow(obj) |
541 | 11x |
obj_label(lr) <- value |
542 | 11x |
if (!is.na(value) && nzchar(value)) { |
543 | 10x |
labelrow_visible(lr) <- TRUE |
544 | 1x |
} else if (is.na(value)) { |
545 | 1x |
labelrow_visible(lr) <- FALSE |
546 |
} |
|
547 | 11x |
tt_labelrow(obj) <- lr |
548 | 11x |
obj |
549 |
} |
|
550 |
) |
|
551 | ||
552 |
### Label rows. |
|
553 |
#' @rdname int_methods |
|
554 | 130232x |
setGeneric("tt_labelrow", function(obj) standardGeneric("tt_labelrow")) |
555 | ||
556 |
#' @rdname int_methods |
|
557 |
setMethod( |
|
558 |
"tt_labelrow", "VTableTree", |
|
559 | 48608x |
function(obj) obj@labelrow |
560 |
) |
|
561 | ||
562 |
#' @rdname int_methods |
|
563 | 3664x |
setGeneric("tt_labelrow<-", function(obj, value) standardGeneric("tt_labelrow<-")) |
564 | ||
565 |
#' @rdname int_methods |
|
566 |
setMethod( |
|
567 |
"tt_labelrow<-", c("VTableTree", "LabelRow"), |
|
568 |
function(obj, value) { |
|
569 | 3664x |
if (no_colinfo(value)) { |
570 | 1x |
col_info(value) <- col_info(obj) |
571 |
} |
|
572 | 3664x |
obj@labelrow <- value |
573 | 3664x |
obj |
574 |
} |
|
575 |
) |
|
576 | ||
577 |
#' @rdname int_methods |
|
578 | 199275x |
setGeneric("labelrow_visible", function(obj) standardGeneric("labelrow_visible")) |
579 | ||
580 |
#' @rdname int_methods |
|
581 |
setMethod( |
|
582 |
"labelrow_visible", "VTableTree", |
|
583 |
function(obj) { |
|
584 | 29862x |
labelrow_visible(tt_labelrow(obj)) |
585 |
} |
|
586 |
) |
|
587 | ||
588 |
#' @rdname int_methods |
|
589 |
setMethod( |
|
590 |
"labelrow_visible", "LabelRow", |
|
591 | 108634x |
function(obj) obj@visible |
592 |
) |
|
593 | ||
594 |
#' @rdname int_methods |
|
595 |
setMethod( |
|
596 |
"labelrow_visible", "VAnalyzeSplit", |
|
597 | 1383x |
function(obj) .labelkids_helper(obj@var_label_position) |
598 |
) |
|
599 | ||
600 |
#' @rdname int_methods |
|
601 | 2895x |
setGeneric("labelrow_visible<-", function(obj, value) standardGeneric("labelrow_visible<-")) |
602 | ||
603 |
#' @rdname int_methods |
|
604 |
setMethod( |
|
605 |
"labelrow_visible<-", "VTableTree", |
|
606 |
function(obj, value) { |
|
607 | 1312x |
lr <- tt_labelrow(obj) |
608 | 1312x |
labelrow_visible(lr) <- value |
609 | 1312x |
tt_labelrow(obj) <- lr |
610 | 1312x |
obj |
611 |
} |
|
612 |
) |
|
613 | ||
614 |
#' @rdname int_methods |
|
615 |
setMethod( |
|
616 |
"labelrow_visible<-", "LabelRow", |
|
617 |
function(obj, value) { |
|
618 | 1323x |
obj@visible <- value |
619 | 1323x |
obj |
620 |
} |
|
621 |
) |
|
622 | ||
623 |
#' @rdname int_methods |
|
624 |
setMethod( |
|
625 |
"labelrow_visible<-", "VAnalyzeSplit", |
|
626 |
function(obj, value) { |
|
627 | 260x |
obj@var_label_position <- value |
628 | 260x |
obj |
629 |
} |
|
630 |
) |
|
631 | ||
632 |
## TRUE is always, FALSE is never, NA is only when no |
|
633 |
## content function (or rows in an instantiated table) is present |
|
634 |
#' @rdname int_methods |
|
635 | 1508x |
setGeneric("label_kids", function(spl) standardGeneric("label_kids")) |
636 | ||
637 |
#' @rdname int_methods |
|
638 | 1508x |
setMethod("label_kids", "Split", function(spl) spl@label_children) |
639 | ||
640 |
#' @rdname int_methods |
|
641 | 3x |
setGeneric("label_kids<-", function(spl, value) standardGeneric("label_kids<-")) |
642 | ||
643 |
#' @rdname int_methods |
|
644 |
setMethod("label_kids<-", c("Split", "character"), function(spl, value) { |
|
645 | 1x |
label_kids(spl) <- .labelkids_helper(value) |
646 | 1x |
spl |
647 |
}) |
|
648 | ||
649 |
#' @rdname int_methods |
|
650 |
setMethod("label_kids<-", c("Split", "logical"), function(spl, value) { |
|
651 | 2x |
spl@label_children <- value |
652 | 2x |
spl |
653 |
}) |
|
654 | ||
655 |
#' @rdname int_methods |
|
656 | 405x |
setGeneric("vis_label", function(spl) standardGeneric("vis_label")) |
657 | ||
658 |
#' @rdname int_methods |
|
659 |
setMethod("vis_label", "Split", function(spl) { |
|
660 | 405x |
.labelkids_helper(label_position(spl)) |
661 |
}) |
|
662 | ||
663 |
## #' @rdname int_methods |
|
664 |
## setGeneric("vis_label<-", function(spl, value) standardGeneric("vis_label<-")) |
|
665 |
## #' @rdname int_methods |
|
666 |
## setMethod("vis_label<-", "Split", function(spl, value) { |
|
667 |
## stop("defunct") |
|
668 |
## if(is.na(value)) |
|
669 |
## stop("split label visibility must be TRUE or FALSE, got NA") |
|
670 |
## # spl@split_label_visible <- value |
|
671 |
## spl |
|
672 |
## }) |
|
673 | ||
674 |
#' @rdname int_methods |
|
675 | 1023x |
setGeneric("label_position", function(spl) standardGeneric("label_position")) |
676 | ||
677 |
#' @rdname int_methods |
|
678 | 704x |
setMethod("label_position", "Split", function(spl) spl@split_label_position) |
679 | ||
680 |
#' @rdname int_methods |
|
681 | 319x |
setMethod("label_position", "VAnalyzeSplit", function(spl) spl@var_label_position) ## split_label_position) |
682 | ||
683 |
#' @rdname int_methods |
|
684 | 50x |
setGeneric("label_position<-", function(spl, value) standardGeneric("label_position<-")) |
685 | ||
686 |
#' @rdname int_methods |
|
687 |
setMethod("label_position<-", "Split", function(spl, value) { |
|
688 | 50x |
value <- match.arg(value, valid_lbl_pos) |
689 | 50x |
spl@split_label_position <- value |
690 | 50x |
spl |
691 |
}) |
|
692 | ||
693 |
### Function accessors (summary, tabulation and split) ---- |
|
694 | ||
695 |
#' @rdname int_methods |
|
696 | 3198x |
setGeneric("content_fun", function(obj) standardGeneric("content_fun")) |
697 | ||
698 |
#' @rdname int_methods |
|
699 | 3147x |
setMethod("content_fun", "Split", function(obj) obj@content_fun) |
700 | ||
701 |
#' @rdname int_methods |
|
702 | 105x |
setGeneric("content_fun<-", function(object, value) standardGeneric("content_fun<-")) |
703 | ||
704 |
#' @rdname int_methods |
|
705 |
setMethod("content_fun<-", "Split", function(object, value) { |
|
706 | 105x |
object@content_fun <- value |
707 | 105x |
object |
708 |
}) |
|
709 | ||
710 |
#' @rdname int_methods |
|
711 | 1711x |
setGeneric("analysis_fun", function(obj) standardGeneric("analysis_fun")) |
712 | ||
713 |
#' @rdname int_methods |
|
714 | 1616x |
setMethod("analysis_fun", "AnalyzeVarSplit", function(obj) obj@analysis_fun) |
715 | ||
716 |
#' @rdname int_methods |
|
717 | 95x |
setMethod("analysis_fun", "AnalyzeColVarSplit", function(obj) obj@analysis_fun) |
718 | ||
719 |
## not used and probably not needed |
|
720 |
## #' @rdname int_methods |
|
721 |
## setGeneric("analysis_fun<-", function(object, value) standardGeneric("analysis_fun<-")) |
|
722 | ||
723 |
## #' @rdname int_methods |
|
724 |
## setMethod("analysis_fun<-", "AnalyzeVarSplit", function(object, value) { |
|
725 |
## object@analysis_fun <- value |
|
726 |
## object |
|
727 |
## }) |
|
728 |
## #' @rdname int_methods |
|
729 |
## setMethod("analysis_fun<-", "AnalyzeColVarSplit", function(object, value) { |
|
730 |
## if(is(value, "function")) |
|
731 |
## value <- list(value) |
|
732 |
## object@analysis_fun <- value |
|
733 |
## object |
|
734 |
## }) |
|
735 | ||
736 |
#' @rdname int_methods |
|
737 | 1029x |
setGeneric("split_fun", function(obj) standardGeneric("split_fun")) |
738 | ||
739 |
#' @rdname int_methods |
|
740 | 859x |
setMethod("split_fun", "CustomizableSplit", function(obj) obj@split_fun) |
741 | ||
742 |
## Only that type of split currently has the slot |
|
743 |
## this should probably change? for now define |
|
744 |
## an accessor that just returns NULL |
|
745 |
#' @rdname int_methods |
|
746 | 119x |
setMethod("split_fun", "Split", function(obj) NULL) |
747 | ||
748 |
#' @rdname int_methods |
|
749 | 12x |
setGeneric("split_fun<-", function(obj, value) standardGeneric("split_fun<-")) |
750 | ||
751 |
#' @rdname int_methods |
|
752 |
setMethod("split_fun<-", "CustomizableSplit", function(obj, value) { |
|
753 | 12x |
obj@split_fun <- value |
754 | 12x |
obj |
755 |
}) |
|
756 | ||
757 |
# nocov start |
|
758 |
## Only that type of split currently has the slot |
|
759 |
## this should probably change? for now define |
|
760 |
## an accessor that just returns NULL |
|
761 |
#' @rdname int_methods |
|
762 |
setMethod( |
|
763 |
"split_fun<-", "Split", |
|
764 |
function(obj, value) { |
|
765 |
stop( |
|
766 |
"Attempted to set a custom split function on a non-customizable split.", |
|
767 |
"This should not happen, please contact the maintainers." |
|
768 |
) |
|
769 |
} |
|
770 |
) |
|
771 |
# nocov end |
|
772 | ||
773 |
## Content specification related accessors ---- |
|
774 | ||
775 |
#' @rdname int_methods |
|
776 | 459x |
setGeneric("content_extra_args", function(obj) standardGeneric("content_extra_args")) |
777 | ||
778 |
#' @rdname int_methods |
|
779 | 459x |
setMethod("content_extra_args", "Split", function(obj) obj@content_extra_args) |
780 | ||
781 |
#' @rdname int_methods |
|
782 | 105x |
setGeneric("content_extra_args<-", function(object, value) standardGeneric("content_extra_args<-")) |
783 | ||
784 |
#' @rdname int_methods |
|
785 |
setMethod("content_extra_args<-", "Split", function(object, value) { |
|
786 | 105x |
object@content_extra_args <- value |
787 | 105x |
object |
788 |
}) |
|
789 | ||
790 |
#' @rdname int_methods |
|
791 | 1810x |
setGeneric("content_var", function(obj) standardGeneric("content_var")) |
792 | ||
793 |
#' @rdname int_methods |
|
794 | 1810x |
setMethod("content_var", "Split", function(obj) obj@content_var) |
795 | ||
796 |
#' @rdname int_methods |
|
797 | 105x |
setGeneric("content_var<-", function(object, value) standardGeneric("content_var<-")) |
798 | ||
799 |
#' @rdname int_methods |
|
800 |
setMethod("content_var<-", "Split", function(object, value) { |
|
801 | 105x |
object@content_var <- value |
802 | 105x |
object |
803 |
}) |
|
804 | ||
805 |
### Miscellaneous accessors ---- |
|
806 | ||
807 |
#' @rdname int_methods |
|
808 | 1116x |
setGeneric("avar_inclNAs", function(obj) standardGeneric("avar_inclNAs")) |
809 | ||
810 |
#' @rdname int_methods |
|
811 |
setMethod( |
|
812 |
"avar_inclNAs", "VAnalyzeSplit", |
|
813 | 1116x |
function(obj) obj@include_NAs |
814 |
) |
|
815 | ||
816 |
#' @rdname int_methods |
|
817 | ! |
setGeneric("avar_inclNAs<-", function(obj, value) standardGeneric("avar_inclNAs<-")) |
818 | ||
819 |
#' @rdname int_methods |
|
820 |
setMethod( |
|
821 |
"avar_inclNAs<-", "VAnalyzeSplit", |
|
822 |
function(obj, value) { |
|
823 | ! |
obj@include_NAs <- value |
824 |
} |
|
825 |
) |
|
826 | ||
827 |
#' @rdname int_methods |
|
828 | 781x |
setGeneric("spl_labelvar", function(obj) standardGeneric("spl_labelvar")) |
829 | ||
830 |
#' @rdname int_methods |
|
831 | 781x |
setMethod("spl_labelvar", "VarLevelSplit", function(obj) obj@value_label_var) |
832 | ||
833 |
#' @rdname int_methods |
|
834 | 2638x |
setGeneric("spl_child_order", function(obj) standardGeneric("spl_child_order")) |
835 | ||
836 |
#' @rdname int_methods |
|
837 | 2350x |
setMethod("spl_child_order", "VarLevelSplit", function(obj) obj@value_order) |
838 | ||
839 |
#' @rdname int_methods |
|
840 |
setGeneric( |
|
841 |
"spl_child_order<-", |
|
842 | 603x |
function(obj, value) standardGeneric("spl_child_order<-") |
843 |
) |
|
844 | ||
845 |
#' @rdname int_methods |
|
846 |
setMethod( |
|
847 |
"spl_child_order<-", "VarLevelSplit", |
|
848 |
function(obj, value) { |
|
849 | 603x |
obj@value_order <- value |
850 | 603x |
obj |
851 |
} |
|
852 |
) |
|
853 | ||
854 |
#' @rdname int_methods |
|
855 |
setMethod( |
|
856 |
"spl_child_order", |
|
857 |
"ManualSplit", |
|
858 | 51x |
function(obj) obj@levels |
859 |
) |
|
860 | ||
861 |
#' @rdname int_methods |
|
862 |
setMethod( |
|
863 |
"spl_child_order", |
|
864 |
"MultiVarSplit", |
|
865 | 96x |
function(obj) spl_varnames(obj) |
866 |
) |
|
867 | ||
868 |
#' @rdname int_methods |
|
869 |
setMethod( |
|
870 |
"spl_child_order", |
|
871 |
"AllSplit", |
|
872 | 97x |
function(obj) character() |
873 |
) |
|
874 | ||
875 |
#' @rdname int_methods |
|
876 |
setMethod( |
|
877 |
"spl_child_order", |
|
878 |
"VarStaticCutSplit", |
|
879 | 44x |
function(obj) spl_cutlabels(obj) |
880 |
) |
|
881 | ||
882 |
#' @rdname int_methods |
|
883 | 931x |
setGeneric("root_spl", function(obj) standardGeneric("root_spl")) |
884 | ||
885 |
#' @rdname int_methods |
|
886 |
setMethod( |
|
887 |
"root_spl", "PreDataAxisLayout", |
|
888 | 931x |
function(obj) obj@root_split |
889 |
) |
|
890 | ||
891 |
#' @rdname int_methods |
|
892 | 9x |
setGeneric("root_spl<-", function(obj, value) standardGeneric("root_spl<-")) |
893 | ||
894 |
#' @rdname int_methods |
|
895 |
setMethod( |
|
896 |
"root_spl<-", "PreDataAxisLayout", |
|
897 |
function(obj, value) { |
|
898 | 9x |
obj@root_split <- value |
899 | 9x |
obj |
900 |
} |
|
901 |
) |
|
902 | ||
903 |
#' Row attribute accessors |
|
904 |
#' |
|
905 |
#' @inheritParams gen_args |
|
906 |
#' |
|
907 |
#' @return Various return values depending on the accessor called. |
|
908 |
#' |
|
909 |
#' @export |
|
910 |
#' @rdname row_accessors |
|
911 | 76x |
setGeneric("obj_avar", function(obj) standardGeneric("obj_avar")) |
912 | ||
913 |
#' @rdname row_accessors |
|
914 |
#' @exportMethod obj_avar |
|
915 | 58x |
setMethod("obj_avar", "TableRow", function(obj) obj@var_analyzed) |
916 | ||
917 |
#' @rdname row_accessors |
|
918 |
#' @exportMethod obj_avar |
|
919 | 18x |
setMethod("obj_avar", "ElementaryTable", function(obj) obj@var_analyzed) |
920 | ||
921 |
#' @export |
|
922 |
#' @rdname row_accessors |
|
923 | 61295x |
setGeneric("row_cells", function(obj) standardGeneric("row_cells")) |
924 | ||
925 |
#' @rdname row_accessors |
|
926 |
#' @exportMethod row_cells |
|
927 | 8020x |
setMethod("row_cells", "TableRow", function(obj) obj@leaf_value) |
928 | ||
929 |
#' @rdname row_accessors |
|
930 | 3262x |
setGeneric("row_cells<-", function(obj, value) standardGeneric("row_cells<-")) |
931 | ||
932 |
#' @rdname row_accessors |
|
933 |
#' @exportMethod row_cells |
|
934 |
setMethod("row_cells<-", "TableRow", function(obj, value) { |
|
935 | 3262x |
obj@leaf_value <- value |
936 | 3262x |
obj |
937 |
}) |
|
938 | ||
939 |
#' @export |
|
940 |
#' @rdname row_accessors |
|
941 | 2717x |
setGeneric("row_values", function(obj) standardGeneric("row_values")) |
942 | ||
943 |
#' @rdname row_accessors |
|
944 |
#' @exportMethod row_values |
|
945 | 529x |
setMethod("row_values", "TableRow", function(obj) rawvalues(obj@leaf_value)) |
946 | ||
947 | ||
948 |
#' @rdname row_accessors |
|
949 |
#' @exportMethod row_values<- |
|
950 | 1234x |
setGeneric("row_values<-", function(obj, value) standardGeneric("row_values<-")) |
951 | ||
952 |
#' @rdname row_accessors |
|
953 |
#' @exportMethod row_values<- |
|
954 |
setMethod( |
|
955 |
"row_values<-", "TableRow", |
|
956 |
function(obj, value) { |
|
957 | 1234x |
obj@leaf_value <- lapply(value, rcell) |
958 | 1234x |
obj |
959 |
} |
|
960 |
) |
|
961 | ||
962 |
#' @rdname row_accessors |
|
963 |
#' @exportMethod row_values<- |
|
964 |
setMethod( |
|
965 |
"row_values<-", "LabelRow", |
|
966 |
function(obj, value) { |
|
967 | ! |
stop("LabelRows cannot have row values.") |
968 |
} |
|
969 |
) |
|
970 | ||
971 |
#' @rdname int_methods |
|
972 | 418x |
setGeneric("spanned_values", function(obj) standardGeneric("spanned_values")) |
973 | ||
974 |
#' @rdname int_methods |
|
975 |
setMethod( |
|
976 |
"spanned_values", "TableRow", |
|
977 |
function(obj) { |
|
978 | 418x |
rawvalues(spanned_cells(obj)) |
979 |
} |
|
980 |
) |
|
981 | ||
982 |
#' @rdname int_methods |
|
983 |
setMethod( |
|
984 |
"spanned_values", "LabelRow", |
|
985 |
function(obj) { |
|
986 | ! |
rep(list(NULL), ncol(obj)) |
987 |
} |
|
988 |
) |
|
989 | ||
990 |
#' @rdname int_methods |
|
991 | 418x |
setGeneric("spanned_cells", function(obj) standardGeneric("spanned_cells")) |
992 | ||
993 |
#' @rdname int_methods |
|
994 |
setMethod( |
|
995 |
"spanned_cells", "TableRow", |
|
996 |
function(obj) { |
|
997 | 418x |
sp <- row_cspans(obj) |
998 | 418x |
rvals <- row_cells(obj) |
999 | 418x |
unlist( |
1000 | 418x |
mapply(function(v, s) rep(list(v), times = s), |
1001 | 418x |
v = rvals, s = sp |
1002 |
), |
|
1003 | 418x |
recursive = FALSE |
1004 |
) |
|
1005 |
} |
|
1006 |
) |
|
1007 | ||
1008 |
#' @rdname int_methods |
|
1009 |
setMethod( |
|
1010 |
"spanned_cells", "LabelRow", |
|
1011 |
function(obj) { |
|
1012 | ! |
rep(list(NULL), ncol(obj)) |
1013 |
} |
|
1014 |
) |
|
1015 | ||
1016 |
#' @rdname int_methods |
|
1017 | 3x |
setGeneric("spanned_values<-", function(obj, value) standardGeneric("spanned_values<-")) |
1018 | ||
1019 |
#' @rdname int_methods |
|
1020 |
setMethod( |
|
1021 |
"spanned_values<-", "TableRow", |
|
1022 |
function(obj, value) { |
|
1023 | 2x |
sp <- row_cspans(obj) |
1024 |
## this is 3 times too clever!!! |
|
1025 | 2x |
valindices <- unlist(lapply(sp, function(x) c(TRUE, rep(FALSE, x - 1)))) |
1026 | ||
1027 | 2x |
splvec <- cumsum(valindices) |
1028 | 2x |
lapply( |
1029 | 2x |
split(value, splvec), |
1030 | 2x |
function(v) { |
1031 | 3x |
if (length(unique(v)) > 1) { |
1032 | 1x |
stop( |
1033 | 1x |
"Got more than one unique value within a span, ", |
1034 | 1x |
"new spanned values do not appear to match the ", |
1035 | 1x |
"existing spanning pattern of the row (", |
1036 | 1x |
paste(sp, collapse = " "), ")" |
1037 |
) |
|
1038 |
} |
|
1039 |
} |
|
1040 |
) |
|
1041 | 1x |
rvals <- value[valindices] |
1042 | ||
1043 |
## rvals = lapply(split(value, splvec), |
|
1044 |
## function(v) { |
|
1045 |
## if(length(v) == 1) |
|
1046 |
## return(v) |
|
1047 |
## stopifnot(length(unique(v)) == 1L) |
|
1048 |
## rcell(unique(v), colspan<- length(v)) |
|
1049 |
## }) |
|
1050 |
## if(any(splvec > 1)) |
|
1051 |
## rvals <- lapply(rvals, function(x) x[[1]]) |
|
1052 | 1x |
row_values(obj) <- rvals |
1053 | 1x |
obj |
1054 |
} |
|
1055 |
) |
|
1056 | ||
1057 |
#' @rdname int_methods |
|
1058 |
setMethod( |
|
1059 |
"spanned_values<-", "LabelRow", |
|
1060 |
function(obj, value) { |
|
1061 | 1x |
if (!is.null(value)) { |
1062 | 1x |
stop("Label rows can't have non-null cell values, got", value) |
1063 |
} |
|
1064 | ! |
obj |
1065 |
} |
|
1066 |
) |
|
1067 | ||
1068 |
### Format manipulation |
|
1069 |
### obj_format<- is not recursive |
|
1070 |
## TODO export these? |
|
1071 |
#' @rdname formatters_methods |
|
1072 |
#' @export |
|
1073 | 6794x |
setMethod("obj_format", "VTableNodeInfo", function(obj) obj@format) |
1074 | ||
1075 |
#' @rdname formatters_methods |
|
1076 |
#' @export |
|
1077 | 91946x |
setMethod("obj_format", "CellValue", function(obj) attr(obj, "format", exact = TRUE)) |
1078 | ||
1079 |
#' @rdname formatters_methods |
|
1080 |
#' @export |
|
1081 | 2273x |
setMethod("obj_format", "Split", function(obj) obj@split_format) |
1082 | ||
1083 |
#' @rdname formatters_methods |
|
1084 |
#' @export |
|
1085 |
setMethod("obj_format<-", "VTableNodeInfo", function(obj, value) { |
|
1086 | 1640x |
obj@format <- value |
1087 | 1640x |
obj |
1088 |
}) |
|
1089 | ||
1090 |
#' @rdname formatters_methods |
|
1091 |
#' @export |
|
1092 |
setMethod("obj_format<-", "Split", function(obj, value) { |
|
1093 | 1x |
obj@split_format <- value |
1094 | 1x |
obj |
1095 |
}) |
|
1096 | ||
1097 |
#' @rdname formatters_methods |
|
1098 |
#' @export |
|
1099 |
setMethod("obj_format<-", "CellValue", function(obj, value) { |
|
1100 | 1221x |
attr(obj, "format") <- value |
1101 | 1221x |
obj |
1102 |
}) |
|
1103 | ||
1104 |
#' @rdname int_methods |
|
1105 |
#' @export |
|
1106 |
setMethod("obj_na_str<-", "CellValue", function(obj, value) { |
|
1107 | 4235x |
attr(obj, "format_na_str") <- value |
1108 | 4235x |
obj |
1109 |
}) |
|
1110 | ||
1111 |
#' @rdname int_methods |
|
1112 |
#' @export |
|
1113 |
setMethod("obj_na_str<-", "VTableNodeInfo", function(obj, value) { |
|
1114 | 26x |
obj@na_str <- value |
1115 | 26x |
obj |
1116 |
}) |
|
1117 | ||
1118 |
#' @rdname int_methods |
|
1119 |
#' @export |
|
1120 |
setMethod("obj_na_str<-", "Split", function(obj, value) { |
|
1121 | ! |
obj@split_na_str <- value |
1122 | ! |
obj |
1123 |
}) |
|
1124 | ||
1125 |
#' @rdname int_methods |
|
1126 |
#' @export |
|
1127 | 25715x |
setMethod("obj_na_str", "VTableNodeInfo", function(obj) obj@na_str) |
1128 | ||
1129 |
#' @rdname formatters_methods |
|
1130 |
#' @export |
|
1131 | 1158x |
setMethod("obj_na_str", "Split", function(obj) obj@split_na_str) |
1132 | ||
1133 |
.no_na_str <- function(x) { |
|
1134 | 15033x |
if (!is.character(x)) { |
1135 | 6192x |
x <- obj_na_str(x) |
1136 |
} |
|
1137 | 15033x |
length(x) == 0 || all(is.na(x)) |
1138 |
} |
|
1139 | ||
1140 |
#' @rdname int_methods |
|
1141 |
setGeneric("set_format_recursive", function(obj, format, na_str, override = FALSE) { |
|
1142 | 8834x |
standardGeneric("set_format_recursive") |
1143 |
}) |
|
1144 | ||
1145 |
#' @param override (`flag`)\cr whether to override attribute. |
|
1146 |
#' |
|
1147 |
#' @rdname int_methods |
|
1148 |
setMethod( |
|
1149 |
"set_format_recursive", "TableRow", |
|
1150 |
function(obj, format, na_str, override = FALSE) { |
|
1151 | 1030x |
if (is.null(format) && .no_na_str(na_str)) { |
1152 | 514x |
return(obj) |
1153 |
} |
|
1154 | ||
1155 | 516x |
if ((is.null(obj_format(obj)) && !is.null(format)) || override) { |
1156 | 515x |
obj_format(obj) <- format |
1157 |
} |
|
1158 | 516x |
if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) { |
1159 | ! |
obj_na_str(obj) <- na_str |
1160 |
} |
|
1161 | 516x |
lcells <- row_cells(obj) |
1162 | 516x |
lvals <- lapply(lcells, function(x) { |
1163 | 1920x |
if (!is.null(x) && (override || is.null(obj_format(x)))) { |
1164 | 53x |
obj_format(x) <- obj_format(obj) |
1165 |
} |
|
1166 | 1920x |
if (!is.null(x) && (override || .no_na_str(x))) { |
1167 | 1920x |
obj_na_str(x) <- obj_na_str(obj) |
1168 |
} |
|
1169 | 1920x |
x |
1170 |
}) |
|
1171 | 516x |
row_values(obj) <- lvals |
1172 | 516x |
obj |
1173 |
} |
|
1174 |
) |
|
1175 | ||
1176 |
#' @rdname int_methods |
|
1177 |
setMethod( |
|
1178 |
"set_format_recursive", "LabelRow", |
|
1179 | 11x |
function(obj, format, override = FALSE) obj |
1180 |
) |
|
1181 | ||
1182 |
setMethod( |
|
1183 |
"set_format_recursive", "VTableTree", |
|
1184 |
function(obj, format, na_str, override = FALSE) { |
|
1185 | 1691x |
force(format) |
1186 | 1691x |
if (is.null(format) && .no_na_str(na_str)) { |
1187 | 1684x |
return(obj) |
1188 |
} |
|
1189 | ||
1190 | 7x |
if ((is.null(obj_format(obj)) && !is.null(format)) || override) { |
1191 | 7x |
obj_format(obj) <- format |
1192 |
} |
|
1193 | 7x |
if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) { |
1194 | ! |
obj_na_str(obj) <- na_str |
1195 |
} |
|
1196 | ||
1197 | 7x |
kids <- tree_children(obj) |
1198 | 7x |
kids <- lapply(kids, function(x, format2, na_str2, oride) { |
1199 | 33x |
set_format_recursive(x, |
1200 | 33x |
format = format2, na_str = na_str2, override = oride |
1201 |
) |
|
1202 |
}, |
|
1203 | 7x |
format2 = obj_format(obj), na_str2 = obj_na_str(obj), oride = override |
1204 |
) |
|
1205 | 7x |
tree_children(obj) <- kids |
1206 | 7x |
obj |
1207 |
} |
|
1208 |
) |
|
1209 | ||
1210 |
#' @rdname int_methods |
|
1211 | 1802x |
setGeneric("content_format", function(obj) standardGeneric("content_format")) |
1212 | ||
1213 |
#' @rdname int_methods |
|
1214 | 1802x |
setMethod("content_format", "Split", function(obj) obj@content_format) |
1215 | ||
1216 |
#' @rdname int_methods |
|
1217 | 105x |
setGeneric("content_format<-", function(obj, value) standardGeneric("content_format<-")) |
1218 | ||
1219 |
#' @rdname int_methods |
|
1220 |
setMethod("content_format<-", "Split", function(obj, value) { |
|
1221 | 105x |
obj@content_format <- value |
1222 | 105x |
obj |
1223 |
}) |
|
1224 | ||
1225 |
#' @rdname int_methods |
|
1226 | 1802x |
setGeneric("content_na_str", function(obj) standardGeneric("content_na_str")) |
1227 | ||
1228 |
#' @rdname int_methods |
|
1229 | 1802x |
setMethod("content_na_str", "Split", function(obj) obj@content_na_str) |
1230 | ||
1231 |
#' @rdname int_methods |
|
1232 | ! |
setGeneric("content_na_str<-", function(obj, value) standardGeneric("content_na_str<-")) |
1233 | ||
1234 |
#' @rdname int_methods |
|
1235 |
setMethod("content_na_str<-", "Split", function(obj, value) { |
|
1236 | ! |
obj@content_na_str <- value |
1237 | ! |
obj |
1238 |
}) |
|
1239 | ||
1240 |
#' Value formats |
|
1241 |
#' |
|
1242 |
#' Returns a matrix of formats for the cells in a table. |
|
1243 |
#' |
|
1244 |
#' @param obj (`VTableTree` or `TableRow`)\cr a table or row object. |
|
1245 |
#' @param default (`string`, `function`, or `list`)\cr default format. |
|
1246 |
#' |
|
1247 |
#' @return Matrix (storage mode list) containing the effective format for each cell position in the table |
|
1248 |
#' (including 'virtual' cells implied by label rows, whose formats are always `NULL`). |
|
1249 |
#' |
|
1250 |
#' @seealso [table_shell()] and [table_shell_str()] for information on the table format structure. |
|
1251 |
#' |
|
1252 |
#' @examples |
|
1253 |
#' lyt <- basic_table() %>% |
|
1254 |
#' split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>% |
|
1255 |
#' analyze("AGE") |
|
1256 |
#' |
|
1257 |
#' tbl <- build_table(lyt, DM) |
|
1258 |
#' value_formats(tbl) |
|
1259 |
#' |
|
1260 |
#' @export |
|
1261 | 1123x |
setGeneric("value_formats", function(obj, default = obj_format(obj)) standardGeneric("value_formats")) |
1262 | ||
1263 |
#' @rdname value_formats |
|
1264 |
setMethod( |
|
1265 |
"value_formats", "ANY", |
|
1266 |
function(obj, default) { |
|
1267 | 762x |
obj_format(obj) %||% default |
1268 |
} |
|
1269 |
) |
|
1270 | ||
1271 |
#' @rdname value_formats |
|
1272 |
setMethod( |
|
1273 |
"value_formats", "TableRow", |
|
1274 |
function(obj, default) { |
|
1275 | 245x |
if (!is.null(obj_format(obj))) { |
1276 | 215x |
default <- obj_format(obj) |
1277 |
} |
|
1278 | 245x |
formats <- lapply(row_cells(obj), function(x) value_formats(x) %||% default) |
1279 | 245x |
formats |
1280 |
} |
|
1281 |
) |
|
1282 | ||
1283 |
#' @rdname value_formats |
|
1284 |
setMethod( |
|
1285 |
"value_formats", "LabelRow", |
|
1286 |
function(obj, default) { |
|
1287 | 102x |
rep(list(NULL), ncol(obj)) |
1288 |
} |
|
1289 |
) |
|
1290 | ||
1291 |
#' @rdname value_formats |
|
1292 |
setMethod( |
|
1293 |
"value_formats", "VTableTree", |
|
1294 |
function(obj, default) { |
|
1295 | 14x |
if (!is.null(obj_format(obj))) { |
1296 | ! |
default <- obj_format(obj) |
1297 |
} |
|
1298 | 14x |
rws <- collect_leaves(obj, TRUE, TRUE) |
1299 | 14x |
formatrws <- lapply(rws, value_formats, default = default) |
1300 | 14x |
mat <- do.call(rbind, formatrws) |
1301 | 14x |
row.names(mat) <- row.names(obj) |
1302 | 14x |
mat |
1303 |
} |
|
1304 |
) |
|
1305 | ||
1306 |
### Collect all leaves of a current tree |
|
1307 |
### This is a workhorse function in various |
|
1308 |
### places |
|
1309 |
### NB this is written generally enought o |
|
1310 |
### be used on all tree-based structures in the |
|
1311 |
### framework. |
|
1312 | ||
1313 |
#' Collect leaves of a `TableTree` |
|
1314 |
#' |
|
1315 |
#' @inheritParams gen_args |
|
1316 |
#' @param incl.cont (`flag`)\cr whether to include rows from content tables within the tree. Defaults to `TRUE`. |
|
1317 |
#' @param add.labrows (`flag`)\cr whether to include label rows. Defaults to `FALSE`. |
|
1318 |
#' |
|
1319 |
#' @return A list of `TableRow` objects for all rows in the table. |
|
1320 |
#' |
|
1321 |
#' @export |
|
1322 |
setGeneric("collect_leaves", |
|
1323 |
function(tt, incl.cont = TRUE, add.labrows = FALSE) { |
|
1324 | 95776x |
standardGeneric("collect_leaves") |
1325 |
}, |
|
1326 |
signature = "tt" |
|
1327 |
) |
|
1328 | ||
1329 |
#' @inheritParams collect_leaves |
|
1330 |
#' |
|
1331 |
#' @rdname int_methods |
|
1332 |
#' @exportMethod collect_leaves |
|
1333 |
setMethod( |
|
1334 |
"collect_leaves", "TableTree", |
|
1335 |
function(tt, incl.cont = TRUE, add.labrows = FALSE) { |
|
1336 | 24783x |
ret <- c( |
1337 | 24783x |
if (add.labrows && labelrow_visible(tt)) { |
1338 | 10050x |
tt_labelrow(tt) |
1339 |
}, |
|
1340 | 24783x |
if (incl.cont) { |
1341 | 24783x |
tree_children(content_table(tt)) |
1342 |
}, |
|
1343 | 24783x |
lapply(tree_children(tt), |
1344 | 24783x |
collect_leaves, |
1345 | 24783x |
incl.cont = incl.cont, add.labrows = add.labrows |
1346 |
) |
|
1347 |
) |
|
1348 | 24783x |
unlist(ret, recursive = TRUE) |
1349 |
} |
|
1350 |
) |
|
1351 | ||
1352 |
#' @rdname int_methods |
|
1353 |
#' @exportMethod collect_leaves |
|
1354 |
setMethod( |
|
1355 |
"collect_leaves", "ElementaryTable", |
|
1356 |
function(tt, incl.cont = TRUE, add.labrows = FALSE) { |
|
1357 | 54006x |
ret <- tree_children(tt) |
1358 | 54006x |
if (add.labrows && labelrow_visible(tt)) { |
1359 | 9460x |
ret <- c(tt_labelrow(tt), ret) |
1360 |
} |
|
1361 | 54006x |
ret |
1362 |
} |
|
1363 |
) |
|
1364 | ||
1365 |
#' @rdname int_methods |
|
1366 |
#' @exportMethod collect_leaves |
|
1367 |
setMethod( |
|
1368 |
"collect_leaves", "VTree", |
|
1369 |
function(tt, incl.cont, add.labrows) { |
|
1370 | ! |
ret <- lapply( |
1371 | ! |
tree_children(tt), |
1372 | ! |
collect_leaves |
1373 |
) |
|
1374 | ! |
unlist(ret, recursive = TRUE) |
1375 |
} |
|
1376 |
) |
|
1377 | ||
1378 |
#' @rdname int_methods |
|
1379 |
#' @exportMethod collect_leaves |
|
1380 |
setMethod( |
|
1381 |
"collect_leaves", "VLeaf", |
|
1382 |
function(tt, incl.cont, add.labrows) { |
|
1383 | 716x |
list(tt) |
1384 |
} |
|
1385 |
) |
|
1386 | ||
1387 |
#' @rdname int_methods |
|
1388 |
#' @exportMethod collect_leaves |
|
1389 |
setMethod( |
|
1390 |
"collect_leaves", "NULL", |
|
1391 |
function(tt, incl.cont, add.labrows) { |
|
1392 | ! |
list() |
1393 |
} |
|
1394 |
) |
|
1395 | ||
1396 |
#' @rdname int_methods |
|
1397 |
#' @exportMethod collect_leaves |
|
1398 |
setMethod( |
|
1399 |
"collect_leaves", "ANY", |
|
1400 |
function(tt, incl.cont, add.labrows) { |
|
1401 | ! |
stop("class ", class(tt), " does not inherit from VTree or VLeaf") |
1402 |
} |
|
1403 |
) |
|
1404 | ||
1405 |
n_leaves <- function(tt, ...) { |
|
1406 | 130x |
length(collect_leaves(tt, ...)) |
1407 |
} |
|
1408 | ||
1409 |
### Spanning information ---- |
|
1410 | ||
1411 |
#' @rdname int_methods |
|
1412 | 46838x |
setGeneric("row_cspans", function(obj) standardGeneric("row_cspans")) |
1413 | ||
1414 |
#' @rdname int_methods |
|
1415 | 4924x |
setMethod("row_cspans", "TableRow", function(obj) obj@colspans) |
1416 | ||
1417 |
#' @rdname int_methods |
|
1418 |
setMethod( |
|
1419 |
"row_cspans", "LabelRow", |
|
1420 | 1363x |
function(obj) rep(1L, ncol(obj)) |
1421 |
) |
|
1422 | ||
1423 |
#' @rdname int_methods |
|
1424 | 3185x |
setGeneric("row_cspans<-", function(obj, value) standardGeneric("row_cspans<-")) |
1425 | ||
1426 |
#' @rdname int_methods |
|
1427 |
setMethod("row_cspans<-", "TableRow", function(obj, value) { |
|
1428 | 3185x |
obj@colspans <- value |
1429 | 3185x |
obj |
1430 |
}) |
|
1431 | ||
1432 |
#' @rdname int_methods |
|
1433 |
setMethod("row_cspans<-", "LabelRow", function(obj, value) { |
|
1434 |
stop("attempted to set colspans for LabelRow") # nocov |
|
1435 |
}) |
|
1436 | ||
1437 |
## XXX TODO colapse with above? |
|
1438 |
#' @rdname int_methods |
|
1439 | 40377x |
setGeneric("cell_cspan", function(obj) standardGeneric("cell_cspan")) |
1440 | ||
1441 |
#' @rdname int_methods |
|
1442 |
setMethod( |
|
1443 |
"cell_cspan", "CellValue", |
|
1444 | 40377x |
function(obj) attr(obj, "colspan", exact = TRUE) |
1445 |
) ## obj@colspan) |
|
1446 | ||
1447 |
#' @rdname int_methods |
|
1448 |
setGeneric( |
|
1449 |
"cell_cspan<-", |
|
1450 | 5842x |
function(obj, value) standardGeneric("cell_cspan<-") |
1451 |
) |
|
1452 | ||
1453 |
#' @rdname int_methods |
|
1454 |
setMethod("cell_cspan<-", "CellValue", function(obj, value) { |
|
1455 |
## obj@colspan <- value |
|
1456 | 5842x |
attr(obj, "colspan") <- value |
1457 | 5842x |
obj |
1458 |
}) |
|
1459 | ||
1460 |
#' @rdname int_methods |
|
1461 | 21889x |
setGeneric("cell_align", function(obj) standardGeneric("cell_align")) |
1462 | ||
1463 |
#' @rdname int_methods |
|
1464 |
setMethod( |
|
1465 |
"cell_align", "CellValue", |
|
1466 | 21889x |
function(obj) attr(obj, "align", exact = TRUE) %||% "center" |
1467 |
) ## obj@colspan) |
|
1468 | ||
1469 |
#' @rdname int_methods |
|
1470 |
setGeneric( |
|
1471 |
"cell_align<-", |
|
1472 | 56x |
function(obj, value) standardGeneric("cell_align<-") |
1473 |
) |
|
1474 | ||
1475 |
#' @rdname int_methods |
|
1476 |
setMethod("cell_align<-", "CellValue", function(obj, value) { |
|
1477 |
## obj@colspan <- value |
|
1478 | 56x |
if (is.null(value)) { |
1479 | ! |
value <- "center" |
1480 |
} else { |
|
1481 | 56x |
value <- tolower(value) |
1482 |
} |
|
1483 | 56x |
check_aligns(value) |
1484 | 56x |
attr(obj, "align") <- value |
1485 | 56x |
obj |
1486 |
}) |
|
1487 | ||
1488 |
### Level (indent) in tree structure ---- |
|
1489 | ||
1490 |
#' @rdname int_methods |
|
1491 | 213x |
setGeneric("tt_level", function(obj) standardGeneric("tt_level")) |
1492 | ||
1493 |
## this will hit everything via inheritence |
|
1494 |
#' @rdname int_methods |
|
1495 | 213x |
setMethod("tt_level", "VNodeInfo", function(obj) obj@level) |
1496 | ||
1497 |
#' @rdname int_methods |
|
1498 | 2x |
setGeneric("tt_level<-", function(obj, value) standardGeneric("tt_level<-")) |
1499 | ||
1500 |
## this will hit everyhing via inheritence |
|
1501 |
#' @rdname int_methods |
|
1502 |
setMethod("tt_level<-", "VNodeInfo", function(obj, value) { |
|
1503 | 1x |
obj@level <- as.integer(value) |
1504 | 1x |
obj |
1505 |
}) |
|
1506 | ||
1507 |
#' @rdname int_methods |
|
1508 |
setMethod( |
|
1509 |
"tt_level<-", "VTableTree", |
|
1510 |
function(obj, value) { |
|
1511 | 1x |
obj@level <- as.integer(value) |
1512 | 1x |
tree_children(obj) <- lapply(tree_children(obj), |
1513 | 1x |
`tt_level<-`, |
1514 | 1x |
value = as.integer(value) + 1L |
1515 |
) |
|
1516 | 1x |
obj |
1517 |
} |
|
1518 |
) |
|
1519 | ||
1520 |
#' @rdname int_methods |
|
1521 |
#' @export |
|
1522 | 53314x |
setGeneric("indent_mod", function(obj) standardGeneric("indent_mod")) |
1523 | ||
1524 |
#' @rdname int_methods |
|
1525 |
setMethod( |
|
1526 |
"indent_mod", "Split", |
|
1527 | 2899x |
function(obj) obj@indent_modifier |
1528 |
) |
|
1529 | ||
1530 |
#' @rdname int_methods |
|
1531 |
setMethod( |
|
1532 |
"indent_mod", "VTableNodeInfo", |
|
1533 | 24859x |
function(obj) obj@indent_modifier |
1534 |
) |
|
1535 | ||
1536 |
#' @rdname int_methods |
|
1537 |
setMethod( |
|
1538 |
"indent_mod", "ANY", |
|
1539 | 22468x |
function(obj) attr(obj, "indent_mod", exact = TRUE) %||% 0L |
1540 |
) |
|
1541 | ||
1542 |
#' @rdname int_methods |
|
1543 |
setMethod( |
|
1544 |
"indent_mod", "RowsVerticalSection", |
|
1545 |
## function(obj) setNames(obj@indent_mods,names(obj))) |
|
1546 |
function(obj) { |
|
1547 | 1596x |
val <- attr(obj, "indent_mods", exact = TRUE) %||% |
1548 | 1596x |
vapply(obj, indent_mod, 1L) ## rep(0L, length(obj)) |
1549 | 1596x |
setNames(val, names(obj)) |
1550 |
} |
|
1551 |
) |
|
1552 | ||
1553 |
#' @examples |
|
1554 |
#' indent_mod(tbl) |
|
1555 |
#' indent_mod(tbl) <- 1L |
|
1556 |
#' tbl |
|
1557 |
#' |
|
1558 |
#' @rdname int_methods |
|
1559 |
#' @export |
|
1560 | 1425x |
setGeneric("indent_mod<-", function(obj, value) standardGeneric("indent_mod<-")) |
1561 | ||
1562 |
#' @rdname int_methods |
|
1563 |
setMethod( |
|
1564 |
"indent_mod<-", "Split", |
|
1565 |
function(obj, value) { |
|
1566 | 1x |
obj@indent_modifier <- as.integer(value) |
1567 | 1x |
obj |
1568 |
} |
|
1569 |
) |
|
1570 | ||
1571 |
#' @rdname int_methods |
|
1572 |
setMethod( |
|
1573 |
"indent_mod<-", "VTableNodeInfo", |
|
1574 |
function(obj, value) { |
|
1575 | 1421x |
obj@indent_modifier <- as.integer(value) |
1576 | 1421x |
obj |
1577 |
} |
|
1578 |
) |
|
1579 | ||
1580 |
#' @rdname int_methods |
|
1581 |
setMethod( |
|
1582 |
"indent_mod<-", "CellValue", |
|
1583 |
function(obj, value) { |
|
1584 | 2x |
attr(obj, "indent_mod") <- as.integer(value) |
1585 | 2x |
obj |
1586 |
} |
|
1587 |
) |
|
1588 | ||
1589 |
#' @rdname int_methods |
|
1590 |
setMethod( |
|
1591 |
"indent_mod<-", "RowsVerticalSection", |
|
1592 |
function(obj, value) { |
|
1593 | 1x |
if (length(value) != 1 && length(value) != length(obj)) { |
1594 | ! |
stop( |
1595 | ! |
"When setting indent mods on a RowsVerticalSection the value ", |
1596 | ! |
"must have length 1 or the number of rows" |
1597 |
) |
|
1598 |
} |
|
1599 | 1x |
attr(obj, "indent_mods") <- as.integer(value) |
1600 | 1x |
obj |
1601 | ||
1602 |
## obj@indent_mods <- value |
|
1603 |
## obj |
|
1604 |
} |
|
1605 |
) |
|
1606 | ||
1607 |
#' @rdname int_methods |
|
1608 |
setGeneric( |
|
1609 |
"content_indent_mod", |
|
1610 | 1198x |
function(obj) standardGeneric("content_indent_mod") |
1611 |
) |
|
1612 | ||
1613 |
#' @rdname int_methods |
|
1614 |
setMethod( |
|
1615 |
"content_indent_mod", "Split", |
|
1616 | 1198x |
function(obj) obj@content_indent_modifier |
1617 |
) |
|
1618 | ||
1619 |
#' @rdname int_methods |
|
1620 |
setMethod( |
|
1621 |
"content_indent_mod", "VTableNodeInfo", |
|
1622 | ! |
function(obj) obj@content_indent_modifier |
1623 |
) |
|
1624 | ||
1625 |
#' @rdname int_methods |
|
1626 |
setGeneric( |
|
1627 |
"content_indent_mod<-", |
|
1628 | 105x |
function(obj, value) standardGeneric("content_indent_mod<-") |
1629 |
) |
|
1630 | ||
1631 |
#' @rdname int_methods |
|
1632 |
setMethod( |
|
1633 |
"content_indent_mod<-", "Split", |
|
1634 |
function(obj, value) { |
|
1635 | 105x |
obj@content_indent_modifier <- as.integer(value) |
1636 | 105x |
obj |
1637 |
} |
|
1638 |
) |
|
1639 | ||
1640 |
#' @rdname int_methods |
|
1641 |
setMethod( |
|
1642 |
"content_indent_mod<-", "VTableNodeInfo", |
|
1643 |
function(obj, value) { |
|
1644 | ! |
obj@content_indent_modifier <- as.integer(value) |
1645 | ! |
obj |
1646 |
} |
|
1647 |
) |
|
1648 | ||
1649 |
## TODO export these? |
|
1650 |
#' @rdname int_methods |
|
1651 |
#' @export |
|
1652 | 117185x |
setGeneric("rawvalues", function(obj) standardGeneric("rawvalues")) |
1653 | ||
1654 |
#' @rdname int_methods |
|
1655 | ! |
setMethod("rawvalues", "ValueWrapper", function(obj) obj@value) |
1656 | ||
1657 |
#' @rdname int_methods |
|
1658 | 30x |
setMethod("rawvalues", "LevelComboSplitValue", function(obj) obj@combolevels) |
1659 | ||
1660 |
#' @rdname int_methods |
|
1661 | 3363x |
setMethod("rawvalues", "list", function(obj) lapply(obj, rawvalues)) |
1662 | ||
1663 |
#' @rdname int_methods |
|
1664 | 1753x |
setMethod("rawvalues", "ANY", function(obj) obj) |
1665 | ||
1666 |
#' @rdname int_methods |
|
1667 | 74623x |
setMethod("rawvalues", "CellValue", function(obj) obj[[1]]) |
1668 | ||
1669 |
#' @rdname int_methods |
|
1670 |
setMethod( |
|
1671 |
"rawvalues", "TreePos", |
|
1672 | 228x |
function(obj) rawvalues(pos_splvals(obj)) |
1673 |
) |
|
1674 | ||
1675 |
#' @rdname int_methods |
|
1676 |
setMethod( |
|
1677 |
"rawvalues", "RowsVerticalSection", |
|
1678 | 2x |
function(obj) unlist(obj, recursive = FALSE) |
1679 |
) |
|
1680 | ||
1681 |
#' @rdname int_methods |
|
1682 |
#' @export |
|
1683 | 43406x |
setGeneric("value_names", function(obj) standardGeneric("value_names")) |
1684 | ||
1685 |
#' @rdname int_methods |
|
1686 |
setMethod( |
|
1687 |
"value_names", "ANY", |
|
1688 | 38x |
function(obj) as.character(rawvalues(obj)) |
1689 |
) |
|
1690 | ||
1691 |
#' @rdname int_methods |
|
1692 |
setMethod( |
|
1693 |
"value_names", "TreePos", |
|
1694 | 1580x |
function(obj) value_names(pos_splvals(obj)) |
1695 |
) |
|
1696 | ||
1697 |
#' @rdname int_methods |
|
1698 |
setMethod( |
|
1699 |
"value_names", "list", |
|
1700 | 3553x |
function(obj) lapply(obj, value_names) |
1701 |
) |
|
1702 | ||
1703 |
#' @rdname int_methods |
|
1704 |
setMethod( |
|
1705 |
"value_names", "ValueWrapper", |
|
1706 | ! |
function(obj) rawvalues(obj) |
1707 |
) |
|
1708 | ||
1709 |
#' @rdname int_methods |
|
1710 |
setMethod( |
|
1711 |
"value_names", "LevelComboSplitValue", |
|
1712 | 315x |
function(obj) obj@value |
1713 |
) ## obj@comboname) |
|
1714 | ||
1715 |
#' @rdname int_methods |
|
1716 |
setMethod( |
|
1717 |
"value_names", "RowsVerticalSection", |
|
1718 | 3168x |
function(obj) attr(obj, "row_names", exact = TRUE) |
1719 |
) ## obj@row_names) |
|
1720 | ||
1721 |
## not sure if I need these anywhere |
|
1722 |
## XXX |
|
1723 |
#' @rdname int_methods |
|
1724 | 5482x |
setGeneric("value_labels", function(obj) standardGeneric("value_labels")) |
1725 | ||
1726 |
#' @rdname int_methods |
|
1727 | ! |
setMethod("value_labels", "ANY", function(obj) as.character(obj_label(obj))) |
1728 | ||
1729 |
#' @rdname int_methods |
|
1730 |
setMethod( |
|
1731 |
"value_labels", "TreePos", |
|
1732 | ! |
function(obj) sapply(pos_splvals(obj), obj_label) |
1733 |
) |
|
1734 | ||
1735 |
#' @rdname int_methods |
|
1736 |
setMethod("value_labels", "list", function(obj) { |
|
1737 | 3837x |
ret <- lapply(obj, obj_label) |
1738 | 3837x |
if (!is.null(names(obj))) { |
1739 | 539x |
inds <- vapply(ret, function(x) length(x) == 0, NA) |
1740 | 539x |
ret[inds] <- names(obj)[inds] |
1741 |
} |
|
1742 | 3837x |
ret |
1743 |
}) |
|
1744 | ||
1745 |
#' @rdname int_methods |
|
1746 |
setMethod( |
|
1747 |
"value_labels", |
|
1748 |
"RowsVerticalSection", |
|
1749 | 1597x |
function(obj) setNames(attr(obj, "row_labels", exact = TRUE), value_names(obj)) |
1750 |
) |
|
1751 | ||
1752 |
#' @rdname int_methods |
|
1753 | ! |
setMethod("value_labels", "ValueWrapper", function(obj) obj_label(obj)) |
1754 | ||
1755 |
#' @rdname int_methods |
|
1756 |
setMethod( |
|
1757 |
"value_labels", "LevelComboSplitValue", |
|
1758 | ! |
function(obj) obj_label(obj) |
1759 |
) |
|
1760 | ||
1761 |
#' @rdname int_methods |
|
1762 | 48x |
setMethod("value_labels", "MultiVarSplit", function(obj) obj@var_labels) |
1763 | ||
1764 |
#' @rdname int_methods |
|
1765 | 6x |
setGeneric("spl_varlabels", function(obj) standardGeneric("spl_varlabels")) |
1766 | ||
1767 |
#' @rdname int_methods |
|
1768 | 6x |
setMethod("spl_varlabels", "MultiVarSplit", function(obj) obj@var_labels) |
1769 | ||
1770 |
#' @rdname int_methods |
|
1771 |
setGeneric( |
|
1772 |
"spl_varlabels<-", |
|
1773 | 2x |
function(object, value) standardGeneric("spl_varlabels<-") |
1774 |
) |
|
1775 | ||
1776 |
#' @rdname int_methods |
|
1777 |
setMethod("spl_varlabels<-", "MultiVarSplit", function(object, value) { |
|
1778 | 2x |
object@var_labels <- value |
1779 | 2x |
object |
1780 |
}) |
|
1781 | ||
1782 |
## These two are similar enough we could probably combine |
|
1783 |
## them but conceptually they are pretty different |
|
1784 |
## split_exargs is a list of extra arguments that apply |
|
1785 |
## to *all the chidlren*, |
|
1786 |
## while splv_extra is for *child-specific* extra arguments, |
|
1787 |
## associated with specific values of the split |
|
1788 |
#' @rdname int_methods |
|
1789 | 3064x |
setGeneric("splv_extra", function(obj) standardGeneric("splv_extra")) |
1790 | ||
1791 |
#' @rdname int_methods |
|
1792 |
setMethod( |
|
1793 |
"splv_extra", "SplitValue", |
|
1794 | 3064x |
function(obj) obj@extra |
1795 |
) |
|
1796 | ||
1797 |
#' @rdname int_methods |
|
1798 |
setGeneric( |
|
1799 |
"splv_extra<-", |
|
1800 | 1699x |
function(obj, value) standardGeneric("splv_extra<-") |
1801 |
) |
|
1802 |
#' @rdname int_methods |
|
1803 |
setMethod( |
|
1804 |
"splv_extra<-", "SplitValue", |
|
1805 |
function(obj, value) { |
|
1806 | 1699x |
obj@extra <- value |
1807 | 1699x |
obj |
1808 |
} |
|
1809 |
) |
|
1810 | ||
1811 |
#' @rdname int_methods |
|
1812 | 2118x |
setGeneric("split_exargs", function(obj) standardGeneric("split_exargs")) |
1813 | ||
1814 |
#' @rdname int_methods |
|
1815 |
setMethod( |
|
1816 |
"split_exargs", "Split", |
|
1817 | 2067x |
function(obj) obj@extra_args |
1818 |
) |
|
1819 | ||
1820 |
#' @rdname int_methods |
|
1821 |
setGeneric( |
|
1822 |
"split_exargs<-", |
|
1823 | 1x |
function(obj, value) standardGeneric("split_exargs<-") |
1824 |
) |
|
1825 | ||
1826 |
#' @rdname int_methods |
|
1827 |
setMethod( |
|
1828 |
"split_exargs<-", "Split", |
|
1829 |
function(obj, value) { |
|
1830 | 1x |
obj@extra_args <- value |
1831 | 1x |
obj |
1832 |
} |
|
1833 |
) |
|
1834 | ||
1835 | ! |
is_labrow <- function(obj) is(obj, "LabelRow") |
1836 | ||
1837 |
spl_ref_group <- function(obj) { |
|
1838 | 17x |
stopifnot(is(obj, "VarLevWBaselineSplit")) |
1839 | 17x |
obj@ref_group_value |
1840 |
} |
|
1841 | ||
1842 |
### column info |
|
1843 | ||
1844 |
#' Column information/structure accessors |
|
1845 |
#' |
|
1846 |
#' @inheritParams gen_args |
|
1847 |
#' @param df (`data.frame` or `NULL`)\cr data to use if the column information is being |
|
1848 |
#' generated from a pre-data layout object. |
|
1849 |
#' @param path (`character` or `NULL`)\cr `col_counts` accessor and setter only. |
|
1850 |
#' Path (in column structure). |
|
1851 |
#' @param rtpos (`TreePos`)\cr root position. |
|
1852 |
#' |
|
1853 |
#' @return A `LayoutColTree` object. |
|
1854 |
#' |
|
1855 |
#' @rdname col_accessors |
|
1856 |
#' @export |
|
1857 | 2654x |
setGeneric("clayout", function(obj) standardGeneric("clayout")) |
1858 | ||
1859 |
#' @rdname col_accessors |
|
1860 |
#' @exportMethod clayout |
|
1861 |
setMethod( |
|
1862 |
"clayout", "VTableNodeInfo", |
|
1863 | 7x |
function(obj) coltree(col_info(obj)) |
1864 |
) |
|
1865 | ||
1866 |
#' @rdname col_accessors |
|
1867 |
#' @exportMethod clayout |
|
1868 |
setMethod( |
|
1869 |
"clayout", "PreDataTableLayouts", |
|
1870 | 2647x |
function(obj) obj@col_layout |
1871 |
) |
|
1872 | ||
1873 |
## useful convenience for the cascading methods in colby_constructors |
|
1874 |
#' @rdname col_accessors |
|
1875 |
#' @exportMethod clayout |
|
1876 | ! |
setMethod("clayout", "ANY", function(obj) PreDataColLayout()) |
1877 | ||
1878 |
#' @rdname col_accessors |
|
1879 |
#' @export |
|
1880 | 878x |
setGeneric("clayout<-", function(object, value) standardGeneric("clayout<-")) |
1881 | ||
1882 |
#' @rdname col_accessors |
|
1883 |
#' @exportMethod clayout<- |
|
1884 |
setMethod( |
|
1885 |
"clayout<-", "PreDataTableLayouts", |
|
1886 |
function(object, value) { |
|
1887 | 878x |
object@col_layout <- value |
1888 | 878x |
object |
1889 |
} |
|
1890 |
) |
|
1891 | ||
1892 |
#' @rdname col_accessors |
|
1893 |
#' @export |
|
1894 | 237896x |
setGeneric("col_info", function(obj) standardGeneric("col_info")) |
1895 | ||
1896 |
#' @rdname col_accessors |
|
1897 |
#' @exportMethod col_info |
|
1898 |
setMethod( |
|
1899 |
"col_info", "VTableNodeInfo", |
|
1900 | 207793x |
function(obj) obj@col_info |
1901 |
) |
|
1902 | ||
1903 |
### XXX I've made this recursive. Do we ALWAYS want it to be? |
|
1904 |
### |
|
1905 |
### I think we do. |
|
1906 |
#' @rdname col_accessors |
|
1907 |
#' @export |
|
1908 | 58659x |
setGeneric("col_info<-", function(obj, value) standardGeneric("col_info<-")) |
1909 | ||
1910 |
#' @return Returns various information about columns, depending on the accessor used. |
|
1911 |
#' |
|
1912 |
#' @exportMethod col_info<- |
|
1913 |
#' @rdname col_accessors |
|
1914 |
setMethod( |
|
1915 |
"col_info<-", "TableRow", |
|
1916 |
function(obj, value) { |
|
1917 | 33606x |
obj@col_info <- value |
1918 | 33606x |
obj |
1919 |
} |
|
1920 |
) |
|
1921 | ||
1922 |
.set_cinfo_kids <- function(obj) { |
|
1923 | 19189x |
kids <- lapply( |
1924 | 19189x |
tree_children(obj), |
1925 | 19189x |
function(x) { |
1926 | 42269x |
col_info(x) <- col_info(obj) |
1927 | 42269x |
x |
1928 |
} |
|
1929 |
) |
|
1930 | 19189x |
tree_children(obj) <- kids |
1931 | 19189x |
obj |
1932 |
} |
|
1933 | ||
1934 |
#' @rdname col_accessors |
|
1935 |
#' @exportMethod col_info<- |
|
1936 |
setMethod( |
|
1937 |
"col_info<-", "ElementaryTable", |
|
1938 |
function(obj, value) { |
|
1939 | 12194x |
obj@col_info <- value |
1940 | 12194x |
.set_cinfo_kids(obj) |
1941 |
} |
|
1942 |
) |
|
1943 | ||
1944 |
#' @rdname col_accessors |
|
1945 |
#' @exportMethod col_info<- |
|
1946 |
setMethod( |
|
1947 |
"col_info<-", "TableTree", |
|
1948 |
function(obj, value) { |
|
1949 | 6995x |
obj@col_info <- value |
1950 | 6995x |
if (nrow(content_table(obj))) { |
1951 | 1902x |
ct <- content_table(obj) |
1952 | 1902x |
col_info(ct) <- value |
1953 | 1902x |
content_table(obj) <- ct |
1954 |
} |
|
1955 | 6995x |
.set_cinfo_kids(obj) |
1956 |
} |
|
1957 |
) |
|
1958 | ||
1959 |
#' @rdname col_accessors |
|
1960 |
#' @export |
|
1961 |
setGeneric( |
|
1962 |
"coltree", |
|
1963 | 8900x |
function(obj, df = NULL, rtpos = TreePos()) standardGeneric("coltree") |
1964 |
) |
|
1965 | ||
1966 |
#' @rdname col_accessors |
|
1967 |
#' @exportMethod coltree |
|
1968 |
setMethod( |
|
1969 |
"coltree", "InstantiatedColumnInfo", |
|
1970 |
function(obj, df = NULL, rtpos = TreePos()) { |
|
1971 | 7071x |
if (!is.null(df)) { |
1972 | ! |
warning("Ignoring df argument and retrieving already-computed LayoutColTree") |
1973 |
} |
|
1974 | 7071x |
obj@tree_layout |
1975 |
} |
|
1976 |
) |
|
1977 | ||
1978 |
#' @rdname col_accessors |
|
1979 |
#' @export coltree |
|
1980 |
setMethod( |
|
1981 |
"coltree", "PreDataTableLayouts", |
|
1982 |
function(obj, df, rtpos) coltree(clayout(obj), df, rtpos) |
|
1983 |
) |
|
1984 | ||
1985 |
#' @rdname col_accessors |
|
1986 |
#' @export coltree |
|
1987 |
setMethod( |
|
1988 |
"coltree", "PreDataColLayout", |
|
1989 |
function(obj, df, rtpos) { |
|
1990 | 308x |
obj <- set_def_child_ord(obj, df) |
1991 | 308x |
kids <- lapply( |
1992 | 308x |
obj, |
1993 | 308x |
function(x) { |
1994 | 313x |
splitvec_to_coltree( |
1995 | 313x |
df = df, |
1996 | 313x |
splvec = x, |
1997 | 313x |
pos = rtpos |
1998 |
) |
|
1999 |
} |
|
2000 |
) |
|
2001 | 304x |
if (length(kids) == 1) { |
2002 | 300x |
res <- kids[[1]] |
2003 |
} else { |
|
2004 | 4x |
res <- LayoutColTree( |
2005 | 4x |
lev = 0L, |
2006 | 4x |
kids = kids, |
2007 | 4x |
tpos = rtpos, |
2008 | 4x |
spl = RootSplit() |
2009 |
) |
|
2010 |
} |
|
2011 | 304x |
disp_ccounts(res) <- disp_ccounts(obj) |
2012 | 304x |
res |
2013 |
} |
|
2014 |
) |
|
2015 | ||
2016 |
#' @rdname col_accessors |
|
2017 |
#' @export coltree |
|
2018 |
setMethod( |
|
2019 |
"coltree", "LayoutColTree", |
|
2020 |
function(obj, df, rtpos) obj |
|
2021 |
) |
|
2022 | ||
2023 |
#' @rdname col_accessors |
|
2024 |
#' @export coltree |
|
2025 |
setMethod( |
|
2026 |
"coltree", "VTableTree", |
|
2027 |
function(obj, df, rtpos) coltree(col_info(obj)) |
|
2028 |
) |
|
2029 | ||
2030 |
#' @rdname col_accessors |
|
2031 |
#' @export coltree |
|
2032 |
setMethod( |
|
2033 |
"coltree", "TableRow", |
|
2034 |
function(obj, df, rtpos) coltree(col_info(obj)) |
|
2035 |
) |
|
2036 | ||
2037 | 813x |
setGeneric("coltree<-", function(obj, value) standardGeneric("coltree<-")) |
2038 |
setMethod( |
|
2039 |
"coltree<-", c("InstantiatedColumnInfo", "LayoutColTree"), |
|
2040 |
function(obj, value) { |
|
2041 | 407x |
obj@tree_layout <- value |
2042 | 407x |
obj |
2043 |
} |
|
2044 |
) |
|
2045 | ||
2046 |
setMethod( |
|
2047 |
"coltree<-", c("VTableTree", "LayoutColTree"), |
|
2048 |
function(obj, value) { |
|
2049 | 406x |
cinfo <- col_info(obj) |
2050 | 406x |
coltree(cinfo) <- value |
2051 | 406x |
col_info(obj) <- cinfo |
2052 | 406x |
obj |
2053 |
} |
|
2054 |
) |
|
2055 | ||
2056 |
#' @rdname col_accessors |
|
2057 |
#' @export |
|
2058 | 110889x |
setGeneric("col_exprs", function(obj, df = NULL) standardGeneric("col_exprs")) |
2059 | ||
2060 |
#' @rdname col_accessors |
|
2061 |
#' @export col_exprs |
|
2062 |
setMethod( |
|
2063 |
"col_exprs", "PreDataTableLayouts", |
|
2064 | 1x |
function(obj, df = NULL) col_exprs(clayout(obj), df) |
2065 |
) |
|
2066 | ||
2067 |
#' @rdname col_accessors |
|
2068 |
#' @export col_exprs |
|
2069 |
setMethod( |
|
2070 |
"col_exprs", "PreDataColLayout", |
|
2071 |
function(obj, df = NULL) { |
|
2072 | 1x |
if (is.null(df)) { |
2073 | ! |
stop("can't determine col_exprs without data") |
2074 |
} |
|
2075 | 1x |
ct <- coltree(obj, df = df) |
2076 | 1x |
make_col_subsets(ct, df = df) |
2077 |
} |
|
2078 |
) |
|
2079 | ||
2080 |
#' @rdname col_accessors |
|
2081 |
#' @export col_exprs |
|
2082 |
setMethod( |
|
2083 |
"col_exprs", "InstantiatedColumnInfo", |
|
2084 |
function(obj, df = NULL) { |
|
2085 | 110887x |
if (!is.null(df)) { |
2086 | ! |
warning("Ignoring df method when extracted precomputed column subsetting expressions.") |
2087 |
} |
|
2088 | 110887x |
obj@subset_exprs |
2089 |
} |
|
2090 |
) |
|
2091 | ||
2092 |
#' @rdname int_methods |
|
2093 | 2494x |
setGeneric("col_extra_args", function(obj, df = NULL) standardGeneric("col_extra_args")) |
2094 | ||
2095 |
#' @rdname int_methods |
|
2096 |
setMethod( |
|
2097 |
"col_extra_args", "InstantiatedColumnInfo", |
|
2098 |
function(obj, df) { |
|
2099 | 2190x |
if (!is.null(df)) { |
2100 | ! |
warning("Ignorning df when retrieving already-computed column extra arguments.") |
2101 |
} |
|
2102 | 2190x |
obj@cextra_args |
2103 |
} |
|
2104 |
) |
|
2105 | ||
2106 |
#' @rdname int_methods |
|
2107 |
setMethod( |
|
2108 |
"col_extra_args", "PreDataTableLayouts", |
|
2109 |
function(obj, df) col_extra_args(clayout(obj), df) |
|
2110 |
) |
|
2111 | ||
2112 |
#' @rdname int_methods |
|
2113 |
setMethod( |
|
2114 |
"col_extra_args", "PreDataColLayout", |
|
2115 |
function(obj, df) { |
|
2116 | ! |
col_extra_args(coltree(obj, df), NULL) |
2117 |
} |
|
2118 |
) |
|
2119 | ||
2120 |
#' @rdname int_methods |
|
2121 |
setMethod( |
|
2122 |
"col_extra_args", "LayoutColTree", |
|
2123 |
function(obj, df) { |
|
2124 | 304x |
if (!is.null(df)) { |
2125 | ! |
warning("Ignoring df argument and returning already calculated extra arguments") |
2126 |
} |
|
2127 | 304x |
get_col_extras(obj) |
2128 |
} |
|
2129 |
) |
|
2130 | ||
2131 |
#' @rdname int_methods |
|
2132 |
setMethod( |
|
2133 |
"col_extra_args", "LayoutColLeaf", |
|
2134 |
function(obj, df) { |
|
2135 | ! |
if (!is.null(df)) { |
2136 | ! |
warning("Ignoring df argument and returning already calculated extra arguments") |
2137 |
} |
|
2138 | ||
2139 | ! |
get_pos_extra(pos = tree_pos(obj)) |
2140 |
} |
|
2141 |
) |
|
2142 | ||
2143 |
#' @export |
|
2144 |
#' @rdname col_accessors |
|
2145 | 2015x |
setGeneric("col_counts", function(obj, path = NULL) standardGeneric("col_counts")) |
2146 | ||
2147 |
#' @export |
|
2148 |
#' @rdname col_accessors |
|
2149 |
setMethod( |
|
2150 |
"col_counts", "InstantiatedColumnInfo", |
|
2151 | 2003x |
function(obj, path = NULL) obj@counts[.path_to_pos(path, obj, cols = TRUE)] |
2152 |
) |
|
2153 | ||
2154 |
#' @export |
|
2155 |
#' @rdname col_accessors |
|
2156 |
setMethod( |
|
2157 |
"col_counts", "VTableNodeInfo", |
|
2158 | 12x |
function(obj, path = NULL) col_counts(col_info(obj), path = path) |
2159 |
) |
|
2160 | ||
2161 |
#' @export |
|
2162 |
#' @rdname col_accessors |
|
2163 | 5x |
setGeneric("col_counts<-", function(obj, path = NULL, value) standardGeneric("col_counts<-")) |
2164 | ||
2165 |
#' @export |
|
2166 |
#' @rdname col_accessors |
|
2167 |
setMethod( |
|
2168 |
"col_counts<-", "InstantiatedColumnInfo", |
|
2169 |
function(obj, path = NULL, value) { |
|
2170 | 3x |
obj@counts[.path_to_pos(path, obj, cols = TRUE)] <- value |
2171 | 3x |
obj |
2172 |
} |
|
2173 |
) |
|
2174 | ||
2175 |
#' @export |
|
2176 |
#' @rdname col_accessors |
|
2177 |
setMethod( |
|
2178 |
"col_counts<-", "VTableNodeInfo", |
|
2179 |
function(obj, path = NULL, value) { |
|
2180 | 2x |
cinfo <- col_info(obj) |
2181 | 2x |
col_counts(cinfo, path = path) <- value |
2182 | 2x |
col_info(obj) <- cinfo |
2183 | 2x |
obj |
2184 |
} |
|
2185 |
) |
|
2186 | ||
2187 |
#' @export |
|
2188 |
#' @rdname col_accessors |
|
2189 | 1577x |
setGeneric("col_total", function(obj) standardGeneric("col_total")) |
2190 | ||
2191 |
#' @export |
|
2192 |
#' @rdname col_accessors |
|
2193 |
setMethod( |
|
2194 |
"col_total", "InstantiatedColumnInfo", |
|
2195 | 1576x |
function(obj) obj@total_count |
2196 |
) |
|
2197 | ||
2198 |
#' @export |
|
2199 |
#' @rdname col_accessors |
|
2200 |
setMethod( |
|
2201 |
"col_total", "VTableNodeInfo", |
|
2202 | 1x |
function(obj) col_total(col_info(obj)) |
2203 |
) |
|
2204 | ||
2205 |
#' @export |
|
2206 |
#' @rdname col_accessors |
|
2207 | 2x |
setGeneric("col_total<-", function(obj, value) standardGeneric("col_total<-")) |
2208 | ||
2209 |
#' @export |
|
2210 |
#' @rdname col_accessors |
|
2211 |
setMethod( |
|
2212 |
"col_total<-", "InstantiatedColumnInfo", |
|
2213 |
function(obj, value) { |
|
2214 | 1x |
obj@total_count <- value |
2215 | 1x |
obj |
2216 |
} |
|
2217 |
) |
|
2218 | ||
2219 |
#' @export |
|
2220 |
#' @rdname col_accessors |
|
2221 |
setMethod( |
|
2222 |
"col_total<-", "VTableNodeInfo", |
|
2223 |
function(obj, value) { |
|
2224 | 1x |
cinfo <- col_info(obj) |
2225 | 1x |
col_total(cinfo) <- value |
2226 | 1x |
col_info(obj) <- cinfo |
2227 | 1x |
obj |
2228 |
} |
|
2229 |
) |
|
2230 | ||
2231 |
#' @rdname int_methods |
|
2232 | 2086x |
setGeneric("disp_ccounts", function(obj) standardGeneric("disp_ccounts")) |
2233 | ||
2234 |
#' @rdname int_methods |
|
2235 |
setMethod( |
|
2236 |
"disp_ccounts", "VTableTree", |
|
2237 | 304x |
function(obj) disp_ccounts(col_info(obj)) |
2238 |
) |
|
2239 | ||
2240 |
#' @rdname int_methods |
|
2241 |
setMethod( |
|
2242 |
"disp_ccounts", "InstantiatedColumnInfo", |
|
2243 | 884x |
function(obj) obj@display_columncounts |
2244 |
) |
|
2245 | ||
2246 |
#' @rdname int_methods |
|
2247 |
setMethod( |
|
2248 |
"disp_ccounts", "PreDataTableLayouts", |
|
2249 | 297x |
function(obj) disp_ccounts(clayout(obj)) |
2250 |
) |
|
2251 | ||
2252 |
#' @rdname int_methods |
|
2253 |
setMethod( |
|
2254 |
"disp_ccounts", "PreDataColLayout", |
|
2255 | 601x |
function(obj) obj@display_columncounts |
2256 |
) |
|
2257 | ||
2258 |
#' @rdname int_methods |
|
2259 | 458x |
setGeneric("disp_ccounts<-", function(obj, value) standardGeneric("disp_ccounts<-")) |
2260 | ||
2261 |
#' @rdname int_methods |
|
2262 |
setMethod( |
|
2263 |
"disp_ccounts<-", "VTableTree", |
|
2264 |
function(obj, value) { |
|
2265 | 1x |
cinfo <- col_info(obj) |
2266 | 1x |
disp_ccounts(cinfo) <- value |
2267 | 1x |
col_info(obj) <- cinfo |
2268 | 1x |
obj |
2269 |
} |
|
2270 |
) |
|
2271 | ||
2272 |
#' @rdname int_methods |
|
2273 |
setMethod( |
|
2274 |
"disp_ccounts<-", "InstantiatedColumnInfo", |
|
2275 |
function(obj, value) { |
|
2276 | 3x |
obj@display_columncounts <- value |
2277 | 3x |
obj |
2278 |
} |
|
2279 |
) |
|
2280 | ||
2281 |
#' @rdname int_methods |
|
2282 |
setMethod( |
|
2283 |
"disp_ccounts<-", "PreDataColLayout", |
|
2284 |
function(obj, value) { |
|
2285 | 75x |
obj@display_columncounts <- value |
2286 | 75x |
obj |
2287 |
} |
|
2288 |
) |
|
2289 | ||
2290 |
#' @rdname int_methods |
|
2291 |
setMethod( |
|
2292 |
"disp_ccounts<-", "LayoutColTree", |
|
2293 |
function(obj, value) { |
|
2294 | 304x |
obj@display_columncounts <- value |
2295 | 304x |
obj |
2296 |
} |
|
2297 |
) |
|
2298 | ||
2299 |
#' @rdname int_methods |
|
2300 |
setMethod( |
|
2301 |
"disp_ccounts<-", "PreDataTableLayouts", |
|
2302 |
function(obj, value) { |
|
2303 | 75x |
clyt <- clayout(obj) |
2304 | 75x |
disp_ccounts(clyt) <- value |
2305 | 75x |
clayout(obj) <- clyt |
2306 | 75x |
obj |
2307 |
} |
|
2308 |
) |
|
2309 | ||
2310 |
#' @rdname int_methods |
|
2311 |
#' @export |
|
2312 | 997x |
setGeneric("colcount_format", function(obj) standardGeneric("colcount_format")) |
2313 | ||
2314 |
#' @rdname int_methods |
|
2315 |
#' @export |
|
2316 |
setMethod( |
|
2317 |
"colcount_format", "InstantiatedColumnInfo", |
|
2318 | 359x |
function(obj) obj@columncount_format |
2319 |
) |
|
2320 | ||
2321 |
#' @rdname int_methods |
|
2322 |
#' @export |
|
2323 |
setMethod( |
|
2324 |
"colcount_format", "VTableNodeInfo", |
|
2325 | 44x |
function(obj) colcount_format(col_info(obj)) |
2326 |
) |
|
2327 | ||
2328 |
#' @rdname int_methods |
|
2329 |
#' @export |
|
2330 |
setMethod( |
|
2331 |
"colcount_format", "PreDataColLayout", |
|
2332 | 297x |
function(obj) obj@columncount_format |
2333 |
) |
|
2334 | ||
2335 |
#' @rdname int_methods |
|
2336 |
#' @export |
|
2337 |
setMethod( |
|
2338 |
"colcount_format", "PreDataTableLayouts", |
|
2339 | 297x |
function(obj) colcount_format(clayout(obj)) |
2340 |
) |
|
2341 | ||
2342 |
#' @rdname int_methods |
|
2343 |
#' @export |
|
2344 |
setGeneric( |
|
2345 |
"colcount_format<-", |
|
2346 | 152x |
function(obj, value) standardGeneric("colcount_format<-") |
2347 |
) |
|
2348 | ||
2349 |
#' @export |
|
2350 |
#' @rdname int_methods |
|
2351 |
setMethod( |
|
2352 |
"colcount_format<-", "InstantiatedColumnInfo", |
|
2353 |
function(obj, value) { |
|
2354 | 1x |
obj@columncount_format <- value |
2355 | 1x |
obj |
2356 |
} |
|
2357 |
) |
|
2358 | ||
2359 |
#' @rdname int_methods |
|
2360 |
#' @export |
|
2361 |
setMethod( |
|
2362 |
"colcount_format<-", "VTableNodeInfo", |
|
2363 |
function(obj, value) { |
|
2364 | 1x |
cinfo <- col_info(obj) |
2365 | 1x |
colcount_format(cinfo) <- value |
2366 | 1x |
col_info(obj) <- cinfo |
2367 | 1x |
obj |
2368 |
} |
|
2369 |
) |
|
2370 | ||
2371 |
#' @rdname int_methods |
|
2372 |
#' @export |
|
2373 |
setMethod( |
|
2374 |
"colcount_format<-", "PreDataColLayout", |
|
2375 |
function(obj, value) { |
|
2376 | 75x |
obj@columncount_format <- value |
2377 | 75x |
obj |
2378 |
} |
|
2379 |
) |
|
2380 | ||
2381 |
#' @rdname int_methods |
|
2382 |
#' @export |
|
2383 |
setMethod( |
|
2384 |
"colcount_format<-", "PreDataTableLayouts", |
|
2385 |
function(obj, value) { |
|
2386 | 75x |
clyt <- clayout(obj) |
2387 | 75x |
colcount_format(clyt) <- value |
2388 | 75x |
clayout(obj) <- clyt |
2389 | 75x |
obj |
2390 |
} |
|
2391 |
) |
|
2392 | ||
2393 |
#' Exported for use in `tern` |
|
2394 |
#' |
|
2395 |
#' Does the `table`/`row`/`InstantiatedColumnInfo` object contain no column structure information? |
|
2396 |
#' |
|
2397 |
#' @inheritParams gen_args |
|
2398 |
#' |
|
2399 |
#' @return `TRUE` if the object has no/empty instantiated column information, `FALSE` otherwise. |
|
2400 |
#' |
|
2401 |
#' @rdname no_info |
|
2402 |
#' @export |
|
2403 | 160638x |
setGeneric("no_colinfo", function(obj) standardGeneric("no_colinfo")) |
2404 | ||
2405 |
#' @exportMethod no_colinfo |
|
2406 |
#' @rdname no_info |
|
2407 |
setMethod( |
|
2408 |
"no_colinfo", "VTableNodeInfo", |
|
2409 | 67760x |
function(obj) no_colinfo(col_info(obj)) |
2410 |
) |
|
2411 | ||
2412 |
#' @exportMethod no_colinfo |
|
2413 |
#' @rdname no_info |
|
2414 |
setMethod( |
|
2415 |
"no_colinfo", "InstantiatedColumnInfo", |
|
2416 | 83276x |
function(obj) length(obj@subset_exprs) == 0 |
2417 |
) ## identical(obj, EmptyColInfo)) |
|
2418 | ||
2419 |
#' Names of a `TableTree` |
|
2420 |
#' |
|
2421 |
#' @param x (`TableTree`)\cr the object. |
|
2422 |
#' |
|
2423 |
#' @details |
|
2424 |
#' For `TableTree`s with more than one level of splitting in columns, the names are defined to be the top-level |
|
2425 |
#' split values repped out across the columns that they span. |
|
2426 |
#' |
|
2427 |
#' @return The column names of `x`, as defined in the details above. |
|
2428 |
#' |
|
2429 |
#' @exportMethod names |
|
2430 |
#' @rdname names |
|
2431 |
setMethod( |
|
2432 |
"names", "VTableNodeInfo", |
|
2433 | 91x |
function(x) names(col_info(x)) |
2434 |
) |
|
2435 | ||
2436 |
#' @rdname names |
|
2437 |
#' @exportMethod names |
|
2438 |
setMethod( |
|
2439 |
"names", "InstantiatedColumnInfo", |
|
2440 | 91x |
function(x) names(coltree(x)) |
2441 |
) |
|
2442 | ||
2443 |
#' @rdname names |
|
2444 |
#' @exportMethod names |
|
2445 |
setMethod( |
|
2446 |
"names", "LayoutColTree", |
|
2447 |
function(x) { |
|
2448 | 91x |
unname(unlist(lapply( |
2449 | 91x |
tree_children(x), |
2450 | 91x |
function(obj) { |
2451 | 130x |
nm <- obj_name(obj) |
2452 | 130x |
rep(nm, n_leaves(obj)) |
2453 |
} |
|
2454 |
))) |
|
2455 |
} |
|
2456 |
) |
|
2457 | ||
2458 |
#' @rdname names |
|
2459 |
#' @exportMethod row.names |
|
2460 |
setMethod( |
|
2461 |
"row.names", "VTableTree", |
|
2462 |
function(x) { |
|
2463 | 102x |
unname(sapply(collect_leaves(x, add.labrows = TRUE), |
2464 | 102x |
obj_label, |
2465 | 102x |
USE.NAMES = FALSE |
2466 | 102x |
)) ## XXXX this should probably be obj_name??? |
2467 |
} |
|
2468 |
) |
|
2469 | ||
2470 |
#' Convert to a vector |
|
2471 |
#' |
|
2472 |
#' Convert an `rtables` framework object into a vector, if possible. This is unlikely to be useful in |
|
2473 |
#' realistic scenarios. |
|
2474 |
#' |
|
2475 |
#' @param x (`ANY`)\cr the object to be converted to a vector. |
|
2476 |
#' @param mode (`string`)\cr passed on to [as.vector()]. |
|
2477 |
#' |
|
2478 |
#' @return A vector of the chosen mode (or an error is raised if more than one row was present). |
|
2479 |
#' |
|
2480 |
#' @note This only works for a table with a single row or a row object. |
|
2481 |
#' |
|
2482 |
#' @name asvec |
|
2483 |
#' @aliases as.vector,VTableTree-method |
|
2484 |
#' @exportMethod as.vector |
|
2485 |
setMethod("as.vector", "VTableTree", function(x, mode) { |
|
2486 | 12x |
stopifnot(nrow(x) == 1L) |
2487 | 12x |
if (nrow(content_table(x)) == 1L) { |
2488 | ! |
tab <- content_table(x) |
2489 |
} else { |
|
2490 | 12x |
tab <- x |
2491 |
} |
|
2492 | 12x |
as.vector(tree_children(tab)[[1]], mode = mode) |
2493 |
}) |
|
2494 | ||
2495 |
#' @inheritParams asvec |
|
2496 |
#' |
|
2497 |
#' @rdname int_methods |
|
2498 |
#' @exportMethod as.vector |
|
2499 |
setMethod("as.vector", "TableRow", function(x, mode) as.vector(unlist(row_values(x)), mode = mode)) |
|
2500 | ||
2501 |
#' @rdname int_methods |
|
2502 |
#' @exportMethod as.vector |
|
2503 |
setMethod("as.vector", "ElementaryTable", function(x, mode) { |
|
2504 | 2x |
stopifnot(nrow(x) == 1L) |
2505 | 2x |
as.vector(tree_children(x)[[1]], mode = mode) |
2506 |
}) |
|
2507 | ||
2508 |
## cuts ---- |
|
2509 | ||
2510 |
#' @rdname int_methods |
|
2511 | 154x |
setGeneric("spl_cuts", function(obj) standardGeneric("spl_cuts")) |
2512 | ||
2513 |
#' @rdname int_methods |
|
2514 |
setMethod( |
|
2515 |
"spl_cuts", "VarStaticCutSplit", |
|
2516 | 154x |
function(obj) obj@cuts |
2517 |
) |
|
2518 | ||
2519 |
#' @rdname int_methods |
|
2520 | 198x |
setGeneric("spl_cutlabels", function(obj) standardGeneric("spl_cutlabels")) |
2521 | ||
2522 |
#' @rdname int_methods |
|
2523 |
setMethod( |
|
2524 |
"spl_cutlabels", "VarStaticCutSplit", |
|
2525 | 198x |
function(obj) obj@cut_labels |
2526 |
) |
|
2527 | ||
2528 |
#' @rdname int_methods |
|
2529 | 5x |
setGeneric("spl_cutfun", function(obj) standardGeneric("spl_cutfun")) |
2530 | ||
2531 |
#' @rdname int_methods |
|
2532 |
setMethod( |
|
2533 |
"spl_cutfun", "VarDynCutSplit", |
|
2534 | 5x |
function(obj) obj@cut_fun |
2535 |
) |
|
2536 | ||
2537 |
#' @rdname int_methods |
|
2538 | 5x |
setGeneric("spl_cutlabelfun", function(obj) standardGeneric("spl_cutlabelfun")) |
2539 | ||
2540 |
#' @rdname int_methods |
|
2541 |
setMethod( |
|
2542 |
"spl_cutlabelfun", "VarDynCutSplit", |
|
2543 | 5x |
function(obj) obj@cut_label_fun |
2544 |
) |
|
2545 | ||
2546 |
#' @rdname int_methods |
|
2547 | 5x |
setGeneric("spl_is_cmlcuts", function(obj) standardGeneric("spl_is_cmlcuts")) |
2548 | ||
2549 |
#' @rdname int_methods |
|
2550 |
setMethod( |
|
2551 |
"spl_is_cmlcuts", "VarDynCutSplit", |
|
2552 | 5x |
function(obj) obj@cumulative_cuts |
2553 |
) |
|
2554 | ||
2555 |
#' @rdname int_methods |
|
2556 |
setGeneric( |
|
2557 |
"spl_varnames", |
|
2558 | 198x |
function(obj) standardGeneric("spl_varnames") |
2559 |
) |
|
2560 | ||
2561 |
#' @rdname int_methods |
|
2562 |
setMethod( |
|
2563 |
"spl_varnames", "MultiVarSplit", |
|
2564 | 198x |
function(obj) obj@var_names |
2565 |
) |
|
2566 | ||
2567 |
#' @rdname int_methods |
|
2568 |
setGeneric( |
|
2569 |
"spl_varnames<-", |
|
2570 | 2x |
function(object, value) standardGeneric("spl_varnames<-") |
2571 |
) |
|
2572 | ||
2573 |
#' @rdname int_methods |
|
2574 |
setMethod( |
|
2575 |
"spl_varnames<-", "MultiVarSplit", |
|
2576 |
function(object, value) { |
|
2577 | 2x |
oldvnms <- spl_varnames(object) |
2578 | 2x |
oldvlbls <- spl_varlabels(object) |
2579 | 2x |
object@var_names <- value |
2580 | 2x |
if (identical(oldvnms, oldvlbls)) { |
2581 | 1x |
spl_varlabels(object) <- value |
2582 |
} |
|
2583 | 2x |
object |
2584 |
} |
|
2585 |
) |
|
2586 | ||
2587 |
#' Top left material |
|
2588 |
#' |
|
2589 |
#' A `TableTree` object can have *top left material* which is a sequence of strings which are printed in the |
|
2590 |
#' area of the table between the column header display and the label of the first row. These functions access |
|
2591 |
#' and modify that material. |
|
2592 |
#' |
|
2593 |
#' @inheritParams gen_args |
|
2594 |
#' |
|
2595 |
#' @return A character vector representing the top-left material of `obj` (or `obj` after modification, in the |
|
2596 |
#' case of the setter). |
|
2597 |
#' |
|
2598 |
#' @export |
|
2599 |
#' @rdname top_left |
|
2600 | 6050x |
setGeneric("top_left", function(obj) standardGeneric("top_left")) |
2601 | ||
2602 |
#' @export |
|
2603 |
#' @rdname top_left |
|
2604 | 2594x |
setMethod("top_left", "VTableTree", function(obj) top_left(col_info(obj))) |
2605 | ||
2606 |
#' @export |
|
2607 |
#' @rdname top_left |
|
2608 | 3149x |
setMethod("top_left", "InstantiatedColumnInfo", function(obj) obj@top_left) |
2609 | ||
2610 |
#' @export |
|
2611 |
#' @rdname top_left |
|
2612 | 307x |
setMethod("top_left", "PreDataTableLayouts", function(obj) obj@top_left) |
2613 | ||
2614 |
#' @export |
|
2615 |
#' @rdname top_left |
|
2616 | 5119x |
setGeneric("top_left<-", function(obj, value) standardGeneric("top_left<-")) |
2617 | ||
2618 |
#' @export |
|
2619 |
#' @rdname top_left |
|
2620 |
setMethod("top_left<-", "VTableTree", function(obj, value) { |
|
2621 | 2559x |
cinfo <- col_info(obj) |
2622 | 2559x |
top_left(cinfo) <- value |
2623 | 2559x |
col_info(obj) <- cinfo |
2624 | 2559x |
obj |
2625 |
}) |
|
2626 | ||
2627 |
#' @export |
|
2628 |
#' @rdname top_left |
|
2629 |
setMethod("top_left<-", "InstantiatedColumnInfo", function(obj, value) { |
|
2630 | 2559x |
obj@top_left <- value |
2631 | 2559x |
obj |
2632 |
}) |
|
2633 | ||
2634 |
#' @export |
|
2635 |
#' @rdname top_left |
|
2636 |
setMethod("top_left<-", "PreDataTableLayouts", function(obj, value) { |
|
2637 | 1x |
obj@top_left <- value |
2638 | 1x |
obj |
2639 |
}) |
|
2640 | ||
2641 |
vil_collapse <- function(x) { |
|
2642 | 14x |
x <- unlist(x) |
2643 | 14x |
x <- x[!is.na(x)] |
2644 | 14x |
x <- unique(x) |
2645 | 14x |
x[nzchar(x)] |
2646 |
} |
|
2647 | ||
2648 |
#' List variables required by a pre-data table layout |
|
2649 |
#' |
|
2650 |
#' @param lyt (`PreDataTableLayouts`)\cr the layout (or a component thereof). |
|
2651 |
#' |
|
2652 |
#' @details |
|
2653 |
#' This will walk the layout declaration and return a vector of the names of the unique variables that are used |
|
2654 |
#' in any of the following ways: |
|
2655 |
#' |
|
2656 |
#' * Variable being split on (directly or via cuts) |
|
2657 |
#' * Element of a Multi-variable column split |
|
2658 |
#' * Content variable |
|
2659 |
#' * Value-label variable |
|
2660 |
#' |
|
2661 |
#' @return A character vector containing the unique variables explicitly used in the layout (see the notes below). |
|
2662 |
#' |
|
2663 |
#' @note |
|
2664 |
#' * This function will not detect dependencies implicit in analysis or summary functions which accept `x` |
|
2665 |
#' or `df` and then rely on the existence of particular variables not being split on/analyzed. |
|
2666 |
#' * The order these variable names appear within the return vector is undefined and should not be relied upon. |
|
2667 |
#' |
|
2668 |
#' @examples |
|
2669 |
#' lyt <- basic_table() %>% |
|
2670 |
#' split_cols_by("ARM") %>% |
|
2671 |
#' split_cols_by("SEX") %>% |
|
2672 |
#' summarize_row_groups(label_fstr = "Overall (N)") %>% |
|
2673 |
#' split_rows_by("RACE", |
|
2674 |
#' split_label = "Ethnicity", labels_var = "ethn_lab", |
|
2675 |
#' split_fun = drop_split_levels |
|
2676 |
#' ) %>% |
|
2677 |
#' summarize_row_groups("RACE", label_fstr = "%s (n)") %>% |
|
2678 |
#' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx") |
|
2679 |
#' |
|
2680 |
#' vars_in_layout(lyt) |
|
2681 |
#' |
|
2682 |
#' @export |
|
2683 |
#' @rdname vil |
|
2684 | 15x |
setGeneric("vars_in_layout", function(lyt) standardGeneric("vars_in_layout")) |
2685 | ||
2686 |
#' @rdname vil |
|
2687 |
setMethod( |
|
2688 |
"vars_in_layout", "PreDataTableLayouts", |
|
2689 |
function(lyt) { |
|
2690 | 1x |
vil_collapse(c( |
2691 | 1x |
vars_in_layout(clayout(lyt)), |
2692 | 1x |
vars_in_layout(rlayout(lyt)) |
2693 |
)) |
|
2694 |
} |
|
2695 |
) |
|
2696 | ||
2697 |
#' @rdname vil |
|
2698 |
setMethod( |
|
2699 |
"vars_in_layout", "PreDataAxisLayout", |
|
2700 |
function(lyt) { |
|
2701 | 2x |
vil_collapse(lapply(lyt, vars_in_layout)) |
2702 |
} |
|
2703 |
) |
|
2704 | ||
2705 |
#' @rdname vil |
|
2706 |
setMethod( |
|
2707 |
"vars_in_layout", "SplitVector", |
|
2708 |
function(lyt) { |
|
2709 | 3x |
vil_collapse(lapply(lyt, vars_in_layout)) |
2710 |
} |
|
2711 |
) |
|
2712 | ||
2713 |
#' @rdname vil |
|
2714 |
setMethod( |
|
2715 |
"vars_in_layout", "Split", |
|
2716 |
function(lyt) { |
|
2717 | 7x |
vil_collapse(c( |
2718 | 7x |
spl_payload(lyt), |
2719 |
## for an AllSplit/RootSplit |
|
2720 |
## doesn't have to be same as payload |
|
2721 | 7x |
content_var(lyt), |
2722 | 7x |
spl_label_var(lyt) |
2723 |
)) |
|
2724 |
} |
|
2725 |
) |
|
2726 | ||
2727 |
#' @rdname vil |
|
2728 |
setMethod( |
|
2729 |
"vars_in_layout", "CompoundSplit", |
|
2730 | 1x |
function(lyt) vil_collapse(lapply(spl_payload(lyt), vars_in_layout)) |
2731 |
) |
|
2732 | ||
2733 |
#' @rdname vil |
|
2734 |
setMethod( |
|
2735 |
"vars_in_layout", "ManualSplit", |
|
2736 | 1x |
function(lyt) character() |
2737 |
) |
|
2738 | ||
2739 |
## Titles and footers ---- |
|
2740 | ||
2741 |
# ##' Titles and Footers |
|
2742 |
# ##' |
|
2743 |
# ##' Get or set the titles and footers on an object |
|
2744 |
# ##' |
|
2745 |
# ##' @inheritParams gen_args |
|
2746 |
# ##' |
|
2747 |
# ##' @rdname title_footer |
|
2748 |
# ##' @export |
|
2749 |
#' @rdname formatters_methods |
|
2750 |
#' @export |
|
2751 |
setMethod( |
|
2752 |
"main_title", "VTitleFooter", |
|
2753 | 3165x |
function(obj) obj@main_title |
2754 |
) |
|
2755 | ||
2756 |
##' @rdname formatters_methods |
|
2757 |
##' @export |
|
2758 |
setMethod( |
|
2759 |
"main_title<-", "VTitleFooter", |
|
2760 |
function(obj, value) { |
|
2761 | 2754x |
stopifnot(length(value) == 1) |
2762 | 2754x |
obj@main_title <- value |
2763 | 2754x |
obj |
2764 |
} |
|
2765 |
) |
|
2766 | ||
2767 |
# Getters for TableRow is here for convenience for binding (no need of setters) |
|
2768 |
#' @rdname formatters_methods |
|
2769 |
#' @export |
|
2770 |
setMethod( |
|
2771 |
"main_title", "TableRow", |
|
2772 | 6x |
function(obj) "" |
2773 |
) |
|
2774 | ||
2775 |
#' @rdname formatters_methods |
|
2776 |
#' @export |
|
2777 |
setMethod( |
|
2778 |
"subtitles", "VTitleFooter", |
|
2779 | 3155x |
function(obj) obj@subtitles |
2780 |
) |
|
2781 | ||
2782 |
#' @rdname formatters_methods |
|
2783 |
#' @export |
|
2784 |
setMethod( |
|
2785 |
"subtitles<-", "VTitleFooter", |
|
2786 |
function(obj, value) { |
|
2787 | 2749x |
obj@subtitles <- value |
2788 | 2749x |
obj |
2789 |
} |
|
2790 |
) |
|
2791 | ||
2792 |
#' @rdname formatters_methods |
|
2793 |
#' @export |
|
2794 |
setMethod( |
|
2795 |
"subtitles", "TableRow", # Only getter: see main_title for TableRow |
|
2796 | 6x |
function(obj) character() |
2797 |
) |
|
2798 | ||
2799 |
#' @rdname formatters_methods |
|
2800 |
#' @export |
|
2801 |
setMethod( |
|
2802 |
"main_footer", "VTitleFooter", |
|
2803 | 3163x |
function(obj) obj@main_footer |
2804 |
) |
|
2805 | ||
2806 |
#' @rdname formatters_methods |
|
2807 |
#' @export |
|
2808 |
setMethod( |
|
2809 |
"main_footer<-", "VTitleFooter", |
|
2810 |
function(obj, value) { |
|
2811 | 2754x |
obj@main_footer <- value |
2812 | 2754x |
obj |
2813 |
} |
|
2814 |
) |
|
2815 | ||
2816 |
#' @rdname formatters_methods |
|
2817 |
#' @export |
|
2818 |
setMethod( |
|
2819 |
"main_footer", "TableRow", # Only getter: see main_title for TableRow |
|
2820 | 6x |
function(obj) character() |
2821 |
) |
|
2822 | ||
2823 |
#' @rdname formatters_methods |
|
2824 |
#' @export |
|
2825 |
setMethod( |
|
2826 |
"prov_footer", "VTitleFooter", |
|
2827 | 3147x |
function(obj) obj@provenance_footer |
2828 |
) |
|
2829 | ||
2830 |
#' @rdname formatters_methods |
|
2831 |
#' @export |
|
2832 |
setMethod( |
|
2833 |
"prov_footer<-", "VTitleFooter", |
|
2834 |
function(obj, value) { |
|
2835 | 2748x |
obj@provenance_footer <- value |
2836 | 2748x |
obj |
2837 |
} |
|
2838 |
) |
|
2839 | ||
2840 |
#' @rdname formatters_methods |
|
2841 |
#' @export |
|
2842 |
setMethod( |
|
2843 |
"prov_footer", "TableRow", # Only getter: see main_title for TableRow |
|
2844 | 6x |
function(obj) character() |
2845 |
) |
|
2846 | ||
2847 |
make_ref_value <- function(value) { |
|
2848 | 3125x |
if (is(value, "RefFootnote")) { |
2849 | ! |
value <- list(value) |
2850 | 3125x |
} else if (!is.list(value) || any(!sapply(value, is, "RefFootnote"))) { |
2851 | 11x |
value <- lapply(value, RefFootnote) |
2852 |
} |
|
2853 | 3125x |
value |
2854 |
} |
|
2855 | ||
2856 |
#' Referential footnote accessors |
|
2857 |
#' |
|
2858 |
#' Access and set the referential footnotes aspects of a built table. |
|
2859 |
#' |
|
2860 |
#' @inheritParams gen_args |
|
2861 |
#' |
|
2862 |
#' @export |
|
2863 |
#' @rdname ref_fnotes |
|
2864 | 48373x |
setGeneric("row_footnotes", function(obj) standardGeneric("row_footnotes")) |
2865 | ||
2866 |
#' @export |
|
2867 |
#' @rdname int_methods |
|
2868 |
setMethod( |
|
2869 |
"row_footnotes", "TableRow", |
|
2870 | 46395x |
function(obj) obj@row_footnotes |
2871 |
) |
|
2872 | ||
2873 |
#' @export |
|
2874 |
#' @rdname int_methods |
|
2875 |
setMethod( |
|
2876 |
"row_footnotes", "RowsVerticalSection", |
|
2877 | 1571x |
function(obj) attr(obj, "row_footnotes", exact = TRUE) %||% list() |
2878 |
) |
|
2879 | ||
2880 |
#' @export |
|
2881 |
#' @rdname ref_fnotes |
|
2882 | 82x |
setGeneric("row_footnotes<-", function(obj, value) standardGeneric("row_footnotes<-")) |
2883 | ||
2884 |
#' @export |
|
2885 |
#' @rdname int_methods |
|
2886 |
setMethod( |
|
2887 |
"row_footnotes<-", "TableRow", |
|
2888 |
function(obj, value) { |
|
2889 | 82x |
obj@row_footnotes <- make_ref_value(value) |
2890 | 82x |
obj |
2891 |
} |
|
2892 |
) |
|
2893 | ||
2894 |
#' @export |
|
2895 |
#' @rdname int_methods |
|
2896 |
setMethod( |
|
2897 |
"row_footnotes", "VTableTree", |
|
2898 |
function(obj) { |
|
2899 | 407x |
rws <- collect_leaves(obj, TRUE, TRUE) |
2900 | 407x |
cells <- lapply(rws, row_footnotes) |
2901 | 407x |
cells |
2902 |
} |
|
2903 |
) |
|
2904 | ||
2905 |
#' @export |
|
2906 |
#' @rdname ref_fnotes |
|
2907 | 180327x |
setGeneric("cell_footnotes", function(obj) standardGeneric("cell_footnotes")) |
2908 | ||
2909 |
#' @export |
|
2910 |
#' @rdname int_methods |
|
2911 |
setMethod( |
|
2912 |
"cell_footnotes", "CellValue", |
|
2913 | 143105x |
function(obj) attr(obj, "footnotes", exact = TRUE) %||% list() |
2914 |
) |
|
2915 | ||
2916 |
#' @export |
|
2917 |
#' @rdname int_methods |
|
2918 |
setMethod( |
|
2919 |
"cell_footnotes", "TableRow", |
|
2920 |
function(obj) { |
|
2921 | 32832x |
ret <- lapply(row_cells(obj), cell_footnotes) |
2922 | 32832x |
if (length(ret) != ncol(obj)) { |
2923 | 119x |
ret <- rep(ret, row_cspans(obj)) |
2924 |
} |
|
2925 | 32832x |
ret |
2926 |
} |
|
2927 |
) |
|
2928 | ||
2929 |
#' @export |
|
2930 |
#' @rdname int_methods |
|
2931 |
setMethod( |
|
2932 |
"cell_footnotes", "LabelRow", |
|
2933 |
function(obj) { |
|
2934 | 3983x |
rep(list(list()), ncol(obj)) |
2935 |
} |
|
2936 |
) |
|
2937 | ||
2938 |
#' @export |
|
2939 |
#' @rdname int_methods |
|
2940 |
setMethod( |
|
2941 |
"cell_footnotes", "VTableTree", |
|
2942 |
function(obj) { |
|
2943 | 407x |
rws <- collect_leaves(obj, TRUE, TRUE) |
2944 | 407x |
cells <- lapply(rws, cell_footnotes) |
2945 | 407x |
do.call(rbind, cells) |
2946 |
} |
|
2947 |
) |
|
2948 | ||
2949 |
#' @export |
|
2950 |
#' @rdname ref_fnotes |
|
2951 | 717x |
setGeneric("cell_footnotes<-", function(obj, value) standardGeneric("cell_footnotes<-")) |
2952 | ||
2953 |
#' @export |
|
2954 |
#' @rdname int_methods |
|
2955 |
setMethod( |
|
2956 |
"cell_footnotes<-", "CellValue", |
|
2957 |
function(obj, value) { |
|
2958 | 640x |
attr(obj, "footnotes") <- make_ref_value(value) |
2959 | 640x |
obj |
2960 |
} |
|
2961 |
) |
|
2962 | ||
2963 |
.cfn_set_helper <- function(obj, value) { |
|
2964 | 77x |
if (length(value) != ncol(obj)) { |
2965 | ! |
stop("Did not get the right number of footnote ref values for cell_footnotes<- on a full row.") |
2966 |
} |
|
2967 | ||
2968 | 77x |
row_cells(obj) <- mapply( |
2969 | 77x |
function(cell, fns) { |
2970 | 283x |
if (is.list(fns)) { |
2971 | 276x |
cell_footnotes(cell) <- lapply(fns, RefFootnote) |
2972 |
} else { |
|
2973 | 7x |
cell_footnotes(cell) <- list(RefFootnote(fns)) |
2974 |
} |
|
2975 | 283x |
cell |
2976 |
}, |
|
2977 | 77x |
cell = row_cells(obj), |
2978 | 77x |
fns = value, SIMPLIFY = FALSE |
2979 |
) |
|
2980 | 77x |
obj |
2981 |
} |
|
2982 | ||
2983 |
#' @export |
|
2984 |
#' @rdname int_methods |
|
2985 |
setMethod("cell_footnotes<-", "DataRow", |
|
2986 |
definition = .cfn_set_helper |
|
2987 |
) |
|
2988 | ||
2989 |
#' @export |
|
2990 |
#' @rdname int_methods |
|
2991 |
setMethod("cell_footnotes<-", "ContentRow", |
|
2992 |
definition = .cfn_set_helper |
|
2993 |
) |
|
2994 | ||
2995 |
# Deprecated methods ---- |
|
2996 | ||
2997 |
#' @export |
|
2998 |
#' @rdname ref_fnotes |
|
2999 | ! |
setGeneric("col_fnotes_here", function(obj) standardGeneric("col_fnotes_here")) |
3000 | ||
3001 |
#' @export |
|
3002 |
#' @rdname ref_fnotes |
|
3003 |
setMethod("col_fnotes_here", "ANY", function(obj) { |
|
3004 | ! |
.Deprecated( |
3005 | ! |
new = "col_footnotes", |
3006 | ! |
old = "col_fnotes_here", |
3007 | ! |
msg = "col_fnotes_here was deprecated in {rtables} version 0.6.5.9011. Please use col_footnotes instead." |
3008 |
) |
|
3009 | ! |
col_footnotes(obj) |
3010 |
}) |
|
3011 | ||
3012 |
#' @export |
|
3013 |
#' @rdname ref_fnotes |
|
3014 | ! |
setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-")) |
3015 | ||
3016 |
#' @export |
|
3017 |
#' @rdname int_methods |
|
3018 |
setMethod("col_fnotes_here<-", "ANY", function(obj, value) { |
|
3019 | ! |
.Deprecated( |
3020 | ! |
new = "col_footnotes<-", |
3021 | ! |
old = "col_fnotes_here<-", |
3022 | ! |
msg = "col_fnotes_here<- was deprecated in {rtables} version 0.6.5.9011. Please use col_footnotes<- instead." |
3023 |
) |
|
3024 | ! |
col_footnotes(obj) <- value |
3025 |
}) |
|
3026 | ||
3027 |
#' @export |
|
3028 |
#' @rdname ref_fnotes |
|
3029 | 19786x |
setGeneric("col_footnotes", function(obj) standardGeneric("col_footnotes")) |
3030 | ||
3031 |
#' @export |
|
3032 |
#' @rdname int_methods |
|
3033 | 1224x |
setMethod("col_footnotes", "LayoutColTree", function(obj) obj@col_footnotes) |
3034 | ||
3035 |
#' @export |
|
3036 |
#' @rdname int_methods |
|
3037 | 18156x |
setMethod("col_footnotes", "LayoutColLeaf", function(obj) obj@col_footnotes) |
3038 | ||
3039 |
#' @export |
|
3040 |
#' @rdname ref_fnotes |
|
3041 | 1853x |
setGeneric("col_footnotes<-", function(obj, value) standardGeneric("col_footnotes<-")) |
3042 | ||
3043 |
#' @export |
|
3044 |
#' @rdname int_methods |
|
3045 |
setMethod("col_footnotes<-", "LayoutColTree", function(obj, value) { |
|
3046 | 691x |
obj@col_footnotes <- make_ref_value(value) |
3047 | 691x |
obj |
3048 |
}) |
|
3049 | ||
3050 |
#' @export |
|
3051 |
#' @rdname int_methods |
|
3052 |
setMethod("col_footnotes<-", "LayoutColLeaf", function(obj, value) { |
|
3053 | 1162x |
obj@col_footnotes <- make_ref_value(value) |
3054 | 1162x |
obj |
3055 |
}) |
|
3056 | ||
3057 |
#' @export |
|
3058 |
#' @rdname int_methods |
|
3059 |
setMethod( |
|
3060 |
"col_footnotes", "VTableTree", |
|
3061 |
function(obj) { |
|
3062 | 406x |
ctree <- coltree(obj) |
3063 | 406x |
cols <- tree_children(ctree) |
3064 | 406x |
while (all(sapply(cols, is, "LayoutColTree"))) { |
3065 | 123x |
cols <- lapply(cols, tree_children) |
3066 | 123x |
cols <- unlist(cols, recursive = FALSE) |
3067 |
} |
|
3068 | 406x |
all_col_fnotes <- lapply(cols, col_footnotes) |
3069 | 406x |
if (is.null(unlist(all_col_fnotes))) { |
3070 | 401x |
return(NULL) |
3071 |
} |
|
3072 | ||
3073 | 5x |
return(all_col_fnotes) |
3074 |
} |
|
3075 |
) |
|
3076 | ||
3077 |
#' @export |
|
3078 |
#' @rdname ref_fnotes |
|
3079 | 3912x |
setGeneric("ref_index", function(obj) standardGeneric("ref_index")) |
3080 | ||
3081 |
#' @export |
|
3082 |
#' @rdname int_methods |
|
3083 |
setMethod( |
|
3084 |
"ref_index", "RefFootnote", |
|
3085 | 3912x |
function(obj) obj@index |
3086 |
) |
|
3087 | ||
3088 |
#' @export |
|
3089 |
#' @rdname ref_fnotes |
|
3090 | 119x |
setGeneric("ref_index<-", function(obj, value) standardGeneric("ref_index<-")) |
3091 | ||
3092 |
#' @export |
|
3093 |
#' @rdname int_methods |
|
3094 |
setMethod( |
|
3095 |
"ref_index<-", "RefFootnote", |
|
3096 |
function(obj, value) { |
|
3097 | 119x |
obj@index <- value |
3098 | 119x |
obj |
3099 |
} |
|
3100 |
) |
|
3101 | ||
3102 |
#' @export |
|
3103 |
#' @rdname ref_fnotes |
|
3104 | 3793x |
setGeneric("ref_symbol", function(obj) standardGeneric("ref_symbol")) |
3105 | ||
3106 |
#' @export |
|
3107 |
#' @rdname int_methods |
|
3108 |
setMethod( |
|
3109 |
"ref_symbol", "RefFootnote", |
|
3110 | 3793x |
function(obj) obj@symbol |
3111 |
) |
|
3112 | ||
3113 |
#' @export |
|
3114 |
#' @rdname ref_fnotes |
|
3115 | ! |
setGeneric("ref_symbol<-", function(obj, value) standardGeneric("ref_symbol<-")) |
3116 | ||
3117 |
#' @export |
|
3118 |
#' @rdname int_methods |
|
3119 |
setMethod( |
|
3120 |
"ref_symbol<-", "RefFootnote", |
|
3121 |
function(obj, value) { |
|
3122 | ! |
obj@symbol <- value |
3123 | ! |
obj |
3124 |
} |
|
3125 |
) |
|
3126 | ||
3127 |
#' @export |
|
3128 |
#' @rdname ref_fnotes |
|
3129 | 2929x |
setGeneric("ref_msg", function(obj) standardGeneric("ref_msg")) |
3130 | ||
3131 |
#' @export |
|
3132 |
#' @rdname int_methods |
|
3133 |
setMethod( |
|
3134 |
"ref_msg", "RefFootnote", |
|
3135 | 2929x |
function(obj) obj@value |
3136 |
) |
|
3137 | ||
3138 | 24x |
setGeneric(".fnote_set_inner<-", function(ttrp, colpath, value) standardGeneric(".fnote_set_inner<-")) |
3139 | ||
3140 |
setMethod( |
|
3141 |
".fnote_set_inner<-", c("TableRow", "NULL"), |
|
3142 |
function(ttrp, colpath, value) { |
|
3143 | 8x |
row_footnotes(ttrp) <- value |
3144 | 8x |
ttrp |
3145 |
} |
|
3146 |
) |
|
3147 | ||
3148 |
setMethod( |
|
3149 |
".fnote_set_inner<-", c("TableRow", "character"), |
|
3150 |
function(ttrp, colpath, value) { |
|
3151 | 7x |
ind <- .path_to_pos(path = colpath, tt = ttrp, cols = TRUE) |
3152 | 7x |
cfns <- cell_footnotes(ttrp) |
3153 | 7x |
cfns[[ind]] <- value |
3154 | 7x |
cell_footnotes(ttrp) <- cfns |
3155 | 7x |
ttrp |
3156 |
} |
|
3157 |
) |
|
3158 | ||
3159 |
setMethod( |
|
3160 |
".fnote_set_inner<-", c("InstantiatedColumnInfo", "character"), |
|
3161 |
function(ttrp, colpath, value) { |
|
3162 | 1x |
ctree <- col_fnotes_at_path(coltree(ttrp), colpath, fnotes = value) |
3163 | 1x |
coltree(ttrp) <- ctree |
3164 | 1x |
ttrp |
3165 |
} |
|
3166 |
) |
|
3167 | ||
3168 |
setMethod( |
|
3169 |
".fnote_set_inner<-", c("VTableTree", "ANY"), |
|
3170 |
function(ttrp, colpath, value) { |
|
3171 | 8x |
if (labelrow_visible(ttrp) && !is.null(value)) { |
3172 | 2x |
lblrw <- tt_labelrow(ttrp) |
3173 | 2x |
row_footnotes(lblrw) <- value |
3174 | 2x |
tt_labelrow(ttrp) <- lblrw |
3175 | 6x |
} else if (NROW(content_table(ttrp)) == 1L) { |
3176 | 6x |
ctbl <- content_table(ttrp) |
3177 | 6x |
pth <- make_row_df(ctbl)$path[[1]] |
3178 | 6x |
fnotes_at_path(ctbl, pth, colpath) <- value |
3179 | 6x |
content_table(ttrp) <- ctbl |
3180 |
} else { |
|
3181 |
stop("an error occurred. this shouldn't happen. please contact the maintainer") # nocov |
|
3182 |
} |
|
3183 | 8x |
ttrp |
3184 |
} |
|
3185 |
) |
|
3186 | ||
3187 |
#' @param rowpath (`character` or `NULL`)\cr path within row structure. `NULL` indicates the footnote should |
|
3188 |
#' go on the column rather than cell. |
|
3189 |
#' @param colpath (`character` or `NULL`)\cr path within column structure. `NULL` indicates footnote should go |
|
3190 |
#' on the row rather than cell. |
|
3191 |
#' @param reset_idx (`flag`)\cr whether the numbering for referential footnotes should be immediately |
|
3192 |
#' recalculated. Defaults to `TRUE`. |
|
3193 |
#' |
|
3194 |
#' @examples |
|
3195 |
#' # How to add referencial footnotes after having created a table |
|
3196 |
#' lyt <- basic_table() %>% |
|
3197 |
#' split_rows_by("SEX", page_by = TRUE) %>% |
|
3198 |
#' analyze("AGE") |
|
3199 |
#' |
|
3200 |
#' tbl <- build_table(lyt, DM) |
|
3201 |
#' tbl <- trim_rows(tbl) |
|
3202 |
#' # Check the row and col structure to add precise references |
|
3203 |
#' # row_paths(tbl) |
|
3204 |
#' # col_paths(t) |
|
3205 |
#' # row_paths_summary(tbl) |
|
3206 |
#' # col_paths_summary(tbl) |
|
3207 |
#' |
|
3208 |
#' # Add the citation numbers on the table and relative references in the footnotes |
|
3209 |
#' fnotes_at_path(tbl, rowpath = c("SEX", "F", "AGE", "Mean")) <- "Famous paper 1" |
|
3210 |
#' fnotes_at_path(tbl, rowpath = c("SEX", "UNDIFFERENTIATED")) <- "Unfamous paper 2" |
|
3211 |
#' # tbl |
|
3212 |
#' |
|
3213 |
#' @seealso [row_paths()], [col_paths()], [row_paths_summary()], [col_paths_summary()] |
|
3214 |
#' |
|
3215 |
#' @export |
|
3216 |
#' @rdname ref_fnotes |
|
3217 |
setGeneric("fnotes_at_path<-", function(obj, |
|
3218 |
rowpath = NULL, |
|
3219 |
colpath = NULL, |
|
3220 |
reset_idx = TRUE, |
|
3221 |
value) { |
|
3222 | 24x |
standardGeneric("fnotes_at_path<-") |
3223 |
}) |
|
3224 | ||
3225 |
## non-null rowpath, null or non-null colpath |
|
3226 |
#' @inheritParams fnotes_at_path<- |
|
3227 |
#' |
|
3228 |
#' @export |
|
3229 |
#' @rdname int_methods |
|
3230 |
setMethod( |
|
3231 |
"fnotes_at_path<-", c("VTableTree", "character"), |
|
3232 |
function(obj, |
|
3233 |
rowpath = NULL, |
|
3234 |
colpath = NULL, |
|
3235 |
reset_idx = TRUE, |
|
3236 |
value) { |
|
3237 | 23x |
rw <- tt_at_path(obj, rowpath) |
3238 | 23x |
.fnote_set_inner(rw, colpath) <- value |
3239 | 23x |
tt_at_path(obj, rowpath) <- rw |
3240 | 23x |
if (reset_idx) { |
3241 | 23x |
obj <- update_ref_indexing(obj) |
3242 |
} |
|
3243 | 23x |
obj |
3244 |
} |
|
3245 |
) |
|
3246 | ||
3247 |
#' @export |
|
3248 |
#' @rdname int_methods |
|
3249 |
setMethod( |
|
3250 |
"fnotes_at_path<-", c("VTableTree", "NULL"), |
|
3251 |
function(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE, value) { |
|
3252 | 1x |
cinfo <- col_info(obj) |
3253 | 1x |
.fnote_set_inner(cinfo, colpath) <- value |
3254 | 1x |
col_info(obj) <- cinfo |
3255 | 1x |
if (reset_idx) { |
3256 | 1x |
obj <- update_ref_indexing(obj) |
3257 |
} |
|
3258 | 1x |
obj |
3259 |
} |
|
3260 |
) |
|
3261 | ||
3262 | 2784x |
setGeneric("has_force_pag", function(obj) standardGeneric("has_force_pag")) |
3263 | ||
3264 | 317x |
setMethod("has_force_pag", "TableTree", function(obj) !is.na(ptitle_prefix(obj))) |
3265 | ||
3266 | 1502x |
setMethod("has_force_pag", "Split", function(obj) !is.na(ptitle_prefix(obj))) |
3267 | ||
3268 | 914x |
setMethod("has_force_pag", "VTableNodeInfo", function(obj) FALSE) |
3269 | ||
3270 | 2283x |
setGeneric("ptitle_prefix", function(obj) standardGeneric("ptitle_prefix")) |
3271 | ||
3272 | 325x |
setMethod("ptitle_prefix", "TableTree", function(obj) obj@page_title_prefix) |
3273 | ||
3274 | 1907x |
setMethod("ptitle_prefix", "Split", function(obj) obj@page_title_prefix) |
3275 | ||
3276 | ! |
setMethod("ptitle_prefix", "ANY", function(obj) NULL) |
3277 | ||
3278 | 361x |
setMethod("page_titles", "VTableTree", function(obj) obj@page_titles) |
3279 | ||
3280 |
setMethod("page_titles<-", "VTableTree", function(obj, value) { |
|
3281 | 19x |
obj@page_titles <- value |
3282 | 19x |
obj |
3283 |
}) |
|
3284 | ||
3285 |
## Horizontal separator -------------------------------------------------------- |
|
3286 | ||
3287 |
#' Access or recursively set header-body separator for tables |
|
3288 |
#' |
|
3289 |
#' @inheritParams gen_args |
|
3290 |
#' @param value (`string`)\cr string to use as new header/body separator. |
|
3291 |
#' |
|
3292 |
#' @return |
|
3293 |
#' * `horizontal_sep` returns the string acting as the header separator. |
|
3294 |
#' * `horizontal_sep<-` returns `obj`, with the new header separator applied recursively to it and all its |
|
3295 |
#' subtables. |
|
3296 |
#' |
|
3297 |
#' @export |
|
3298 | 341x |
setGeneric("horizontal_sep", function(obj) standardGeneric("horizontal_sep")) |
3299 | ||
3300 |
#' @rdname horizontal_sep |
|
3301 |
#' @export |
|
3302 |
setMethod( |
|
3303 |
"horizontal_sep", "VTableTree", |
|
3304 | 341x |
function(obj) obj@horizontal_sep |
3305 |
) |
|
3306 | ||
3307 |
#' @rdname horizontal_sep |
|
3308 |
#' @export |
|
3309 | 23842x |
setGeneric("horizontal_sep<-", function(obj, value) standardGeneric("horizontal_sep<-")) |
3310 | ||
3311 |
#' @rdname horizontal_sep |
|
3312 |
#' @export |
|
3313 |
setMethod( |
|
3314 |
"horizontal_sep<-", "VTableTree", |
|
3315 |
function(obj, value) { |
|
3316 | 13353x |
cont <- content_table(obj) |
3317 | 13353x |
if (NROW(cont) > 0) { |
3318 | 1878x |
horizontal_sep(cont) <- value |
3319 | 1878x |
content_table(obj) <- cont |
3320 |
} |
|
3321 | ||
3322 | 13353x |
kids <- lapply(tree_children(obj), |
3323 | 13353x |
`horizontal_sep<-`, |
3324 | 13353x |
value = value |
3325 |
) |
|
3326 | ||
3327 | 13353x |
tree_children(obj) <- kids |
3328 | 13353x |
obj@horizontal_sep <- value |
3329 | 13353x |
obj |
3330 |
} |
|
3331 |
) |
|
3332 | ||
3333 |
#' @rdname horizontal_sep |
|
3334 |
#' @export |
|
3335 |
setMethod( |
|
3336 |
"horizontal_sep<-", "TableRow", |
|
3337 | 10489x |
function(obj, value) obj |
3338 |
) |
|
3339 | ||
3340 |
## Section dividers ------------------------------------------------------------ |
|
3341 | ||
3342 |
# Used for splits |
|
3343 | 1623x |
setGeneric("spl_section_div", function(obj) standardGeneric("spl_section_div")) |
3344 | ||
3345 |
setMethod( |
|
3346 |
"spl_section_div", "Split", |
|
3347 | 1623x |
function(obj) obj@child_section_div |
3348 |
) |
|
3349 | ||
3350 | ! |
setGeneric("spl_section_div<-", function(obj, value) standardGeneric("spl_section_div<-")) |
3351 | ||
3352 |
setMethod( |
|
3353 |
"spl_section_div<-", "Split", |
|
3354 |
function(obj, value) { |
|
3355 | ! |
obj@child_section_div <- value |
3356 | ! |
obj |
3357 |
} |
|
3358 |
) |
|
3359 | ||
3360 |
# Used for table object parts |
|
3361 | 25103x |
setGeneric("trailing_section_div", function(obj) standardGeneric("trailing_section_div")) |
3362 | 10146x |
setMethod("trailing_section_div", "VTableTree", function(obj) obj@trailing_section_div) |
3363 | 4811x |
setMethod("trailing_section_div", "LabelRow", function(obj) obj@trailing_section_div) |
3364 | 10146x |
setMethod("trailing_section_div", "TableRow", function(obj) obj@trailing_section_div) |
3365 | ||
3366 | 1593x |
setGeneric("trailing_section_div<-", function(obj, value) standardGeneric("trailing_section_div<-")) |
3367 |
setMethod("trailing_section_div<-", "VTableTree", function(obj, value) { |
|
3368 | 1494x |
obj@trailing_section_div <- value |
3369 | 1494x |
obj |
3370 |
}) |
|
3371 |
setMethod("trailing_section_div<-", "LabelRow", function(obj, value) { |
|
3372 | 40x |
obj@trailing_section_div <- value |
3373 | 40x |
obj |
3374 |
}) |
|
3375 |
setMethod("trailing_section_div<-", "TableRow", function(obj, value) { |
|
3376 | 59x |
obj@trailing_section_div <- value |
3377 | 59x |
obj |
3378 |
}) |
|
3379 | ||
3380 |
#' Section dividers accessor and setter |
|
3381 |
#' |
|
3382 |
#' `section_div` can be used to set or get the section divider for a table object |
|
3383 |
#' produced by [build_table()]. When assigned in post-processing (`section_div<-`) |
|
3384 |
#' the table can have a section divider after every row, each assigned independently. |
|
3385 |
#' If assigning during layout creation, only [split_rows_by()] (and its related row-wise |
|
3386 |
#' splits) and [analyze()] have a `section_div` parameter that will produce separators |
|
3387 |
#' between split sections and data subgroups, respectively. |
|
3388 |
#' |
|
3389 |
#' @param obj (`VTableTree`)\cr table object. This can be of any class that inherits from `VTableTree` |
|
3390 |
#' or `TableRow`/`LabelRow`. |
|
3391 |
#' @param only_sep_sections (`flag`)\cr defaults to `FALSE` for `section_div<-`. Allows |
|
3392 |
#' you to set the section divider only for sections that are splits or analyses if the number of |
|
3393 |
#' values is less than the number of rows in the table. If `TRUE`, the section divider will |
|
3394 |
#' be set for all rows of the table. |
|
3395 |
#' @param value (`character`)\cr vector of single characters to use as section dividers. Each character |
|
3396 |
#' is repeated such that all section dividers span the width of the table. Each character that is |
|
3397 |
#' not `NA_character_` will produce a trailing separator for each row of the table. `value` length |
|
3398 |
#' should reflect the number of rows, or be between 1 and the number of splits/levels. |
|
3399 |
#' See the Details section below for more information. |
|
3400 |
#' |
|
3401 |
#' @return The section divider string. Each line that does not have a trailing separator |
|
3402 |
#' will have `NA_character_` as section divider. |
|
3403 |
#' |
|
3404 |
#' @seealso [basic_table()] parameter `header_section_div` and `top_level_section_div` for global |
|
3405 |
#' section dividers. |
|
3406 |
#' |
|
3407 |
#' @details |
|
3408 |
#' Assigned value to section divider must be a character vector. If any value is `NA_character_` |
|
3409 |
#' the section divider will be absent for that row or section. When you want to only affect sections |
|
3410 |
#' or splits, please use `only_sep_sections` or provide a shorter vector than the number of rows. |
|
3411 |
#' Ideally, the length of the vector should be less than the number of splits with, eventually, the |
|
3412 |
#' leaf-level, i.e. `DataRow` where analyze results are. Note that if only one value is inserted, |
|
3413 |
#' only the first split will be affected. |
|
3414 |
#' If `only_sep_sections = TRUE`, which is the default for `section_div()` produced from the table |
|
3415 |
#' construction, the section divider will be set for all the splits and eventually analyses, but |
|
3416 |
#' not for the header or each row of the table. This can be set with `header_section_div` in |
|
3417 |
#' [basic_table()] or, eventually, with `hsep` in [build_table()]. If `FALSE`, the section |
|
3418 |
#' divider will be set for all the rows of the table. |
|
3419 |
#' |
|
3420 |
#' @examples |
|
3421 |
#' # Data |
|
3422 |
#' df <- data.frame( |
|
3423 |
#' cat = c( |
|
3424 |
#' "really long thing its so ", "long" |
|
3425 |
#' ), |
|
3426 |
#' value = c(6, 3, 10, 1) |
|
3427 |
#' ) |
|
3428 |
#' fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2) |
|
3429 |
#' |
|
3430 |
#' tbl <- basic_table() %>% |
|
3431 |
#' split_rows_by("cat", section_div = "~") %>% |
|
3432 |
#' analyze("value", afun = fast_afun, section_div = " ") %>% |
|
3433 |
#' build_table(df) |
|
3434 |
#' |
|
3435 |
#' # Getter |
|
3436 |
#' section_div(tbl) |
|
3437 |
#' |
|
3438 |
#' # Setter |
|
3439 |
#' section_div(tbl) <- letters[seq_len(nrow(tbl))] |
|
3440 |
#' tbl |
|
3441 |
#' |
|
3442 |
#' # last letter can appear if there is another table |
|
3443 |
#' rbind(tbl, tbl) |
|
3444 |
#' |
|
3445 |
#' # header_section_div |
|
3446 |
#' header_section_div(tbl) <- "+" |
|
3447 |
#' tbl |
|
3448 |
#' |
|
3449 |
#' @docType methods |
|
3450 |
#' @rdname section_div |
|
3451 |
#' @export |
|
3452 | 362x |
setGeneric("section_div", function(obj) standardGeneric("section_div")) |
3453 | ||
3454 |
#' @rdname section_div |
|
3455 |
#' @aliases section_div,VTableTree-method |
|
3456 |
setMethod("section_div", "VTableTree", function(obj) { |
|
3457 | 150x |
content_row_tbl <- content_table(obj) |
3458 | 150x |
is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 # otherwise NA or NULL |
3459 | 150x |
if (labelrow_visible(obj) || is_content_table) { |
3460 | 67x |
section_div <- trailing_section_div(obj) |
3461 | 67x |
labelrow_div <- trailing_section_div(tt_labelrow(obj)) |
3462 | 67x |
rest_of_tree <- section_div(tree_children(obj)) |
3463 |
# Case it is the section itself and not the labels to have a trailing sep |
|
3464 | 67x |
if (!is.na(section_div)) { |
3465 | 45x |
rest_of_tree[length(rest_of_tree)] <- section_div |
3466 |
} |
|
3467 | 67x |
unname(c(labelrow_div, rest_of_tree)) |
3468 |
} else { |
|
3469 | 83x |
unname(section_div(tree_children(obj))) |
3470 |
} |
|
3471 |
}) |
|
3472 | ||
3473 |
#' @rdname section_div |
|
3474 |
#' @aliases section_div,list-method |
|
3475 |
setMethod("section_div", "list", function(obj) { |
|
3476 | 150x |
unlist(lapply(obj, section_div)) |
3477 |
}) |
|
3478 | ||
3479 |
#' @rdname section_div |
|
3480 |
#' @aliases section_div,TableRow-method |
|
3481 |
setMethod("section_div", "TableRow", function(obj) { |
|
3482 | 62x |
trailing_section_div(obj) |
3483 |
}) |
|
3484 | ||
3485 |
# section_div setter from table object |
|
3486 |
#' @rdname section_div |
|
3487 |
#' @export |
|
3488 |
setGeneric("section_div<-", function(obj, only_sep_sections = FALSE, value) { |
|
3489 | 217x |
standardGeneric("section_div<-") |
3490 |
}) |
|
3491 | ||
3492 |
#' @rdname section_div |
|
3493 |
#' @aliases section_div<-,VTableTree-method |
|
3494 |
setMethod("section_div<-", "VTableTree", function(obj, only_sep_sections = FALSE, value) { |
|
3495 | 90x |
char_v <- as.character(value) |
3496 | 90x |
tree_depths <- unname(vapply(collect_leaves(obj), tt_level, numeric(1))) |
3497 | 90x |
max_tree_depth <- max(tree_depths) |
3498 | 90x |
stopifnot(is.logical(only_sep_sections)) |
3499 | 90x |
.check_char_vector_for_section_div(char_v, max_tree_depth, nrow(obj)) |
3500 | ||
3501 |
# Automatic establishment of intent |
|
3502 | 90x |
if (length(char_v) < nrow(obj)) { |
3503 | 3x |
only_sep_sections <- TRUE |
3504 |
} |
|
3505 | ||
3506 |
# Case where only separators or splits need to change externally |
|
3507 | 90x |
if (only_sep_sections && length(char_v) < nrow(obj)) { |
3508 |
# Case where char_v is longer than the max depth |
|
3509 | 3x |
char_v <- char_v[seq_len(min(max_tree_depth, length(char_v)))] |
3510 |
# Filling up with NAs the rest of the tree depth section div chr vector |
|
3511 | 3x |
missing_char_v_len <- max_tree_depth - length(char_v) |
3512 | 3x |
char_v <- c(char_v, rep(NA_character_, missing_char_v_len)) |
3513 |
} |
|
3514 | ||
3515 |
# Retrieving if it is a contentRow (no need for labelrow to be visible in this case) |
|
3516 | 90x |
content_row_tbl <- content_table(obj) |
3517 | 90x |
is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 |
3518 | ||
3519 |
# Main table structure change |
|
3520 | 90x |
if (labelrow_visible(obj) || is_content_table) { |
3521 | 40x |
if (only_sep_sections) { |
3522 |
# Only tables are modified |
|
3523 | 34x |
trailing_section_div(tt_labelrow(obj)) <- NA_character_ |
3524 | 34x |
trailing_section_div(obj) <- char_v[1] |
3525 | 34x |
section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1] |
3526 |
} else { |
|
3527 |
# All leaves are modified |
|
3528 | 6x |
trailing_section_div(tt_labelrow(obj)) <- char_v[1] |
3529 | 6x |
trailing_section_div(obj) <- NA_character_ |
3530 | 6x |
section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1] |
3531 |
} |
|
3532 |
} else { |
|
3533 | 50x |
section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v |
3534 |
} |
|
3535 | 90x |
obj |
3536 |
}) |
|
3537 | ||
3538 |
#' @rdname section_div |
|
3539 |
#' @aliases section_div<-,list-method |
|
3540 |
setMethod("section_div<-", "list", function(obj, only_sep_sections = FALSE, value) { |
|
3541 | 90x |
char_v <- as.character(value) |
3542 | 90x |
for (i in seq_along(obj)) { |
3543 | 121x |
stopifnot(is(obj[[i]], "VTableTree") || is(obj[[i]], "TableRow") || is(obj[[i]], "LabelRow")) |
3544 | 121x |
list_element_size <- nrow(obj[[i]]) |
3545 | 121x |
if (only_sep_sections) { |
3546 | 97x |
char_v_i <- char_v[seq_len(min(list_element_size, length(char_v)))] |
3547 | 97x |
char_v_i <- c(char_v_i, rep(NA_character_, list_element_size - length(char_v_i))) |
3548 |
} else { |
|
3549 | 24x |
init <- (i - 1) * list_element_size + 1 |
3550 | 24x |
chunk_of_char_v_to_take <- seq(init, init + list_element_size - 1) |
3551 | 24x |
char_v_i <- char_v[chunk_of_char_v_to_take] |
3552 |
} |
|
3553 | 121x |
section_div(obj[[i]], only_sep_sections = only_sep_sections) <- char_v_i |
3554 |
} |
|
3555 | 90x |
obj |
3556 |
}) |
|
3557 | ||
3558 |
#' @rdname section_div |
|
3559 |
#' @aliases section_div<-,TableRow-method |
|
3560 |
setMethod("section_div<-", "TableRow", function(obj, only_sep_sections = FALSE, value) { |
|
3561 | 37x |
trailing_section_div(obj) <- value |
3562 | 37x |
obj |
3563 |
}) |
|
3564 | ||
3565 |
#' @rdname section_div |
|
3566 |
#' @aliases section_div<-,LabelRow-method |
|
3567 |
setMethod("section_div<-", "LabelRow", function(obj, only_sep_sections = FALSE, value) { |
|
3568 | ! |
trailing_section_div(obj) <- value |
3569 | ! |
obj |
3570 |
}) |
|
3571 | ||
3572 |
# Helper check function |
|
3573 |
.check_char_vector_for_section_div <- function(char_v, min_splits, max) { |
|
3574 | 90x |
lcv <- length(char_v) |
3575 | 90x |
if (lcv < 1 || lcv > max) { |
3576 | ! |
stop("section_div must be a vector of length between 1 and numer of table rows.") |
3577 |
} |
|
3578 | 90x |
if (lcv > min_splits && lcv < max) { |
3579 | ! |
warning( |
3580 | ! |
"section_div will be truncated to the number of splits (", min_splits, ")", |
3581 | ! |
" because it is shorter than the number of rows (", max, ")." |
3582 |
) |
|
3583 |
} |
|
3584 | 90x |
nchar_check_v <- nchar(char_v) |
3585 | 90x |
if (any(nchar_check_v > 1, na.rm = TRUE)) { |
3586 | ! |
stop("section_div must be a vector of single characters or NAs") |
3587 |
} |
|
3588 |
} |
|
3589 | ||
3590 |
#' @rdname section_div |
|
3591 |
#' @export |
|
3592 | 581x |
setGeneric("header_section_div", function(obj) standardGeneric("header_section_div")) |
3593 | ||
3594 |
#' @rdname section_div |
|
3595 |
#' @aliases header_section_div,PreDataTableLayouts-method |
|
3596 |
setMethod( |
|
3597 |
"header_section_div", "PreDataTableLayouts", |
|
3598 | 283x |
function(obj) obj@header_section_div |
3599 |
) |
|
3600 | ||
3601 |
#' @rdname section_div |
|
3602 |
#' @aliases header_section_div,PreDataTableLayouts-method |
|
3603 |
setMethod( |
|
3604 |
"header_section_div", "VTableTree", |
|
3605 | 298x |
function(obj) obj@header_section_div |
3606 |
) |
|
3607 | ||
3608 |
#' @rdname section_div |
|
3609 |
#' @export |
|
3610 | 238x |
setGeneric("header_section_div<-", function(obj, value) standardGeneric("header_section_div<-")) |
3611 | ||
3612 |
#' @rdname section_div |
|
3613 |
#' @aliases header_section_div<-,PreDataTableLayouts-method |
|
3614 |
setMethod( |
|
3615 |
"header_section_div<-", "PreDataTableLayouts", |
|
3616 |
function(obj, value) { |
|
3617 | 1x |
.check_header_section_div(value) |
3618 | 1x |
obj@header_section_div <- value |
3619 | 1x |
obj |
3620 |
} |
|
3621 |
) |
|
3622 | ||
3623 |
#' @rdname section_div |
|
3624 |
#' @aliases header_section_div<-,PreDataTableLayouts-method |
|
3625 |
setMethod( |
|
3626 |
"header_section_div<-", "VTableTree", |
|
3627 |
function(obj, value) { |
|
3628 | 237x |
.check_header_section_div(value) |
3629 | 237x |
obj@header_section_div <- value |
3630 | 237x |
obj |
3631 |
} |
|
3632 |
) |
|
3633 | ||
3634 |
.check_header_section_div <- function(chr) { |
|
3635 | 536x |
if (!is.na(chr) && (!is.character(chr) || length(chr) > 1 || nchar(chr) > 1 || nchar(chr) == 0)) { |
3636 | ! |
stop("header_section_div must be a single character or NA_character_ if not used") |
3637 |
} |
|
3638 | 536x |
invisible(TRUE) |
3639 |
} |
|
3640 | ||
3641 |
#' @rdname section_div |
|
3642 |
#' @export |
|
3643 | 287x |
setGeneric("top_level_section_div", function(obj) standardGeneric("top_level_section_div")) |
3644 | ||
3645 |
#' @rdname section_div |
|
3646 |
#' @aliases top_level_section_div,PreDataTableLayouts-method |
|
3647 |
setMethod( |
|
3648 |
"top_level_section_div", "PreDataTableLayouts", |
|
3649 | 287x |
function(obj) obj@top_level_section_div |
3650 |
) |
|
3651 | ||
3652 |
#' @rdname section_div |
|
3653 |
#' @export |
|
3654 | 1x |
setGeneric("top_level_section_div<-", function(obj, value) standardGeneric("top_level_section_div<-")) |
3655 | ||
3656 |
#' @rdname section_div |
|
3657 |
#' @aliases top_level_section_div<-,PreDataTableLayouts-method |
|
3658 |
setMethod( |
|
3659 |
"top_level_section_div<-", "PreDataTableLayouts", |
|
3660 |
function(obj, value) { |
|
3661 | 1x |
checkmate::assert_character(value, len = 1, n.chars = 1) |
3662 | 1x |
obj@top_level_section_div <- value |
3663 | 1x |
obj |
3664 |
} |
|
3665 |
) |
|
3666 | ||
3667 |
## table_inset ---------------------------------------------------------- |
|
3668 | ||
3669 |
#' @rdname formatters_methods |
|
3670 |
#' @export |
|
3671 |
setMethod( |
|
3672 |
"table_inset", "VTableNodeInfo", ## VTableTree", |
|
3673 | 303x |
function(obj) obj@table_inset |
3674 |
) |
|
3675 | ||
3676 |
#' @rdname formatters_methods |
|
3677 |
#' @export |
|
3678 |
setMethod( |
|
3679 |
"table_inset", "PreDataTableLayouts", |
|
3680 | 282x |
function(obj) obj@table_inset |
3681 |
) |
|
3682 | ||
3683 |
## #' @rdname formatters_methods |
|
3684 |
## #' @export |
|
3685 |
## setMethod("table_inset", "InstantiatedColumnInfo", |
|
3686 |
## function(obj) obj@table_inset) |
|
3687 | ||
3688 |
#' @rdname formatters_methods |
|
3689 |
#' @export |
|
3690 |
setMethod( |
|
3691 |
"table_inset<-", "VTableNodeInfo", ## "VTableTree", |
|
3692 |
function(obj, value) { |
|
3693 | 15980x |
if (!is.integer(value)) { |
3694 | 5x |
value <- as.integer(value) |
3695 |
} |
|
3696 | 15980x |
if (is.na(value) || value < 0) { |
3697 | ! |
stop("Got invalid table_inset value, must be an integer > 0") |
3698 |
} |
|
3699 | 15980x |
cont <- content_table(obj) |
3700 | 15980x |
if (NROW(cont) > 0) { |
3701 | 1433x |
table_inset(cont) <- value |
3702 | 1433x |
content_table(obj) <- cont |
3703 |
} |
|
3704 | ||
3705 | 15980x |
if (length(tree_children(obj)) > 0) { |
3706 | 4871x |
kids <- lapply(tree_children(obj), |
3707 | 4871x |
`table_inset<-`, |
3708 | 4871x |
value = value |
3709 |
) |
|
3710 | 4871x |
tree_children(obj) <- kids |
3711 |
} |
|
3712 | 15980x |
obj@table_inset <- value |
3713 | 15980x |
obj |
3714 |
} |
|
3715 |
) |
|
3716 | ||
3717 |
#' @rdname formatters_methods |
|
3718 |
#' @export |
|
3719 |
setMethod( |
|
3720 |
"table_inset<-", "PreDataTableLayouts", |
|
3721 |
function(obj, value) { |
|
3722 | ! |
if (!is.integer(value)) { |
3723 | ! |
value <- as.integer(value) |
3724 |
} |
|
3725 | ! |
if (is.na(value) || value < 0) { |
3726 | ! |
stop("Got invalid table_inset value, must be an integer > 0") |
3727 |
} |
|
3728 | ||
3729 | ! |
obj@table_inset <- value |
3730 | ! |
obj |
3731 |
} |
|
3732 |
) |
|
3733 | ||
3734 |
#' @rdname formatters_methods |
|
3735 |
#' @export |
|
3736 |
setMethod( |
|
3737 |
"table_inset<-", "InstantiatedColumnInfo", |
|
3738 |
function(obj, value) { |
|
3739 | ! |
if (!is.integer(value)) { |
3740 | ! |
value <- as.integer(value) |
3741 |
} |
|
3742 | ! |
if (is.na(value) || value < 0) { |
3743 | ! |
stop("Got invalid table_inset value, must be an integer > 0") |
3744 |
} |
|
3745 | ! |
obj@table_inset <- value |
3746 | ! |
obj |
3747 |
} |
|
3748 |
) |
1 |
#' @importFrom utils browseURL |
|
2 |
NULL |
|
3 | ||
4 |
#' Display an `rtable` object in the Viewer pane in RStudio or in a browser |
|
5 |
#' |
|
6 |
#' The table will be displayed using bootstrap styling. |
|
7 |
#' |
|
8 |
#' @param x (`rtable` or `shiny.tag`)\cr an object of class `rtable` or `shiny.tag` (defined in `htmltools` package). |
|
9 |
#' @param y (`rtable` or `shiny.tag`)\cr optional second argument of same type as `x`. |
|
10 |
#' @param ... arguments passed to [as_html()]. |
|
11 |
#' |
|
12 |
#' @return Not meaningful. Called for the side effect of opening a browser or viewer pane. |
|
13 |
#' |
|
14 |
#' @examples |
|
15 |
#' if (interactive()) { |
|
16 |
#' sl5 <- factor(iris$Sepal.Length > 5, |
|
17 |
#' levels = c(TRUE, FALSE), |
|
18 |
#' labels = c("S.L > 5", "S.L <= 5") |
|
19 |
#' ) |
|
20 |
#' |
|
21 |
#' df <- cbind(iris, sl5 = sl5) |
|
22 |
#' |
|
23 |
#' lyt <- basic_table() %>% |
|
24 |
#' split_cols_by("sl5") %>% |
|
25 |
#' analyze("Sepal.Length") |
|
26 |
#' |
|
27 |
#' tbl <- build_table(lyt, df) |
|
28 |
#' |
|
29 |
#' Viewer(tbl) |
|
30 |
#' Viewer(tbl, tbl) |
|
31 |
#' |
|
32 |
#' |
|
33 |
#' tbl2 <- htmltools::tags$div( |
|
34 |
#' class = "table-responsive", |
|
35 |
#' as_html(tbl, class_table = "table") |
|
36 |
#' ) |
|
37 |
#' |
|
38 |
#' Viewer(tbl, tbl2) |
|
39 |
#' } |
|
40 |
#' @export |
|
41 |
Viewer <- function(x, y = NULL, ...) { |
|
42 | 3x |
check_convert <- function(x, name, accept_NULL = FALSE) { |
43 | 6x |
if (accept_NULL && is.null(x)) { |
44 | 3x |
NULL |
45 | 3x |
} else if (is(x, "shiny.tag")) { |
46 | ! |
x |
47 | 3x |
} else if (is(x, "VTableTree")) { |
48 | 3x |
as_html(x, ...) |
49 |
} else { |
|
50 | ! |
stop("object of class rtable or shiny tag excepted for ", name) |
51 |
} |
|
52 |
} |
|
53 | ||
54 | 3x |
x_tag <- check_convert(x, "x", FALSE) |
55 | 3x |
y_tag <- check_convert(y, "y", TRUE) |
56 | ||
57 | 3x |
html_output <- if (is.null(y)) { |
58 | 3x |
x_tag |
59 |
} else { |
|
60 | ! |
tags$div(class = "container-fluid", htmltools::tags$div( |
61 | ! |
class = "row", |
62 | ! |
tags$div(class = "col-xs-6", x_tag), |
63 | ! |
tags$div(class = "col-xs-6", y_tag) |
64 |
)) |
|
65 |
} |
|
66 | ||
67 | 3x |
sandbox_folder <- file.path(tempdir(), "rtable") |
68 | ||
69 | 3x |
if (!dir.exists(sandbox_folder)) { |
70 | 1x |
dir.create(sandbox_folder, recursive = TRUE) |
71 | 1x |
pbs <- file.path(path.package(package = "rtables"), "bootstrap/") |
72 | 1x |
file.copy(list.files(pbs, full.names = TRUE, recursive = FALSE), sandbox_folder, recursive = TRUE) |
73 |
# list.files(sandbox_folder) |
|
74 |
} |
|
75 | ||
76 |
# get html name |
|
77 | 3x |
n_try <- 10000 |
78 | 3x |
for (i in seq_len(n_try)) { |
79 | 6x |
htmlFile <- file.path(sandbox_folder, paste0("table", i, ".html")) |
80 | ||
81 | 6x |
if (!file.exists(htmlFile)) { |
82 | 3x |
break |
83 | 3x |
} else if (i == n_try) { |
84 | ! |
stop("too many html rtables created, restart your session") |
85 |
} |
|
86 |
} |
|
87 | ||
88 | 3x |
html_bs <- tags$html( |
89 | 3x |
lang = "en", |
90 | 3x |
tags$head( |
91 | 3x |
tags$meta(charset = "utf-8"), |
92 | 3x |
tags$meta("http-equiv" = "X-UA-Compatible", content = "IE=edge"), |
93 | 3x |
tags$meta( |
94 | 3x |
name = "viewport", |
95 | 3x |
content = "width=device-width, initial-scale=1" |
96 |
), |
|
97 | 3x |
tags$title("rtable"), |
98 | 3x |
tags$link( |
99 | 3x |
href = "css/bootstrap.min.css", |
100 | 3x |
rel = "stylesheet" |
101 |
) |
|
102 |
), |
|
103 | 3x |
tags$body( |
104 | 3x |
html_output |
105 |
) |
|
106 |
) |
|
107 | ||
108 | 3x |
cat( |
109 | 3x |
paste("<!DOCTYPE html>\n", htmltools::doRenderTags(html_bs)), |
110 | 3x |
file = htmlFile, append = FALSE |
111 |
) |
|
112 | ||
113 | 3x |
viewer <- getOption("viewer") |
114 | ||
115 | 3x |
if (!is.null(viewer)) { |
116 | 3x |
viewer(htmlFile) |
117 |
} else { |
|
118 | ! |
browseURL(htmlFile) |
119 |
} |
|
120 |
} |
1 |
#' Trimming and pruning criteria |
|
2 |
#' |
|
3 |
#' Criteria functions (and constructors thereof) for trimming and pruning tables. |
|
4 |
#' |
|
5 |
#' @inheritParams gen_args |
|
6 |
#' |
|
7 |
#' @return A logical value indicating whether `tr` should be included (`TRUE`) or pruned (`FALSE`) during pruning. |
|
8 |
#' |
|
9 |
#' @seealso [prune_table()], [trim_rows()] |
|
10 |
#' |
|
11 |
#' @details `all_zero_or_na` returns `TRUE` (and thus indicates trimming/pruning) for any *non-`LabelRow`* |
|
12 |
#' `TableRow` which contain only any mix of `NA` (including `NaN`), `0`, `Inf` and `-Inf` values. |
|
13 |
#' |
|
14 |
#' @examples |
|
15 |
#' adsl <- ex_adsl |
|
16 |
#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER") |
|
17 |
#' adsl$AGE[adsl$SEX == "UNDIFFERENTIATED"] <- 0 |
|
18 |
#' adsl$BMRKR1 <- 0 |
|
19 |
#' |
|
20 |
#' tbl_to_prune <- basic_table() %>% |
|
21 |
#' analyze("BMRKR1") %>% |
|
22 |
#' split_cols_by("ARM") %>% |
|
23 |
#' split_rows_by("SEX") %>% |
|
24 |
#' summarize_row_groups() %>% |
|
25 |
#' split_rows_by("STRATA1") %>% |
|
26 |
#' summarize_row_groups() %>% |
|
27 |
#' analyze("AGE") %>% |
|
28 |
#' build_table(adsl) |
|
29 |
#' |
|
30 |
#' tbl_to_prune %>% prune_table(all_zero_or_na) |
|
31 |
#' |
|
32 |
#' @rdname trim_prune_funs |
|
33 |
#' @export |
|
34 |
all_zero_or_na <- function(tr) { |
|
35 | 347x |
if (!is(tr, "TableRow") || is(tr, "LabelRow")) { |
36 | 93x |
return(FALSE) |
37 |
} |
|
38 | 254x |
rvs <- unlist(unname(row_values(tr))) |
39 | 254x |
all(is.na(rvs) | rvs == 0 | !is.finite(rvs)) |
40 |
} |
|
41 | ||
42 |
#' @details `all_zero` returns `TRUE` for any non-`LabelRow` which contains only (non-missing) zero values. |
|
43 |
#' |
|
44 |
#' @examples |
|
45 |
#' tbl_to_prune %>% prune_table(all_zero) |
|
46 |
#' |
|
47 |
#' @rdname trim_prune_funs |
|
48 |
#' @export |
|
49 |
all_zero <- function(tr) { |
|
50 | 8x |
if (!is(tr, "TableRow") || is(tr, "LabelRow")) { |
51 | ! |
return(FALSE) |
52 |
} |
|
53 | 8x |
rvs <- unlist(unname(row_values(tr))) |
54 | 8x |
isTRUE(all(rvs == 0)) |
55 |
} |
|
56 | ||
57 |
#' Trim rows from a populated table without regard for table structure |
|
58 |
#' |
|
59 |
#' @inheritParams gen_args |
|
60 |
#' @param criteria (`function`)\cr function which takes a `TableRow` object and returns `TRUE` if that row |
|
61 |
#' should be removed. Defaults to [all_zero_or_na()]. |
|
62 |
#' |
|
63 |
#' @return The table with rows that have only `NA` or 0 cell values removed. |
|
64 |
#' |
|
65 |
#' @note |
|
66 |
#' Visible `LabelRow`s are including in this trimming, which can lead to either all label rows being trimmed or |
|
67 |
#' label rows remaining when all data rows have been trimmed, depending on what `criteria` returns when called on |
|
68 |
#' a `LabelRow` object. To avoid this, use the structurally-aware [prune_table()] machinery instead. |
|
69 |
#' |
|
70 |
#' @details |
|
71 |
#' This function will be deprecated in the future in favor of the more elegant and versatile [prune_table()] |
|
72 |
#' function which can perform the same function as `trim_rows()` but is more powerful as it takes table structure |
|
73 |
#' into account. |
|
74 |
#' |
|
75 |
#' @seealso [prune_table()] |
|
76 |
#' |
|
77 |
#' @examples |
|
78 |
#' adsl <- ex_adsl |
|
79 |
#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER") |
|
80 |
#' |
|
81 |
#' tbl_to_trim <- basic_table() %>% |
|
82 |
#' analyze("BMRKR1") %>% |
|
83 |
#' split_cols_by("ARM") %>% |
|
84 |
#' split_rows_by("SEX") %>% |
|
85 |
#' summarize_row_groups() %>% |
|
86 |
#' split_rows_by("STRATA1") %>% |
|
87 |
#' summarize_row_groups() %>% |
|
88 |
#' analyze("AGE") %>% |
|
89 |
#' build_table(adsl) |
|
90 |
#' |
|
91 |
#' tbl_to_trim %>% trim_rows() |
|
92 |
#' |
|
93 |
#' tbl_to_trim %>% trim_rows(all_zero) |
|
94 |
#' |
|
95 |
#' @export |
|
96 |
trim_rows <- function(tt, criteria = all_zero_or_na) { |
|
97 | 3x |
rows <- collect_leaves(tt, TRUE, TRUE) |
98 | 3x |
torm <- vapply(rows, criteria, |
99 | 3x |
NA, |
100 | 3x |
USE.NAMES = FALSE |
101 |
) |
|
102 | 3x |
tt[!torm, , |
103 | 3x |
keep_topleft = TRUE, |
104 | 3x |
keep_titles = TRUE, |
105 | 3x |
keep_footers = TRUE, |
106 | 3x |
reindex_refs = TRUE |
107 |
] |
|
108 |
} |
|
109 | ||
110 |
#' @inheritParams trim_rows |
|
111 |
#' |
|
112 |
#' @details |
|
113 |
#' `content_all_zeros_nas` prunes a subtable if both of the following are true: |
|
114 |
#' |
|
115 |
#' * It has a content table with exactly one row in it. |
|
116 |
#' * `all_zero_or_na` returns `TRUE` for that single content row. In practice, when the default summary/content |
|
117 |
#' function is used, this represents pruning any subtable which corresponds to an empty set of the input data |
|
118 |
#' (e.g. because a factor variable was used in [split_rows_by()] but not all levels were present in the data). |
|
119 |
#' |
|
120 |
#' @examples |
|
121 |
#' tbl_to_prune %>% prune_table(content_all_zeros_nas) |
|
122 |
#' |
|
123 |
#' @rdname trim_prune_funs |
|
124 |
#' @export |
|
125 |
content_all_zeros_nas <- function(tt, criteria = all_zero_or_na) { |
|
126 |
## this will be NULL if |
|
127 |
## tt is something that doesn't have a content table |
|
128 | 254x |
ct <- content_table(tt) |
129 |
## NROW returns 0 for NULL. |
|
130 | 254x |
if (NROW(ct) == 0 || nrow(ct) > 1) { |
131 | 242x |
return(FALSE) |
132 |
} |
|
133 | ||
134 | 12x |
cr <- tree_children(ct)[[1]] |
135 | 12x |
criteria(cr) |
136 |
} |
|
137 | ||
138 |
#' @details |
|
139 |
#' `prune_empty_level` combines `all_zero_or_na` behavior for `TableRow` objects, `content_all_zeros_nas` on |
|
140 |
#' `content_table(tt)` for `TableTree` objects, and an additional check that returns `TRUE` if the `tt` has no |
|
141 |
#' children. |
|
142 |
#' |
|
143 |
#' @examples |
|
144 |
#' tbl_to_prune %>% prune_table(prune_empty_level) |
|
145 |
#' |
|
146 |
#' @rdname trim_prune_funs |
|
147 |
#' @export |
|
148 |
prune_empty_level <- function(tt) { |
|
149 | 389x |
if (is(tt, "TableRow")) { |
150 | 151x |
return(all_zero_or_na(tt)) |
151 |
} |
|
152 | ||
153 | 238x |
if (content_all_zeros_nas(tt)) { |
154 | 2x |
return(TRUE) |
155 |
} |
|
156 | 236x |
kids <- tree_children(tt) |
157 | 236x |
length(kids) == 0 |
158 |
} |
|
159 | ||
160 |
#' @details `prune_zeros_only` behaves as `prune_empty_level` does, except that like `all_zero` it prunes |
|
161 |
#' only in the case of all non-missing zero values. |
|
162 |
#' |
|
163 |
#' @examples |
|
164 |
#' tbl_to_prune %>% prune_table(prune_zeros_only) |
|
165 |
#' |
|
166 |
#' @rdname trim_prune_funs |
|
167 |
#' @export |
|
168 |
prune_zeros_only <- function(tt) { |
|
169 | 16x |
if (is(tt, "TableRow")) { |
170 | 8x |
return(all_zero(tt)) |
171 |
} |
|
172 | ||
173 | 8x |
if (content_all_zeros_nas(tt, criteria = all_zero)) { |
174 | ! |
return(TRUE) |
175 |
} |
|
176 | 8x |
kids <- tree_children(tt) |
177 | 8x |
length(kids) == 0 |
178 |
} |
|
179 | ||
180 |
#' @param min (`numeric(1)`)\cr (used by `low_obs_pruner` only). Minimum aggregate count value. |
|
181 |
#' Subtables whose combined/average count are below this threshold will be pruned. |
|
182 |
#' @param type (`string`)\cr how count values should be aggregated. Must be `"sum"` (the default) or `"mean"`. |
|
183 |
#' |
|
184 |
#' @details |
|
185 |
#' `low_obs_pruner` is a *constructor function* which, when called, returns a pruning criteria function which |
|
186 |
#' will prune on content rows by comparing sum or mean (dictated by `type`) of the count portions of the cell |
|
187 |
#' values (defined as the first value per cell regardless of how many values per cell there are) against `min`. |
|
188 |
#' |
|
189 |
#' @examples |
|
190 |
#' min_prune <- low_obs_pruner(70, "sum") |
|
191 |
#' tbl_to_prune %>% prune_table(min_prune) |
|
192 |
#' |
|
193 |
#' @rdname trim_prune_funs |
|
194 |
#' @export |
|
195 |
low_obs_pruner <- function(min, type = c("sum", "mean")) { |
|
196 | 3x |
type <- match.arg(type) |
197 | 3x |
function(tt) { |
198 | 21x |
if (is(tt, "TableRow") || NROW(ctab <- content_table(tt)) != 1) { ## note the <- in there!!! |
199 | 9x |
return(FALSE) ## only trimming on count content rows |
200 |
} |
|
201 | 12x |
ctr <- tree_children(ctab)[[1]] |
202 | 12x |
vals <- sapply(row_values(ctr), function(v) v[[1]]) |
203 | 12x |
sumvals <- sum(vals) |
204 | 12x |
if (type == "mean") { |
205 | 8x |
sumvals <- sumvals / length(vals) |
206 |
} |
|
207 | 12x |
sumvals < min |
208 |
} |
|
209 |
} |
|
210 | ||
211 |
#' Recursively prune a `TableTree` |
|
212 |
#' |
|
213 |
#' @inheritParams gen_args |
|
214 |
#' @param prune_func (`function`)\cr a function to be called on each subtree which returns `TRUE` if the |
|
215 |
#' entire subtree should be removed. |
|
216 |
#' @param stop_depth (`numeric(1)`)\cr the depth after which subtrees should not be checked for pruning. |
|
217 |
#' Defaults to `NA` which indicates pruning should happen at all levels. |
|
218 |
#' @param depth (`numeric(1)`)\cr used internally, not intended to be set by the end user. |
|
219 |
#' |
|
220 |
#' @return A `TableTree` pruned via recursive application of `prune_func`. |
|
221 |
#' |
|
222 |
#' @seealso [prune_empty_level()] for details on this and several other basic pruning functions included |
|
223 |
#' in the `rtables` package. |
|
224 |
#' |
|
225 |
#' @examples |
|
226 |
#' adsl <- ex_adsl |
|
227 |
#' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER") |
|
228 |
#' |
|
229 |
#' tbl_to_prune <- basic_table() %>% |
|
230 |
#' split_cols_by("ARM") %>% |
|
231 |
#' split_rows_by("SEX") %>% |
|
232 |
#' summarize_row_groups() %>% |
|
233 |
#' split_rows_by("STRATA1") %>% |
|
234 |
#' summarize_row_groups() %>% |
|
235 |
#' analyze("AGE") %>% |
|
236 |
#' build_table(adsl) |
|
237 |
#' |
|
238 |
#' tbl_to_prune %>% prune_table() |
|
239 |
#' |
|
240 |
#' @export |
|
241 |
prune_table <- function(tt, |
|
242 |
prune_func = prune_empty_level, |
|
243 |
stop_depth = NA_real_, |
|
244 |
depth = 0) { |
|
245 | 323x |
if (!is.na(stop_depth) && depth > stop_depth) { |
246 | ! |
return(tt) |
247 |
} |
|
248 | 323x |
if (is(tt, "TableRow")) { |
249 | 54x |
if (prune_func(tt)) { |
250 | ! |
tt <- NULL |
251 |
} |
|
252 | 54x |
return(tt) |
253 |
} |
|
254 | ||
255 | 269x |
kids <- tree_children(tt) |
256 | ||
257 | 269x |
torm <- vapply(kids, function(tb) { |
258 | 386x |
!is.null(tb) && prune_func(tb) |
259 | 269x |
}, NA) |
260 | ||
261 | 269x |
keepkids <- kids[!torm] |
262 | 269x |
keepkids <- lapply(keepkids, prune_table, |
263 | 269x |
prune_func = prune_func, |
264 | 269x |
stop_depth = stop_depth, |
265 | 269x |
depth = depth + 1 |
266 |
) |
|
267 | ||
268 | 269x |
keepkids <- keepkids[!vapply(keepkids, is.null, NA)] |
269 | 269x |
if (length(keepkids) > 0) { |
270 | 135x |
tree_children(tt) <- keepkids |
271 |
} else { |
|
272 | 134x |
tt <- NULL |
273 |
} |
|
274 | 269x |
tt |
275 |
} |
1 |
label_pos_values <- c("hidden", "visible", "topleft") |
|
2 | ||
3 |
#' @name internal_methods |
|
4 |
#' @rdname int_methods |
|
5 |
NULL |
|
6 | ||
7 |
#' Combine `SplitVector` objects |
|
8 |
#' |
|
9 |
#' @param x (`SplitVector`)\cr a `SplitVector` object. |
|
10 |
#' @param ... splits or `SplitVector` objects. |
|
11 |
#' |
|
12 |
#' @return Various, but should be considered implementation details. |
|
13 |
#' |
|
14 |
#' @rdname int_methods |
|
15 |
#' @exportMethod c |
|
16 |
setMethod("c", "SplitVector", function(x, ...) { |
|
17 | 375x |
arglst <- list(...) |
18 | 375x |
stopifnot(all(sapply(arglst, is, "Split"))) |
19 | 375x |
tmp <- c(unclass(x), arglst) |
20 | 375x |
SplitVector(lst = tmp) |
21 |
}) |
|
22 | ||
23 |
## split_rows and split_cols are "recursive method stacks" which follow |
|
24 |
## the general pattern of accept object -> call add_*_split on slot of object -> |
|
25 |
## update object with value returned from slot method, return object. |
|
26 |
## |
|
27 |
## Thus each of the methods is idempotent, returning an updated object of the |
|
28 |
## same class it was passed. The exception for idempotency is the NULL method |
|
29 |
## which constructs a PreDataTableLayouts object with the specified split in the |
|
30 |
## correct place. |
|
31 | ||
32 |
## The cascading (by class) in this case is as follows for the row case: |
|
33 |
## PreDataTableLayouts -> PreDataRowLayout -> SplitVector |
|
34 |
#' @param cmpnd_fun (`function`)\cr intended for internal use. |
|
35 |
#' @param pos (`numeric(1)`)\cr intended for internal use. |
|
36 |
#' @param spl (`Split`)\cr the split. |
|
37 |
#' |
|
38 |
#' @rdname int_methods |
|
39 |
setGeneric( |
|
40 |
"split_rows", |
|
41 |
function(lyt = NULL, spl, pos, |
|
42 |
cmpnd_fun = AnalyzeMultiVars) { |
|
43 | 1592x |
standardGeneric("split_rows") |
44 |
} |
|
45 |
) |
|
46 | ||
47 |
#' @rdname int_methods |
|
48 |
setMethod("split_rows", "NULL", function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) { |
|
49 | 1x |
.Deprecated(msg = "Initializing layouts via NULL is deprecated, please use basic_table() instead") |
50 | 1x |
rl <- PreDataRowLayout(SplitVector(spl)) |
51 | 1x |
cl <- PreDataColLayout() |
52 | 1x |
PreDataTableLayouts(rlayout = rl, clayout = cl) |
53 |
}) |
|
54 | ||
55 |
#' @rdname int_methods |
|
56 |
setMethod( |
|
57 |
"split_rows", "PreDataRowLayout", |
|
58 |
function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) { |
|
59 | 539x |
stopifnot(pos > 0 && pos <= length(lyt) + 1) |
60 | 539x |
tmp <- if (pos <= length(lyt)) { |
61 | 513x |
split_rows(lyt[[pos]], spl, pos, cmpnd_fun) |
62 |
} else { |
|
63 | 26x |
if (pos != 1 && has_force_pag(spl)) { |
64 | 1x |
stop("page_by splits cannot have top-level siblings", |
65 | 1x |
call. = FALSE |
66 |
) |
|
67 |
} |
|
68 | 25x |
SplitVector(spl) |
69 |
} |
|
70 | 537x |
lyt[[pos]] <- tmp |
71 | 537x |
lyt |
72 |
} |
|
73 |
) |
|
74 | ||
75 |
is_analysis_spl <- function(spl) { |
|
76 | ! |
is(spl, "VAnalyzeSplit") || is(spl, "AnalyzeMultiVars") |
77 |
} |
|
78 | ||
79 |
## note "pos" is ignored here because it is for which nest-chain |
|
80 |
## spl should be placed in, NOIT for where in that chain it should go |
|
81 |
#' @rdname int_methods |
|
82 |
setMethod( |
|
83 |
"split_rows", "SplitVector", |
|
84 |
function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) { |
|
85 |
## if(is_analysis_spl(spl) && |
|
86 |
## is_analysis_spl(last_rowsplit(lyt))) { |
|
87 |
## return(cmpnd_last_rowsplit(lyt, spl, cmpnd_fun)) |
|
88 |
## } |
|
89 | ||
90 | 513x |
if (has_force_pag(spl) && length(lyt) > 0 && !has_force_pag(lyt[[length(lyt)]])) { |
91 | 1x |
stop("page_by splits cannot be nested within non-page_by splits", |
92 | 1x |
call. = FALSE |
93 |
) |
|
94 |
} |
|
95 | 512x |
tmp <- c(unclass(lyt), spl) |
96 | 512x |
SplitVector(lst = tmp) |
97 |
} |
|
98 |
) |
|
99 | ||
100 |
#' @rdname int_methods |
|
101 |
setMethod( |
|
102 |
"split_rows", "PreDataTableLayouts", |
|
103 |
function(lyt, spl, pos) { |
|
104 | 539x |
rlyt <- rlayout(lyt) |
105 | 539x |
addtl <- FALSE |
106 | 539x |
split_label <- obj_label(spl) |
107 |
if ( |
|
108 | 539x |
is(spl, "Split") && ## exclude existing tables that are being tacked in |
109 | 539x |
identical(label_position(spl), "topleft") && |
110 | 539x |
length(split_label) == 1 && nzchar(split_label) |
111 |
) { |
|
112 | 19x |
addtl <- TRUE |
113 |
## label_position(spl) <- "hidden" |
|
114 |
} |
|
115 | ||
116 | 539x |
rlyt <- split_rows(rlyt, spl, pos) |
117 | 537x |
rlayout(lyt) <- rlyt |
118 | 537x |
if (addtl) { |
119 | 19x |
lyt <- append_topleft(lyt, indent_string(split_label, .tl_indent(lyt))) |
120 |
} |
|
121 | 537x |
lyt |
122 |
} |
|
123 |
) |
|
124 | ||
125 |
#' @rdname int_methods |
|
126 |
setMethod( |
|
127 |
"split_rows", "ANY", |
|
128 |
function(lyt, spl, pos) { |
|
129 | ! |
stop("nope. can't add a row split to that (", class(lyt), "). contact the maintaner.") |
130 |
} |
|
131 |
) |
|
132 | ||
133 |
## cmpnd_last_rowsplit ===== |
|
134 | ||
135 |
#' @rdname int_methods |
|
136 |
#' |
|
137 |
#' @param constructor (`function`)\cr constructor function. |
|
138 | 82x |
setGeneric("cmpnd_last_rowsplit", function(lyt, spl, constructor) standardGeneric("cmpnd_last_rowsplit")) |
139 | ||
140 |
#' @rdname int_methods |
|
141 |
setMethod("cmpnd_last_rowsplit", "NULL", function(lyt, spl, constructor) { |
|
142 |
stop("no existing splits to compound with. contact the maintainer") # nocov |
|
143 |
}) |
|
144 | ||
145 |
#' @rdname int_methods |
|
146 |
setMethod( |
|
147 |
"cmpnd_last_rowsplit", "PreDataRowLayout", |
|
148 |
function(lyt, spl, constructor) { |
|
149 | 27x |
pos <- length(lyt) |
150 | 27x |
tmp <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor) |
151 | 27x |
lyt[[pos]] <- tmp |
152 | 27x |
lyt |
153 |
} |
|
154 |
) |
|
155 |
#' @rdname int_methods |
|
156 |
setMethod( |
|
157 |
"cmpnd_last_rowsplit", "SplitVector", |
|
158 |
function(lyt, spl, constructor) { |
|
159 | 28x |
pos <- length(lyt) |
160 | 28x |
lst <- lyt[[pos]] |
161 | 28x |
tmp <- if (is(lst, "CompoundSplit")) { |
162 | 3x |
spl_payload(lst) <- c( |
163 | 3x |
.uncompound(spl_payload(lst)), |
164 | 3x |
.uncompound(spl) |
165 |
) |
|
166 | 3x |
obj_name(lst) <- make_ma_name(spl = lst) |
167 | 3x |
lst |
168 |
## XXX never reached because AnalzyeMultiVars inherits from |
|
169 |
## CompoundSplit??? |
|
170 |
} else { |
|
171 | 25x |
constructor(.payload = list(lst, spl)) |
172 |
} |
|
173 | 28x |
lyt[[pos]] <- tmp |
174 | 28x |
lyt |
175 |
} |
|
176 |
) |
|
177 | ||
178 |
#' @rdname int_methods |
|
179 |
setMethod( |
|
180 |
"cmpnd_last_rowsplit", "PreDataTableLayouts", |
|
181 |
function(lyt, spl, constructor) { |
|
182 | 27x |
rlyt <- rlayout(lyt) |
183 | 27x |
rlyt <- cmpnd_last_rowsplit(rlyt, spl, constructor) |
184 | 27x |
rlayout(lyt) <- rlyt |
185 | 27x |
lyt |
186 |
} |
|
187 |
) |
|
188 |
#' @rdname int_methods |
|
189 |
setMethod( |
|
190 |
"cmpnd_last_rowsplit", "ANY", |
|
191 |
function(lyt, spl, constructor) { |
|
192 | ! |
stop( |
193 | ! |
"nope. can't do cmpnd_last_rowsplit to that (", |
194 | ! |
class(lyt), "). contact the maintaner." |
195 |
) |
|
196 |
} |
|
197 |
) |
|
198 | ||
199 |
## split_cols ==== |
|
200 | ||
201 |
#' @rdname int_methods |
|
202 |
setGeneric( |
|
203 |
"split_cols", |
|
204 |
function(lyt = NULL, spl, pos) { |
|
205 | 950x |
standardGeneric("split_cols") |
206 |
} |
|
207 |
) |
|
208 | ||
209 |
#' @rdname int_methods |
|
210 |
setMethod("split_cols", "NULL", function(lyt, spl, pos) { |
|
211 | 1x |
.Deprecated(msg = paste( |
212 | 1x |
"Initializing layouts via NULL is deprecated,", |
213 | 1x |
"please use basic_table() instead" |
214 |
)) |
|
215 | 1x |
cl <- PreDataColLayout(SplitVector(spl)) |
216 | 1x |
rl <- PreDataRowLayout() |
217 | 1x |
PreDataTableLayouts(rlayout = rl, clayout = cl) |
218 |
}) |
|
219 | ||
220 |
#' @rdname int_methods |
|
221 |
setMethod( |
|
222 |
"split_cols", "PreDataColLayout", |
|
223 |
function(lyt, spl, pos) { |
|
224 | 287x |
stopifnot(pos > 0 && pos <= length(lyt) + 1) |
225 | 287x |
tmp <- if (pos <= length(lyt)) { |
226 | 282x |
split_cols(lyt[[pos]], spl, pos) |
227 |
} else { |
|
228 | 5x |
SplitVector(spl) |
229 |
} |
|
230 | ||
231 | 287x |
lyt[[pos]] <- tmp |
232 | 287x |
lyt |
233 |
} |
|
234 |
) |
|
235 | ||
236 |
#' @rdname int_methods |
|
237 |
setMethod( |
|
238 |
"split_cols", "SplitVector", |
|
239 |
function(lyt, spl, pos) { |
|
240 | 375x |
tmp <- c(lyt, spl) |
241 | 375x |
SplitVector(lst = tmp) |
242 |
} |
|
243 |
) |
|
244 | ||
245 |
#' @rdname int_methods |
|
246 |
setMethod( |
|
247 |
"split_cols", "PreDataTableLayouts", |
|
248 |
function(lyt, spl, pos) { |
|
249 | 287x |
rlyt <- lyt@col_layout |
250 | 287x |
rlyt <- split_cols(rlyt, spl, pos) |
251 | 287x |
lyt@col_layout <- rlyt |
252 | 287x |
lyt |
253 |
} |
|
254 |
) |
|
255 | ||
256 |
#' @rdname int_methods |
|
257 |
setMethod( |
|
258 |
"split_cols", "ANY", |
|
259 |
function(lyt, spl, pos) { |
|
260 | ! |
stop( |
261 | ! |
"nope. can't add a col split to that (", class(lyt), |
262 | ! |
"). contact the maintaner." |
263 |
) |
|
264 |
} |
|
265 |
) |
|
266 | ||
267 |
# Constructors ===== |
|
268 | ||
269 |
## Pipe-able functions to add the various types of splits to the current layout |
|
270 |
## for both row and column. These all act as wrappers to the split_cols and |
|
271 |
## split_rows method stacks. |
|
272 | ||
273 |
#' Declaring a column-split based on levels of a variable |
|
274 |
#' |
|
275 |
#' Will generate children for each subset of a categorical variable. |
|
276 |
#' |
|
277 |
#' @inheritParams lyt_args |
|
278 |
#' @param ref_group (`string` or `NULL`)\cr level of `var` that should be considered `ref_group`/reference. |
|
279 |
#' |
|
280 |
#' @return A `PreDataTableLayouts` object suitable for passing to further layouting functions, and to [build_table()]. |
|
281 |
#' |
|
282 |
#' @inheritSection custom_split_funs Custom Splitting Function Details |
|
283 |
#' |
|
284 |
#' @examples |
|
285 |
#' lyt <- basic_table() %>% |
|
286 |
#' split_cols_by("ARM") %>% |
|
287 |
#' analyze(c("AGE", "BMRKR2")) |
|
288 |
#' |
|
289 |
#' tbl <- build_table(lyt, ex_adsl) |
|
290 |
#' tbl |
|
291 |
#' |
|
292 |
#' # Let's look at the splits in more detail |
|
293 |
#' |
|
294 |
#' lyt1 <- basic_table() %>% split_cols_by("ARM") |
|
295 |
#' lyt1 |
|
296 |
#' |
|
297 |
#' # add an analysis (summary) |
|
298 |
#' lyt2 <- lyt1 %>% |
|
299 |
#' analyze(c("AGE", "COUNTRY"), |
|
300 |
#' afun = list_wrap_x(summary), |
|
301 |
#' format = "xx.xx" |
|
302 |
#' ) |
|
303 |
#' lyt2 |
|
304 |
#' |
|
305 |
#' tbl2 <- build_table(lyt2, DM) |
|
306 |
#' tbl2 |
|
307 |
#' |
|
308 |
#' # By default sequentially adding layouts results in nesting |
|
309 |
#' library(dplyr) |
|
310 |
#' |
|
311 |
#' DM_MF <- DM %>% |
|
312 |
#' filter(SEX %in% c("M", "F")) %>% |
|
313 |
#' mutate(SEX = droplevels(SEX)) |
|
314 |
#' |
|
315 |
#' lyt3 <- basic_table() %>% |
|
316 |
#' split_cols_by("ARM") %>% |
|
317 |
#' split_cols_by("SEX") %>% |
|
318 |
#' analyze(c("AGE", "COUNTRY"), |
|
319 |
#' afun = list_wrap_x(summary), |
|
320 |
#' format = "xx.xx" |
|
321 |
#' ) |
|
322 |
#' lyt3 |
|
323 |
#' |
|
324 |
#' tbl3 <- build_table(lyt3, DM_MF) |
|
325 |
#' tbl3 |
|
326 |
#' |
|
327 |
#' # nested=TRUE vs not |
|
328 |
#' lyt4 <- basic_table() %>% |
|
329 |
#' split_cols_by("ARM") %>% |
|
330 |
#' split_rows_by("SEX", split_fun = drop_split_levels) %>% |
|
331 |
#' split_rows_by("RACE", split_fun = drop_split_levels) %>% |
|
332 |
#' analyze("AGE") |
|
333 |
#' lyt4 |
|
334 |
#' |
|
335 |
#' tbl4 <- build_table(lyt4, DM) |
|
336 |
#' tbl4 |
|
337 |
#' |
|
338 |
#' lyt5 <- basic_table() %>% |
|
339 |
#' split_cols_by("ARM") %>% |
|
340 |
#' split_rows_by("SEX", split_fun = drop_split_levels) %>% |
|
341 |
#' analyze("AGE") %>% |
|
342 |
#' split_rows_by("RACE", nested = FALSE, split_fun = drop_split_levels) %>% |
|
343 |
#' analyze("AGE") |
|
344 |
#' lyt5 |
|
345 |
#' |
|
346 |
#' tbl5 <- build_table(lyt5, DM) |
|
347 |
#' tbl5 |
|
348 |
#' |
|
349 |
#' @author Gabriel Becker |
|
350 |
#' @export |
|
351 |
split_cols_by <- function(lyt, |
|
352 |
var, |
|
353 |
labels_var = var, |
|
354 |
split_label = var, |
|
355 |
split_fun = NULL, |
|
356 |
format = NULL, |
|
357 |
nested = TRUE, |
|
358 |
child_labels = c("default", "visible", "hidden"), |
|
359 |
extra_args = list(), |
|
360 |
ref_group = NULL) { ## , |
|
361 | 252x |
if (is.null(ref_group)) { |
362 | 243x |
spl <- VarLevelSplit( |
363 | 243x |
var = var, |
364 | 243x |
split_label = split_label, |
365 | 243x |
labels_var = labels_var, |
366 | 243x |
split_format = format, |
367 | 243x |
child_labels = child_labels, |
368 | 243x |
split_fun = split_fun, |
369 | 243x |
extra_args = extra_args |
370 |
) |
|
371 |
} else { |
|
372 | 9x |
spl <- VarLevWBaselineSplit( |
373 | 9x |
var = var, |
374 | 9x |
ref_group = ref_group, |
375 | 9x |
split_label = split_label, |
376 | 9x |
split_fun = split_fun, |
377 | 9x |
labels_var = labels_var, |
378 | 9x |
split_format = format |
379 |
) |
|
380 |
} |
|
381 | 252x |
pos <- next_cpos(lyt, nested) |
382 | 252x |
split_cols(lyt, spl, pos) |
383 |
} |
|
384 | ||
385 |
## .tl_indent ==== |
|
386 | ||
387 | 57x |
setGeneric(".tl_indent_inner", function(lyt) standardGeneric(".tl_indent_inner")) |
388 | ||
389 |
setMethod( |
|
390 |
".tl_indent_inner", "PreDataTableLayouts", |
|
391 | 19x |
function(lyt) .tl_indent_inner(rlayout(lyt)) |
392 |
) |
|
393 |
setMethod( |
|
394 |
".tl_indent_inner", "PreDataRowLayout", |
|
395 |
function(lyt) { |
|
396 | 19x |
if (length(lyt) == 0 || length(lyt[[1]]) == 0) { |
397 | ! |
0L |
398 |
} else { |
|
399 | 19x |
.tl_indent_inner(lyt[[length(lyt)]]) |
400 |
} |
|
401 |
} |
|
402 |
) |
|
403 | ||
404 |
setMethod( |
|
405 |
".tl_indent_inner", "SplitVector", |
|
406 |
function(lyt) { |
|
407 | 19x |
sum(vapply(lyt, function(x) label_position(x) == "topleft", TRUE)) - 1L |
408 |
} |
|
409 |
) ## length(lyt) - 1L) |
|
410 | ||
411 |
.tl_indent <- function(lyt, nested = TRUE) { |
|
412 | 19x |
if (!nested) { |
413 | ! |
0L |
414 |
} else { |
|
415 | 19x |
.tl_indent_inner(lyt) |
416 |
} |
|
417 |
} |
|
418 | ||
419 |
#' Add rows according to levels of a variable |
|
420 |
#' |
|
421 |
#' @inheritParams lyt_args |
|
422 |
#' |
|
423 |
#' @inherit split_cols_by return |
|
424 |
#' |
|
425 |
#' @inheritSection custom_split_funs Custom Splitting Function Details |
|
426 |
#' |
|
427 |
#' @note |
|
428 |
#' If `var` is a factor with empty unobserved levels and `labels_var` is specified, it must also be a factor |
|
429 |
#' with the same number of levels as `var`. Currently the error that occurs when this is not the case is not very |
|
430 |
#' informative, but that will change in the future. |
|
431 |
#' |
|
432 |
#' @examples |
|
433 |
#' lyt <- basic_table() %>% |
|
434 |
#' split_cols_by("ARM") %>% |
|
435 |
#' split_rows_by("RACE", split_fun = drop_split_levels) %>% |
|
436 |
#' analyze("AGE", mean, var_labels = "Age", format = "xx.xx") |
|
437 |
#' |
|
438 |
#' tbl <- build_table(lyt, DM) |
|
439 |
#' tbl |
|
440 |
#' |
|
441 |
#' lyt2 <- basic_table() %>% |
|
442 |
#' split_cols_by("ARM") %>% |
|
443 |
#' split_rows_by("RACE") %>% |
|
444 |
#' analyze("AGE", mean, var_labels = "Age", format = "xx.xx") |
|
445 |
#' |
|
446 |
#' tbl2 <- build_table(lyt2, DM) |
|
447 |
#' tbl2 |
|
448 |
#' |
|
449 |
#' lyt3 <- basic_table() %>% |
|
450 |
#' split_cols_by("ARM") %>% |
|
451 |
#' split_cols_by("SEX") %>% |
|
452 |
#' summarize_row_groups(label_fstr = "Overall (N)") %>% |
|
453 |
#' split_rows_by("RACE", |
|
454 |
#' split_label = "Ethnicity", labels_var = "ethn_lab", |
|
455 |
#' split_fun = drop_split_levels |
|
456 |
#' ) %>% |
|
457 |
#' summarize_row_groups("RACE", label_fstr = "%s (n)") %>% |
|
458 |
#' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx") |
|
459 |
#' |
|
460 |
#' lyt3 |
|
461 |
#' |
|
462 |
#' library(dplyr) |
|
463 |
#' |
|
464 |
#' DM2 <- DM %>% |
|
465 |
#' filter(SEX %in% c("M", "F")) %>% |
|
466 |
#' mutate( |
|
467 |
#' SEX = droplevels(SEX), |
|
468 |
#' gender_lab = c( |
|
469 |
#' "F" = "Female", "M" = "Male", |
|
470 |
#' "U" = "Unknown", |
|
471 |
#' "UNDIFFERENTIATED" = "Undifferentiated" |
|
472 |
#' )[SEX], |
|
473 |
#' ethn_lab = c( |
|
474 |
#' "ASIAN" = "Asian", |
|
475 |
#' "BLACK OR AFRICAN AMERICAN" = "Black or African American", |
|
476 |
#' "WHITE" = "White", |
|
477 |
#' "AMERICAN INDIAN OR ALASKA NATIVE" = "American Indian or Alaska Native", |
|
478 |
#' "MULTIPLE" = "Multiple", |
|
479 |
#' "NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER" = |
|
480 |
#' "Native Hawaiian or Other Pacific Islander", |
|
481 |
#' "OTHER" = "Other", "UNKNOWN" = "Unknown" |
|
482 |
#' )[RACE] |
|
483 |
#' ) |
|
484 |
#' |
|
485 |
#' tbl3 <- build_table(lyt3, DM2) |
|
486 |
#' tbl3 |
|
487 |
#' |
|
488 |
#' @author Gabriel Becker |
|
489 |
#' @export |
|
490 |
split_rows_by <- function(lyt, |
|
491 |
var, |
|
492 |
labels_var = var, |
|
493 |
split_label = var, |
|
494 |
split_fun = NULL, |
|
495 |
format = NULL, |
|
496 |
na_str = NA_character_, |
|
497 |
nested = TRUE, |
|
498 |
child_labels = c("default", "visible", "hidden"), |
|
499 |
label_pos = "hidden", |
|
500 |
indent_mod = 0L, |
|
501 |
page_by = FALSE, |
|
502 |
page_prefix = split_label, |
|
503 |
section_div = NA_character_) { |
|
504 | 242x |
label_pos <- match.arg(label_pos, label_pos_values) |
505 | 242x |
child_labels <- match.arg(child_labels) |
506 | 242x |
spl <- VarLevelSplit( |
507 | 242x |
var = var, |
508 | 242x |
split_label = split_label, |
509 | 242x |
label_pos = label_pos, |
510 | 242x |
labels_var = labels_var, |
511 | 242x |
split_fun = split_fun, |
512 | 242x |
split_format = format, |
513 | 242x |
split_na_str = na_str, |
514 | 242x |
child_labels = child_labels, |
515 | 242x |
indent_mod = indent_mod, |
516 | 242x |
page_prefix = if (page_by) page_prefix else NA_character_, |
517 | 242x |
section_div = section_div |
518 |
) |
|
519 | ||
520 | 242x |
pos <- next_rpos(lyt, nested) |
521 | 242x |
ret <- split_rows(lyt, spl, pos) |
522 | ||
523 | 240x |
ret |
524 |
} |
|
525 | ||
526 |
#' Associate multiple variables with columns |
|
527 |
#' |
|
528 |
#' In some cases, the variable to be ultimately analyzed is most naturally defined on a column, not a row, basis. |
|
529 |
#' When we need columns to reflect different variables entirely, rather than different levels of a single |
|
530 |
#' variable, we use `split_cols_by_multivar`. |
|
531 |
#' |
|
532 |
#' @inheritParams lyt_args |
|
533 |
#' |
|
534 |
#' @inherit split_cols_by return |
|
535 |
#' |
|
536 |
#' @seealso [analyze_colvars()] |
|
537 |
#' |
|
538 |
#' @examples |
|
539 |
#' library(dplyr) |
|
540 |
#' |
|
541 |
#' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n())) |
|
542 |
#' |
|
543 |
#' ## toy example where we take the mean of the first variable and the |
|
544 |
#' ## count of >.5 for the second. |
|
545 |
#' colfuns <- list( |
|
546 |
#' function(x) in_rows(mean = mean(x), .formats = "xx.x"), |
|
547 |
#' function(x) in_rows("# x > 5" = sum(x > .5), .formats = "xx") |
|
548 |
#' ) |
|
549 |
#' |
|
550 |
#' lyt <- basic_table() %>% |
|
551 |
#' split_cols_by("ARM") %>% |
|
552 |
#' split_cols_by_multivar(c("value", "pctdiff")) %>% |
|
553 |
#' split_rows_by("RACE", |
|
554 |
#' split_label = "ethnicity", |
|
555 |
#' split_fun = drop_split_levels |
|
556 |
#' ) %>% |
|
557 |
#' summarize_row_groups() %>% |
|
558 |
#' analyze_colvars(afun = colfuns) |
|
559 |
#' lyt |
|
560 |
#' |
|
561 |
#' tbl <- build_table(lyt, ANL) |
|
562 |
#' tbl |
|
563 |
#' |
|
564 |
#' @author Gabriel Becker |
|
565 |
#' @export |
|
566 |
split_cols_by_multivar <- function(lyt, |
|
567 |
vars, |
|
568 |
split_fun = NULL, |
|
569 |
varlabels = vars, |
|
570 |
varnames = NULL, |
|
571 |
nested = TRUE, |
|
572 |
extra_args = list()) { |
|
573 | 24x |
spl <- MultiVarSplit( |
574 | 24x |
vars = vars, split_label = "", |
575 | 24x |
varlabels = varlabels, |
576 | 24x |
varnames = varnames, |
577 | 24x |
split_fun = split_fun, |
578 | 24x |
extra_args = extra_args |
579 |
) |
|
580 | 24x |
pos <- next_cpos(lyt, nested) |
581 | 24x |
split_cols(lyt, spl, pos) |
582 |
} |
|
583 | ||
584 |
#' Associate multiple variables with rows |
|
585 |
#' |
|
586 |
#' When we need rows to reflect different variables rather than different |
|
587 |
#' levels of a single variable, we use `split_rows_by_multivar`. |
|
588 |
#' |
|
589 |
#' @inheritParams lyt_args |
|
590 |
#' |
|
591 |
#' @inherit split_rows_by return |
|
592 |
#' |
|
593 |
#' @seealso [split_rows_by()] for typical row splitting, and [split_cols_by_multivar()] to perform the same type of |
|
594 |
#' split on a column basis. |
|
595 |
#' |
|
596 |
#' @examples |
|
597 |
#' lyt <- basic_table() %>% |
|
598 |
#' split_cols_by("ARM") %>% |
|
599 |
#' split_rows_by_multivar(c("SEX", "STRATA1")) %>% |
|
600 |
#' summarize_row_groups() %>% |
|
601 |
#' analyze(c("AGE", "SEX")) |
|
602 |
#' |
|
603 |
#' tbl <- build_table(lyt, DM) |
|
604 |
#' tbl |
|
605 |
#' |
|
606 |
#' @export |
|
607 |
split_rows_by_multivar <- function(lyt, |
|
608 |
vars, |
|
609 |
split_fun = NULL, |
|
610 |
split_label = "", |
|
611 |
varlabels = vars, |
|
612 |
format = NULL, |
|
613 |
na_str = NA_character_, |
|
614 |
nested = TRUE, |
|
615 |
child_labels = c("default", "visible", "hidden"), |
|
616 |
indent_mod = 0L, |
|
617 |
section_div = NA_character_, |
|
618 |
extra_args = list()) { |
|
619 | 2x |
child_labels <- match.arg(child_labels) |
620 | 2x |
spl <- MultiVarSplit( |
621 | 2x |
vars = vars, split_label = split_label, varlabels, |
622 | 2x |
split_format = format, |
623 | 2x |
split_na_str = na_str, |
624 | 2x |
child_labels = child_labels, |
625 | 2x |
indent_mod = indent_mod, |
626 | 2x |
split_fun = split_fun, |
627 | 2x |
section_div = section_div, |
628 | 2x |
extra_args = extra_args |
629 |
) |
|
630 | 2x |
pos <- next_rpos(lyt, nested) |
631 | 2x |
split_rows(lyt, spl, pos) |
632 |
} |
|
633 | ||
634 |
#' Split on static or dynamic cuts of the data |
|
635 |
#' |
|
636 |
#' Create columns (or row splits) based on values (such as quartiles) of `var`. |
|
637 |
#' |
|
638 |
#' @inheritParams lyt_args |
|
639 |
#' |
|
640 |
#' @details For dynamic cuts, the cut is transformed into a static cut by [build_table()] *based on the full dataset*, |
|
641 |
#' before proceeding. Thus even when nested within another split in column/row space, the resulting split will reflect |
|
642 |
#' the overall values (e.g., quartiles) in the dataset, NOT the values for subset it is nested under. |
|
643 |
#' |
|
644 |
#' @inherit split_cols_by return |
|
645 |
#' |
|
646 |
#' @examples |
|
647 |
#' library(dplyr) |
|
648 |
#' |
|
649 |
#' # split_cols_by_cuts |
|
650 |
#' lyt <- basic_table() %>% |
|
651 |
#' split_cols_by("ARM") %>% |
|
652 |
#' split_cols_by_cuts("AGE", |
|
653 |
#' split_label = "Age", |
|
654 |
#' cuts = c(0, 25, 35, 1000), |
|
655 |
#' cutlabels = c("young", "medium", "old") |
|
656 |
#' ) %>% |
|
657 |
#' analyze(c("BMRKR2", "STRATA2")) %>% |
|
658 |
#' append_topleft("counts") |
|
659 |
#' |
|
660 |
#' tbl <- build_table(lyt, ex_adsl) |
|
661 |
#' tbl |
|
662 |
#' |
|
663 |
#' # split_rows_by_cuts |
|
664 |
#' lyt2 <- basic_table() %>% |
|
665 |
#' split_cols_by("ARM") %>% |
|
666 |
#' split_rows_by_cuts("AGE", |
|
667 |
#' split_label = "Age", |
|
668 |
#' cuts = c(0, 25, 35, 1000), |
|
669 |
#' cutlabels = c("young", "medium", "old") |
|
670 |
#' ) %>% |
|
671 |
#' analyze(c("BMRKR2", "STRATA2")) %>% |
|
672 |
#' append_topleft("counts") |
|
673 |
#' |
|
674 |
#' |
|
675 |
#' tbl2 <- build_table(lyt2, ex_adsl) |
|
676 |
#' tbl2 |
|
677 |
#' |
|
678 |
#' # split_cols_by_quartiles |
|
679 |
#' |
|
680 |
#' lyt3 <- basic_table() %>% |
|
681 |
#' split_cols_by("ARM") %>% |
|
682 |
#' split_cols_by_quartiles("AGE", split_label = "Age") %>% |
|
683 |
#' analyze(c("BMRKR2", "STRATA2")) %>% |
|
684 |
#' append_topleft("counts") |
|
685 |
#' |
|
686 |
#' tbl3 <- build_table(lyt3, ex_adsl) |
|
687 |
#' tbl3 |
|
688 |
#' |
|
689 |
#' # split_rows_by_quartiles |
|
690 |
#' lyt4 <- basic_table(show_colcounts = TRUE) %>% |
|
691 |
#' split_cols_by("ARM") %>% |
|
692 |
#' split_rows_by_quartiles("AGE", split_label = "Age") %>% |
|
693 |
#' analyze("BMRKR2") %>% |
|
694 |
#' append_topleft(c("Age Quartiles", " Counts BMRKR2")) |
|
695 |
#' |
|
696 |
#' tbl4 <- build_table(lyt4, ex_adsl) |
|
697 |
#' tbl4 |
|
698 |
#' |
|
699 |
#' # split_cols_by_cutfun |
|
700 |
#' cutfun <- function(x) { |
|
701 |
#' cutpoints <- c( |
|
702 |
#' min(x), |
|
703 |
#' mean(x), |
|
704 |
#' max(x) |
|
705 |
#' ) |
|
706 |
#' |
|
707 |
#' names(cutpoints) <- c("", "Younger", "Older") |
|
708 |
#' cutpoints |
|
709 |
#' } |
|
710 |
#' |
|
711 |
#' lyt5 <- basic_table() %>% |
|
712 |
#' split_cols_by_cutfun("AGE", cutfun = cutfun) %>% |
|
713 |
#' analyze("SEX") |
|
714 |
#' |
|
715 |
#' tbl5 <- build_table(lyt5, ex_adsl) |
|
716 |
#' tbl5 |
|
717 |
#' |
|
718 |
#' # split_rows_by_cutfun |
|
719 |
#' lyt6 <- basic_table() %>% |
|
720 |
#' split_cols_by("SEX") %>% |
|
721 |
#' split_rows_by_cutfun("AGE", cutfun = cutfun) %>% |
|
722 |
#' analyze("BMRKR2") |
|
723 |
#' |
|
724 |
#' tbl6 <- build_table(lyt6, ex_adsl) |
|
725 |
#' tbl6 |
|
726 |
#' |
|
727 |
#' @author Gabriel Becker |
|
728 |
#' @export |
|
729 |
#' @rdname varcuts |
|
730 |
split_cols_by_cuts <- function(lyt, var, cuts, |
|
731 |
cutlabels = NULL, |
|
732 |
split_label = var, |
|
733 |
nested = TRUE, |
|
734 |
cumulative = FALSE) { |
|
735 | 3x |
spl <- make_static_cut_split( |
736 | 3x |
var = var, |
737 | 3x |
split_label = split_label, |
738 | 3x |
cuts = cuts, |
739 | 3x |
cutlabels = cutlabels, |
740 | 3x |
cumulative = cumulative |
741 |
) |
|
742 |
## if(cumulative) |
|
743 |
## spl = as(spl, "CumulativeCutSplit") |
|
744 | 3x |
pos <- next_cpos(lyt, nested) |
745 | 3x |
split_cols(lyt, spl, pos) |
746 |
} |
|
747 | ||
748 |
#' @export |
|
749 |
#' @rdname varcuts |
|
750 |
split_rows_by_cuts <- function(lyt, var, cuts, |
|
751 |
cutlabels = NULL, |
|
752 |
split_label = var, |
|
753 |
format = NULL, |
|
754 |
na_str = NA_character_, |
|
755 |
nested = TRUE, |
|
756 |
cumulative = FALSE, |
|
757 |
label_pos = "hidden", |
|
758 |
section_div = NA_character_) { |
|
759 | 2x |
label_pos <- match.arg(label_pos, label_pos_values) |
760 |
## VarStaticCutSplit( |
|
761 | 2x |
spl <- make_static_cut_split(var, split_label, |
762 | 2x |
cuts = cuts, |
763 | 2x |
cutlabels = cutlabels, |
764 | 2x |
split_format = format, |
765 | 2x |
split_na_str = na_str, |
766 | 2x |
label_pos = label_pos, |
767 | 2x |
cumulative = cumulative, |
768 | 2x |
section_div = section_div |
769 |
) |
|
770 |
## if(cumulative) |
|
771 |
## spl = as(spl, "CumulativeCutSplit") |
|
772 | 2x |
pos <- next_rpos(lyt, nested) |
773 | 2x |
split_rows(lyt, spl, pos) |
774 |
} |
|
775 | ||
776 |
#' @export |
|
777 |
#' @rdname varcuts |
|
778 |
split_cols_by_cutfun <- function(lyt, var, |
|
779 |
cutfun = qtile_cuts, |
|
780 |
cutlabelfun = function(x) NULL, |
|
781 |
split_label = var, |
|
782 |
nested = TRUE, |
|
783 |
extra_args = list(), |
|
784 |
cumulative = FALSE) { |
|
785 | 3x |
spl <- VarDynCutSplit(var, split_label, |
786 | 3x |
cutfun = cutfun, |
787 | 3x |
cutlabelfun = cutlabelfun, |
788 | 3x |
extra_args = extra_args, |
789 | 3x |
cumulative = cumulative, |
790 | 3x |
label_pos = "hidden" |
791 |
) |
|
792 | 3x |
pos <- next_cpos(lyt, nested) |
793 | 3x |
split_cols(lyt, spl, pos) |
794 |
} |
|
795 | ||
796 |
#' @export |
|
797 |
#' @rdname varcuts |
|
798 |
split_cols_by_quartiles <- function(lyt, var, split_label = var, |
|
799 |
nested = TRUE, |
|
800 |
extra_args = list(), |
|
801 |
cumulative = FALSE) { |
|
802 | 2x |
split_cols_by_cutfun( |
803 | 2x |
lyt = lyt, |
804 | 2x |
var = var, |
805 | 2x |
split_label = split_label, |
806 | 2x |
cutfun = qtile_cuts, |
807 | 2x |
cutlabelfun = function(x) { |
808 | 2x |
c( |
809 | 2x |
"[min, Q1]", |
810 | 2x |
"(Q1, Q2]", |
811 | 2x |
"(Q2, Q3]", |
812 | 2x |
"(Q3, max]" |
813 |
) |
|
814 |
}, |
|
815 | 2x |
nested = nested, |
816 | 2x |
extra_args = extra_args, |
817 | 2x |
cumulative = cumulative |
818 |
) |
|
819 |
## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts, |
|
820 |
## cutlabelfun = function(x) c("[min, Q1]", |
|
821 |
## "(Q1, Q2]", |
|
822 |
## "(Q2, Q3]", |
|
823 |
## "(Q3, max]"), |
|
824 |
## split_format = format, |
|
825 |
## extra_args = extra_args, |
|
826 |
## cumulative = cumulative, |
|
827 |
## label_pos = "hidden") |
|
828 |
## pos = next_cpos(lyt, nested) |
|
829 |
## split_cols(lyt, spl, pos) |
|
830 |
} |
|
831 | ||
832 |
#' @export |
|
833 |
#' @rdname varcuts |
|
834 |
split_rows_by_quartiles <- function(lyt, var, split_label = var, |
|
835 |
format = NULL, |
|
836 |
na_str = NA_character_, |
|
837 |
nested = TRUE, |
|
838 |
child_labels = c("default", "visible", "hidden"), |
|
839 |
extra_args = list(), |
|
840 |
cumulative = FALSE, |
|
841 |
indent_mod = 0L, |
|
842 |
label_pos = "hidden", |
|
843 |
section_div = NA_character_) { |
|
844 | 2x |
split_rows_by_cutfun( |
845 | 2x |
lyt = lyt, |
846 | 2x |
var = var, |
847 | 2x |
split_label = split_label, |
848 | 2x |
format = format, |
849 | 2x |
na_str = na_str, |
850 | 2x |
cutfun = qtile_cuts, |
851 | 2x |
cutlabelfun = function(x) { |
852 | 2x |
c( |
853 | 2x |
"[min, Q1]", |
854 | 2x |
"(Q1, Q2]", |
855 | 2x |
"(Q2, Q3]", |
856 | 2x |
"(Q3, max]" |
857 |
) |
|
858 |
}, |
|
859 | 2x |
nested = nested, |
860 | 2x |
child_labels = child_labels, |
861 | 2x |
extra_args = extra_args, |
862 | 2x |
cumulative = cumulative, |
863 | 2x |
indent_mod = indent_mod, |
864 | 2x |
label_pos = label_pos, |
865 | 2x |
section_div = section_div |
866 |
) |
|
867 | ||
868 |
## label_pos <- match.arg(label_pos, label_pos_values) |
|
869 |
## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts, |
|
870 |
## cutlabelfun = , |
|
871 |
## split_format = format, |
|
872 |
## child_labels = child_labels, |
|
873 |
## extra_args = extra_args, |
|
874 |
## cumulative = cumulative, |
|
875 |
## indent_mod = indent_mod, |
|
876 |
## label_pos = label_pos) |
|
877 |
## pos = next_rpos(lyt, nested) |
|
878 |
## split_rows(lyt, spl, pos) |
|
879 |
} |
|
880 | ||
881 |
qtile_cuts <- function(x) { |
|
882 | 6x |
ret <- quantile(x) |
883 | 6x |
names(ret) <- c( |
884 |
"", |
|
885 | 6x |
"1st qrtile", |
886 | 6x |
"2nd qrtile", |
887 | 6x |
"3rd qrtile", |
888 | 6x |
"4th qrtile" |
889 |
) |
|
890 | 6x |
ret |
891 |
} |
|
892 | ||
893 |
#' @export |
|
894 |
#' @rdname varcuts |
|
895 |
split_rows_by_cutfun <- function(lyt, var, |
|
896 |
cutfun = qtile_cuts, |
|
897 |
cutlabelfun = function(x) NULL, |
|
898 |
split_label = var, |
|
899 |
format = NULL, |
|
900 |
na_str = NA_character_, |
|
901 |
nested = TRUE, |
|
902 |
child_labels = c("default", "visible", "hidden"), |
|
903 |
extra_args = list(), |
|
904 |
cumulative = FALSE, |
|
905 |
indent_mod = 0L, |
|
906 |
label_pos = "hidden", |
|
907 |
section_div = NA_character_) { |
|
908 | 2x |
label_pos <- match.arg(label_pos, label_pos_values) |
909 | 2x |
child_labels <- match.arg(child_labels) |
910 | 2x |
spl <- VarDynCutSplit(var, split_label, |
911 | 2x |
cutfun = cutfun, |
912 | 2x |
cutlabelfun = cutlabelfun, |
913 | 2x |
split_format = format, |
914 | 2x |
split_na_str = na_str, |
915 | 2x |
child_labels = child_labels, |
916 | 2x |
extra_args = extra_args, |
917 | 2x |
cumulative = cumulative, |
918 | 2x |
indent_mod = indent_mod, |
919 | 2x |
label_pos = label_pos, |
920 | 2x |
section_div = section_div |
921 |
) |
|
922 | 2x |
pos <- next_rpos(lyt, nested) |
923 | 2x |
split_rows(lyt, spl, pos) |
924 |
} |
|
925 | ||
926 |
#' .spl_context within analysis and split functions |
|
927 |
#' |
|
928 |
#' `.spl_context` is an optional parameter for any of rtables' special functions, i.e. `afun` (analysis function |
|
929 |
#' in [analyze()]), `cfun` (content or label function in [summarize_row_groups()]), or `split_fun` (e.g. for |
|
930 |
#' [split_rows_by()]). |
|
931 |
#' |
|
932 |
#' @details |
|
933 |
#' The `.spl_context` `data.frame` gives information about the subsets of data corresponding to the splits within |
|
934 |
#' which the current `analyze` action is nested. Taken together, these correspond to the path that the resulting (set |
|
935 |
#' of) rows the analysis function is creating, although the information is in a slightly different form. Each split |
|
936 |
#' (which correspond to groups of rows in the resulting table), as well as the initial 'root' "split", is represented |
|
937 |
#' via the following columns: |
|
938 |
#' |
|
939 |
#' \describe{ |
|
940 |
#' \item{split}{The name of the split (often the variable being split).} |
|
941 |
#' \item{value}{The string representation of the value at that split (`split`).} |
|
942 |
#' \item{full_parent_df}{A `data.frame` containing the full data (i.e. across all columns) corresponding to the path |
|
943 |
#' defined by the combination of `split` and `value` of this row *and all rows above this row*.} |
|
944 |
#' \item{all_cols_n}{The number of observations corresponding to the row grouping (union of all columns).} |
|
945 |
#' \item{column for each column in the table structure (*row-split and analyze contexts only*)}{These list columns |
|
946 |
#' (named the same as `names(col_exprs(tab))`) contain logical vectors corresponding to the subset of this row's |
|
947 |
#' `full_parent_df` corresponding to the column.} |
|
948 |
#' \item{cur_col_id}{Identifier of the current column. This may be an internal name, constructed by pasting the |
|
949 |
#' column path together.} |
|
950 |
#' \item{cur_col_subset}{List column containing logical vectors indicating the subset of this row's `full_parent_df` |
|
951 |
#' for the column currently being created by the analysis function.} |
|
952 |
#' \item{cur_col_expr}{List of current column expression. This may be used to filter `.alt_df_row`, or any external |
|
953 |
#' data, by column. Filtering `.alt_df_row` by columns produces `.alt_df`.} |
|
954 |
#' \item{cur_col_n}{Integer column containing the observation counts for that split.} |
|
955 |
#' \item{cur_col_split}{Current column split names. This is recovered from the current column path.} |
|
956 |
#' \item{cur_col_split_val}{Current column split values. This is recovered from the current column path.} |
|
957 |
#' } |
|
958 |
#' |
|
959 |
#' @note |
|
960 |
#' Within analysis functions that accept `.spl_context`, the `all_cols_n` and `cur_col_n` columns of the data frame |
|
961 |
#' will contain the 'true' observation counts corresponding to the row-group and row-group x column subsets of the |
|
962 |
#' data. These numbers will not, and currently cannot, reflect alternate column observation counts provided by the |
|
963 |
#' `alt_counts_df`, `col_counts` or `col_total` arguments to [build_table()]. |
|
964 |
#' |
|
965 |
#' @name spl_context |
|
966 |
NULL |
|
967 | ||
968 |
#' Additional parameters within analysis and content functions (`afun`/`cfun`) |
|
969 |
#' |
|
970 |
#' @description |
|
971 |
#' It is possible to add specific parameters to `afun` and `cfun`, in [analyze()] and [summarize_row_groups()], |
|
972 |
#' respectively. These parameters grant access to relevant information like the row split structure (see |
|
973 |
#' [spl_context]) and the predefined baseline (`.ref_group`). |
|
974 |
#' |
|
975 |
#' @details |
|
976 |
#' We list and describe all the parameters that can be added to a custom analysis function below: |
|
977 |
#' |
|
978 |
#' \describe{ |
|
979 |
#' \item{.N_col}{Column-wise N (column count) for the full column being tabulated within.} |
|
980 |
#' \item{.N_total}{Overall N (all observation count, defined as sum of column counts) for the tabulation.} |
|
981 |
#' \item{.N_row}{Row-wise N (row group count) for the group of observations being analyzed (i.e. with no |
|
982 |
#' column-based subsetting).} |
|
983 |
#' \item{.df_row}{`data.frame` for observations in the row group being analyzed (i.e. with no column-based |
|
984 |
#' subsetting).} |
|
985 |
#' \item{.var}{Variable being analyzed.} |
|
986 |
#' \item{.ref_group}{`data.frame` or vector of subset corresponding to the `ref_group` column including subsetting |
|
987 |
#' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.} |
|
988 |
#' \item{.ref_full}{`data.frame` or vector of subset corresponding to the `ref_group` column without subsetting |
|
989 |
#' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.} |
|
990 |
#' \item{.in_ref_col}{Boolean indicating if calculation is done for cells within the reference column.} |
|
991 |
#' \item{.spl_context}{`data.frame` where each row gives information about a previous 'ancestor' split state. |
|
992 |
#' See [spl_context].} |
|
993 |
#' \item{.alt_df_row}{`data.frame`, i.e. the `alt_count_df` after row splitting. It can be used with |
|
994 |
#' `.all_col_exprs` and `.spl_context` information to retrieve current faceting, but for `alt_count_df`. |
|
995 |
#' It can be an empty table if all the entries are filtered out.} |
|
996 |
#' \item{.alt_df}{`data.frame`, `.alt_df_row` but filtered by columns expression. This data present the same |
|
997 |
#' faceting of main data `df`. This also filters `NA`s out if related parameters are set to do so (e.g. `inclNAs` |
|
998 |
#' in [analyze()]). Similarly to `.alt_df_row`, it can be an empty table if all the entries are filtered out.} |
|
999 |
#' \item{.all_col_exprs}{List of expressions. Each of them represents a different column splitting.} |
|
1000 |
#' \item{.all_col_counts}{Vector of integers. Each of them represents the global count for each column. It differs |
|
1001 |
#' if `alt_counts_df` is used (see [build_table()]).} |
|
1002 |
#' } |
|
1003 |
#' |
|
1004 |
#' @note If any of these formals is specified incorrectly or not present in the tabulation machinery, it will be |
|
1005 |
#' treated as if missing. For example, `.ref_group` will be missing if no baseline is previously defined during |
|
1006 |
#' data splitting (via `ref_group` parameters in, e.g., [split_rows_by()]). Similarly, if no `alt_counts_df` is |
|
1007 |
#' provided to [build_table()], `.alt_df_row` and `.alt_df` will not be present. |
|
1008 |
#' |
|
1009 |
#' @name additional_fun_params |
|
1010 |
NULL |
|
1011 | ||
1012 |
#' Generate rows analyzing variables across columns |
|
1013 |
#' |
|
1014 |
#' Adding *analyzed variables* to our table layout defines the primary tabulation to be performed. We do this by |
|
1015 |
#' adding calls to `analyze` and/or [analyze_colvars()] into our layout pipeline. As with adding further splitting, |
|
1016 |
#' the tabulation will occur at the current/next level of nesting by default. |
|
1017 |
#' |
|
1018 |
#' @inheritParams lyt_args |
|
1019 |
#' |
|
1020 |
#' @inherit split_cols_by return |
|
1021 |
#' |
|
1022 |
#' @details |
|
1023 |
#' When non-`NULL`, `format` is used to specify formats for all generated rows, and can be a character vector, a |
|
1024 |
#' function, or a list of functions. It will be repped out to the number of rows once this is calculated during the |
|
1025 |
#' tabulation process, but will be overridden by formats specified within `rcell` calls in `afun`. |
|
1026 |
#' |
|
1027 |
#' The analysis function (`afun`) should take as its first parameter either `x` or `df`. Whichever of these the |
|
1028 |
#' function accepts will change the behavior when tabulation is performed as follows: |
|
1029 |
#' |
|
1030 |
#' - If `afun`'s first parameter is `x`, it will receive the corresponding subset *vector* of data from the relevant |
|
1031 |
#' column (from `var` here) of the raw data being used to build the table. |
|
1032 |
#' - If `afun`'s first parameter is `df`, it will receive the corresponding subset *data frame* (i.e. all columns) of |
|
1033 |
#' the raw data being tabulated. |
|
1034 |
#' |
|
1035 |
#' In addition to differentiation on the first argument, the analysis function can optionally accept a number of |
|
1036 |
#' other parameters which, *if and only if* present in the formals, will be passed to the function by the tabulation |
|
1037 |
#' machinery. These are listed and described in [additional_fun_params]. |
|
1038 |
#' |
|
1039 |
#' @note None of the arguments described in the Details section can be overridden via `extra_args` or when calling |
|
1040 |
#' [make_afun()]. `.N_col` and `.N_total` can be overridden via the `col_counts` argument to [build_table()]. |
|
1041 |
#' Alternative values for the others must be calculated within `afun` based on a combination of extra arguments and |
|
1042 |
#' the unmodified values provided by the tabulation framework. |
|
1043 |
#' |
|
1044 |
#' @examples |
|
1045 |
#' lyt <- basic_table() %>% |
|
1046 |
#' split_cols_by("ARM") %>% |
|
1047 |
#' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") |
|
1048 |
#' lyt |
|
1049 |
#' |
|
1050 |
#' tbl <- build_table(lyt, DM) |
|
1051 |
#' tbl |
|
1052 |
#' |
|
1053 |
#' lyt2 <- basic_table() %>% |
|
1054 |
#' split_cols_by("Species") %>% |
|
1055 |
#' analyze(head(names(iris), -1), afun = function(x) { |
|
1056 |
#' list( |
|
1057 |
#' "mean / sd" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), |
|
1058 |
#' "range" = rcell(diff(range(x)), format = "xx.xx") |
|
1059 |
#' ) |
|
1060 |
#' }) |
|
1061 |
#' lyt2 |
|
1062 |
#' |
|
1063 |
#' tbl2 <- build_table(lyt2, iris) |
|
1064 |
#' tbl2 |
|
1065 |
#' |
|
1066 |
#' @author Gabriel Becker |
|
1067 |
#' @export |
|
1068 |
analyze <- function(lyt, |
|
1069 |
vars, |
|
1070 |
afun = simple_analysis, |
|
1071 |
var_labels = vars, |
|
1072 |
table_names = vars, |
|
1073 |
format = NULL, |
|
1074 |
na_str = NA_character_, |
|
1075 |
nested = TRUE, |
|
1076 |
## can't name this na_rm symbol conflict with possible afuns!! |
|
1077 |
inclNAs = FALSE, |
|
1078 |
extra_args = list(), |
|
1079 |
show_labels = c("default", "visible", "hidden"), |
|
1080 |
indent_mod = 0L, |
|
1081 |
section_div = NA_character_) { |
|
1082 | 298x |
show_labels <- match.arg(show_labels) |
1083 | 298x |
subafun <- substitute(afun) |
1084 |
if ( |
|
1085 | 298x |
is.name(subafun) && |
1086 | 298x |
is.function(afun) && |
1087 |
## this is gross. basically testing |
|
1088 |
## if the symbol we have corresponds |
|
1089 |
## in some meaningful way to the function |
|
1090 |
## we will be calling. |
|
1091 | 298x |
identical( |
1092 | 298x |
mget( |
1093 | 298x |
as.character(subafun), |
1094 | 298x |
mode = "function", |
1095 | 298x |
ifnotfound = list(NULL), |
1096 | 298x |
inherits = TRUE |
1097 | 298x |
)[[1]], afun |
1098 |
) |
|
1099 |
) { |
|
1100 | 165x |
defrowlab <- as.character(subafun) |
1101 |
} else { |
|
1102 | 133x |
defrowlab <- var_labels |
1103 |
} |
|
1104 | ||
1105 | 298x |
spl <- AnalyzeMultiVars(vars, var_labels, |
1106 | 298x |
afun = afun, |
1107 | 298x |
split_format = format, |
1108 | 298x |
split_na_str = na_str, |
1109 | 298x |
defrowlab = defrowlab, |
1110 | 298x |
inclNAs = inclNAs, |
1111 | 298x |
extra_args = extra_args, |
1112 | 298x |
indent_mod = indent_mod, |
1113 | 298x |
child_names = table_names, |
1114 | 298x |
child_labels = show_labels, |
1115 | 298x |
section_div = section_div |
1116 |
) |
|
1117 | ||
1118 | 298x |
if (nested && (is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars"))) { |
1119 | 27x |
cmpnd_last_rowsplit(lyt, spl, AnalyzeMultiVars) |
1120 |
} else { |
|
1121 |
## analysis compounding now done in split_rows |
|
1122 | 269x |
pos <- next_rpos(lyt, nested) |
1123 | 269x |
split_rows(lyt, spl, pos) |
1124 |
} |
|
1125 |
} |
|
1126 | ||
1127 |
get_acolvar_name <- function(lyt) { |
|
1128 |
## clyt <- clayout(lyt) |
|
1129 |
## stopifnot(length(clyt) == 1L) |
|
1130 |
## vec = clyt[[1]] |
|
1131 |
## vcls = vapply(vec, class, "") |
|
1132 |
## pos = max(which(vcls == "MultiVarSplit")) |
|
1133 | 22x |
paste(c("ac", get_acolvar_vars(lyt)), collapse = "_") |
1134 |
} |
|
1135 | ||
1136 |
get_acolvar_vars <- function(lyt) { |
|
1137 | 35x |
clyt <- clayout(lyt) |
1138 | 35x |
stopifnot(length(clyt) == 1L) |
1139 | 35x |
vec <- clyt[[1]] |
1140 | 35x |
vcls <- vapply(vec, class, "") |
1141 | 35x |
pos <- which(vcls == "MultiVarSplit") |
1142 | 35x |
if (length(pos) > 0) { |
1143 | 35x |
spl_payload(vec[[pos]]) |
1144 |
} else { |
|
1145 | ! |
"non_multivar" |
1146 |
} |
|
1147 |
} |
|
1148 | ||
1149 |
#' Generate rows analyzing different variables across columns |
|
1150 |
#' |
|
1151 |
#' @inheritParams lyt_args |
|
1152 |
#' @param afun (`function` or `list`)\cr function(s) to be used to calculate the values in each column. The list |
|
1153 |
#' will be repped out as needed and matched by position with the columns during tabulation. This functions |
|
1154 |
#' accepts the same parameters as [analyze()] like `afun` and `format`. For further information see |
|
1155 |
#' [additional_fun_params]. |
|
1156 |
#' |
|
1157 |
#' @inherit split_cols_by return |
|
1158 |
#' |
|
1159 |
#' @seealso [split_cols_by_multivar()] |
|
1160 |
#' |
|
1161 |
#' @examples |
|
1162 |
#' library(dplyr) |
|
1163 |
#' |
|
1164 |
#' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n())) |
|
1165 |
#' |
|
1166 |
#' ## toy example where we take the mean of the first variable and the |
|
1167 |
#' ## count of >.5 for the second. |
|
1168 |
#' colfuns <- list( |
|
1169 |
#' function(x) rcell(mean(x), format = "xx.x"), |
|
1170 |
#' function(x) rcell(sum(x > .5), format = "xx") |
|
1171 |
#' ) |
|
1172 |
#' |
|
1173 |
#' lyt <- basic_table() %>% |
|
1174 |
#' split_cols_by("ARM") %>% |
|
1175 |
#' split_cols_by_multivar(c("value", "pctdiff")) %>% |
|
1176 |
#' split_rows_by("RACE", |
|
1177 |
#' split_label = "ethnicity", |
|
1178 |
#' split_fun = drop_split_levels |
|
1179 |
#' ) %>% |
|
1180 |
#' summarize_row_groups() %>% |
|
1181 |
#' analyze_colvars(afun = colfuns) |
|
1182 |
#' lyt |
|
1183 |
#' |
|
1184 |
#' tbl <- build_table(lyt, ANL) |
|
1185 |
#' tbl |
|
1186 |
#' |
|
1187 |
#' lyt2 <- basic_table() %>% |
|
1188 |
#' split_cols_by("ARM") %>% |
|
1189 |
#' split_cols_by_multivar(c("value", "pctdiff"), |
|
1190 |
#' varlabels = c("Measurement", "Pct Diff") |
|
1191 |
#' ) %>% |
|
1192 |
#' split_rows_by("RACE", |
|
1193 |
#' split_label = "ethnicity", |
|
1194 |
#' split_fun = drop_split_levels |
|
1195 |
#' ) %>% |
|
1196 |
#' summarize_row_groups() %>% |
|
1197 |
#' analyze_colvars(afun = mean, format = "xx.xx") |
|
1198 |
#' |
|
1199 |
#' tbl2 <- build_table(lyt2, ANL) |
|
1200 |
#' tbl2 |
|
1201 |
#' |
|
1202 |
#' @author Gabriel Becker |
|
1203 |
#' @export |
|
1204 |
analyze_colvars <- function(lyt, |
|
1205 |
afun, |
|
1206 |
format = NULL, |
|
1207 |
na_str = NA_character_, |
|
1208 |
nested = TRUE, |
|
1209 |
extra_args = list(), |
|
1210 |
indent_mod = 0L, |
|
1211 |
inclNAs = FALSE) { |
|
1212 | 22x |
if (is.function(afun)) { |
1213 | 13x |
subafun <- substitute(afun) |
1214 |
if ( |
|
1215 | 13x |
is.name(subafun) && |
1216 | 13x |
is.function(afun) && |
1217 |
## this is gross. basically testing |
|
1218 |
## if the symbol we have corresponds |
|
1219 |
## in some meaningful way to the function |
|
1220 |
## we will be calling. |
|
1221 | 13x |
identical( |
1222 | 13x |
mget( |
1223 | 13x |
as.character(subafun), |
1224 | 13x |
mode = "function", |
1225 | 13x |
ifnotfound = list(NULL), |
1226 | 13x |
inherits = TRUE |
1227 | 13x |
)[[1]], |
1228 | 13x |
afun |
1229 |
) |
|
1230 |
) { |
|
1231 | 13x |
defrowlab <- as.character(subafun) |
1232 |
} else { |
|
1233 | ! |
defrowlab <- "" |
1234 |
} |
|
1235 | 13x |
afun <- lapply( |
1236 | 13x |
get_acolvar_vars(lyt), |
1237 | 13x |
function(x) afun |
1238 |
) |
|
1239 |
} else { |
|
1240 | 9x |
defrowlab <- "" |
1241 |
} |
|
1242 | 22x |
spl <- AnalyzeColVarSplit( |
1243 | 22x |
afun = afun, |
1244 | 22x |
defrowlab = defrowlab, |
1245 | 22x |
split_format = format, |
1246 | 22x |
split_na_str = na_str, |
1247 | 22x |
split_name = get_acolvar_name(lyt), |
1248 | 22x |
indent_mod = indent_mod, |
1249 | 22x |
extra_args = extra_args, |
1250 | 22x |
inclNAs = inclNAs |
1251 |
) |
|
1252 | 22x |
pos <- next_rpos(lyt, nested, for_analyze = TRUE) |
1253 | 22x |
split_rows(lyt, spl, pos) |
1254 |
} |
|
1255 | ||
1256 |
## Add a total column at the next **top level** spot in |
|
1257 |
## the column layout. |
|
1258 | ||
1259 |
#' Add overall column |
|
1260 |
#' |
|
1261 |
#' This function will *only* add an overall column at the *top* level of splitting, NOT within existing column splits. |
|
1262 |
#' See [add_overall_level()] for the recommended way to add overall columns more generally within existing splits. |
|
1263 |
#' |
|
1264 |
#' @inheritParams lyt_args |
|
1265 |
#' |
|
1266 |
#' @inherit split_cols_by return |
|
1267 |
#' |
|
1268 |
#' @seealso [add_overall_level()] |
|
1269 |
#' |
|
1270 |
#' @examples |
|
1271 |
#' lyt <- basic_table() %>% |
|
1272 |
#' split_cols_by("ARM") %>% |
|
1273 |
#' add_overall_col("All Patients") %>% |
|
1274 |
#' analyze("AGE") |
|
1275 |
#' lyt |
|
1276 |
#' |
|
1277 |
#' tbl <- build_table(lyt, DM) |
|
1278 |
#' tbl |
|
1279 |
#' |
|
1280 |
#' @export |
|
1281 |
add_overall_col <- function(lyt, label) { |
|
1282 | 99x |
spl <- AllSplit(label) |
1283 | 99x |
split_cols( |
1284 | 99x |
lyt, |
1285 | 99x |
spl, |
1286 | 99x |
next_cpos(lyt, FALSE) |
1287 |
) |
|
1288 |
} |
|
1289 | ||
1290 |
## add_row_summary ==== |
|
1291 | ||
1292 |
#' @inheritParams lyt_args |
|
1293 |
#' |
|
1294 |
#' @export |
|
1295 |
#' |
|
1296 |
#' @rdname int_methods |
|
1297 |
setGeneric( |
|
1298 |
".add_row_summary", |
|
1299 |
function(lyt, |
|
1300 |
label, |
|
1301 |
cfun, |
|
1302 |
child_labels = c("default", "visible", "hidden"), |
|
1303 |
cformat = NULL, |
|
1304 |
cna_str = "-", |
|
1305 |
indent_mod = 0L, |
|
1306 |
cvar = "", |
|
1307 |
extra_args = list()) { |
|
1308 | 411x |
standardGeneric(".add_row_summary") |
1309 |
} |
|
1310 |
) |
|
1311 | ||
1312 |
#' @rdname int_methods |
|
1313 |
setMethod( |
|
1314 |
".add_row_summary", "PreDataTableLayouts", |
|
1315 |
function(lyt, |
|
1316 |
label, |
|
1317 |
cfun, |
|
1318 |
child_labels = c("default", "visible", "hidden"), |
|
1319 |
cformat = NULL, |
|
1320 |
cna_str = "-", |
|
1321 |
indent_mod = 0L, |
|
1322 |
cvar = "", |
|
1323 |
extra_args = list()) { |
|
1324 | 105x |
child_labels <- match.arg(child_labels) |
1325 | 105x |
tmp <- .add_row_summary(rlayout(lyt), label, cfun, |
1326 | 105x |
child_labels = child_labels, |
1327 | 105x |
cformat = cformat, |
1328 | 105x |
cna_str = cna_str, |
1329 | 105x |
indent_mod = indent_mod, |
1330 | 105x |
cvar = cvar, |
1331 | 105x |
extra_args = extra_args |
1332 |
) |
|
1333 | 105x |
rlayout(lyt) <- tmp |
1334 | 105x |
lyt |
1335 |
} |
|
1336 |
) |
|
1337 | ||
1338 |
#' @rdname int_methods |
|
1339 |
setMethod( |
|
1340 |
".add_row_summary", "PreDataRowLayout", |
|
1341 |
function(lyt, |
|
1342 |
label, |
|
1343 |
cfun, |
|
1344 |
child_labels = c("default", "visible", "hidden"), |
|
1345 |
cformat = NULL, |
|
1346 |
cna_str = "-", |
|
1347 |
indent_mod = 0L, |
|
1348 |
cvar = "", |
|
1349 |
extra_args = list()) { |
|
1350 | 105x |
child_labels <- match.arg(child_labels) |
1351 | 105x |
if (length(lyt) == 0 || (length(lyt) == 1 && length(lyt[[1]]) == 0)) { |
1352 |
## XXX ignoring indent mod here |
|
1353 | 9x |
rt <- root_spl(lyt) |
1354 | 9x |
rt <- .add_row_summary(rt, |
1355 | 9x |
label, |
1356 | 9x |
cfun, |
1357 | 9x |
child_labels = child_labels, |
1358 | 9x |
cformat = cformat, |
1359 | 9x |
cna_str = cna_str, |
1360 | 9x |
cvar = cvar, |
1361 | 9x |
extra_args = extra_args |
1362 |
) |
|
1363 | 9x |
root_spl(lyt) <- rt |
1364 |
} else { |
|
1365 | 96x |
ind <- length(lyt) |
1366 | 96x |
tmp <- .add_row_summary(lyt[[ind]], label, cfun, |
1367 | 96x |
child_labels = child_labels, |
1368 | 96x |
cformat = cformat, |
1369 | 96x |
cna_str = cna_str, |
1370 | 96x |
indent_mod = indent_mod, |
1371 | 96x |
cvar = cvar, |
1372 | 96x |
extra_args = extra_args |
1373 |
) |
|
1374 | 96x |
lyt[[ind]] <- tmp |
1375 |
} |
|
1376 | 105x |
lyt |
1377 |
} |
|
1378 |
) |
|
1379 | ||
1380 |
#' @rdname int_methods |
|
1381 |
setMethod( |
|
1382 |
".add_row_summary", "SplitVector", |
|
1383 |
function(lyt, |
|
1384 |
label, |
|
1385 |
cfun, |
|
1386 |
child_labels = c("default", "visible", "hidden"), |
|
1387 |
cformat = NULL, |
|
1388 |
cna_str = "-", |
|
1389 |
indent_mod = 0L, |
|
1390 |
cvar = "", |
|
1391 |
extra_args = list()) { |
|
1392 | 96x |
child_labels <- match.arg(child_labels) |
1393 | 96x |
ind <- length(lyt) |
1394 | ! |
if (ind == 0) stop("no split to add content rows at") |
1395 | 96x |
spl <- lyt[[ind]] |
1396 |
# if(is(spl, "AnalyzeVarSplit")) |
|
1397 |
# stop("can't add content rows to analyze variable split") |
|
1398 | 96x |
tmp <- .add_row_summary(spl, |
1399 | 96x |
label, |
1400 | 96x |
cfun, |
1401 | 96x |
child_labels = child_labels, |
1402 | 96x |
cformat = cformat, |
1403 | 96x |
cna_str = cna_str, |
1404 | 96x |
indent_mod = indent_mod, |
1405 | 96x |
cvar = cvar, |
1406 | 96x |
extra_args = extra_args |
1407 |
) |
|
1408 | 96x |
lyt[[ind]] <- tmp |
1409 | 96x |
lyt |
1410 |
} |
|
1411 |
) |
|
1412 | ||
1413 |
#' @rdname int_methods |
|
1414 |
setMethod( |
|
1415 |
".add_row_summary", "Split", |
|
1416 |
function(lyt, |
|
1417 |
label, |
|
1418 |
cfun, |
|
1419 |
child_labels = c("default", "visible", "hidden"), |
|
1420 |
cformat = NULL, |
|
1421 |
cna_str = "-", |
|
1422 |
indent_mod = 0L, |
|
1423 |
cvar = "", |
|
1424 |
extra_args = list()) { |
|
1425 | 105x |
child_labels <- match.arg(child_labels) |
1426 |
# lbl_kids = .labelkids_helper(child_labels) |
|
1427 | 105x |
content_fun(lyt) <- cfun |
1428 | 105x |
content_indent_mod(lyt) <- indent_mod |
1429 | 105x |
content_var(lyt) <- cvar |
1430 |
## obj_format(lyt) = cformat |
|
1431 | 105x |
content_format(lyt) <- cformat |
1432 | 105x |
if (!identical(child_labels, "default") && !identical(child_labels, label_kids(lyt))) { |
1433 | ! |
label_kids(lyt) <- child_labels |
1434 |
} |
|
1435 | 105x |
content_na_str <- cna_str |
1436 | 105x |
content_extra_args(lyt) <- extra_args |
1437 | 105x |
lyt |
1438 |
} |
|
1439 |
) |
|
1440 | ||
1441 |
.count_raw_constr <- function(var, format, label_fstr) { |
|
1442 | 2x |
function(df, labelstr = "") { |
1443 | 24x |
if (grepl("%s", label_fstr, fixed = TRUE)) { |
1444 | 21x |
label <- sprintf(label_fstr, labelstr) |
1445 |
} else { |
|
1446 | 3x |
label <- label_fstr |
1447 |
} |
|
1448 | 24x |
if (is(df, "data.frame")) { |
1449 | 24x |
if (!is.null(var) && nzchar(var)) { |
1450 | 3x |
cnt <- sum(!is.na(df[[var]])) |
1451 |
} else { |
|
1452 | 21x |
cnt <- nrow(df) |
1453 |
} |
|
1454 | 2x |
} else { # df is the data column vector |
1455 | ! |
cnt <- sum(!is.na(df)) |
1456 |
} |
|
1457 | 24x |
ret <- rcell(cnt, |
1458 | 24x |
format = format, |
1459 | 24x |
label = label |
1460 |
) |
|
1461 | 24x |
ret |
1462 |
} |
|
1463 |
} |
|
1464 | ||
1465 |
.count_wpcts_constr <- function(var, format, label_fstr) { |
|
1466 | 90x |
function(df, labelstr = "", .N_col) { |
1467 | 1523x |
if (grepl("%s", label_fstr, fixed = TRUE)) { |
1468 | 1499x |
label <- sprintf(label_fstr, labelstr) |
1469 |
} else { |
|
1470 | 24x |
label <- label_fstr |
1471 |
} |
|
1472 | 1523x |
if (is(df, "data.frame")) { |
1473 | 1523x |
if (!is.null(var) && nzchar(var)) { |
1474 | 407x |
cnt <- sum(!is.na(df[[var]])) |
1475 |
} else { |
|
1476 | 1116x |
cnt <- nrow(df) |
1477 |
} |
|
1478 | 90x |
} else { # df is the data column vector |
1479 | ! |
cnt <- sum(!is.na(df)) |
1480 |
} |
|
1481 |
## the formatter does the *100 so we don't here. |
|
1482 |
## TODO name elements of this so that ARD generation has access to them |
|
1483 |
## ret <- rcell(c(n = cnt, pct = cnt / .N_col), |
|
1484 | 1523x |
ret <- rcell(c(cnt, cnt / .N_col), |
1485 | 1523x |
format = format, |
1486 | 1523x |
label = label |
1487 |
) |
|
1488 | 1523x |
ret |
1489 |
} |
|
1490 |
} |
|
1491 | ||
1492 |
.validate_cfuns <- function(fun) { |
|
1493 | 111x |
if (is.list(fun)) { |
1494 | 2x |
return(unlist(lapply(fun, .validate_cfuns))) |
1495 |
} |
|
1496 | ||
1497 | 109x |
frmls <- formals(fun) |
1498 | 109x |
ls_pos <- match("labelstr", names(frmls)) |
1499 | 109x |
if (is.na(ls_pos)) { |
1500 | ! |
stop("content functions must explicitly accept a 'labelstr' argument") |
1501 |
} |
|
1502 | ||
1503 | 109x |
list(fun) |
1504 |
} |
|
1505 | ||
1506 |
#' Analysis function to count levels of a factor with percentage of the column total |
|
1507 |
#' |
|
1508 |
#' @param x (`factor`)\cr a vector of data, provided by rtables pagination machinery. |
|
1509 |
#' @param .N_col (`integer(1)`)\cr total count for the column, provided by rtables pagination machinery. |
|
1510 |
#' |
|
1511 |
#' @return A `RowsVerticalSection` object with counts (and percents) for each level of the factor. |
|
1512 |
#' |
|
1513 |
#' @examples |
|
1514 |
#' counts_wpcts(DM$SEX, 400) |
|
1515 |
#' |
|
1516 |
#' @export |
|
1517 |
counts_wpcts <- function(x, .N_col) { |
|
1518 | 2x |
if (!is.factor(x)) { |
1519 | 1x |
stop( |
1520 | 1x |
"using the 'counts_wpcts' analysis function requires factor data ", |
1521 | 1x |
"to guarantee equal numbers of rows across all collumns, got class ", |
1522 | 1x |
class(x), "." |
1523 |
) |
|
1524 |
} |
|
1525 | 1x |
ret <- table(x) |
1526 | 1x |
in_rows(.list = lapply(ret, function(y) rcell(y * c(1, 1 / .N_col), format = "xx (xx.x%)"))) |
1527 |
} |
|
1528 | ||
1529 |
#' Add a content row of summary counts |
|
1530 |
#' |
|
1531 |
#' @inheritParams lyt_args |
|
1532 |
#' |
|
1533 |
#' @inherit split_cols_by return |
|
1534 |
#' |
|
1535 |
#' @details |
|
1536 |
#' If `format` expects 1 value (i.e. it is specified as a format string and `xx` appears for two values |
|
1537 |
#' (i.e. `xx` appears twice in the format string) or is specified as a function, then both raw and percent of |
|
1538 |
#' column total counts are calculated. If `format` is a format string where `xx` appears only one time, only |
|
1539 |
#' raw counts are used. |
|
1540 |
#' |
|
1541 |
#' `cfun` must accept `x` or `df` as its first argument. For the `df` argument `cfun` will receive the subset |
|
1542 |
#' `data.frame` corresponding with the row- and column-splitting for the cell being calculated. Must accept |
|
1543 |
#' `labelstr` as the second parameter, which accepts the `label` of the level of the parent split currently |
|
1544 |
#' being summarized. Can additionally take any optional argument supported by analysis functions. (see [analyze()]). |
|
1545 |
#' |
|
1546 |
#' In addition, if complex custom functions are needed, we suggest checking the available [additional_fun_params] |
|
1547 |
#' that can be used in `cfun`. |
|
1548 |
#' |
|
1549 |
#' @examples |
|
1550 |
#' DM2 <- subset(DM, COUNTRY %in% c("USA", "CAN", "CHN")) |
|
1551 |
#' |
|
1552 |
#' lyt <- basic_table() %>% |
|
1553 |
#' split_cols_by("ARM") %>% |
|
1554 |
#' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>% |
|
1555 |
#' summarize_row_groups(label_fstr = "%s (n)") %>% |
|
1556 |
#' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") |
|
1557 |
#' lyt |
|
1558 |
#' |
|
1559 |
#' tbl <- build_table(lyt, DM2) |
|
1560 |
#' tbl |
|
1561 |
#' |
|
1562 |
#' row_paths_summary(tbl) # summary count is a content table |
|
1563 |
#' |
|
1564 |
#' ## use a cfun and extra_args to customize summarization |
|
1565 |
#' ## behavior |
|
1566 |
#' sfun <- function(x, labelstr, trim) { |
|
1567 |
#' in_rows( |
|
1568 |
#' c(mean(x, trim = trim), trim), |
|
1569 |
#' .formats = "xx.x (xx.x%)", |
|
1570 |
#' .labels = sprintf( |
|
1571 |
#' "%s (Trimmed mean and trim %%)", |
|
1572 |
#' labelstr |
|
1573 |
#' ) |
|
1574 |
#' ) |
|
1575 |
#' } |
|
1576 |
#' |
|
1577 |
#' lyt2 <- basic_table(show_colcounts = TRUE) %>% |
|
1578 |
#' split_cols_by("ARM") %>% |
|
1579 |
#' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>% |
|
1580 |
#' summarize_row_groups("AGE", |
|
1581 |
#' cfun = sfun, |
|
1582 |
#' extra_args = list(trim = .2) |
|
1583 |
#' ) %>% |
|
1584 |
#' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>% |
|
1585 |
#' append_topleft(c("Country", " Age")) |
|
1586 |
#' |
|
1587 |
#' tbl2 <- build_table(lyt2, DM2) |
|
1588 |
#' tbl2 |
|
1589 |
#' |
|
1590 |
#' @author Gabriel Becker |
|
1591 |
#' @export |
|
1592 |
summarize_row_groups <- function(lyt, |
|
1593 |
var = "", |
|
1594 |
label_fstr = "%s", |
|
1595 |
format = "xx (xx.x%)", |
|
1596 |
na_str = "-", |
|
1597 |
cfun = NULL, |
|
1598 |
indent_mod = 0L, |
|
1599 |
extra_args = list()) { |
|
1600 | 105x |
if (is.null(cfun)) { |
1601 | 92x |
if (is.character(format) && length(gregexpr("xx(\\.x*){0,1}", format)[[1]]) == 1) { |
1602 | 2x |
cfun <- .count_raw_constr(var, format, label_fstr) |
1603 |
} else { |
|
1604 | 90x |
cfun <- .count_wpcts_constr(var, format, label_fstr) |
1605 |
} |
|
1606 |
} |
|
1607 | 105x |
cfun <- .validate_cfuns(cfun) |
1608 | 105x |
.add_row_summary(lyt, |
1609 | 105x |
cfun = cfun, |
1610 | 105x |
cformat = format, |
1611 | 105x |
cna_str = na_str, |
1612 | 105x |
indent_mod = indent_mod, |
1613 | 105x |
cvar = var, |
1614 | 105x |
extra_args = extra_args |
1615 |
) |
|
1616 |
} |
|
1617 | ||
1618 |
#' Add the column population counts to the header |
|
1619 |
#' |
|
1620 |
#' Add the data derived column counts. |
|
1621 |
#' |
|
1622 |
#' @details It is often the case that the the column counts derived from the |
|
1623 |
#' input data to [build_table()] is not representative of the population counts. |
|
1624 |
#' For example, if events are counted in the table and the header should |
|
1625 |
#' display the number of subjects and not the total number of events. |
|
1626 |
#' |
|
1627 |
#' @inheritParams lyt_args |
|
1628 |
#' |
|
1629 |
#' @inherit split_cols_by return |
|
1630 |
#' |
|
1631 |
#' @examples |
|
1632 |
#' lyt <- basic_table() %>% |
|
1633 |
#' split_cols_by("ARM") %>% |
|
1634 |
#' add_colcounts() %>% |
|
1635 |
#' split_rows_by("RACE", split_fun = drop_split_levels) %>% |
|
1636 |
#' analyze("AGE", afun = function(x) list(min = min(x), max = max(x))) |
|
1637 |
#' lyt |
|
1638 |
#' |
|
1639 |
#' tbl <- build_table(lyt, DM) |
|
1640 |
#' tbl |
|
1641 |
#' |
|
1642 |
#' @author Gabriel Becker |
|
1643 |
#' @export |
|
1644 |
add_colcounts <- function(lyt, format = "(N=xx)") { |
|
1645 | 75x |
if (is.null(lyt)) { |
1646 | ! |
lyt <- PreDataTableLayouts() |
1647 |
} |
|
1648 | 75x |
disp_ccounts(lyt) <- TRUE |
1649 | 75x |
colcount_format(lyt) <- format |
1650 | 75x |
lyt |
1651 |
} |
|
1652 | ||
1653 |
## Currently existing tables can ONLY be added as new entries at the top level, never at any level of nesting. |
|
1654 |
#' Add an already calculated table to the layout |
|
1655 |
#' |
|
1656 |
#' @inheritParams lyt_args |
|
1657 |
#' @inheritParams gen_args |
|
1658 |
#' |
|
1659 |
#' @inherit split_cols_by return |
|
1660 |
#' |
|
1661 |
#' @examples |
|
1662 |
#' lyt1 <- basic_table() %>% |
|
1663 |
#' split_cols_by("ARM") %>% |
|
1664 |
#' analyze("AGE", afun = mean, format = "xx.xx") |
|
1665 |
#' |
|
1666 |
#' tbl1 <- build_table(lyt1, DM) |
|
1667 |
#' tbl1 |
|
1668 |
#' |
|
1669 |
#' lyt2 <- basic_table() %>% |
|
1670 |
#' split_cols_by("ARM") %>% |
|
1671 |
#' analyze("AGE", afun = sd, format = "xx.xx") %>% |
|
1672 |
#' add_existing_table(tbl1) |
|
1673 |
#' |
|
1674 |
#' tbl2 <- build_table(lyt2, DM) |
|
1675 |
#' tbl2 |
|
1676 |
#' |
|
1677 |
#' table_structure(tbl2) |
|
1678 |
#' row_paths_summary(tbl2) |
|
1679 |
#' |
|
1680 |
#' @author Gabriel Becker |
|
1681 |
#' @export |
|
1682 |
add_existing_table <- function(lyt, tt, indent_mod = 0) { |
|
1683 | 1x |
indent_mod(tt) <- indent_mod |
1684 | 1x |
lyt <- split_rows( |
1685 | 1x |
lyt, |
1686 | 1x |
tt, |
1687 | 1x |
next_rpos(lyt, nested = FALSE) |
1688 |
) |
|
1689 | 1x |
lyt |
1690 |
} |
|
1691 | ||
1692 |
## takes_coln = function(f) { |
|
1693 |
## stopifnot(is(f, "function")) |
|
1694 |
## forms = names(formals(f)) |
|
1695 |
## res = ".N_col" %in% forms |
|
1696 |
## res |
|
1697 |
## } |
|
1698 | ||
1699 |
## takes_totn = function(f) { |
|
1700 |
## stopifnot(is(f, "function")) |
|
1701 |
## forms = names(formals(f)) |
|
1702 |
## res = ".N_total" %in% forms |
|
1703 |
## res |
|
1704 |
## } |
|
1705 | ||
1706 |
## use data to transform dynamic cuts to static cuts |
|
1707 |
#' @rdname int_methods |
|
1708 | 2597x |
setGeneric("fix_dyncuts", function(spl, df) standardGeneric("fix_dyncuts")) |
1709 | ||
1710 |
#' @rdname int_methods |
|
1711 | 970x |
setMethod("fix_dyncuts", "Split", function(spl, df) spl) |
1712 | ||
1713 |
#' @rdname int_methods |
|
1714 |
setMethod( |
|
1715 |
"fix_dyncuts", "VarDynCutSplit", |
|
1716 |
function(spl, df) { |
|
1717 | 5x |
var <- spl_payload(spl) |
1718 | 5x |
varvec <- df[[var]] |
1719 | ||
1720 | 5x |
cfun <- spl_cutfun(spl) |
1721 | 5x |
cuts <- cfun(varvec) |
1722 | 5x |
cutlabels <- spl_cutlabelfun(spl)(cuts) |
1723 | 5x |
if (length(cutlabels) != length(cuts) - 1 && !is.null(names(cuts))) { |
1724 | 1x |
cutlabels <- names(cuts)[-1] |
1725 |
} |
|
1726 | ||
1727 | 5x |
ret <- make_static_cut_split( |
1728 | 5x |
var = var, split_label = obj_label(spl), |
1729 | 5x |
cuts = cuts, cutlabels = cutlabels, |
1730 | 5x |
cumulative = spl_is_cmlcuts(spl) |
1731 |
) |
|
1732 |
## ret = VarStaticCutSplit(var = var, split_label = obj_label(spl), |
|
1733 |
## cuts = cuts, cutlabels = cutlabels) |
|
1734 |
## ## classes are tthe same structurally CumulativeCutSplit |
|
1735 |
## ## is just a sentinal so it can hit different make_subset_expr |
|
1736 |
## ## method |
|
1737 |
## if(spl_is_cmlcuts(spl)) |
|
1738 |
## ret = as(ret, "CumulativeCutSplit") |
|
1739 | 5x |
ret |
1740 |
} |
|
1741 |
) |
|
1742 | ||
1743 |
#' @rdname int_methods |
|
1744 |
setMethod( |
|
1745 |
"fix_dyncuts", "VTableTree", |
|
1746 | 1x |
function(spl, df) spl |
1747 |
) |
|
1748 | ||
1749 |
.fd_helper <- function(spl, df) { |
|
1750 | 1303x |
lst <- lapply(spl, fix_dyncuts, df = df) |
1751 | 1303x |
spl@.Data <- lst |
1752 | 1303x |
spl |
1753 |
} |
|
1754 | ||
1755 |
#' @rdname int_methods |
|
1756 |
setMethod( |
|
1757 |
"fix_dyncuts", "PreDataRowLayout", |
|
1758 |
function(spl, df) { |
|
1759 |
# rt = root_spl(spl) |
|
1760 | 318x |
ret <- .fd_helper(spl, df) |
1761 |
# root_spl(ret) = rt |
|
1762 | 318x |
ret |
1763 |
} |
|
1764 |
) |
|
1765 | ||
1766 |
#' @rdname int_methods |
|
1767 |
setMethod( |
|
1768 |
"fix_dyncuts", "PreDataColLayout", |
|
1769 |
function(spl, df) { |
|
1770 |
# rt = root_spl(spl) |
|
1771 | 318x |
ret <- .fd_helper(spl, df) |
1772 |
# root_spl(ret) = rt |
|
1773 |
# disp_ccounts(ret) = disp_ccounts(spl) |
|
1774 |
# colcount_format(ret) = colcount_format(spl) |
|
1775 | 318x |
ret |
1776 |
} |
|
1777 |
) |
|
1778 | ||
1779 |
#' @rdname int_methods |
|
1780 |
setMethod( |
|
1781 |
"fix_dyncuts", "SplitVector", |
|
1782 |
function(spl, df) { |
|
1783 | 667x |
.fd_helper(spl, df) |
1784 |
} |
|
1785 |
) |
|
1786 | ||
1787 |
#' @rdname int_methods |
|
1788 |
setMethod( |
|
1789 |
"fix_dyncuts", "PreDataTableLayouts", |
|
1790 |
function(spl, df) { |
|
1791 | 318x |
rlayout(spl) <- fix_dyncuts(rlayout(spl), df) |
1792 | 318x |
clayout(spl) <- fix_dyncuts(clayout(spl), df) |
1793 | 318x |
spl |
1794 |
} |
|
1795 |
) |
|
1796 | ||
1797 |
## Manual column construction in a simple (seeming to the user) way. |
|
1798 |
#' Manual column declaration |
|
1799 |
#' |
|
1800 |
#' @param ... one or more vectors of levels to appear in the column space. If more than one set of levels is given, |
|
1801 |
#' the values of the second are nested within each value of the first, and so on. |
|
1802 |
#' @param .lst (`list`)\cr a list of sets of levels, by default populated via `list(...)`. |
|
1803 |
#' |
|
1804 |
#' @return An `InstantiatedColumnInfo` object, suitable for declaring the column structure for a manually constructed |
|
1805 |
#' table. |
|
1806 |
#' |
|
1807 |
#' @examples |
|
1808 |
#' # simple one level column space |
|
1809 |
#' rows <- lapply(1:5, function(i) { |
|
1810 |
#' DataRow(rep(i, times = 3)) |
|
1811 |
#' }) |
|
1812 |
#' tbl <- TableTree(kids = rows, cinfo = manual_cols(split = c("a", "b", "c"))) |
|
1813 |
#' tbl |
|
1814 |
#' |
|
1815 |
#' # manually declared nesting |
|
1816 |
#' tbl2 <- TableTree( |
|
1817 |
#' kids = list(DataRow(as.list(1:4))), |
|
1818 |
#' cinfo = manual_cols( |
|
1819 |
#' Arm = c("Arm A", "Arm B"), |
|
1820 |
#' Gender = c("M", "F") |
|
1821 |
#' ) |
|
1822 |
#' ) |
|
1823 |
#' tbl2 |
|
1824 |
#' |
|
1825 |
#' @author Gabriel Becker |
|
1826 |
#' @export |
|
1827 |
manual_cols <- function(..., .lst = list(...)) { |
|
1828 | 40x |
if (is.null(names(.lst))) { |
1829 | 40x |
names(.lst) <- paste("colsplit", seq_along(.lst)) |
1830 |
} |
|
1831 | ||
1832 | 40x |
splvec <- SplitVector(lst = mapply(ManualSplit, |
1833 | 40x |
levels = .lst, |
1834 | 40x |
label = names(.lst) |
1835 |
)) |
|
1836 | 40x |
ctree <- splitvec_to_coltree(data.frame(), splvec = splvec, pos = TreePos()) |
1837 | 40x |
InstantiatedColumnInfo(treelyt = ctree) |
1838 |
} |
|
1839 | ||
1840 |
#' Returns a function that coerces the return values of a function to a list |
|
1841 |
#' |
|
1842 |
#' @param f (`function`)\cr the function to wrap. |
|
1843 |
#' |
|
1844 |
#' @details |
|
1845 |
#' `list_wrap_x` generates a wrapper which takes `x` as its first argument, while `list_wrap_df` generates an |
|
1846 |
#' otherwise identical wrapper function whose first argument is named `df`. |
|
1847 |
#' |
|
1848 |
#' We provide both because when using the functions as tabulation in [analyze()], functions which take `df` as |
|
1849 |
#' their first argument are passed the full subset data frame, while those which accept anything else notably |
|
1850 |
#' including `x` are passed only the relevant subset of the variable being analyzed. |
|
1851 |
#' |
|
1852 |
#' @return A function that returns a list of `CellValue` objects. |
|
1853 |
#' |
|
1854 |
#' @examples |
|
1855 |
#' summary(iris$Sepal.Length) |
|
1856 |
#' |
|
1857 |
#' f <- list_wrap_x(summary) |
|
1858 |
#' f(x = iris$Sepal.Length) |
|
1859 |
#' |
|
1860 |
#' f2 <- list_wrap_df(summary) |
|
1861 |
#' f2(df = iris$Sepal.Length) |
|
1862 |
#' |
|
1863 |
#' @author Gabriel Becker |
|
1864 |
#' @rdname list_wrap |
|
1865 |
#' @export |
|
1866 |
list_wrap_x <- function(f) { |
|
1867 | 17x |
function(x, ...) { |
1868 | 74x |
vs <- as.list(f(x, ...)) |
1869 | 74x |
ret <- mapply( |
1870 | 74x |
function(v, nm) { |
1871 | 258x |
rcell(v, label = nm) |
1872 |
}, |
|
1873 | 74x |
v = vs, |
1874 | 74x |
nm = names(vs) |
1875 |
) |
|
1876 | 74x |
ret |
1877 |
} |
|
1878 |
} |
|
1879 | ||
1880 |
#' @rdname list_wrap |
|
1881 |
#' @export |
|
1882 |
list_wrap_df <- function(f) { |
|
1883 | 1x |
function(df, ...) { |
1884 | 1x |
vs <- as.list(f(df, ...)) |
1885 | 1x |
ret <- mapply( |
1886 | 1x |
function(v, nm) { |
1887 | 6x |
rcell(v, label = nm) |
1888 |
}, |
|
1889 | 1x |
v = vs, |
1890 | 1x |
nm = names(vs) |
1891 |
) |
|
1892 | 1x |
ret |
1893 |
} |
|
1894 |
} |
|
1895 | ||
1896 |
#' Layout with 1 column and zero rows |
|
1897 |
#' |
|
1898 |
#' Every layout must start with a basic table. |
|
1899 |
#' |
|
1900 |
#' @inheritParams constr_args |
|
1901 |
#' @param show_colcounts (`flag`)\cr whether column counts should be displayed in the resulting table when this |
|
1902 |
#' layout is applied to data. |
|
1903 |
#' @param colcount_format (`string`)\cr format for use when displaying the column counts. Must be 1d, or 2d |
|
1904 |
#' where one component is a percent. See Details below. |
|
1905 |
#' @param top_level_section_div (`character(1)`)\cr if assigned a single character, the first (top level) split |
|
1906 |
#' or division of the table will be highlighted by a line made of that character. See [section_div] for more |
|
1907 |
#' information. |
|
1908 |
#' |
|
1909 |
#' @details |
|
1910 |
#' `colcount_format` is ignored if `show_colcounts` is `FALSE` (the default). When `show_colcounts` is `TRUE`, |
|
1911 |
#' and `colcount_format` is 2-dimensional with a percent component, the value component for the percent is always |
|
1912 |
#' populated with `1` (i.e. 100%). 1d formats are used to render the counts exactly as they normally would be, |
|
1913 |
#' while 2d formats which don't include a percent, and all 3d formats result in an error. Formats in the form of |
|
1914 |
#' functions are not supported for `colcount` format. See [formatters::list_valid_format_labels()] for the list |
|
1915 |
#' of valid format labels to select from. |
|
1916 |
#' |
|
1917 |
#' @inherit split_cols_by return |
|
1918 |
#' |
|
1919 |
#' @note |
|
1920 |
#' - Because percent components in `colcount_format` are *always* populated with the value 1, we can get arguably |
|
1921 |
#' strange results, such as that individual arm columns and a combined "all patients" column all list "100%" as |
|
1922 |
#' their percentage, even though the individual arm columns represent strict subsets of the "all patients" column. |
|
1923 |
#' |
|
1924 |
#' - Note that subtitles ([subtitles()]) and footers ([main_footer()] and [prov_footer()]) that span more than one |
|
1925 |
#' line can be supplied as a character vector to maintain indentation on multiple lines. |
|
1926 |
#' |
|
1927 |
#' @examples |
|
1928 |
#' lyt <- basic_table() %>% |
|
1929 |
#' analyze("AGE", afun = mean) |
|
1930 |
#' |
|
1931 |
#' tbl <- build_table(lyt, DM) |
|
1932 |
#' tbl |
|
1933 |
#' |
|
1934 |
#' lyt2 <- basic_table( |
|
1935 |
#' title = "Title of table", |
|
1936 |
#' subtitles = c("a number", "of subtitles"), |
|
1937 |
#' main_footer = "test footer", |
|
1938 |
#' prov_footer = paste( |
|
1939 |
#' "test.R program, executed at", |
|
1940 |
#' Sys.time() |
|
1941 |
#' ) |
|
1942 |
#' ) %>% |
|
1943 |
#' split_cols_by("ARM") %>% |
|
1944 |
#' analyze("AGE", mean) |
|
1945 |
#' |
|
1946 |
#' tbl2 <- build_table(lyt2, DM) |
|
1947 |
#' tbl2 |
|
1948 |
#' |
|
1949 |
#' lyt3 <- basic_table( |
|
1950 |
#' show_colcounts = TRUE, |
|
1951 |
#' colcount_format = "xx. (xx.%)" |
|
1952 |
#' ) %>% |
|
1953 |
#' split_cols_by("ARM") |
|
1954 |
#' |
|
1955 |
#' @export |
|
1956 |
basic_table <- function(title = "", |
|
1957 |
subtitles = character(), |
|
1958 |
main_footer = character(), |
|
1959 |
prov_footer = character(), |
|
1960 |
show_colcounts = FALSE, |
|
1961 |
colcount_format = "(N=xx)", |
|
1962 |
header_section_div = NA_character_, |
|
1963 |
top_level_section_div = NA_character_, |
|
1964 |
inset = 0L) { |
|
1965 | 300x |
inset <- as.integer(inset) |
1966 | 300x |
if (is.na(inset) || inset < 0L) { |
1967 | 2x |
stop("Got invalid table_inset value, must be an integer > 0") |
1968 |
} |
|
1969 | 298x |
.check_header_section_div(header_section_div) |
1970 | 298x |
checkmate::assert_character(top_level_section_div, len = 1, n.chars = 1) |
1971 | ||
1972 | 298x |
ret <- PreDataTableLayouts( |
1973 | 298x |
title = title, |
1974 | 298x |
subtitles = subtitles, |
1975 | 298x |
main_footer = main_footer, |
1976 | 298x |
prov_footer = prov_footer, |
1977 | 298x |
header_section_div = header_section_div, |
1978 | 298x |
top_level_section_div = top_level_section_div, |
1979 | 298x |
table_inset = as.integer(inset) |
1980 |
) |
|
1981 | 298x |
if (show_colcounts) { |
1982 | 70x |
ret <- add_colcounts(ret, format = colcount_format) |
1983 |
} |
|
1984 | 298x |
ret |
1985 |
} |
|
1986 | ||
1987 |
#' Append a description to the 'top-left' materials for the layout |
|
1988 |
#' |
|
1989 |
#' This function *adds* `newlines` to the current set of "top-left materials". |
|
1990 |
#' |
|
1991 |
#' @details |
|
1992 |
#' Adds `newlines` to the set of strings representing the 'top-left' materials declared in the layout (the content |
|
1993 |
#' displayed to the left of the column labels when the resulting tables are printed). |
|
1994 |
#' |
|
1995 |
#' Top-left material strings are stored and then displayed *exactly as is*, no structure or indenting is applied to |
|
1996 |
#' them either when they are added or when they are displayed. |
|
1997 |
#' |
|
1998 |
#' @inheritParams lyt_args |
|
1999 |
#' @param newlines (`character`)\cr the new line(s) to be added to the materials. |
|
2000 |
#' |
|
2001 |
#' @note |
|
2002 |
#' Currently, where in the construction of the layout this is called makes no difference, as it is independent of |
|
2003 |
#' the actual splitting keywords. This may change in the future. |
|
2004 |
#' |
|
2005 |
#' This function is experimental, its name and the details of its behavior are subject to change in future versions. |
|
2006 |
#' |
|
2007 |
#' @inherit split_cols_by return |
|
2008 |
#' |
|
2009 |
#' @seealso [top_left()] |
|
2010 |
#' |
|
2011 |
#' @examples |
|
2012 |
#' library(dplyr) |
|
2013 |
#' |
|
2014 |
#' DM2 <- DM %>% mutate(RACE = factor(RACE), SEX = factor(SEX)) |
|
2015 |
#' |
|
2016 |
#' lyt <- basic_table() %>% |
|
2017 |
#' split_cols_by("ARM") %>% |
|
2018 |
#' split_cols_by("SEX") %>% |
|
2019 |
#' split_rows_by("RACE") %>% |
|
2020 |
#' append_topleft("Ethnicity") %>% |
|
2021 |
#' analyze("AGE") %>% |
|
2022 |
#' append_topleft(" Age") |
|
2023 |
#' |
|
2024 |
#' tbl <- build_table(lyt, DM2) |
|
2025 |
#' tbl |
|
2026 |
#' |
|
2027 |
#' @export |
|
2028 |
append_topleft <- function(lyt, newlines) { |
|
2029 | 53x |
stopifnot( |
2030 | 53x |
is(lyt, "PreDataTableLayouts"), |
2031 | 53x |
is(newlines, "character") |
2032 |
) |
|
2033 | 53x |
lyt@top_left <- c(lyt@top_left, newlines) |
2034 | 53x |
lyt |
2035 |
} |
1 |
match_extra_args <- function(f, |
|
2 |
.N_col, |
|
3 |
.N_total, |
|
4 |
.all_col_exprs, |
|
5 |
.all_col_counts, |
|
6 |
.var, |
|
7 |
.ref_group = NULL, |
|
8 |
.alt_df_row = NULL, |
|
9 |
.alt_df = NULL, |
|
10 |
.ref_full = NULL, |
|
11 |
.in_ref_col = NULL, |
|
12 |
.spl_context = NULL, |
|
13 |
.N_row, |
|
14 |
.df_row, |
|
15 |
extras) { |
|
16 |
# This list is always present |
|
17 | 5759x |
possargs <- c( |
18 | 5759x |
list( |
19 | 5759x |
.N_col = .N_col, |
20 | 5759x |
.N_total = .N_total, |
21 | 5759x |
.N_row = .N_row, |
22 | 5759x |
.df_row = .df_row, |
23 | 5759x |
.all_col_exprs = .all_col_exprs, |
24 | 5759x |
.all_col_counts = .all_col_counts |
25 |
), |
|
26 | 5759x |
extras |
27 |
) |
|
28 | ||
29 |
## specialized arguments that must be named in formals, cannot go |
|
30 |
## anonymously into ... |
|
31 | 5759x |
if (!is.null(.var) && nzchar(.var)) { |
32 | 4514x |
possargs <- c(possargs, list(.var = .var)) |
33 |
} |
|
34 | 5759x |
if (!is.null(.ref_group)) { |
35 | 1834x |
possargs <- c(possargs, list(.ref_group = .ref_group)) |
36 |
} |
|
37 | 5759x |
if (!is.null(.alt_df_row)) { |
38 | 105x |
possargs <- c(possargs, list(.alt_df_row = .alt_df_row)) |
39 |
} |
|
40 | 5759x |
if (!is.null(.alt_df)) { |
41 | 105x |
possargs <- c(possargs, list(.alt_df = .alt_df)) |
42 |
} |
|
43 | 5759x |
if (!is.null(.ref_full)) { |
44 | 141x |
possargs <- c(possargs, list(.ref_full = .ref_full)) |
45 |
} |
|
46 | 5759x |
if (!is.null(.in_ref_col)) { |
47 | 141x |
possargs <- c(possargs, list(.in_ref_col = .in_ref_col)) |
48 |
} |
|
49 | ||
50 |
# Special case: .spl_context |
|
51 | 5759x |
if (!is.null(.spl_context) && !(".spl_context" %in% names(possargs))) { |
52 | 5759x |
possargs <- c(possargs, list(.spl_context = .spl_context)) |
53 |
} else { |
|
54 | ! |
possargs$.spl_context <- NULL |
55 |
} |
|
56 | ||
57 |
# Extra args handling |
|
58 | 5759x |
formargs <- formals(f) |
59 | 5759x |
formnms <- names(formargs) |
60 | 5759x |
exnms <- names(extras) |
61 | 5759x |
if (is.null(formargs)) { |
62 | 206x |
return(NULL) |
63 | 5553x |
} else if ("..." %in% names(formargs)) { |
64 | 4865x |
formnms <- c(formnms, exnms[nzchar(exnms)]) |
65 |
} |
|
66 | 5553x |
possargs[names(possargs) %in% formnms] |
67 |
} |
|
68 | ||
69 |
#' @noRd |
|
70 |
#' @return A `RowsVerticalSection` object representing the `k x 1` section of the |
|
71 |
#' table being generated, with `k` the number of rows the analysis function |
|
72 |
#' generates. |
|
73 |
gen_onerv <- function(csub, col, count, cextr, cpath, |
|
74 |
dfpart, func, totcount, splextra, |
|
75 |
all_col_exprs, |
|
76 |
all_col_counts, |
|
77 |
takesdf = .takes_df(func), |
|
78 |
baselinedf, |
|
79 |
alt_dfpart, |
|
80 |
inclNAs, |
|
81 |
col_parent_inds, |
|
82 |
spl_context) { |
|
83 | 5759x |
if (NROW(spl_context) > 0) { |
84 | 5738x |
spl_context$cur_col_id <- paste(cpath[seq(2, length(cpath), 2)], collapse = ".") |
85 | 5738x |
spl_context$cur_col_subset <- col_parent_inds |
86 | 5738x |
spl_context$cur_col_expr <- list(csub) |
87 | 5738x |
spl_context$cur_col_n <- vapply(col_parent_inds, sum, 1L) |
88 | 5738x |
spl_context$cur_col_split <- list(cpath[seq(1, length(cpath), 2)]) |
89 | 5738x |
spl_context$cur_col_split_val <- list(cpath[seq(2, length(cpath), 2)]) |
90 |
} |
|
91 | ||
92 |
# Making .alt_df from alt_dfpart (i.e. .alt_df_row) |
|
93 | 5759x |
if (NROW(alt_dfpart) > 0) { |
94 | 105x |
alt_dfpart_fil <- alt_dfpart[eval(csub, envir = alt_dfpart), , drop = FALSE] |
95 | 105x |
if (!is.null(col) && col %in% names(alt_dfpart_fil) && !inclNAs) { |
96 | 99x |
alt_dfpart_fil <- alt_dfpart_fil[!is.na(alt_dfpart_fil[[col]]), , |
97 | 99x |
drop = FALSE |
98 |
] |
|
99 |
} |
|
100 |
} else { |
|
101 | 5654x |
alt_dfpart_fil <- alt_dfpart |
102 |
} |
|
103 | ||
104 |
## workaround for https://github.com/insightsengineering/rtables/issues/159 |
|
105 | 5759x |
if (NROW(dfpart) > 0) { |
106 | 4891x |
inds <- eval(csub, envir = dfpart) |
107 | 4891x |
dat <- dfpart[inds, , drop = FALSE] |
108 |
} else { |
|
109 | 868x |
dat <- dfpart |
110 |
} |
|
111 | 5759x |
if (!is.null(col) && !inclNAs) { |
112 | 4488x |
dat <- dat[!is.na(dat[[col]]), , drop = FALSE] |
113 |
} |
|
114 | ||
115 | 5759x |
fullrefcoldat <- cextr$.ref_full |
116 | 5759x |
if (!is.null(fullrefcoldat)) { |
117 | 141x |
cextr$.ref_full <- NULL |
118 |
} |
|
119 | 5759x |
inrefcol <- cextr$.in_ref_col |
120 | 5759x |
if (!is.null(fullrefcoldat)) { |
121 | 141x |
cextr$.in_ref_col <- NULL |
122 |
} |
|
123 | ||
124 | 5759x |
exargs <- c(cextr, splextra) |
125 | ||
126 |
## behavior for x/df and ref-data (full and group) |
|
127 |
## match |
|
128 | 5759x |
if (!is.null(col) && !takesdf) { |
129 | 3571x |
dat <- dat[[col]] |
130 | 3571x |
fullrefcoldat <- fullrefcoldat[[col]] |
131 | 3571x |
baselinedf <- baselinedf[[col]] |
132 |
} |
|
133 | 5759x |
args <- list(dat) |
134 | ||
135 | 5759x |
names(all_col_counts) <- names(all_col_exprs) |
136 | ||
137 | 5759x |
exargs <- match_extra_args(func, |
138 | 5759x |
.N_col = count, |
139 | 5759x |
.N_total = totcount, |
140 | 5759x |
.all_col_exprs = all_col_exprs, |
141 | 5759x |
.all_col_counts = all_col_counts, |
142 | 5759x |
.var = col, |
143 | 5759x |
.ref_group = baselinedf, |
144 | 5759x |
.alt_df_row = alt_dfpart, |
145 | 5759x |
.alt_df = alt_dfpart_fil, |
146 | 5759x |
.ref_full = fullrefcoldat, |
147 | 5759x |
.in_ref_col = inrefcol, |
148 | 5759x |
.N_row = NROW(dfpart), |
149 | 5759x |
.df_row = dfpart, |
150 | 5759x |
.spl_context = spl_context, |
151 | 5759x |
extras = c( |
152 | 5759x |
cextr, |
153 | 5759x |
splextra |
154 |
) |
|
155 |
) |
|
156 | ||
157 | 5759x |
args <- c(args, exargs) |
158 | ||
159 | 5759x |
val <- do.call(func, args) |
160 | 5756x |
if (!is(val, "RowsVerticalSection")) { |
161 | 3787x |
if (!is(val, "list")) { |
162 | 3298x |
val <- list(val) |
163 |
} |
|
164 | 3787x |
ret <- in_rows( |
165 | 3787x |
.list = val, |
166 | 3787x |
.labels = unlist(value_labels(val)), |
167 | 3787x |
.names = names(val) |
168 |
) |
|
169 |
} else { |
|
170 | 1969x |
ret <- val |
171 |
} |
|
172 | 5756x |
ret |
173 |
} |
|
174 | ||
175 |
strip_multivar_suffix <- function(x) { |
|
176 | 228x |
gsub("\\._\\[\\[[0-9]\\]\\]_\\.$", "", x) |
177 |
} |
|
178 | ||
179 |
## Generate all values (one for each column) for one or more rows |
|
180 |
## by calling func once per column (as defined by cinfo) |
|
181 |
#' @noRd |
|
182 |
#' @return A list of `m` `RowsVerticalSection` objects, one for each (leaf) column in the table. |
|
183 |
gen_rowvalues <- function(dfpart, |
|
184 |
datcol, |
|
185 |
cinfo, |
|
186 |
func, |
|
187 |
splextra, |
|
188 |
takesdf = NULL, |
|
189 |
baselines, |
|
190 |
alt_dfpart, |
|
191 |
inclNAs, |
|
192 |
spl_context = spl_context) { |
|
193 | 1575x |
colexprs <- col_exprs(cinfo) |
194 | 1575x |
colcounts <- col_counts(cinfo) |
195 | 1575x |
colextras <- col_extra_args(cinfo, NULL) |
196 | 1575x |
cpaths <- col_paths(cinfo) |
197 |
## XXX I don't think this is used anywhere??? |
|
198 |
## splextra = c(splextra, list(.spl_context = spl_context)) |
|
199 | 1575x |
totcount <- col_total(cinfo) |
200 | ||
201 | 1575x |
colleaves <- collect_leaves(cinfo@tree_layout) |
202 | ||
203 | 1575x |
gotflist <- is.list(func) |
204 | ||
205 |
## one set of named args to be applied to all columns |
|
206 | 1575x |
if (!is.null(names(splextra))) { |
207 | 25x |
splextra <- list(splextra) |
208 |
} else { |
|
209 | 1550x |
length(splextra) <- ncol(cinfo) |
210 |
} |
|
211 | ||
212 | 1575x |
if (!gotflist) { |
213 | 1062x |
func <- list(func) |
214 | 513x |
} else if (length(splextra) == 1) { |
215 | 88x |
splextra <- rep(splextra, length.out = length(func)) |
216 |
} |
|
217 |
## if(length(func)) == 1 && names(spl) |
|
218 |
## splextra = list(splextra) |
|
219 | ||
220 |
## we are in analyze_colvars, so we have to match |
|
221 |
## the exargs value by position for each column repeatedly |
|
222 |
## across the higher level col splits. |
|
223 | 1575x |
if (!is.null(datcol) && is.na(datcol)) { |
224 | 54x |
datcol <- character(length(colleaves)) |
225 | 54x |
exargs <- vector("list", length(colleaves)) |
226 | 54x |
for (i in seq_along(colleaves)) { |
227 | 228x |
x <- colleaves[[i]] |
228 | ||
229 | 228x |
pos <- tree_pos(x) |
230 | 228x |
spls <- pos_splits(pos) |
231 |
## values have the suffix but we are populating datacol |
|
232 |
## so it has to match var numbers so strip the suffixes back off |
|
233 | 228x |
splvals <- strip_multivar_suffix(rawvalues(pos)) |
234 | 228x |
n <- length(spls) |
235 | 228x |
datcol[i] <- if (is(spls[[n]], "MultiVarSplit")) { |
236 | 228x |
splvals[n] |
237 |
} else { |
|
238 | 228x |
NA_character_ |
239 |
} |
|
240 | 228x |
argpos <- match(datcol[i], spl_payload(spls[[n]])) |
241 |
## single bracket here because assigning NULL into a list removes |
|
242 |
## the position entirely |
|
243 | 228x |
exargs[i] <- if (argpos <= length(splextra)) { |
244 | 228x |
splextra[argpos] |
245 |
} else { |
|
246 | ! |
list(NULL) |
247 |
} |
|
248 |
} |
|
249 |
## }) |
|
250 | 54x |
if (all(is.na(datcol))) { |
251 | ! |
datcol <- list(NULL) |
252 | 54x |
} else if (any(is.na(datcol))) { |
253 | ! |
stop("mix of var and non-var columns with NA analysis rowvara") |
254 |
} |
|
255 |
} else { |
|
256 | 1521x |
exargs <- splextra |
257 | 1521x |
if (is.null(datcol)) { |
258 | 316x |
datcol <- list(NULL) |
259 |
} |
|
260 | 1521x |
datcol <- rep(datcol, length(colexprs)) |
261 |
## if(gotflist) |
|
262 |
## length(exargs) <- length(func) ## func is a list |
|
263 | 1521x |
exargs <- rep(exargs, length.out = length(colexprs)) |
264 |
} |
|
265 | 1575x |
allfuncs <- rep(func, length.out = length(colexprs)) |
266 | ||
267 | 1575x |
if (is.null(takesdf)) { |
268 | 1116x |
takesdf <- .takes_df(allfuncs) |
269 |
} |
|
270 | ||
271 | 1575x |
rawvals <- mapply(gen_onerv, |
272 | 1575x |
csub = colexprs, |
273 | 1575x |
col = datcol, |
274 | 1575x |
count = colcounts, |
275 | 1575x |
cextr = colextras, |
276 | 1575x |
cpath = cpaths, |
277 | 1575x |
baselinedf = baselines, |
278 | 1575x |
alt_dfpart = list(alt_dfpart), |
279 | 1575x |
func = allfuncs, |
280 | 1575x |
takesdf = takesdf, |
281 | 1575x |
col_parent_inds = spl_context[, names(colexprs), |
282 | 1575x |
drop = FALSE |
283 |
], |
|
284 | 1575x |
all_col_exprs = list(colexprs), |
285 | 1575x |
all_col_counts = list(colcounts), |
286 | 1575x |
splextra = exargs, |
287 | 1575x |
MoreArgs = list( |
288 | 1575x |
dfpart = dfpart, |
289 | 1575x |
totcount = totcount, |
290 | 1575x |
inclNAs = inclNAs, |
291 | 1575x |
spl_context = spl_context |
292 |
), |
|
293 | 1575x |
SIMPLIFY = FALSE |
294 |
) |
|
295 | ||
296 | 1572x |
names(rawvals) <- names(colexprs) |
297 | 1572x |
rawvals |
298 |
} |
|
299 | ||
300 |
.strip_lst_rvals <- function(lst) { |
|
301 | ! |
lapply(lst, rawvalues) |
302 |
} |
|
303 | ||
304 |
#' @noRd |
|
305 |
#' @return A list of table rows, even when only one is generated. |
|
306 |
.make_tablerows <- function(dfpart, |
|
307 |
alt_dfpart, |
|
308 |
func, |
|
309 |
cinfo, |
|
310 |
datcol = NULL, |
|
311 |
lev = 1L, |
|
312 |
rvlab = NA_character_, |
|
313 |
format = NULL, |
|
314 |
defrowlabs = NULL, |
|
315 |
rowconstr = DataRow, |
|
316 |
splextra = list(), |
|
317 |
takesdf = NULL, |
|
318 |
baselines = replicate( |
|
319 |
length(col_exprs(cinfo)), |
|
320 |
list(dfpart[0, ]) |
|
321 |
), |
|
322 |
inclNAs, |
|
323 |
spl_context = context_df_row(cinfo = cinfo)) { |
|
324 | 1575x |
if (is.null(datcol) && !is.na(rvlab)) { |
325 | ! |
stop("NULL datcol but non-na rowvar label") |
326 |
} |
|
327 | 1575x |
if (!is.null(datcol) && !is.na(datcol)) { |
328 | 1205x |
if (!all(datcol %in% names(dfpart))) { |
329 | ! |
stop( |
330 | ! |
"specified analysis variable (", datcol, |
331 | ! |
") not present in data" |
332 |
) |
|
333 |
} |
|
334 | ||
335 | 1205x |
rowvar <- datcol |
336 |
} else { |
|
337 | 370x |
rowvar <- NA_character_ |
338 |
} |
|
339 | ||
340 | 1575x |
rawvals <- gen_rowvalues(dfpart, |
341 | 1575x |
alt_dfpart = alt_dfpart, |
342 | 1575x |
datcol = datcol, |
343 | 1575x |
cinfo = cinfo, |
344 | 1575x |
func = func, |
345 | 1575x |
splextra = splextra, |
346 | 1575x |
takesdf = takesdf, |
347 | 1575x |
baselines = baselines, |
348 | 1575x |
inclNAs = inclNAs, |
349 | 1575x |
spl_context = spl_context |
350 |
) |
|
351 | ||
352 |
## if(is.null(rvtypes)) |
|
353 |
## rvtypes = rep(NA_character_, length(rawvals)) |
|
354 | 1572x |
lens <- vapply(rawvals, length, NA_integer_) |
355 | 1572x |
unqlens <- unique(lens) |
356 |
## length 0 returns are ok to not match cause they are |
|
357 |
## just empty space we can fill in as needed. |
|
358 | 1572x |
if (length(unqlens[unqlens > 0]) != 1L) { ## length(unqlens) != 1 && |
359 |
## (0 %in% unqlens && length(unqlens) != 2)) { |
|
360 | 1x |
stop( |
361 | 1x |
"Number of rows generated by analysis function do not match ", |
362 | 1x |
"across all columns. ", |
363 | 1x |
if (!is.na(datcol) && is.character(dfpart[[datcol]])) { |
364 | ! |
paste( |
365 | ! |
"\nPerhaps convert analysis variable", datcol, |
366 | ! |
"to a factor?" |
367 |
) |
|
368 |
} |
|
369 |
) |
|
370 |
} |
|
371 | 1571x |
maxind <- match(max(unqlens), lens) |
372 | ||
373 |
## look if we got labels, if not apply the |
|
374 |
## default row labels |
|
375 |
## this is guaranteed to be a RowsVerticalSection object. |
|
376 | 1571x |
rv1col <- rawvals[[maxind]] |
377 |
## nocov start |
|
378 |
if (!is(rv1col, "RowsVerticalSection")) { |
|
379 |
stop( |
|
380 |
"gen_rowvalues appears to have generated something that was not ", |
|
381 |
"a RowsVerticalSection object. Please contact the maintainer." |
|
382 |
) |
|
383 |
} |
|
384 |
# nocov end |
|
385 | ||
386 | 1571x |
labels <- value_labels(rv1col) |
387 | ||
388 | 1571x |
ncrows <- max(unqlens) |
389 | 1571x |
if (ncrows == 0) { |
390 | ! |
return(list()) |
391 |
} |
|
392 | 1571x |
stopifnot(ncrows > 0) |
393 | ||
394 | 1571x |
if (is.null(labels)) { |
395 | 210x |
if (length(rawvals[[maxind]]) == length(defrowlabs)) { |
396 | 202x |
labels <- defrowlabs |
397 |
} else { |
|
398 | 8x |
labels <- rep("", ncrows) |
399 |
} |
|
400 |
} |
|
401 | ||
402 | 1571x |
rfootnotes <- rep(list(list(), length(rv1col))) |
403 | 1571x |
nms <- value_names(rv1col) |
404 | 1571x |
rfootnotes <- row_footnotes(rv1col) |
405 | ||
406 | 1571x |
imods <- indent_mod(rv1col) ## rv1col@indent_mods |
407 | 1571x |
unwrapped_vals <- lapply(rawvals, as, Class = "list", strict = TRUE) |
408 | ||
409 | 1571x |
formatvec <- NULL |
410 | 1571x |
if (!is.null(format)) { |
411 | 208x |
if (is.function(format)) { |
412 | 1x |
format <- list(format) |
413 |
} |
|
414 | 208x |
formatvec <- rep(format, length.out = ncrows) |
415 |
} |
|
416 | ||
417 | 1571x |
trows <- lapply(1:ncrows, function(i) { |
418 | 2542x |
rowvals <- lapply(unwrapped_vals, function(colvals) { |
419 | 9110x |
colvals[[i]] |
420 |
}) |
|
421 | 2542x |
imod <- unique(vapply(rowvals, indent_mod, 0L)) |
422 | 2542x |
if (length(imod) != 1) { |
423 | ! |
stop( |
424 | ! |
"Different cells in the same row appear to have been given ", |
425 | ! |
"different indent_mod values" |
426 |
) |
|
427 |
} |
|
428 | 2542x |
rowconstr( |
429 | 2542x |
vals = rowvals, |
430 | 2542x |
cinfo = cinfo, |
431 | 2542x |
lev = lev, |
432 | 2542x |
label = labels[i], |
433 | 2542x |
name = nms[i], ## labels[i], ## XXX this is probably wrong?! |
434 | 2542x |
var = rowvar, |
435 | 2542x |
format = formatvec[[i]], |
436 | 2542x |
indent_mod = imods[[i]] %||% 0L, |
437 | 2542x |
footnotes = rfootnotes[[i]] ## one bracket so list |
438 |
) |
|
439 |
}) |
|
440 | 1571x |
trows |
441 |
} |
|
442 | ||
443 |
.make_caller <- function(parent_cfun, clabelstr = "") { |
|
444 | 470x |
formalnms <- names(formals(parent_cfun)) |
445 |
## note the <- here |
|
446 | 470x |
if (!is.na(dotspos <- match("...", formalnms))) { |
447 | 1x |
toremove <- dotspos |
448 |
} else { |
|
449 | 469x |
toremove <- NULL |
450 |
} |
|
451 | ||
452 | 470x |
labelstrpos <- match("labelstr", names(formals(parent_cfun))) |
453 | 470x |
if (is.na(labelstrpos)) { |
454 | ! |
stop( |
455 | ! |
"content function does not appear to accept the labelstr", |
456 | ! |
"arguent" |
457 |
) |
|
458 |
} |
|
459 | 470x |
toremove <- c(toremove, labelstrpos) |
460 | 470x |
formalnms <- formalnms[-1 * toremove] |
461 | ||
462 | 470x |
caller <- eval(parser_helper(text = paste( |
463 | 470x |
"function() { parent_cfun(", |
464 | 470x |
paste(formalnms, "=", |
465 | 470x |
formalnms, |
466 | 470x |
collapse = ", " |
467 |
), |
|
468 | 470x |
", labelstr = clabelstr, ...)}" |
469 |
))) |
|
470 | 470x |
formals(caller) <- c( |
471 | 470x |
formals(parent_cfun)[-labelstrpos], |
472 | 470x |
alist("..." = ) |
473 | 470x |
) # nolint |
474 | 470x |
caller |
475 |
} |
|
476 | ||
477 |
# Makes content table xxx renaming |
|
478 |
.make_ctab <- function(df, |
|
479 |
lvl, ## treepos, |
|
480 |
name, |
|
481 |
label, |
|
482 |
cinfo, |
|
483 |
parent_cfun = NULL, |
|
484 |
format = NULL, |
|
485 |
na_str = NA_character_, |
|
486 |
indent_mod = 0L, |
|
487 |
cvar = NULL, |
|
488 |
inclNAs, |
|
489 |
alt_df, |
|
490 |
extra_args, |
|
491 |
spl_context = context_df_row(cinfo = cinfo)) { |
|
492 | 1803x |
if (length(cvar) == 0 || is.na(cvar) || identical(nchar(cvar), 0L)) { |
493 | 1627x |
cvar <- NULL |
494 |
} |
|
495 | 1803x |
if (!is.null(parent_cfun)) { |
496 |
## cfunc <- .make_caller(parent_cfun, label) |
|
497 | 459x |
cfunc <- lapply(parent_cfun, .make_caller, clabelstr = label) |
498 | 459x |
contkids <- tryCatch( |
499 | 459x |
.make_tablerows(df, |
500 | 459x |
lev = lvl, |
501 | 459x |
func = cfunc, |
502 | 459x |
cinfo = cinfo, |
503 | 459x |
rowconstr = ContentRow, |
504 | 459x |
datcol = cvar, |
505 | 459x |
takesdf = rep(.takes_df(cfunc), |
506 | 459x |
length.out = ncol(cinfo) |
507 |
), |
|
508 | 459x |
inclNAs = FALSE, |
509 | 459x |
alt_dfpart = alt_df, |
510 | 459x |
splextra = extra_args, |
511 | 459x |
spl_context = spl_context |
512 |
), |
|
513 | 459x |
error = function(e) e |
514 |
) |
|
515 | 459x |
if (is(contkids, "error")) { |
516 | 1x |
stop("Error in content (summary) function: ", contkids$message, |
517 | 1x |
"\n\toccured at path: ", |
518 | 1x |
spl_context_to_disp_path(spl_context), |
519 | 1x |
call. = FALSE |
520 |
) |
|
521 |
} |
|
522 |
} else { |
|
523 | 1344x |
contkids <- list() |
524 |
} |
|
525 | 1802x |
ctab <- ElementaryTable( |
526 | 1802x |
kids = contkids, |
527 | 1802x |
name = paste0(name, "@content"), |
528 | 1802x |
lev = lvl, |
529 | 1802x |
labelrow = LabelRow(), |
530 | 1802x |
cinfo = cinfo, |
531 | 1802x |
iscontent = TRUE, |
532 | 1802x |
format = format, |
533 | 1802x |
indent_mod = indent_mod, |
534 | 1802x |
na_str = na_str |
535 |
) |
|
536 | 1802x |
ctab |
537 |
} |
|
538 | ||
539 |
.make_analyzed_tab <- function(df, |
|
540 |
alt_df, |
|
541 |
spl, |
|
542 |
cinfo, |
|
543 |
partlabel = "", |
|
544 |
dolab = TRUE, |
|
545 |
lvl, |
|
546 |
baselines, |
|
547 |
spl_context) { |
|
548 | 1117x |
stopifnot(is(spl, "VAnalyzeSplit")) |
549 | 1117x |
check_validsplit(spl, df) |
550 | 1116x |
defrlabel <- spl@default_rowlabel |
551 | 1116x |
if (nchar(defrlabel) == 0 && !missing(partlabel) && nchar(partlabel) > 0) { |
552 | ! |
defrlabel <- partlabel |
553 |
} |
|
554 | 1116x |
kids <- tryCatch( |
555 | 1116x |
.make_tablerows(df, |
556 | 1116x |
func = analysis_fun(spl), |
557 | 1116x |
defrowlabs = defrlabel, # XXX |
558 | 1116x |
cinfo = cinfo, |
559 | 1116x |
datcol = spl_payload(spl), |
560 | 1116x |
lev = lvl + 1L, |
561 | 1116x |
format = obj_format(spl), |
562 | 1116x |
splextra = split_exargs(spl), |
563 | 1116x |
baselines = baselines, |
564 | 1116x |
alt_dfpart = alt_df, |
565 | 1116x |
inclNAs = avar_inclNAs(spl), |
566 | 1116x |
spl_context = spl_context |
567 |
), |
|
568 | 1116x |
error = function(e) e |
569 |
) |
|
570 | ||
571 |
# Adding section_div for DataRows (analyze leaves) |
|
572 | 1116x |
kids <- .set_kids_section_div(kids, spl_section_div(spl), "DataRow") |
573 | ||
574 | 1116x |
if (is(kids, "error")) { |
575 | 3x |
stop("Error applying analysis function (var - ", |
576 | 3x |
spl_payload(spl) %||% "colvars", "): ", kids$message, |
577 | 3x |
"\n\toccured at (row) path: ", |
578 | 3x |
spl_context_to_disp_path(spl_context), |
579 | 3x |
call. = FALSE |
580 |
) |
|
581 |
} |
|
582 | 1113x |
lab <- obj_label(spl) |
583 | 1113x |
ret <- TableTree( |
584 | 1113x |
kids = kids, |
585 | 1113x |
name = obj_name(spl), |
586 | 1113x |
label = lab, |
587 | 1113x |
lev = lvl, |
588 | 1113x |
cinfo = cinfo, |
589 | 1113x |
format = obj_format(spl), |
590 | 1113x |
na_str = obj_na_str(spl), |
591 | 1113x |
indent_mod = indent_mod(spl) |
592 |
) |
|
593 | ||
594 | 1113x |
labelrow_visible(ret) <- dolab |
595 | 1113x |
ret |
596 |
} |
|
597 | ||
598 |
#' @param ... all arguments to `recurse_applysplit`, methods may only use some of them. |
|
599 |
#' @return A `list` of children to place at this level. |
|
600 |
#' |
|
601 |
#' @noRd |
|
602 |
setGeneric(".make_split_kids", function(spl, have_controws, make_lrow, ...) { |
|
603 | 1643x |
standardGeneric(".make_split_kids") |
604 |
}) |
|
605 | ||
606 |
## single AnalyzeSplit |
|
607 |
setMethod( |
|
608 |
".make_split_kids", "VAnalyzeSplit", |
|
609 |
function(spl, |
|
610 |
have_controws, ## unused here |
|
611 |
make_lrow, ## unused here |
|
612 |
..., |
|
613 |
df, |
|
614 |
alt_df, |
|
615 |
lvl, |
|
616 |
name, |
|
617 |
cinfo, |
|
618 |
baselines, |
|
619 |
spl_context, |
|
620 |
nsibs = 0) { |
|
621 | 1117x |
spvis <- labelrow_visible(spl) |
622 | 1117x |
if (is.na(spvis)) { |
623 | 190x |
spvis <- nsibs > 0 |
624 |
} |
|
625 | ||
626 | 1117x |
ret <- .make_analyzed_tab( |
627 | 1117x |
df = df, |
628 | 1117x |
alt_df, |
629 | 1117x |
spl = spl, |
630 | 1117x |
cinfo = cinfo, |
631 | 1117x |
lvl = lvl + 1L, |
632 | 1117x |
dolab = spvis, |
633 | 1117x |
partlabel = obj_label(spl), |
634 | 1117x |
baselines = baselines, |
635 | 1117x |
spl_context = spl_context |
636 |
) |
|
637 | 1113x |
indent_mod(ret) <- indent_mod(spl) |
638 | ||
639 | 1113x |
kids <- list(ret) |
640 | 1113x |
names(kids) <- obj_name(ret) |
641 | 1113x |
kids |
642 |
} |
|
643 |
) |
|
644 | ||
645 |
# Adding section_divisors to TableRow |
|
646 |
.set_kids_section_div <- function(lst, trailing_section_div_char, allowed_class = "VTableTree") { |
|
647 | 1623x |
if (!is.na(trailing_section_div_char)) { |
648 | 29x |
lst <- lapply( |
649 | 29x |
lst, |
650 | 29x |
function(k) { |
651 | 70x |
if (is(k, allowed_class)) { |
652 | 70x |
trailing_section_div(k) <- trailing_section_div_char |
653 |
} |
|
654 | 70x |
k |
655 |
} |
|
656 |
) |
|
657 |
} |
|
658 | 1623x |
lst |
659 |
} |
|
660 | ||
661 |
## 1 or more AnalyzeSplits |
|
662 |
setMethod( |
|
663 |
".make_split_kids", "AnalyzeMultiVars", |
|
664 |
function(spl, |
|
665 |
have_controws, |
|
666 |
make_lrow, ## used here |
|
667 |
spl_context, |
|
668 |
...) { ## all passed directly down to VAnalyzeSplit method |
|
669 | 102x |
avspls <- spl_payload(spl) |
670 | ||
671 | 102x |
nspl <- length(avspls) |
672 | ||
673 | 102x |
kids <- unlist(lapply(avspls, |
674 | 102x |
.make_split_kids, |
675 | 102x |
nsibs = nspl - 1, |
676 | 102x |
have_controws = have_controws, |
677 | 102x |
make_lrow = make_lrow, |
678 | 102x |
spl_context = spl_context, |
679 |
... |
|
680 |
)) |
|
681 | ||
682 | 102x |
kids <- .set_kids_section_div(kids, spl_section_div(spl), "VTableTree") |
683 | ||
684 |
## XXX this seems like it should be identical not !identical |
|
685 |
## TODO FIXME |
|
686 | 102x |
if (!identical(make_lrow, FALSE) && !have_controws && length(kids) == 1) { |
687 |
## we only analyzed one var so |
|
688 |
## we don't need an extra wrapper table |
|
689 |
## in the structure |
|
690 | ! |
stopifnot(identical( |
691 | ! |
obj_name(kids[[1]]), |
692 | ! |
spl_payload(spl) |
693 |
)) |
|
694 | ! |
return(kids[[1]]) |
695 |
} |
|
696 |
## this will be the variables |
|
697 |
## nms = sapply(spl_payload(spl), spl_payload) |
|
698 | ||
699 | 102x |
nms <- vapply(kids, obj_name, "") |
700 | 102x |
labs <- vapply(kids, obj_label, "") |
701 | 102x |
if (length(unique(nms)) != length(nms) && length(unique(nms)) != length(nms)) { |
702 | 1x |
warning("Non-unique sibling analysis table names. Using Labels ", |
703 | 1x |
"instead. Use the table_names argument to analyze to avoid ", |
704 | 1x |
"this when analyzing the same variable multiple times.", |
705 | 1x |
"\n\toccured at (row) path: ", |
706 | 1x |
spl_context_to_disp_path(spl_context), |
707 | 1x |
call. = FALSE |
708 |
) |
|
709 | 1x |
kids <- mapply(function(k, nm) { |
710 | 2x |
obj_name(k) <- nm |
711 | 2x |
k |
712 | 1x |
}, k = kids, nm = labs, SIMPLIFY = FALSE) |
713 | 1x |
nms <- labs |
714 |
} |
|
715 | ||
716 | 102x |
nms[is.na(nms)] <- "" |
717 | ||
718 | 102x |
names(kids) <- nms |
719 | 102x |
kids |
720 |
} |
|
721 |
) |
|
722 | ||
723 |
setMethod( |
|
724 |
".make_split_kids", "Split", |
|
725 |
function(spl, |
|
726 |
have_controws, |
|
727 |
make_lrow, |
|
728 |
..., |
|
729 |
splvec, ## passed to recursive_applysplit |
|
730 |
df, ## used to apply split |
|
731 |
alt_df, ## used to apply split for alternative df |
|
732 |
lvl, ## used to calculate innerlev |
|
733 |
cinfo, ## used for sanity check |
|
734 |
baselines, ## used to calc new baselines |
|
735 |
spl_context) { |
|
736 |
## do the core splitting of data into children for this split |
|
737 | 424x |
rawpart <- do_split(spl, df, spl_context = spl_context) |
738 | 420x |
dataspl <- rawpart[["datasplit"]] |
739 |
## these are SplitValue objects |
|
740 | 420x |
splvals <- rawpart[["values"]] |
741 | 420x |
partlabels <- rawpart[["labels"]] |
742 | 420x |
if (is.factor(partlabels)) { |
743 | ! |
partlabels <- as.character(partlabels) |
744 |
} |
|
745 | 420x |
nms <- unlist(value_names(splvals)) |
746 | 420x |
if (is.factor(nms)) { |
747 | ! |
nms <- as.character(nms) |
748 |
} |
|
749 | ||
750 |
## Get new baseline values |
|
751 |
## |
|
752 |
## XXX this is a lot of data churn, if it proves too slow |
|
753 |
## we can |
|
754 |
## a) check if any of the analyses (i.e. the afuns) need the baseline in this |
|
755 |
## splitvec and not do any of this if not, or |
|
756 |
## b) refactor row splitting to behave like column splitting |
|
757 |
## |
|
758 |
## (b) seems the better design but is a major reworking of the guts of how |
|
759 |
## rtables tabulation works |
|
760 |
## (a) will only help if analyses that use baseline |
|
761 |
## info are mixed with those who don't. |
|
762 | 420x |
newbl_raw <- lapply(baselines, function(dat) { |
763 |
# If no ref_group is specified |
|
764 | 1524x |
if (is.null(dat)) { |
765 | 1504x |
return(NULL) |
766 |
} |
|
767 | ||
768 |
## apply the same splitting on the |
|
769 | 20x |
bldataspl <- tryCatch(do_split(spl, dat, spl_context = spl_context)[["datasplit"]], |
770 | 20x |
error = function(e) e |
771 |
) |
|
772 | ||
773 |
# Error localization |
|
774 | 20x |
if (is(bldataspl, "error")) { |
775 | ! |
stop("Following error encountered in splitting .ref_group (baselines): ", |
776 | ! |
bldataspl$message, |
777 | ! |
call. = FALSE |
778 |
) |
|
779 |
} |
|
780 | ||
781 |
## we only keep the ones corresponding with actual data splits |
|
782 | 20x |
res <- lapply( |
783 | 20x |
names(dataspl), |
784 | 20x |
function(nm) { |
785 | 52x |
if (nm %in% names(bldataspl)) { |
786 | 52x |
bldataspl[[nm]] |
787 |
} else { |
|
788 | ! |
dataspl[[1]][0, ] |
789 |
} |
|
790 |
} |
|
791 |
) |
|
792 | ||
793 | 20x |
names(res) <- names(dataspl) |
794 | 20x |
res |
795 |
}) |
|
796 | ||
797 | 420x |
newbaselines <- lapply(names(dataspl), function(nm) { |
798 | 1241x |
lapply(newbl_raw, function(rawdat) { |
799 | 4490x |
if (nm %in% names(rawdat)) { |
800 | 52x |
rawdat[[nm]] |
801 |
} else { |
|
802 | 4438x |
rawdat[[1]][0, ] |
803 |
} |
|
804 |
}) |
|
805 |
}) |
|
806 | ||
807 | 420x |
if (length(newbaselines) != length(dataspl)) { |
808 | ! |
stop( |
809 | ! |
"Baselines (ref_group) after row split does not have", |
810 | ! |
" the same number of levels of input data split. ", |
811 | ! |
"Contact the maintainer." |
812 | ! |
) # nocov |
813 |
} |
|
814 | 420x |
if (!(length(newbaselines) == 0 || |
815 | 420x |
identical( |
816 | 420x |
unique(sapply(newbaselines, length)), |
817 | 420x |
length(col_exprs(cinfo)) |
818 |
))) { |
|
819 | ! |
stop( |
820 | ! |
"Baselines (ref_group) do not have the same number of columns", |
821 | ! |
" in each split. Contact the maintainer." |
822 | ! |
) # nocov |
823 |
} |
|
824 | ||
825 |
# If params are not present do not do the calculation |
|
826 | 420x |
acdf_param <- check_afun_cfun_params( |
827 | 420x |
SplitVector(spl, splvec), |
828 | 420x |
c(".alt_df", ".alt_df_row") |
829 |
) |
|
830 | ||
831 |
# Apply same split for alt_counts_df |
|
832 | 420x |
if (!is.null(alt_df) && any(acdf_param)) { |
833 | 17x |
alt_dfpart <- tryCatch( |
834 | 17x |
do_split(spl, alt_df, |
835 | 17x |
spl_context = spl_context |
836 | 17x |
)[["datasplit"]], |
837 | 17x |
error = function(e) e |
838 |
) |
|
839 | ||
840 |
# Removing NA rows - to explore why this happens at all in a split |
|
841 |
# This would be a fix but it is done in post-processing instead of pre-proc -> xxx |
|
842 |
# x alt_dfpart <- lapply(alt_dfpart, function(data) { |
|
843 |
# x data[!apply(is.na(data), 1, all), ] |
|
844 |
# x }) |
|
845 | ||
846 |
# Error localization |
|
847 | 17x |
if (is(alt_dfpart, "error")) { |
848 | 2x |
stop("Following error encountered in splitting alt_counts_df: ", |
849 | 2x |
alt_dfpart$message, |
850 | 2x |
call. = FALSE |
851 |
) |
|
852 |
} |
|
853 |
# Error if split does not have the same values in the alt_df (and order) |
|
854 |
# The following breaks if there are different levels (do_split returns empty list) |
|
855 |
# or if there are different number of the same levels. Added handling of NAs |
|
856 |
# in the values of the factor when is all only NAs |
|
857 | 15x |
is_all_na <- all(is.na(alt_df[[spl_payload(spl)]])) |
858 | ||
859 | 15x |
if (!all(names(dataspl) %in% names(alt_dfpart)) || length(alt_dfpart) != length(dataspl) || is_all_na) { |
860 | 5x |
alt_df_spl_vals <- unique(alt_df[[spl_payload(spl)]]) |
861 | 5x |
end_part <- "" |
862 | ||
863 | 5x |
if (!all(alt_df_spl_vals %in% levels(alt_df_spl_vals))) { |
864 | 2x |
end_part <- paste0( |
865 | 2x |
" and following levels: ", |
866 | 2x |
paste_vec(levels(alt_df_spl_vals)) |
867 |
) |
|
868 |
} |
|
869 | ||
870 | 5x |
if (is_all_na) { |
871 | 2x |
end_part <- ". Found only NAs in alt_counts_df split" |
872 |
} |
|
873 | ||
874 | 5x |
stop( |
875 | 5x |
"alt_counts_df split variable(s) [", spl_payload(spl), |
876 | 5x |
"] (in split ", as.character(class(spl)), |
877 | 5x |
") does not have the same factor levels of df.\ndf has c(", '"', |
878 | 5x |
paste(names(dataspl), collapse = '", "'), '"', ") levels while alt_counts_df has ", |
879 | 5x |
ifelse(length(alt_df_spl_vals) > 0, paste_vec(alt_df_spl_vals), ""), |
880 | 5x |
" unique values", end_part |
881 |
) |
|
882 |
} |
|
883 |
} else { |
|
884 | 403x |
alt_dfpart <- setNames(rep(list(NULL), length(dataspl)), names(dataspl)) |
885 |
} |
|
886 | ||
887 | ||
888 | 413x |
innerlev <- lvl + (have_controws || is.na(make_lrow) || make_lrow) |
889 |
## do full recursive_applysplit on each part of the split defined by spl |
|
890 | 413x |
inner <- unlist(mapply( |
891 | 413x |
function(dfpart, alt_dfpart, nm, label, baselines, splval) { |
892 | 1199x |
rsplval <- context_df_row( |
893 | 1199x |
split = obj_name(spl), |
894 | 1199x |
value = value_names(splval), |
895 | 1199x |
full_parent_df = list(dfpart), |
896 | 1199x |
cinfo = cinfo |
897 |
) |
|
898 | ||
899 |
## if(length(rsplval) > 0) |
|
900 |
## rsplval <- setNames(rsplval, obj_name(spl)) |
|
901 | 1199x |
recursive_applysplit( |
902 | 1199x |
df = dfpart, |
903 | 1199x |
alt_df = alt_dfpart, |
904 | 1199x |
name = nm, |
905 | 1199x |
lvl = innerlev, |
906 | 1199x |
splvec = splvec, |
907 | 1199x |
cinfo = cinfo, |
908 | 1199x |
make_lrow = label_kids(spl), |
909 | 1199x |
parent_cfun = content_fun(spl), |
910 | 1199x |
cformat = content_format(spl), |
911 | 1199x |
cna_str = content_na_str(spl), |
912 | 1199x |
partlabel = label, |
913 | 1199x |
cindent_mod = content_indent_mod(spl), |
914 | 1199x |
cvar = content_var(spl), |
915 | 1199x |
baselines = baselines, |
916 | 1199x |
cextra_args = content_extra_args(spl), |
917 |
## splval should still be retaining its name |
|
918 | 1199x |
spl_context = rbind(spl_context, rsplval) |
919 |
) |
|
920 |
}, |
|
921 | 413x |
dfpart = dataspl, |
922 | 413x |
alt_dfpart = alt_dfpart, |
923 | 413x |
label = partlabels, |
924 | 413x |
nm = nms, |
925 | 413x |
baselines = newbaselines, |
926 | 413x |
splval = splvals, |
927 | 413x |
SIMPLIFY = FALSE |
928 |
)) |
|
929 | ||
930 |
# Setting the kids section separator if they inherits VTableTree |
|
931 | 405x |
inner <- .set_kids_section_div( |
932 | 405x |
inner, |
933 | 405x |
trailing_section_div_char = spl_section_div(spl), |
934 | 405x |
allowed_class = "VTableTree" |
935 |
) |
|
936 | ||
937 |
## This is where we need to build the structural tables |
|
938 |
## even if they are invisible because their labels are not |
|
939 |
## not shown. |
|
940 | 405x |
innertab <- TableTree( |
941 | 405x |
kids = inner, |
942 | 405x |
name = obj_name(spl), |
943 | 405x |
labelrow = LabelRow( |
944 | 405x |
label = obj_label(spl), |
945 | 405x |
vis = isTRUE(vis_label(spl)) |
946 |
), |
|
947 | 405x |
cinfo = cinfo, |
948 | 405x |
iscontent = FALSE, |
949 | 405x |
indent_mod = indent_mod(spl), |
950 | 405x |
page_title = ptitle_prefix(spl) |
951 |
) |
|
952 |
## kids = inner |
|
953 | 405x |
kids <- list(innertab) |
954 | 405x |
kids |
955 |
} |
|
956 |
) |
|
957 | ||
958 |
context_df_row <- function(split = character(), |
|
959 |
value = character(), |
|
960 |
full_parent_df = list(), |
|
961 |
cinfo = NULL) { |
|
962 | 2741x |
ret <- data.frame( |
963 | 2741x |
split = split, |
964 | 2741x |
value = value, |
965 | 2741x |
full_parent_df = I(full_parent_df), |
966 |
# parent_cold_inds = I(parent_col_inds), |
|
967 | 2741x |
stringsAsFactors = FALSE |
968 |
) |
|
969 | 2741x |
if (nrow(ret) > 0) { |
970 | 2725x |
ret$all_cols_n <- nrow(full_parent_df[[1]]) |
971 |
} else { |
|
972 | 16x |
ret$all_cols_n <- integer() ## should this be numeric??? This never happens |
973 |
} |
|
974 | ||
975 | 2741x |
if (!is.null(cinfo)) { |
976 | 1507x |
if (nrow(ret) > 0) { |
977 | 1498x |
colcols <- as.data.frame(lapply(col_exprs(cinfo), function(e) { |
978 | 5356x |
vals <- eval(e, envir = full_parent_df[[1]]) |
979 | 5356x |
if (identical(vals, TRUE)) { |
980 | 507x |
vals <- rep(vals, length.out = nrow(full_parent_df[[1]])) |
981 |
} |
|
982 | 5356x |
I(list(vals)) |
983 |
})) |
|
984 |
} else { |
|
985 | 9x |
colcols <- as.data.frame(rep(list(logical()), ncol(cinfo))) |
986 |
} |
|
987 | 1507x |
names(colcols) <- names(col_exprs(cinfo)) |
988 | 1507x |
ret <- cbind(ret, colcols) |
989 |
} |
|
990 | 2741x |
ret |
991 |
} |
|
992 | ||
993 |
recursive_applysplit <- function(df, |
|
994 |
lvl = 0L, |
|
995 |
alt_df, |
|
996 |
splvec, |
|
997 |
name, |
|
998 |
# label, |
|
999 |
make_lrow = NA, |
|
1000 |
partlabel = "", |
|
1001 |
cinfo, |
|
1002 |
parent_cfun = NULL, |
|
1003 |
cformat = NULL, |
|
1004 |
cna_str = NA_character_, |
|
1005 |
cindent_mod = 0L, |
|
1006 |
cextra_args = list(), |
|
1007 |
cvar = NULL, |
|
1008 |
baselines = lapply( |
|
1009 |
col_extra_args(cinfo), |
|
1010 |
function(x) x$.ref_full |
|
1011 |
), |
|
1012 |
spl_context = context_df_row(cinfo = cinfo), |
|
1013 |
no_outer_tbl = FALSE, |
|
1014 |
parent_sect_split = NA_character_) { |
|
1015 |
## pre-existing table was added to the layout |
|
1016 | 1507x |
if (length(splvec) == 1L && is(splvec[[1]], "VTableNodeInfo")) { |
1017 | 1x |
return(splvec[[1]]) |
1018 |
} |
|
1019 | ||
1020 |
## the content function is the one from the PREVIOUS |
|
1021 |
## split, i.e. the one whose children we are now constructing |
|
1022 |
## this is a bit annoying but makes the semantics for |
|
1023 |
## declaring layouts much more sane. |
|
1024 | 1506x |
ctab <- .make_ctab(df, |
1025 | 1506x |
lvl = lvl, |
1026 | 1506x |
name = name, |
1027 | 1506x |
label = partlabel, |
1028 | 1506x |
cinfo = cinfo, |
1029 | 1506x |
parent_cfun = parent_cfun, |
1030 | 1506x |
format = cformat, |
1031 | 1506x |
na_str = cna_str, |
1032 | 1506x |
indent_mod = cindent_mod, |
1033 | 1506x |
cvar = cvar, |
1034 | 1506x |
alt_df = alt_df, |
1035 | 1506x |
extra_args = cextra_args, |
1036 | 1506x |
spl_context = spl_context |
1037 |
) |
|
1038 | ||
1039 | 1505x |
nonroot <- lvl != 0L |
1040 | ||
1041 | 1505x |
if (is.na(make_lrow)) { |
1042 | 1209x |
make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE |
1043 |
} |
|
1044 |
## never print an empty row label for root. |
|
1045 | 1505x |
if (make_lrow && partlabel == "" && !nonroot) { |
1046 | 6x |
make_lrow <- FALSE |
1047 |
} |
|
1048 | ||
1049 | 1505x |
if (length(splvec) == 0L) { |
1050 | 79x |
kids <- list() |
1051 | 79x |
imod <- 0L |
1052 | 79x |
spl <- NULL |
1053 |
} else { |
|
1054 | 1426x |
spl <- splvec[[1]] |
1055 | 1426x |
splvec <- splvec[-1] |
1056 | ||
1057 |
## we pass this everything recursive_applysplit received and |
|
1058 |
## it all gets passed around through ... as needed |
|
1059 |
## to the various methods of .make_split_kids |
|
1060 | 1426x |
kids <- .make_split_kids( |
1061 | 1426x |
spl = spl, |
1062 | 1426x |
df = df, |
1063 | 1426x |
alt_df = alt_df, |
1064 | 1426x |
lvl = lvl, |
1065 | 1426x |
splvec = splvec, |
1066 | 1426x |
name = name, |
1067 | 1426x |
make_lrow = make_lrow, |
1068 | 1426x |
partlabel = partlabel, |
1069 | 1426x |
cinfo = cinfo, |
1070 | 1426x |
parent_cfun = parent_cfun, |
1071 | 1426x |
cformat = cformat, |
1072 | 1426x |
cindent_mod = cindent_mod, |
1073 | 1426x |
cextra_args = cextra_args, cvar = cvar, |
1074 | 1426x |
baselines = baselines, |
1075 | 1426x |
spl_context = spl_context, |
1076 | 1426x |
have_controws = nrow(ctab) > 0 |
1077 |
) |
|
1078 | 1403x |
imod <- 0L |
1079 |
} ## end length(splvec) |
|
1080 | ||
1081 | 1482x |
if (is.na(make_lrow)) { |
1082 | ! |
make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE |
1083 |
} |
|
1084 |
## never print an empty row label for root. |
|
1085 | 1482x |
if (make_lrow && partlabel == "" && !nonroot) { |
1086 | ! |
make_lrow <- FALSE |
1087 |
} |
|
1088 | ||
1089 |
## this is only true when called from build_table and the first split |
|
1090 |
## in (one of the) SplitVector is NOT an AnalyzeMultiVars split. |
|
1091 |
## in that case we would be "double creating" the structural |
|
1092 |
## subtable |
|
1093 | 1482x |
if (no_outer_tbl) { |
1094 | 266x |
ret <- kids[[1]] |
1095 | 266x |
indent_mod(ret) <- indent_mod(spl) |
1096 | 1216x |
} else if (nrow(ctab) > 0L || length(kids) > 0L) { |
1097 |
## previously we checked if the child had an identical label |
|
1098 |
## but I don't think thats needed anymore. |
|
1099 | 1216x |
tlabel <- partlabel |
1100 | 1216x |
ret <- TableTree( |
1101 | 1216x |
cont = ctab, |
1102 | 1216x |
kids = kids, |
1103 | 1216x |
name = name, |
1104 | 1216x |
label = tlabel, # partlabel, |
1105 | 1216x |
lev = lvl, |
1106 | 1216x |
iscontent = FALSE, |
1107 | 1216x |
labelrow = LabelRow( |
1108 | 1216x |
lev = lvl, |
1109 | 1216x |
label = tlabel, |
1110 | 1216x |
cinfo = cinfo, |
1111 | 1216x |
vis = make_lrow |
1112 |
), |
|
1113 | 1216x |
cinfo = cinfo, |
1114 | 1216x |
indent_mod = imod |
1115 |
) |
|
1116 |
} else { |
|
1117 | ! |
ret <- NULL |
1118 |
} |
|
1119 | ||
1120 |
## if(!is.null(spl) && !is.na(spl_section_sep(spl))) |
|
1121 |
## ret <- apply_kids_section_sep(ret, spl_section_sep(spl)) |
|
1122 |
## ## message(sprintf("indent modifier: %d", indentmod)) |
|
1123 |
## if(!is.null(ret)) |
|
1124 |
## indent_mod(ret) = indentmod |
|
1125 | 1482x |
ret |
1126 |
} |
|
1127 | ||
1128 |
#' Create a table from a layout and data |
|
1129 |
#' |
|
1130 |
#' Layouts are used to describe a table pre-data. `build_table` is used to create a table |
|
1131 |
#' using a layout and a dataset. |
|
1132 |
#' |
|
1133 |
#' @inheritParams gen_args |
|
1134 |
#' @inheritParams lyt_args |
|
1135 |
#' @param col_counts (`numeric` or `NULL`)\cr `r lifecycle::badge("deprecated")` if non-`NULL`, column counts |
|
1136 |
#' which override those calculated automatically during tabulation. Must specify "counts" for *all* |
|
1137 |
#' resulting columns if non-`NULL`. `NA` elements will be replaced with the automatically calculated counts. |
|
1138 |
#' @param col_total (`integer(1)`)\cr the total observations across all columns. Defaults to `nrow(df)`. |
|
1139 |
#' @param ... ignored. |
|
1140 |
#' |
|
1141 |
#' @details |
|
1142 |
#' When `alt_counts_df` is specified, column counts are calculated by applying the exact column subsetting |
|
1143 |
#' expressions determined when applying column splitting to the main data (`df`) to `alt_counts_df` and |
|
1144 |
#' counting the observations in each resulting subset. |
|
1145 |
#' |
|
1146 |
#' In particular, this means that in the case of splitting based on cuts of the data, any dynamic cuts will have |
|
1147 |
#' been calculated based on `df` and simply re-used for the count calculation. |
|
1148 |
#' |
|
1149 |
#' @note |
|
1150 |
#' When overriding the column counts or totals care must be taken that, e.g., `length()` or `nrow()` are not called |
|
1151 |
#' within tabulation functions, because those will NOT give the overridden counts. Writing/using tabulation |
|
1152 |
#' functions which accept `.N_col` and `.N_total` or do not rely on column counts at all (even implicitly) is the |
|
1153 |
#' only way to ensure overridden counts are fully respected. |
|
1154 |
#' |
|
1155 |
#' @return A `TableTree` or `ElementaryTable` object representing the table created by performing the tabulations |
|
1156 |
#' declared in `lyt` to the data `df`. |
|
1157 |
#' |
|
1158 |
#' @examples |
|
1159 |
#' lyt <- basic_table() %>% |
|
1160 |
#' split_cols_by("Species") %>% |
|
1161 |
#' analyze("Sepal.Length", afun = function(x) { |
|
1162 |
#' list( |
|
1163 |
#' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), |
|
1164 |
#' "range" = diff(range(x)) |
|
1165 |
#' ) |
|
1166 |
#' }) |
|
1167 |
#' lyt |
|
1168 |
#' |
|
1169 |
#' tbl <- build_table(lyt, iris) |
|
1170 |
#' tbl |
|
1171 |
#' |
|
1172 |
#' # analyze multiple variables |
|
1173 |
#' lyt2 <- basic_table() %>% |
|
1174 |
#' split_cols_by("Species") %>% |
|
1175 |
#' analyze(c("Sepal.Length", "Petal.Width"), afun = function(x) { |
|
1176 |
#' list( |
|
1177 |
#' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), |
|
1178 |
#' "range" = diff(range(x)) |
|
1179 |
#' ) |
|
1180 |
#' }) |
|
1181 |
#' |
|
1182 |
#' tbl2 <- build_table(lyt2, iris) |
|
1183 |
#' tbl2 |
|
1184 |
#' |
|
1185 |
#' # an example more relevant for clinical trials with column counts |
|
1186 |
#' lyt3 <- basic_table(show_colcounts = TRUE) %>% |
|
1187 |
#' split_cols_by("ARM") %>% |
|
1188 |
#' analyze("AGE", afun = function(x) { |
|
1189 |
#' setNames(as.list(fivenum(x)), c( |
|
1190 |
#' "minimum", "lower-hinge", "median", |
|
1191 |
#' "upper-hinge", "maximum" |
|
1192 |
#' )) |
|
1193 |
#' }) |
|
1194 |
#' |
|
1195 |
#' tbl3 <- build_table(lyt3, DM) |
|
1196 |
#' tbl3 |
|
1197 |
#' |
|
1198 |
#' tbl4 <- build_table(lyt3, subset(DM, AGE > 40)) |
|
1199 |
#' tbl4 |
|
1200 |
#' |
|
1201 |
#' # with column counts calculated based on different data |
|
1202 |
#' miniDM <- DM[sample(1:NROW(DM), 100), ] |
|
1203 |
#' tbl5 <- build_table(lyt3, DM, alt_counts_df = miniDM) |
|
1204 |
#' tbl5 |
|
1205 |
#' |
|
1206 |
#' tbl6 <- build_table(lyt3, DM, col_counts = 1:3) |
|
1207 |
#' tbl6 |
|
1208 |
#' |
|
1209 |
#' @author Gabriel Becker |
|
1210 |
#' @export |
|
1211 |
build_table <- function(lyt, df, |
|
1212 |
alt_counts_df = NULL, |
|
1213 |
col_counts = NULL, |
|
1214 |
col_total = if (is.null(alt_counts_df)) nrow(df) else nrow(alt_counts_df), |
|
1215 |
topleft = NULL, |
|
1216 |
hsep = default_hsep(), |
|
1217 |
...) { |
|
1218 | 318x |
if (!is(lyt, "PreDataTableLayouts")) { |
1219 | ! |
stop( |
1220 | ! |
"lyt must be a PreDataTableLayouts object. Got object of class ", |
1221 | ! |
class(lyt) |
1222 |
) |
|
1223 |
} |
|
1224 | ||
1225 |
## if no columns are defined (e.g. because lyt is NULL) |
|
1226 |
## add a single overall column as the "most basic" |
|
1227 |
## table column structure that makes sense |
|
1228 | 318x |
clyt <- clayout(lyt) |
1229 | 318x |
if (length(clyt) == 1 && length(clyt[[1]]) == 0) { |
1230 | 93x |
clyt[[1]] <- add_overall_col(clyt[[1]], "") |
1231 | 93x |
clayout(lyt) <- clyt |
1232 |
} |
|
1233 | ||
1234 |
## do checks and defensive programming now that we have the data |
|
1235 | 318x |
lyt <- fix_dyncuts(lyt, df) |
1236 | 318x |
lyt <- set_def_child_ord(lyt, df) |
1237 | 317x |
lyt <- fix_analyze_vis(lyt) |
1238 | 317x |
df <- fix_split_vars(lyt, df, char_ok = is.null(col_counts)) |
1239 | 308x |
alt_params <- check_afun_cfun_params(lyt, c(".alt_df", ".alt_df_row")) |
1240 | 308x |
if (any(alt_params) && is.null(alt_counts_df)) { |
1241 | 2x |
stop( |
1242 | 2x |
"Layout contains afun/cfun functions that have optional parameters ", |
1243 | 2x |
".alt_df and/or .alt_df_row, but no alt_count_df was provided in ", |
1244 | 2x |
"build_table()." |
1245 |
) |
|
1246 |
} |
|
1247 | ||
1248 | 306x |
rtpos <- TreePos() |
1249 | 306x |
cinfo <- create_colinfo(lyt, df, rtpos, |
1250 | 306x |
counts = col_counts, |
1251 | 306x |
alt_counts_df = alt_counts_df, |
1252 | 306x |
total = col_total, |
1253 | 306x |
topleft |
1254 |
) |
|
1255 | 297x |
if (!is.null(col_counts)) { |
1256 | 1x |
disp_ccounts(cinfo) <- TRUE |
1257 |
} |
|
1258 | 297x |
rlyt <- rlayout(lyt) |
1259 | 297x |
rtspl <- root_spl(rlyt) |
1260 | 297x |
ctab <- .make_ctab(df, 0L, |
1261 | 297x |
alt_df = NULL, |
1262 | 297x |
name = "root", |
1263 | 297x |
label = "", |
1264 | 297x |
cinfo = cinfo, ## cexprs, ctree, |
1265 | 297x |
parent_cfun = content_fun(rtspl), |
1266 | 297x |
format = content_format(rtspl), |
1267 | 297x |
na_str = content_na_str(rtspl), |
1268 | 297x |
indent_mod = 0L, |
1269 | 297x |
cvar = content_var(rtspl), |
1270 | 297x |
extra_args = content_extra_args(rtspl) |
1271 |
) |
|
1272 | ||
1273 | 297x |
kids <- lapply(seq_along(rlyt), function(i) { |
1274 | 322x |
splvec <- rlyt[[i]] |
1275 | 322x |
if (length(splvec) == 0) { |
1276 | 14x |
return(NULL) |
1277 |
} |
|
1278 | 308x |
firstspl <- splvec[[1]] |
1279 | 308x |
nm <- obj_name(firstspl) |
1280 |
## XXX unused, probably shouldn't be? |
|
1281 |
## this seems to be covered by grabbing the partlabel |
|
1282 |
## TODO confirm this |
|
1283 |
## lab <- obj_label(firstspl) |
|
1284 | 308x |
recursive_applysplit( |
1285 | 308x |
df = df, lvl = 0L, |
1286 | 308x |
alt_df = alt_counts_df, |
1287 | 308x |
name = nm, |
1288 | 308x |
splvec = splvec, |
1289 | 308x |
cinfo = cinfo, |
1290 |
## XXX are these ALWAYS right? |
|
1291 | 308x |
make_lrow = label_kids(firstspl), |
1292 | 308x |
parent_cfun = NULL, |
1293 | 308x |
cformat = content_format(firstspl), |
1294 | 308x |
cna_str = content_na_str(firstspl), |
1295 | 308x |
cvar = content_var(firstspl), |
1296 | 308x |
cextra_args = content_extra_args(firstspl), |
1297 | 308x |
spl_context = context_df_row( |
1298 | 308x |
split = "root", value = "root", |
1299 | 308x |
full_parent_df = list(df), |
1300 | 308x |
cinfo = cinfo |
1301 |
), |
|
1302 |
## we DO want the 'outer table' if the first |
|
1303 |
## one is a multi-analyze |
|
1304 | 308x |
no_outer_tbl = !is(firstspl, "AnalyzeMultiVars") |
1305 |
) |
|
1306 |
}) |
|
1307 | 281x |
kids <- kids[!sapply(kids, is.null)] |
1308 | 267x |
if (length(kids) > 0) names(kids) <- sapply(kids, obj_name) |
1309 | ||
1310 |
# top level divisor |
|
1311 | 281x |
if (!is.na(top_level_section_div(lyt))) { |
1312 | 2x |
kids <- lapply(kids, function(first_level_kids) { |
1313 | 4x |
trailing_section_div(first_level_kids) <- top_level_section_div(lyt) |
1314 | 4x |
first_level_kids |
1315 |
}) |
|
1316 |
} |
|
1317 | ||
1318 | 281x |
if (nrow(ctab) == 0L && length(kids) == 1L && is(kids[[1]], "VTableTree")) { |
1319 | 236x |
tab <- kids[[1]] |
1320 | 236x |
main_title(tab) <- main_title(lyt) |
1321 | 236x |
subtitles(tab) <- subtitles(lyt) |
1322 | 236x |
main_footer(tab) <- main_footer(lyt) |
1323 | 236x |
prov_footer(tab) <- prov_footer(lyt) |
1324 | 236x |
header_section_div(tab) <- header_section_div(lyt) |
1325 |
} else { |
|
1326 | 45x |
tab <- TableTree( |
1327 | 45x |
cont = ctab, |
1328 | 45x |
kids = kids, |
1329 | 45x |
lev = 0L, |
1330 | 45x |
name = "root", |
1331 | 45x |
label = "", |
1332 | 45x |
iscontent = FALSE, |
1333 | 45x |
cinfo = cinfo, |
1334 | 45x |
format = obj_format(rtspl), |
1335 | 45x |
na_str = obj_na_str(rtspl), |
1336 | 45x |
title = main_title(lyt), |
1337 | 45x |
subtitles = subtitles(lyt), |
1338 | 45x |
main_footer = main_footer(lyt), |
1339 | 45x |
prov_footer = prov_footer(lyt), |
1340 | 45x |
header_section_div = header_section_div(lyt) |
1341 |
) |
|
1342 |
} |
|
1343 | ||
1344 |
## This seems to be unneeded, not clear what 'top_left' check it refers to |
|
1345 |
## but both top_left taller than column headers and very long topleft are now |
|
1346 |
## allowed, so this is just wasted computation. |
|
1347 | ||
1348 |
## ## this is where the top_left check lives right now. refactor later maybe |
|
1349 |
## ## but now just call it so the error gets thrown when I want it to |
|
1350 |
## unused <- matrix_form(tab) |
|
1351 | 281x |
tab <- update_ref_indexing(tab) |
1352 | 281x |
horizontal_sep(tab) <- hsep |
1353 | 281x |
if (table_inset(lyt) > 0) { |
1354 | 1x |
table_inset(tab) <- table_inset(lyt) |
1355 |
} |
|
1356 | 281x |
tab |
1357 |
} |
|
1358 | ||
1359 |
# fix_split_vars ---- |
|
1360 |
# These checks guarantee that all the split variables are present in the data. |
|
1361 |
# No generic is needed because it is not dependent on the input layout but |
|
1362 |
# on the df. |
|
1363 |
fix_one_split_var <- function(spl, df, char_ok = TRUE) { |
|
1364 | 522x |
var <- spl_payload(spl) |
1365 | 522x |
if (!(var %in% names(df))) { |
1366 | 2x |
stop("Split variable [", var, "] not found in data being tabulated.") |
1367 |
} |
|
1368 | 520x |
varvec <- df[[var]] |
1369 | 520x |
if (!is(varvec, "character") && !is.factor(varvec)) { |
1370 | 1x |
message(sprintf( |
1371 | 1x |
paste( |
1372 | 1x |
"Split var [%s] was not character or factor.", |
1373 | 1x |
"Converting to factor" |
1374 |
), |
|
1375 | 1x |
var |
1376 |
)) |
|
1377 | 1x |
varvec <- factor(varvec) |
1378 | 1x |
df[[var]] <- varvec |
1379 | 519x |
} else if (is(varvec, "character") && !char_ok) { |
1380 | 1x |
stop( |
1381 | 1x |
"Overriding column counts is not supported when splitting on ", |
1382 | 1x |
"character variables.\n Please convert all column split variables to ", |
1383 | 1x |
"factors." |
1384 |
) |
|
1385 |
} |
|
1386 | ||
1387 | 519x |
if (is.factor(varvec)) { |
1388 | 360x |
levs <- levels(varvec) |
1389 |
} else { |
|
1390 | 159x |
levs <- unique(varvec) |
1391 |
} |
|
1392 | 519x |
if (!all(nzchar(levs))) { |
1393 | 4x |
stop( |
1394 | 4x |
"Got empty string level in splitting variable ", var, |
1395 | 4x |
" This is not supported.\nIf display as an empty level is ", |
1396 | 4x |
"desired use a value-labeling variable." |
1397 |
) |
|
1398 |
} |
|
1399 | ||
1400 |
## handle label var |
|
1401 | 515x |
lblvar <- spl_label_var(spl) |
1402 | 515x |
have_lblvar <- !identical(var, lblvar) |
1403 | 515x |
if (have_lblvar) { |
1404 | 88x |
if (!(lblvar %in% names(df))) { |
1405 | 1x |
stop( |
1406 | 1x |
"Value label variable [", lblvar, |
1407 | 1x |
"] not found in data being tabulated." |
1408 |
) |
|
1409 |
} |
|
1410 | 87x |
lblvec <- df[[lblvar]] |
1411 | 87x |
tab <- table(varvec, lblvec) |
1412 | ||
1413 | 87x |
if (any(rowSums(tab > 0) > 1) || any(colSums(tab > 0) > 1)) { |
1414 | 1x |
stop(sprintf( |
1415 | 1x |
paste( |
1416 | 1x |
"There does not appear to be a 1-1", |
1417 | 1x |
"correspondence between values in split var", |
1418 | 1x |
"[%s] and label var [%s]" |
1419 |
), |
|
1420 | 1x |
var, lblvar |
1421 |
)) |
|
1422 |
} |
|
1423 | ||
1424 | 86x |
if (!is(lblvec, "character") && !is.factor(lblvec)) { |
1425 | ! |
message(sprintf( |
1426 | ! |
paste( |
1427 | ! |
"Split label var [%s] was not character or", |
1428 | ! |
"factor. Converting to factor" |
1429 |
), |
|
1430 | ! |
var |
1431 |
)) |
|
1432 | ! |
lblvec <- factor(lblvec) |
1433 | ! |
df[[lblvar]] <- lblvec |
1434 |
} |
|
1435 |
} |
|
1436 | ||
1437 | 513x |
df |
1438 |
} |
|
1439 | ||
1440 |
fix_split_vars <- function(lyt, df, char_ok) { |
|
1441 | 317x |
df <- fix_split_vars_inner(clayout(lyt), df, char_ok = char_ok) |
1442 | 313x |
df <- fix_split_vars_inner(rlayout(lyt), df, char_ok = TRUE) |
1443 | 308x |
df |
1444 | ||
1445 |
## clyt <- clayout(lyt) |
|
1446 |
## rlyt <- rlayout(lyt) |
|
1447 | ||
1448 |
## allspls <- unlist(list(clyt, rlyt)) |
|
1449 |
## VarLevelSplit includes sublclass VarLevWBaselineSplit |
|
1450 |
} |
|
1451 | ||
1452 |
fix_split_vars_inner <- function(lyt, df, char_ok) { |
|
1453 | 630x |
stopifnot(is(lyt, "PreDataAxisLayout")) |
1454 | 630x |
allspls <- unlist(lyt) |
1455 | 630x |
varspls <- allspls[sapply(allspls, is, "VarLevelSplit")] |
1456 | 630x |
unqvarinds <- !duplicated(sapply(varspls, spl_payload)) |
1457 | 630x |
unqvarspls <- varspls[unqvarinds] |
1458 | 522x |
for (spl in unqvarspls) df <- fix_one_split_var(spl, df, char_ok = char_ok) |
1459 | ||
1460 | 621x |
df |
1461 |
} |
|
1462 | ||
1463 |
# set_def_child_ord ---- |
|
1464 |
## the table is built by recursively splitting the data and doing things to each |
|
1465 |
## piece. The order (or even values) of unique(df[[col]]) is not guaranteed to |
|
1466 |
## be the same in all the different partitions. This addresses that. |
|
1467 |
setGeneric( |
|
1468 |
"set_def_child_ord", |
|
1469 | 3600x |
function(lyt, df) standardGeneric("set_def_child_ord") |
1470 |
) |
|
1471 | ||
1472 |
setMethod( |
|
1473 |
"set_def_child_ord", "PreDataTableLayouts", |
|
1474 |
function(lyt, df) { |
|
1475 | 318x |
clayout(lyt) <- set_def_child_ord(clayout(lyt), df) |
1476 | 317x |
rlayout(lyt) <- set_def_child_ord(rlayout(lyt), df) |
1477 | 317x |
lyt |
1478 |
} |
|
1479 |
) |
|
1480 | ||
1481 |
setMethod( |
|
1482 |
"set_def_child_ord", "PreDataAxisLayout", |
|
1483 |
function(lyt, df) { |
|
1484 | 943x |
lyt@.Data <- lapply(lyt, set_def_child_ord, df = df) |
1485 | 942x |
lyt |
1486 |
} |
|
1487 |
) |
|
1488 | ||
1489 |
setMethod( |
|
1490 |
"set_def_child_ord", "SplitVector", |
|
1491 |
function(lyt, df) { |
|
1492 | 979x |
lyt[] <- lapply(lyt, set_def_child_ord, df = df) |
1493 | 978x |
lyt |
1494 |
} |
|
1495 |
) |
|
1496 | ||
1497 |
## for most split types, don't do anything |
|
1498 |
## becuause their ordering already isn't data-based |
|
1499 |
setMethod( |
|
1500 |
"set_def_child_ord", "ANY", |
|
1501 | 580x |
function(lyt, df) lyt |
1502 |
) |
|
1503 | ||
1504 |
setMethod( |
|
1505 |
"set_def_child_ord", "VarLevelSplit", |
|
1506 |
function(lyt, df) { |
|
1507 | 763x |
if (!is.null(spl_child_order(lyt))) { |
1508 | 244x |
return(lyt) |
1509 |
} |
|
1510 | ||
1511 | 519x |
vec <- df[[spl_payload(lyt)]] |
1512 | 519x |
vals <- if (is.factor(vec)) { |
1513 | 358x |
levels(vec) |
1514 |
} else { |
|
1515 | 161x |
unique(vec) |
1516 |
} |
|
1517 | 519x |
spl_child_order(lyt) <- vals |
1518 | 519x |
lyt |
1519 |
} |
|
1520 |
) |
|
1521 | ||
1522 |
setMethod( |
|
1523 |
"set_def_child_ord", "VarLevWBaselineSplit", |
|
1524 |
function(lyt, df) { |
|
1525 | 17x |
bline <- spl_ref_group(lyt) |
1526 | 17x |
if (!is.null(spl_child_order(lyt)) && match(bline, spl_child_order(lyt), nomatch = -1) == 1L) { |
1527 | 6x |
return(lyt) |
1528 |
} |
|
1529 | ||
1530 | 11x |
if (!is.null(split_fun(lyt))) { |
1531 |
## expensive but sadly necessary, I think |
|
1532 | 3x |
pinfo <- do_split(lyt, df, spl_context = context_df_row()) |
1533 | 3x |
vals <- sort(unlist(value_names(pinfo$values))) |
1534 |
} else { |
|
1535 | 8x |
vec <- df[[spl_payload(lyt)]] |
1536 | 8x |
vals <- if (is.factor(vec)) { |
1537 | 5x |
levels(vec) |
1538 |
} else { |
|
1539 | 3x |
unique(vec) |
1540 |
} |
|
1541 |
} |
|
1542 | 11x |
if (!bline %in% vals) { |
1543 | 1x |
stop(paste0( |
1544 | 1x |
'Reference group "', bline, '"', " was not present in the levels of ", spl_payload(lyt), " in the data." |
1545 |
)) |
|
1546 |
} |
|
1547 | 10x |
spl_child_order(lyt) <- vals |
1548 | 10x |
lyt |
1549 |
} |
|
1550 |
) |
|
1551 | ||
1552 |
splitvec_to_coltree <- function(df, splvec, pos = NULL, |
|
1553 |
lvl = 1L, label = "", |
|
1554 |
spl_context = context_df_row(cinfo = NULL)) { |
|
1555 | 1580x |
stopifnot( |
1556 | 1580x |
lvl <= length(splvec) + 1L, |
1557 | 1580x |
is(splvec, "SplitVector") |
1558 |
) |
|
1559 | ||
1560 | ||
1561 | 1580x |
if (lvl == length(splvec) + 1L) { |
1562 |
## XXX this should be a LayoutColree I Think. |
|
1563 | 1037x |
nm <- unlist(tail(value_names(pos), 1)) %||% "" |
1564 | 1037x |
LayoutColLeaf( |
1565 | 1037x |
lev = lvl - 1L, |
1566 | 1037x |
label = label, |
1567 | 1037x |
tpos = pos, |
1568 | 1037x |
name = nm |
1569 |
) |
|
1570 |
} else { |
|
1571 | 543x |
spl <- splvec[[lvl]] |
1572 | 543x |
nm <- if (is.null(pos)) { |
1573 | ! |
obj_name(spl) |
1574 |
} else { |
|
1575 | 543x |
unlist(tail( |
1576 | 543x |
value_names(pos), |
1577 | 543x |
1 |
1578 |
)) |
|
1579 |
} |
|
1580 | 543x |
rawpart <- do_split(spl, df, |
1581 | 543x |
trim = FALSE, |
1582 | 543x |
spl_context = spl_context |
1583 |
) |
|
1584 | 539x |
datparts <- rawpart[["datasplit"]] |
1585 | 539x |
vals <- rawpart[["values"]] |
1586 | 539x |
labs <- rawpart[["labels"]] |
1587 | ||
1588 | ||
1589 | 539x |
kids <- mapply( |
1590 | 539x |
function(dfpart, value, partlab) { |
1591 | 1227x |
newprev <- context_df_row( |
1592 | 1227x |
split = obj_name(spl), |
1593 | 1227x |
value = value_names(value), |
1594 | 1227x |
full_parent_df = list(dfpart), |
1595 | 1227x |
cinfo = NULL |
1596 |
) |
|
1597 | 1227x |
newpos <- make_child_pos(pos, spl, value, partlab) |
1598 | 1227x |
splitvec_to_coltree(dfpart, splvec, newpos, |
1599 | 1227x |
lvl + 1L, partlab, |
1600 | 1227x |
spl_context = rbind(spl_context, newprev) |
1601 |
) |
|
1602 |
}, |
|
1603 | 539x |
dfpart = datparts, value = vals, |
1604 | 539x |
partlab = labs, SIMPLIFY = FALSE |
1605 |
) |
|
1606 | 538x |
names(kids) <- value_names(vals) |
1607 | 538x |
LayoutColTree( |
1608 | 538x |
lev = lvl, label = label, |
1609 | 538x |
spl = spl, |
1610 | 538x |
kids = kids, tpos = pos, |
1611 | 538x |
name = nm, |
1612 | 538x |
summary_function = content_fun(spl) |
1613 |
) |
|
1614 |
} |
|
1615 |
} |
|
1616 | ||
1617 |
# fix_analyze_vis ---- |
|
1618 |
## now that we know for sure the number of siblings |
|
1619 |
## collaplse NAs to TRUE/FALSE for whether |
|
1620 |
## labelrows should be visible for ElementaryTables |
|
1621 |
## generatead from analyzing a single variable |
|
1622 | 976x |
setGeneric("fix_analyze_vis", function(lyt) standardGeneric("fix_analyze_vis")) |
1623 | ||
1624 |
setMethod( |
|
1625 |
"fix_analyze_vis", "PreDataTableLayouts", |
|
1626 |
function(lyt) { |
|
1627 | 317x |
rlayout(lyt) <- fix_analyze_vis(rlayout(lyt)) |
1628 | 317x |
lyt |
1629 |
} |
|
1630 |
) |
|
1631 | ||
1632 |
setMethod( |
|
1633 |
"fix_analyze_vis", "PreDataRowLayout", |
|
1634 |
function(lyt) { |
|
1635 | 317x |
splvecs <- lapply(lyt, fix_analyze_vis) |
1636 | 317x |
PreDataRowLayout( |
1637 | 317x |
root = root_spl(lyt), |
1638 | 317x |
lst = splvecs |
1639 |
) |
|
1640 |
} |
|
1641 |
) |
|
1642 | ||
1643 |
setMethod( |
|
1644 |
"fix_analyze_vis", "SplitVector", |
|
1645 |
function(lyt) { |
|
1646 | 342x |
len <- length(lyt) |
1647 | 342x |
if (len == 0) { |
1648 | 14x |
return(lyt) |
1649 |
} |
|
1650 | 328x |
lastspl <- lyt[[len]] |
1651 | 328x |
if (!(is(lastspl, "VAnalyzeSplit") || is(lastspl, "AnalyzeMultivar"))) { |
1652 | 62x |
return(lyt) |
1653 |
} |
|
1654 | ||
1655 | 266x |
if (is(lastspl, "VAnalyzeSplit") && is.na(labelrow_visible(lastspl))) { |
1656 |
## labelrow_visible(lastspl) = FALSE |
|
1657 | 260x |
labelrow_visible(lastspl) <- "hidden" |
1658 | 6x |
} else if (is(lastspl, "AnalyzeMultiVar")) { |
1659 | ! |
pld <- spl_payload(lastspl) |
1660 | ! |
newpld <- lapply(pld, function(sp, havesibs) { |
1661 | ! |
if (is.na(labelrow_visible(sp))) { |
1662 | ! |
labelrow_visible(sp) <- havesibs |
1663 |
} |
|
1664 | ! |
}, havesibs = len > 1) |
1665 | ! |
spl_payload(lastspl) <- newpld |
1666 |
## pretty sure this isn't needed... |
|
1667 | ! |
if (is.na(label_kids(lastspl))) { |
1668 | ! |
label_kids(lastspl) <- len > 1 |
1669 |
} |
|
1670 |
} |
|
1671 | 266x |
lyt[[len]] <- lastspl |
1672 | 266x |
lyt |
1673 |
} |
|
1674 |
) |
|
1675 | ||
1676 |
# check_afun_cfun_params ---- |
|
1677 | ||
1678 |
# This checks if the input params are used anywhere in cfun/afun |
|
1679 |
setGeneric("check_afun_cfun_params", function(lyt, params) { |
|
1680 | 3129x |
standardGeneric("check_afun_cfun_params") |
1681 |
}) |
|
1682 | ||
1683 |
setMethod( |
|
1684 |
"check_afun_cfun_params", "PreDataTableLayouts", |
|
1685 |
function(lyt, params) { |
|
1686 |
# clayout does not have analysis functions |
|
1687 | 308x |
check_afun_cfun_params(rlayout(lyt), params) |
1688 |
} |
|
1689 |
) |
|
1690 | ||
1691 |
setMethod( |
|
1692 |
"check_afun_cfun_params", "PreDataRowLayout", |
|
1693 |
function(lyt, params) { |
|
1694 | 308x |
ro_spl_parm_l <- check_afun_cfun_params(root_spl(lyt), params) |
1695 | 308x |
r_spl_parm_l <- lapply(lyt, check_afun_cfun_params, params = params) |
1696 | 308x |
Reduce(`|`, c(list(ro_spl_parm_l), r_spl_parm_l)) |
1697 |
} |
|
1698 |
) |
|
1699 | ||
1700 |
# Main function for checking parameters |
|
1701 |
setMethod( |
|
1702 |
"check_afun_cfun_params", "SplitVector", |
|
1703 |
function(lyt, params) { |
|
1704 | 753x |
param_l <- lapply(lyt, check_afun_cfun_params, params = params) |
1705 | 753x |
Reduce(`|`, param_l) |
1706 |
} |
|
1707 |
) |
|
1708 | ||
1709 |
# Helper function for check_afun_cfun_params |
|
1710 |
.afun_cfun_switch <- function(spl_i) { |
|
1711 | 1759x |
if (is(spl_i, "VAnalyzeSplit")) { |
1712 | 595x |
analysis_fun(spl_i) |
1713 |
} else { |
|
1714 | 1164x |
content_fun(spl_i) |
1715 |
} |
|
1716 |
} |
|
1717 | ||
1718 |
# Extreme case that happens only when using add_existing_table |
|
1719 |
setMethod( |
|
1720 |
"check_afun_cfun_params", "VTableTree", |
|
1721 |
function(lyt, params) { |
|
1722 | 1x |
setNames(logical(length(params)), params) # All FALSE |
1723 |
} |
|
1724 |
) |
|
1725 | ||
1726 |
setMethod( |
|
1727 |
"check_afun_cfun_params", "Split", |
|
1728 |
function(lyt, params) { |
|
1729 |
# Extract function in the split |
|
1730 | 1759x |
fnc <- .afun_cfun_switch(lyt) |
1731 | ||
1732 |
# For each parameter, check if it is called |
|
1733 | 1759x |
sapply(params, function(pai) any(unlist(func_takes(fnc, pai)))) |
1734 |
} |
|
1735 |
) |
|
1736 | ||
1737 |
# Helper functions ---- |
|
1738 | ||
1739 | 231x |
count <- function(df, ...) NROW(df) |
1740 | ||
1741 |
guess_format <- function(val) { |
|
1742 | 1054x |
if (length(val) == 1) { |
1743 | 1042x |
if (is.integer(val) || !is.numeric(val)) { |
1744 | 226x |
"xx" |
1745 |
} else { |
|
1746 | 816x |
"xx.xx" |
1747 |
} |
|
1748 | 12x |
} else if (length(val) == 2) { |
1749 | 12x |
"xx.x / xx.x" |
1750 | ! |
} else if (length(val) == 3) { |
1751 | ! |
"xx.x (xx.x - xx.x)" |
1752 |
} else { |
|
1753 | ! |
stop("got value of length > 3") |
1754 |
} |
|
1755 |
} |
|
1756 | ||
1757 |
.quick_afun <- function(afun, lbls) { |
|
1758 | 14x |
if (.takes_df(afun)) { |
1759 | 5x |
function(df, .spl_context, ...) { |
1760 | 226x |
if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) { |
1761 | 222x |
lbls <- tail(.spl_context$value, 1) |
1762 |
} |
|
1763 | 226x |
if (".spl_context" %in% names(formals(afun))) { |
1764 | ! |
res <- afun(df = df, .spl_context = .spl_context, ...) |
1765 |
} else { |
|
1766 | 226x |
res <- afun(df = df, ...) |
1767 |
} |
|
1768 | 226x |
if (is(res, "RowsVerticalSection")) { |
1769 | ! |
ret <- res |
1770 |
} else { |
|
1771 | 226x |
if (!is.list(res)) { |
1772 | 226x |
ret <- rcell(res, label = lbls, format = guess_format(res)) |
1773 |
} else { |
|
1774 | ! |
if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) { |
1775 | ! |
names(res) <- lbls |
1776 |
} |
|
1777 | ! |
ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, "")) |
1778 |
} |
|
1779 |
} |
|
1780 | 226x |
ret |
1781 |
} |
|
1782 |
} else { |
|
1783 | 9x |
function(x, .spl_context, ...) { |
1784 | 387x |
if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) { |
1785 | 225x |
lbls <- tail(.spl_context$value, 1) |
1786 |
} |
|
1787 | 387x |
if (".spl_context" %in% names(formals(afun))) { |
1788 | ! |
res <- afun(x = x, .spl_context = .spl_context, ...) |
1789 |
} else { |
|
1790 | 387x |
res <- afun(x = x, ...) |
1791 |
} |
|
1792 | 387x |
if (is(res, "RowsVerticalSection")) { |
1793 | ! |
ret <- res |
1794 |
} else { |
|
1795 | 387x |
if (!is.list(res)) { |
1796 | 297x |
ret <- rcell(res, label = lbls, format = guess_format(res)) |
1797 |
} else { |
|
1798 | 90x |
if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) { |
1799 | 9x |
names(res) <- lbls |
1800 |
} |
|
1801 | 90x |
ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, "")) |
1802 |
} |
|
1803 |
} |
|
1804 | 387x |
ret |
1805 |
} |
|
1806 |
} |
|
1807 |
} |
|
1808 | ||
1809 |
# qtable ---- |
|
1810 | ||
1811 |
n_cells_res <- function(res) { |
|
1812 | 8x |
ans <- 1L |
1813 | 8x |
if (is.list(res)) { |
1814 | 4x |
ans <- length(res) |
1815 | 4x |
} else if (is(res, "RowsVerticalSection")) { |
1816 | ! |
ans <- length(res$values) |
1817 |
} # XXX penetrating the abstraction |
|
1818 | 8x |
ans |
1819 |
} |
|
1820 | ||
1821 |
#' Generalized frequency table |
|
1822 |
#' |
|
1823 |
#' This function provides a convenience interface for generating generalizations of a 2-way frequency table. Row and |
|
1824 |
#' column space can be facetted by variables, and an analysis function can be specified. The function then builds a |
|
1825 |
#' layout with the specified layout and applies it to the data provided. |
|
1826 |
#' |
|
1827 |
#' @inheritParams constr_args |
|
1828 |
#' @inheritParams basic_table |
|
1829 |
#' @param row_vars (`character`)\cr the names of variables to be used in row facetting. |
|
1830 |
#' @param col_vars (`character`)\cr the names of variables to be used in column facetting. |
|
1831 |
#' @param data (`data.frame`)\cr the data to tabulate. |
|
1832 |
#' @param avar (`string`)\cr the variable to be analyzed. Defaults to the first variable in `data`. |
|
1833 |
#' @param row_labels (`character` or `NULL`)\cr row label(s) which should be applied to the analysis rows. Length must |
|
1834 |
#' match the number of rows generated by `afun`. |
|
1835 |
#' @param afun (`function`)\cr the function to generate the analysis row cell values. This can be a proper analysis |
|
1836 |
#' function, or a function which returns a vector or list. Vectors are taken as multi-valued single cells, whereas |
|
1837 |
#' lists are interpreted as multiple cells. |
|
1838 |
#' @param drop_levels (`flag`)\cr whether unobserved factor levels should be dropped during facetting. Defaults to |
|
1839 |
#' `TRUE`. |
|
1840 |
#' @param summarize_groups (`flag`)\cr whether each level of nesting should include marginal summary rows. Defaults to |
|
1841 |
#' `FALSE`. |
|
1842 |
#' @param ... additional arguments passed to `afun`. |
|
1843 |
#' @param .default_rlabel (`string`)\cr this is an implementation detail that should not be set by end users. |
|
1844 |
#' |
|
1845 |
#' @details |
|
1846 |
#' This function creates a table with a single top-level structure in both row and column dimensions involving faceting |
|
1847 |
#' by 0 or more variables in each dimension. |
|
1848 |
#' |
|
1849 |
#' The display of the table depends on certain details of the tabulation. In the case of an `afun` which returns a |
|
1850 |
#' single cell's contents (either a scalar or a vector of 2 or 3 elements), the label rows for the deepest-nested row |
|
1851 |
#' facets will be hidden and the labels used there will be used as the analysis row labels. In the case of an `afun` |
|
1852 |
#' which returns a list (corresponding to multiple cells), the names of the list will be used as the analysis row |
|
1853 |
#' labels and the deepest-nested facet row labels will be visible. |
|
1854 |
#' |
|
1855 |
#' The table will be annotated in the top-left area with an informative label displaying the analysis variable |
|
1856 |
#' (`avar`), if set, and the function used (captured via substitute) where possible, or 'count' if not. One exception |
|
1857 |
#' where the user may directly modify the top-left area (via `row_labels`) is the case of a table with row facets and |
|
1858 |
#' an `afun` which returns a single row. |
|
1859 |
#' |
|
1860 |
#' @return |
|
1861 |
#' * `qtable` returns a built `TableTree` object representing the desired table |
|
1862 |
#' * `qtable_layout` returns a `PreDataTableLayouts` object declaring the structure of the desired table, suitable for |
|
1863 |
#' passing to [build_table()]. |
|
1864 |
#' |
|
1865 |
#' @examples |
|
1866 |
#' qtable(ex_adsl) |
|
1867 |
#' qtable(ex_adsl, row_vars = "ARM") |
|
1868 |
#' qtable(ex_adsl, col_vars = "ARM") |
|
1869 |
#' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM") |
|
1870 |
#' qtable(ex_adsl, row_vars = c("COUNTRY", "SEX"), col_vars = c("ARM", "STRATA1")) |
|
1871 |
#' qtable(ex_adsl, |
|
1872 |
#' row_vars = c("COUNTRY", "SEX"), |
|
1873 |
#' col_vars = c("ARM", "STRATA1"), avar = "AGE", afun = mean |
|
1874 |
#' ) |
|
1875 |
#' summary_list <- function(x, ...) as.list(summary(x)) |
|
1876 |
#' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM", avar = "AGE", afun = summary_list) |
|
1877 |
#' suppressWarnings(qtable(ex_adsl, |
|
1878 |
#' row_vars = "SEX", |
|
1879 |
#' col_vars = "ARM", avar = "AGE", afun = range |
|
1880 |
#' )) |
|
1881 |
#' |
|
1882 |
#' @export |
|
1883 |
qtable_layout <- function(data, |
|
1884 |
row_vars = character(), |
|
1885 |
col_vars = character(), |
|
1886 |
avar = NULL, |
|
1887 |
row_labels = NULL, |
|
1888 |
afun = NULL, |
|
1889 |
summarize_groups = FALSE, |
|
1890 |
title = "", |
|
1891 |
subtitles = character(), |
|
1892 |
main_footer = character(), |
|
1893 |
prov_footer = character(), |
|
1894 |
show_colcounts = TRUE, |
|
1895 |
drop_levels = TRUE, |
|
1896 |
..., |
|
1897 |
.default_rlabel = NULL) { |
|
1898 | 16x |
subafun <- substitute(afun) |
1899 | 16x |
if (!is.null(.default_rlabel)) { |
1900 | 16x |
dflt_row_lbl <- .default_rlabel |
1901 |
} else if ( |
|
1902 | ! |
is.name(subafun) && |
1903 | ! |
is.function(afun) && |
1904 |
## this is gross. basically testing |
|
1905 |
## if the symbol we have corresponds |
|
1906 |
## in some meaningful way to the function |
|
1907 |
## we will be calling. |
|
1908 | ! |
identical( |
1909 | ! |
mget( |
1910 | ! |
as.character(subafun), |
1911 | ! |
mode = "function", |
1912 | ! |
envir = parent.frame(1), |
1913 | ! |
ifnotfound = list(NULL), |
1914 | ! |
inherits = TRUE |
1915 | ! |
)[[1]], |
1916 | ! |
afun |
1917 |
) |
|
1918 |
) { |
|
1919 | ! |
dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ") |
1920 |
} else { |
|
1921 | ! |
dflt_row_lbl <- if (is.null(avar)) "count" else avar |
1922 |
} |
|
1923 | ||
1924 | 16x |
if (is.null(afun)) { |
1925 | 5x |
afun <- count |
1926 |
} |
|
1927 | ||
1928 | 16x |
if (is.null(avar)) { |
1929 | 5x |
avar <- names(data)[1] |
1930 |
} |
|
1931 | 16x |
fakeres <- afun(data[[avar]], ...) |
1932 | 16x |
multirow <- is.list(fakeres) || is(fakeres, "RowsVerticalSection") || summarize_groups |
1933 |
## this is before we plug in the default so if not specified by the user |
|
1934 |
## explicitly, row_labels is NULL at this point. |
|
1935 | 16x |
if (!is.null(row_labels) && length(row_labels) != n_cells_res(fakeres)) { |
1936 | 2x |
stop( |
1937 | 2x |
"Length of row_labels (", |
1938 | 2x |
length(row_labels), |
1939 | 2x |
") does not agree with number of rows generated by analysis function (", |
1940 | 2x |
n_cells_res(fakeres), |
1941 |
")." |
|
1942 |
) |
|
1943 |
} |
|
1944 | ||
1945 | 14x |
if (is.null(row_labels)) { |
1946 | 10x |
row_labels <- dflt_row_lbl |
1947 |
} |
|
1948 | ||
1949 | 14x |
lyt <- basic_table( |
1950 | 14x |
title = title, |
1951 | 14x |
subtitles = subtitles, |
1952 | 14x |
main_footer = main_footer, |
1953 | 14x |
prov_footer = prov_footer, |
1954 | 14x |
show_colcounts = show_colcounts |
1955 |
) |
|
1956 | ||
1957 | 14x |
for (var in col_vars) lyt <- split_cols_by(lyt, var) |
1958 | ||
1959 | 14x |
for (var in head(row_vars, -1)) { |
1960 | 4x |
lyt <- split_rows_by(lyt, var, split_fun = if (drop_levels) drop_split_levels else NULL) |
1961 | 4x |
if (summarize_groups) { |
1962 | 2x |
lyt <- summarize_row_groups(lyt) |
1963 |
} |
|
1964 |
} |
|
1965 | ||
1966 | 14x |
tleft <- if (multirow || length(row_vars) > 0) dflt_row_lbl else character() |
1967 | 14x |
if (length(row_vars) > 0) { |
1968 | 10x |
if (!multirow) { |
1969 |
## in the single row in splitting case, we use the row label as the topleft |
|
1970 |
## and the split values as the row labels for a more compact apeparance |
|
1971 | 6x |
tleft <- row_labels |
1972 | 6x |
row_labels <- NA_character_ |
1973 | 6x |
lyt <- split_rows_by( |
1974 | 6x |
lyt, tail(row_vars, 1), |
1975 | 6x |
split_fun = if (drop_levels) drop_split_levels else NULL, child_labels = "hidden" |
1976 |
) |
|
1977 |
} else { |
|
1978 | 4x |
lyt <- split_rows_by(lyt, tail(row_vars, 1), split_fun = if (drop_levels) drop_split_levels else NULL) |
1979 |
} |
|
1980 | 10x |
if (summarize_groups) { |
1981 | 2x |
lyt <- summarize_row_groups(lyt) |
1982 |
} |
|
1983 |
} |
|
1984 | 14x |
inner_afun <- .quick_afun(afun, row_labels) |
1985 | 14x |
lyt <- analyze(lyt, avar, afun = inner_afun, extra_args = list(...)) |
1986 | 14x |
lyt <- append_topleft(lyt, tleft) |
1987 |
} |
|
1988 | ||
1989 |
#' @rdname qtable_layout |
|
1990 |
#' @export |
|
1991 |
qtable <- function(data, |
|
1992 |
row_vars = character(), |
|
1993 |
col_vars = character(), |
|
1994 |
avar = NULL, |
|
1995 |
row_labels = NULL, |
|
1996 |
afun = NULL, |
|
1997 |
summarize_groups = FALSE, |
|
1998 |
title = "", |
|
1999 |
subtitles = character(), |
|
2000 |
main_footer = character(), |
|
2001 |
prov_footer = character(), |
|
2002 |
show_colcounts = TRUE, |
|
2003 |
drop_levels = TRUE, |
|
2004 |
...) { |
|
2005 |
## this involves substitution so it needs to appear in both functions. Gross but true. |
|
2006 | 16x |
subafun <- substitute(afun) |
2007 |
if ( |
|
2008 | 16x |
is.name(subafun) && is.function(afun) && |
2009 |
## this is gross. basically testing |
|
2010 |
## if the symbol we have corresponds |
|
2011 |
## in some meaningful way to the function |
|
2012 |
## we will be calling. |
|
2013 | 16x |
identical( |
2014 | 16x |
mget( |
2015 | 16x |
as.character(subafun), |
2016 | 16x |
mode = "function", envir = parent.frame(1), ifnotfound = list(NULL), inherits = TRUE |
2017 | 16x |
)[[1]], |
2018 | 16x |
afun |
2019 |
) |
|
2020 |
) { |
|
2021 | 11x |
dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ") |
2022 |
} else { |
|
2023 | 5x |
dflt_row_lbl <- if (is.null(avar)) "count" else avar |
2024 |
} |
|
2025 | ||
2026 | 16x |
lyt <- qtable_layout( |
2027 | 16x |
data = data, |
2028 | 16x |
row_vars = row_vars, |
2029 | 16x |
col_vars = col_vars, |
2030 | 16x |
avar = avar, |
2031 | 16x |
row_labels = row_labels, |
2032 | 16x |
afun = afun, |
2033 | 16x |
summarize_groups = summarize_groups, |
2034 | 16x |
title = title, |
2035 | 16x |
subtitles = subtitles, |
2036 | 16x |
main_footer = main_footer, |
2037 | 16x |
prov_footer = prov_footer, |
2038 | 16x |
show_colcounts = show_colcounts, |
2039 | 16x |
drop_levels = drop_levels, |
2040 |
..., |
|
2041 | 16x |
.default_rlabel = dflt_row_lbl |
2042 |
) |
|
2043 | 14x |
build_table(lyt, data) |
2044 |
} |
1 |
#' Create an `rtable` row |
|
2 |
#' |
|
3 |
#' @inheritParams compat_args |
|
4 |
#' @param ... cell values. |
|
5 |
#' |
|
6 |
#' @return A row object of the context-appropriate type (label or data). |
|
7 |
#' |
|
8 |
#' @examples |
|
9 |
#' rrow("ABC", c(1, 2), c(3, 2), format = "xx (xx.%)") |
|
10 |
#' rrow("") |
|
11 |
#' |
|
12 |
#' @family compatibility |
|
13 |
#' @export |
|
14 |
rrow <- function(row.name = "", ..., format = NULL, indent = 0, inset = 0L) { |
|
15 | 258x |
vals <- list(...) |
16 | 258x |
if (is.null(row.name)) { |
17 | 40x |
row.name <- "" |
18 | 218x |
} else if (!is(row.name, "character")) { |
19 | ! |
stop("row.name must be NULL or a character string") |
20 |
} |
|
21 | 258x |
if (length(vals) == 0L) { |
22 | 22x |
LabelRow( |
23 | 22x |
lev = as.integer(indent), |
24 | 22x |
label = row.name, |
25 | 22x |
name = row.name, |
26 | 22x |
vis = TRUE, |
27 | 22x |
table_inset = 0L |
28 |
) |
|
29 |
} else { |
|
30 | 236x |
csps <- as.integer(sapply(vals, function(x) { |
31 | 1391x |
attr(x, "colspan", exact = TRUE) %||% 1L |
32 |
})) |
|
33 |
## we have to leave the formats on the cells and NOT the row unless we were |
|
34 |
## already told to do so, because row formats get clobbered when cbinding |
|
35 |
## but cell formats do not. |
|
36 |
## formats = sapply(vals, obj_format) |
|
37 |
## if(is.character(formats) && length(unique(formats)) == 1L && is.null(format)) |
|
38 |
## format = unique(formats) |
|
39 | 236x |
DataRow( |
40 | 236x |
vals = vals, lev = as.integer(indent), label = row.name, |
41 | 236x |
name = row.name, ## XXX TODO |
42 | 236x |
cspan = csps, |
43 | 236x |
format = format, |
44 | 236x |
table_inset = as.integer(inset) |
45 |
) |
|
46 |
} |
|
47 |
} |
|
48 | ||
49 |
#' Create an `rtable` row from a vector or list of values |
|
50 |
#' |
|
51 |
#' @inheritParams compat_args |
|
52 |
#' @param ... values in vector/list form. |
|
53 |
#' |
|
54 |
#' @inherit rrow return |
|
55 |
#' |
|
56 |
#' @examples |
|
57 |
#' rrowl("a", c(1, 2, 3), format = "xx") |
|
58 |
#' rrowl("a", c(1, 2, 3), c(4, 5, 6), format = "xx") |
|
59 |
#' |
|
60 |
#' |
|
61 |
#' rrowl("N", table(iris$Species)) |
|
62 |
#' rrowl("N", table(iris$Species), format = "xx") |
|
63 |
#' |
|
64 |
#' x <- tapply(iris$Sepal.Length, iris$Species, mean, simplify = FALSE) |
|
65 |
#' |
|
66 |
#' rrow(row.name = "row 1", x) |
|
67 |
#' rrow("ABC", 2, 3) |
|
68 |
#' |
|
69 |
#' rrowl(row.name = "row 1", c(1, 2), c(3, 4)) |
|
70 |
#' rrow(row.name = "row 2", c(1, 2), c(3, 4)) |
|
71 |
#' |
|
72 |
#' @family compatibility |
|
73 |
#' @export |
|
74 |
rrowl <- function(row.name, ..., format = NULL, indent = 0, inset = 0L) { |
|
75 | 38x |
dots <- list(...) |
76 | 38x |
args_list <- c(list( |
77 | 38x |
row.name = row.name, format = format, |
78 | 38x |
indent = indent, inset = inset |
79 | 38x |
), val = unlist(lapply(dots, as.list), recursive = FALSE)) |
80 | 38x |
do.call(rrow, args_list) |
81 |
} |
|
82 | ||
83 |
## rcell moved to tt_afun_utils.R |
|
84 | ||
85 |
## inefficient trash |
|
86 |
paste_em_n <- function(lst, n, sep = ".") { |
|
87 | 9x |
ret <- lst[[1]] |
88 | 9x |
if (n > 1) { |
89 | 4x |
for (i in 2:n) { |
90 | 4x |
ret <- paste(ret, lst[[i]], sep = sep) |
91 |
} |
|
92 |
} |
|
93 | 9x |
ret |
94 |
} |
|
95 | ||
96 |
hrows_to_colinfo <- function(rows) { |
|
97 | 34x |
nr <- length(rows) |
98 | 34x |
stopifnot(nr > 0) |
99 | 34x |
cspans <- lapply(rows, row_cspans) |
100 | 34x |
vals <- lapply(rows, function(x) unlist(row_values(x))) |
101 | 34x |
unqvals <- lapply(vals, unique) |
102 | 34x |
formats <- lapply(rows, obj_format) |
103 | 34x |
counts <- NULL |
104 | 34x |
if (formats[nr] == "(N=xx)" || all(sapply(row_cells(rows[[nr]]), obj_format) == "(N=xx)")) { ## count row |
105 | 1x |
counts <- vals[[nr]] |
106 | 1x |
vals <- vals[-nr] |
107 | 1x |
cspans <- cspans[-nr] |
108 | 1x |
nr <- nr - 1 |
109 |
} |
|
110 |
## easiest case, one header row no counts. we're done |
|
111 |
## XXX could one row but cspan ever make sense???? |
|
112 |
## I don't think so? |
|
113 | 34x |
if (nr == 1) { ## && all(cspans == 1L)) { |
114 | 29x |
ret <- manual_cols(unlist(vals[[1]])) |
115 | 29x |
if (!is.null(counts)) { |
116 | 1x |
col_counts(ret) <- counts |
117 | 1x |
disp_ccounts(ret) <- TRUE |
118 |
} |
|
119 | 29x |
return(ret) |
120 |
} |
|
121 |
## second easiest case full repeated nestin |
|
122 | 5x |
repvals <- mapply(function(v, csp) rep(v, times = csp), |
123 | 5x |
v = vals, csp = cspans, SIMPLIFY = FALSE |
124 |
) |
|
125 | ||
126 |
## nr > 1 here |
|
127 | 5x |
fullnest <- TRUE |
128 | 5x |
for (i in 2:nr) { |
129 | 5x |
psted <- paste_em_n(repvals, i - 1) |
130 | 5x |
spl <- split(repvals[[i]], psted) |
131 | 5x |
if (!all(sapply(spl, function(x) identical(x, spl[[1]])))) { |
132 | 4x |
fullnest <- FALSE |
133 | 4x |
break |
134 |
} |
|
135 |
} |
|
136 | ||
137 |
## if its full nesting we're done, so put |
|
138 |
## the counts on as necessary and return. |
|
139 | 5x |
if (fullnest) { |
140 | 1x |
ret <- manual_cols(.lst = unqvals) |
141 | 1x |
if (!is.null(counts)) { |
142 | ! |
col_counts(ret) <- counts |
143 | ! |
disp_ccounts(ret) <- TRUE |
144 |
} |
|
145 | 1x |
return(ret) |
146 |
} |
|
147 | ||
148 |
## booo. the fully complex case where the multiple rows |
|
149 |
## really don't represent nesting at all, each top level |
|
150 |
## can have different sub labels |
|
151 | ||
152 |
## we will build it up as if it were full nesting and then prune |
|
153 |
## based on the columns we actually want. |
|
154 | ||
155 | 4x |
fullcolinfo <- manual_cols(.lst = unqvals) |
156 | 4x |
fullbusiness <- names(collect_leaves(coltree(fullcolinfo))) |
157 | 4x |
wanted <- paste_em_n(repvals, nr) |
158 | 4x |
wantcols <- match(wanted, fullbusiness) |
159 | 4x |
stopifnot(all(!is.na(wantcols))) |
160 | ||
161 | 4x |
subset_cols(fullcolinfo, wantcols) |
162 |
} |
|
163 | ||
164 |
#' Create a header |
|
165 |
#' |
|
166 |
#' @inheritParams compat_args |
|
167 |
#' @param ... row specifications, either as character vectors or the output from [rrow()], [DataRow()], |
|
168 |
#' [LabelRow()], etc. |
|
169 |
#' |
|
170 |
#' @return A `InstantiatedColumnInfo` object. |
|
171 |
#' |
|
172 |
#' @examples |
|
173 |
#' h1 <- rheader(c("A", "B", "C")) |
|
174 |
#' h1 |
|
175 |
#' |
|
176 |
#' h2 <- rheader( |
|
177 |
#' rrow(NULL, rcell("group 1", colspan = 2), rcell("group 2", colspan = 2)), |
|
178 |
#' rrow(NULL, "A", "B", "A", "B") |
|
179 |
#' ) |
|
180 |
#' h2 |
|
181 |
#' |
|
182 |
#' @family compatibility |
|
183 |
#' @export |
|
184 |
rheader <- function(..., format = "xx", .lst = NULL) { |
|
185 | 3x |
if (!is.null(.lst)) { |
186 | ! |
args <- .lst |
187 |
} else { |
|
188 | 3x |
args <- list(...) |
189 |
} |
|
190 | 3x |
rrows <- if (length(args) == 1 && !is(args[[1]], "TableRow")) { |
191 | ! |
list(rrowl(row.name = NULL, val = args[[1]], format = format)) |
192 | 3x |
} else if (are(args, "TableRow")) { |
193 | 3x |
args |
194 |
} |
|
195 | ||
196 | 3x |
hrows_to_colinfo(rrows) |
197 |
} |
|
198 | ||
199 |
.char_to_hrows <- function(hdr) { |
|
200 | 31x |
nlfnd <- grep("\n", hdr, fixed = TRUE) |
201 | 31x |
if (length(nlfnd) == 0) { |
202 | 27x |
return(list(rrowl(NULL, hdr))) |
203 |
} |
|
204 | ||
205 | 4x |
stopifnot(length(nlfnd) == length(hdr)) |
206 | 4x |
raw <- strsplit(hdr, "\n", fixed = TRUE) |
207 | 4x |
lens <- unique(sapply(raw, length)) |
208 | 4x |
stopifnot(length(lens) == 1L) |
209 | 4x |
lapply( |
210 | 4x |
seq(1, lens), |
211 | 4x |
function(i) { |
212 | 8x |
rrowl(NULL, vapply(raw, `[`, NA_character_, i = i)) |
213 |
} |
|
214 |
) |
|
215 |
} |
|
216 | ||
217 |
#' Create a table |
|
218 |
#' |
|
219 |
#' @inheritParams compat_args |
|
220 |
#' @inheritParams gen_args |
|
221 |
#' @param header (`TableRow`, `character`, or `InstantiatedColumnInfo`)\cr information defining the header |
|
222 |
#' (column structure) of the table. This can be as row objects (legacy), character vectors, or an |
|
223 |
#' `InstantiatedColumnInfo` object. |
|
224 |
#' @param ... rows to place in the table. |
|
225 |
#' |
|
226 |
#' @return A formal table object of the appropriate type (`ElementaryTable` or `TableTree`). |
|
227 |
#' |
|
228 |
#' @examples |
|
229 |
#' rtable( |
|
230 |
#' header = LETTERS[1:3], |
|
231 |
#' rrow("one to three", 1, 2, 3), |
|
232 |
#' rrow("more stuff", rcell(pi, format = "xx.xx"), "test", "and more") |
|
233 |
#' ) |
|
234 |
#' |
|
235 |
#' # Table with multirow header |
|
236 |
#' |
|
237 |
#' sel <- iris$Species == "setosa" |
|
238 |
#' mtbl <- rtable( |
|
239 |
#' header = rheader( |
|
240 |
#' rrow( |
|
241 |
#' row.name = NULL, rcell("Sepal.Length", colspan = 2), |
|
242 |
#' rcell("Petal.Length", colspan = 2) |
|
243 |
#' ), |
|
244 |
#' rrow(NULL, "mean", "median", "mean", "median") |
|
245 |
#' ), |
|
246 |
#' rrow( |
|
247 |
#' row.name = "All Species", |
|
248 |
#' mean(iris$Sepal.Length), median(iris$Sepal.Length), |
|
249 |
#' mean(iris$Petal.Length), median(iris$Petal.Length), |
|
250 |
#' format = "xx.xx" |
|
251 |
#' ), |
|
252 |
#' rrow( |
|
253 |
#' row.name = "Setosa", |
|
254 |
#' mean(iris$Sepal.Length[sel]), median(iris$Sepal.Length[sel]), |
|
255 |
#' mean(iris$Petal.Length[sel]), median(iris$Petal.Length[sel]) |
|
256 |
#' ) |
|
257 |
#' ) |
|
258 |
#' |
|
259 |
#' mtbl |
|
260 |
#' |
|
261 |
#' names(mtbl) # always first row of header |
|
262 |
#' |
|
263 |
#' # Single row header |
|
264 |
#' |
|
265 |
#' tbl <- rtable( |
|
266 |
#' header = c("Treatement\nN=100", "Comparison\nN=300"), |
|
267 |
#' format = "xx (xx.xx%)", |
|
268 |
#' rrow("A", c(104, .2), c(100, .4)), |
|
269 |
#' rrow("B", c(23, .4), c(43, .5)), |
|
270 |
#' rrow(""), |
|
271 |
#' rrow("this is a very long section header"), |
|
272 |
#' rrow("estimate", rcell(55.23, "xx.xx", colspan = 2)), |
|
273 |
#' rrow("95% CI", indent = 1, rcell(c(44.8, 67.4), format = "(xx.x, xx.x)", colspan = 2)) |
|
274 |
#' ) |
|
275 |
#' tbl |
|
276 |
#' |
|
277 |
#' row.names(tbl) |
|
278 |
#' names(tbl) |
|
279 |
#' |
|
280 |
#' # Subsetting |
|
281 |
#' |
|
282 |
#' tbl[1, ] |
|
283 |
#' tbl[, 1] |
|
284 |
#' |
|
285 |
#' tbl[1, 2] |
|
286 |
#' tbl[2, 1] |
|
287 |
#' |
|
288 |
#' tbl[3, 2] |
|
289 |
#' tbl[5, 1] |
|
290 |
#' tbl[5, 2] |
|
291 |
#' |
|
292 |
#' # Data Structure methods |
|
293 |
#' |
|
294 |
#' dim(tbl) |
|
295 |
#' nrow(tbl) |
|
296 |
#' ncol(tbl) |
|
297 |
#' names(tbl) |
|
298 |
#' |
|
299 |
#' # Colspans |
|
300 |
#' |
|
301 |
#' tbl2 <- rtable( |
|
302 |
#' c("A", "B", "C", "D", "E"), |
|
303 |
#' format = "xx", |
|
304 |
#' rrow("r1", 1, 2, 3, 4, 5), |
|
305 |
#' rrow("r2", rcell("sp2", colspan = 2), "sp1", rcell("sp2-2", colspan = 2)) |
|
306 |
#' ) |
|
307 |
#' tbl2 |
|
308 |
#' |
|
309 |
#' @family compatibility |
|
310 |
#' @export |
|
311 |
rtable <- function(header, ..., format = NULL, hsep = default_hsep(), |
|
312 |
inset = 0L) { |
|
313 | 34x |
if (is.character(header)) { |
314 | 31x |
header <- .char_to_hrows(header) |
315 |
} # list(rrowl(NULL, header)) |
|
316 | 34x |
if (is.list(header)) { |
317 | 31x |
if (are(header, "TableRow")) { |
318 | 31x |
colinfo <- hrows_to_colinfo(header) |
319 | ! |
} else if (are(header, "list")) { |
320 | ! |
colinfo <- do.call(rheader, header) |
321 |
} |
|
322 | 3x |
} else if (is(header, "InstantiatedColumnInfo")) { |
323 | 3x |
colinfo <- header |
324 | ! |
} else if (is(header, "TableRow")) { |
325 | ! |
colinfo <- hrows_to_colinfo(list(header)) |
326 |
} else { |
|
327 | ! |
stop("problems") |
328 |
} |
|
329 | ||
330 | 34x |
body <- list(...) |
331 |
## XXX this shouldn't be needed. hacky |
|
332 | 34x |
if (length(body) == 1 && is.list(body[[1]])) { |
333 | ! |
body <- body[[1]] |
334 |
} |
|
335 | 34x |
if (are(body, "ElementaryTable") && |
336 | 34x |
all(sapply(body, function(tb) { |
337 | ! |
nrow(tb) == 1 && obj_name(tb) == "" |
338 |
}))) { |
|
339 | 1x |
body <- lapply(body, function(tb) tree_children(tb)[[1]]) |
340 |
} |
|
341 | ||
342 | 34x |
TableTree( |
343 | 34x |
kids = body, format = format, cinfo = colinfo, |
344 | 34x |
labelrow = LabelRow(lev = 0L, label = "", vis = FALSE), |
345 | 34x |
hsep = hsep, inset = inset |
346 |
) |
|
347 |
} |
|
348 | ||
349 |
#' @rdname rtable |
|
350 |
#' @export |
|
351 |
rtablel <- function(header, ..., format = NULL, hsep = default_hsep(), inset = 0L) { |
|
352 | 1x |
dots <- list(...) |
353 | 1x |
args_list <- c(list(header = header, format = format, hsep = hsep, inset = inset), unlist(lapply( |
354 | 1x |
dots, |
355 | 1x |
as.list |
356 | 1x |
), recursive = FALSE)) |
357 | 1x |
do.call(rtable, args_list) |
358 |
} |
|
359 | ||
360 |
# All object annotations are identical (and exist) |
|
361 |
all_annots_identical <- function(all_annots) { |
|
362 | 60x |
if (!is.list(all_annots)) { |
363 | 15x |
all_annots[1] != "" && length(unique(all_annots)) == 1 |
364 |
} else { |
|
365 | 45x |
length(all_annots[[1]]) > 0 && Reduce(identical, all_annots) |
366 |
} |
|
367 |
} |
|
368 | ||
369 |
# Only first object has annotations |
|
370 |
only_first_annot <- function(all_annots) { |
|
371 | 56x |
if (!is.list(all_annots)) { |
372 | 14x |
all_annots[1] != "" && all(all_annots[-1] == "") |
373 |
} else { |
|
374 | 42x |
length(all_annots[[1]]) > 0 && all(sapply(all_annots, length)[-1] == 0) |
375 |
} |
|
376 |
} |
|
377 | ||
378 |
#' @param gap `r lifecycle::badge("deprecated")` ignored. |
|
379 |
#' @param check_headers `r lifecycle::badge("deprecated")` ignored. |
|
380 |
#' |
|
381 |
#' @return A formal table object. |
|
382 |
#' |
|
383 |
#' @rdname rbind |
|
384 |
#' @aliases rbind |
|
385 |
#' @export |
|
386 |
rbindl_rtables <- function(x, gap = 0, check_headers = TRUE) { |
|
387 | 16x |
if (!check_headers) { |
388 | ! |
warning("check_headers = FALSE is no longer supported, ignoring.") |
389 |
} |
|
390 | ||
391 | 16x |
firstcols <- col_info(x[[1]]) |
392 | 16x |
i <- 1 |
393 | 16x |
while (no_colinfo(firstcols) && i <= length(x)) { |
394 | 2x |
firstcols <- col_info(x[[i]]) |
395 | 2x |
i <- i + 1 |
396 |
} |
|
397 | ||
398 | 16x |
lapply(x, function(xi) chk_compat_cinfos(x[[1]], xi)) ## col_info(xi))) |
399 | ||
400 | 15x |
rbind_annot <- list( |
401 | 15x |
main_title = "", |
402 | 15x |
subtitles = character(), |
403 | 15x |
main_footer = character(), |
404 | 15x |
prov_footer = character() |
405 |
) |
|
406 | ||
407 |
# Titles/footer info are (independently) retained from first object if |
|
408 |
# identical or missing in all other objects |
|
409 | 15x |
all_titles <- sapply(x, main_title) |
410 | 15x |
if (all_annots_identical(all_titles) || only_first_annot(all_titles)) { |
411 | 2x |
rbind_annot[["main_title"]] <- all_titles[[1]] |
412 |
} |
|
413 | ||
414 | 15x |
all_sts <- lapply(x, subtitles) |
415 | 15x |
if (all_annots_identical(all_sts) || only_first_annot(all_sts)) { |
416 | 2x |
rbind_annot[["subtitles"]] <- all_sts[[1]] |
417 |
} |
|
418 | ||
419 | 15x |
all_ftrs <- lapply(x, main_footer) |
420 | 15x |
if (all_annots_identical(all_ftrs) || only_first_annot(all_ftrs)) { |
421 | 2x |
rbind_annot[["main_footer"]] <- all_ftrs[[1]] |
422 |
} |
|
423 | ||
424 | 15x |
all_pfs <- lapply(x, prov_footer) |
425 | 15x |
if (all_annots_identical(all_pfs) || only_first_annot(all_pfs)) { |
426 | 2x |
rbind_annot[["prov_footer"]] <- all_pfs[[1]] |
427 |
} |
|
428 | ||
429 |
## if we got only ElementaryTable and |
|
430 |
## TableRow objects, construct a new |
|
431 |
## elementary table with all the rows |
|
432 |
## instead of adding nesting. |
|
433 | ||
434 |
## we used to check for xi not being a lable row, why?? XXX |
|
435 | 15x |
if (all(sapply(x, function(xi) { |
436 | 30x |
(is(xi, "ElementaryTable") && !labelrow_visible(xi)) || |
437 | 30x |
is(xi, "TableRow") |
438 | 15x |
}))) { ## && !is(xi, "LabelRow")}))) { |
439 | 8x |
x <- unlist(lapply(x, function(xi) { |
440 | 16x |
if (is(xi, "TableRow")) { |
441 | 4x |
xi |
442 |
} else { |
|
443 | 12x |
lst <- tree_children(xi) |
444 | 12x |
lapply(lst, indent, |
445 | 12x |
by = indent_mod(xi) |
446 |
) |
|
447 |
} |
|
448 |
})) |
|
449 |
} |
|
450 | ||
451 | 15x |
TableTree( |
452 | 15x |
kids = x, |
453 | 15x |
cinfo = firstcols, |
454 | 15x |
name = "rbind_root", |
455 | 15x |
label = "", |
456 | 15x |
title = rbind_annot[["main_title"]], |
457 | 15x |
subtitles = rbind_annot[["subtitles"]], |
458 | 15x |
main_footer = rbind_annot[["main_footer"]], |
459 | 15x |
prov_footer = rbind_annot[["prov_footer"]] |
460 |
) |
|
461 |
} |
|
462 | ||
463 |
#' Row-bind `TableTree` and related objects |
|
464 |
#' |
|
465 |
#' @param deparse.level (`numeric(1)`)\cr currently ignored. |
|
466 |
#' @param ... (`ANY`)\cr elements to be stacked. |
|
467 |
#' |
|
468 |
#' @note |
|
469 |
#' When objects are row-bound, titles and footer information is retained from the first object (if any exists) if all |
|
470 |
#' other objects have no titles/footers or have identical titles/footers. Otherwise, all titles/footers are removed |
|
471 |
#' and must be set for the bound table via the [main_title()], [subtitles()], [main_footer()], and [prov_footer()] |
|
472 |
#' functions. |
|
473 |
#' |
|
474 |
#' @examples |
|
475 |
#' mtbl <- rtable( |
|
476 |
#' header = rheader( |
|
477 |
#' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)), |
|
478 |
#' rrow(NULL, "mean", "median", "mean", "median") |
|
479 |
#' ), |
|
480 |
#' rrow( |
|
481 |
#' row.name = "All Species", |
|
482 |
#' mean(iris$Sepal.Length), median(iris$Sepal.Length), |
|
483 |
#' mean(iris$Petal.Length), median(iris$Petal.Length), |
|
484 |
#' format = "xx.xx" |
|
485 |
#' ) |
|
486 |
#' ) |
|
487 |
#' |
|
488 |
#' mtbl2 <- with(subset(iris, Species == "setosa"), rtable( |
|
489 |
#' header = rheader( |
|
490 |
#' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)), |
|
491 |
#' rrow(NULL, "mean", "median", "mean", "median") |
|
492 |
#' ), |
|
493 |
#' rrow( |
|
494 |
#' row.name = "Setosa", |
|
495 |
#' mean(Sepal.Length), median(Sepal.Length), |
|
496 |
#' mean(Petal.Length), median(Petal.Length), |
|
497 |
#' format = "xx.xx" |
|
498 |
#' ) |
|
499 |
#' )) |
|
500 |
#' |
|
501 |
#' rbind(mtbl, mtbl2) |
|
502 |
#' rbind(mtbl, rrow(), mtbl2) |
|
503 |
#' rbind(mtbl, rrow("aaa"), indent(mtbl2)) |
|
504 |
#' |
|
505 |
#' @exportMethod rbind |
|
506 |
#' @rdname rbind |
|
507 |
setMethod( |
|
508 |
"rbind", "VTableNodeInfo", |
|
509 |
function(..., deparse.level = 1) { |
|
510 | ! |
rbindl_rtables(list(...), check_headers = TRUE) |
511 |
} |
|
512 |
) |
|
513 | ||
514 |
#' @param y (`ANY`)\cr second element to be row-bound via `rbind2`. |
|
515 |
#' |
|
516 |
#' @exportMethod rbind2 |
|
517 |
#' @rdname int_methods |
|
518 |
setMethod( |
|
519 |
"rbind2", c("VTableNodeInfo", "missing"), |
|
520 |
function(x, y) { |
|
521 | 2x |
TableTree(kids = list(x), cinfo = col_info(x), name = "rbind_root", label = "") |
522 |
} |
|
523 |
) |
|
524 | ||
525 |
#' @param x (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object. |
|
526 |
#' @param y (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object. |
|
527 |
#' |
|
528 |
#' @exportMethod rbind2 |
|
529 |
#' @rdname rbind |
|
530 |
setMethod( |
|
531 |
"rbind2", "VTableNodeInfo", |
|
532 |
function(x, y) { |
|
533 | 12x |
rbindl_rtables(list(x, y), check_headers = TRUE) |
534 |
} |
|
535 |
) |
|
536 | ||
537 |
combine_cinfo <- function(..., new_total = NULL) { |
|
538 | 10x |
tabs <- list(...) |
539 | 10x |
chk_cbindable_many(tabs) |
540 | 8x |
cinfs <- lapply(tabs, col_info) |
541 | 8x |
stopifnot(are(cinfs, "InstantiatedColumnInfo")) |
542 | ||
543 | 8x |
ctrees <- lapply(cinfs, coltree) |
544 | ||
545 | 8x |
newctree <- LayoutColTree(kids = ctrees) |
546 | 8x |
newcounts <- unlist(lapply(cinfs, col_counts)) |
547 | 8x |
if (is.null(new_total)) { |
548 | 8x |
new_total <- sum(newcounts) |
549 |
} |
|
550 | 8x |
newexprs <- unlist(lapply(cinfs, col_exprs), recursive = FALSE) |
551 | 8x |
newexargs <- unlist(lapply(cinfs, col_extra_args), recursive = FALSE) %||% vector("list", length(newcounts)) |
552 | 8x |
newdisp <- any(vapply(cinfs, disp_ccounts, NA)) |
553 | 8x |
alltls <- lapply(cinfs, top_left) |
554 | 8x |
newtl <- character() |
555 | 8x |
if (!are(tabs, "TableRow")) { |
556 | 8x |
alltls <- alltls[vapply(alltls, function(x) length(x) > 0, NA)] ## these are already enforced to all be the same |
557 | 8x |
if (length(alltls) > 0) { |
558 | ! |
newtl <- alltls[[1]] |
559 |
} |
|
560 |
} |
|
561 | 8x |
InstantiatedColumnInfo( |
562 | 8x |
treelyt = newctree, |
563 | 8x |
csubs = newexprs, |
564 | 8x |
extras = newexargs, |
565 | 8x |
cnts = newcounts, |
566 | 8x |
dispcounts = newdisp, |
567 | 8x |
countformat = colcount_format(cinfs[[1]]), |
568 | 8x |
total_cnt = new_total, |
569 | 8x |
topleft = newtl |
570 |
) |
|
571 |
} |
|
572 | ||
573 |
nz_len_els <- function(lst) { |
|
574 | 104x |
if (is(lst, "list")) { |
575 | 13x |
lst[vapply(lst, function(x) length(x) > 0, NA)] |
576 | 91x |
} else if (is(lst, "character")) { |
577 | 78x |
lst[nzchar(lst)] |
578 |
} else { |
|
579 | 13x |
lst |
580 |
} |
|
581 |
} |
|
582 | ||
583 |
has_one_unq <- function(x) { |
|
584 | 104x |
length(unique(nz_len_els(x))) <= 1 |
585 |
} |
|
586 | ||
587 |
classvec <- function(lst, enforce_one = TRUE) { |
|
588 | 24x |
if (enforce_one) { |
589 | 24x |
vapply(lst, class, "") |
590 |
} else { |
|
591 | ! |
lapply(lst, class) |
592 |
} |
|
593 |
} |
|
594 | ||
595 |
chk_cbindable_many <- function(lst) { |
|
596 |
## we actually want is/inherits there but no easy way |
|
597 |
## to figure out what the lowest base class is |
|
598 |
## that I can think of right now, so we do the |
|
599 |
## broken wrong thing instead :( |
|
600 | 15x |
if (are(lst, "TableRow")) { |
601 | 2x |
if (!has_one_unq(classvec(lst))) { |
602 | 1x |
stop("Cannot cbind different types of TableRow objects together") |
603 |
} |
|
604 | 1x |
return(TRUE) |
605 |
} |
|
606 |
## if(!are(lst, "VTableTree") |
|
607 |
## stop("Not all elements to be bound are TableTrees or TableRows") |
|
608 | ||
609 | 13x |
nrs <- vapply(lst, NROW, 1L) |
610 | 13x |
if (!has_one_unq(nrs)) { |
611 | ! |
stop("Not all elements to be bound have matching numbers of rows") |
612 |
} |
|
613 | ||
614 | 13x |
tls <- lapply(lst, top_left) |
615 | 13x |
if (!has_one_unq(tls[vapply(tls, function(x) length(x) > 0, NA)])) { |
616 | 2x |
stop( |
617 | 2x |
"Elements to be bound have differing top-left content: ", |
618 | 2x |
paste(which(!duplicated(tls)), collapse = " ") |
619 |
) |
|
620 |
} |
|
621 | ||
622 | 11x |
if (all(vapply(lst, function(x) nrow(x) == 0, NA))) { |
623 | 1x |
return(TRUE) |
624 |
} |
|
625 | ||
626 | 10x |
rns <- matrix(vapply(lst, row.names, rep("", nrs[[1]])), |
627 | 10x |
nrow = nrs[[1]] |
628 |
) |
|
629 | 10x |
rnsok <- apply(rns, 1, has_one_unq) |
630 | 10x |
if (!all(rnsok)) { |
631 | 1x |
stop( |
632 | 1x |
"Mismatching, non-empty row names detected in rows ", |
633 | 1x |
paste(which(!rnsok), collapse = " ") |
634 |
) |
|
635 |
} |
|
636 | ||
637 | 9x |
rws <- lapply(lst, collect_leaves, add.labrows = TRUE) |
638 | 9x |
rwclsmat <- matrix(unlist(lapply(rws, classvec)), |
639 | 9x |
ncol = length(lst) |
640 |
) |
|
641 | ||
642 | 9x |
rwsok <- apply(rwclsmat, 1, has_one_unq) |
643 | 9x |
if (!all(rwsok)) { |
644 | ! |
stop( |
645 | ! |
"Mismatching row classes found for rows: ", |
646 | ! |
paste(which(!rwsok), collapse = " ") |
647 |
) |
|
648 |
} |
|
649 | 9x |
TRUE |
650 |
} |
|
651 | ||
652 |
#' Column-bind two `TableTree` objects |
|
653 |
#' |
|
654 |
#' @param x (`TableTree` or `TableRow`)\cr a table or row object. |
|
655 |
#' @param ... one or more further objects of the same class as `x`. |
|
656 |
#' |
|
657 |
#' @inherit rbindl_rtables return |
|
658 |
#' |
|
659 |
#' @examples |
|
660 |
#' x <- rtable(c("A", "B"), rrow("row 1", 1, 2), rrow("row 2", 3, 4)) |
|
661 |
#' y <- rtable("C", rrow("row 1", 5), rrow("row 2", 6)) |
|
662 |
#' z <- rtable("D", rrow("row 1", 9), rrow("row 2", 10)) |
|
663 |
#' |
|
664 |
#' t1 <- cbind_rtables(x, y) |
|
665 |
#' t1 |
|
666 |
#' |
|
667 |
#' t2 <- cbind_rtables(x, y, z) |
|
668 |
#' t2 |
|
669 |
#' |
|
670 |
#' col_paths_summary(t1) |
|
671 |
#' col_paths_summary(t2) |
|
672 |
#' |
|
673 |
#' @export |
|
674 |
cbind_rtables <- function(x, ...) { |
|
675 | 10x |
lst <- list(...) |
676 | 10x |
newcinfo <- combine_cinfo(x, ...) |
677 | 8x |
recurse_cbindl(x, cinfo = newcinfo, .list = lst) |
678 |
} |
|
679 | ||
680 | 98x |
setGeneric("recurse_cbindl", function(x, cinfo, .list = NULL) standardGeneric("recurse_cbindl")) |
681 | ||
682 |
setMethod( |
|
683 |
"recurse_cbindl", c( |
|
684 |
x = "VTableNodeInfo", |
|
685 |
cinfo = "NULL" |
|
686 |
), |
|
687 |
function(x, cinfo, .list = NULL) { |
|
688 | ! |
recurse_cbindl(x, cinfo = combine_cinfo(.list), .list = .list) |
689 |
} |
|
690 |
) |
|
691 | ||
692 |
setMethod( |
|
693 |
"recurse_cbindl", c( |
|
694 |
x = "TableTree", |
|
695 |
cinfo = "InstantiatedColumnInfo" |
|
696 |
), |
|
697 |
function(x, cinfo, .list = NULL) { |
|
698 | 21x |
stopifnot(are(.list, "VTableTree")) |
699 |
## chk_cbindable(x, y) |
|
700 | 21x |
xcont <- content_table(x) |
701 | 21x |
lstconts <- lapply(.list, content_table) |
702 | 21x |
lcontnrows <- vapply(lstconts, NROW, 1L) |
703 | 21x |
unqnrcont <- unique(c(NROW(xcont), lcontnrows)) |
704 | 21x |
if (length(unqnrcont) > 1) { |
705 | ! |
stop( |
706 | ! |
"Got differing numbers of content rows [", |
707 | ! |
paste(unqnrcont, collapse = ", "), |
708 | ! |
"]. Unable to cbind these rtables" |
709 |
) |
|
710 |
} |
|
711 | ||
712 | 21x |
if (unqnrcont == 0) { |
713 | 20x |
cont <- ElementaryTable(cinfo = cinfo) |
714 |
} else { |
|
715 | 1x |
cont <- recurse_cbindl(xcont, |
716 | 1x |
.list = lstconts, |
717 | 1x |
cinfo = cinfo |
718 |
) |
|
719 |
} |
|
720 | ||
721 | 21x |
kids <- lapply( |
722 | 21x |
seq_along(tree_children(x)), |
723 | 21x |
function(i) { |
724 | 31x |
recurse_cbindl( |
725 | 31x |
x = tree_children(x)[[i]], |
726 | 31x |
cinfo = cinfo, |
727 | 31x |
.list = lapply(.list, function(tt) tree_children(tt)[[i]]) |
728 |
) |
|
729 |
} |
|
730 |
) |
|
731 | 21x |
names(kids) <- names(tree_children(x)) |
732 | 21x |
TableTree( |
733 | 21x |
kids = kids, labelrow = recurse_cbindl(tt_labelrow(x), |
734 | 21x |
cinfo = cinfo, |
735 | 21x |
.list = lapply(.list, tt_labelrow) |
736 |
), |
|
737 | 21x |
cont = cont, |
738 | 21x |
name = obj_name(x), |
739 | 21x |
lev = tt_level(x), |
740 | 21x |
cinfo = cinfo, |
741 | 21x |
format = obj_format(x) |
742 |
) |
|
743 |
} |
|
744 |
) |
|
745 | ||
746 |
setMethod( |
|
747 |
"recurse_cbindl", c( |
|
748 |
x = "ElementaryTable", |
|
749 |
cinfo = "InstantiatedColumnInfo" |
|
750 |
), |
|
751 |
function(x, cinfo, .list) { |
|
752 | 19x |
stopifnot(are(.list, class(x))) |
753 |
## chk_cbindable(x,y) |
|
754 | 19x |
if (nrow(x) == 0 && all(vapply(.list, nrow, 1L) == 0)) { |
755 | 1x |
col_info(x) <- cinfo |
756 | 1x |
return(x) ## this needs testing... I was right, it did #136 |
757 |
} |
|
758 | 18x |
kids <- lapply( |
759 | 18x |
seq_along(tree_children(x)), |
760 | 18x |
function(i) { |
761 | 19x |
recurse_cbindl( |
762 | 19x |
x = tree_children(x)[[i]], |
763 | 19x |
cinfo = cinfo, |
764 | 19x |
.list = lapply(.list, function(tt) tree_children(tt)[[i]]) |
765 |
) |
|
766 |
} |
|
767 |
) |
|
768 | 18x |
names(kids) <- names(tree_children(x)) |
769 | ||
770 | 18x |
ElementaryTable( |
771 | 18x |
kids = kids, |
772 | 18x |
labelrow = recurse_cbindl(tt_labelrow(x), |
773 | 18x |
.list = lapply(.list, tt_labelrow), |
774 | 18x |
cinfo |
775 |
), |
|
776 | 18x |
name = obj_name(x), |
777 | 18x |
lev = tt_level(x), |
778 | 18x |
cinfo = cinfo, |
779 | 18x |
format = obj_format(x), |
780 | 18x |
var = obj_avar(x) |
781 |
) |
|
782 |
} |
|
783 |
) |
|
784 | ||
785 |
.combine_rows <- function(x, cinfo = NULL, .list) { |
|
786 | 19x |
stopifnot(are(.list, class(x))) |
787 | ||
788 | 19x |
avars <- c(obj_avar(x), unlist(lapply(.list, obj_avar), recursive = FALSE)) |
789 | 19x |
avars <- avars[!is.na(avars)] |
790 | ||
791 | 19x |
if (length(unique(avars)) > 1) { |
792 | ! |
stop("Got rows that don't analyze the same variable") |
793 |
} |
|
794 | ||
795 | 19x |
xlst <- c(list(x), .list) |
796 | ||
797 | 19x |
ncols <- vapply(xlst, ncol, 1L) |
798 | 19x |
totcols <- sum(ncols) |
799 | 19x |
cumncols <- cumsum(ncols) |
800 | 19x |
strtncols <- c(0L, head(cumncols, -1)) + 1L |
801 | 19x |
vals <- vector("list", totcols) |
802 | 19x |
cspans <- integer(totcols) |
803 |
## vals[1:ncol(x)] <- row_values(x) |
|
804 |
## cpans[1:ncol(x)] <- row_cspans(x) |
|
805 | ||
806 | 19x |
for (i in seq_along(xlst)) { |
807 | 39x |
strt <- strtncols[i] |
808 | 39x |
end <- cumncols[i] |
809 |
## full vars are here for debugging purposes |
|
810 | 39x |
fullvy <- vy <- row_cells(xlst[[i]]) # nolint |
811 | 39x |
fullcspy <- cspy <- row_cspans(xlst[[i]]) # nolint |
812 | ||
813 |
if ( |
|
814 | 39x |
i > 1 && |
815 | 39x |
identical(rawvalues(vy[[1]]), rawvalues(lastval)) && |
816 |
## cspy[1] == lastspn && |
|
817 | 39x |
lastspn > 1 |
818 |
) { |
|
819 | ! |
vy <- vy[-1] |
820 | ! |
cspans[strt - 1L] <- lastspn + cspy[1] |
821 | ! |
cspy <- cspy[-1] |
822 | ! |
strt <- strt + 1L |
823 |
} |
|
824 | 39x |
if (length(vy) > 0) { |
825 | 39x |
vals[strt:end] <- vy |
826 | 39x |
cspans[strt:end] <- cspy |
827 | 39x |
lastval <- vy[[length(vy)]] |
828 | 39x |
lastspn <- cspy[[length(cspy)]] |
829 |
} else { |
|
830 |
## lastval stays the same |
|
831 | ! |
lastspn <- cspans[strtncols[i] - 1] ## already updated |
832 |
} |
|
833 |
} |
|
834 | ||
835 |
## Could be DataRow or ContentRow |
|
836 |
## This is ok because LabelRow is special cased |
|
837 | 19x |
constr_fun <- get(class(x), mode = "function") |
838 | 19x |
constr_fun( |
839 | 19x |
vals = vals, |
840 | 19x |
cspan = cspans, |
841 | 19x |
cinfo = cinfo, |
842 | 19x |
var = obj_avar(x), |
843 | 19x |
format = obj_format(x), |
844 | 19x |
name = obj_name(x), |
845 | 19x |
label = obj_label(x) |
846 |
) |
|
847 |
} |
|
848 | ||
849 |
setMethod( |
|
850 |
"recurse_cbindl", c( |
|
851 |
"TableRow", |
|
852 |
"InstantiatedColumnInfo" |
|
853 |
), |
|
854 |
function(x, cinfo = NULL, .list) { |
|
855 | 19x |
.combine_rows(x, cinfo, .list) |
856 |
} |
|
857 |
) |
|
858 | ||
859 |
setMethod( |
|
860 |
"recurse_cbindl", c( |
|
861 |
x = "LabelRow", |
|
862 |
cinfo = "InstantiatedColumnInfo" |
|
863 |
), |
|
864 |
function(x, cinfo = NULL, .list) { |
|
865 | 39x |
col_info(x) <- cinfo |
866 | 39x |
x |
867 |
} |
|
868 |
) |
|
869 | ||
870 |
## we don't care about the following discrepencies: |
|
871 |
## - ci2 having NA counts when ci1 doesn't |
|
872 |
## - mismatching display_ccounts values |
|
873 |
## - mismatching colcount formats |
|
874 |
## |
|
875 | ||
876 |
# chk_compat_cinfos <- function(ci1, ci2) { |
|
877 |
chk_compat_cinfos <- function(tt1, tt2) { |
|
878 | 41x |
nc1 <- ncol(tt1) |
879 | 41x |
nc2 <- ncol(tt2) |
880 | 41x |
if (nc1 != nc2 && nc1 > 0 && nc2 > 0) { |
881 | 1x |
stop("Column structures contain different non-zero numbers of columns: ", nc1, ", ", nc2) |
882 |
} |
|
883 | 40x |
if (no_colinfo(tt1) || no_colinfo(tt2)) { |
884 | 10x |
return(TRUE) |
885 |
} |
|
886 | 30x |
ci1 <- col_info(tt1) |
887 | 30x |
ci2 <- col_info(tt2) |
888 |
## this will enforce same length and |
|
889 |
## same names, in addition to same |
|
890 |
## expressions so we dont need |
|
891 |
## to check those separateley |
|
892 | 30x |
if (!identical(col_exprs(ci1), col_exprs(ci2))) { |
893 | ! |
stop("Column structures not compatible: subset expression lists not identical") |
894 |
} |
|
895 | ||
896 | 30x |
if (any(!is.na(col_counts(ci2))) && |
897 | 30x |
!identical( |
898 | 30x |
col_counts(ci1), |
899 | 30x |
col_counts(ci2) |
900 |
)) { |
|
901 | ! |
stop("Column structures not compatible: 2nd column structure has non-matching, non-null column counts") |
902 |
} |
|
903 | ||
904 | 30x |
if (any(sapply( |
905 | 30x |
col_extra_args(ci2), |
906 | 30x |
function(x) length(x) > 0 |
907 |
)) && |
|
908 | 30x |
!identical( |
909 | 30x |
col_extra_args(ci1), |
910 | 30x |
col_extra_args(ci2) |
911 |
)) { |
|
912 | ! |
stop( |
913 | ! |
"Column structures not compatible: 2nd column structure has ", |
914 | ! |
"non-matching, non-null extra args" |
915 |
) |
|
916 |
} |
|
917 | ||
918 | 30x |
if (any(nzchar(top_left(ci1))) && any(nzchar(top_left(ci2))) && !identical(top_left(ci1), top_left(ci2))) { |
919 | 1x |
stop( |
920 | 1x |
"Top-left materials not compatible: Got non-empty, non-matching ", |
921 | 1x |
"top-left materials. Clear them using top_left(x)<-character() ", |
922 | 1x |
"before binding to force compatibility." |
923 |
) |
|
924 |
} |
|
925 | 29x |
TRUE |
926 |
} |
|
927 | ||
928 | ||
929 |
#' **Deprecated:** Insert `rrow`s at (before) a specific location |
|
930 |
#' |
|
931 |
#' This function is deprecated and will be removed in a future release of `rtables`. Please use |
|
932 |
#' [insert_row_at_path()] or [label_at_path()] instead. |
|
933 |
#' |
|
934 |
#' @param tbl (`VTableTree`)\cr a `rtable` object. |
|
935 |
#' @param rrow (`TableRow`)\cr an `rrow` to append to `tbl`. |
|
936 |
#' @param at (`integer(1)`)\cr position into which to put the `rrow`, defaults to beginning (i.e. row 1). |
|
937 |
#' @param ascontent (`flag`)\cr currently ignored. |
|
938 |
#' |
|
939 |
#' @return A `TableTree` of the same specific class as `tbl`. |
|
940 |
#' |
|
941 |
#' @note |
|
942 |
#' Label rows (i.e. a row with no data values, only a `row.name`) can only be inserted at positions which do |
|
943 |
#' not already contain a label row when there is a non-trivial nested row structure in `tbl`. |
|
944 |
#' |
|
945 |
#' @examples |
|
946 |
#' o <- options(warn = 0) |
|
947 |
#' lyt <- basic_table() %>% |
|
948 |
#' split_cols_by("Species") %>% |
|
949 |
#' analyze("Sepal.Length") |
|
950 |
#' |
|
951 |
#' tbl <- build_table(lyt, iris) |
|
952 |
#' |
|
953 |
#' insert_rrow(tbl, rrow("Hello World")) |
|
954 |
#' insert_rrow(tbl, rrow("Hello World"), at = 2) |
|
955 |
#' |
|
956 |
#' lyt2 <- basic_table() %>% |
|
957 |
#' split_cols_by("Species") %>% |
|
958 |
#' split_rows_by("Species") %>% |
|
959 |
#' analyze("Sepal.Length") |
|
960 |
#' |
|
961 |
#' tbl2 <- build_table(lyt2, iris) |
|
962 |
#' |
|
963 |
#' insert_rrow(tbl2, rrow("Hello World")) |
|
964 |
#' insert_rrow(tbl2, rrow("Hello World"), at = 2) |
|
965 |
#' insert_rrow(tbl2, rrow("Hello World"), at = 4) |
|
966 |
#' |
|
967 |
#' insert_rrow(tbl2, rrow("new row", 5, 6, 7)) |
|
968 |
#' |
|
969 |
#' insert_rrow(tbl2, rrow("new row", 5, 6, 7), at = 3) |
|
970 |
#' |
|
971 |
#' options(o) |
|
972 |
#' |
|
973 |
#' @export |
|
974 |
insert_rrow <- function(tbl, rrow, at = 1, |
|
975 |
ascontent = FALSE) { |
|
976 | 9x |
.Deprecated("insert_row_at_path or label_at_path(tab)<-", old = "insert_rrow") |
977 | 9x |
stopifnot( |
978 | 9x |
is(tbl, "VTableTree"), |
979 | 9x |
is(rrow, "TableRow"), |
980 | 9x |
at >= 1 && at <= nrow(tbl) + 1 |
981 |
) |
|
982 | 9x |
chk_compat_cinfos(tbl, rrow) |
983 | 8x |
if (no_colinfo(rrow)) { |
984 | 8x |
col_info(rrow) <- col_info(tbl) |
985 |
} |
|
986 | ||
987 | 8x |
if (at == 1) { |
988 | 4x |
return(rbindl_rtables(list(rrow, tbl), |
989 | 4x |
check_headers = TRUE |
990 |
)) |
|
991 | 4x |
} else if (at == nrow(tbl) + 1) { |
992 | 1x |
return(rbind2(tbl, rrow)) |
993 |
} |
|
994 | ||
995 | 3x |
ret <- recurse_insert(tbl, rrow, |
996 | 3x |
at = at, |
997 | 3x |
pos = 0, |
998 | 3x |
ascontent = ascontent |
999 |
) |
|
1000 | 3x |
ret |
1001 |
} |
|
1002 | ||
1003 |
.insert_helper <- function(tt, row, at, pos, |
|
1004 |
ascontent = FALSE) { |
|
1005 | 9x |
islab <- is(row, "LabelRow") |
1006 | 9x |
kids <- tree_children(tt) |
1007 | 9x |
numkids <- length(kids) |
1008 | 9x |
kidnrs <- sapply(kids, nrow) |
1009 | 9x |
cumpos <- pos + cumsum(kidnrs) |
1010 | 9x |
contnr <- if (is(tt, "TableTree")) { |
1011 | 6x |
nrow(content_table(tt)) |
1012 |
} else { |
|
1013 | 3x |
0 |
1014 |
} |
|
1015 | 9x |
contnr <- contnr + as.numeric(labelrow_visible(tt)) |
1016 | ||
1017 | 9x |
totnr <- nrow(tt) |
1018 | 9x |
endpos <- pos + totnr |
1019 | 9x |
atend <- !islab && endpos == at - 1 |
1020 | 9x |
if (at == pos + 1 && islab) { |
1021 | 2x |
if (labelrow_visible(tt)) { |
1022 | ! |
stop("Inserting a label row at a position that already has a label row is not currently supported") |
1023 |
} |
|
1024 | 2x |
tt_labelrow(tt) <- row |
1025 | 2x |
return(tt) |
1026 |
} |
|
1027 | ||
1028 | 7x |
if (numkids == 0) { |
1029 | ! |
kids <- list(row) |
1030 | 7x |
} else if (atend) { |
1031 | 2x |
if (are(kids, "TableRow")) { |
1032 | 1x |
kids <- c(kids, list(row)) |
1033 |
} else { |
|
1034 | 1x |
kids[[numkids]] <- recurse_insert( |
1035 | 1x |
kids[[numkids]], |
1036 | 1x |
row = row, |
1037 | 1x |
at = at, |
1038 | 1x |
pos = pos + contnr + sum(kidnrs[-numkids]), |
1039 | 1x |
ascontent = ascontent |
1040 |
) |
|
1041 |
} |
|
1042 |
} else { # have >0 kids |
|
1043 | 5x |
kidnrs <- sapply(kids, nrow) |
1044 | 5x |
cumpos <- pos + cumsum(kidnrs) |
1045 | ||
1046 |
## data rows go in the end of the |
|
1047 |
## preceding subtable (if applicable) |
|
1048 |
## label rows go in the beginning of |
|
1049 |
## one at at |
|
1050 | 5x |
ind <- min( |
1051 | 5x |
which((cumpos + !islab) >= at), |
1052 | 5x |
numkids |
1053 |
) |
|
1054 | 5x |
thekid <- kids[[ind]] |
1055 | ||
1056 | 5x |
if (is(thekid, "TableRow")) { |
1057 | ! |
tt_level(row) <- tt_level(thekid) |
1058 | ! |
if (ind == 1) { |
1059 | ! |
bef <- integer() |
1060 | ! |
aft <- 1:numkids |
1061 | ! |
} else if (ind == numkids) { |
1062 | ! |
bef <- 1:(ind - 1) |
1063 | ! |
aft <- ind |
1064 |
} else { |
|
1065 | ! |
bef <- 1:ind |
1066 | ! |
aft <- (ind + 1):numkids |
1067 |
} |
|
1068 | ! |
kids <- c( |
1069 | ! |
kids[bef], list(row), |
1070 | ! |
kids[aft] |
1071 |
) |
|
1072 |
} else { # kid is not a table row |
|
1073 | 5x |
newpos <- if (ind == 1) { |
1074 | 4x |
pos + contnr |
1075 |
} else { |
|
1076 | 1x |
cumpos[ind - 1] |
1077 |
} |
|
1078 | ||
1079 | 5x |
kids[[ind]] <- recurse_insert(thekid, |
1080 | 5x |
row, |
1081 | 5x |
at, |
1082 | 5x |
pos = newpos, |
1083 | 5x |
ascontent = ascontent |
1084 |
) |
|
1085 |
} # end kid is not table row |
|
1086 |
} |
|
1087 | 7x |
tree_children(tt) <- kids |
1088 | 7x |
tt |
1089 |
} |
|
1090 | ||
1091 | 9x |
setGeneric("recurse_insert", function(tt, row, at, pos, ascontent = FALSE) standardGeneric("recurse_insert")) |
1092 | ||
1093 |
setMethod( |
|
1094 |
"recurse_insert", "TableTree", |
|
1095 |
function(tt, row, at, pos, ascontent = FALSE) { |
|
1096 | 6x |
ctab <- content_table(tt) |
1097 | 6x |
contnr <- nrow(ctab) |
1098 | 6x |
contpos <- pos + contnr |
1099 | 6x |
islab <- is(row, "LabelRow") |
1100 |
## this will NOT insert it as |
|
1101 | 6x |
if ((contnr > 0 || islab) && contpos > at) { |
1102 | ! |
content_table(tt) <- recurse_insert(ctab, row, at, pos, TRUE) |
1103 | ! |
return(tt) |
1104 |
} |
|
1105 | ||
1106 | 6x |
.insert_helper(tt, row, |
1107 | 6x |
at = at, pos = pos + contnr, |
1108 | 6x |
ascontent = ascontent |
1109 |
) |
|
1110 |
} |
|
1111 |
) |
|
1112 | ||
1113 |
setMethod( |
|
1114 |
"recurse_insert", "ElementaryTable", |
|
1115 |
function(tt, row, at, pos, ascontent = FALSE) { |
|
1116 | 3x |
.insert_helper(tt, row, |
1117 | 3x |
at = at, pos = pos, |
1118 | 3x |
ascontent = FALSE |
1119 |
) |
|
1120 |
} |
|
1121 |
) |
1 |
## Split types ----------------------------------------------------------------- |
|
2 |
## variable: split on distinct values of a variable |
|
3 |
## all: include all observations (root 'split') |
|
4 |
## rawcut: cut on static values of a variable |
|
5 |
## quantilecut: cut on quantiles of observed values for a variable |
|
6 |
## missing: split obs based on missingness of a variable/observation. This could be used for compare to ref_group?? |
|
7 |
## multicolumn: each child analyzes a different column |
|
8 |
## arbitrary: children are not related to each other in any systematic fashion. |
|
9 | ||
10 |
## null is ok here. |
|
11 |
check_ok_label <- function(lbl, multi_ok = FALSE) { |
|
12 | 46336x |
if (length(lbl) == 0) { |
13 | 10406x |
return(TRUE) |
14 |
} |
|
15 | ||
16 | 35930x |
if (length(lbl) > 1) { |
17 | 1688x |
if (multi_ok) { |
18 | 1688x |
return(all(vapply(lbl, check_ok_label, TRUE))) |
19 |
} |
|
20 | ! |
stop("got a label of length > 1") |
21 |
} |
|
22 | ||
23 | 34242x |
if (grepl("([{}])", lbl)) { |
24 | 1x |
stop("Labels cannot contain { or } due to their use for indicating referential footnotes") |
25 |
} |
|
26 | 34241x |
invisible(TRUE) |
27 |
} |
|
28 | ||
29 |
valid_lbl_pos <- c("default", "visible", "hidden", "topleft") |
|
30 |
.labelkids_helper <- function(charval) { |
|
31 | 2370x |
ret <- switch(charval, |
32 | 2370x |
"default" = NA, |
33 | 2370x |
"visible" = TRUE, |
34 | 2370x |
"hidden" = FALSE, |
35 | 2370x |
"topleft" = FALSE, |
36 | 2370x |
stop( |
37 | 2370x |
"unrecognized charval in .labelkids_helper. ", |
38 | 2370x |
"this shouldn't ever happen" |
39 |
) |
|
40 |
) |
|
41 | 2370x |
ret |
42 |
} |
|
43 | ||
44 |
setOldClass("expression") |
|
45 |
setClassUnion("SubsetDef", c("expression", "logical", "integer", "numeric")) |
|
46 | ||
47 |
setClassUnion("integerOrNULL", c("NULL", "integer")) |
|
48 |
setClassUnion("characterOrNULL", c("NULL", "character")) |
|
49 | ||
50 |
## should XXX [splits, s_values, sval_labels, subset(?)] be a data.frame? |
|
51 |
setClass("TreePos", representation( |
|
52 |
splits = "list", |
|
53 |
s_values = "list", |
|
54 |
sval_labels = "character", |
|
55 |
subset = "SubsetDef" |
|
56 |
), |
|
57 |
validity = function(object) { |
|
58 |
nspl <- length(object@splits) |
|
59 |
length(object@s_values) == nspl && length(object@sval_labels) == nspl |
|
60 |
} |
|
61 |
) |
|
62 | ||
63 |
setClassUnion("functionOrNULL", c("NULL", "function")) |
|
64 |
setClassUnion("listOrNULL", c("NULL", "list")) |
|
65 |
## TODO (?) make "list" more specific, e.g FormatList, or FunctionList? |
|
66 |
setClassUnion("FormatSpec", c("NULL", "character", "function", "list")) |
|
67 | ||
68 |
setClass("ValueWrapper", representation( |
|
69 |
value = "ANY", |
|
70 |
label = "characterOrNULL" |
|
71 |
), |
|
72 |
contains = "VIRTUAL" |
|
73 |
) |
|
74 |
## heavier-weight than I'd like but I think we need |
|
75 |
## this to carry around thee subsets for |
|
76 |
## comparison-based splits |
|
77 | ||
78 |
setClass("SplitValue", |
|
79 |
contains = "ValueWrapper", |
|
80 |
representation(extra = "list") |
|
81 |
) |
|
82 | ||
83 |
SplitValue <- function(val, extr = list(), label = val) { |
|
84 | 4243x |
if (is(val, "SplitValue")) { |
85 | 1699x |
if (length(splv_extra(val)) > 0) { |
86 | 29x |
extr <- c(splv_extra(val), extr) |
87 |
} |
|
88 | 1699x |
splv_extra(val) <- extr |
89 | 1699x |
return(val) |
90 |
} |
|
91 | 2544x |
if (!is(extr, "list")) { |
92 | ! |
extr <- list(extr) |
93 |
} |
|
94 | 2544x |
if (!is(label, "character")) { |
95 | ! |
label <- as.character(label) |
96 |
} |
|
97 | 2544x |
check_ok_label(label) |
98 | 2544x |
new("SplitValue", |
99 | 2544x |
value = val, |
100 | 2544x |
extra = extr, label = label |
101 |
) |
|
102 |
} |
|
103 | ||
104 |
setClass("LevelComboSplitValue", |
|
105 |
contains = "SplitValue", |
|
106 |
representation(combolevels = "character") |
|
107 |
) |
|
108 | ||
109 |
## wrapped in user-facing `add_combo_facet` |
|
110 |
LevelComboSplitValue <- function(val, extr, combolevels, label = val) { |
|
111 | 20x |
check_ok_label(label) |
112 | 20x |
new("LevelComboSplitValue", |
113 | 20x |
value = val, |
114 | 20x |
extra = extr, |
115 | 20x |
combolevels = combolevels, |
116 | 20x |
label = label |
117 |
) |
|
118 |
} |
|
119 | ||
120 |
setClass("Split", |
|
121 |
contains = "VIRTUAL", |
|
122 |
representation( |
|
123 |
payload = "ANY", |
|
124 |
name = "character", |
|
125 |
split_label = "character", |
|
126 |
split_format = "FormatSpec", |
|
127 |
split_na_str = "character", |
|
128 |
split_label_position = "character", |
|
129 |
## NB this is the function which is applied to |
|
130 |
## get the content rows for the CHILDREN of this |
|
131 |
## split!!! |
|
132 |
content_fun = "listOrNULL", ## functionOrNULL", |
|
133 |
content_format = "FormatSpec", |
|
134 |
content_na_str = "character", |
|
135 |
content_var = "character", |
|
136 |
label_children = "logical", |
|
137 |
extra_args = "list", |
|
138 |
indent_modifier = "integer", |
|
139 |
content_indent_modifier = "integer", |
|
140 |
content_extra_args = "list", |
|
141 |
page_title_prefix = "character", |
|
142 |
child_section_div = "character" |
|
143 |
) |
|
144 |
) |
|
145 | ||
146 |
setClass("CustomizableSplit", |
|
147 |
contains = "Split", |
|
148 |
representation(split_fun = "functionOrNULL") |
|
149 |
) |
|
150 | ||
151 |
#' @author Gabriel Becker |
|
152 |
#' @exportClass VarLevelSplit |
|
153 |
#' @rdname VarLevelSplit |
|
154 |
setClass("VarLevelSplit", |
|
155 |
contains = "CustomizableSplit", |
|
156 |
representation( |
|
157 |
value_label_var = "character", |
|
158 |
value_order = "ANY" |
|
159 |
) |
|
160 |
) |
|
161 |
#' Split on levels within a variable |
|
162 |
#' |
|
163 |
#' @inheritParams lyt_args |
|
164 |
#' @inheritParams constr_args |
|
165 |
#' |
|
166 |
#' @return a `VarLevelSplit` object. |
|
167 |
#' |
|
168 |
#' @export |
|
169 |
VarLevelSplit <- function(var, |
|
170 |
split_label, |
|
171 |
labels_var = NULL, |
|
172 |
cfun = NULL, |
|
173 |
cformat = NULL, |
|
174 |
cna_str = NA_character_, |
|
175 |
split_fun = NULL, |
|
176 |
split_format = NULL, |
|
177 |
split_na_str = NA_character_, |
|
178 |
valorder = NULL, |
|
179 |
split_name = var, |
|
180 |
child_labels = c("default", "visible", "hidden"), |
|
181 |
extra_args = list(), |
|
182 |
indent_mod = 0L, |
|
183 |
label_pos = c("topleft", "hidden", "visible"), |
|
184 |
cindent_mod = 0L, |
|
185 |
cvar = "", |
|
186 |
cextra_args = list(), |
|
187 |
page_prefix = NA_character_, |
|
188 |
section_div = NA_character_) { |
|
189 | 487x |
child_labels <- match.arg(child_labels) |
190 | 487x |
if (is.null(labels_var)) { |
191 | 1x |
labels_var <- var |
192 |
} |
|
193 | 487x |
check_ok_label(split_label) |
194 | 487x |
new("VarLevelSplit", |
195 | 487x |
payload = var, |
196 | 487x |
split_label = split_label, |
197 | 487x |
name = split_name, |
198 | 487x |
value_label_var = labels_var, |
199 | 487x |
content_fun = cfun, |
200 | 487x |
content_format = cformat, |
201 | 487x |
content_na_str = cna_str, |
202 | 487x |
split_fun = split_fun, |
203 | 487x |
split_format = split_format, |
204 | 487x |
split_na_str = split_na_str, |
205 | 487x |
value_order = NULL, |
206 | 487x |
label_children = .labelkids_helper(child_labels), |
207 | 487x |
extra_args = extra_args, |
208 | 487x |
indent_modifier = as.integer(indent_mod), |
209 | 487x |
content_indent_modifier = as.integer(cindent_mod), |
210 | 487x |
content_var = cvar, |
211 | 487x |
split_label_position = label_pos, |
212 | 487x |
content_extra_args = cextra_args, |
213 | 487x |
page_title_prefix = page_prefix, |
214 | 487x |
child_section_div = section_div |
215 |
) |
|
216 |
} |
|
217 | ||
218 |
setClass("AllSplit", contains = "Split") |
|
219 | ||
220 |
AllSplit <- function(split_label = "", |
|
221 |
cfun = NULL, |
|
222 |
cformat = NULL, |
|
223 |
cna_str = NA_character_, |
|
224 |
split_format = NULL, |
|
225 |
split_na_str = NA_character_, |
|
226 |
split_name = NULL, |
|
227 |
extra_args = list(), |
|
228 |
indent_mod = 0L, |
|
229 |
cindent_mod = 0L, |
|
230 |
cvar = "", |
|
231 |
cextra_args = list(), |
|
232 |
...) { |
|
233 | 100x |
if (is.null(split_name)) { |
234 | 100x |
if (nzchar(split_label)) { |
235 | 7x |
split_name <- split_label |
236 |
} else { |
|
237 | 93x |
split_name <- "all obs" |
238 |
} |
|
239 |
} |
|
240 | 100x |
check_ok_label(split_label) |
241 | 100x |
new("AllSplit", |
242 | 100x |
split_label = split_label, |
243 | 100x |
content_fun = cfun, |
244 | 100x |
content_format = cformat, |
245 | 100x |
content_na_str = cna_str, |
246 | 100x |
split_format = split_format, |
247 | 100x |
split_na_str = split_na_str, |
248 | 100x |
name = split_name, |
249 | 100x |
label_children = FALSE, |
250 | 100x |
extra_args = extra_args, |
251 | 100x |
indent_modifier = as.integer(indent_mod), |
252 | 100x |
content_indent_modifier = as.integer(cindent_mod), |
253 | 100x |
content_var = cvar, |
254 | 100x |
split_label_position = "hidden", |
255 | 100x |
content_extra_args = cextra_args, |
256 | 100x |
page_title_prefix = NA_character_, |
257 | 100x |
child_section_div = NA_character_ |
258 |
) |
|
259 |
} |
|
260 | ||
261 |
setClass("RootSplit", contains = "AllSplit") |
|
262 | ||
263 |
RootSplit <- function(split_label = "", cfun = NULL, cformat = NULL, cna_str = NA_character_, cvar = "", |
|
264 |
split_format = NULL, split_na_str = NA_character_, cextra_args = list(), ...) { |
|
265 | 607x |
check_ok_label(split_label) |
266 | 607x |
new("RootSplit", |
267 | 607x |
split_label = split_label, |
268 | 607x |
content_fun = cfun, |
269 | 607x |
content_format = cformat, |
270 | 607x |
content_na_str = cna_str, |
271 | 607x |
split_format = split_format, |
272 | 607x |
split_na_str = split_na_str, |
273 | 607x |
name = "root", |
274 | 607x |
label_children = FALSE, |
275 | 607x |
indent_modifier = 0L, |
276 | 607x |
content_indent_modifier = 0L, |
277 | 607x |
content_var = cvar, |
278 | 607x |
split_label_position = "hidden", |
279 | 607x |
content_extra_args = cextra_args, |
280 | 607x |
child_section_div = NA_character_ |
281 |
) |
|
282 |
} |
|
283 | ||
284 |
setClass("ManualSplit", |
|
285 |
contains = "AllSplit", |
|
286 |
representation(levels = "character") |
|
287 |
) |
|
288 | ||
289 |
#' Manually defined split |
|
290 |
#' |
|
291 |
#' @inheritParams lyt_args |
|
292 |
#' @inheritParams constr_args |
|
293 |
#' @inheritParams gen_args |
|
294 |
#' @param levels (`character`)\cr levels of the split (i.e. the children of the manual split). |
|
295 |
#' |
|
296 |
#' @return A `ManualSplit` object. |
|
297 |
#' |
|
298 |
#' @author Gabriel Becker |
|
299 |
#' @export |
|
300 |
ManualSplit <- function(levels, label, name = "manual", |
|
301 |
extra_args = list(), |
|
302 |
indent_mod = 0L, |
|
303 |
cindent_mod = 0L, |
|
304 |
cvar = "", |
|
305 |
cextra_args = list(), |
|
306 |
label_pos = "visible", |
|
307 |
page_prefix = NA_character_, |
|
308 |
section_div = NA_character_) { |
|
309 | 47x |
label_pos <- match.arg(label_pos, label_pos_values) |
310 | 47x |
check_ok_label(label, multi_ok = TRUE) |
311 | 47x |
new("ManualSplit", |
312 | 47x |
split_label = label, |
313 | 47x |
levels = levels, |
314 | 47x |
name = name, |
315 | 47x |
label_children = FALSE, |
316 | 47x |
extra_args = extra_args, |
317 | 47x |
indent_modifier = 0L, |
318 | 47x |
content_indent_modifier = as.integer(cindent_mod), |
319 | 47x |
content_var = cvar, |
320 | 47x |
split_format = NULL, |
321 | 47x |
split_na_str = NA_character_, |
322 | 47x |
split_label_position = label_pos, |
323 | 47x |
page_title_prefix = page_prefix, |
324 | 47x |
child_section_div = section_div |
325 |
) |
|
326 |
} |
|
327 | ||
328 |
## splits across which variables are being analynzed |
|
329 |
setClass("MultiVarSplit", |
|
330 |
contains = "CustomizableSplit", ## "Split", |
|
331 |
representation( |
|
332 |
var_labels = "character", |
|
333 |
var_names = "character" |
|
334 |
), |
|
335 |
validity = function(object) { |
|
336 |
length(object@payload) >= 1 && |
|
337 |
all(!is.na(object@payload)) && |
|
338 |
(length(object@var_labels) == 0 || length(object@payload) == length(object@var_labels)) |
|
339 |
} |
|
340 |
) |
|
341 | ||
342 |
.make_suffix_vec <- function(n) { |
|
343 | 3x |
c( |
344 |
"", |
|
345 | 3x |
sprintf( |
346 | 3x |
"._[[%d]]_.", |
347 | 3x |
seq_len(n - 1) + 1L |
348 |
) |
|
349 |
) |
|
350 |
} |
|
351 | ||
352 |
.make_multivar_names <- function(vars) { |
|
353 | 28x |
dups <- duplicated(vars) |
354 | 28x |
if (!any(dups)) { |
355 | 25x |
return(vars) |
356 |
} |
|
357 | 3x |
dupvars <- unique(vars[dups]) |
358 | 3x |
ret <- vars |
359 | 3x |
for (v in dupvars) { |
360 | 3x |
pos <- which(ret == v) |
361 | 3x |
ret[pos] <- paste0( |
362 | 3x |
ret[pos], |
363 | 3x |
.make_suffix_vec(length(pos)) |
364 |
) |
|
365 |
} |
|
366 | 3x |
ret |
367 |
} |
|
368 | ||
369 |
#' Split between two or more different variables |
|
370 |
#' |
|
371 |
#' @inheritParams lyt_args |
|
372 |
#' @inheritParams constr_args |
|
373 |
#' |
|
374 |
#' @return A `MultiVarSplit` object. |
|
375 |
#' |
|
376 |
#' @author Gabriel Becker |
|
377 |
#' @export |
|
378 |
MultiVarSplit <- function(vars, |
|
379 |
split_label = "", |
|
380 |
varlabels = NULL, |
|
381 |
varnames = NULL, |
|
382 |
cfun = NULL, |
|
383 |
cformat = NULL, |
|
384 |
cna_str = NA_character_, |
|
385 |
split_format = NULL, |
|
386 |
split_na_str = NA_character_, |
|
387 |
split_name = "multivars", |
|
388 |
child_labels = c("default", "visible", "hidden"), |
|
389 |
extra_args = list(), |
|
390 |
indent_mod = 0L, |
|
391 |
cindent_mod = 0L, |
|
392 |
cvar = "", |
|
393 |
cextra_args = list(), |
|
394 |
label_pos = "visible", |
|
395 |
split_fun = NULL, |
|
396 |
page_prefix = NA_character_, |
|
397 |
section_div = NA_character_) { |
|
398 | 28x |
check_ok_label(split_label) |
399 |
## no topleft allowed |
|
400 | 28x |
label_pos <- match.arg(label_pos, label_pos_values[-3]) |
401 | 28x |
child_labels <- match.arg(child_labels) |
402 | 28x |
if (length(vars) == 1 && grepl(":", vars)) { |
403 | ! |
vars <- strsplit(vars, ":")[[1]] |
404 |
} |
|
405 | 28x |
if (length(varlabels) == 0) { ## covers NULL and character() |
406 | 1x |
varlabels <- vars |
407 |
} |
|
408 | 28x |
vnames <- varnames %||% .make_multivar_names(vars) |
409 | 28x |
stopifnot(length(vnames) == length(vars)) |
410 | 28x |
new("MultiVarSplit", |
411 | 28x |
payload = vars, |
412 | 28x |
split_label = split_label, |
413 | 28x |
var_labels = varlabels, |
414 | 28x |
var_names = vnames, |
415 | 28x |
content_fun = cfun, |
416 | 28x |
content_format = cformat, |
417 | 28x |
content_na_str = cna_str, |
418 | 28x |
split_format = split_format, |
419 | 28x |
split_na_str = split_na_str, |
420 | 28x |
label_children = .labelkids_helper(child_labels), |
421 | 28x |
name = split_name, |
422 | 28x |
extra_args = extra_args, |
423 | 28x |
indent_modifier = as.integer(indent_mod), |
424 | 28x |
content_indent_modifier = as.integer(cindent_mod), |
425 | 28x |
content_var = cvar, |
426 | 28x |
split_label_position = label_pos, |
427 | 28x |
content_extra_args = cextra_args, |
428 | 28x |
split_fun = split_fun, |
429 | 28x |
page_title_prefix = page_prefix, |
430 | 28x |
child_section_div = section_div |
431 |
) |
|
432 |
} |
|
433 | ||
434 |
#' Splits for cutting by values of a numeric variable |
|
435 |
#' |
|
436 |
#' @inheritParams lyt_args |
|
437 |
#' @inheritParams constr_args |
|
438 |
#' |
|
439 |
#' @exportClass VarStaticCutSplit |
|
440 |
#' @rdname cutsplits |
|
441 |
setClass("VarStaticCutSplit", |
|
442 |
contains = "Split", |
|
443 |
representation( |
|
444 |
cuts = "numeric", |
|
445 |
cut_labels = "character" |
|
446 |
) |
|
447 |
) |
|
448 | ||
449 |
.is_cut_lab_lst <- function(cuts) { |
|
450 | 12x |
is.list(cuts) && is.numeric(cuts[[1]]) && |
451 | 12x |
is.character(cuts[[2]]) && |
452 | 12x |
length(cuts[[1]]) == length(cuts[[2]]) |
453 |
} |
|
454 | ||
455 |
#' Create static cut or static cumulative cut split |
|
456 |
#' |
|
457 |
#' @inheritParams lyt_args |
|
458 |
#' @inheritParams constr_args |
|
459 |
#' |
|
460 |
#' @return A `VarStaticCutSplit`, `CumulativeCutSplit` object for `make_static_cut_split`, or a `VarDynCutSplit` |
|
461 |
#' object for [VarDynCutSplit()]. |
|
462 |
#' |
|
463 |
#' @rdname cutsplits |
|
464 |
make_static_cut_split <- function(var, |
|
465 |
split_label, |
|
466 |
cuts, |
|
467 |
cutlabels = NULL, |
|
468 |
cfun = NULL, |
|
469 |
cformat = NULL, |
|
470 |
cna_str = NA_character_, |
|
471 |
split_format = NULL, |
|
472 |
split_na_str = NA_character_, |
|
473 |
split_name = var, |
|
474 |
child_labels = c("default", "visible", "hidden"), |
|
475 |
extra_args = list(), |
|
476 |
indent_mod = 0L, |
|
477 |
cindent_mod = 0L, |
|
478 |
cvar = "", |
|
479 |
cextra_args = list(), |
|
480 |
label_pos = "visible", |
|
481 |
cumulative = FALSE, |
|
482 |
page_prefix = NA_character_, |
|
483 |
section_div = NA_character_) { |
|
484 | 12x |
cls <- if (cumulative) "CumulativeCutSplit" else "VarStaticCutSplit" |
485 | 12x |
check_ok_label(split_label) |
486 | ||
487 | 12x |
label_pos <- match.arg(label_pos, label_pos_values) |
488 | 12x |
child_labels <- match.arg(child_labels) |
489 | 12x |
if (.is_cut_lab_lst(cuts)) { |
490 | ! |
cutlabels <- cuts[[2]] |
491 | ! |
cuts <- cuts[[1]] |
492 |
} |
|
493 | 12x |
if (is.unsorted(cuts, strictly = TRUE)) { |
494 | ! |
stop("invalid cuts vector. not sorted unique values.") |
495 |
} |
|
496 | ||
497 | 12x |
if (is.null(cutlabels) && !is.null(names(cuts))) { |
498 | 1x |
cutlabels <- names(cuts)[-1] |
499 |
} ## XXX is this always right? |
|
500 | ||
501 | 12x |
new(cls, |
502 | 12x |
payload = var, |
503 | 12x |
split_label = split_label, |
504 | 12x |
cuts = cuts, |
505 | 12x |
cut_labels = cutlabels, |
506 | 12x |
content_fun = cfun, |
507 | 12x |
content_format = cformat, |
508 | 12x |
content_na_str = cna_str, |
509 | 12x |
split_format = split_format, |
510 | 12x |
split_na_str = split_na_str, |
511 | 12x |
name = split_name, |
512 | 12x |
label_children = .labelkids_helper(child_labels), |
513 | 12x |
extra_args = extra_args, |
514 | 12x |
indent_modifier = as.integer(indent_mod), |
515 | 12x |
content_indent_modifier = as.integer(cindent_mod), |
516 | 12x |
content_var = cvar, |
517 | 12x |
split_label_position = label_pos, |
518 | 12x |
content_extra_args = cextra_args, |
519 | 12x |
page_title_prefix = page_prefix, |
520 | 12x |
child_section_div = section_div |
521 |
) |
|
522 |
} |
|
523 | ||
524 |
#' @exportClass CumulativeCutSplit |
|
525 |
#' @rdname cutsplits |
|
526 |
setClass("CumulativeCutSplit", contains = "VarStaticCutSplit") |
|
527 | ||
528 |
## make_static_cut_split with cumulative=TRUE is the constructor |
|
529 |
## for CumulativeCutSplit |
|
530 | ||
531 |
## do we want this to be a CustomizableSplit instead of |
|
532 |
## taking cut_fun? |
|
533 |
## cut_funct must take avector and no other arguments |
|
534 |
## and return a named vector of cut points |
|
535 |
#' @exportClass VarDynCutSplit |
|
536 |
#' @rdname cutsplits |
|
537 |
setClass("VarDynCutSplit", |
|
538 |
contains = "Split", |
|
539 |
representation( |
|
540 |
cut_fun = "function", |
|
541 |
cut_label_fun = "function", |
|
542 |
cumulative_cuts = "logical" |
|
543 |
) |
|
544 |
) |
|
545 | ||
546 |
#' @export |
|
547 |
#' @rdname cutsplits |
|
548 |
VarDynCutSplit <- function(var, |
|
549 |
split_label, |
|
550 |
cutfun, |
|
551 |
cutlabelfun = function(x) NULL, |
|
552 |
cfun = NULL, |
|
553 |
cformat = NULL, |
|
554 |
cna_str = NA_character_, |
|
555 |
split_format = NULL, |
|
556 |
split_na_str = NA_character_, |
|
557 |
split_name = var, |
|
558 |
child_labels = c("default", "visible", "hidden"), |
|
559 |
extra_args = list(), |
|
560 |
cumulative = FALSE, |
|
561 |
indent_mod = 0L, |
|
562 |
cindent_mod = 0L, |
|
563 |
cvar = "", |
|
564 |
cextra_args = list(), |
|
565 |
label_pos = "visible", |
|
566 |
page_prefix = NA_character_, |
|
567 |
section_div = NA_character_) { |
|
568 | 6x |
check_ok_label(split_label) |
569 | 6x |
label_pos <- match.arg(label_pos, label_pos_values) |
570 | 6x |
child_labels <- match.arg(child_labels) |
571 | 6x |
new("VarDynCutSplit", |
572 | 6x |
payload = var, |
573 | 6x |
split_label = split_label, |
574 | 6x |
cut_fun = cutfun, |
575 | 6x |
cumulative_cuts = cumulative, |
576 | 6x |
cut_label_fun = cutlabelfun, |
577 | 6x |
content_fun = cfun, |
578 | 6x |
content_format = cformat, |
579 | 6x |
content_na_str = cna_str, |
580 | 6x |
split_format = split_format, |
581 | 6x |
split_na_str = split_na_str, |
582 | 6x |
name = split_name, |
583 | 6x |
label_children = .labelkids_helper(child_labels), |
584 | 6x |
extra_args = extra_args, |
585 | 6x |
indent_modifier = as.integer(indent_mod), |
586 | 6x |
content_indent_modifier = as.integer(cindent_mod), |
587 | 6x |
content_var = cvar, |
588 | 6x |
split_label_position = label_pos, |
589 | 6x |
content_extra_args = cextra_args, |
590 | 6x |
page_title_prefix = page_prefix, |
591 | 6x |
child_section_div = section_div |
592 |
) |
|
593 |
} |
|
594 | ||
595 |
## NB analyze splits can't have content-related things |
|
596 |
setClass("VAnalyzeSplit", |
|
597 |
contains = "Split", |
|
598 |
representation( |
|
599 |
default_rowlabel = "character", |
|
600 |
include_NAs = "logical", |
|
601 |
var_label_position = "character" |
|
602 |
) |
|
603 |
) |
|
604 | ||
605 |
setClass("AnalyzeVarSplit", |
|
606 |
contains = "VAnalyzeSplit", |
|
607 |
representation(analysis_fun = "function") |
|
608 |
) |
|
609 | ||
610 |
setClass("AnalyzeColVarSplit", |
|
611 |
contains = "VAnalyzeSplit", |
|
612 |
representation(analysis_fun = "list") |
|
613 |
) |
|
614 | ||
615 |
#' Define a subset tabulation/analysis |
|
616 |
#' |
|
617 |
#' @inheritParams lyt_args |
|
618 |
#' @inheritParams constr_args |
|
619 |
#' @param defrowlab (`character`)\cr default row labels, if not specified by the return value of `afun`. |
|
620 |
#' |
|
621 |
#' @return An `AnalyzeVarSplit` object. |
|
622 |
#' |
|
623 |
#' @author Gabriel Becker |
|
624 |
#' @export |
|
625 |
#' @rdname avarspl |
|
626 |
AnalyzeVarSplit <- function(var, |
|
627 |
split_label = var, |
|
628 |
afun, |
|
629 |
defrowlab = "", |
|
630 |
cfun = NULL, |
|
631 |
cformat = NULL, |
|
632 |
split_format = NULL, |
|
633 |
split_na_str = NA_character_, |
|
634 |
inclNAs = FALSE, |
|
635 |
split_name = var, |
|
636 |
extra_args = list(), |
|
637 |
indent_mod = 0L, |
|
638 |
label_pos = "default", |
|
639 |
cvar = "", |
|
640 |
section_div = NA_character_) { |
|
641 | 326x |
check_ok_label(split_label) |
642 | 326x |
label_pos <- match.arg(label_pos, c("default", label_pos_values)) |
643 | 326x |
if (!any(nzchar(defrowlab))) { |
644 | 1x |
defrowlab <- as.character(substitute(afun)) |
645 | 1x |
if (length(defrowlab) > 1 || startsWith(defrowlab, "function(")) { |
646 | ! |
defrowlab <- "" |
647 |
} |
|
648 |
} |
|
649 | 326x |
new("AnalyzeVarSplit", |
650 | 326x |
payload = var, |
651 | 326x |
split_label = split_label, |
652 | 326x |
content_fun = cfun, |
653 | 326x |
analysis_fun = afun, |
654 | 326x |
content_format = cformat, |
655 | 326x |
split_format = split_format, |
656 | 326x |
split_na_str = split_na_str, |
657 | 326x |
default_rowlabel = defrowlab, |
658 | 326x |
include_NAs = inclNAs, |
659 | 326x |
name = split_name, |
660 | 326x |
label_children = FALSE, |
661 | 326x |
extra_args = extra_args, |
662 | 326x |
indent_modifier = as.integer(indent_mod), |
663 | 326x |
content_indent_modifier = 0L, |
664 | 326x |
var_label_position = label_pos, |
665 | 326x |
content_var = cvar, |
666 | 326x |
page_title_prefix = NA_character_, |
667 | 326x |
child_section_div = section_div |
668 | 326x |
) ## no content_extra_args |
669 |
} |
|
670 | ||
671 |
#' Define a subset tabulation/analysis |
|
672 |
#' |
|
673 |
#' @inheritParams lyt_args |
|
674 |
#' @inheritParams constr_args |
|
675 |
#' |
|
676 |
#' @author Gabriel Becker |
|
677 |
#' @export |
|
678 |
#' @rdname avarspl |
|
679 |
AnalyzeColVarSplit <- function(afun, |
|
680 |
defrowlab = "", |
|
681 |
cfun = NULL, |
|
682 |
cformat = NULL, |
|
683 |
split_format = NULL, |
|
684 |
split_na_str = NA_character_, |
|
685 |
inclNAs = FALSE, |
|
686 |
split_name = "", |
|
687 |
extra_args = list(), |
|
688 |
indent_mod = 0L, |
|
689 |
label_pos = "default", |
|
690 |
cvar = "", |
|
691 |
section_div = NA_character_) { |
|
692 | 23x |
label_pos <- match.arg(label_pos, c("default", label_pos_values)) |
693 | 23x |
new("AnalyzeColVarSplit", |
694 | 23x |
payload = NA_character_, |
695 | 23x |
split_label = "", |
696 | 23x |
content_fun = cfun, |
697 | 23x |
analysis_fun = afun, |
698 | 23x |
content_format = cformat, |
699 | 23x |
split_format = split_format, |
700 | 23x |
split_na_str = split_na_str, |
701 | 23x |
default_rowlabel = defrowlab, |
702 | 23x |
include_NAs = inclNAs, |
703 | 23x |
name = split_name, |
704 | 23x |
label_children = FALSE, |
705 | 23x |
extra_args = extra_args, |
706 | 23x |
indent_modifier = as.integer(indent_mod), |
707 | 23x |
content_indent_modifier = 0L, |
708 | 23x |
var_label_position = label_pos, |
709 | 23x |
content_var = cvar, |
710 | 23x |
page_title_prefix = NA_character_, |
711 | 23x |
child_section_div = section_div |
712 | 23x |
) ## no content_extra_args |
713 |
} |
|
714 | ||
715 |
setClass("CompoundSplit", |
|
716 |
contains = "Split", |
|
717 |
validity = function(object) are(object@payload, "Split") |
|
718 |
) |
|
719 | ||
720 |
setClass("AnalyzeMultiVars", contains = "CompoundSplit") |
|
721 | ||
722 |
.repoutlst <- function(x, nv) { |
|
723 | 1788x |
if (!is.function(x) && length(x) == nv) { |
724 | 858x |
return(x) |
725 |
} |
|
726 | 930x |
if (!is(x, "list")) { |
727 | 930x |
x <- list(x) |
728 |
} |
|
729 | 930x |
rep(x, length.out = nv) |
730 |
} |
|
731 | ||
732 |
.uncompound <- function(csplit) { |
|
733 | 63x |
if (is(csplit, "list")) { |
734 | 3x |
return(unlist(lapply(csplit, .uncompound))) |
735 |
} |
|
736 | ||
737 | 60x |
if (!is(csplit, "CompoundSplit")) { |
738 | 59x |
return(csplit) |
739 |
} |
|
740 | ||
741 | 1x |
pld <- spl_payload(csplit) |
742 | 1x |
done <- all(!vapply(pld, is, TRUE, class2 = "CompoundSplit")) |
743 | 1x |
if (done) { |
744 | 1x |
pld |
745 |
} else { |
|
746 | ! |
unlist(lapply(pld, .uncompound)) |
747 |
} |
|
748 |
} |
|
749 | ||
750 |
strip_compound_name <- function(obj) { |
|
751 | 11x |
nm <- obj_name(obj) |
752 | 11x |
gsub("^ma_", "", nm) |
753 |
} |
|
754 | ||
755 |
make_ma_name <- function(spl, pld = spl_payload(spl)) { |
|
756 | 3x |
paste( |
757 | 3x |
c( |
758 | 3x |
"ma", |
759 | 3x |
vapply(pld, strip_compound_name, "") |
760 |
), |
|
761 | 3x |
collapse = "_" |
762 |
) |
|
763 |
} |
|
764 | ||
765 |
#' @param .payload (`list`)\cr used internally, not intended to be set by end users. |
|
766 |
#' |
|
767 |
#' @return An `AnalyzeMultiVars` split object. |
|
768 |
#' |
|
769 |
#' @export |
|
770 |
#' @rdname avarspl |
|
771 |
AnalyzeMultiVars <- function(var, |
|
772 |
split_label = "", |
|
773 |
afun, |
|
774 |
defrowlab = "", |
|
775 |
cfun = NULL, |
|
776 |
cformat = NULL, |
|
777 |
split_format = NULL, |
|
778 |
split_na_str = NA_character_, |
|
779 |
inclNAs = FALSE, |
|
780 |
.payload = NULL, |
|
781 |
split_name = NULL, |
|
782 |
extra_args = list(), |
|
783 |
indent_mod = 0L, |
|
784 |
child_labels = c("default", "topleft", "visible", "hidden"), |
|
785 |
child_names = var, |
|
786 |
cvar = "", |
|
787 |
section_div = NA_character_) { |
|
788 |
## NB we used to resolve to strict TRUE/FALSE for label visibillity |
|
789 |
## in this function but that was too greedy for repeated |
|
790 |
## analyze calls, so that now occurs in the tabulation machinery |
|
791 |
## when the table is actually being built. |
|
792 |
## show_kidlabs = .labelkids_helper(match.arg(child_labels)) |
|
793 | 323x |
child_labels <- match.arg(child_labels) |
794 | 323x |
show_kidlabs <- child_labels |
795 | 323x |
if (is.null(.payload)) { |
796 | 298x |
nv <- length(var) |
797 | 298x |
defrowlab <- .repoutlst(defrowlab, nv) |
798 | 298x |
afun <- .repoutlst(afun, nv) |
799 | 298x |
split_label <- .repoutlst(split_label, nv) |
800 | 298x |
check_ok_label(split_label, multi_ok = TRUE) |
801 | 298x |
cfun <- .repoutlst(cfun, nv) |
802 | 298x |
cformat <- .repoutlst(cformat, nv) |
803 |
## split_format = .repoutlst(split_format, nv) |
|
804 | 298x |
inclNAs <- .repoutlst(inclNAs, nv) |
805 | 298x |
section_div_if_multivar <- if (length(var) > 1) NA_character_ else section_div |
806 | 298x |
pld <- mapply(AnalyzeVarSplit, |
807 | 298x |
var = var, |
808 | 298x |
split_name = child_names, |
809 | 298x |
split_label = split_label, |
810 | 298x |
afun = afun, |
811 | 298x |
defrowlab = defrowlab, |
812 | 298x |
cfun = cfun, |
813 | 298x |
cformat = cformat, |
814 |
## split_format = split_format, |
|
815 | 298x |
inclNAs = inclNAs, |
816 | 298x |
MoreArgs = list( |
817 | 298x |
extra_args = extra_args, |
818 | 298x |
indent_mod = indent_mod, |
819 | 298x |
label_pos = show_kidlabs, |
820 | 298x |
split_format = split_format, |
821 | 298x |
split_na_str = split_na_str, |
822 | 298x |
section_div = section_div_if_multivar |
823 | 298x |
), ## rvis), |
824 | 298x |
SIMPLIFY = FALSE |
825 |
) |
|
826 |
} else { |
|
827 |
## we're combining existing splits here |
|
828 | 25x |
pld <- unlist(lapply(.payload, .uncompound)) |
829 | ||
830 |
## only override the childen being combined if the constructor |
|
831 |
## was passed a non-default value for child_labels |
|
832 |
## and the child was at NA before |
|
833 | 25x |
pld <- lapply( |
834 | 25x |
pld, |
835 | 25x |
function(x) { |
836 | 50x |
rvis <- label_position(x) ## labelrow_visible(x) |
837 | 50x |
if (!identical(show_kidlabs, "default")) { ## is.na(show_kidlabs)) { |
838 | ! |
if (identical(rvis, "default")) { ## ois.na(rvis)) |
839 | ! |
rvis <- show_kidlabs |
840 |
} |
|
841 |
} |
|
842 | 50x |
label_position(x) <- rvis |
843 | 50x |
x |
844 |
} |
|
845 |
) |
|
846 |
} |
|
847 | 323x |
if (length(pld) == 1) { |
848 | 275x |
ret <- pld[[1]] |
849 |
} else { |
|
850 | 48x |
if (is.null(split_name)) { |
851 | 48x |
split_name <- paste(c("ma", vapply(pld, obj_name, "")), |
852 | 48x |
collapse = "_" |
853 |
) |
|
854 |
} |
|
855 | 48x |
ret <- new("AnalyzeMultiVars", |
856 | 48x |
payload = pld, |
857 | 48x |
split_label = "", |
858 | 48x |
split_format = NULL, |
859 | 48x |
split_na_str = split_na_str, |
860 | 48x |
content_fun = NULL, |
861 | 48x |
content_format = NULL, |
862 |
## I beleive this is superfluous now |
|
863 |
## the payloads carry aroudn the real instructions |
|
864 |
## XXX |
|
865 | 48x |
label_children = .labelkids_helper(show_kidlabs), |
866 | 48x |
split_label_position = "hidden", ## XXX is this right? |
867 | 48x |
name = split_name, |
868 | 48x |
extra_args = extra_args, |
869 |
## modifier applied on splits in payload |
|
870 | 48x |
indent_modifier = 0L, |
871 | 48x |
content_indent_modifier = 0L, |
872 | 48x |
content_var = cvar, |
873 | 48x |
page_title_prefix = NA_character_, |
874 | 48x |
child_section_div = section_div |
875 |
) |
|
876 |
} |
|
877 | 323x |
ret |
878 |
} |
|
879 | ||
880 |
setClass("VarLevWBaselineSplit", |
|
881 |
contains = "VarLevelSplit", |
|
882 |
representation( |
|
883 |
var = "character", |
|
884 |
ref_group_value = "character" |
|
885 |
) |
|
886 |
) |
|
887 | ||
888 |
#' @rdname VarLevelSplit |
|
889 |
#' @export |
|
890 |
VarLevWBaselineSplit <- function(var, |
|
891 |
ref_group, |
|
892 |
labels_var = var, |
|
893 |
split_label, |
|
894 |
split_fun = NULL, |
|
895 |
label_fstr = "%s - %s", |
|
896 |
## not needed I Think... |
|
897 |
cfun = NULL, |
|
898 |
cformat = NULL, |
|
899 |
cna_str = NA_character_, |
|
900 |
cvar = "", |
|
901 |
split_format = NULL, |
|
902 |
split_na_str = NA_character_, |
|
903 |
valorder = NULL, |
|
904 |
split_name = var, |
|
905 |
extra_args = list()) { |
|
906 | 10x |
check_ok_label(split_label) |
907 | 10x |
new("VarLevWBaselineSplit", |
908 | 10x |
payload = var, |
909 | 10x |
ref_group_value = ref_group, |
910 |
## This will occur at the row level not on the column split, for now |
|
911 |
## TODO revisit this to confirm its right |
|
912 |
## comparison_func = comparison, |
|
913 |
# label_format = label_fstr, |
|
914 | 10x |
value_label_var = labels_var, |
915 | 10x |
split_label = split_label, |
916 | 10x |
content_fun = cfun, |
917 | 10x |
content_format = cformat, |
918 | 10x |
content_na_str = cna_str, |
919 | 10x |
split_format = split_format, |
920 | 10x |
split_na_str = split_na_str, |
921 | 10x |
split_fun = split_fun, |
922 | 10x |
name = split_name, |
923 | 10x |
label_children = FALSE, |
924 | 10x |
extra_args = extra_args, |
925 |
## this is always a column split |
|
926 | 10x |
indent_modifier = 0L, |
927 | 10x |
content_indent_modifier = 0L, |
928 | 10x |
content_var = cvar, |
929 |
## so long as this is columnspace only |
|
930 | 10x |
page_title_prefix = NA_character_, |
931 | 10x |
child_section_div = NA_character_ |
932 |
) |
|
933 |
} |
|
934 | ||
935 |
.chkname <- function(nm) { |
|
936 | 18605x |
if (is.null(nm)) { |
937 | 349x |
nm <- "" |
938 |
} |
|
939 | 18605x |
if (length(nm) != 1) { |
940 | ! |
stop("name is not of length one") |
941 | 18605x |
} else if (is.na(nm)) { |
942 | ! |
warning("Got missing value for name, converting to characters '<NA>'") |
943 | ! |
nm <- "<NA>" |
944 |
} |
|
945 | 18605x |
nm |
946 |
} |
|
947 | ||
948 |
### Tree Position Representation |
|
949 |
### |
|
950 |
### Class(es) that represent position with in a |
|
951 |
### tree as parallel vectors of Split objects and |
|
952 |
### values chosen at that split, plus labeling info |
|
953 |
TreePos <- function(spls = list(), |
|
954 |
svals = list(), |
|
955 |
svlabels = character(), |
|
956 |
sub = NULL) { |
|
957 | 1583x |
check_ok_label(svlabels, multi_ok = TRUE) |
958 | 1583x |
svals <- make_splvalue_vec(vals = svals) |
959 | 1583x |
if (is.null(sub)) { |
960 | 356x |
if (length(spls) > 0) { |
961 | ! |
sub <- make_pos_subset( |
962 | ! |
spls = spls, |
963 | ! |
svals = svals |
964 |
) |
|
965 |
} else { |
|
966 | 356x |
sub <- expression(TRUE) |
967 |
} |
|
968 |
} |
|
969 | 1583x |
new("TreePos", |
970 | 1583x |
splits = spls, s_values = svals, |
971 | 1583x |
sval_labels = svlabels, |
972 | 1583x |
subset = sub |
973 |
) |
|
974 |
} |
|
975 | ||
976 |
## Tree position convenience functions |
|
977 |
## |
|
978 |
make_child_pos <- function(parpos, |
|
979 |
newspl, |
|
980 |
newval, |
|
981 |
newlab = newval, |
|
982 |
newextra = list()) { |
|
983 | 1227x |
if (!is(newval, "SplitValue")) { |
984 | ! |
nsplitval <- SplitValue(newval, extr = newextra, label = newlab) |
985 |
} else { |
|
986 | 1227x |
nsplitval <- newval |
987 |
} |
|
988 | 1227x |
check_ok_label(newlab) |
989 | 1227x |
newpos <- TreePos( |
990 | 1227x |
spls = c(pos_splits(parpos), newspl), |
991 | 1227x |
svals = c(pos_splvals(parpos), nsplitval), |
992 | 1227x |
svlabels = c(pos_splval_labels(parpos), newlab), |
993 | 1227x |
sub = .combine_subset_exprs( |
994 | 1227x |
pos_subset(parpos), |
995 | 1227x |
make_subset_expr(newspl, nsplitval) |
996 |
) |
|
997 |
) |
|
998 | 1227x |
newpos |
999 |
} |
|
1000 | ||
1001 |
## Virtual Classes for Tree Nodes and Layouts ================================= |
|
1002 |
## |
|
1003 |
## Virtual class hiearchy for the various types of trees in use in the S4 |
|
1004 |
## implementation of the TableTree machinery |
|
1005 | ||
1006 |
## core basics |
|
1007 |
setClass("VNodeInfo", |
|
1008 |
contains = "VIRTUAL", |
|
1009 |
representation( |
|
1010 |
level = "integer", |
|
1011 |
name = "character" ## , |
|
1012 |
## label = "character" |
|
1013 |
) |
|
1014 |
) |
|
1015 | ||
1016 |
setClass("VTree", |
|
1017 |
contains = c("VIRTUAL", "VNodeInfo"), |
|
1018 |
representation(children = "list") |
|
1019 |
) |
|
1020 | ||
1021 |
setClass("VLeaf", contains = c("VIRTUAL", "VNodeInfo")) |
|
1022 | ||
1023 |
## Layout trees ================================= |
|
1024 | ||
1025 |
# setClass("VLayoutNode", contains= c("VIRTUAL", "VNodeInfo")) |
|
1026 | ||
1027 |
setClass("VLayoutLeaf", |
|
1028 |
contains = c("VIRTUAL", "VLeaf"), |
|
1029 |
representation( |
|
1030 |
pos_in_tree = "TreePos", |
|
1031 |
label = "character" |
|
1032 |
) |
|
1033 |
) |
|
1034 | ||
1035 |
setClass("VLayoutTree", |
|
1036 |
contains = c("VIRTUAL", "VTree"), |
|
1037 |
representation( |
|
1038 |
split = "Split", |
|
1039 |
pos_in_tree = "TreePos", |
|
1040 |
label = "character" |
|
1041 |
) |
|
1042 |
) |
|
1043 | ||
1044 |
setClassUnion("VLayoutNode", c("VLayoutLeaf", "VLayoutTree")) |
|
1045 | ||
1046 |
## LayoutAxisTree classes ================================= |
|
1047 | ||
1048 |
setOldClass("function") |
|
1049 |
setOldClass("NULL") |
|
1050 |
setClassUnion("FunctionOrNULL", c("function", "NULL")) |
|
1051 | ||
1052 |
setClass("LayoutAxisTree", |
|
1053 |
contains = "VLayoutTree", |
|
1054 |
representation(summary_func = "FunctionOrNULL"), |
|
1055 |
validity = function(object) { |
|
1056 |
all(sapply(object@children, function(x) is(x, "LayoutAxisTree") || is(x, "LayoutAxisLeaf"))) |
|
1057 |
} |
|
1058 |
) |
|
1059 | ||
1060 |
setClass("LayoutAxisLeaf", |
|
1061 |
contains = "VLayoutLeaf", ## "VNodeInfo", |
|
1062 |
representation( |
|
1063 |
func = "function", |
|
1064 |
col_footnotes = "list" |
|
1065 |
) |
|
1066 |
) |
|
1067 | ||
1068 |
setClass("LayoutColTree", |
|
1069 |
contains = "LayoutAxisTree", |
|
1070 |
representation( |
|
1071 |
display_columncounts = "logical", |
|
1072 |
columncount_format = "character", |
|
1073 |
col_footnotes = "list" |
|
1074 |
) |
|
1075 |
) |
|
1076 | ||
1077 |
setClass("LayoutColLeaf", contains = "LayoutAxisLeaf") |
|
1078 |
LayoutColTree <- function(lev = 0L, |
|
1079 |
name = obj_name(spl), |
|
1080 |
label = obj_label(spl), |
|
1081 |
kids = list(), |
|
1082 |
spl = EmptyAllSplit, |
|
1083 |
tpos = TreePos(), |
|
1084 |
summary_function = NULL, |
|
1085 |
disp_colcounts = FALSE, |
|
1086 |
colcount_format = "(N=xx)", |
|
1087 |
footnotes = list()) { ## , |
|
1088 |
## sub = expression(TRUE), |
|
1089 |
## svar = NA_character_, |
|
1090 |
## slab = NA_character_) { |
|
1091 | 550x |
if (is.null(spl)) { |
1092 | ! |
stop( |
1093 | ! |
"LayoutColTree constructor got NULL for spl. ", # nocov |
1094 | ! |
"This should never happen. Please contact the maintainer." |
1095 |
) |
|
1096 |
} # nocov |
|
1097 | 550x |
footnotes <- make_ref_value(footnotes) |
1098 | 550x |
check_ok_label(label) |
1099 | 550x |
new("LayoutColTree", |
1100 | 550x |
level = lev, children = kids, |
1101 | 550x |
name = .chkname(name), |
1102 | 550x |
summary_func = summary_function, |
1103 | 550x |
pos_in_tree = tpos, |
1104 | 550x |
split = spl, |
1105 |
## subset = sub, |
|
1106 |
## splitvar = svar, |
|
1107 | 550x |
label = label, |
1108 | 550x |
display_columncounts = disp_colcounts, |
1109 | 550x |
columncount_format = colcount_format, |
1110 | 550x |
col_footnotes = footnotes |
1111 |
) |
|
1112 |
} |
|
1113 | ||
1114 |
LayoutColLeaf <- function(lev = 0L, |
|
1115 |
name = label, |
|
1116 |
label = "", |
|
1117 |
tpos = TreePos()) { |
|
1118 | 1037x |
check_ok_label(label) |
1119 | 1037x |
new("LayoutColLeaf", |
1120 | 1037x |
level = lev, name = .chkname(name), label = label, |
1121 | 1037x |
pos_in_tree = tpos ## , |
1122 |
## subset = sub#, |
|
1123 |
## N_count = n, |
|
1124 |
## splitvar = svar |
|
1125 |
) |
|
1126 |
} |
|
1127 | ||
1128 |
## Instantiated column info class ============================================== |
|
1129 |
## |
|
1130 |
## This is so we don't need multiple arguments |
|
1131 |
## in the recursive functions that track |
|
1132 |
## various aspects of the column layout |
|
1133 |
## once its applied to the data. |
|
1134 | ||
1135 |
#' Instantiated column info |
|
1136 |
#' |
|
1137 |
#' @inheritParams gen_args |
|
1138 |
#' |
|
1139 |
#' @exportClass InstantiatedColumnInfo |
|
1140 |
#' @rdname cinfo |
|
1141 |
setClass( |
|
1142 |
"InstantiatedColumnInfo", |
|
1143 |
representation( |
|
1144 |
tree_layout = "VLayoutNode", ## LayoutColTree", |
|
1145 |
subset_exprs = "list", |
|
1146 |
cextra_args = "list", |
|
1147 |
counts = "integer", |
|
1148 |
total_count = "integer", |
|
1149 |
display_columncounts = "logical", |
|
1150 |
columncount_format = "FormatSpec", |
|
1151 |
columncount_na_str = "character", |
|
1152 |
top_left = "character" |
|
1153 |
) |
|
1154 |
) |
|
1155 | ||
1156 |
#' @param treelyt (`LayoutColTree`)\cr a `LayoutColTree` object. |
|
1157 |
#' @param csubs (`list`)\cr a list of subsetting expressions. |
|
1158 |
#' @param extras (`list`)\cr extra arguments associated with the columns. |
|
1159 |
#' @param cnts (`integer`)\cr counts. |
|
1160 |
#' @param total_cnt (`integer(1)`)\cr total observations represented across all columns. |
|
1161 |
#' @param dispcounts (`flag`)\cr whether the counts should be displayed as header info when the associated |
|
1162 |
#' table is printed. |
|
1163 |
#' @param countformat (`string`)\cr format for the counts if they are displayed. |
|
1164 |
#' @param count_na_str (`character`)\cr string to use in place of missing values when formatting counts. Defaults |
|
1165 |
#' to `""`. |
|
1166 |
#' |
|
1167 |
#' @return An `InstantiateadColumnInfo` object. |
|
1168 |
#' |
|
1169 |
#' @export |
|
1170 |
#' @rdname cinfo |
|
1171 |
InstantiatedColumnInfo <- function(treelyt = LayoutColTree(), |
|
1172 |
csubs = list(expression(TRUE)), |
|
1173 |
extras = list(list()), |
|
1174 |
cnts = NA_integer_, |
|
1175 |
total_cnt = NA_integer_, |
|
1176 |
dispcounts = FALSE, |
|
1177 |
countformat = "(N=xx)", |
|
1178 |
count_na_str = "", |
|
1179 |
topleft = character()) { |
|
1180 | 608x |
leaves <- collect_leaves(treelyt) |
1181 | 608x |
nl <- length(leaves) |
1182 | 608x |
extras <- rep(extras, length.out = nl) |
1183 | 608x |
cnts <- rep(cnts, length.out = nl) |
1184 | 608x |
csubs <- rep(csubs, length.out = nl) |
1185 | ||
1186 | 608x |
nleaves <- length(leaves) |
1187 | 608x |
snas <- sum(is.na(cnts)) |
1188 | 608x |
if (length(csubs) != nleaves || length(extras) != nleaves || length(cnts) != nleaves) { |
1189 | ! |
stop( |
1190 | ! |
"Mismatching number of columns indicated by: csubs [", |
1191 | ! |
length(csubs), "], ", |
1192 | ! |
"treelyt [", nl, "], extras [", length(extras), |
1193 | ! |
"] and counts [", cnts, "]." |
1194 |
) |
|
1195 |
} |
|
1196 | 608x |
if (snas != 0 && snas != nleaves) { |
1197 | 2x |
warning( |
1198 | 2x |
"Mixture of missing and non-missing column counts when ", |
1199 | 2x |
"creating column info." |
1200 |
) |
|
1201 |
} |
|
1202 | ||
1203 | 608x |
new("InstantiatedColumnInfo", |
1204 | 608x |
tree_layout = treelyt, |
1205 | 608x |
subset_exprs = csubs, |
1206 | 608x |
cextra_args = extras, |
1207 | 608x |
counts = cnts, |
1208 | 608x |
total_count = total_cnt, |
1209 | 608x |
display_columncounts = dispcounts, |
1210 | 608x |
columncount_format = countformat, |
1211 | 608x |
columncount_na_str = count_na_str, |
1212 | 608x |
top_left = topleft |
1213 |
) |
|
1214 |
} |
|
1215 | ||
1216 |
## TableTrees and row classes ================================================== |
|
1217 |
## XXX Rowspans as implemented dont really work |
|
1218 |
## they're aren't attached to the right data structures |
|
1219 |
## during conversions. |
|
1220 | ||
1221 |
## FIXME: if we ever actually need row spanning |
|
1222 |
setClass("VTableNodeInfo", |
|
1223 |
contains = c("VNodeInfo", "VIRTUAL"), |
|
1224 |
representation( |
|
1225 |
## col_layout = "VLayoutNode", |
|
1226 |
col_info = "InstantiatedColumnInfo", |
|
1227 |
format = "FormatSpec", |
|
1228 |
na_str = "character", |
|
1229 |
indent_modifier = "integer", |
|
1230 |
table_inset = "integer" |
|
1231 |
) |
|
1232 |
) |
|
1233 | ||
1234 |
setClass("TableRow", |
|
1235 |
contains = c("VIRTUAL", "VLeaf", "VTableNodeInfo"), |
|
1236 |
representation( |
|
1237 |
leaf_value = "ANY", |
|
1238 |
var_analyzed = "character", |
|
1239 |
## var_label = "character", |
|
1240 |
label = "character", |
|
1241 |
row_footnotes = "list", |
|
1242 |
trailing_section_div = "character" |
|
1243 |
) |
|
1244 |
) |
|
1245 | ||
1246 |
## TableTree Core Non-Virtual Classes ============== |
|
1247 |
## |
|
1248 |
#' Row classes and constructors |
|
1249 |
#' |
|
1250 |
#' @inheritParams constr_args |
|
1251 |
#' @inheritParams lyt_args |
|
1252 |
#' @param vis (`flag`)\cr whether the row should be visible (`LabelRow` only). |
|
1253 |
#' |
|
1254 |
#' @return A formal object representing a table row of the constructed type. |
|
1255 |
#' |
|
1256 |
#' @author Gabriel Becker |
|
1257 |
#' @export |
|
1258 |
#' @rdname rowclasses |
|
1259 |
LabelRow <- function(lev = 1L, |
|
1260 |
label = "", |
|
1261 |
name = label, |
|
1262 |
vis = !is.na(label) && nzchar(label), |
|
1263 |
cinfo = EmptyColInfo, |
|
1264 |
indent_mod = 0L, |
|
1265 |
table_inset = 0L, |
|
1266 |
trailing_section_div = NA_character_) { |
|
1267 | 4712x |
check_ok_label(label) |
1268 | 4712x |
new("LabelRow", |
1269 | 4712x |
leaf_value = list(), |
1270 | 4712x |
level = lev, |
1271 | 4712x |
label = label, |
1272 |
## XXX this means that a label row and its talbe can have the same name.... |
|
1273 |
## XXX that is bad but how bad remains to be seen |
|
1274 |
## XXX |
|
1275 | 4712x |
name = .chkname(name), |
1276 | 4712x |
col_info = cinfo, |
1277 | 4712x |
visible = vis, |
1278 | 4712x |
indent_modifier = as.integer(indent_mod), |
1279 | 4712x |
table_inset = as.integer(table_inset), |
1280 | 4712x |
trailing_section_div = trailing_section_div |
1281 |
) |
|
1282 |
} |
|
1283 | ||
1284 |
#' Row constructors and classes |
|
1285 |
#' |
|
1286 |
#' @rdname rowclasses |
|
1287 |
#' @exportClass DataRow |
|
1288 |
setClass("DataRow", |
|
1289 |
contains = "TableRow", |
|
1290 |
representation(colspans = "integer") ## , |
|
1291 |
## pos_in_tree = "TableRowPos"), |
|
1292 |
## validity = function(object) { |
|
1293 |
## lcsp = length(object@colspans) |
|
1294 |
## length(lcsp == 0) || lcsp == length(object@leaf_value) |
|
1295 |
## } |
|
1296 |
) |
|
1297 | ||
1298 |
#' @rdname rowclasses |
|
1299 |
#' @exportClass ContentRow |
|
1300 |
setClass("ContentRow", |
|
1301 |
contains = "TableRow", |
|
1302 |
representation(colspans = "integer") ## , |
|
1303 |
## pos_in_tree = "TableRowPos"), |
|
1304 |
## validity = function(object) { |
|
1305 |
## lcsp = length(object@colspans) |
|
1306 |
## length(lcsp == 0) || lcsp == length(object@leaf_value) |
|
1307 |
## } |
|
1308 |
) |
|
1309 | ||
1310 |
#' @rdname rowclasses |
|
1311 |
#' @exportClass LabelRow |
|
1312 |
setClass("LabelRow", |
|
1313 |
contains = "TableRow", |
|
1314 |
representation(visible = "logical") |
|
1315 |
) |
|
1316 | ||
1317 |
#' @param klass (`character`)\cr internal detail. |
|
1318 |
#' |
|
1319 |
#' @export |
|
1320 |
#' @rdname rowclasses |
|
1321 |
.tablerow <- function(vals = list(), |
|
1322 |
name = "", |
|
1323 |
lev = 1L, |
|
1324 |
label = name, |
|
1325 |
cspan = rep(1L, length(vals)), |
|
1326 |
cinfo = EmptyColInfo, |
|
1327 |
var = NA_character_, |
|
1328 |
format = NULL, |
|
1329 |
na_str = NA_character_, |
|
1330 |
klass, |
|
1331 |
indent_mod = 0L, |
|
1332 |
footnotes = list(), |
|
1333 |
table_inset = 0L, |
|
1334 |
trailing_section_div = NA_character_) { |
|
1335 | 3205x |
if ((missing(name) || is.null(name) || is.na(name) || nchar(name) == 0) && !missing(label)) { |
1336 | 260x |
name <- label |
1337 |
} |
|
1338 | 3205x |
vals <- lapply(vals, rcell) |
1339 | 3205x |
rlabels <- unique(unlist(lapply(vals, obj_label))) |
1340 | 3205x |
if ((missing(label) || is.null(label) || identical(label, "")) && sum(nzchar(rlabels)) == 1) { |
1341 | ! |
label <- rlabels[nzchar(rlabels)] |
1342 |
} |
|
1343 | 3205x |
if (missing(cspan) && !is.null(unlist(lapply(vals, cell_cspan)))) { |
1344 | 2946x |
cspan <- vapply(vals, cell_cspan, 0L) |
1345 |
} |
|
1346 | ||
1347 | 3205x |
check_ok_label(label) |
1348 | 3205x |
rw <- new(klass, |
1349 | 3205x |
leaf_value = vals, |
1350 | 3205x |
name = .chkname(name), |
1351 | 3205x |
level = lev, |
1352 | 3205x |
label = .chkname(label), |
1353 | 3205x |
colspans = cspan, |
1354 | 3205x |
col_info = cinfo, |
1355 | 3205x |
var_analyzed = var, |
1356 |
## these are set in set_format_recursive below |
|
1357 | 3205x |
format = NULL, |
1358 | 3205x |
na_str = NA_character_, |
1359 | 3205x |
indent_modifier = indent_mod, |
1360 | 3205x |
row_footnotes = footnotes, |
1361 | 3205x |
table_inset = table_inset, |
1362 | 3205x |
trailing_section_div = trailing_section_div |
1363 |
) |
|
1364 | 3205x |
rw <- set_format_recursive(rw, format, na_str, FALSE) |
1365 | 3205x |
rw |
1366 |
} |
|
1367 | ||
1368 |
#' @param ... additional parameters passed to shared constructor (`.tablerow`). |
|
1369 |
#' |
|
1370 |
#' @export |
|
1371 |
#' @rdname rowclasses |
|
1372 | 2690x |
DataRow <- function(...) .tablerow(..., klass = "DataRow") |
1373 | ||
1374 |
#' @export |
|
1375 |
#' @rdname rowclasses |
|
1376 | 515x |
ContentRow <- function(...) .tablerow(..., klass = "ContentRow") |
1377 | ||
1378 |
setClass("VTitleFooter", |
|
1379 |
contains = "VIRTUAL", |
|
1380 |
representation( |
|
1381 |
main_title = "character", |
|
1382 |
subtitles = "character", |
|
1383 |
main_footer = "character", |
|
1384 |
provenance_footer = "character" |
|
1385 |
) |
|
1386 |
) |
|
1387 | ||
1388 |
setClass("VTableTree", |
|
1389 |
contains = c("VIRTUAL", "VTableNodeInfo", "VTree", "VTitleFooter"), |
|
1390 |
representation( |
|
1391 |
children = "list", |
|
1392 |
rowspans = "data.frame", |
|
1393 |
labelrow = "LabelRow", |
|
1394 |
page_titles = "character", |
|
1395 |
horizontal_sep = "character", |
|
1396 |
header_section_div = "character", |
|
1397 |
trailing_section_div = "character" |
|
1398 |
) |
|
1399 |
) |
|
1400 | ||
1401 |
setClassUnion("IntegerOrNull", c("integer", "NULL")) |
|
1402 |
## covered because it's ElementaryTable's validity method but covr misses it |
|
1403 |
## nocov start |
|
1404 |
etable_validity <- function(object) { |
|
1405 |
kids <- tree_children(object) |
|
1406 |
all(sapply( |
|
1407 |
kids, |
|
1408 |
function(k) { |
|
1409 |
(is(k, "DataRow") || is(k, "ContentRow")) |
|
1410 |
} |
|
1411 |
)) ### && |
|
1412 |
} |
|
1413 |
## nocov end |
|
1414 | ||
1415 |
#' `TableTree` classes |
|
1416 |
#' |
|
1417 |
#' @return A formal object representing a populated table. |
|
1418 |
#' |
|
1419 |
#' @author Gabriel Becker |
|
1420 |
#' @exportClass ElementaryTable |
|
1421 |
#' @rdname tabclasses |
|
1422 |
setClass("ElementaryTable", |
|
1423 |
contains = "VTableTree", |
|
1424 |
representation(var_analyzed = "character"), |
|
1425 |
validity = etable_validity ## function(object) { |
|
1426 |
) |
|
1427 | ||
1428 |
.enforce_valid_kids <- function(lst, colinfo) { |
|
1429 |
## colinfo |
|
1430 | 5896x |
if (!no_colinfo(colinfo)) { |
1431 | 5896x |
lst <- lapply( |
1432 | 5896x |
lst, |
1433 | 5896x |
function(x) { |
1434 | 7399x |
if (no_colinfo(x)) { |
1435 | 208x |
col_info(x) <- colinfo |
1436 | 7191x |
} else if (!identical(colinfo, col_info(x), ignore.environment = TRUE)) { |
1437 |
## split functions from function factories (e.g. add_combo_levels) |
|
1438 |
## have different environments so we can't use identical here |
|
1439 |
## all.equal requires the **values within the closures** to be the |
|
1440 |
## same but not the actual enclosing environments. |
|
1441 | ! |
stop( |
1442 | ! |
"attempted to add child with non-matching, non-empty ", |
1443 | ! |
"column info to an existing table" |
1444 |
) |
|
1445 |
} |
|
1446 | 7399x |
x |
1447 |
} |
|
1448 |
) |
|
1449 |
} |
|
1450 | ||
1451 | 5896x |
if (are(lst, "ElementaryTable") && |
1452 | 5896x |
all(sapply(lst, function(tb) { |
1453 | 1038x |
nrow(tb) <= 1 && identical(obj_name(tb), "") |
1454 |
}))) { |
|
1455 | 1524x |
lst <- unlist(lapply(lst, function(tb) tree_children(tb)[[1]])) |
1456 |
} |
|
1457 | 5896x |
if (length(lst) == 0) { |
1458 | 1524x |
return(list()) |
1459 |
} |
|
1460 |
## names |
|
1461 | 4372x |
realnames <- sapply(lst, obj_name) |
1462 | 4372x |
lstnames <- names(lst) |
1463 | 4372x |
if (is.null(lstnames)) { |
1464 | 1862x |
names(lst) <- realnames |
1465 | 2510x |
} else if (!identical(realnames, lstnames)) { |
1466 | 2510x |
names(lst) <- realnames |
1467 |
} |
|
1468 | ||
1469 | 4372x |
lst |
1470 |
} |
|
1471 | ||
1472 |
#' Table constructors and classes |
|
1473 |
#' |
|
1474 |
#' @inheritParams constr_args |
|
1475 |
#' @inheritParams gen_args |
|
1476 |
#' @inheritParams lyt_args |
|
1477 |
#' @param rspans (`data.frame`)\cr currently stored but otherwise ignored. |
|
1478 |
#' |
|
1479 |
#' @author Gabriel Becker |
|
1480 |
#' @export |
|
1481 |
#' @rdname tabclasses |
|
1482 |
ElementaryTable <- function(kids = list(), |
|
1483 |
name = "", |
|
1484 |
lev = 1L, |
|
1485 |
label = "", |
|
1486 |
labelrow = LabelRow( |
|
1487 |
lev = lev, |
|
1488 |
label = label, |
|
1489 |
vis = !isTRUE(iscontent) && |
|
1490 |
!is.na(label) && |
|
1491 |
nzchar(label) |
|
1492 |
), |
|
1493 |
rspans = data.frame(), |
|
1494 |
cinfo = NULL, |
|
1495 |
iscontent = NA, |
|
1496 |
var = NA_character_, |
|
1497 |
format = NULL, |
|
1498 |
na_str = NA_character_, |
|
1499 |
indent_mod = 0L, |
|
1500 |
title = "", |
|
1501 |
subtitles = character(), |
|
1502 |
main_footer = character(), |
|
1503 |
prov_footer = character(), |
|
1504 |
header_section_div = NA_character_, |
|
1505 |
hsep = default_hsep(), |
|
1506 |
trailing_section_div = NA_character_, |
|
1507 |
inset = 0L) { |
|
1508 | 3038x |
check_ok_label(label) |
1509 | 3038x |
if (is.null(cinfo)) { |
1510 | ! |
if (length(kids) > 0) { |
1511 | ! |
cinfo <- col_info(kids[[1]]) |
1512 |
} else { |
|
1513 | ! |
cinfo <- EmptyColInfo |
1514 |
} |
|
1515 |
} |
|
1516 | ||
1517 | 3038x |
if (no_colinfo(labelrow)) { |
1518 | 1853x |
col_info(labelrow) <- cinfo |
1519 |
} |
|
1520 | 3038x |
kids <- .enforce_valid_kids(kids, cinfo) |
1521 | 3038x |
tab <- new("ElementaryTable", |
1522 | 3038x |
children = kids, |
1523 | 3038x |
name = .chkname(name), |
1524 | 3038x |
level = lev, |
1525 | 3038x |
labelrow = labelrow, |
1526 | 3038x |
rowspans = rspans, |
1527 | 3038x |
col_info = cinfo, |
1528 | 3038x |
var_analyzed = var, |
1529 |
## XXX these are hardcoded, because they both get set during |
|
1530 |
## set_format_recursive anyway |
|
1531 | 3038x |
format = NULL, |
1532 | 3038x |
na_str = NA_character_, |
1533 | 3038x |
table_inset = 0L, |
1534 | 3038x |
indent_modifier = as.integer(indent_mod), |
1535 | 3038x |
main_title = title, |
1536 | 3038x |
subtitles = subtitles, |
1537 | 3038x |
main_footer = main_footer, |
1538 | 3038x |
provenance_footer = prov_footer, |
1539 | 3038x |
horizontal_sep = hsep, |
1540 | 3038x |
header_section_div = header_section_div, |
1541 | 3038x |
trailing_section_div = trailing_section_div |
1542 |
) |
|
1543 | 3038x |
tab <- set_format_recursive(tab, format, na_str, FALSE) |
1544 | 3038x |
table_inset(tab) <- as.integer(inset) |
1545 | 3038x |
tab |
1546 |
} |
|
1547 | ||
1548 |
ttable_validity <- function(object) { |
|
1549 | ! |
all(sapply( |
1550 | ! |
tree_children(object), |
1551 | ! |
function(x) is(x, "VTableTree") || is(x, "TableRow") |
1552 |
)) |
|
1553 |
} |
|
1554 | ||
1555 |
.calc_cinfo <- function(cinfo, cont, kids) { |
|
1556 | 2858x |
if (!is.null(cinfo)) { |
1557 | 2858x |
cinfo |
1558 | ! |
} else if (!is.null(cont)) { |
1559 | ! |
col_info(cont) |
1560 | ! |
} else if (length(kids) >= 1) { |
1561 | ! |
col_info(kids[[1]]) |
1562 |
} else { |
|
1563 | ! |
EmptyColInfo |
1564 |
} |
|
1565 |
} |
|
1566 | ||
1567 |
## under this model, non-leaf nodes can have a content table where rollup |
|
1568 |
## analyses live |
|
1569 |
#' @exportClass TableTree |
|
1570 |
#' @rdname tabclasses |
|
1571 |
setClass("TableTree", |
|
1572 |
contains = c("VTableTree"), |
|
1573 |
representation( |
|
1574 |
content = "ElementaryTable", |
|
1575 |
page_title_prefix = "character" |
|
1576 |
), |
|
1577 |
validity = ttable_validity |
|
1578 |
) |
|
1579 | ||
1580 |
#' @export |
|
1581 |
#' @rdname tabclasses |
|
1582 |
TableTree <- function(kids = list(), |
|
1583 |
name = if (!is.na(var)) var else "", |
|
1584 |
cont = EmptyElTable, |
|
1585 |
lev = 1L, |
|
1586 |
label = name, |
|
1587 |
labelrow = LabelRow( |
|
1588 |
lev = lev, |
|
1589 |
label = label, |
|
1590 |
vis = nrow(cont) == 0 && !is.na(label) && |
|
1591 |
nzchar(label) |
|
1592 |
), |
|
1593 |
rspans = data.frame(), |
|
1594 |
iscontent = NA, |
|
1595 |
var = NA_character_, |
|
1596 |
cinfo = NULL, |
|
1597 |
format = NULL, |
|
1598 |
na_str = NA_character_, |
|
1599 |
indent_mod = 0L, |
|
1600 |
title = "", |
|
1601 |
subtitles = character(), |
|
1602 |
main_footer = character(), |
|
1603 |
prov_footer = character(), |
|
1604 |
page_title = NA_character_, |
|
1605 |
hsep = default_hsep(), |
|
1606 |
header_section_div = NA_character_, |
|
1607 |
trailing_section_div = NA_character_, |
|
1608 |
inset = 0L) { |
|
1609 | 2858x |
check_ok_label(label) |
1610 | 2858x |
cinfo <- .calc_cinfo(cinfo, cont, kids) |
1611 | ||
1612 | 2858x |
kids <- .enforce_valid_kids(kids, cinfo) |
1613 | 2858x |
if (isTRUE(iscontent) && !is.null(cont) && nrow(cont) > 0) { |
1614 | ! |
stop("Got table tree with content table and content position") |
1615 |
} |
|
1616 | 2858x |
if (no_colinfo(labelrow)) { |
1617 | 1621x |
col_info(labelrow) <- cinfo |
1618 |
} |
|
1619 | 2858x |
if ((is.null(cont) || nrow(cont) == 0) && all(sapply(kids, is, "DataRow"))) { |
1620 | 1167x |
if (!is.na(page_title)) { |
1621 | ! |
stop("Got a page title prefix for an Elementary Table") |
1622 |
} |
|
1623 |
## constructor takes care of recursive format application |
|
1624 | 1167x |
ElementaryTable( |
1625 | 1167x |
kids = kids, |
1626 | 1167x |
name = .chkname(name), |
1627 | 1167x |
lev = lev, |
1628 | 1167x |
labelrow = labelrow, |
1629 | 1167x |
rspans = rspans, |
1630 | 1167x |
cinfo = cinfo, |
1631 | 1167x |
var = var, |
1632 | 1167x |
format = format, |
1633 | 1167x |
na_str = na_str, |
1634 | 1167x |
indent_mod = indent_mod, |
1635 | 1167x |
title = title, |
1636 | 1167x |
subtitles = subtitles, |
1637 | 1167x |
main_footer = main_footer, |
1638 | 1167x |
prov_footer = prov_footer, |
1639 | 1167x |
hsep = hsep, |
1640 | 1167x |
header_section_div = header_section_div, |
1641 | 1167x |
trailing_section_div = trailing_section_div, |
1642 | 1167x |
inset = inset |
1643 |
) |
|
1644 |
} else { |
|
1645 | 1691x |
tab <- new("TableTree", |
1646 | 1691x |
content = cont, |
1647 | 1691x |
children = kids, |
1648 | 1691x |
name = .chkname(name), |
1649 | 1691x |
level = lev, |
1650 | 1691x |
labelrow = labelrow, |
1651 | 1691x |
rowspans = rspans, |
1652 | 1691x |
col_info = cinfo, |
1653 | 1691x |
format = NULL, |
1654 | 1691x |
na_str = na_str, |
1655 | 1691x |
table_inset = 0L, |
1656 | 1691x |
indent_modifier = as.integer(indent_mod), |
1657 | 1691x |
main_title = title, |
1658 | 1691x |
subtitles = subtitles, |
1659 | 1691x |
main_footer = main_footer, |
1660 | 1691x |
provenance_footer = prov_footer, |
1661 | 1691x |
page_title_prefix = page_title, |
1662 | 1691x |
horizontal_sep = "-", |
1663 | 1691x |
header_section_div = header_section_div, |
1664 | 1691x |
trailing_section_div = trailing_section_div |
1665 | 1691x |
) ## this is overridden below to get recursiveness |
1666 | 1691x |
tab <- set_format_recursive(tab, format, na_str, FALSE) |
1667 | ||
1668 |
## these is recursive |
|
1669 |
## XXX combine these probably |
|
1670 | 1691x |
horizontal_sep(tab) <- hsep |
1671 | 1691x |
table_inset(tab) <- as.integer(inset) |
1672 | 1691x |
tab |
1673 |
} |
|
1674 |
} |
|
1675 | ||
1676 |
### Pre-Data Layout Declaration Classes |
|
1677 |
### |
|
1678 |
### Notably these are NOT represented as trees |
|
1679 |
### because without data we cannot know what the |
|
1680 |
### children should be. |
|
1681 | ||
1682 |
## Vector (ordered list) of splits. |
|
1683 |
## |
|
1684 |
## This is a vector (ordered list) of splits to be |
|
1685 |
## applied recursively to the data when provided. |
|
1686 |
## |
|
1687 |
## For convenience, if this is length 1, it can contain |
|
1688 |
## a pre-existing TableTree/ElementaryTable. |
|
1689 |
## This is used for add_existing_table in colby_constructors.R |
|
1690 | ||
1691 |
setClass("SplitVector", |
|
1692 |
contains = "list", |
|
1693 |
validity = function(object) { |
|
1694 |
if (length(object) >= 1) { |
|
1695 |
lst <- tail(object, 1)[[1]] |
|
1696 |
} else { |
|
1697 |
lst <- NULL |
|
1698 |
} |
|
1699 |
all(sapply(head(object, -1), is, "Split")) && |
|
1700 |
(is.null(lst) || is(lst, "Split") || is(lst, "VTableNodeInfo")) |
|
1701 |
} |
|
1702 |
) |
|
1703 | ||
1704 |
SplitVector <- function(x = NULL, |
|
1705 |
..., |
|
1706 |
lst = list(...)) { |
|
1707 | 2353x |
if (!is.null(x)) { |
1708 | 452x |
lst <- unlist(c(list(x), lst), recursive = FALSE) |
1709 |
} |
|
1710 | 2353x |
new("SplitVector", lst) |
1711 |
} |
|
1712 | ||
1713 |
avar_noneorlast <- function(vec) { |
|
1714 | 944x |
if (!is(vec, "SplitVector")) { |
1715 | ! |
return(FALSE) |
1716 |
} |
|
1717 | 944x |
if (length(vec) == 0) { |
1718 | 612x |
return(TRUE) |
1719 |
} |
|
1720 | 332x |
isavar <- which(sapply(vec, is, "AnalyzeVarSplit")) |
1721 | 332x |
(length(isavar) == 0) || (length(isavar) == 1 && isavar == length(vec)) |
1722 |
} |
|
1723 | ||
1724 |
setClass("PreDataAxisLayout", |
|
1725 |
contains = "list", |
|
1726 |
representation(root_split = "ANY"), |
|
1727 |
validity = function(object) { |
|
1728 |
allleafs <- unlist(object, recursive = TRUE) |
|
1729 |
all(sapply(object, avar_noneorlast)) && |
|
1730 |
all(sapply( |
|
1731 |
allleafs, |
|
1732 |
## remember existing table trees can be added to layouts |
|
1733 |
## for now... |
|
1734 |
function(x) is(x, "Split") || is(x, "VTableTree") |
|
1735 |
)) |
|
1736 |
} |
|
1737 |
) |
|
1738 | ||
1739 |
setClass("PreDataColLayout", |
|
1740 |
contains = "PreDataAxisLayout", |
|
1741 |
representation( |
|
1742 |
display_columncounts = "logical", |
|
1743 |
columncount_format = "character" |
|
1744 |
) |
|
1745 |
) |
|
1746 | ||
1747 |
setClass("PreDataRowLayout", contains = "PreDataAxisLayout") |
|
1748 | ||
1749 |
PreDataColLayout <- function(x = SplitVector(), |
|
1750 |
rtsp = RootSplit(), |
|
1751 |
..., |
|
1752 |
lst = list(x, ...), |
|
1753 |
disp_colcounts = FALSE, |
|
1754 |
colcount_format = "(N=xx)") { |
|
1755 | 301x |
ret <- new("PreDataColLayout", lst, |
1756 | 301x |
display_columncounts = disp_colcounts, |
1757 | 301x |
columncount_format = colcount_format |
1758 |
) |
|
1759 | 301x |
ret@root_split <- rtsp |
1760 | 301x |
ret |
1761 |
} |
|
1762 | ||
1763 |
PreDataRowLayout <- function(x = SplitVector(), |
|
1764 |
root = RootSplit(), |
|
1765 |
..., |
|
1766 |
lst = list(x, ...)) { |
|
1767 | 618x |
new("PreDataRowLayout", lst, root_split = root) |
1768 |
} |
|
1769 | ||
1770 |
setClass("PreDataTableLayouts", |
|
1771 |
contains = "VTitleFooter", |
|
1772 |
representation( |
|
1773 |
row_layout = "PreDataRowLayout", |
|
1774 |
col_layout = "PreDataColLayout", |
|
1775 |
top_left = "character", |
|
1776 |
header_section_div = "character", |
|
1777 |
top_level_section_div = "character", |
|
1778 |
table_inset = "integer" |
|
1779 |
) |
|
1780 |
) |
|
1781 | ||
1782 |
PreDataTableLayouts <- function(rlayout = PreDataRowLayout(), |
|
1783 |
clayout = PreDataColLayout(), |
|
1784 |
topleft = character(), |
|
1785 |
title = "", |
|
1786 |
subtitles = character(), |
|
1787 |
main_footer = character(), |
|
1788 |
prov_footer = character(), |
|
1789 |
header_section_div = NA_character_, |
|
1790 |
top_level_section_div = NA_character_, |
|
1791 |
table_inset = 0L) { |
|
1792 | 301x |
new("PreDataTableLayouts", |
1793 | 301x |
row_layout = rlayout, |
1794 | 301x |
col_layout = clayout, |
1795 | 301x |
top_left = topleft, |
1796 | 301x |
main_title = title, |
1797 | 301x |
subtitles = subtitles, |
1798 | 301x |
main_footer = main_footer, |
1799 | 301x |
provenance_footer = prov_footer, |
1800 | 301x |
header_section_div = header_section_div, |
1801 | 301x |
top_level_section_div = top_level_section_div, |
1802 | 301x |
table_inset = table_inset |
1803 |
) |
|
1804 |
} |
|
1805 | ||
1806 |
## setClass("CellValue", contains = "ValueWrapper", |
|
1807 |
## representation(format = "FormatSpec", |
|
1808 |
## colspan = "integerOrNULL", |
|
1809 |
## label = "characterOrNULL"), |
|
1810 |
## prototype = list(label ="", colspan = NULL, format = NULL)) |
|
1811 | ||
1812 |
setOldClass("CellValue") |
|
1813 | ||
1814 |
#' Length of a Cell value |
|
1815 |
#' |
|
1816 |
#' @param x (`CellValue`)\cr a `CellValue` object. |
|
1817 |
#' |
|
1818 |
#' @return Always returns `1L`. |
|
1819 |
#' |
|
1820 |
#' @exportMethod length |
|
1821 |
setMethod( |
|
1822 |
"length", "CellValue", |
|
1823 | ! |
function(x) 1L |
1824 |
) |
|
1825 | ||
1826 |
setClass("RefFootnote", representation( |
|
1827 |
value = "character", |
|
1828 |
index = "integer", |
|
1829 |
symbol = "character" |
|
1830 |
)) |
|
1831 | ||
1832 |
RefFootnote <- function(note, index = NA_integer_, symbol = NA_character_) { |
|
1833 | 168x |
if (is(note, "RefFootnote")) { |
1834 | 66x |
return(note) |
1835 | 102x |
} else if (length(note) == 0) { |
1836 | ! |
return(NULL) |
1837 |
} |
|
1838 | 102x |
if (length(symbol) != 1L) { |
1839 | ! |
stop( |
1840 | ! |
"Referential footnote can only have a single string as its index.", |
1841 | ! |
" Got char vector of length ", length(index) |
1842 |
) |
|
1843 |
} |
|
1844 | 102x |
if (!is.na(symbol) && (index == "NA" || grepl("[{}]", index))) { |
1845 | ! |
stop( |
1846 | ! |
"The string 'NA' and strings containing '{' or '}' cannot be used as ", |
1847 | ! |
"referential footnote index symbols. Got string '", index, "'." |
1848 |
) |
|
1849 |
} |
|
1850 | ||
1851 | 102x |
new("RefFootnote", value = note, index = index, symbol = symbol) |
1852 |
} |
|
1853 | ||
1854 |
#' Constructor for Cell Value |
|
1855 |
#' |
|
1856 |
#' @inheritParams lyt_args |
|
1857 |
#' @inheritParams rcell |
|
1858 |
#' @param val (`ANY`)\cr value in the cell exactly as it should be passed to a formatter or returned when extracted. |
|
1859 |
#' |
|
1860 |
#' @return An object representing the value within a single cell within a populated table. The underlying structure |
|
1861 |
#' of this object is an implementation detail and should not be relied upon beyond calling accessors for the class. |
|
1862 |
#' |
|
1863 |
#' @export |
|
1864 | ||
1865 |
## Class definition |
|
1866 |
## [[1]] list: cell value |
|
1867 |
## format : format for cell |
|
1868 |
## colspan: column span info for cell |
|
1869 |
## label: row label to be used for parent row |
|
1870 |
## indent_mod: indent modifier to be used for parent row |
|
1871 |
CellValue <- function(val, format = NULL, colspan = 1L, label = NULL, |
|
1872 |
indent_mod = NULL, footnotes = NULL, |
|
1873 |
align = NULL, format_na_str = NULL) { |
|
1874 | 12211x |
if (is.null(colspan)) { |
1875 | ! |
colspan <- 1L |
1876 |
} |
|
1877 | 12211x |
if (!is.null(colspan) && !is(colspan, "integer")) { |
1878 | 10x |
colspan <- as.integer(colspan) |
1879 |
} |
|
1880 |
## if we're not given a label but the value has one associated with |
|
1881 |
## it we use that. |
|
1882 |
## NB: we need to be able to override a non-empty label with an empty one |
|
1883 |
## so we can't have "" mean "not given a label" here |
|
1884 | 12211x |
if ((is.null(label) || is.na(label)) && !is.null(obj_label(val))) { |
1885 | 2x |
label <- obj_label(val) |
1886 |
} |
|
1887 | 12211x |
if (!is.list(footnotes)) { |
1888 | 9x |
footnotes <- lapply(footnotes, RefFootnote) |
1889 |
} |
|
1890 | 12211x |
check_ok_label(label) |
1891 | 12211x |
ret <- structure(list(val), |
1892 | 12211x |
format = format, colspan = colspan, |
1893 | 12211x |
label = label, |
1894 | 12211x |
indent_mod = indent_mod, footnotes = footnotes, |
1895 | 12211x |
align = align, |
1896 | 12211x |
format_na_str = format_na_str, |
1897 | 12211x |
class = "CellValue" |
1898 |
) |
|
1899 | 12211x |
ret |
1900 |
} |
|
1901 | ||
1902 |
#' @method print CellValue |
|
1903 |
#' |
|
1904 |
#' @export |
|
1905 |
print.CellValue <- function(x, ...) { |
|
1906 | ! |
cat(paste("rcell:", format_rcell(x), "\n")) |
1907 | ! |
invisible(x) |
1908 |
} |
|
1909 | ||
1910 |
## too slow |
|
1911 |
# setClass("RowsVerticalSection", contains = "list", |
|
1912 |
# representation = list(row_names = "characterOrNULL", |
|
1913 |
# row_labels = "characterOrNULL", |
|
1914 |
# row_formats = "ANY", |
|
1915 |
# indent_mods = "integerOrNULL")) |
|
1916 | ||
1917 |
setOldClass("RowsVerticalSection") |
|
1918 |
RowsVerticalSection <- function(values, |
|
1919 |
names = names(values), |
|
1920 |
labels = NULL, |
|
1921 |
indent_mods = NULL, |
|
1922 |
formats = NULL, |
|
1923 |
footnotes = NULL, |
|
1924 |
format_na_strs = NULL) { |
|
1925 | 5800x |
stopifnot(is(values, "list")) |
1926 |
## innernms <- value_names(values) |
|
1927 | ||
1928 | 5800x |
if (is.null(labels)) { |
1929 | 2531x |
labels <- names(values) |
1930 |
} |
|
1931 | 5800x |
if (is.null(names) && all(nzchar(labels))) { |
1932 | 3309x |
names <- labels |
1933 | 2491x |
} else if (is.null(labels) && !is.null(names)) { |
1934 | 15x |
labels <- names |
1935 |
} |
|
1936 | ||
1937 | 5800x |
if (!is.null(indent_mods)) { |
1938 | 68x |
indent_mods <- as.integer(indent_mods) |
1939 |
} |
|
1940 | 5800x |
check_ok_label(labels, multi_ok = TRUE) |
1941 | 5799x |
structure(values, |
1942 | 5799x |
class = "RowsVerticalSection", row_names = names, |
1943 | 5799x |
row_labels = labels, indent_mods = indent_mods, |
1944 | 5799x |
row_formats = formats, |
1945 | 5799x |
row_na_strs = format_na_strs, |
1946 | 5799x |
row_footnotes = lapply( |
1947 | 5799x |
footnotes, |
1948 |
## cause each row needs to accept |
|
1949 |
## a *list* of row footnotes |
|
1950 | 5799x |
function(fns) lapply(fns, RefFootnote) |
1951 |
) |
|
1952 |
) |
|
1953 |
} |
|
1954 | ||
1955 |
#' @method print RowsVerticalSection |
|
1956 |
#' |
|
1957 |
#' @export |
|
1958 |
print.RowsVerticalSection <- function(x, ...) { |
|
1959 | 1x |
cat("RowsVerticalSection (in_rows) object print method:\n-------------------", |
1960 | 1x |
"---------\n", |
1961 | 1x |
sep = "" |
1962 |
) |
|
1963 | 1x |
print(data.frame( |
1964 | 1x |
row_name = attr(x, "row_names", exact = TRUE), |
1965 | 1x |
formatted_cell = vapply(x, format_rcell, character(1)), |
1966 | 1x |
indent_mod = indent_mod(x), ## vapply(x, indent_mod, numeric(1)), |
1967 | 1x |
row_label = attr(x, "row_labels", exact = TRUE), |
1968 | 1x |
stringsAsFactors = FALSE, |
1969 | 1x |
row.names = NULL |
1970 | 1x |
), row.names = TRUE) |
1971 | 1x |
invisible(x) |
1972 |
} |
|
1973 | ||
1974 |
#### Empty default objects to avoid repeated calls |
|
1975 |
## EmptyColInfo <- InstantiatedColumnInfo() |
|
1976 |
## EmptyElTable <- ElementaryTable() |
|
1977 |
## EmptyRootSplit <- RootSplit() |
|
1978 |
## EmptyAllSplit <- AllSplit() |
1 |
#' Compare two rtables |
|
2 |
#' |
|
3 |
#' Prints a matrix where `.` means cell matches, `X` means cell does |
|
4 |
#' not match, `+` cell (row) is missing, and `-` cell (row) |
|
5 |
#' should not be there. If `structure` is set to `TRUE`, `C` indicates |
|
6 |
#' column-structure mismatch, `R` indicates row-structure mismatch, and |
|
7 |
#' `S` indicates mismatch in both row and column structure. |
|
8 |
#' |
|
9 |
#' @param object (`VTableTree`)\cr `rtable` to test. |
|
10 |
#' @param expected (`VTableTree`)\cr expected `rtable`. |
|
11 |
#' @param tol (`numeric(1)`)\cr tolerance. |
|
12 |
#' @param comp.attr (`flag`)\cr whether to compare cell formats. Other attributes are |
|
13 |
#' silently ignored. |
|
14 |
#' @param structure (`flag`)\cr whether structures (in the form of column and row |
|
15 |
#' paths to cells) should be compared. Currently defaults to `FALSE`, but this is |
|
16 |
#' subject to change in future versions. |
|
17 |
#' |
|
18 |
#' @note In its current form, `compare_rtables` does not take structure into |
|
19 |
#' account, only row and cell position. |
|
20 |
#' |
|
21 |
#' @return A matrix of class `rtables_diff` representing the differences |
|
22 |
#' between `object` and `expected` as described above. |
|
23 |
#' |
|
24 |
#' @examples |
|
25 |
#' t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2)) |
|
26 |
#' t2 <- rtable(header = c("A", "B", "C"), format = "xx", rrow("row 1", 1, 2, 3)) |
|
27 |
#' |
|
28 |
#' compare_rtables(object = t1, expected = t2) |
|
29 |
#' |
|
30 |
#' if (interactive()) { |
|
31 |
#' Viewer(t1, t2) |
|
32 |
#' } |
|
33 |
#' |
|
34 |
#' expected <- rtable( |
|
35 |
#' header = c("ARM A\nN=100", "ARM B\nN=200"), |
|
36 |
#' format = "xx", |
|
37 |
#' rrow("row 1", 10, 15), |
|
38 |
#' rrow(), |
|
39 |
#' rrow("section title"), |
|
40 |
#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)")) |
|
41 |
#' ) |
|
42 |
#' |
|
43 |
#' expected |
|
44 |
#' |
|
45 |
#' object <- rtable( |
|
46 |
#' header = c("ARM A\nN=100", "ARM B\nN=200"), |
|
47 |
#' format = "xx", |
|
48 |
#' rrow("row 1", 10, 15), |
|
49 |
#' rrow("section title"), |
|
50 |
#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)")) |
|
51 |
#' ) |
|
52 |
#' |
|
53 |
#' compare_rtables(object, expected, comp.attr = FALSE) |
|
54 |
#' |
|
55 |
#' object <- rtable( |
|
56 |
#' header = c("ARM A\nN=100", "ARM B\nN=200"), |
|
57 |
#' format = "xx", |
|
58 |
#' rrow("row 1", 10, 15), |
|
59 |
#' rrow(), |
|
60 |
#' rrow("section title") |
|
61 |
#' ) |
|
62 |
#' |
|
63 |
#' compare_rtables(object, expected) |
|
64 |
#' |
|
65 |
#' object <- rtable( |
|
66 |
#' header = c("ARM A\nN=100", "ARM B\nN=200"), |
|
67 |
#' format = "xx", |
|
68 |
#' rrow("row 1", 14, 15.03), |
|
69 |
#' rrow(), |
|
70 |
#' rrow("section title"), |
|
71 |
#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)")) |
|
72 |
#' ) |
|
73 |
#' |
|
74 |
#' compare_rtables(object, expected) |
|
75 |
#' |
|
76 |
#' object <- rtable( |
|
77 |
#' header = c("ARM A\nN=100", "ARM B\nN=200"), |
|
78 |
#' format = "xx", |
|
79 |
#' rrow("row 1", 10, 15), |
|
80 |
#' rrow(), |
|
81 |
#' rrow("section title"), |
|
82 |
#' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.x, xx.x)")) |
|
83 |
#' ) |
|
84 |
#' |
|
85 |
#' compare_rtables(object, expected) |
|
86 |
#' |
|
87 |
#' @export |
|
88 |
compare_rtables <- function(object, expected, tol = 0.1, comp.attr = TRUE, |
|
89 |
structure = FALSE) { |
|
90 |
# if (identical(object, expected)) return(invisible(TRUE)) |
|
91 | ||
92 | 12x |
if (!is(object, "VTableTree")) { |
93 | ! |
stop( |
94 | ! |
"argument object is expected to be of class TableTree or ", |
95 | ! |
"ElementaryTable" |
96 |
) |
|
97 |
} |
|
98 | 12x |
if (!is(expected, "VTableTree")) { |
99 | ! |
stop( |
100 | ! |
"argument expected is expected to be of class TableTree or ", |
101 | ! |
"ElementaryTable" |
102 |
) |
|
103 |
} |
|
104 | 12x |
dim_out <- apply(rbind(dim(object), dim(expected)), 2, max) |
105 | ||
106 | 12x |
X <- matrix(rep(".", dim_out[1] * dim_out[2]), ncol = dim_out[2]) |
107 | 12x |
row.names(X) <- as.character(1:dim_out[1]) |
108 | 12x |
colnames(X) <- as.character(1:dim_out[2]) |
109 | ||
110 | 12x |
if (!identical(names(object), names(expected))) { |
111 | 7x |
attr(X, "info") <- "column names are not the same" |
112 |
} |
|
113 | ||
114 | 12x |
if (!comp.attr) { |
115 | ! |
attr(X, "info") <- c( |
116 | ! |
attr(X, "info"), |
117 | ! |
"cell attributes have not been compared" |
118 |
) |
|
119 |
} |
|
120 | 12x |
if (!identical(row.names(object), row.names(expected))) { |
121 | 2x |
attr(X, "info") <- c(attr(X, "info"), "row labels are not the same") |
122 |
} |
|
123 | ||
124 | 12x |
nro <- nrow(object) |
125 | 12x |
nre <- nrow(expected) |
126 | 12x |
nco <- ncol(object) |
127 | 12x |
nce <- ncol(expected) |
128 | ||
129 | 12x |
if (nco < nce) { |
130 | 2x |
X[, seq(nco + 1, nce)] <- "-" |
131 | 10x |
} else if (nce < nco) { |
132 | 3x |
X[, seq(nce + 1, nco)] <- "+" |
133 |
} |
|
134 | 12x |
if (nro < nre) { |
135 | 1x |
X[seq(nro + 1, nre), ] <- "-" |
136 | 11x |
} else if (nre < nro) { |
137 | ! |
X[seq(nre + 1, nro), ] <- "+" |
138 |
} |
|
139 | ||
140 | 12x |
orig_object <- object # nolint |
141 | 12x |
orig_expected <- expected # nolint |
142 | 12x |
if (nro != nre || nco != nce) { |
143 | 5x |
object <- object[1:min(nro, nre), 1:min(nco, nce), drop = FALSE] |
144 | 5x |
expected <- expected[1:min(nro, nre), 1:min(nco, nce), drop = FALSE] |
145 | 5x |
inner <- compare_rtables(object, expected, tol = tol, comp.attr = comp.attr, structure = structure) |
146 | 5x |
X[seq_len(nrow(object)), seq_len(ncol(object))] <- inner |
147 | 5x |
class(X) <- c("rtables_diff", class(X)) |
148 | 5x |
return(X) |
149 |
} |
|
150 | ||
151 |
## from here dimensions match! |
|
152 | ||
153 | 7x |
orows <- cell_values(object, omit_labrows = FALSE) |
154 | 7x |
erows <- cell_values(expected, omit_labrows = FALSE) |
155 | 7x |
if (nrow(object) == 1) { |
156 | ! |
orows <- list(orows) |
157 | ! |
erows <- list(erows) |
158 |
} |
|
159 | 7x |
res <- mapply(compare_rrows, |
160 | 7x |
row1 = orows, row2 = erows, tol = tol, ncol = ncol(object), |
161 | 7x |
USE.NAMES = FALSE, SIMPLIFY = FALSE |
162 |
) |
|
163 | 7x |
X <- do.call(rbind, res) |
164 | 7x |
rpo <- row_paths(object) |
165 | 7x |
rpe <- row_paths(expected) |
166 | ||
167 | 7x |
if (comp.attr) { |
168 | 7x |
ofmts <- value_formats(object) |
169 | 7x |
efmts <- value_formats(expected) |
170 |
## dim(ofmts) <- NULL |
|
171 |
## dim(efmts) <- NULL |
|
172 | ||
173 | 7x |
fmt_mismatch <- which(!mapply(identical, x = ofmts, y = efmts)) ## inherently ignores dim |
174 | ||
175 | ||
176 |
## note the single index here!!!, no comma!!!! |
|
177 | 7x |
X[fmt_mismatch] <- "X" |
178 |
} |
|
179 | ||
180 | ||
181 | 7x |
if (structure) { |
182 | 1x |
rp_mismatches <- !mapply(identical, x = rpo, y = rpe) |
183 | 1x |
cpo <- col_paths(object) |
184 | 1x |
cpe <- col_paths(expected) |
185 | 1x |
cp_mismatches <- !mapply(identical, x = cpo, y = cpe) |
186 | ||
187 | 1x |
if (any(rp_mismatches)) { # P for (row or column) path do not match |
188 | ! |
X[rp_mismatches, ] <- "R" |
189 |
} |
|
190 | 1x |
if (any(cp_mismatches)) { |
191 | 1x |
crep <- rep("C", nrow(X)) |
192 | 1x |
if (any(rp_mismatches)) { |
193 | ! |
crep[rp_mismatches] <- "P" |
194 |
} |
|
195 | 1x |
X[, cp_mismatches] <- rep(crep, sum(cp_mismatches)) |
196 |
} |
|
197 |
} |
|
198 | 7x |
class(X) <- c("rtables_diff", class(X)) |
199 | 7x |
X |
200 |
} |
|
201 | ||
202 |
## for (i in 1:dim(X)[1]) { |
|
203 |
## for (j in 1:dim(X)[2]) { |
|
204 | ||
205 |
## is_equivalent <- TRUE |
|
206 |
## if (i <= nro && i <= nre && j <= nco && j <= nce) { |
|
207 |
## x <- object[i,j, drop = TRUE] |
|
208 |
## y <- expected[i,j, drop = TRUE] |
|
209 | ||
210 |
## attr_x <- attributes(x) |
|
211 |
## attr_y <- attributes(y) |
|
212 | ||
213 |
## attr_x_sorted <- if (is.null(attr_x)) NULL else attr_x[order(names(attr_x))] |
|
214 |
## attr_y_sorted <- if (is.null(attr_y)) NULL else attr_y[order(names(attr_y))] |
|
215 | ||
216 |
## if (comp.attr && !identical(attr_x_sorted, attr_y_sorted)) { |
|
217 |
## is_equivalent <- FALSE |
|
218 |
## } else if (is.numeric(x) && is.numeric(y)) { |
|
219 |
## if (any(abs(na.omit(x - y)) > tol)) { |
|
220 |
## is_equivalent <- FALSE |
|
221 |
## } |
|
222 |
## } else { |
|
223 |
## if (!identical(x, y)) { |
|
224 |
## is_equivalent <- FALSE |
|
225 |
## } |
|
226 |
## } |
|
227 | ||
228 |
## if (!is_equivalent) { |
|
229 |
## X[i,j] <- "X" |
|
230 |
## } |
|
231 |
## } else if (i > nro || j > nco) { |
|
232 |
## ## missing in object |
|
233 |
## X[i, j] <- "+" |
|
234 |
## } else { |
|
235 |
## ## too many elements |
|
236 |
## X[i, j] <- "-" |
|
237 |
## } |
|
238 |
## } |
|
239 |
## } |
|
240 |
## class(X) <- c("rtable_diff", class(X)) |
|
241 |
## X |
|
242 |
## } |
|
243 | ||
244 |
compare_value <- function(x, y, tol) { |
|
245 | 359x |
if (identical(x, y) || (is.numeric(x) && is.numeric(y) && max(abs(x - y)) <= tol)) { |
246 |
"." |
|
247 |
} else { |
|
248 | 72x |
"X" |
249 |
} |
|
250 |
} |
|
251 | ||
252 |
compare_rrows <- function(row1, row2, tol, ncol) { |
|
253 | 173x |
if (length(row1) == ncol && length(row2) == ncol) { |
254 | 115x |
mapply(compare_value, x = row1, y = row2, tol = tol, USE.NAMES = FALSE) |
255 | 58x |
} else if (length(row1) == 0 && length(row2) == 0) { |
256 | 44x |
rep(".", ncol) |
257 |
} else { |
|
258 | 14x |
rep("X", ncol) |
259 |
} |
|
260 |
} |
|
261 | ||
262 |
## #' @export |
|
263 |
## print.rtable_diff <- function(x, ...) { |
|
264 |
## print.default(unclass(x), quote = FALSE, ...) |
|
265 |
## } |
1 |
#' @importFrom tools file_ext |
|
2 |
NULL |
|
3 | ||
4 |
#' Create enriched flat value table with paths |
|
5 |
#' |
|
6 |
#' This function creates a flat tabular file of cell values and corresponding paths via [path_enriched_df()]. It then |
|
7 |
#' writes that data frame out as a `tsv` file. |
|
8 |
#' |
|
9 |
#' By default (i.e. when `value_func` is not specified, list columns where at least one value has length > 1 are |
|
10 |
#' collapsed to character vectors by collapsing the list element with `"|"`. |
|
11 |
#' |
|
12 |
#' @note |
|
13 |
#' There is currently no round-trip capability for this type of export. You can read values exported this way back in |
|
14 |
#' via `import_from_tsv` but you will receive only the `data.frame` version back, NOT a `TableTree`. |
|
15 |
#' |
|
16 |
#' @inheritParams gen_args |
|
17 |
#' @inheritParams data.frame_export |
|
18 |
#' @param file (`string`)\cr the path of the file to written to or read from. |
|
19 |
#' |
|
20 |
#' @return |
|
21 |
#' * `export_as_tsv` returns `NULL` silently. |
|
22 |
#' * `import_from_tsv` returns a `data.frame` with re-constituted list values. |
|
23 |
#' |
|
24 |
#' @seealso [path_enriched_df()] for the underlying function that does the work. |
|
25 |
#' |
|
26 |
#' @importFrom utils write.table read.table |
|
27 |
#' @rdname tsv_io |
|
28 |
#' @export |
|
29 |
export_as_tsv <- function(tt, file = NULL, path_fun = collapse_path, |
|
30 |
value_fun = collapse_values) { |
|
31 | 1x |
df <- path_enriched_df(tt, path_fun = path_fun, value_fun = value_fun) |
32 | 1x |
write.table(df, file, sep = "\t") |
33 |
} |
|
34 | ||
35 |
#' @rdname tsv_io |
|
36 |
#' @export |
|
37 |
import_from_tsv <- function(file) { |
|
38 | 1x |
rawdf <- read.table(file, header = TRUE, sep = "\t") |
39 | 1x |
as.data.frame(lapply( |
40 | 1x |
rawdf, |
41 | 1x |
function(col) { |
42 | 7x |
if (!any(grepl(.collapse_char, col, fixed = TRUE))) { |
43 | ! |
col |
44 |
} else { |
|
45 | 7x |
I(strsplit(col, split = .collapse_char_esc)) |
46 |
} |
|
47 |
} |
|
48 |
)) |
|
49 |
} |
|
50 | ||
51 |
### Migrated to formatters ---- |
|
52 | ||
53 |
#' @importFrom formatters export_as_txt |
|
54 |
#' |
|
55 |
#' @examples |
|
56 |
#' lyt <- basic_table() %>% |
|
57 |
#' split_cols_by("ARM") %>% |
|
58 |
#' analyze(c("AGE", "BMRKR2", "COUNTRY")) |
|
59 |
#' |
|
60 |
#' tbl <- build_table(lyt, ex_adsl) |
|
61 |
#' |
|
62 |
#' cat(export_as_txt(tbl, file = NULL, paginate = TRUE, lpp = 8)) |
|
63 |
#' |
|
64 |
#' \dontrun{ |
|
65 |
#' tf <- tempfile(fileext = ".txt") |
|
66 |
#' export_as_txt(tbl, file = tf) |
|
67 |
#' system2("cat", tf) |
|
68 |
#' } |
|
69 |
#' |
|
70 |
#' @export |
|
71 |
formatters::export_as_txt |
|
72 | ||
73 |
# data.frame output ------------------------------------------------------------ |
|
74 | ||
75 |
#' Generate a result data frame |
|
76 |
#' |
|
77 |
#' Collection of utilities to extract `data.frame` objects from `TableTree` objects. |
|
78 |
#' |
|
79 |
#' @inheritParams gen_args |
|
80 |
#' @param spec (`string`)\cr the specification to use to extract the result data frame. See Details below. |
|
81 |
#' @param simplify (`flag`)\cr whether the result data frame should only have labels and result columns visible. |
|
82 |
#' @param ... additional arguments passed to spec-specific result data frame conversion function. Currently it can be |
|
83 |
#' one or more of the following parameters (valid only for `v0_experimental` spec. for now): |
|
84 |
#' - `expand_colnames`: when `TRUE`, the result data frame will have expanded column names above the usual |
|
85 |
#' output. This is useful when the result data frame is used for further processing. |
|
86 |
#' - `simplify`: when `TRUE`, the result data frame will have only visible labels and result columns. |
|
87 |
#' - `as_strings`: when `TRUE`, the result data frame will have all values as strings, as they appear |
|
88 |
#' in the final table (it can also be retrieved from `matrix_form(tt)$strings`). This is also true for |
|
89 |
#' column counts if `expand_colnames = TRUE`. |
|
90 |
#' - `as_viewer`: when `TRUE`, the result data frame will have all values as they appear in the final table, |
|
91 |
#' i.e. with the same precision and numbers, but in easy-to-use numeric form. |
|
92 |
#' - `keep_label_rows`: when `TRUE`, the result data frame will have all labels as they appear in the |
|
93 |
#' final table. |
|
94 |
#' - `as_is`: when `TRUE`, the result data frame will have all the values as they appear in the final table, |
|
95 |
#' but without information about the row structure. Row labels will be assigned to rows so to work well |
|
96 |
#' with [df_to_tt()]. |
|
97 |
#' |
|
98 |
#' @details `as_result_df()`: Result data frame specifications may differ in the exact information |
|
99 |
#' they include and the form in which they represent it. Specifications whose names end in "_experimental" |
|
100 |
#' are subject to change without notice, but specifications without the "_experimental" |
|
101 |
#' suffix will remain available *including any bugs in their construction* indefinitely. |
|
102 |
#' |
|
103 |
#' @return |
|
104 |
#' * `as_result_df` returns a result `data.frame`. |
|
105 |
#' |
|
106 |
#' @seealso [df_to_tt()] when using `as_is = TRUE` and [make_row_df()] to have a comprehensive view of the |
|
107 |
#' hierarchical structure of the rows. |
|
108 |
#' |
|
109 |
#' @examples |
|
110 |
#' lyt <- basic_table() %>% |
|
111 |
#' split_cols_by("ARM") %>% |
|
112 |
#' split_rows_by("STRATA1") %>% |
|
113 |
#' analyze(c("AGE", "BMRKR2")) |
|
114 |
#' |
|
115 |
#' tbl <- build_table(lyt, ex_adsl) |
|
116 |
#' as_result_df(tbl) |
|
117 |
#' |
|
118 |
#' @name data.frame_export |
|
119 |
#' @export |
|
120 |
as_result_df <- function(tt, spec = "v0_experimental", simplify = FALSE, ...) { |
|
121 | 24x |
checkmate::assert_class(tt, "VTableTree") |
122 | 24x |
checkmate::assert_string(spec) |
123 | 24x |
checkmate::assert_flag(simplify) |
124 | ||
125 | 24x |
if (nrow(tt) == 0) { |
126 | 2x |
return(sanitize_table_struct(tt)) |
127 |
} |
|
128 | ||
129 | 22x |
result_df_fun <- lookup_result_df_specfun(spec) |
130 | 22x |
out <- result_df_fun(tt, ...) |
131 | ||
132 | 22x |
if (simplify) { |
133 | 4x |
out <- .simplify_result_df(out) |
134 |
} |
|
135 | ||
136 | 22x |
out |
137 |
} |
|
138 | ||
139 |
# Function that selects specific outputs from the result data frame |
|
140 |
.simplify_result_df <- function(df) { |
|
141 | 4x |
col_df <- colnames(df) |
142 | 4x |
row_names_col <- which(col_df == "row_name") |
143 | 4x |
result_cols <- seq(which(col_df == "node_class") + 1, length(col_df)) |
144 | ||
145 | 4x |
df[, c(row_names_col, result_cols)] |
146 |
} |
|
147 | ||
148 |
# Not used in rtables |
|
149 |
# .split_colwidths <- function(ptabs, nctot, colwidths) { |
|
150 |
# ret <- list() |
|
151 |
# i <- 1L |
|
152 |
# |
|
153 |
# rlw <- colwidths[1] |
|
154 |
# colwidths <- colwidths[-1] |
|
155 |
# donenc <- 0 |
|
156 |
# while (donenc < nctot) { |
|
157 |
# curnc <- NCOL(ptabs[[i]]) |
|
158 |
# ret[[i]] <- c(rlw, colwidths[seq_len(curnc)]) |
|
159 |
# colwidths <- colwidths[-1 * seq_len(curnc)] |
|
160 |
# donenc <- donenc + curnc |
|
161 |
# i <- i + 1 |
|
162 |
# } |
|
163 |
# ret |
|
164 |
# } |
|
165 | ||
166 |
#' @describeIn data.frame_export A list of functions that extract result data frames from `TableTree`s. |
|
167 |
#' |
|
168 |
#' @return |
|
169 |
#' * `result_df_specs()` returns a named list of result data frame extraction functions by "specification". |
|
170 |
#' |
|
171 |
#' @examples |
|
172 |
#' result_df_specs() |
|
173 |
#' |
|
174 |
#' @export |
|
175 |
result_df_specs <- function() { |
|
176 | 44x |
list(v0_experimental = result_df_v0_experimental) |
177 |
} |
|
178 | ||
179 |
lookup_result_df_specfun <- function(spec) { |
|
180 | 22x |
if (!(spec %in% names(result_df_specs()))) { |
181 | ! |
stop( |
182 | ! |
"unrecognized result data frame specification: ", |
183 | ! |
spec, |
184 | ! |
"If that specification is correct you may need to update your version of rtables" |
185 |
) |
|
186 |
} |
|
187 | 22x |
result_df_specs()[[spec]] |
188 |
} |
|
189 | ||
190 |
result_df_v0_experimental <- function(tt, |
|
191 |
as_viewer = FALSE, |
|
192 |
as_strings = FALSE, |
|
193 |
expand_colnames = FALSE, |
|
194 |
keep_label_rows = FALSE, |
|
195 |
as_is = FALSE) { |
|
196 | 22x |
checkmate::assert_flag(as_viewer) |
197 | 22x |
checkmate::assert_flag(as_strings) |
198 | 22x |
checkmate::assert_flag(expand_colnames) |
199 | 22x |
checkmate::assert_flag(keep_label_rows) |
200 | 22x |
checkmate::assert_flag(as_is) |
201 | ||
202 | 22x |
if (as_is) { |
203 | 2x |
keep_label_rows <- TRUE |
204 | 2x |
expand_colnames <- FALSE |
205 |
} |
|
206 | ||
207 | 22x |
raw_cvals <- cell_values(tt) |
208 |
## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values |
|
209 |
## rather than a list of length 1 representing the single row. This is bad but may not be changeable |
|
210 |
## at this point. |
|
211 | 22x |
if (nrow(tt) == 1 && length(raw_cvals) > 1) { |
212 | 2x |
raw_cvals <- list(raw_cvals) |
213 |
} |
|
214 | ||
215 |
# Flatten the list of lists (rows) of cell values into a data frame |
|
216 | 22x |
cellvals <- as.data.frame(do.call(rbind, raw_cvals)) |
217 | 22x |
row.names(cellvals) <- NULL |
218 | ||
219 | 22x |
if (nrow(tt) == 1 && ncol(tt) == 1) { |
220 | 5x |
colnames(cellvals) <- names(raw_cvals) |
221 |
} |
|
222 | ||
223 | 22x |
if (as_viewer || as_strings) { |
224 |
# we keep previous calculations to check the format of the data |
|
225 | 9x |
mf_tt <- matrix_form(tt) |
226 | 9x |
mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1] |
227 | 9x |
mf_result_chars <- .remove_empty_elements(mf_result_chars) |
228 | 9x |
mf_result_numeric <- as.data.frame( |
229 | 9x |
.make_numeric_char_mf(mf_result_chars) |
230 |
) |
|
231 | 9x |
mf_result_chars <- as.data.frame(mf_result_chars) |
232 | 9x |
if (!setequal(dim(mf_result_numeric), dim(cellvals)) || !setequal(dim(mf_result_chars), dim(cellvals))) { |
233 | ! |
stop( |
234 | ! |
"The extracted numeric data.frame does not have the same dimension of the", |
235 | ! |
" cell values extracted with cell_values(). This is a bug. Please report it." |
236 | ! |
) # nocov |
237 |
} |
|
238 | 9x |
if (as_strings) { |
239 | 5x |
colnames(mf_result_chars) <- colnames(cellvals) |
240 | 5x |
cellvals <- mf_result_chars |
241 |
} else { |
|
242 | 4x |
colnames(mf_result_numeric) <- colnames(cellvals) |
243 | 4x |
cellvals <- mf_result_numeric |
244 |
} |
|
245 |
} |
|
246 | ||
247 | 22x |
rdf <- make_row_df(tt) |
248 | ||
249 | 22x |
df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")] |
250 |
# Removing initial root elements from path (out of the loop -> right maxlen) |
|
251 | 22x |
df$path <- lapply(df$path, .remove_root_elems_from_path, |
252 | 22x |
which_root_name = c("root", "rbind_root"), |
253 | 22x |
all = TRUE |
254 |
) |
|
255 | 22x |
maxlen <- max(lengths(df$path)) |
256 | ||
257 |
# Loop for metadata (path and details from make_row_df) |
|
258 | 22x |
metadf <- do.call( |
259 | 22x |
rbind.data.frame, |
260 | 22x |
lapply( |
261 | 22x |
seq_len(NROW(df)), |
262 | 22x |
function(ii) { |
263 | 433x |
handle_rdf_row(df[ii, ], maxlen = maxlen) |
264 |
} |
|
265 |
) |
|
266 |
) |
|
267 | ||
268 |
# Should we keep label rows with NAs instead of values? |
|
269 | 22x |
if (keep_label_rows) { |
270 | 7x |
cellvals_mat_struct <- as.data.frame( |
271 | 7x |
matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals)) |
272 |
) |
|
273 | 7x |
colnames(cellvals_mat_struct) <- colnames(cellvals) |
274 | 7x |
cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals |
275 | 7x |
ret <- cbind(metadf, cellvals_mat_struct) |
276 |
} else { |
|
277 | 15x |
ret <- cbind( |
278 | 15x |
metadf[metadf$node_class != "LabelRow", ], |
279 | 15x |
cellvals |
280 |
) |
|
281 |
} |
|
282 | ||
283 |
# If we want to expand colnames |
|
284 | 22x |
if (expand_colnames) { |
285 | 6x |
col_name_structure <- .get_formatted_colnames(clayout(tt)) |
286 | 6x |
number_of_non_data_cols <- which(colnames(ret) == "node_class") |
287 | 6x |
if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) { |
288 | ! |
stop( |
289 | ! |
"When expanding colnames structure, we were not able to find the same", |
290 | ! |
" number of columns as in the result data frame. This is a bug. Please report it." |
291 | ! |
) # nocov |
292 |
} |
|
293 | ||
294 | 6x |
buffer_rows_for_colnames <- matrix( |
295 | 6x |
rep("<only_for_column_names>", number_of_non_data_cols * NROW(col_name_structure)), |
296 | 6x |
nrow = NROW(col_name_structure) |
297 |
) |
|
298 | ||
299 | 6x |
header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure)) |
300 | 6x |
colnames(header_colnames_matrix) <- colnames(ret) |
301 | ||
302 | 6x |
count_row <- NULL |
303 | 6x |
if (disp_ccounts(tt)) { |
304 | 3x |
ccounts <- col_counts(tt) |
305 | 3x |
if (as_strings) { |
306 | 2x |
ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ] |
307 | 2x |
ccounts <- .remove_empty_elements(ccounts) |
308 |
} |
|
309 | 3x |
count_row <- c(rep("<only_for_column_counts>", number_of_non_data_cols), ccounts) |
310 | 3x |
header_colnames_matrix <- rbind(header_colnames_matrix, count_row) |
311 |
} |
|
312 | 6x |
ret <- rbind(header_colnames_matrix, ret) |
313 |
} |
|
314 | ||
315 |
# Using only labels for row names and losing information about paths |
|
316 | 22x |
if (as_is) { |
317 | 2x |
tmp_rownames <- ret$label_name |
318 | 2x |
ret <- ret[, -seq_len(which(colnames(ret) == "node_class"))] |
319 | 2x |
if (length(unique(tmp_rownames)) == length(tmp_rownames)) { |
320 | 1x |
rownames(ret) <- tmp_rownames |
321 |
} else { |
|
322 | 1x |
ret <- cbind("label_name" = tmp_rownames, ret) |
323 | 1x |
rownames(ret) <- NULL |
324 |
} |
|
325 |
} else { |
|
326 | 20x |
rownames(ret) <- NULL |
327 |
} |
|
328 | ||
329 | 22x |
ret |
330 |
} |
|
331 | ||
332 |
.remove_empty_elements <- function(char_df) { |
|
333 | 11x |
if (is.null(dim(char_df))) { |
334 | 5x |
return(char_df[nzchar(char_df, keepNA = TRUE)]) |
335 |
} |
|
336 | ||
337 | 6x |
apply(char_df, 2, function(col_i) col_i[nzchar(col_i, keepNA = TRUE)]) |
338 |
} |
|
339 | ||
340 |
# Helper function to make the character matrix numeric |
|
341 |
.make_numeric_char_mf <- function(char_df) { |
|
342 | 9x |
if (is.null(dim(char_df))) { |
343 | 3x |
return(as.numeric(stringi::stri_extract_all(char_df, regex = "\\d+.\\d+|\\d+"))) |
344 |
} |
|
345 | ||
346 | 6x |
ret <- apply(char_df, 2, function(col_i) { |
347 | 27x |
lapply( |
348 | 27x |
stringi::stri_extract_all(col_i, regex = "\\d+.\\d+|\\d+"), |
349 | 27x |
as.numeric |
350 |
) |
|
351 |
}) |
|
352 | ||
353 | 6x |
do.call(cbind, ret) |
354 |
} |
|
355 | ||
356 |
make_result_df_md_colnames <- function(maxlen) { |
|
357 | 433x |
spllen <- floor((maxlen - 2) / 2) |
358 | 433x |
ret <- character() |
359 | 433x |
if (spllen > 0) { |
360 | 387x |
ret <- paste(c("spl_var", "spl_value"), rep(seq_len(spllen), rep(2, spllen)), sep = "_") |
361 |
} |
|
362 | 433x |
ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class")) |
363 |
} |
|
364 | ||
365 |
do_label_row <- function(rdfrow, maxlen) { |
|
366 | 143x |
pth <- rdfrow$path[[1]] |
367 |
# Adjusting for the fact that we have two columns for each split |
|
368 | 143x |
extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2 |
369 | ||
370 |
# Special cases with hidden labels |
|
371 | 143x |
if (length(pth) %% 2 == 1) { |
372 | 108x |
extra_nas_from_splits <- extra_nas_from_splits + 1 |
373 |
} |
|
374 | ||
375 | 143x |
c( |
376 | 143x |
as.list(pth[seq_len(length(pth) - 1)]), |
377 | 143x |
as.list(replicate(extra_nas_from_splits, list(NA_character_))), |
378 | 143x |
as.list(tail(pth, 1)), |
379 | 143x |
list( |
380 | 143x |
label_name = rdfrow$label, |
381 | 143x |
row_num = rdfrow$abs_rownumber, |
382 | 143x |
content = FALSE, |
383 | 143x |
node_class = rdfrow$node_class |
384 |
) |
|
385 |
) |
|
386 |
} |
|
387 | ||
388 |
do_content_row <- function(rdfrow, maxlen) { |
|
389 | 36x |
pth <- rdfrow$path[[1]] |
390 | 36x |
contpos <- which(pth == "@content") |
391 | ||
392 | 36x |
seq_before <- seq_len(contpos - 1) |
393 | ||
394 | 36x |
c( |
395 | 36x |
as.list(pth[seq_before]), |
396 | 36x |
as.list(replicate(maxlen - contpos, list(NA_character_))), |
397 | 36x |
list(tail(pth, 1)), |
398 | 36x |
list( |
399 | 36x |
label_name = rdfrow$label, |
400 | 36x |
row_num = rdfrow$abs_rownumber, |
401 | 36x |
content = TRUE, |
402 | 36x |
node_class = rdfrow$node_class |
403 |
) |
|
404 |
) |
|
405 |
} |
|
406 | ||
407 |
do_data_row <- function(rdfrow, maxlen) { |
|
408 | 254x |
pth <- rdfrow$path[[1]] |
409 | 254x |
pthlen <- length(pth) |
410 |
## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame |
|
411 | 254x |
if (pthlen %% 2 == 1) { |
412 | 38x |
pth <- pth[-1 * (pthlen - 2)] |
413 |
} |
|
414 | 254x |
pthlen_new <- length(pth) |
415 | 33x |
if (maxlen == 1) pthlen_new <- 3 |
416 | 254x |
c( |
417 | 254x |
as.list(pth[seq_len(pthlen_new - 2)]), |
418 | 254x |
replicate(maxlen - pthlen, list(NA_character_)), |
419 | 254x |
as.list(tail(pth, 2)), |
420 | 254x |
list( |
421 | 254x |
label_name = rdfrow$label, |
422 | 254x |
row_num = rdfrow$abs_rownumber, |
423 | 254x |
content = FALSE, |
424 | 254x |
node_class = rdfrow$node_class |
425 |
) |
|
426 |
) |
|
427 |
} |
|
428 | ||
429 |
.remove_root_elems_from_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) { |
|
430 | 434x |
any_root_paths <- path[1] %in% which_root_name |
431 | 434x |
if (any_root_paths) { |
432 | 274x |
if (isTRUE(all)) { |
433 |
# Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later) |
|
434 | 274x |
root_indices <- which(path %in% which_root_name) |
435 | 274x |
if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE |
436 | ! |
end_point_root_headers <- which(diff(root_indices) > 1)[1] |
437 |
} else { |
|
438 | 274x |
end_point_root_headers <- length(root_indices) |
439 |
} |
|
440 | 274x |
root_path_to_remove <- seq_len(end_point_root_headers) |
441 |
} else { |
|
442 | ! |
root_path_to_remove <- 1 |
443 |
} |
|
444 | 274x |
path <- path[-root_path_to_remove] |
445 |
} |
|
446 | ||
447 |
# Fix for very edge case where we have only root elements |
|
448 | 434x |
if (length(path) == 0) { |
449 | 1x |
path <- which_root_name[1] |
450 |
} |
|
451 | ||
452 | 434x |
path |
453 |
} |
|
454 | ||
455 |
handle_rdf_row <- function(rdfrow, maxlen) { |
|
456 | 433x |
nclass <- rdfrow$node_class |
457 | ||
458 | 433x |
ret <- switch(nclass, |
459 | 433x |
LabelRow = do_label_row(rdfrow, maxlen), |
460 | 433x |
ContentRow = do_content_row(rdfrow, maxlen), |
461 | 433x |
DataRow = do_data_row(rdfrow, maxlen), |
462 | 433x |
stop("Unrecognized node type in row dataframe, unable to generate result data frame") |
463 |
) |
|
464 | 433x |
setNames(ret, make_result_df_md_colnames(maxlen)) |
465 |
} |
|
466 | ||
467 |
# Helper recurrent function to get the column names for the result data frame from the VTableTree |
|
468 |
.get_formatted_colnames <- function(clyt) { |
|
469 | 41x |
ret <- obj_label(clyt) |
470 | 41x |
if (!nzchar(ret)) { |
471 | 6x |
ret <- NULL |
472 |
} |
|
473 | 41x |
if (is.null(tree_children(clyt))) { |
474 | ! |
return(ret) |
475 |
} else { |
|
476 | 41x |
ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames))) |
477 | 41x |
colnames(ret) <- NULL |
478 | 41x |
rownames(ret) <- NULL |
479 | 41x |
return(ret) |
480 |
} |
|
481 |
} |
|
482 | ||
483 |
#' @describeIn data.frame_export Transform a `TableTree` object to a path-enriched `data.frame`. |
|
484 |
#' |
|
485 |
#' @param path_fun (`function`)\cr function to transform paths into single-string row/column names. |
|
486 |
#' @param value_fun (`function`)\cr function to transform cell values into cells of a `data.frame`. Defaults to |
|
487 |
#' `collapse_values`, which creates strings where multi-valued cells are collapsed together, separated by `|`. |
|
488 |
#' |
|
489 |
#' @return |
|
490 |
#' * `path_enriched_df()` returns a `data.frame` of `tt`'s cell values (processed by `value_fun`, with columns named by |
|
491 |
#' the full column paths (processed by `path_fun` and an additional `row_path` column with the row paths (processed |
|
492 |
#' by `path_fun`). |
|
493 |
#' |
|
494 |
#' @examples |
|
495 |
#' lyt <- basic_table() %>% |
|
496 |
#' split_cols_by("ARM") %>% |
|
497 |
#' analyze(c("AGE", "BMRKR2")) |
|
498 |
#' |
|
499 |
#' tbl <- build_table(lyt, ex_adsl) |
|
500 |
#' path_enriched_df(tbl) |
|
501 |
#' |
|
502 |
#' @export |
|
503 |
path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) { |
|
504 | 3x |
rdf <- make_row_df(tt) |
505 | 3x |
cdf <- make_col_df(tt) |
506 | 3x |
cvs <- as.data.frame(do.call(rbind, cell_values(tt))) |
507 | 3x |
cvs <- as.data.frame(lapply(cvs, value_fun)) |
508 | 3x |
row.names(cvs) <- NULL |
509 | 3x |
colnames(cvs) <- path_fun(cdf$path) |
510 | 3x |
preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path) |
511 | 3x |
cbind.data.frame(row_path = preppaths, cvs) |
512 |
} |
|
513 | ||
514 |
.collapse_char <- "|" |
|
515 |
.collapse_char_esc <- "\\|" |
|
516 | ||
517 |
collapse_path <- function(paths) { |
|
518 | 196x |
if (is.list(paths)) { |
519 | 6x |
return(vapply(paths, collapse_path, "")) |
520 |
} |
|
521 | 190x |
paste(paths, collapse = .collapse_char) |
522 |
} |
|
523 | ||
524 |
collapse_values <- function(colvals) { |
|
525 | 13x |
if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1)) |
526 | ! |
return(colvals) |
527 | 13x |
} else if (all(vapply(colvals, length, 1L) == 1)) { |
528 | 1x |
return(unlist(colvals)) |
529 |
} |
|
530 | 12x |
vapply(colvals, paste, "", collapse = .collapse_char) |
531 |
} |
|
532 | ||
533 |
# pdf output ------------------------------------------------------------------- |
|
534 | ||
535 |
### Export as PDF - migrated to formatters |
|
536 | ||
537 |
#' @importFrom formatters export_as_pdf |
|
538 |
#' |
|
539 |
#' @examples |
|
540 |
#' lyt <- basic_table() %>% |
|
541 |
#' split_cols_by("ARM") %>% |
|
542 |
#' analyze(c("AGE", "BMRKR2", "COUNTRY")) |
|
543 |
#' |
|
544 |
#' tbl <- build_table(lyt, ex_adsl) |
|
545 |
#' |
|
546 |
#' \dontrun{ |
|
547 |
#' tf <- tempfile(fileext = ".pdf") |
|
548 |
#' export_as_pdf(tbl, file = tf, pg_height = 4) |
|
549 |
#' tf <- tempfile(fileext = ".pdf") |
|
550 |
#' export_as_pdf(tbl, file = tf, lpp = 8) |
|
551 |
#' } |
|
552 |
#' |
|
553 |
#' @export |
|
554 |
formatters::export_as_pdf |
|
555 | ||
556 |
# only used in pagination |
|
557 |
.tab_to_colpath_set <- function(tt) { |
|
558 | 4x |
vapply( |
559 | 4x |
collect_leaves(coltree(tt)), |
560 | 4x |
function(y) paste(pos_to_path(tree_pos(y)), collapse = " "), |
561 |
"" |
|
562 |
) |
|
563 |
} |
|
564 |
.figure_out_colinds <- function(subtab, fulltab) { |
|
565 | 2x |
match( |
566 | 2x |
.tab_to_colpath_set(subtab), |
567 | 2x |
.tab_to_colpath_set(fulltab) |
568 |
) |
|
569 |
} |
|
570 | ||
571 |
# Flextable and docx ----------------------------------------------------------- |
|
572 | ||
573 |
#' Export as word document |
|
574 |
#' |
|
575 |
#' From a table, produce a self-contained word document or attach it to a template word |
|
576 |
#' file (`template_file`). This function is based on the [tt_to_flextable()] transformer and |
|
577 |
#' the `officer` package. |
|
578 |
#' |
|
579 |
#' @inheritParams gen_args |
|
580 |
#' @param file (`string`)\cr string that indicates the final file output. Must have `.docx` extension. |
|
581 |
#' @param doc_metadata (`list` of `string`s)\cr any value that can be used as metadata by |
|
582 |
#' `?officer::set_doc_properties`. Important text values are `title`, `subject`, `creator`, and `description`, |
|
583 |
#' while `created` is a date object. |
|
584 |
#' @inheritParams tt_to_flextable |
|
585 |
#' @param template_file (`string`)\cr template file that `officer` will use as a starting point for the final |
|
586 |
#' document. Document attaches the table and uses the defaults defined in the template file. |
|
587 |
#' @param section_properties (`officer::prop_section`)\cr an [officer::prop_section()] object which sets margins and |
|
588 |
#' page size. |
|
589 |
#' |
|
590 |
#' @note `export_as_docx()` has few customization options available. If you require specific formats and details, |
|
591 |
#' we suggest that you use [tt_to_flextable()] prior to `export_as_docx`. Only the `title_as_header` and |
|
592 |
#' `footer_as_text` parameters must be re-specified if the table is changed first using [tt_to_flextable()]. |
|
593 |
#' |
|
594 |
#' @seealso [tt_to_flextable()] |
|
595 |
#' |
|
596 |
#' @examples |
|
597 |
#' lyt <- basic_table() %>% |
|
598 |
#' split_cols_by("ARM") %>% |
|
599 |
#' analyze(c("AGE", "BMRKR2", "COUNTRY")) |
|
600 |
#' |
|
601 |
#' tbl <- build_table(lyt, ex_adsl) |
|
602 |
#' |
|
603 |
#' # See how section_properties_portrait function is built for custom |
|
604 |
#' \dontrun{ |
|
605 |
#' tf <- tempfile(fileext = ".docx") |
|
606 |
#' export_as_docx(tbl, file = tf, section_properties = section_properties_portrait()) |
|
607 |
#' } |
|
608 |
#' |
|
609 |
#' @export |
|
610 |
export_as_docx <- function(tt, |
|
611 |
file, |
|
612 |
doc_metadata = NULL, |
|
613 |
titles_as_header = FALSE, |
|
614 |
footers_as_text = TRUE, |
|
615 |
template_file = NULL, |
|
616 |
section_properties = NULL) { |
|
617 |
# Checks |
|
618 | 3x |
check_required_packages(c("flextable", "officer")) |
619 | 3x |
if (inherits(tt, "VTableTree")) { |
620 | 2x |
flex_tbl <- tt_to_flextable(tt, |
621 | 2x |
titles_as_header = titles_as_header, |
622 | 2x |
footers_as_text = footers_as_text |
623 |
) |
|
624 | 2x |
if (isFALSE(titles_as_header) || isTRUE(footers_as_text)) { |
625 |
# Ugly but I could not find a getter for font.size |
|
626 | 2x |
font_sz <- flex_tbl$header$styles$text$font.size$data[1, 1] |
627 | 2x |
font_sz_footer <- flex_tbl$header$styles$text$font.size$data[1, 1] - 1 |
628 | 2x |
font_fam <- flex_tbl$header$styles$text$font.family$data[1, 1] |
629 | ||
630 |
# Set the test as the tt |
|
631 | 2x |
fpt <- officer::fp_text(font.family = font_fam, font.size = font_sz) |
632 | 2x |
fpt_footer <- officer::fp_text(font.family = font_fam, font.size = font_sz_footer) |
633 |
} |
|
634 |
} else { |
|
635 | 1x |
flex_tbl <- tt |
636 |
} |
|
637 | 3x |
if (!is.null(template_file) && !file.exists(template_file)) { |
638 | 1x |
template_file <- NULL |
639 |
} |
|
640 | ||
641 |
# Create a new empty Word document |
|
642 | 3x |
if (!is.null(template_file)) { |
643 | 2x |
doc <- officer::read_docx(template_file) |
644 |
} else { |
|
645 | 1x |
doc <- officer::read_docx() |
646 |
} |
|
647 | ||
648 | 3x |
if (!is.null(section_properties)) { |
649 | 3x |
doc <- officer::body_set_default_section(doc, section_properties) |
650 |
} |
|
651 | ||
652 |
# Extract title |
|
653 | 3x |
if (isFALSE(titles_as_header) && inherits(tt, "VTableTree")) { |
654 | 2x |
ts_tbl <- all_titles(tt) |
655 | 2x |
if (length(ts_tbl) > 0) { |
656 | 2x |
doc <- add_text_par(doc, ts_tbl, fpt) |
657 |
} |
|
658 |
} |
|
659 | ||
660 |
# Add the table to the document |
|
661 | 3x |
doc <- flextable::body_add_flextable(doc, flex_tbl, align = "left") |
662 | ||
663 |
# add footers as paragraphs |
|
664 | 3x |
if (isTRUE(footers_as_text) && inherits(tt, "VTableTree")) { |
665 |
# Adding referantial footer line separator if present |
|
666 |
# (this is usually done differently, i.e. inside footnotes) |
|
667 | 2x |
matform <- matrix_form(tt, indent_rownames = TRUE) |
668 | 2x |
if (length(matform$ref_footnotes) > 0) { |
669 | 2x |
doc <- add_text_par(doc, matform$ref_footnotes, fpt_footer) |
670 |
} |
|
671 |
# Footer lines |
|
672 | 2x |
if (length(all_footers(tt)) > 0) { |
673 | 2x |
doc <- add_text_par(doc, all_footers(tt), fpt_footer) |
674 |
} |
|
675 |
} |
|
676 | ||
677 | 3x |
if (!is.null(doc_metadata)) { |
678 |
# Checks for values rely on officer function |
|
679 | 3x |
doc <- do.call(officer::set_doc_properties, c(list("x" = doc), doc_metadata)) |
680 |
} |
|
681 | ||
682 |
# Save the Word document to a file |
|
683 | 3x |
print(doc, target = file) |
684 |
} |
|
685 | ||
686 |
# Shorthand to add text paragraph |
|
687 |
add_text_par <- function(doc, chr_v, text_format) { |
|
688 | 6x |
for (ii in seq_along(chr_v)) { |
689 | 16x |
cur_fp <- officer::fpar(officer::ftext(chr_v[ii], prop = text_format)) |
690 | 16x |
doc <- officer::body_add_fpar(doc, cur_fp) |
691 |
} |
|
692 | 6x |
doc |
693 |
} |
|
694 | ||
695 |
#' @describeIn export_as_docx Helper function that defines standard portrait properties for tables. |
|
696 |
#' @export |
|
697 |
section_properties_portrait <- function() { |
|
698 | 2x |
officer::prop_section( |
699 | 2x |
page_size = officer::page_size( |
700 | 2x |
orient = "portrait", |
701 | 2x |
width = 8.5, height = 11 |
702 |
), |
|
703 | 2x |
type = "continuous", |
704 | 2x |
page_margins = margins_potrait() |
705 |
) |
|
706 |
} |
|
707 | ||
708 |
#' @describeIn export_as_docx Helper function that defines standard landscape properties for tables. |
|
709 |
#' @export |
|
710 |
section_properties_landscape <- function() { |
|
711 | 1x |
officer::prop_section( |
712 | 1x |
page_size = officer::page_size( |
713 | 1x |
orient = "landscape", |
714 | 1x |
width = 8.5, height = 11 |
715 |
), |
|
716 | 1x |
type = "continuous", |
717 | 1x |
page_margins = margins_landscape() |
718 |
) |
|
719 |
} |
|
720 | ||
721 |
#' @describeIn export_as_docx Helper function that defines standard portrait margins for tables. |
|
722 |
#' @export |
|
723 |
margins_potrait <- function() { |
|
724 | 2x |
officer::page_mar(bottom = 0.98, top = 0.95, left = 1.5, right = 1, gutter = 0) |
725 |
} |
|
726 |
#' @describeIn export_as_docx Helper function that defines standard landscape margins for tables. |
|
727 |
#' @export |
|
728 |
margins_landscape <- function() { |
|
729 | 1x |
officer::page_mar(bottom = 1, top = 1.5, left = 0.98, right = 0.95, gutter = 0) |
730 |
} |
|
731 | ||
732 |
#' Create a `flextable` from an `rtables` table |
|
733 |
#' |
|
734 |
#' Principally used for export ([export_as_docx()]), this function produces a `flextable` |
|
735 |
#' from an `rtables` table. If `theme = NULL`, `rtables`-like style will be used. Otherwise, |
|
736 |
#' [theme_docx_default()] will produce a `.docx`-friendly table. |
|
737 |
#' |
|
738 |
#' @inheritParams gen_args |
|
739 |
#' @inheritParams paginate_table |
|
740 |
#' @param theme (`function` or `NULL`)\cr A theme function that is designed internally as a function of a `flextable` |
|
741 |
#' object to change its layout and style. If `NULL`, it will produce a table similar to `rtables` default. Defaults |
|
742 |
#' to `theme_docx_default(tt)`. |
|
743 |
#' @param border (`officer` border object)\cr defaults to `officer::fp_border(width = 0.5)`. |
|
744 |
#' @param indent_size (`integer(1)`)\cr if `NULL`, the default indent size of the table (see [matrix_form()] |
|
745 |
#' `indent_size`) is used. To work with `docx`, any size is multiplied by 2 mm (5.67 pt) by default. |
|
746 |
#' @param titles_as_header (`flag`)\cr defaults to `TRUE` for [tt_to_flextable()], so the table is self-contained |
|
747 |
#' as it makes additional header rows for [main_title()] string and [subtitles()] character vector (one per element). |
|
748 |
#' `FALSE` is suggested for [export_as_docx()]. This adds titles and subtitles as a text paragraph above the table. |
|
749 |
#' The same style is applied. |
|
750 |
#' @param footers_as_text (`flag`)\cr defaults to `FALSE` for [tt_to_flextable()], so the table is self-contained with |
|
751 |
#' the `flextable` definition of footnotes. `TRUE` is used for [export_as_docx()] to add the footers as a new |
|
752 |
#' paragraph after the table. The same style is applied, but with a smaller font. |
|
753 |
#' @param counts_in_newline (`flag`)\cr defaults to `FALSE`. In `rtables` text printing ([formatters::toString()]), |
|
754 |
#' the column counts, i.e. `(N=xx)`, are always on a new line. For `docx` exports it could be necessary to print it |
|
755 |
#' on the same line. |
|
756 |
#' @param paginate (`flag`)\cr when exporting `.docx` documents using `export_as_docx`, we suggest relying on the |
|
757 |
#' Microsoft Word pagination system. If `TRUE`, this option splits `tt` into different "pages" as multiple |
|
758 |
#' `flextables`. Cooperation between the two mechanisms is not guaranteed. Defaults to `FALSE`. |
|
759 |
#' @param total_width (`numeric(1)`)\cr total width (in inches) for the resulting flextable(s). Defaults to 10. |
|
760 |
#' |
|
761 |
#' @return A `flextable` object. |
|
762 |
#' |
|
763 |
#' @seealso [export_as_docx()] |
|
764 |
#' |
|
765 |
#' @examples |
|
766 |
#' analysisfun <- function(x, ...) { |
|
767 |
#' in_rows( |
|
768 |
#' row1 = 5, |
|
769 |
#' row2 = c(1, 2), |
|
770 |
#' .row_footnotes = list(row1 = "row 1 - row footnote"), |
|
771 |
#' .cell_footnotes = list(row2 = "row 2 - cell footnote") |
|
772 |
#' ) |
|
773 |
#' } |
|
774 |
#' |
|
775 |
#' lyt <- basic_table( |
|
776 |
#' title = "Title says Whaaaat", subtitles = "Oh, ok.", |
|
777 |
#' main_footer = "ha HA! Footer!" |
|
778 |
#' ) %>% |
|
779 |
#' split_cols_by("ARM") %>% |
|
780 |
#' analyze("AGE", afun = analysisfun) |
|
781 |
#' |
|
782 |
#' tbl <- build_table(lyt, ex_adsl) |
|
783 |
#' # rtables style |
|
784 |
#' tt_to_flextable(tbl, theme = NULL) |
|
785 |
#' |
|
786 |
#' tt_to_flextable(tbl, theme = theme_docx_default(tbl, font_size = 7)) |
|
787 |
#' |
|
788 |
#' @export |
|
789 |
tt_to_flextable <- function(tt, |
|
790 |
theme = theme_docx_default(tt), |
|
791 |
border = flextable::fp_border_default(width = 0.5), |
|
792 |
indent_size = NULL, |
|
793 |
titles_as_header = TRUE, |
|
794 |
footers_as_text = FALSE, |
|
795 |
counts_in_newline = FALSE, |
|
796 |
paginate = FALSE, |
|
797 |
lpp = NULL, |
|
798 |
cpp = NULL, |
|
799 |
..., |
|
800 |
colwidths = propose_column_widths(matrix_form(tt, indent_rownames = TRUE)), |
|
801 |
tf_wrap = !is.null(cpp), |
|
802 |
max_width = cpp, |
|
803 |
total_width = 10) { |
|
804 | 13x |
check_required_packages("flextable") |
805 | 13x |
if (!inherits(tt, "VTableTree")) { |
806 | ! |
stop("Input table is not an rtables' object.") |
807 |
} |
|
808 | 13x |
checkmate::assert_flag(titles_as_header) |
809 | 13x |
checkmate::assert_flag(footers_as_text) |
810 | 13x |
checkmate::assert_flag(counts_in_newline) |
811 | ||
812 |
## if we're paginating, just call -> pagination happens also afterwards if needed |
|
813 | 13x |
if (paginate) { |
814 | 1x |
if (is.null(lpp)) { |
815 | ! |
stop("lpp must be specified when calling tt_to_flextable with paginate=TRUE") |
816 |
} |
|
817 | 1x |
tabs <- paginate_table(tt, lpp = lpp, cpp = cpp, tf_wrap = tf_wrap, max_width = max_width, ...) |
818 | 1x |
cinds <- lapply(tabs, function(tb) c(1, .figure_out_colinds(tb, tt) + 1L)) |
819 | 1x |
return(mapply(tt_to_flextable, |
820 | 1x |
tt = tabs, colwidths = cinds, |
821 | 1x |
MoreArgs = list(paginate = FALSE, total_width = total_width), |
822 | 1x |
SIMPLIFY = FALSE |
823 |
)) |
|
824 |
} |
|
825 | ||
826 |
# Calculate the needed colwidths |
|
827 | 12x |
final_cwidths <- total_width * colwidths / sum(colwidths) # xxx to fix |
828 |
# xxx FIXME missing transformer from character based widths to mm or pt |
|
829 | ||
830 |
# Extract relevant information |
|
831 | 12x |
matform <- matrix_form(tt, indent_rownames = TRUE) |
832 | 12x |
body <- mf_strings(matform) # Contains header |
833 | 12x |
spans <- mf_spans(matform) # Contains header |
834 | 12x |
mpf_aligns <- mf_aligns(matform) # Contains header |
835 | 12x |
hnum <- mf_nlheader(matform) # Number of lines for the header |
836 | 12x |
rdf <- make_row_df(tt) # Row-wise info |
837 | ||
838 |
# decimal alignment pre-proc |
|
839 | 12x |
if (any(grepl("dec", mpf_aligns))) { |
840 | ! |
body <- decimal_align(body, mpf_aligns) |
841 |
# Coercion for flextable |
|
842 | ! |
mpf_aligns[mpf_aligns == "decimal"] <- "center" |
843 | ! |
mpf_aligns[mpf_aligns == "dec_left"] <- "left" |
844 | ! |
mpf_aligns[mpf_aligns == "dec_right"] <- "right" |
845 |
} |
|
846 | ||
847 |
# Fundamental content of the table |
|
848 | 12x |
content <- as.data.frame(body[-seq_len(hnum), , drop = FALSE]) |
849 | 12x |
flx <- flextable::qflextable(content) %>% |
850 |
# Default rtables if no footnotes |
|
851 | 12x |
remove_hborder(part = "body", w = "bottom") |
852 | ||
853 |
# Header addition -> NB: here we have a problem with (N=xx) |
|
854 | 12x |
hdr <- body[seq_len(hnum), , drop = FALSE] |
855 | ||
856 |
# IMPORTANT: Fix of (N=xx) which is by default on a new line but we usually do not |
|
857 |
# want this, and it depends on the size of the table, it is not another |
|
858 |
# row with different columns -> All of this should be fixed at source (in toString) |
|
859 | 12x |
if (hnum > 1) { # otherwise nothing to do |
860 | 12x |
det_nclab <- apply(hdr, 2, grepl, pattern = "\\(N=[0-9]+\\)$") |
861 | 12x |
has_nclab <- apply(det_nclab, 1, any) |
862 | 12x |
if (isFALSE(counts_in_newline) && any(has_nclab)) { |
863 | 5x |
whsnc <- which(has_nclab) # which rows have it |
864 | 5x |
what_is_nclab <- det_nclab[whsnc, ] |
865 | ||
866 |
# condition for popping the interested row by merging the upper one |
|
867 | 5x |
hdr[whsnc, what_is_nclab] <- paste(hdr[whsnc - 1, what_is_nclab], |
868 | 5x |
hdr[whsnc, what_is_nclab], |
869 | 5x |
sep = " " |
870 |
) |
|
871 | 5x |
hdr[whsnc - 1, what_is_nclab] <- "" |
872 | ||
873 |
# We can remove the row if they are all "" |
|
874 | 5x |
row_to_pop <- whsnc - 1 |
875 | 5x |
if (all(!nzchar(hdr[row_to_pop, ]))) { |
876 | 4x |
hdr <- hdr[-row_to_pop, , drop = FALSE] |
877 | 4x |
spans <- spans[-row_to_pop, , drop = FALSE] |
878 | 4x |
body <- body[-row_to_pop, , drop = FALSE] |
879 | 4x |
mpf_aligns <- mpf_aligns[-row_to_pop, , drop = FALSE] |
880 | 4x |
hnum <- hnum - 1 |
881 |
} |
|
882 |
} |
|
883 |
} |
|
884 | ||
885 | 12x |
flx <- flx %>% |
886 | 12x |
flextable::set_header_labels( # Needed bc headers must be unique |
887 | 12x |
values = setNames( |
888 | 12x |
as.vector(hdr[hnum, , drop = TRUE]), |
889 | 12x |
names(content) |
890 |
) |
|
891 |
) |
|
892 |
# If there are more rows |
|
893 | 12x |
if (hnum > 1) { |
894 | 11x |
for (i in seq(hnum - 1, 1)) { |
895 | 11x |
sel <- spans_to_viscell(spans[i, ]) |
896 | 11x |
flx <- flextable::add_header_row( |
897 | 11x |
flx, |
898 | 11x |
top = TRUE, |
899 | 11x |
values = as.vector(hdr[i, sel]), |
900 | 11x |
colwidths = as.integer(spans[i, sel]) # xxx to fix |
901 |
) |
|
902 |
} |
|
903 |
} |
|
904 | ||
905 |
# Polish the inner horizontal borders from the header |
|
906 | 12x |
flx <- flx %>% |
907 | 12x |
remove_hborder(part = "header", w = "all") %>% |
908 | 12x |
add_hborder("header", ii = c(0, hnum), border = border) |
909 | ||
910 |
# ALIGNS |
|
911 | 12x |
flx <- flx %>% |
912 | 12x |
apply_alignments(mpf_aligns[seq_len(hnum), , drop = FALSE], "header") %>% |
913 | 12x |
apply_alignments(mpf_aligns[-seq_len(hnum), , drop = FALSE], "body") |
914 | ||
915 |
# Rownames indentation |
|
916 | 12x |
checkmate::check_int(indent_size, null.ok = TRUE) |
917 | 12x |
if (is.null(indent_size)) { |
918 | 12x |
indent_size <- matform$indent_size * word_mm_to_pt(2) # default is 2mm (5.7pt) |
919 |
} |
|
920 | 12x |
for (i in seq_len(NROW(tt))) { |
921 | 229x |
flx <- flextable::padding(flx, |
922 | 229x |
i = i, j = 1, |
923 | 229x |
padding.left = indent_size * rdf$indent[[i]] + word_mm_to_pt(0.1), # 0.1 mmm in pt |
924 | 229x |
padding.right = word_mm_to_pt(0.1) # 0.1 mmm in pt (so not to touch the border) |
925 |
) |
|
926 |
} |
|
927 | ||
928 |
# Adding referantial footer line separator if present |
|
929 | 12x |
if (length(matform$ref_footnotes) > 0 && isFALSE(footers_as_text)) { |
930 | 7x |
flx <- flextable::add_footer_lines(flx, values = matform$ref_footnotes) %>% |
931 | 7x |
add_hborder(part = "body", ii = nrow(tt), border = border) |
932 |
} |
|
933 | ||
934 |
# Footer lines |
|
935 | 12x |
if (length(all_footers(tt)) > 0 && isFALSE(footers_as_text)) { |
936 | 1x |
flx <- flextable::add_footer_lines(flx, values = all_footers(tt)) |
937 |
} |
|
938 | ||
939 | 12x |
flx <- flextable::width(flx, width = final_cwidths) # xxx to fix |
940 | ||
941 | 12x |
if (!is.null(theme)) { |
942 | 11x |
flx <- theme(flx) |
943 |
} |
|
944 | ||
945 |
# Title lines (after theme for problems with lines) |
|
946 | 11x |
if (titles_as_header && length(all_titles(tt)) > 0 && any(nzchar(all_titles(tt)))) { |
947 | 1x |
real_titles <- all_titles(tt) |
948 | 1x |
real_titles <- real_titles[nzchar(real_titles)] |
949 | 1x |
flx <- flextable::add_header_lines(flx, values = real_titles, top = TRUE) %>% |
950 |
# Remove the added borders |
|
951 | 1x |
remove_hborder(part = "header", w = c("inner", "top")) %>% |
952 |
# Re-add the separator between titles and real headers |
|
953 | 1x |
add_hborder( |
954 | 1x |
part = "header", ii = length(real_titles), |
955 | 1x |
border = border |
956 |
) %>% |
|
957 |
# Remove vertical borders added by theme eventually |
|
958 | 1x |
remove_vborder(part = "header", ii = seq_along(real_titles)) |
959 |
} |
|
960 | ||
961 |
# These final formatting need to work with colwidths |
|
962 | 11x |
flx <- flextable::set_table_properties(flx, layout = "autofit", align = "left") # xxx to fix |
963 |
# NB: autofit or fixed may be switched if widths are correctly staying in the page |
|
964 | 11x |
flx <- flextable::fix_border_issues(flx) # Fixes some rendering gaps in borders |
965 | ||
966 | 11x |
flx |
967 |
} |
|
968 | ||
969 |
#' @describeIn tt_to_flextable Main theme function for [export_as_docx()] |
|
970 |
#' |
|
971 |
#' @inheritParams export_as_docx |
|
972 |
#' @param font (`string`)\cr defaults to `"Arial"`. If the font is not available, `flextable` default is used. |
|
973 |
#' @param font_size (`integer(1)`)\cr font size. Defaults to 9. |
|
974 |
#' @param bold (`character`)\cr parts of the table text that should be in bold. Can be any combination of |
|
975 |
#' `c("header", "content_rows", "label_rows")`. The first one renders all column names bold (not `topleft` content). |
|
976 |
#' The second and third option use [rtables::make_row_df()] to render content or/and label rows as bold. |
|
977 |
#' @param bold_manual (named `list` or `NULL`)\cr list of index lists. See example for needed structure. Accepted |
|
978 |
#' groupings/names are `c("header", "body")`. |
|
979 |
#' |
|
980 |
#' @seealso [export_as_docx()] |
|
981 |
#' |
|
982 |
#' @examples |
|
983 |
#' # Custom theme |
|
984 |
#' special_bold <- list( |
|
985 |
#' "header" = list("i" = 1, "j" = c(1, 3)), |
|
986 |
#' "body" = list("i" = c(1, 2), "j" = 1) |
|
987 |
#' ) |
|
988 |
#' custom_theme <- theme_docx_default(tbl, |
|
989 |
#' font_size = 10, |
|
990 |
#' font = "Brush Script MT", |
|
991 |
#' border = flextable::fp_border_default(color = "pink", width = 2), |
|
992 |
#' bold = NULL, |
|
993 |
#' bold_manual = special_bold |
|
994 |
#' ) |
|
995 |
#' tt_to_flextable(tbl, |
|
996 |
#' border = flextable::fp_border_default(color = "pink", width = 2), |
|
997 |
#' theme = custom_theme |
|
998 |
#' ) |
|
999 |
#' |
|
1000 |
#' @export |
|
1001 |
theme_docx_default <- function(tt = NULL, # Option for more complicated stuff |
|
1002 |
font = "Arial", |
|
1003 |
font_size = 9, |
|
1004 |
bold = c("header", "content_rows", "label_rows"), |
|
1005 |
bold_manual = NULL, |
|
1006 |
border = flextable::fp_border_default(width = 0.5)) { |
|
1007 | 11x |
function(flx) { |
1008 | 11x |
check_required_packages("flextable") |
1009 | 11x |
if (!inherits(flx, "flextable")) { |
1010 | ! |
stop(sprintf( |
1011 | ! |
"Function `%s` supports only flextable objects.", |
1012 | ! |
"theme_box()" |
1013 |
)) |
|
1014 |
} |
|
1015 | 11x |
if (!is.null(tt) && !inherits(tt, "VTableTree")) { |
1016 | ! |
stop("Input table is not an rtables' object.") |
1017 |
} |
|
1018 | 11x |
checkmate::assert_int(font_size, lower = 1) |
1019 | 11x |
checkmate::assert_string(font) |
1020 | 11x |
checkmate::assert_subset(bold, |
1021 | 11x |
eval(formals(theme_docx_default)$bold), |
1022 | 11x |
empty.ok = TRUE |
1023 |
) |
|
1024 | ||
1025 |
# Font setting |
|
1026 | 11x |
flx <- flextable::fontsize(flx, size = font_size, part = "all") %>% |
1027 | 11x |
flextable::fontsize(size = font_size - 1, part = "footer") %>% |
1028 | 11x |
flextable::font(fontname = font, part = "all") |
1029 | ||
1030 |
# Vertical borders |
|
1031 | 11x |
flx <- flx %>% |
1032 | 11x |
flextable::border_outer(part = "body", border = border) %>% |
1033 | 11x |
flextable::border_outer(part = "header", border = border) |
1034 | ||
1035 |
# Vertical alignment -> all top for now, we will set it for the future |
|
1036 | 11x |
flx <- flx %>% |
1037 | 11x |
flextable::valign(j = 2:(NCOL(tt) + 1), valign = "top", part = "body") %>% |
1038 | 11x |
flextable::valign(j = 1, valign = "top", part = "body") %>% |
1039 | 11x |
flextable::valign(j = 2:(NCOL(tt) + 1), valign = "top", part = "header") |
1040 | ||
1041 |
# Bold settings |
|
1042 | 11x |
if (any(bold == "header")) { |
1043 | 9x |
flx <- flextable::bold(flx, j = 2:(NCOL(tt) + 1), part = "header") # Done with theme |
1044 |
} |
|
1045 |
# Content rows are effectively our labels in row names |
|
1046 | 11x |
if (any(bold == "content_rows")) { |
1047 | ! |
if (is.null(tt)) stop('bold = "content_rows" needs the original rtables object (tt).') |
1048 | 9x |
rdf <- make_row_df(tt) |
1049 | 9x |
which_body <- which(rdf$node_class == "ContentRow") |
1050 | 9x |
flx <- flextable::bold(flx, j = 1, i = which_body, part = "body") |
1051 |
} |
|
1052 | 11x |
if (any(bold == "label_rows")) { |
1053 | ! |
if (is.null(tt)) stop('bold = "content_rows" needs the original rtables object (tt).') |
1054 | 9x |
rdf <- make_row_df(tt) |
1055 | 9x |
which_body <- which(rdf$node_class == "LabelRow") |
1056 | 9x |
flx <- flextable::bold(flx, j = 1, i = which_body, part = "body") |
1057 |
} |
|
1058 |
# If you want specific cells to be bold |
|
1059 | 11x |
if (!is.null(bold_manual)) { |
1060 | 2x |
checkmate::assert_list(bold_manual) |
1061 | 2x |
valid_sections <- c("header", "body") # Only valid values |
1062 | 2x |
checkmate::assert_subset(names(bold_manual), valid_sections) |
1063 | 2x |
for (bi in seq_along(bold_manual)) { |
1064 | 3x |
bld_tmp <- bold_manual[[bi]] |
1065 | 3x |
checkmate::assert_list(bld_tmp) |
1066 | 3x |
if (!all(c("i", "j") %in% names(bld_tmp)) || !all(vapply(bld_tmp, checkmate::test_integerish, logical(1)))) { |
1067 | 1x |
stop( |
1068 | 1x |
"Found an allowed section for manual bold (", names(bold_manual)[bi], |
1069 | 1x |
") that was not a named list with i (row) and j (col) integer vectors." |
1070 |
) |
|
1071 |
} |
|
1072 | 2x |
flx <- flextable::bold(flx, |
1073 | 2x |
i = bld_tmp$i, j = bld_tmp$j, |
1074 | 2x |
part = names(bold_manual)[bi] |
1075 |
) |
|
1076 |
} |
|
1077 |
} |
|
1078 | ||
1079 |
# vertical padding is manual atm and respect doc std |
|
1080 | 10x |
flx <- flx %>% |
1081 |
# flextable::padding(j = 2:(NCOL(tt) + 1), padding.top = , part = "body") %>% # not specified |
|
1082 | 10x |
flextable::padding(j = 1, padding.top = 1, padding.bottom = 1, part = "body") %>% |
1083 | 10x |
flextable::padding(j = 2:(NCOL(tt) + 1), padding.top = 0, padding.bottom = 3, part = "header") |
1084 | ||
1085 |
# single line spacing (for safety) -> space = 1 |
|
1086 | 10x |
flx <- flextable::line_spacing(flx, space = 1, part = "all") |
1087 | ||
1088 | 10x |
flx |
1089 |
} |
|
1090 |
} |
|
1091 | ||
1092 |
# Padding helper functions to transform mm to pt and viceversa |
|
1093 |
# # General note for word: 1pt -> 0.3527777778mm -> 0.013888888888889" |
|
1094 |
word_inch_to_pt <- function(inch) { # nocov |
|
1095 |
inch / 0.013888888888889 # nocov |
|
1096 |
} |
|
1097 | ||
1098 |
word_mm_to_pt <- function(mm) { |
|
1099 | 470x |
mm / 0.3527777778 |
1100 |
} |
|
1101 | ||
1102 |
# Polish horizontal borders |
|
1103 |
remove_hborder <- function(flx, part, w = c("top", "bottom", "inner")) { |
|
1104 |
# If you need to remove all of them |
|
1105 | 25x |
if (length(w) == 1 && w == "all") { |
1106 | 12x |
w <- eval(formals(remove_hborder)$w) |
1107 |
} |
|
1108 | ||
1109 | 25x |
if (any(w == "top")) { |
1110 | 13x |
flx <- flextable::hline_top(flx, |
1111 | 13x |
border = flextable::fp_border_default(width = 0), |
1112 | 13x |
part = part |
1113 |
) |
|
1114 |
} |
|
1115 | 25x |
if (any(w == "bottom")) { |
1116 | 24x |
flx <- flextable::hline_bottom(flx, |
1117 | 24x |
border = flextable::fp_border_default(width = 0), |
1118 | 24x |
part = part |
1119 |
) |
|
1120 |
} |
|
1121 |
# Inner horizontal lines removal |
|
1122 | 25x |
if (any(w == "inner")) { |
1123 | 13x |
flx <- flextable::border_inner_h( |
1124 | 13x |
flx, |
1125 | 13x |
border = flextable::fp_border_default(width = 0), |
1126 | 13x |
part = part |
1127 |
) |
|
1128 |
} |
|
1129 | 25x |
flx |
1130 |
} |
|
1131 | ||
1132 |
# Remove vertical borders from both sides (for titles) |
|
1133 |
remove_vborder <- function(flx, part, ii) { |
|
1134 | 1x |
flx <- flextable::border(flx, |
1135 | 1x |
i = ii, part = part, |
1136 | 1x |
border.left = flextable::fp_border_default(width = 0), |
1137 | 1x |
border.right = flextable::fp_border_default(width = 0) |
1138 |
) |
|
1139 |
} |
|
1140 | ||
1141 |
# Add horizontal border |
|
1142 |
add_hborder <- function(flx, part, ii, border) { |
|
1143 | 20x |
if (any(ii == 0)) { |
1144 | 12x |
flx <- flextable::border(flx, i = 1, border.top = border, part = part) |
1145 | 12x |
ii <- ii[!(ii == 0)] |
1146 |
} |
|
1147 | 20x |
if (length(ii) > 0) { |
1148 | 20x |
flx <- flextable::border(flx, i = ii, border.bottom = border, part = part) |
1149 |
} |
|
1150 | 20x |
flx |
1151 |
} |
|
1152 | ||
1153 |
apply_alignments <- function(flx, aligns_df, part) { |
|
1154 |
# List of characters you want to search for |
|
1155 | 24x |
search_chars <- unique(c(aligns_df)) |
1156 | ||
1157 |
# Loop through each character and find its indexes |
|
1158 | 24x |
for (char in search_chars) { |
1159 | 48x |
indexes <- which(aligns_df == char, arr.ind = TRUE) |
1160 | 48x |
tmp_inds <- as.data.frame(indexes) |
1161 | 48x |
flx <- flx %>% |
1162 | 48x |
flextable::align( |
1163 | 48x |
i = tmp_inds[["row"]], |
1164 | 48x |
j = tmp_inds[["col"]], |
1165 | 48x |
align = char, |
1166 | 48x |
part = part |
1167 |
) |
|
1168 |
} |
|
1169 | ||
1170 | 24x |
flx |
1171 |
} |
1 |
## NB handling the case where there are no values is done during tabulation |
|
2 |
## which is the only reason expression(TRUE) is ok, because otherwise |
|
3 |
## we (sometimes) run into |
|
4 |
## factor()[TRUE] giving <NA> (i.e. length 1) |
|
5 | 2542x |
setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_expr")) |
6 | ||
7 |
setMethod( |
|
8 |
"make_subset_expr", "VarLevelSplit", |
|
9 |
function(spl, val) { |
|
10 | 1883x |
v <- unlist(rawvalues(val)) |
11 |
## XXX if we're including all levels should even missing be included? |
|
12 | 1883x |
if (is(v, "AllLevelsSentinel")) { |
13 | 8x |
as.expression(bquote((!is.na(.(a))), list(a = as.name(spl_payload(spl))))) |
14 |
} else { |
|
15 | 1875x |
as.expression(bquote((!is.na(.(a)) & .(a) %in% .(b)), list( |
16 | 1875x |
a = as.name(spl_payload(spl)), |
17 | 1875x |
b = v |
18 |
))) |
|
19 |
} |
|
20 |
} |
|
21 |
) |
|
22 | ||
23 |
setMethod( |
|
24 |
"make_subset_expr", "MultiVarSplit", |
|
25 |
function(spl, val) { |
|
26 |
## v = rawvalues(val) |
|
27 |
## as.expression(bquote(!is.na(.(a)), list(a = v))) |
|
28 | 198x |
expression(TRUE) |
29 |
} |
|
30 |
) |
|
31 | ||
32 |
setMethod( |
|
33 |
"make_subset_expr", "AnalyzeVarSplit", |
|
34 |
function(spl, val) { |
|
35 | ! |
if (avar_inclNAs(spl)) { |
36 | ! |
expression(TRUE) |
37 |
} else { |
|
38 | ! |
as.expression(bquote( |
39 | ! |
!is.na(.(a)), |
40 | ! |
list(a = as.name(spl_payload(spl))) |
41 |
)) |
|
42 |
} |
|
43 |
} |
|
44 |
) |
|
45 | ||
46 |
setMethod( |
|
47 |
"make_subset_expr", "AnalyzeColVarSplit", |
|
48 |
function(spl, val) { |
|
49 | ! |
expression(TRUE) |
50 |
} |
|
51 |
) |
|
52 | ||
53 |
## XXX these are going to be ridiculously slow |
|
54 |
## FIXME |
|
55 | ||
56 |
setMethod( |
|
57 |
"make_subset_expr", "VarStaticCutSplit", |
|
58 |
function(spl, val) { |
|
59 | 90x |
v <- rawvalues(val) |
60 |
## as.expression(bquote(which(cut(.(a), breaks=.(brk), labels = .(labels), |
|
61 | 90x |
as.expression(bquote( |
62 | 90x |
cut(.(a), |
63 | 90x |
breaks = .(brk), labels = .(labels), |
64 | 90x |
include.lowest = TRUE |
65 | 90x |
) == .(b), |
66 | 90x |
list( |
67 | 90x |
a = as.name(spl_payload(spl)), |
68 | 90x |
b = v, |
69 | 90x |
brk = spl_cuts(spl), |
70 | 90x |
labels = spl_cutlabels(spl) |
71 |
) |
|
72 |
)) |
|
73 |
} |
|
74 |
) |
|
75 | ||
76 |
## NB this assumes spl_cutlabels(spl) is in order!!!!!! |
|
77 |
setMethod( |
|
78 |
"make_subset_expr", "CumulativeCutSplit", |
|
79 |
function(spl, val) { |
|
80 | 42x |
v <- rawvalues(val) |
81 |
## as.expression(bquote(which(as.integer(cut(.(a), breaks=.(brk), |
|
82 | 42x |
as.expression(bquote( |
83 | 42x |
as.integer(cut(.(a), |
84 | 42x |
breaks = .(brk), |
85 | 42x |
labels = .(labels), |
86 | 42x |
include.lowest = TRUE |
87 |
)) <= |
|
88 | 42x |
as.integer(factor(.(b), levels = .(labels))), |
89 | 42x |
list( |
90 | 42x |
a = as.name(spl_payload(spl)), |
91 | 42x |
b = v, |
92 | 42x |
brk = spl_cuts(spl), |
93 | 42x |
labels = spl_cutlabels(spl) |
94 |
) |
|
95 |
)) |
|
96 |
} |
|
97 |
) |
|
98 | ||
99 |
## I think this one is unnecessary, |
|
100 |
## build_table collapses DynCutSplits into |
|
101 |
## static ones. |
|
102 |
## |
|
103 |
## XXX TODO fixme |
|
104 |
## setMethod("make_subset_expr", "VarDynCutSplit", |
|
105 |
## function(spl, val) { |
|
106 |
## v = rawvalues(val) |
|
107 |
## ## as.expression(bquote(which(.(fun)(.(a)) == .(b)), |
|
108 |
## as.expression(bquote(.(fun)(.(a)) == .(b)), |
|
109 |
## list(a = as.name(spl_payload(spl)), |
|
110 |
## b = v, |
|
111 |
## fun = spl@cut_fun)) |
|
112 |
## }) |
|
113 | ||
114 |
setMethod( |
|
115 |
"make_subset_expr", "AllSplit", |
|
116 | 194x |
function(spl, val) expression(TRUE) |
117 |
) |
|
118 | ||
119 |
## probably don't need this |
|
120 | ||
121 |
setMethod( |
|
122 |
"make_subset_expr", "expression", |
|
123 | ! |
function(spl, val) spl |
124 |
) |
|
125 | ||
126 |
setMethod( |
|
127 |
"make_subset_expr", "character", |
|
128 |
function(spl, val) { |
|
129 | ! |
newspl <- VarLevelSplit(spl, spl) |
130 | ! |
make_subset_expr(newspl, val) |
131 |
} |
|
132 |
) |
|
133 | ||
134 |
.combine_subset_exprs <- function(ex1, ex2) { |
|
135 | 2542x |
if (is.null(ex1) || identical(ex1, expression(TRUE))) { |
136 | 1723x |
if (is.expression(ex2) && !identical(ex2, expression(TRUE))) { |
137 | 1316x |
return(ex2) |
138 |
} else { |
|
139 | 407x |
return(expression(TRUE)) |
140 |
} |
|
141 |
} |
|
142 | 819x |
stopifnot(is.expression(ex1), is.expression(ex2)) |
143 | 819x |
as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]]))) |
144 |
} |
|
145 | ||
146 |
make_pos_subset <- function(spls = pos_splits(pos), |
|
147 |
svals = pos_splvals(pos), |
|
148 |
pos) { |
|
149 | 905x |
expr <- NULL |
150 | 905x |
for (i in seq_along(spls)) { |
151 | 1315x |
newexpr <- make_subset_expr(spls[[i]], svals[[i]]) |
152 | 1315x |
expr <- .combine_subset_exprs(expr, newexpr) |
153 |
} |
|
154 | 905x |
expr |
155 |
} |
|
156 | ||
157 |
get_pos_extra <- function(svals = pos_splvals(pos), |
|
158 |
pos) { |
|
159 | 911x |
ret <- list() |
160 | 911x |
for (i in seq_along(svals)) { |
161 | 1327x |
extrs <- splv_extra(svals[[i]]) |
162 | 1327x |
if (any(names(ret) %in% names(extrs))) { |
163 | ! |
stop("same extra argument specified at multiple levels of nesting. Not currently supported") |
164 |
} |
|
165 | 1327x |
ret <- c(ret, extrs) |
166 |
} |
|
167 | 911x |
ret |
168 |
} |
|
169 | ||
170 |
get_col_extras <- function(ctree) { |
|
171 | 304x |
leaves <- collect_leaves(ctree) |
172 | 304x |
lapply( |
173 | 304x |
leaves, |
174 | 304x |
function(x) get_pos_extra(pos = tree_pos(x)) |
175 |
) |
|
176 |
} |
|
177 | ||
178 |
setGeneric( |
|
179 |
"make_col_subsets", |
|
180 | 1208x |
function(lyt, df) standardGeneric("make_col_subsets") |
181 |
) |
|
182 | ||
183 |
setMethod( |
|
184 |
"make_col_subsets", "LayoutColTree", |
|
185 |
function(lyt, df) { |
|
186 | 303x |
leaves <- collect_leaves(lyt) |
187 | 303x |
lapply(leaves, make_col_subsets) |
188 |
} |
|
189 |
) |
|
190 | ||
191 |
setMethod( |
|
192 |
"make_col_subsets", "LayoutColLeaf", |
|
193 |
function(lyt, df) { |
|
194 | 905x |
make_pos_subset(pos = tree_pos(lyt)) |
195 |
} |
|
196 |
) |
|
197 | ||
198 |
create_colinfo <- function(lyt, df, rtpos = TreePos(), |
|
199 |
counts = NULL, |
|
200 |
alt_counts_df = NULL, |
|
201 |
total = NULL, |
|
202 |
topleft = NULL) { |
|
203 |
## this will work whether clayout is pre or post |
|
204 |
## data |
|
205 | 306x |
clayout <- clayout(lyt) |
206 | 306x |
if (is.null(topleft)) { |
207 | 306x |
topleft <- top_left(lyt) |
208 |
} |
|
209 | 306x |
ctree <- coltree(clayout, df = df, rtpos = rtpos) |
210 | ||
211 | 302x |
cexprs <- make_col_subsets(ctree, df) |
212 | 302x |
colextras <- col_extra_args(ctree) |
213 | ||
214 |
## calculate the counts based on the df |
|
215 |
## This presumes that it is called on the WHOLE dataset, |
|
216 |
## NOT after any splitting has occurred. Otherwise |
|
217 |
## the counts will obviously be wrong. |
|
218 | 302x |
if (is.null(counts)) { |
219 | 300x |
counts <- rep(NA_integer_, length(cexprs)) |
220 |
} else { |
|
221 | 2x |
if (length(counts) != length(cexprs)) { |
222 | 1x |
stop( |
223 | 1x |
"Length of overriding counts must equal number of columns. Got ", |
224 | 1x |
length(counts), " values for ", length(cexprs), " columns. ", |
225 | 1x |
"Use NAs to specify that the default counting machinery should be ", |
226 | 1x |
"used for that position." |
227 |
) |
|
228 |
} |
|
229 | 1x |
counts <- as.integer(counts) |
230 |
} |
|
231 | ||
232 | 301x |
counts_df_name <- "alt_counts_df" |
233 | 301x |
if (is.null(alt_counts_df)) { |
234 | 282x |
alt_counts_df <- df |
235 | 282x |
counts_df_name <- "df" |
236 |
} |
|
237 | 301x |
calcpos <- is.na(counts) |
238 | ||
239 | 301x |
calccounts <- sapply(cexprs, function(ex) { |
240 | 889x |
if (identical(ex, expression(TRUE))) { |
241 | 136x |
nrow(alt_counts_df) |
242 | 753x |
} else if (identical(ex, expression(FALSE))) { |
243 | ! |
0 |
244 |
} else { |
|
245 | 753x |
vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE) |
246 | 753x |
if (is(vec, "try-error")) { |
247 | 4x |
stop(sprintf( |
248 | 4x |
paste( |
249 | 4x |
counts_df_name, "appears", |
250 | 4x |
"incompatible with column-split", |
251 | 4x |
"structure. Offending column subset", |
252 | 4x |
"expression: %s\nOriginal error", |
253 | 4x |
"message: %s" |
254 | 4x |
), deparse(ex[[1]]), |
255 | 4x |
conditionMessage(attr(vec, "condition")) |
256 |
)) |
|
257 |
} |
|
258 | 749x |
if (is(vec, "numeric")) { |
259 | ! |
length(vec) |
260 | 749x |
} else if (is(vec, "logical")) { ## sum(is.na(.)) ???? |
261 | 749x |
sum(vec, na.rm = TRUE) |
262 |
} |
|
263 |
} |
|
264 |
}) |
|
265 | 297x |
counts[calcpos] <- calccounts[calcpos] |
266 | 297x |
if (is.null(total)) { |
267 | ! |
total <- sum(counts) |
268 |
} |
|
269 | 297x |
format <- colcount_format(lyt) |
270 | 297x |
InstantiatedColumnInfo( |
271 | 297x |
treelyt = ctree, |
272 | 297x |
csubs = cexprs, |
273 | 297x |
extras = colextras, |
274 | 297x |
cnts = counts, |
275 | 297x |
dispcounts = disp_ccounts(lyt), |
276 | 297x |
countformat = format, |
277 | 297x |
total_cnt = total, |
278 | 297x |
topleft = topleft |
279 |
) |
|
280 |
} |
1 |
#' Format `rcell` objects |
|
2 |
#' |
|
3 |
#' This is a wrapper for [formatters::format_value()] for use with `CellValue` objects |
|
4 |
#' |
|
5 |
#' @inheritParams lyt_args |
|
6 |
#' @param x (`CellValue` or `ANY`)\cr an object of class `CellValue`, or a raw value. |
|
7 |
#' @param format (`string` or `function`)\cr the format label or formatter function to |
|
8 |
#' apply to `x`. |
|
9 |
#' @param output (`string`)\cr output type. |
|
10 |
#' @param pr_row_format (`list`)\cr list of default formats coming from the general row. |
|
11 |
#' @param pr_row_na_str (`list`)\cr list of default `"NA"` strings coming from the general row. |
|
12 |
#' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the |
|
13 |
#' values with formats applied. Defaults to `FALSE`. |
|
14 |
#' |
|
15 |
#' @return Formatted text. |
|
16 |
#' |
|
17 |
#' @examples |
|
18 |
#' cll <- CellValue(pi, format = "xx.xxx") |
|
19 |
#' format_rcell(cll) |
|
20 |
#' |
|
21 |
#' # Cell values precedes the row values |
|
22 |
#' cll <- CellValue(pi, format = "xx.xxx") |
|
23 |
#' format_rcell(cll, pr_row_format = "xx.x") |
|
24 |
#' |
|
25 |
#' # Similarly for NA values |
|
26 |
#' cll <- CellValue(NA, format = "xx.xxx", format_na_str = "This is THE NA") |
|
27 |
#' format_rcell(cll, pr_row_na_str = "This is NA") |
|
28 |
#' |
|
29 |
#' @export |
|
30 |
format_rcell <- function(x, format, |
|
31 |
output = c("ascii", "html"), |
|
32 |
na_str = obj_na_str(x) %||% "NA", |
|
33 |
pr_row_format = NULL, |
|
34 |
pr_row_na_str = NULL, |
|
35 |
shell = FALSE) { |
|
36 |
# Check for format and parent row format |
|
37 | 86930x |
format <- if (missing(format)) obj_format(x) else format |
38 | 86930x |
if (is.null(format) && !is.null(pr_row_format)) { |
39 | 57064x |
format <- pr_row_format |
40 |
} |
|
41 |
# Check for na_str from parent |
|
42 | 86930x |
if (is.null(obj_na_str(x)) && !is.null(pr_row_na_str)) { |
43 | 69772x |
na_str <- pr_row_na_str |
44 |
} |
|
45 | ||
46 |
# Main call to external function or shell |
|
47 | 86930x |
if (shell) { |
48 | 21903x |
return(format) |
49 |
} |
|
50 | 65027x |
format_value(rawvalues(x), |
51 | 65027x |
format = format, |
52 | 65027x |
output = output, |
53 | 65027x |
na_str = na_str |
54 |
) |
|
55 |
} |
1 |
treestruct <- function(obj, ind = 0L) { |
|
2 | 19x |
nc <- ncol(obj) |
3 | 19x |
cat(rep(" ", times = ind), |
4 | 19x |
sprintf("[%s] %s", class(obj), obj_name(obj)), |
5 | 19x |
sep = "" |
6 |
) |
|
7 | 19x |
if (!is(obj, "ElementaryTable") && nrow(obj@content) > 0) { |
8 | 6x |
crows <- nrow(content_table(obj)) |
9 | 6x |
ccols <- if (crows == 0) 0 else nc |
10 | 6x |
cat(sprintf( |
11 | 6x |
" [cont: %d x %d]", |
12 | 6x |
crows, ccols |
13 |
)) |
|
14 |
} |
|
15 | 19x |
if (is(obj, "VTableTree") && length(tree_children(obj))) { |
16 | 19x |
kids <- tree_children(obj) |
17 | 19x |
if (are(kids, "TableRow")) { |
18 | 9x |
cat(sprintf( |
19 | 9x |
" (%d x %d)\n", |
20 | 9x |
length(kids), nc |
21 |
)) |
|
22 |
} else { |
|
23 | 10x |
cat("\n") |
24 | 10x |
lapply(kids, treestruct, ind = ind + 1) |
25 |
} |
|
26 |
} |
|
27 | 19x |
invisible(NULL) |
28 |
} |
|
29 | ||
30 |
setGeneric( |
|
31 |
"ploads_to_str", |
|
32 | 103x |
function(x, collapse = ":") standardGeneric("ploads_to_str") |
33 |
) |
|
34 | ||
35 |
setMethod( |
|
36 |
"ploads_to_str", "Split", |
|
37 |
function(x, collapse = ":") { |
|
38 | 52x |
paste(sapply(spl_payload(x), ploads_to_str), |
39 | 52x |
collapse = collapse |
40 |
) |
|
41 |
} |
|
42 |
) |
|
43 | ||
44 |
setMethod( |
|
45 |
"ploads_to_str", "CompoundSplit", |
|
46 |
function(x, collapse = ":") { |
|
47 | 6x |
paste(sapply(spl_payload(x), ploads_to_str), |
48 | 6x |
collapse = collapse |
49 |
) |
|
50 |
} |
|
51 |
) |
|
52 | ||
53 |
setMethod( |
|
54 |
"ploads_to_str", "list", |
|
55 |
function(x, collapse = ":") { |
|
56 | ! |
stop("Please contact the maintainer") |
57 |
} |
|
58 |
) |
|
59 | ||
60 |
setMethod( |
|
61 |
"ploads_to_str", "SplitVector", |
|
62 |
function(x, collapse = ":") { |
|
63 | 8x |
sapply(x, ploads_to_str) |
64 |
} |
|
65 |
) |
|
66 | ||
67 |
setMethod( |
|
68 |
"ploads_to_str", "ANY", |
|
69 |
function(x, collapse = ":") { |
|
70 | 37x |
paste(x) |
71 |
} |
|
72 |
) |
|
73 | ||
74 | 41x |
setGeneric("payloadmsg", function(spl) standardGeneric("payloadmsg")) |
75 | ||
76 |
setMethod( |
|
77 |
"payloadmsg", "VarLevelSplit", |
|
78 |
function(spl) { |
|
79 | 40x |
spl_payload(spl) |
80 |
} |
|
81 |
) |
|
82 | ||
83 |
setMethod( |
|
84 |
"payloadmsg", "MultiVarSplit", |
|
85 | 1x |
function(spl) "var" |
86 |
) |
|
87 | ||
88 |
setMethod( |
|
89 |
"payloadmsg", "VarLevWBaselineSplit", |
|
90 |
function(spl) { |
|
91 | ! |
paste0( |
92 | ! |
spl_payload(spl), "[bsl ", |
93 | ! |
spl@ref_group_value, # XXX XXX |
94 |
"]" |
|
95 |
) |
|
96 |
} |
|
97 |
) |
|
98 | ||
99 |
setMethod( |
|
100 |
"payloadmsg", "ManualSplit", |
|
101 | ! |
function(spl) "mnl" |
102 |
) |
|
103 | ||
104 |
setMethod( |
|
105 |
"payloadmsg", "AllSplit", |
|
106 | ! |
function(spl) "all" |
107 |
) |
|
108 | ||
109 |
setMethod( |
|
110 |
"payloadmsg", "ANY", |
|
111 |
function(spl) { |
|
112 | ! |
warning("don't know how to make payload print message for Split of class", class(spl)) |
113 | ! |
"XXX" |
114 |
} |
|
115 |
) |
|
116 | ||
117 |
spldesc <- function(spl, value = "") { |
|
118 | 32x |
value <- rawvalues(value) |
119 | 32x |
payloadmsg <- payloadmsg(spl) |
120 | 32x |
format <- "%s (%s)" |
121 | 32x |
sprintf( |
122 | 32x |
format, |
123 | 32x |
value, |
124 | 32x |
payloadmsg |
125 |
) |
|
126 |
} |
|
127 | ||
128 |
layoutmsg <- function(obj) { |
|
129 |
## if(!is(obj, "VLayoutNode")) |
|
130 |
## stop("how did a non layoutnode object get in docatlayout??") |
|
131 | ||
132 | 28x |
pos <- tree_pos(obj) |
133 | 28x |
spllst <- pos_splits(pos) |
134 | 28x |
spvallst <- pos_splvals(pos) |
135 | 28x |
if (is(obj, "LayoutAxisTree")) { |
136 | 12x |
kids <- tree_children(obj) |
137 | 12x |
return(unlist(lapply(kids, layoutmsg))) |
138 |
} |
|
139 | ||
140 | 16x |
msg <- paste( |
141 | 16x |
collapse = " -> ", |
142 | 16x |
mapply(spldesc, |
143 | 16x |
spl = spllst, |
144 | 16x |
value = spvallst |
145 |
) |
|
146 |
) |
|
147 | 16x |
msg |
148 |
} |
|
149 | ||
150 |
setMethod( |
|
151 |
"show", "LayoutAxisTree", |
|
152 |
function(object) { |
|
153 | 2x |
msg <- layoutmsg(object) |
154 | 2x |
cat(msg, "\n") |
155 | 2x |
invisible(object) |
156 |
} |
|
157 |
) |
|
158 | ||
159 | 46x |
setGeneric("spltype_abbrev", function(obj) standardGeneric("spltype_abbrev")) |
160 | ||
161 |
setMethod( |
|
162 |
"spltype_abbrev", "VarLevelSplit", |
|
163 | 4x |
function(obj) "lvls" |
164 |
) |
|
165 | ||
166 |
setMethod( |
|
167 |
"spltype_abbrev", "VarLevWBaselineSplit", |
|
168 | 5x |
function(obj) paste("ref_group", obj@ref_group_value) |
169 |
) |
|
170 | ||
171 |
setMethod( |
|
172 |
"spltype_abbrev", "MultiVarSplit", |
|
173 | ! |
function(obj) "vars" |
174 |
) |
|
175 | ||
176 |
setMethod( |
|
177 |
"spltype_abbrev", "VarStaticCutSplit", |
|
178 | 10x |
function(obj) "scut" |
179 |
) |
|
180 | ||
181 |
setMethod( |
|
182 |
"spltype_abbrev", "VarDynCutSplit", |
|
183 | 5x |
function(obj) "dcut" |
184 |
) |
|
185 |
setMethod( |
|
186 |
"spltype_abbrev", "AllSplit", |
|
187 | 15x |
function(obj) "all obs" |
188 |
) |
|
189 |
## setMethod("spltype_abbrev", "NULLSplit", |
|
190 |
## function(obj) "no obs") |
|
191 | ||
192 |
setMethod( |
|
193 |
"spltype_abbrev", "AnalyzeVarSplit", |
|
194 | 1x |
function(obj) "** analysis **" |
195 |
) |
|
196 | ||
197 |
setMethod( |
|
198 |
"spltype_abbrev", "CompoundSplit", |
|
199 | ! |
function(obj) paste("compound", paste(sapply(spl_payload(obj), spltype_abbrev), collapse = " ")) |
200 |
) |
|
201 | ||
202 |
setMethod( |
|
203 |
"spltype_abbrev", "AnalyzeMultiVars", |
|
204 | 6x |
function(obj) "** multivar analysis **" |
205 |
) |
|
206 |
setMethod( |
|
207 |
"spltype_abbrev", "AnalyzeColVarSplit", |
|
208 | ! |
function(obj) "** col-var analysis **" |
209 |
) |
|
210 | ||
211 |
docat_splitvec <- function(object, indent = 0) { |
|
212 | 8x |
if (indent > 0) { |
213 | ! |
cat(rep(" ", times = indent), sep = "") |
214 |
} |
|
215 | 8x |
if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) { |
216 | ! |
tab <- object[[1]] |
217 | ! |
msg <- sprintf( |
218 | ! |
"A Pre-Existing Table [%d x %d]", |
219 | ! |
nrow(tab), ncol(tab) |
220 |
) |
|
221 |
} else { |
|
222 | 8x |
plds <- ploads_to_str(object) ## lapply(object, spl_payload)) |
223 | ||
224 | 8x |
tabbrev <- sapply(object, spltype_abbrev) |
225 | 8x |
msg <- paste( |
226 | 8x |
collapse = " -> ", |
227 | 8x |
paste0(plds, " (", tabbrev, ")") |
228 |
) |
|
229 |
} |
|
230 | 8x |
cat(msg, "\n") |
231 |
} |
|
232 | ||
233 |
setMethod( |
|
234 |
"show", "SplitVector", |
|
235 |
function(object) { |
|
236 | 1x |
cat("A SplitVector Pre-defining a Tree Structure\n\n") |
237 | 1x |
docat_splitvec(object) |
238 | 1x |
cat("\n") |
239 | 1x |
invisible(object) |
240 |
} |
|
241 |
) |
|
242 | ||
243 |
docat_predataxis <- function(object, indent = 0) { |
|
244 | 6x |
lapply(object, docat_splitvec) |
245 |
} |
|
246 | ||
247 |
setMethod( |
|
248 |
"show", "PreDataColLayout", |
|
249 |
function(object) { |
|
250 | 1x |
cat("A Pre-data Column Layout Object\n\n") |
251 | 1x |
docat_predataxis(object) |
252 | 1x |
invisible(object) |
253 |
} |
|
254 |
) |
|
255 | ||
256 |
setMethod( |
|
257 |
"show", "PreDataRowLayout", |
|
258 |
function(object) { |
|
259 | 1x |
cat("A Pre-data Row Layout Object\n\n") |
260 | 1x |
docat_predataxis(object) |
261 | 1x |
invisible(object) |
262 |
} |
|
263 |
) |
|
264 | ||
265 |
setMethod( |
|
266 |
"show", "PreDataTableLayouts", |
|
267 |
function(object) { |
|
268 | 2x |
cat("A Pre-data Table Layout\n") |
269 | 2x |
cat("\nColumn-Split Structure:\n") |
270 | 2x |
docat_predataxis(object@col_layout) |
271 | 2x |
cat("\nRow-Split Structure:\n") |
272 | 2x |
docat_predataxis(object@row_layout) |
273 | 2x |
cat("\n") |
274 | 2x |
invisible(object) |
275 |
} |
|
276 |
) |
|
277 | ||
278 |
setMethod( |
|
279 |
"show", "InstantiatedColumnInfo", |
|
280 |
function(object) { |
|
281 | 2x |
layoutmsg <- layoutmsg(coltree(object)) |
282 | 2x |
cat("An InstantiatedColumnInfo object", |
283 | 2x |
"Columns:", |
284 | 2x |
layoutmsg, |
285 | 2x |
if (disp_ccounts(object)) { |
286 | 2x |
paste( |
287 | 2x |
"ColumnCounts:\n", |
288 | 2x |
paste(col_counts(object), |
289 | 2x |
collapse = ", " |
290 |
) |
|
291 |
) |
|
292 |
}, |
|
293 |
"", |
|
294 | 2x |
sep = "\n" |
295 |
) |
|
296 | 2x |
invisible(object) |
297 |
} |
|
298 |
) |
|
299 | ||
300 |
#' @rdname int_methods |
|
301 |
setMethod("print", "VTableTree", function(x, ...) { |
|
302 | 4x |
msg <- toString(x, ...) |
303 | 4x |
cat(msg) |
304 | 4x |
invisible(x) |
305 |
}) |
|
306 | ||
307 |
#' @rdname int_methods |
|
308 |
setMethod("show", "VTableTree", function(object) { |
|
309 | ! |
cat(toString(object)) |
310 | ! |
invisible(object) |
311 |
}) |
|
312 | ||
313 |
setMethod("show", "TableRow", function(object) { |
|
314 | 1x |
cat(sprintf( |
315 | 1x |
"[%s indent_mod %d]: %s %s\n", |
316 | 1x |
class(object), |
317 | 1x |
indent_mod(object), |
318 | 1x |
obj_label(object), |
319 | 1x |
paste(as.vector(get_formatted_cells(object)), |
320 | 1x |
collapse = " " |
321 |
) |
|
322 |
)) |
|
323 | 1x |
invisible(object) |
324 |
}) |
1 |
## Rules for pagination |
|
2 |
## |
|
3 |
## 1. user defined number of lines per page |
|
4 |
## 2. all lines have the same height |
|
5 |
## 3. header always reprinted on all pages |
|
6 |
## 4. "Label-rows", i.e. content rows above break in the nesting structure, optionally reprinted (default TRUE) |
|
7 |
## 5. Never (?) break on a "label"/content row |
|
8 |
## 6. Never (?) break on the second (i.e. after the first) data row at a particular leaf Elementary table. |
|
9 |
## |
|
10 |
## Current behavior: paginate_ttree takes a TableTree object and |
|
11 |
## returns a list of rtable (S3) objects for printing. |
|
12 | ||
13 |
#' @inheritParams formatters::nlines |
|
14 |
#' |
|
15 |
#' @rdname formatters_methods |
|
16 |
#' @aliases nlines,TableRow-method |
|
17 |
#' @exportMethod nlines |
|
18 |
setMethod( |
|
19 |
"nlines", "TableRow", |
|
20 |
function(x, colwidths, max_width) { |
|
21 |
## XXX this is wrong and needs to be fixed |
|
22 |
## should not be hardcoded here |
|
23 | 10079x |
col_gap <- 3L |
24 | 10079x |
fns <- sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width))) + |
25 | 10079x |
sum(unlist(lapply(cell_footnotes(x), nlines, max_width = max_width))) |
26 | 10079x |
fcells <- as.vector(get_formatted_cells(x)) |
27 | 10079x |
spans <- row_cspans(x) |
28 | 10079x |
have_cw <- !is.null(colwidths) |
29 |
## handle spanning so that the projected word-wrapping from nlines is correct |
|
30 | 10079x |
if (any(spans > 1)) { |
31 | 6x |
new_fcells <- character(length(spans)) |
32 | 6x |
new_colwidths <- numeric(length(spans)) |
33 | 6x |
cur_fcells <- fcells |
34 | 6x |
cur_colwidths <- colwidths[-1] ## not the row labels they can't span |
35 | 6x |
for (i in seq_along(spans)) { |
36 | 6x |
spi <- spans[i] |
37 | 6x |
new_fcells[i] <- cur_fcells[1] ## 1 cause we're trimming it every loop |
38 | 6x |
new_colwidths[i] <- sum(head(cur_colwidths, spi)) + col_gap * (spi - 1) |
39 | 6x |
cur_fcells <- tail(cur_fcells, -1 * spi) |
40 | 6x |
cur_colwidths <- tail(cur_colwidths, -1 * spi) |
41 |
} |
|
42 | 6x |
if (have_cw) { |
43 | ! |
colwidths <- c(colwidths[1], new_colwidths) |
44 |
} |
|
45 | 6x |
fcells <- new_fcells |
46 |
} |
|
47 | ||
48 |
## rowext <- max(vapply(strsplit(c(obj_label(x), fcells), "\n", fixed = TRUE), |
|
49 |
## length, |
|
50 |
## 1L)) |
|
51 | 10079x |
rowext <- max(unlist(mapply(function(s, w) { |
52 | 52979x |
nlines(strsplit(s, "\n", fixed = TRUE), max_width = w) |
53 | 10079x |
}, s = c(obj_label(x), fcells), w = (colwidths %||% max_width) %||% 1000L, SIMPLIFY = FALSE))) |
54 | ||
55 | 10079x |
rowext + fns |
56 |
} |
|
57 |
) |
|
58 | ||
59 |
#' @export |
|
60 |
#' @rdname formatters_methods |
|
61 |
setMethod( |
|
62 |
"nlines", "LabelRow", |
|
63 |
function(x, colwidths, max_width) { |
|
64 | 3328x |
if (labelrow_visible(x)) { |
65 | 3328x |
nlines(strsplit(obj_label(x), "\n", fixed = TRUE)[[1]], max_width = colwidths[1]) + |
66 | 3328x |
sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width))) |
67 |
} else { |
|
68 | ! |
0L |
69 |
} |
|
70 |
} |
|
71 |
) |
|
72 | ||
73 |
#' @export |
|
74 |
#' @rdname formatters_methods |
|
75 |
setMethod( |
|
76 |
"nlines", "RefFootnote", |
|
77 |
function(x, colwidths, max_width) { |
|
78 | 2140x |
nlines(format_fnote_note(x), colwidths = colwidths, max_width = max_width) |
79 |
} |
|
80 |
) |
|
81 | ||
82 |
#' @export |
|
83 |
#' @rdname formatters_methods |
|
84 |
setMethod( |
|
85 |
"nlines", "InstantiatedColumnInfo", |
|
86 |
function(x, colwidths, max_width) { |
|
87 | 5x |
h_rows <- .do_tbl_h_piece2(x) |
88 | 5x |
tl <- top_left(x) %||% rep("", length(h_rows)) |
89 | 5x |
main_nls <- vapply( |
90 | 5x |
seq_along(h_rows), |
91 | 5x |
function(i) max(nlines(h_rows[[i]], colwidths = colwidths), nlines(tl[i], colwidths = colwidths[1])), |
92 | 5x |
1L |
93 |
) |
|
94 | ||
95 |
## lfs <- collect_leaves(coltree(x)) |
|
96 |
## depths <- sapply(lfs, function(l) length(pos_splits(l))) |
|
97 | ||
98 | 5x |
coldf <- make_col_df(x, colwidths = colwidths) |
99 | 5x |
have_fnotes <- length(unlist(coldf$col_fnotes)) > 0 |
100 |
## ret <- max(depths, length(top_left(x))) + |
|
101 |
## divider_height(x) |
|
102 | 5x |
ret <- sum(main_nls, divider_height(x)) |
103 | 5x |
if (have_fnotes) { |
104 | ! |
ret <- sum( |
105 | ! |
ret, |
106 | ! |
vapply(unlist(coldf$col_fnotes), |
107 | ! |
nlines, |
108 | ! |
1, |
109 | ! |
max_width = max_width |
110 |
), |
|
111 | ! |
2 * divider_height(x) |
112 |
) |
|
113 |
} |
|
114 | 5x |
ret |
115 |
} |
|
116 |
) |
|
117 | ||
118 |
col_dfrow <- function(col, |
|
119 |
nm = obj_name(col), |
|
120 |
lab = obj_label(col), |
|
121 |
cnum, |
|
122 |
pth = NULL, |
|
123 |
sibpos = NA_integer_, |
|
124 |
nsibs = NA_integer_, |
|
125 |
leaf_indices = cnum, |
|
126 |
span = length(leaf_indices), |
|
127 |
col_fnotes = list()) { |
|
128 | 16393x |
if (is.null(pth)) { |
129 | 15871x |
pth <- pos_to_path(tree_pos(col)) |
130 |
} |
|
131 | 16393x |
data.frame( |
132 | 16393x |
stringsAsFactors = FALSE, |
133 | 16393x |
name = nm, |
134 | 16393x |
label = lab, |
135 | 16393x |
abs_pos = cnum, |
136 | 16393x |
path = I(list(pth)), |
137 | 16393x |
pos_in_siblings = sibpos, |
138 | 16393x |
n_siblings = nsibs, |
139 | 16393x |
leaf_indices = I(list(leaf_indices)), |
140 | 16393x |
total_span = span, |
141 | 16393x |
col_fnotes = I(list(col_fnotes)), |
142 | 16393x |
n_col_fnotes = length(col_fnotes) |
143 |
) |
|
144 |
} |
|
145 | ||
146 |
pos_to_path <- function(pos) { |
|
147 | 17037x |
spls <- pos_splits(pos) |
148 | 17037x |
vals <- pos_splvals(pos) |
149 | ||
150 | 17037x |
path <- character() |
151 | 17037x |
for (i in seq_along(spls)) { |
152 | 25847x |
path <- c( |
153 | 25847x |
path, |
154 | 25847x |
obj_name(spls[[i]]), |
155 |
## rawvalues(vals[[i]])) |
|
156 | 25847x |
value_names(vals[[i]]) |
157 |
) |
|
158 |
} |
|
159 | 17037x |
path |
160 |
} |
|
161 | ||
162 |
# make_row_df --------------------------------------------------------------- |
|
163 | ||
164 |
#' @inherit formatters::make_row_df |
|
165 |
#' |
|
166 |
# #' @note The technically present root tree node is excluded from the summary returned by both `make_row_df` and |
|
167 |
# #' `make_col_df`, as it is simply the row/column structure of `tt` and thus not useful for pathing or pagination. |
|
168 |
# #' |
|
169 |
# #' @return a data.frame of row/column-structure information used by the pagination machinery. |
|
170 |
# #' |
|
171 |
# #' @export |
|
172 |
# #' @name make_row_df |
|
173 |
# #' @rdname make_row_df |
|
174 |
# #' @aliases make_row_df,VTableTree-method |
|
175 |
#' @rdname formatters_methods |
|
176 |
#' @exportMethod make_row_df |
|
177 |
setMethod( |
|
178 |
"make_row_df", "VTableTree", |
|
179 |
function(tt, |
|
180 |
colwidths = NULL, |
|
181 |
visible_only = TRUE, |
|
182 |
rownum = 0, |
|
183 |
indent = 0L, |
|
184 |
path = character(), |
|
185 |
incontent = FALSE, |
|
186 |
repr_ext = 0L, |
|
187 |
repr_inds = integer(), |
|
188 |
sibpos = NA_integer_, |
|
189 |
nsibs = NA_integer_, |
|
190 |
max_width = NULL) { |
|
191 | 9955x |
indent <- indent + indent_mod(tt) |
192 |
## retained for debugging info |
|
193 | 9955x |
orig_rownum <- rownum # nolint |
194 | 9955x |
if (incontent) { |
195 | 1402x |
path <- c(path, "@content") |
196 | 8553x |
} else if (length(path) > 0 || nzchar(obj_name(tt))) { ## don't add "" for root |
197 |
## else if (length(path) > 0 && nzchar(obj_name(tt))) ## don't add "" for root # nolint |
|
198 | 8511x |
path <- c(path, obj_name(tt)) |
199 |
} |
|
200 | 9955x |
ret <- list() |
201 | ||
202 |
## note this is the **table** not the label row |
|
203 | 9955x |
if (!visible_only) { |
204 | 21x |
ret <- c( |
205 | 21x |
ret, |
206 | 21x |
list(pagdfrow( |
207 | 21x |
rnum = NA, |
208 | 21x |
nm = obj_name(tt), |
209 | 21x |
lab = "", |
210 | 21x |
pth = path, |
211 | 21x |
colwidths = colwidths, |
212 | 21x |
repext = repr_ext, |
213 | 21x |
repind = list(repr_inds), |
214 | 21x |
extent = 0, |
215 | 21x |
indent = indent, |
216 | 21x |
rclass = class(tt), sibpos = sibpos, |
217 | 21x |
nsibs = nsibs, |
218 | 21x |
nrowrefs = 0L, |
219 | 21x |
ncellrefs = 0L, |
220 | 21x |
nreflines = 0L |
221 |
)) |
|
222 |
) |
|
223 |
} |
|
224 | 9955x |
if (labelrow_visible(tt)) { |
225 | 3308x |
lr <- tt_labelrow(tt) |
226 | 3308x |
newdf <- make_row_df(lr, |
227 | 3308x |
colwidths = colwidths, |
228 | 3308x |
visible_only = visible_only, |
229 | 3308x |
rownum = rownum, |
230 | 3308x |
indent = indent, |
231 | 3308x |
path = path, |
232 | 3308x |
incontent = TRUE, |
233 | 3308x |
repr_ext = repr_ext, |
234 | 3308x |
repr_inds = repr_inds, |
235 | 3308x |
max_width = max_width |
236 |
) |
|
237 | 3308x |
rownum <- max(newdf$abs_rownumber, na.rm = TRUE) |
238 | ||
239 | 3308x |
ret <- c( |
240 | 3308x |
ret, |
241 | 3308x |
list(newdf) |
242 |
) |
|
243 | 3308x |
repr_ext <- repr_ext + 1L |
244 | 3308x |
repr_inds <- c(repr_inds, rownum) |
245 | 3308x |
indent <- indent + 1L |
246 |
} |
|
247 | ||
248 | 9955x |
if (NROW(content_table(tt)) > 0) { |
249 | 1402x |
ct_tt <- content_table(tt) |
250 | 1402x |
cind <- indent + indent_mod(ct_tt) |
251 | 1402x |
trailing_section_div(ct_tt) <- trailing_section_div(tt_labelrow(tt)) |
252 | 1402x |
contdf <- make_row_df(ct_tt, |
253 | 1402x |
colwidths = colwidths, |
254 | 1402x |
visible_only = visible_only, |
255 | 1402x |
rownum = rownum, |
256 | 1402x |
indent = cind, |
257 | 1402x |
path = path, |
258 | 1402x |
incontent = TRUE, |
259 | 1402x |
repr_ext = repr_ext, |
260 | 1402x |
repr_inds = repr_inds, |
261 | 1402x |
max_width = max_width |
262 |
) |
|
263 | 1402x |
crnums <- contdf$abs_rownumber |
264 | 1402x |
crnums <- crnums[!is.na(crnums)] |
265 | ||
266 | 1402x |
newrownum <- max(crnums, na.rm = TRUE) |
267 | 1402x |
if (is.finite(newrownum)) { |
268 | 1402x |
rownum <- newrownum |
269 | 1402x |
repr_ext <- repr_ext + length(crnums) |
270 | 1402x |
repr_inds <- c(repr_inds, crnums) |
271 |
} |
|
272 | 1402x |
ret <- c(ret, list(contdf)) |
273 | 1402x |
indent <- cind + 1 |
274 |
} |
|
275 | ||
276 | 9955x |
allkids <- tree_children(tt) |
277 | 9955x |
newnsibs <- length(allkids) |
278 | 9955x |
for (i in seq_along(allkids)) { |
279 | 17818x |
kid <- allkids[[i]] |
280 | 17818x |
kiddfs <- make_row_df(kid, |
281 | 17818x |
colwidths = colwidths, |
282 | 17818x |
visible_only = visible_only, |
283 | 17818x |
rownum = force(rownum), |
284 | 17818x |
indent = indent, ## + 1, |
285 | 17818x |
path = path, |
286 | 17818x |
incontent = incontent, |
287 | 17818x |
repr_ext = repr_ext, |
288 | 17818x |
repr_inds = repr_inds, |
289 | 17818x |
nsibs = newnsibs, |
290 | 17818x |
sibpos = i, |
291 | 17818x |
max_width = max_width |
292 |
) |
|
293 | ||
294 |
# print(kiddfs$abs_rownumber) |
|
295 | 17818x |
rownum <- max(rownum + 1L, kiddfs$abs_rownumber, na.rm = TRUE) |
296 | 17818x |
ret <- c(ret, list(kiddfs)) |
297 |
} |
|
298 | ||
299 | 9955x |
ret <- do.call(rbind, ret) |
300 | ||
301 |
# Case where it has Elementary table or VTableTree section_div it is overridden |
|
302 | 9955x |
if (!is.na(trailing_section_div(tt))) { |
303 | 110x |
ret$trailing_sep[nrow(ret)] <- trailing_section_div(tt) |
304 |
} |
|
305 | 9955x |
ret |
306 |
} |
|
307 |
) |
|
308 | ||
309 |
# #' @exportMethod make_row_df |
|
310 |
#' @inherit formatters::make_row_df |
|
311 |
#' |
|
312 |
#' @export |
|
313 |
#' @rdname formatters_methods |
|
314 |
setMethod( |
|
315 |
"make_row_df", "TableRow", |
|
316 |
function(tt, colwidths = NULL, visible_only = TRUE, |
|
317 |
rownum = 0, |
|
318 |
indent = 0L, |
|
319 |
path = "root", |
|
320 |
incontent = FALSE, |
|
321 |
repr_ext = 0L, |
|
322 |
repr_inds = integer(), |
|
323 |
sibpos = NA_integer_, |
|
324 |
nsibs = NA_integer_, |
|
325 |
max_width = NULL) { |
|
326 | 10074x |
indent <- indent + indent_mod(tt) |
327 | 10074x |
rownum <- rownum + 1 |
328 | 10074x |
rrefs <- row_footnotes(tt) |
329 | 10074x |
crefs <- cell_footnotes(tt) |
330 | 10074x |
reflines <- sum(sapply(c(rrefs, crefs), nlines, colwidths = colwidths, max_width = max_width)) |
331 | 10074x |
ret <- pagdfrow( |
332 | 10074x |
row = tt, |
333 | 10074x |
rnum = rownum, |
334 | 10074x |
colwidths = colwidths, |
335 | 10074x |
sibpos = sibpos, |
336 | 10074x |
nsibs = nsibs, |
337 | 10074x |
pth = c(path, unname(obj_name(tt))), |
338 | 10074x |
repext = repr_ext, |
339 | 10074x |
repind = repr_inds, |
340 | 10074x |
indent = indent, |
341 | 10074x |
extent = nlines(tt, colwidths = colwidths, max_width = max_width), |
342 |
## these two are unlist calls cause they come in lists even with no footnotes |
|
343 | 10074x |
nrowrefs = length(rrefs), |
344 | 10074x |
ncellrefs = length(unlist(crefs)), |
345 | 10074x |
nreflines = reflines, |
346 | 10074x |
trailing_sep = trailing_section_div(tt) |
347 |
) |
|
348 | 10074x |
ret |
349 |
} |
|
350 |
) |
|
351 | ||
352 |
# #' @exportMethod make_row_df |
|
353 |
#' @export |
|
354 |
#' @rdname formatters_methods |
|
355 |
setMethod( |
|
356 |
"make_row_df", "LabelRow", |
|
357 |
function(tt, colwidths = NULL, visible_only = TRUE, |
|
358 |
rownum = 0, |
|
359 |
indent = 0L, |
|
360 |
path = "root", |
|
361 |
incontent = FALSE, |
|
362 |
repr_ext = 0L, |
|
363 |
repr_inds = integer(), |
|
364 |
sibpos = NA_integer_, |
|
365 |
nsibs = NA_integer_, |
|
366 |
max_width = NULL) { |
|
367 | 3328x |
rownum <- rownum + 1 |
368 | 3328x |
indent <- indent + indent_mod(tt) |
369 | 3328x |
ret <- pagdfrow(tt, |
370 | 3328x |
extent = nlines(tt, colwidths = colwidths, max_width = max_width), |
371 | 3328x |
rnum = rownum, |
372 | 3328x |
colwidths = colwidths, |
373 | 3328x |
sibpos = sibpos, |
374 | 3328x |
nsibs = nsibs, |
375 | 3328x |
pth = path, |
376 | 3328x |
repext = repr_ext, |
377 | 3328x |
repind = repr_inds, |
378 | 3328x |
indent = indent, |
379 | 3328x |
nrowrefs = length(row_footnotes(tt)), |
380 | 3328x |
ncellrefs = 0L, |
381 | 3328x |
nreflines = sum(vapply(row_footnotes(tt), nlines, NA_integer_, |
382 | 3328x |
colwidths = colwidths, |
383 | 3328x |
max_width = max_width |
384 |
)), |
|
385 | 3328x |
trailing_sep = trailing_section_div(tt) |
386 |
) |
|
387 | 3328x |
if (!labelrow_visible(tt)) { |
388 | ! |
ret <- ret[0, , drop = FALSE] |
389 |
} |
|
390 | 3328x |
ret |
391 |
} |
|
392 |
) |
|
393 | ||
394 |
setGeneric("inner_col_df", function(ct, |
|
395 |
colwidths = NULL, |
|
396 |
visible_only = TRUE, |
|
397 |
colnum = 0L, |
|
398 |
sibpos = NA_integer_, |
|
399 |
nsibs = NA_integer_, |
|
400 |
ncolref = 0L) { |
|
401 | 24202x |
standardGeneric("inner_col_df") |
402 |
}) |
|
403 | ||
404 |
#' Column layout summary |
|
405 |
#' |
|
406 |
#' Used for pagination. Generate a structural summary of the columns of an `rtables` table and return it as a |
|
407 |
#' `data.frame`. |
|
408 |
#' |
|
409 |
#' @inheritParams formatters::make_row_df |
|
410 |
#' |
|
411 |
#' @export |
|
412 |
make_col_df <- function(tt, |
|
413 |
colwidths = NULL, |
|
414 |
visible_only = TRUE) { |
|
415 | 4270x |
ctree <- coltree(tt) ## this is a null op if its already a coltree object |
416 | 4270x |
rows <- inner_col_df(ctree, |
417 |
## colwidths is currently unused anyway... propose_column_widths(matrix_form(tt, indent_rownames=TRUE)), |
|
418 | 4270x |
colwidths = colwidths, |
419 | 4270x |
visible_only = visible_only, |
420 | 4270x |
colnum = 1L, |
421 | 4270x |
sibpos = 1L, |
422 | 4270x |
nsibs = 1L |
423 | 4270x |
) ## nsiblings includes current so 1 means "only child" |
424 | ||
425 | 4270x |
do.call(rbind, rows) |
426 |
} |
|
427 | ||
428 |
setMethod( |
|
429 |
"inner_col_df", "LayoutColLeaf", |
|
430 |
function(ct, colwidths, visible_only, |
|
431 |
colnum, |
|
432 |
sibpos, |
|
433 |
nsibs) { |
|
434 | 15871x |
list(col_dfrow( |
435 | 15871x |
col = ct, |
436 | 15871x |
cnum = colnum, |
437 | 15871x |
sibpos = sibpos, |
438 | 15871x |
nsibs = nsibs, |
439 | 15871x |
leaf_indices = colnum, |
440 | 15871x |
col_fnotes = col_footnotes(ct) |
441 |
)) |
|
442 |
} |
|
443 |
) |
|
444 | ||
445 |
setMethod( |
|
446 |
"inner_col_df", "LayoutColTree", |
|
447 |
function(ct, colwidths, visible_only, |
|
448 |
colnum, |
|
449 |
sibpos, |
|
450 |
nsibs) { |
|
451 | 8331x |
kids <- tree_children(ct) |
452 | 8331x |
ret <- vector("list", length(kids)) |
453 | 8331x |
for (i in seq_along(kids)) { |
454 | 19932x |
k <- kids[[i]] |
455 | 19932x |
newrows <- do.call( |
456 | 19932x |
rbind, |
457 | 19932x |
inner_col_df(k, |
458 | 19932x |
colnum = colnum, |
459 | 19932x |
sibpos = i, |
460 | 19932x |
nsibs = length(kids), |
461 | 19932x |
visible_only = visible_only |
462 |
) |
|
463 |
) |
|
464 | 19932x |
colnum <- max(newrows$abs_pos, colnum, na.rm = TRUE) + 1 |
465 | 19932x |
ret[[i]] <- newrows |
466 |
} |
|
467 | ||
468 | 8331x |
if (!visible_only) { |
469 | 1142x |
allindices <- unlist(lapply(ret, function(df) df$abs_pos[!is.na(df$abs_pos)])) |
470 | 1142x |
thispth <- pos_to_path(tree_pos(ct)) |
471 | 1142x |
if (any(nzchar(thispth))) { |
472 | 522x |
thisone <- list(col_dfrow( |
473 | 522x |
col = ct, |
474 | 522x |
cnum = NA_integer_, |
475 | 522x |
leaf_indices = allindices, |
476 | 522x |
sibpos = sibpos, |
477 | 522x |
nsibs = nsibs, |
478 | 522x |
pth = thispth, |
479 | 522x |
col_fnotes = col_footnotes(ct) |
480 |
)) |
|
481 | 522x |
ret <- c(thisone, ret) |
482 |
} |
|
483 |
} |
|
484 | ||
485 | 8331x |
ret |
486 |
} |
|
487 |
) |
|
488 | ||
489 |
## THIS INCLUDES BOTH "table stub" (i.e. column label and top_left) AND |
|
490 |
## title/subtitle!!!!! |
|
491 |
.header_rep_nlines <- function(tt, colwidths, max_width, verbose = FALSE) { |
|
492 | 3x |
cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width) |
493 | 3x |
if (any(nzchar(all_titles(tt)))) { |
494 |
## +1 is for blank line between subtitles and divider |
|
495 | 2x |
tlines <- sum(nlines(all_titles(tt), |
496 | 2x |
colwidths = colwidths, |
497 | 2x |
max_width = max_width |
498 | 2x |
)) + divider_height(tt) + 1L |
499 |
} else { |
|
500 | 1x |
tlines <- 0 |
501 |
} |
|
502 | 3x |
ret <- cinfo_lines + tlines |
503 | 3x |
if (verbose) { |
504 | ! |
message( |
505 | ! |
"Lines required for header content: ", |
506 | ! |
ret, " (col info: ", cinfo_lines, ", titles: ", tlines, ")" |
507 |
) |
|
508 |
} |
|
509 | 3x |
ret |
510 |
} |
|
511 | ||
512 |
## this is ***only*** lines that are expected to be repeated on multiple pages: |
|
513 |
## main footer, prov footer, and referential footnotes on **columns** |
|
514 | ||
515 |
.footer_rep_nlines <- function(tt, colwidths, max_width, have_cfnotes, verbose = FALSE) { |
|
516 | 3x |
flines <- nlines(main_footer(tt), |
517 | 3x |
colwidths = colwidths, |
518 | 3x |
max_width = max_width - table_inset(tt) |
519 |
) + |
|
520 | 3x |
nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width) |
521 | 3x |
if (flines > 0) { |
522 | 2x |
dl_contrib <- if (have_cfnotes) 0 else divider_height(tt) |
523 | 2x |
flines <- flines + dl_contrib + 1L |
524 |
} |
|
525 | ||
526 | 3x |
if (verbose) { |
527 | ! |
message( |
528 | ! |
"Determining lines required for footer content", |
529 | ! |
if (have_cfnotes) " [column fnotes present]", |
530 | ! |
": ", flines, " lines" |
531 |
) |
|
532 |
} |
|
533 | ||
534 | 3x |
flines |
535 |
} |
|
536 | ||
537 |
# Pagination --------------------------------------------------------------- |
|
538 | ||
539 |
#' Pagination of a `TableTree` |
|
540 |
#' |
|
541 |
#' Paginate an `rtables` table in the vertical and/or horizontal direction, as required for the specified page size. |
|
542 |
#' |
|
543 |
#' @inheritParams gen_args |
|
544 |
#' @inheritParams paginate_table |
|
545 |
#' @param lpp (`numeric(1)`)\cr maximum lines per page including (re)printed header and context rows. |
|
546 |
#' @param min_siblings (`numeric(1)`)\cr minimum sibling rows which must appear on either side of pagination row for a |
|
547 |
#' mid-subtable split to be valid. Defaults to 2. |
|
548 |
#' @param nosplitin (`character`)\cr names of sub-tables where page-breaks are not allowed, regardless of other |
|
549 |
#' considerations. Defaults to none. |
|
550 |
#' |
|
551 |
#' @return |
|
552 |
#' * `pag_tt_indices` returns a list of paginated-groups of row-indices of `tt`. |
|
553 |
#' * `paginate_table` returns the subtables defined by subsetting by the indices defined by `pag_tt_indices`. |
|
554 |
#' |
|
555 |
#' @details |
|
556 |
#' `rtables` pagination is context aware, meaning that label rows and row-group summaries (content rows) are repeated |
|
557 |
#' after (vertical) pagination, as appropriate. This allows the reader to immediately understand where they are in the |
|
558 |
#' table after turning to a new page, but does also mean that a rendered, paginated table will take up more lines of |
|
559 |
#' text than rendering the table without pagination would. |
|
560 |
#' |
|
561 |
#' Pagination also takes into account word-wrapping of title, footer, column-label, and formatted cell value content. |
|
562 |
#' |
|
563 |
#' Vertical pagination information (pagination `data.frame`) is created using (`make_row_df`). |
|
564 |
#' |
|
565 |
#' Horizontal pagination is performed by creating a pagination data frame for the columns, and then applying the same |
|
566 |
#' algorithm used for vertical pagination to it. |
|
567 |
#' |
|
568 |
#' If physical page size and font information are specified, these are used to derive lines-per-page (`lpp`) and |
|
569 |
#' characters-per-page (`cpp`) values. |
|
570 |
#' |
|
571 |
#' The full multi-direction pagination algorithm then is as follows: |
|
572 |
#' |
|
573 |
#' 0. Adjust `lpp` and `cpp` to account for rendered elements that are not rows (columns): |
|
574 |
#' - titles/footers/column labels, and horizontal dividers in the vertical pagination case |
|
575 |
#' - row-labels, table_inset, and top-left materials in the horizontal case |
|
576 |
#' 1. Perform 'forced pagination' representing page-by row splits, generating 1 or more tables. |
|
577 |
#' 2. Perform vertical pagination separately on each table generated in (1). |
|
578 |
#' 3. Perform horizontal pagination **on the entire table** and apply the results to each table |
|
579 |
#' page generated in (1)-(2). |
|
580 |
#' 4. Return a list of subtables representing full bi-directional pagination. |
|
581 |
#' |
|
582 |
#' Pagination in both directions is done using the *Core Pagination Algorithm* implemented in the `formatters` package: |
|
583 |
#' |
|
584 |
#' @inheritSection formatters::pagination_algo Pagination Algorithm |
|
585 |
#' |
|
586 |
#' @examples |
|
587 |
#' s_summary <- function(x) { |
|
588 |
#' if (is.numeric(x)) { |
|
589 |
#' in_rows( |
|
590 |
#' "n" = rcell(sum(!is.na(x)), format = "xx"), |
|
591 |
#' "Mean (sd)" = rcell(c(mean(x, na.rm = TRUE), sd(x, na.rm = TRUE)), |
|
592 |
#' format = "xx.xx (xx.xx)" |
|
593 |
#' ), |
|
594 |
#' "IQR" = rcell(IQR(x, na.rm = TRUE), format = "xx.xx"), |
|
595 |
#' "min - max" = rcell(range(x, na.rm = TRUE), format = "xx.xx - xx.xx") |
|
596 |
#' ) |
|
597 |
#' } else if (is.factor(x)) { |
|
598 |
#' vs <- as.list(table(x)) |
|
599 |
#' do.call(in_rows, lapply(vs, rcell, format = "xx")) |
|
600 |
#' } else { |
|
601 |
#' ( |
|
602 |
#' stop("type not supported") |
|
603 |
#' ) |
|
604 |
#' } |
|
605 |
#' } |
|
606 |
#' |
|
607 |
#' lyt <- basic_table() %>% |
|
608 |
#' split_cols_by(var = "ARM") %>% |
|
609 |
#' analyze(c("AGE", "SEX", "BEP01FL", "BMRKR1", "BMRKR2", "COUNTRY"), afun = s_summary) |
|
610 |
#' |
|
611 |
#' tbl <- build_table(lyt, ex_adsl) |
|
612 |
#' tbl |
|
613 |
#' |
|
614 |
#' nrow(tbl) |
|
615 |
#' |
|
616 |
#' row_paths_summary(tbl) |
|
617 |
#' |
|
618 |
#' tbls <- paginate_table(tbl, lpp = 15) |
|
619 |
#' mf <- matrix_form(tbl, indent_rownames = TRUE) |
|
620 |
#' w_tbls <- propose_column_widths(mf) # so that we have the same column widths |
|
621 |
#' |
|
622 |
#' |
|
623 |
#' tmp <- lapply(tbls, function(tbli) { |
|
624 |
#' cat(toString(tbli, widths = w_tbls)) |
|
625 |
#' cat("\n\n") |
|
626 |
#' cat("~~~~ PAGE BREAK ~~~~") |
|
627 |
#' cat("\n\n") |
|
628 |
#' }) |
|
629 |
#' |
|
630 |
#' @rdname paginate |
|
631 |
#' @export |
|
632 |
pag_tt_indices <- function(tt, |
|
633 |
lpp = 15, |
|
634 |
min_siblings = 2, |
|
635 |
nosplitin = character(), |
|
636 |
colwidths = NULL, |
|
637 |
max_width = NULL, |
|
638 |
verbose = FALSE) { |
|
639 | 3x |
dheight <- divider_height(tt) |
640 | ||
641 |
# cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width) |
|
642 | 3x |
coldf <- make_col_df(tt, colwidths) |
643 | 3x |
have_cfnotes <- length(unlist(coldf$col_fnotes)) > 0 |
644 | ||
645 | 3x |
hlines <- .header_rep_nlines(tt, |
646 | 3x |
colwidths = colwidths, max_width = max_width, |
647 | 3x |
verbose = verbose |
648 |
) |
|
649 |
## if(any(nzchar(all_titles(tt)))) { |
|
650 |
## tlines <- sum(nlines(all_titles(tt), colwidths = colwidths, max_width = max_width)) + |
|
651 |
## length(wrap_txt(all_titles(tt), max_width = max_width)) + |
|
652 |
## dheight + 1L |
|
653 |
## } else { |
|
654 |
## tlines <- 0 |
|
655 |
## } |
|
656 |
## flines <- nlines(main_footer(tt), colwidths = colwidths, |
|
657 |
## max_width = max_width - table_inset(tt)) + |
|
658 |
## nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width) |
|
659 |
## if(flines > 0) { |
|
660 |
## dl_contrib <- if(have_cfnotes) 0 else dheight |
|
661 |
## flines <- flines + dl_contrib + 1L |
|
662 |
## } |
|
663 | 3x |
flines <- .footer_rep_nlines(tt, |
664 | 3x |
colwidths = colwidths, max_width = max_width, |
665 | 3x |
have_cfnotes = have_cfnotes, verbose = verbose |
666 |
) |
|
667 |
## row lines per page |
|
668 | 3x |
rlpp <- lpp - hlines - flines |
669 | 3x |
if (verbose) { |
670 | ! |
message( |
671 | ! |
"Adjusted Lines Per Page: ", |
672 | ! |
rlpp, " (original lpp: ", lpp, ")" |
673 |
) |
|
674 |
} |
|
675 | 3x |
pagdf <- make_row_df(tt, colwidths, max_width = max_width) |
676 | ||
677 | 3x |
pag_indices_inner(pagdf, |
678 | 3x |
rlpp = rlpp, min_siblings = min_siblings, |
679 | 3x |
nosplitin = nosplitin, |
680 | 3x |
verbose = verbose, |
681 | 3x |
have_col_fnotes = have_cfnotes, |
682 | 3x |
div_height = dheight |
683 |
) |
|
684 |
} |
|
685 | ||
686 |
copy_title_footer <- function(to, from, newptitle) { |
|
687 | 18x |
main_title(to) <- main_title(from) |
688 | 18x |
subtitles(to) <- subtitles(from) |
689 | 18x |
page_titles(to) <- c(page_titles(from), newptitle) |
690 | 18x |
main_footer(to) <- main_footer(from) |
691 | 18x |
prov_footer(to) <- prov_footer(from) |
692 | 18x |
to |
693 |
} |
|
694 | ||
695 |
pag_btw_kids <- function(tt) { |
|
696 | 8x |
pref <- ptitle_prefix(tt) |
697 | 8x |
lapply( |
698 | 8x |
tree_children(tt), |
699 | 8x |
function(tbl) { |
700 | 18x |
tbl <- copy_title_footer( |
701 | 18x |
tbl, tt, |
702 | 18x |
paste(pref, obj_label(tbl), sep = ": ") |
703 |
) |
|
704 | 18x |
labelrow_visible(tbl) <- FALSE |
705 | 18x |
tbl |
706 |
} |
|
707 |
) |
|
708 |
} |
|
709 | ||
710 |
force_paginate <- function(tt, |
|
711 |
force_pag = vapply(tree_children(tt), has_force_pag, NA), |
|
712 |
verbose = FALSE) { |
|
713 |
## forced pagination is happening at this |
|
714 | 107x |
if (has_force_pag(tt)) { |
715 | 8x |
ret <- pag_btw_kids(tt) |
716 | 8x |
return(unlist(lapply(ret, force_paginate))) |
717 |
} |
|
718 | 99x |
chunks <- list() |
719 | 99x |
kinds <- seq_along(force_pag) |
720 | 99x |
while (length(kinds) > 0) { |
721 | 99x |
if (force_pag[kinds[1]]) { |
722 | ! |
outertbl <- copy_title_footer( |
723 | ! |
tree_children(tt)[[kinds[1]]], |
724 | ! |
tt, |
725 | ! |
NULL |
726 |
) |
|
727 | ||
728 | ! |
chunks <- c(chunks, force_paginate(outertbl)) |
729 | ! |
kinds <- kinds[-1] |
730 |
} else { |
|
731 | 99x |
tmptbl <- tt |
732 | 99x |
runend <- min(which(force_pag[kinds]), length(kinds)) |
733 | 99x |
useinds <- 1:runend |
734 | 99x |
tree_children(tmptbl) <- tree_children(tt)[useinds] |
735 | 99x |
chunks <- c(chunks, tmptbl) |
736 | 99x |
kinds <- kinds[-useinds] |
737 |
} |
|
738 |
} |
|
739 | 99x |
unlist(chunks, recursive = TRUE) |
740 |
} |
|
741 | ||
742 |
#' @importFrom formatters do_forced_paginate |
|
743 |
setMethod( |
|
744 |
"do_forced_paginate", "VTableTree", |
|
745 | 89x |
function(obj) force_paginate(obj) |
746 |
) |
|
747 | ||
748 | 178x |
non_null_na <- function(x) !is.null(x) && is.na(x) |
749 | ||
750 |
#' @inheritParams formatters::vert_pag_indices |
|
751 |
#' @inheritParams formatters::page_lcpp |
|
752 |
#' @inheritParams formatters::toString |
|
753 |
#' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) of the pages for horizontal pagination. |
|
754 |
#' `NA` (the default) indicates `cpp` should be inferred from the page size; `NULL` indicates no horizontal |
|
755 |
#' pagination should be done regardless of page size. |
|
756 |
#' |
|
757 |
#' @rdname paginate |
|
758 |
#' @aliases paginate_table |
|
759 |
#' @export |
|
760 |
paginate_table <- function(tt, |
|
761 |
page_type = "letter", |
|
762 |
font_family = "Courier", |
|
763 |
font_size = 8, |
|
764 |
lineheight = 1, |
|
765 |
landscape = FALSE, |
|
766 |
pg_width = NULL, |
|
767 |
pg_height = NULL, |
|
768 |
margins = c(top = .5, bottom = .5, left = .75, right = .75), |
|
769 |
lpp = NA_integer_, |
|
770 |
cpp = NA_integer_, |
|
771 |
min_siblings = 2, |
|
772 |
nosplitin = character(), |
|
773 |
colwidths = NULL, |
|
774 |
tf_wrap = FALSE, |
|
775 |
max_width = NULL, |
|
776 |
verbose = FALSE) { |
|
777 | 49x |
if ((non_null_na(lpp) || non_null_na(cpp)) && |
778 | 49x |
(!is.null(page_type) || (!is.null(pg_width) && !is.null(pg_height)))) { # nolint |
779 | 12x |
pg_lcpp <- page_lcpp( |
780 | 12x |
page_type = page_type, |
781 | 12x |
font_family = font_family, |
782 | 12x |
font_size = font_size, |
783 | 12x |
lineheight = lineheight, |
784 | 12x |
pg_width = pg_width, |
785 | 12x |
pg_height = pg_height, |
786 | 12x |
margins = margins, |
787 | 12x |
landscape = landscape |
788 |
) |
|
789 | ||
790 | 12x |
if (non_null_na(lpp)) { |
791 | 6x |
lpp <- pg_lcpp$lpp |
792 |
} |
|
793 | 12x |
if (is.na(cpp)) { |
794 | 8x |
cpp <- pg_lcpp$cpp |
795 |
} |
|
796 |
} else { |
|
797 | 37x |
if (non_null_na(cpp)) { |
798 | ! |
cpp <- NULL |
799 |
} |
|
800 | 37x |
if (non_null_na(lpp)) { |
801 | ! |
lpp <- 70 |
802 |
} |
|
803 |
} |
|
804 | ||
805 | 49x |
if (is.null(colwidths)) { |
806 | 32x |
colwidths <- propose_column_widths(matrix_form(tt, indent_rownames = TRUE)) |
807 |
} |
|
808 | ||
809 | 49x |
if (!tf_wrap) { |
810 | 39x |
if (!is.null(max_width)) { |
811 | ! |
warning("tf_wrap is FALSE - ignoring non-null max_width value.") |
812 |
} |
|
813 | 39x |
max_width <- NULL |
814 | 10x |
} else if (is.null(max_width)) { |
815 | 5x |
max_width <- cpp |
816 | 5x |
} else if (identical(max_width, "auto")) { |
817 |
## XXX this 3 is column sep width!!!!!!! |
|
818 | ! |
max_width <- sum(colwidths) + 3 * (length(colwidths) - 1) |
819 |
} |
|
820 | 49x |
if (!is.null(cpp) && !is.null(max_width) && max_width > cpp) { |
821 | ! |
warning("max_width specified is wider than characters per page width (cpp).") |
822 |
} |
|
823 | ||
824 |
## taken care of in vert_pag_indices now |
|
825 |
## if(!is.null(cpp)) |
|
826 |
## cpp <- cpp - table_inset(tt) |
|
827 | ||
828 | 49x |
force_pag <- vapply(tree_children(tt), has_force_pag, TRUE) |
829 | 49x |
if (has_force_pag(tt) || any(force_pag)) { |
830 | 5x |
spltabs <- do_forced_paginate(tt) |
831 | 5x |
spltabs <- unlist(spltabs, recursive = TRUE) |
832 | 5x |
ret <- lapply(spltabs, paginate_table, |
833 | 5x |
lpp = lpp, |
834 | 5x |
cpp = cpp, |
835 | 5x |
min_siblings = min_siblings, |
836 | 5x |
nosplitin = nosplitin, |
837 | 5x |
colwidths = colwidths, |
838 | 5x |
tf_wrap = tf_wrap, |
839 | 5x |
max_width = max_width, |
840 | 5x |
verbose = verbose |
841 |
) |
|
842 | 5x |
return(unlist(ret, recursive = TRUE)) |
843 |
} |
|
844 | ||
845 | 44x |
inds <- paginate_indices(tt, |
846 | 44x |
page_type = page_type, |
847 | 44x |
font_family = font_family, |
848 | 44x |
font_size = font_size, |
849 | 44x |
lineheight = lineheight, |
850 | 44x |
landscape = landscape, |
851 | 44x |
pg_width = pg_width, |
852 | 44x |
pg_height = pg_height, |
853 | 44x |
margins = margins, |
854 | 44x |
lpp = lpp, |
855 | 44x |
cpp = cpp, |
856 | 44x |
min_siblings = min_siblings, |
857 | 44x |
nosplitin = nosplitin, |
858 | 44x |
colwidths = colwidths, |
859 | 44x |
tf_wrap = tf_wrap, |
860 | 44x |
max_width = max_width, |
861 | 44x |
verbose = verbose |
862 | 44x |
) ## paginate_table apparently doesn't accept indent_size |
863 | ||
864 | 40x |
res <- lapply( |
865 | 40x |
inds$pag_row_indices, |
866 | 40x |
function(ii) { |
867 | 115x |
subt <- tt[ii, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE] |
868 | 115x |
lapply( |
869 | 115x |
inds$pag_col_indices, |
870 | 115x |
function(jj) { |
871 | 207x |
subt[, jj, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE] |
872 |
} |
|
873 |
) |
|
874 |
} |
|
875 |
) |
|
876 | 40x |
res <- unlist(res, recursive = FALSE) |
877 | 40x |
res |
878 |
} |
1 |
#' Cell value constructors |
|
2 |
#' |
|
3 |
#' Construct a cell value and associate formatting, labeling, indenting, and column spanning information with it. |
|
4 |
#' |
|
5 |
#' @inheritParams compat_args |
|
6 |
#' @inheritParams lyt_args |
|
7 |
#' @param x (`ANY`)\cr cell value. |
|
8 |
#' @param format (`string` or `function`)\cr the format label (string) or `formatters` function to apply to `x`. |
|
9 |
#' See [formatters::list_valid_format_labels()] for currently supported format labels. |
|
10 |
#' @param label (`string` or `NULL`)\cr label. If non-`NULL`, it will be looked at when determining row labels. |
|
11 |
#' @param colspan (`integer(1)`)\cr column span value. |
|
12 |
#' @param footnotes (`list` or `NULL`)\cr referential footnote messages for the cell. |
|
13 |
#' |
|
14 |
#' @inherit CellValue return |
|
15 |
#' |
|
16 |
#' @note Currently column spanning is only supported for defining header structure. |
|
17 |
#' |
|
18 |
#' @rdname rcell |
|
19 |
#' @export |
|
20 |
rcell <- function(x, |
|
21 |
format = NULL, |
|
22 |
colspan = 1L, |
|
23 |
label = NULL, |
|
24 |
indent_mod = NULL, |
|
25 |
footnotes = NULL, |
|
26 |
align = NULL, |
|
27 |
format_na_str = NULL) { |
|
28 | 31027x |
if (!is.null(align)) { |
29 | 56x |
check_aligns(align) |
30 |
} |
|
31 | 31027x |
if (is(x, "CellValue")) { |
32 | 18825x |
if (!is.null(label)) { |
33 | 1x |
obj_label(x) <- label |
34 |
} |
|
35 | 18825x |
if (colspan != 1L) { |
36 | 1x |
cell_cspan(x) <- colspan |
37 |
} |
|
38 | 18825x |
if (!is.null(indent_mod)) { |
39 | 1x |
indent_mod(x) <- indent_mod |
40 |
} |
|
41 | 18825x |
if (!is.null(format)) { |
42 | 1x |
obj_format(x) <- format |
43 |
} |
|
44 | 18825x |
if (!is.null(footnotes)) { |
45 | 357x |
cell_footnotes(x) <- lapply(footnotes, RefFootnote) |
46 |
} |
|
47 | 18825x |
if (!is.null(format_na_str)) { |
48 | ! |
obj_na_str(x) <- format_na_str |
49 |
} |
|
50 | 18825x |
ret <- x |
51 |
} else { |
|
52 | 12202x |
if (is.null(label)) { |
53 | 9275x |
label <- obj_label(x) |
54 |
} |
|
55 | 12202x |
if (is.null(format)) { |
56 | 6683x |
format <- obj_format(x) |
57 |
} |
|
58 | 12202x |
if (is.null(indent_mod)) { |
59 | 12202x |
indent_mod <- indent_mod(x) |
60 |
} |
|
61 | 12202x |
footnotes <- lapply(footnotes, RefFootnote) |
62 | 12202x |
ret <- CellValue( |
63 | 12202x |
val = x, |
64 | 12202x |
format = format, |
65 | 12202x |
colspan = colspan, |
66 | 12202x |
label = label, |
67 | 12202x |
indent_mod = indent_mod, |
68 | 12202x |
footnotes = footnotes, |
69 | 12202x |
format_na_str = format_na_str |
70 | 12202x |
) # RefFootnote(footnote)) |
71 |
} |
|
72 | 31027x |
if (!is.null(align)) { |
73 | 56x |
cell_align(ret) <- align |
74 |
} |
|
75 | 31027x |
ret |
76 |
} |
|
77 | ||
78 |
#' @param is_ref (`flag`)\cr whether function is being used in the reference column (i.e. `.in_ref_col` should be |
|
79 |
#' passed to this argument). |
|
80 |
#' @param refval (`ANY`)\cr value to use when in the reference column. Defaults to `NULL`. |
|
81 |
#' |
|
82 |
#' @details |
|
83 |
#' `non_ref_rcell` provides the common *blank for cells in the reference column, this value otherwise*, and should |
|
84 |
#' be passed the value of `.in_ref_col` when it is used. |
|
85 |
#' |
|
86 |
#' @rdname rcell |
|
87 |
#' @export |
|
88 |
non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L, |
|
89 |
label = NULL, indent_mod = NULL, |
|
90 |
refval = NULL, |
|
91 |
align = "center", |
|
92 |
format_na_str = NULL) { |
|
93 | 2x |
val <- if (is_ref) refval else x |
94 | 2x |
rcell(val, |
95 | 2x |
format = format, colspan = colspan, label = label, |
96 | 2x |
indent_mod = indent_mod, align = align, |
97 | 2x |
format_na_str = format_na_str |
98 |
) |
|
99 |
} |
|
100 | ||
101 |
#' Create multiple rows in analysis or summary functions |
|
102 |
#' |
|
103 |
#' Define the cells that get placed into multiple rows in `afun`. |
|
104 |
#' |
|
105 |
#' @param ... single row defining expressions. |
|
106 |
#' @param .list (`list`)\cr list cell content (usually `rcells`). The `.list` is concatenated to `...`. |
|
107 |
#' @param .names (`character` or `NULL`)\cr names of the returned list/structure. |
|
108 |
#' @param .labels (`character` or `NULL`)\cr labels for the defined rows. |
|
109 |
#' @param .formats (`character` or `NULL`)\cr formats for the values. |
|
110 |
#' @param .indent_mods (`integer` or `NULL`)\cr indent modifications for the defined rows. |
|
111 |
#' @param .cell_footnotes (`list`)\cr referential footnote messages to be associated by name with *cells*. |
|
112 |
#' @param .row_footnotes (`list`)\cr referential footnotes messages to be associated by name with *rows*. |
|
113 |
#' @param .aligns (`character` or `NULL`)\cr alignments for the cells. Standard for `NULL` is `"center"`. |
|
114 |
#' See [formatters::list_valid_aligns()] for currently supported alignments. |
|
115 |
#' @param .format_na_strs (`character` or `NULL`)\cr NA strings for the cells. |
|
116 |
#' |
|
117 |
#' @note In post-processing, referential footnotes can also be added using row and column |
|
118 |
#' paths with [`fnotes_at_path<-`]. |
|
119 |
#' |
|
120 |
#' @return A `RowsVerticalSection` object (or `NULL`). The details of this object should be considered an |
|
121 |
#' internal implementation detail. |
|
122 |
#' |
|
123 |
#' @seealso [analyze()] |
|
124 |
#' |
|
125 |
#' @examples |
|
126 |
#' in_rows(1, 2, 3, .names = c("a", "b", "c")) |
|
127 |
#' in_rows(1, 2, 3, .labels = c("a", "b", "c")) |
|
128 |
#' in_rows(1, 2, 3, .names = c("a", "b", "c"), .labels = c("AAA", "BBB", "CCC")) |
|
129 |
#' |
|
130 |
#' in_rows(.list = list(a = 1, b = 2, c = 3)) |
|
131 |
#' in_rows(1, 2, .list = list(3), .names = c("a", "b", "c")) |
|
132 |
#' |
|
133 |
#' lyt <- basic_table() %>% |
|
134 |
#' split_cols_by("ARM") %>% |
|
135 |
#' analyze("AGE", afun = function(x) { |
|
136 |
#' in_rows( |
|
137 |
#' "Mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), |
|
138 |
#' "Range" = rcell(range(x), format = "xx.xx - xx.xx") |
|
139 |
#' ) |
|
140 |
#' }) |
|
141 |
#' |
|
142 |
#' tbl <- build_table(lyt, ex_adsl) |
|
143 |
#' tbl |
|
144 |
#' |
|
145 |
#' @export |
|
146 |
in_rows <- function(..., .list = NULL, .names = NULL, |
|
147 |
.labels = NULL, |
|
148 |
.formats = NULL, |
|
149 |
.indent_mods = NULL, |
|
150 |
.cell_footnotes = list(NULL), |
|
151 |
.row_footnotes = list(NULL), |
|
152 |
.aligns = NULL, |
|
153 |
.format_na_strs = NULL) { |
|
154 | 5800x |
if (is.function(.formats)) { |
155 | ! |
.formats <- list(.formats) |
156 |
} |
|
157 | ||
158 | 5800x |
l <- c(list(...), .list) |
159 | ||
160 | 5800x |
if (missing(.names) && missing(.labels)) { |
161 | 1736x |
if (length(l) > 0 && is.null(names(l))) { |
162 | ! |
stop("need a named list") |
163 |
} else { |
|
164 | 1736x |
.names <- names(l) |
165 |
} |
|
166 | 1736x |
stopifnot(!anyNA(.names)) |
167 |
} |
|
168 | ||
169 | 5800x |
if (length(l) == 0) { |
170 |
if ( |
|
171 | ! |
length(.labels) > 0 || |
172 | ! |
length(.formats) > 0 || |
173 | ! |
length(.names) > 0 || |
174 | ! |
length(.indent_mods) > 0 || |
175 | ! |
length(.format_na_strs) > 0 |
176 |
) { |
|
177 | ! |
stop( |
178 | ! |
"in_rows got 0 rows but length >0 of at least one of ", |
179 | ! |
".labels, .formats, .names, .indent_mods, .format_na_strs. ", |
180 | ! |
"Does your analysis/summary function handle the 0 row ", |
181 | ! |
"df/length 0 x case?" |
182 |
) |
|
183 |
} |
|
184 | ! |
l2 <- list() |
185 |
} else { |
|
186 | 5800x |
if (is.null(.formats)) { |
187 | 5340x |
.formats <- list(NULL) |
188 |
} |
|
189 | 5800x |
stopifnot(is.list(.cell_footnotes)) |
190 | 5800x |
if (length(.cell_footnotes) != length(l)) { |
191 | 1230x |
.cell_footnotes <- c( |
192 | 1230x |
.cell_footnotes, |
193 | 1230x |
setNames( |
194 | 1230x |
rep(list(character()), |
195 | 1230x |
length.out = length(setdiff( |
196 | 1230x |
names(l), |
197 | 1230x |
names(.cell_footnotes) |
198 |
)) |
|
199 |
), |
|
200 | 1230x |
setdiff( |
201 | 1230x |
names(l), |
202 | 1230x |
names(.cell_footnotes) |
203 |
) |
|
204 |
) |
|
205 |
) |
|
206 | 1230x |
.cell_footnotes <- .cell_footnotes[names(l)] |
207 |
} |
|
208 | 5800x |
if (is.null(.aligns)) { |
209 | 5797x |
.aligns <- list(NULL) |
210 |
} |
|
211 | 5800x |
l2 <- mapply(rcell, |
212 | 5800x |
x = l, format = .formats, |
213 | 5800x |
footnotes = .cell_footnotes %||% list(NULL), |
214 | 5800x |
align = .aligns, |
215 | 5800x |
format_na_str = .format_na_strs %||% list(NULL), |
216 | 5800x |
SIMPLIFY = FALSE |
217 |
) |
|
218 |
} |
|
219 | 5800x |
if (is.null(.labels)) { |
220 | 2600x |
objlabs <- vapply(l2, function(x) obj_label(x) %||% "", "") |
221 | 2600x |
if (any(nzchar(objlabs))) { |
222 | 69x |
.labels <- objlabs |
223 |
} |
|
224 |
} |
|
225 | ||
226 | 5800x |
if (is.null(.names) && !is.null(names(l))) { |
227 | 97x |
.names <- names(l) |
228 |
} |
|
229 | 5800x |
stopifnot(is.list(.row_footnotes)) |
230 | 5800x |
if (length(.row_footnotes) != length(l2)) { |
231 | 1230x |
tmp <- .row_footnotes |
232 | 1230x |
.row_footnotes <- vector("list", length(l2)) |
233 | 1230x |
pos <- match(names(tmp), .names) |
234 | 1230x |
nonna <- which(!is.na(pos)) |
235 | 1230x |
.row_footnotes[pos] <- tmp[nonna] |
236 |
# length(.row_footnotes) <- length(l2) |
|
237 |
} |
|
238 | 5800x |
ret <- RowsVerticalSection(l2, |
239 | 5800x |
names = .names, |
240 | 5800x |
labels = .labels, |
241 | 5800x |
indent_mods = .indent_mods, |
242 | 5800x |
formats = .formats, |
243 | 5800x |
footnotes = .row_footnotes, |
244 | 5800x |
format_na_strs = .format_na_strs |
245 |
) |
|
246 |
## if(!is.null(.names)) |
|
247 |
## names(l2) <- .names |
|
248 |
## else |
|
249 |
## names(l2) <- names(l) |
|
250 | ! |
if (length(ret) == 0) NULL else ret |
251 | ||
252 |
## if (length(l) == 0) NULL else l |
|
253 |
} |
|
254 | ||
255 |
.validate_nms <- function(vals, .stats, arg) { |
|
256 | 268x |
if (!is.null(arg)) { |
257 | 112x |
if (is.null(names(arg))) { |
258 | ! |
stopifnot(length(arg) == length(.stats)) |
259 | ! |
names(arg) <- names(vals) |
260 |
} else { |
|
261 | 112x |
lblpos <- match(names(arg), names(vals)) |
262 | 112x |
stopifnot(!anyNA(lblpos)) |
263 |
} |
|
264 |
} |
|
265 | 268x |
arg |
266 |
} |
|
267 | ||
268 |
#' Create a custom analysis function wrapping an existing function |
|
269 |
#' |
|
270 |
#' @param fun (`function`)\cr the function to be wrapped in a new customized analysis function. |
|
271 |
#' `fun` should return a named `list`. |
|
272 |
#' @param .stats (`character`)\cr names of elements to keep from `fun`'s full output. |
|
273 |
#' @param .formats (`ANY`)\cr vector or list of formats to override any defaults applied by `fun`. |
|
274 |
#' @param .labels (`character`)\cr vector of labels to override defaults returned by `fun`. |
|
275 |
#' @param .indent_mods (`integer`)\cr named vector of indent modifiers for the generated rows. |
|
276 |
#' @param .ungroup_stats (`character`)\cr vector of names, which must match elements of `.stats`. |
|
277 |
#' @param ... additional arguments to `fun` which effectively become new defaults. These can still be |
|
278 |
#' overridden by `extra_args` within a split. |
|
279 |
#' @param .null_ref_cells (`flag`)\cr whether cells for the reference column should be `NULL`-ed by the |
|
280 |
#' returned analysis function. Defaults to `TRUE` if `fun` accepts `.in_ref_col` as a formal argument. Note |
|
281 |
#' this argument occurs after `...` so it must be *fully* specified by name when set. |
|
282 |
#' @param .format_na_strs (`ANY`)\cr vector/list of `NA` strings to override any defaults applied by `fun`. |
|
283 |
#' |
|
284 |
#' @return A function suitable for use in [analyze()] with element selection, reformatting, and relabeling |
|
285 |
#' performed automatically. |
|
286 |
#' |
|
287 |
#' @note |
|
288 |
#' Setting `.ungroup_stats` to non-`NULL` changes the *structure* of the value(s) returned by `fun`, rather than |
|
289 |
#' just labeling (`.labels`), formatting (`.formats`), and selecting amongst (`.stats`) them. This means that |
|
290 |
#' subsequent `make_afun` calls to customize the output further both can and must operate on the new structure, |
|
291 |
#' *not* the original structure returned by `fun`. See the final pair of examples below. |
|
292 |
#' |
|
293 |
#' @seealso [analyze()] |
|
294 |
#' |
|
295 |
#' @examples |
|
296 |
#' s_summary <- function(x) { |
|
297 |
#' stopifnot(is.numeric(x)) |
|
298 |
#' |
|
299 |
#' list( |
|
300 |
#' n = sum(!is.na(x)), |
|
301 |
#' mean_sd = c(mean = mean(x), sd = sd(x)), |
|
302 |
#' min_max = range(x) |
|
303 |
#' ) |
|
304 |
#' } |
|
305 |
#' |
|
306 |
#' s_summary(iris$Sepal.Length) |
|
307 |
#' |
|
308 |
#' a_summary <- make_afun( |
|
309 |
#' fun = s_summary, |
|
310 |
#' .formats = c(n = "xx", mean_sd = "xx.xx (xx.xx)", min_max = "xx.xx - xx.xx"), |
|
311 |
#' .labels = c(n = "n", mean_sd = "Mean (sd)", min_max = "min - max") |
|
312 |
#' ) |
|
313 |
#' |
|
314 |
#' a_summary(x = iris$Sepal.Length) |
|
315 |
#' |
|
316 |
#' a_summary2 <- make_afun(a_summary, .stats = c("n", "mean_sd")) |
|
317 |
#' |
|
318 |
#' a_summary2(x = iris$Sepal.Length) |
|
319 |
#' |
|
320 |
#' a_summary3 <- make_afun(a_summary, .formats = c(mean_sd = "(xx.xxx, xx.xxx)")) |
|
321 |
#' |
|
322 |
#' s_foo <- function(df, .N_col, a = 1, b = 2) { |
|
323 |
#' list( |
|
324 |
#' nrow_df = nrow(df), |
|
325 |
#' .N_col = .N_col, |
|
326 |
#' a = a, |
|
327 |
#' b = b |
|
328 |
#' ) |
|
329 |
#' } |
|
330 |
#' |
|
331 |
#' s_foo(iris, 40) |
|
332 |
#' |
|
333 |
#' a_foo <- make_afun(s_foo, |
|
334 |
#' b = 4, |
|
335 |
#' .formats = c(nrow_df = "xx.xx", ".N_col" = "xx.", a = "xx", b = "xx.x"), |
|
336 |
#' .labels = c( |
|
337 |
#' nrow_df = "Nrow df", |
|
338 |
#' ".N_col" = "n in cols", a = "a value", b = "b value" |
|
339 |
#' ), |
|
340 |
#' .indent_mods = c(nrow_df = 2L, a = 1L) |
|
341 |
#' ) |
|
342 |
#' |
|
343 |
#' a_foo(iris, .N_col = 40) |
|
344 |
#' a_foo2 <- make_afun(a_foo, .labels = c(nrow_df = "Number of Rows")) |
|
345 |
#' a_foo2(iris, .N_col = 40) |
|
346 |
#' |
|
347 |
#' # grouping and further customization |
|
348 |
#' s_grp <- function(df, .N_col, a = 1, b = 2) { |
|
349 |
#' list( |
|
350 |
#' nrow_df = nrow(df), |
|
351 |
#' .N_col = .N_col, |
|
352 |
#' letters = list( |
|
353 |
#' a = a, |
|
354 |
#' b = b |
|
355 |
#' ) |
|
356 |
#' ) |
|
357 |
#' } |
|
358 |
#' a_grp <- make_afun(s_grp, |
|
359 |
#' b = 3, |
|
360 |
#' .labels = c( |
|
361 |
#' nrow_df = "row count", |
|
362 |
#' .N_col = "count in column" |
|
363 |
#' ), |
|
364 |
#' .formats = c(nrow_df = "xx.", .N_col = "xx."), |
|
365 |
#' .indent_mods = c(letters = 1L), |
|
366 |
#' .ungroup_stats = "letters" |
|
367 |
#' ) |
|
368 |
#' a_grp(iris, 40) |
|
369 |
#' a_aftergrp <- make_afun(a_grp, |
|
370 |
#' .stats = c("nrow_df", "b"), |
|
371 |
#' .formats = c(b = "xx.") |
|
372 |
#' ) |
|
373 |
#' a_aftergrp(iris, 40) |
|
374 |
#' |
|
375 |
#' s_ref <- function(x, .in_ref_col, .ref_group) { |
|
376 |
#' list( |
|
377 |
#' mean_diff = mean(x) - mean(.ref_group) |
|
378 |
#' ) |
|
379 |
#' } |
|
380 |
#' |
|
381 |
#' a_ref <- make_afun(s_ref, |
|
382 |
#' .labels = c(mean_diff = "Mean Difference from Ref") |
|
383 |
#' ) |
|
384 |
#' a_ref(iris$Sepal.Length, .in_ref_col = TRUE, 1:10) |
|
385 |
#' a_ref(iris$Sepal.Length, .in_ref_col = FALSE, 1:10) |
|
386 |
#' |
|
387 |
#' @export |
|
388 |
make_afun <- function(fun, |
|
389 |
.stats = NULL, |
|
390 |
.formats = NULL, |
|
391 |
.labels = NULL, |
|
392 |
.indent_mods = NULL, |
|
393 |
.ungroup_stats = NULL, |
|
394 |
.format_na_strs = NULL, |
|
395 |
..., |
|
396 |
.null_ref_cells = ".in_ref_col" %in% names(formals(fun))) { |
|
397 |
## there is a LOT more computing-on-the-language hackery in here that I |
|
398 |
## would prefer, but currently this is the way I see to do everything we |
|
399 |
## want to do. |
|
400 | ||
401 |
## too clever by three-quarters (because half wasn't enough) |
|
402 |
## gross scope hackery |
|
403 | 23x |
fun_args <- force(list(...)) |
404 | 23x |
fun_fnames <- names(formals(fun)) |
405 | ||
406 |
## force EVERYTHING otherwise calling this within loops is the stuff of |
|
407 |
## nightmares |
|
408 | 23x |
force(.stats) |
409 | 23x |
force(.formats) |
410 | 23x |
force(.format_na_strs) |
411 | 23x |
force(.labels) |
412 | 23x |
force(.indent_mods) |
413 | 23x |
force(.ungroup_stats) |
414 | 23x |
force(.null_ref_cells) ## this one probably isn't needed? |
415 | ||
416 | 23x |
ret <- function(x, ...) { ## remember formals get clobbered here |
417 | ||
418 |
## this helper will grab the value and wrap it in a named list if |
|
419 |
## we need the variable and return list() otherwise. |
|
420 |
## We define it in here so that the scoping hackery works correctly |
|
421 | 66x |
.if_in_formals <- function(nm, ifnot = list(), named_lwrap = TRUE) { |
422 | 660x |
val <- if (nm %in% fun_fnames) get(nm) else ifnot |
423 | 660x |
if (named_lwrap && !identical(val, ifnot)) { |
424 | 78x |
setNames(list(val), nm) |
425 |
} else { |
|
426 | 582x |
val |
427 |
} |
|
428 |
} |
|
429 | ||
430 | 66x |
custargs <- fun_args |
431 | ||
432 |
## special handling cause I need it at the bottom as well |
|
433 | 66x |
in_rc_argl <- .if_in_formals(".in_ref_col") |
434 | 66x |
.in_ref_col <- if (length(in_rc_argl) > 0) in_rc_argl[[1]] else FALSE |
435 | ||
436 | 66x |
sfunargs <- c( |
437 |
## these are either named lists containing the arg, or list() |
|
438 |
## depending on whether fun accept the argument or not |
|
439 | 66x |
.if_in_formals("x"), |
440 | 66x |
.if_in_formals("df"), |
441 | 66x |
.if_in_formals(".N_col"), |
442 | 66x |
.if_in_formals(".N_total"), |
443 | 66x |
.if_in_formals(".N_row"), |
444 | 66x |
.if_in_formals(".ref_group"), |
445 | 66x |
in_rc_argl, |
446 | 66x |
.if_in_formals(".df_row"), |
447 | 66x |
.if_in_formals(".var"), |
448 | 66x |
.if_in_formals(".ref_full") |
449 |
) |
|
450 | ||
451 | 66x |
allvars <- setdiff(fun_fnames, c("...", names(sfunargs))) |
452 |
## values int he actual call to this function override customization |
|
453 |
## done by the constructor. evalparse is to avoid a "... in wrong context" NOTE |
|
454 | 66x |
if ("..." %in% fun_fnames) { |
455 | 5x |
exargs <- eval(parser_helper(text = "list(...)")) |
456 | 5x |
custargs[names(exargs)] <- exargs |
457 | 5x |
allvars <- unique(c(allvars, names(custargs))) |
458 |
} |
|
459 | ||
460 | 66x |
for (var in allvars) { |
461 |
## not missing, i.e. specified in the direct call, takes precedence |
|
462 | 22x |
if (var %in% fun_fnames && eval(parser_helper(text = paste0("!missing(", var, ")")))) { |
463 | 5x |
sfunargs[[var]] <- get(var) |
464 | 17x |
} else if (var %in% names(custargs)) { ## not specified in the call, but specified in the constructor |
465 | 4x |
sfunargs[[var]] <- custargs[[var]] |
466 |
} |
|
467 |
## else left out so we hit the original default we inherited from fun |
|
468 |
} |
|
469 | ||
470 | 66x |
rawvals <- do.call(fun, sfunargs) |
471 | ||
472 |
## note single brackets here so its a list |
|
473 |
## no matter what. thats important! |
|
474 | 66x |
final_vals <- if (is.null(.stats)) rawvals else rawvals[.stats] |
475 | ||
476 | 66x |
if (!is.list(rawvals)) { |
477 | ! |
stop("make_afun expects a function fun that always returns a list") |
478 |
} |
|
479 | 66x |
if (!is.null(.stats)) { |
480 | 10x |
stopifnot(all(.stats %in% names(rawvals))) |
481 |
} else { |
|
482 | 56x |
.stats <- names(rawvals) |
483 |
} |
|
484 | 66x |
if (!is.null(.ungroup_stats) && !all(.ungroup_stats %in% .stats)) { |
485 | ! |
stop( |
486 | ! |
"Stats specified for ungrouping not included in non-null .stats list: ", |
487 | ! |
setdiff(.ungroup_stats, .stats) |
488 |
) |
|
489 |
} |
|
490 | ||
491 | 66x |
.labels <- .validate_nms(final_vals, .stats, .labels) |
492 | 66x |
.formats <- .validate_nms(final_vals, .stats, .formats) |
493 | 66x |
.indent_mods <- .validate_nms(final_vals, .stats, .indent_mods) |
494 | 66x |
.format_na_strs <- .validate_nms(final_vals, .stats, .format_na_strs) |
495 | ||
496 | 66x |
final_labels <- value_labels(final_vals) |
497 | 66x |
final_labels[names(.labels)] <- .labels |
498 | ||
499 | 66x |
final_formats <- lapply(final_vals, obj_format) |
500 | 66x |
final_formats[names(.formats)] <- .formats |
501 | ||
502 | 66x |
final_format_na_strs <- lapply(final_vals, obj_na_str) |
503 | 66x |
final_format_na_strs[names(.format_na_strs)] <- .format_na_strs |
504 | ||
505 | 66x |
if (is(final_vals, "RowsVerticalSection")) { |
506 | 20x |
final_imods <- indent_mod(final_vals) |
507 |
} else { |
|
508 | 46x |
final_imods <- vapply(final_vals, indent_mod, 1L) |
509 |
} |
|
510 | 66x |
final_imods[names(.indent_mods)] <- .indent_mods |
511 | ||
512 | 66x |
if (!is.null(.ungroup_stats)) { |
513 | 2x |
for (nm in .ungroup_stats) { |
514 | 3x |
tmp <- final_vals[[nm]] |
515 | 3x |
if (is(tmp, "CellValue")) { |
516 | 1x |
tmp <- tmp[[1]] |
517 | 23x |
} ## unwrap it |
518 | 3x |
final_vals <- insert_replace(final_vals, nm, tmp) |
519 | 3x |
stopifnot(all(nzchar(names(final_vals)))) |
520 | ||
521 | 3x |
final_labels <- insert_replace( |
522 | 3x |
final_labels, |
523 | 3x |
nm, |
524 | 3x |
setNames( |
525 | 3x |
value_labels(tmp), |
526 | 3x |
names(tmp) |
527 |
) |
|
528 |
) |
|
529 | 3x |
final_formats <- insert_replace( |
530 | 3x |
final_formats, |
531 | 3x |
nm, |
532 | 3x |
setNames( |
533 | 3x |
rep(final_formats[nm], |
534 | 3x |
length.out = length(tmp) |
535 |
), |
|
536 | 3x |
names(tmp) |
537 |
) |
|
538 |
) |
|
539 | 3x |
final_format_na_strs <- insert_replace( |
540 | 3x |
final_format_na_strs, |
541 | 3x |
nm, |
542 | 3x |
setNames( |
543 | 3x |
rep(final_format_na_strs[nm], |
544 | 3x |
length.out = length(tmp) |
545 |
), |
|
546 | 3x |
names(tmp) |
547 |
) |
|
548 |
) |
|
549 | 3x |
final_imods <- insert_replace( |
550 | 3x |
final_imods, |
551 | 3x |
nm, |
552 | 3x |
setNames( |
553 | 3x |
rep(final_imods[nm], |
554 | 3x |
length.out = length(tmp) |
555 |
), |
|
556 | 3x |
names(tmp) |
557 |
) |
|
558 |
) |
|
559 |
} |
|
560 |
} |
|
561 | 66x |
rcells <- mapply( |
562 | 66x |
function(x, f, l, na_str) { |
563 | 197x |
if (is(x, "CellValue")) { |
564 | 65x |
obj_label(x) <- l |
565 | 65x |
obj_format(x) <- f |
566 | 65x |
obj_na_str(x) <- na_str |
567 |
# indent_mod(x) <- im |
|
568 | 65x |
x |
569 | 132x |
} else if (.null_ref_cells) { |
570 | ! |
non_ref_rcell(x, |
571 | ! |
is_ref = .in_ref_col, |
572 | ! |
format = f, label = l, |
573 | ! |
format_na_str = na_str |
574 | ! |
) # , indent_mod = im) |
575 |
} else { |
|
576 | 132x |
rcell(x, format = f, label = l, format_na_str = na_str) # , indent_mod = im) |
577 |
} |
|
578 |
}, |
|
579 | 66x |
f = final_formats, x = final_vals, |
580 | 66x |
l = final_labels, |
581 | 66x |
na_str = final_format_na_strs, |
582 |
# im = final_imods, |
|
583 | 66x |
SIMPLIFY = FALSE |
584 |
) |
|
585 | 66x |
in_rows(.list = rcells, .indent_mods = final_imods) ## , .labels = .labels) |
586 |
} |
|
587 | 23x |
formals(ret) <- formals(fun) |
588 | 23x |
ret |
589 |
} |
|
590 | ||
591 |
insert_replace <- function(x, nm, newvals = x[[nm]]) { |
|
592 | 15x |
i <- match(nm, names(x)) |
593 | 15x |
if (is.na(i)) { |
594 | ! |
stop("name not found") |
595 |
} |
|
596 | 15x |
bef <- if (i > 1) 1:(i - 1) else numeric() |
597 | 15x |
aft <- if (i < length(x)) (i + 1):length(x) else numeric() |
598 | 15x |
ret <- c(x[bef], newvals, x[aft]) |
599 | 15x |
names(ret) <- c(names(x)[bef], names(newvals), names(x)[aft]) |
600 | 15x |
ret |
601 |
} |
|
602 | ||
603 |
parser_helper <- function(text, envir = parent.frame(2)) { |
|
604 | 495x |
parse(text = text, keep.source = FALSE) |
605 |
} |
|
606 | ||
607 |
length_w_name <- function(x, .parent_splval) { |
|
608 | ! |
in_rows(length(x), |
609 | ! |
.names = value_labels(.parent_splval) |
610 |
) |
|
611 |
} |
1 |
# paths summary ---- |
|
2 | ||
3 |
#' Get a list of table row/column paths |
|
4 |
#' |
|
5 |
#' @param x (`VTableTree`)\cr an `rtable` object. |
|
6 |
#' |
|
7 |
#' @return A list of paths to each row/column within `x`. |
|
8 |
#' |
|
9 |
#' @seealso [cell_values()], [`fnotes_at_path<-`], [row_paths_summary()], [col_paths_summary()] |
|
10 |
#' |
|
11 |
#' @examples |
|
12 |
#' lyt <- basic_table() %>% |
|
13 |
#' split_cols_by("ARM") %>% |
|
14 |
#' analyze(c("SEX", "AGE")) |
|
15 |
#' |
|
16 |
#' tbl <- build_table(lyt, ex_adsl) |
|
17 |
#' tbl |
|
18 |
#' |
|
19 |
#' row_paths(tbl) |
|
20 |
#' col_paths(tbl) |
|
21 |
#' |
|
22 |
#' cell_values(tbl, c("AGE", "Mean"), c("ARM", "B: Placebo")) |
|
23 |
#' |
|
24 |
#' @rdname make_col_row_df |
|
25 |
#' @export |
|
26 |
row_paths <- function(x) { |
|
27 | 45x |
stopifnot(is_rtable(x)) |
28 | 45x |
make_row_df(x, visible_only = TRUE)$path |
29 |
} |
|
30 | ||
31 |
#' @rdname make_col_row_df |
|
32 |
#' @export |
|
33 |
col_paths <- function(x) { |
|
34 | 1598x |
if (!is(coltree(x), "LayoutColTree")) { |
35 | ! |
stop("I don't know how to extract the column paths from an object of class ", class(x)) |
36 |
} |
|
37 | 1598x |
make_col_df(x, visible_only = TRUE)$path |
38 |
} |
|
39 | ||
40 |
#' Print row/column paths summary |
|
41 |
#' |
|
42 |
#' @param x (`VTableTree`)\cr an `rtable` object. |
|
43 |
#' |
|
44 |
#' @return A data frame summarizing the row- or column-structure of `x`. |
|
45 |
#' |
|
46 |
#' @examples |
|
47 |
#' ex_adsl_MF <- ex_adsl %>% dplyr::filter(SEX %in% c("M", "F")) |
|
48 |
#' |
|
49 |
#' lyt <- basic_table() %>% |
|
50 |
#' split_cols_by("ARM") %>% |
|
51 |
#' split_cols_by("SEX", split_fun = drop_split_levels) %>% |
|
52 |
#' analyze(c("AGE", "BMRKR2")) |
|
53 |
#' |
|
54 |
#' tbl <- build_table(lyt, ex_adsl_MF) |
|
55 |
#' tbl |
|
56 |
#' |
|
57 |
#' df <- row_paths_summary(tbl) |
|
58 |
#' df |
|
59 |
#' |
|
60 |
#' col_paths_summary(tbl) |
|
61 |
#' |
|
62 |
#' # manually constructed table |
|
63 |
#' tbl2 <- rtable( |
|
64 |
#' rheader( |
|
65 |
#' rrow( |
|
66 |
#' "row 1", rcell("a", colspan = 2), |
|
67 |
#' rcell("b", colspan = 2) |
|
68 |
#' ), |
|
69 |
#' rrow("h2", "a", "b", "c", "d") |
|
70 |
#' ), |
|
71 |
#' rrow("r1", 1, 2, 1, 2), rrow("r2", 3, 4, 2, 1) |
|
72 |
#' ) |
|
73 |
#' col_paths_summary(tbl2) |
|
74 |
#' |
|
75 |
#' @export |
|
76 |
row_paths_summary <- function(x) { |
|
77 | 1x |
stopifnot(is_rtable(x)) |
78 | ||
79 | 1x |
if (nrow(x) == 0) { |
80 | ! |
return("rowname node_class path\n---------------------\n") |
81 |
} |
|
82 | ||
83 | 1x |
pagdf <- make_row_df(x, visible_only = TRUE) |
84 | 1x |
row.names(pagdf) <- NULL |
85 | ||
86 | 1x |
mat <- rbind( |
87 | 1x |
c("rowname", "node_class", "path"), |
88 | 1x |
t(apply(pagdf, 1, function(xi) { |
89 | 28x |
c( |
90 | 28x |
indent_string(xi$label, xi$indent), |
91 | 28x |
xi$node_class, |
92 | 28x |
paste(xi$path, collapse = ", ") |
93 |
) |
|
94 |
})) |
|
95 |
) |
|
96 | ||
97 | 1x |
txt <- mat_as_string(mat) |
98 | 1x |
cat(txt) |
99 | 1x |
cat("\n") |
100 | ||
101 | 1x |
invisible(pagdf[, c("label", "indent", "node_class", "path")]) |
102 |
} |
|
103 | ||
104 |
#' @rdname row_paths_summary |
|
105 |
#' @export |
|
106 |
col_paths_summary <- function(x) { |
|
107 | 1x |
stopifnot(is_rtable(x)) |
108 | ||
109 | 1x |
pagdf <- make_col_df(x, visible_only = FALSE) |
110 | 1x |
row.names(pagdf) <- NULL |
111 | ||
112 | 1x |
mat <- rbind( |
113 | 1x |
c("label", "path"), |
114 | 1x |
t(apply(pagdf, 1, function(xi) { |
115 | 6x |
c( |
116 | 6x |
indent_string(xi$label, floor(length(xi$path) / 2 - 1)), |
117 | 6x |
paste(xi$path, collapse = ", ") |
118 |
) |
|
119 |
})) |
|
120 |
) |
|
121 | ||
122 | 1x |
txt <- mat_as_string(mat) |
123 | 1x |
cat(txt) |
124 | 1x |
cat("\n") |
125 | ||
126 | 1x |
invisible(pagdf[, c("label", "path")]) |
127 |
} |
|
128 | ||
129 |
# Rows ---- |
|
130 |
# . Summarize Rows ---- |
|
131 | ||
132 |
# summarize_row_df <- |
|
133 |
# function(name, |
|
134 |
# label, |
|
135 |
# indent, |
|
136 |
# depth, |
|
137 |
# rowtype, |
|
138 |
# indent_mod, |
|
139 |
# level) { |
|
140 |
# data.frame( |
|
141 |
# name = name, |
|
142 |
# label = label, |
|
143 |
# indent = indent, |
|
144 |
# depth = level, |
|
145 |
# rowtype = rowtype, |
|
146 |
# indent_mod = indent_mod, |
|
147 |
# level = level, |
|
148 |
# stringsAsFactors = FALSE |
|
149 |
# ) |
|
150 |
# } |
|
151 | ||
152 |
#' Summarize rows |
|
153 |
#' |
|
154 |
#' @inheritParams gen_args |
|
155 |
#' @param depth (`numeric(1)`)\cr depth. |
|
156 |
#' @param indent (`numeric(1)`)\cr indent. |
|
157 |
#' |
|
158 |
#' @examples |
|
159 |
#' library(dplyr) |
|
160 |
#' |
|
161 |
#' iris2 <- iris %>% |
|
162 |
#' group_by(Species) %>% |
|
163 |
#' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>% |
|
164 |
#' ungroup() |
|
165 |
#' |
|
166 |
#' lyt <- basic_table() %>% |
|
167 |
#' split_cols_by("Species") %>% |
|
168 |
#' split_cols_by("group") %>% |
|
169 |
#' analyze(c("Sepal.Length", "Petal.Width"), |
|
170 |
#' afun = list_wrap_x(summary), |
|
171 |
#' format = "xx.xx" |
|
172 |
#' ) |
|
173 |
#' |
|
174 |
#' tbl <- build_table(lyt, iris2) |
|
175 |
#' |
|
176 |
#' @rdname int_methods |
|
177 |
setGeneric("summarize_rows_inner", function(obj, depth = 0, indent = 0) { |
|
178 | ! |
standardGeneric("summarize_rows_inner") |
179 |
}) |
|
180 | ||
181 |
#' @rdname int_methods |
|
182 |
setMethod( |
|
183 |
"summarize_rows_inner", "TableTree", |
|
184 |
function(obj, depth = 0, indent = 0) { |
|
185 | ! |
indent <- max(0L, indent + indent_mod(obj)) |
186 | ||
187 | ! |
lr <- summarize_rows_inner(tt_labelrow(obj), depth, indent) |
188 | ! |
if (!is.null(lr)) { |
189 | ! |
ret <- list(lr) |
190 |
} else { |
|
191 | ! |
ret <- list() |
192 |
} |
|
193 | ||
194 | ! |
indent <- indent + (!is.null(lr)) |
195 | ||
196 | ! |
ctab <- content_table(obj) |
197 | ! |
if (NROW(ctab)) { |
198 | ! |
ct <- summarize_rows_inner(ctab, |
199 | ! |
depth = depth, |
200 | ! |
indent = indent + indent_mod(ctab) |
201 |
) |
|
202 | ! |
ret <- c(ret, ct) |
203 | ! |
indent <- indent + (length(ct) > 0) * (1 + indent_mod(ctab)) |
204 |
} |
|
205 | ||
206 | ! |
kids <- tree_children(obj) |
207 | ! |
els <- lapply(tree_children(obj), summarize_rows_inner, |
208 | ! |
depth = depth + 1, indent = indent |
209 |
) |
|
210 | ! |
if (!are(kids, "TableRow")) { |
211 | ! |
if (!are(kids, "VTableTree")) { |
212 |
## hatchet job of a hack, wrap em just so we can unlist em all at |
|
213 |
## the same level |
|
214 | ! |
rowinds <- vapply(kids, is, NA, class2 = "TableRow") |
215 | ! |
els[rowinds] <- lapply(els[rowinds], function(x) list(x)) |
216 |
} |
|
217 | ! |
els <- unlist(els, recursive = FALSE) |
218 |
} |
|
219 | ! |
ret <- c(ret, els) |
220 | ! |
ret |
221 |
## df <- do.call(rbind, c(list(lr), list(ct), els)) |
|
222 | ||
223 |
## row.names(df) <- NULL |
|
224 |
## df |
|
225 |
} |
|
226 |
) |
|
227 | ||
228 |
# Print Table Structure ---- |
|
229 | ||
230 |
#' Summarize table |
|
231 |
#' |
|
232 |
#' @param x (`VTableTree`)\cr a table object. |
|
233 |
#' @param detail (`string`)\cr either `row` or `subtable`. |
|
234 |
#' |
|
235 |
#' @return No return value. Called for the side-effect of printing a row- or subtable-structure summary of `x`. |
|
236 |
#' |
|
237 |
#' @examples |
|
238 |
#' library(dplyr) |
|
239 |
#' |
|
240 |
#' iris2 <- iris %>% |
|
241 |
#' group_by(Species) %>% |
|
242 |
#' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>% |
|
243 |
#' ungroup() |
|
244 |
#' |
|
245 |
#' lyt <- basic_table() %>% |
|
246 |
#' split_cols_by("Species") %>% |
|
247 |
#' split_cols_by("group") %>% |
|
248 |
#' analyze(c("Sepal.Length", "Petal.Width"), |
|
249 |
#' afun = list_wrap_x(summary), |
|
250 |
#' format = "xx.xx" |
|
251 |
#' ) |
|
252 |
#' |
|
253 |
#' tbl <- build_table(lyt, iris2) |
|
254 |
#' tbl |
|
255 |
#' |
|
256 |
#' row_paths(tbl) |
|
257 |
#' |
|
258 |
#' table_structure(tbl) |
|
259 |
#' |
|
260 |
#' table_structure(tbl, detail = "row") |
|
261 |
#' |
|
262 |
#' @export |
|
263 |
table_structure <- function(x, detail = c("subtable", "row")) { |
|
264 | 2x |
detail <- match.arg(detail) |
265 | ||
266 | 2x |
switch(detail, |
267 | 1x |
subtable = treestruct(x), |
268 | 1x |
row = table_structure_inner(x), |
269 | ! |
stop("unsupported level of detail ", detail) |
270 |
) |
|
271 |
} |
|
272 | ||
273 |
#' @param obj (`VTableTree`)\cr a table object. |
|
274 |
#' @param depth (`numeric(1)`)\cr depth in tree. |
|
275 |
#' @param indent (`numeric(1)`)\cr indent. |
|
276 |
#' @param print_indent (`numeric(1)`)\cr indent for printing. |
|
277 |
#' |
|
278 |
#' @rdname int_methods |
|
279 |
setGeneric( |
|
280 |
"table_structure_inner", |
|
281 |
function(obj, |
|
282 |
depth = 0, |
|
283 |
indent = 0, |
|
284 |
print_indent = 0) { |
|
285 | 70x |
standardGeneric("table_structure_inner") |
286 |
} |
|
287 |
) |
|
288 | ||
289 |
scat <- function(..., indent = 0, newline = TRUE) { |
|
290 | 101x |
txt <- paste(..., collapse = "", sep = "") |
291 | ||
292 | 101x |
cat(indent_string(txt, indent)) |
293 | ||
294 | 101x |
if (newline) cat("\n") |
295 |
} |
|
296 | ||
297 |
## helper functions |
|
298 |
obj_visible <- function(x) { |
|
299 | 50x |
x@visible |
300 |
} |
|
301 | ||
302 |
is_empty_labelrow <- function(x) { |
|
303 | 4x |
obj_label(x) == "" && !labelrow_visible(x) |
304 |
} |
|
305 | ||
306 |
is_empty_ElementaryTable <- function(x) { |
|
307 | 10x |
length(tree_children(x)) == 0 && is_empty_labelrow(tt_labelrow(x)) |
308 |
} |
|
309 | ||
310 |
#' @param object (`VTableTree`)\cr a table object. |
|
311 |
#' |
|
312 |
#' @rdname int_methods |
|
313 |
#' @export |
|
314 |
setGeneric("str", function(object, ...) { |
|
315 | ! |
standardGeneric("str") |
316 |
}) |
|
317 | ||
318 |
#' @param max.level (`numeric(1)`)\cr passed to `utils::str`. Defaults to 3 for the `VTableTree` method, unlike |
|
319 |
#' the underlying default of `NA`. `NA` is *not* appropriate for `VTableTree` objects. |
|
320 |
#' |
|
321 |
#' @rdname int_methods |
|
322 |
#' @export |
|
323 |
setMethod( |
|
324 |
"str", "VTableTree", |
|
325 |
function(object, max.level = 3L, ...) { |
|
326 | ! |
utils::str(object, max.level = max.level, ...) |
327 | ! |
warning("str provides a low level, implementation-detail-specific description of the TableTree object structure. ", |
328 | ! |
"See table_structure(.) for a summary of table struture intended for end users.", |
329 | ! |
call. = FALSE |
330 |
) |
|
331 | ! |
invisible(NULL) |
332 |
} |
|
333 |
) |
|
334 | ||
335 |
#' @inheritParams table_structure_inner |
|
336 |
#' @rdname int_methods |
|
337 |
setMethod( |
|
338 |
"table_structure_inner", "TableTree", |
|
339 |
function(obj, depth = 0, indent = 0, print_indent = 0) { |
|
340 | 10x |
indent <- indent + indent_mod(obj) |
341 | ||
342 | 10x |
scat("TableTree: ", "[", obj_name(obj), "] (", |
343 | 10x |
obj_label(obj), ")", |
344 | 10x |
indent = print_indent |
345 |
) |
|
346 | ||
347 | 10x |
table_structure_inner( |
348 | 10x |
tt_labelrow(obj), depth, indent, |
349 | 10x |
print_indent + 1 |
350 |
) |
|
351 | ||
352 | 10x |
ctab <- content_table(obj) |
353 | 10x |
visible_content <- if (is_empty_ElementaryTable(ctab)) { |
354 |
# scat("content: -", indent = print_indent + 1) |
|
355 | 4x |
FALSE |
356 |
} else { |
|
357 | 6x |
scat("content:", indent = print_indent + 1) |
358 | 6x |
table_structure_inner(ctab, |
359 | 6x |
depth = depth, |
360 | 6x |
indent = indent + indent_mod(ctab), |
361 | 6x |
print_indent = print_indent + 2 |
362 |
) |
|
363 |
} |
|
364 | ||
365 | 10x |
if (length(tree_children(obj)) == 0) { |
366 | ! |
scat("children: - ", indent = print_indent + 1) |
367 |
} else { |
|
368 | 10x |
scat("children: ", indent = print_indent + 1) |
369 | 10x |
lapply(tree_children(obj), table_structure_inner, |
370 | 10x |
depth = depth + 1, |
371 | 10x |
indent = indent + visible_content * (1 + indent_mod(ctab)), |
372 | 10x |
print_indent = print_indent + 2 |
373 |
) |
|
374 |
} |
|
375 | ||
376 | 10x |
invisible(NULL) |
377 |
} |
|
378 |
) |
|
379 | ||
380 |
#' @rdname int_methods |
|
381 |
setMethod( |
|
382 |
"table_structure_inner", "ElementaryTable", |
|
383 |
function(obj, depth = 0, indent = 0, print_indent = 0) { |
|
384 | 15x |
scat("ElementaryTable: ", "[", obj_name(obj), |
385 | 15x |
"] (", obj_label(obj), ")", |
386 | 15x |
indent = print_indent |
387 |
) |
|
388 | ||
389 | 15x |
indent <- indent + indent_mod(obj) |
390 | ||
391 | 15x |
table_structure_inner( |
392 | 15x |
tt_labelrow(obj), depth, |
393 | 15x |
indent, print_indent + 1 |
394 |
) |
|
395 | ||
396 | 15x |
if (length(tree_children(obj)) == 0) { |
397 | ! |
scat("children: - ", indent = print_indent + 1) |
398 |
} else { |
|
399 | 15x |
scat("children: ", indent = print_indent + 1) |
400 | 15x |
lapply(tree_children(obj), table_structure_inner, |
401 | 15x |
depth = depth + 1, indent = indent, |
402 | 15x |
print_indent = print_indent + 2 |
403 |
) |
|
404 |
} |
|
405 | ||
406 | 15x |
invisible(NULL) |
407 |
} |
|
408 |
) |
|
409 | ||
410 |
#' @rdname int_methods |
|
411 |
setMethod( |
|
412 |
"table_structure_inner", "TableRow", |
|
413 |
function(obj, depth = 0, indent = 0, print_indent = 0) { |
|
414 | 20x |
scat(class(obj), ": ", "[", obj_name(obj), "] (", |
415 | 20x |
obj_label(obj), ")", |
416 | 20x |
indent = print_indent |
417 |
) |
|
418 | ||
419 | 20x |
indent <- indent + indent_mod(obj) |
420 | ||
421 | 20x |
invisible(NULL) |
422 |
} |
|
423 |
) |
|
424 | ||
425 |
#' @rdname int_methods |
|
426 |
setMethod( |
|
427 |
"table_structure_inner", "LabelRow", |
|
428 |
function(obj, depth = 0, indent = 0, print_indent = 0) { |
|
429 | 25x |
indent <- indent + indent_mod(obj) |
430 | ||
431 | 25x |
txtvis <- if (!obj_visible(obj)) " - <not visible>" else "" |
432 | ||
433 | 25x |
scat("labelrow: ", "[", obj_name(obj), "] (", obj_label(obj), ")", |
434 | 25x |
txtvis, |
435 | 25x |
indent = print_indent |
436 |
) |
|
437 | ||
438 | 25x |
obj_visible(obj) |
439 |
} |
|
440 |
) |
1 |
do_recursive_replace <- function(tab, path, incontent = FALSE, value) { ## rows = NULL, |
|
2 |
## cols = NULL, value) { |
|
3 |
## don't want this in the recursive function |
|
4 |
## so thats why we have the do_ variant |
|
5 | 188x |
if (is.character(path) && length(path) > 1) { |
6 | 163x |
path <- as.list(path) |
7 |
} |
|
8 | 188x |
if (length(path) > 0 && path[[1]] == obj_name(tab)) { |
9 | 162x |
path <- path[-1] |
10 |
} |
|
11 | 188x |
recursive_replace(tab, path, value) ## incontent, rows, cols,value) |
12 |
} |
|
13 | ||
14 |
## different cases we want to support: |
|
15 |
## 1. Replace entire children for a particular node/position in the tree |
|
16 |
## 2. Replace entire rows at a particular (ElementaryTable) position within the |
|
17 |
## tree |
|
18 |
## 3. Replace specific cell values within a set of row x column positions within |
|
19 |
## an ElementaryTable at a particular position within the tree |
|
20 |
## 3. replace entire content table at a node position |
|
21 |
## 4. replace entire rows within the content table at a particular node position |
|
22 |
## in the tree |
|
23 |
## 5. replace data cell values for specific row/col positions within the content |
|
24 |
## table at a particular position within the tree |
|
25 | ||
26 |
## XXX This is wrong, what happens if a split (or more accurately, value) |
|
27 |
## happens more than once in the overall tree??? |
|
28 |
recursive_replace <- function(tab, path, value) { ## incontent = FALSE, rows = NULL, cols = NULL, value) { |
|
29 | 771x |
if (length(path) == 0) { ## done recursing |
30 |
## if(is.null(rows) && is.null(cols)) { ## replacing whole subtree a this position |
|
31 |
## if(incontent) { |
|
32 |
## newkid = tab |
|
33 |
## content_table(newkid) = value |
|
34 |
## } else |
|
35 | 191x |
newkid <- value |
36 |
## newkid has either thee content table |
|
37 |
## replaced on the old kid or is the new |
|
38 |
## kid |
|
39 |
# } ## else { ## rows or cols (or both) non-null |
|
40 |
## if(incontent) { |
|
41 |
## ctab = content_table(tab) |
|
42 |
## ctab[rows, cols] = value |
|
43 |
## content_table(tab) = ctab |
|
44 |
## newkid = tab |
|
45 | ||
46 |
## } else { |
|
47 |
## allkids = tree_children(tab) |
|
48 |
## stopifnot(are(allkids, "TableRow")) |
|
49 |
## newkid = tab |
|
50 |
## newkid[rows, cols] = value |
|
51 |
## } |
|
52 |
## } |
|
53 | 191x |
return(newkid) |
54 | 580x |
} else if (path[[1]] == "@content") { |
55 | 27x |
ctb <- content_table(tab) |
56 | 27x |
ctb <- recursive_replace(ctb, |
57 | 27x |
path = path[-1], |
58 |
## rows = rows, |
|
59 |
## cols = cols, |
|
60 | 27x |
value = value |
61 |
) |
|
62 | 27x |
content_table(tab) <- ctb |
63 | 27x |
tab |
64 |
} else { ## length(path) > 1, more recursing to do |
|
65 | 553x |
kidel <- path[[1]] |
66 |
## broken up for debugabiliity, could be a single complex |
|
67 |
## expression |
|
68 |
## for now only the last step supports selecting |
|
69 |
## multiple kids |
|
70 | 553x |
stopifnot( |
71 | 553x |
length(kidel) == 1, |
72 | 553x |
is.character(kidel) || is.factor(kidel) |
73 |
) |
|
74 | 553x |
knms <- names(tree_children(tab)) |
75 | 553x |
if (!(kidel %in% knms)) { |
76 | ! |
stop(sprintf("position element %s not in names of next level children", kidel)) |
77 | 553x |
} else if (sum(kidel == knms) > 1) { |
78 | ! |
stop(sprintf("position element %s appears more than once, not currently supported", kidel)) |
79 |
} |
|
80 | ! |
if (is.factor(kidel)) kidel <- levels(kidel)[kidel] |
81 | 553x |
newkid <- recursive_replace( |
82 | 553x |
tree_children(tab)[[kidel]], |
83 | 553x |
path[-1], |
84 |
## incontent = incontent, |
|
85 |
## rows = rows, |
|
86 |
## cols = cols, |
|
87 | 553x |
value |
88 |
) |
|
89 | 553x |
tree_children(tab)[[kidel]] <- newkid |
90 | 553x |
tab |
91 |
} |
|
92 |
} |
|
93 | ||
94 | 1x |
coltree_split <- function(ctree) ctree@split |
95 | ||
96 |
col_fnotes_at_path <- function(ctree, path, fnotes) { |
|
97 | 2x |
if (length(path) == 0) { |
98 | 1x |
col_footnotes(ctree) <- fnotes |
99 | 1x |
return(ctree) |
100 |
} |
|
101 | ||
102 | 1x |
if (identical(path[1], obj_name(coltree_split(ctree)))) { |
103 | 1x |
path <- path[-1] |
104 |
} else { |
|
105 | ! |
stop(paste("Path appears invalid at step:", path[1])) |
106 |
} |
|
107 | ||
108 | 1x |
kids <- tree_children(ctree) |
109 | 1x |
kidel <- path[[1]] |
110 | 1x |
knms <- names(kids) |
111 | 1x |
stopifnot(kidel %in% knms) |
112 | 1x |
newkid <- col_fnotes_at_path(kids[[kidel]], |
113 | 1x |
path[-1], |
114 | 1x |
fnotes = fnotes |
115 |
) |
|
116 | 1x |
kids[[kidel]] <- newkid |
117 | 1x |
tree_children(ctree) <- kids |
118 | 1x |
ctree |
119 |
} |
|
120 | ||
121 |
#' Insert row at path |
|
122 |
#' |
|
123 |
#' Insert a row into an existing table directly before or directly after an existing data (i.e., non-content and |
|
124 |
#' non-label) row, specified by its path. |
|
125 |
#' |
|
126 |
#' @inheritParams gen_args |
|
127 |
#' @param after (`flag`)\cr whether `value` should be added as a row directly before (`FALSE`, the default) or after |
|
128 |
#' (`TRUE`) the row specified by `path`. |
|
129 |
#' |
|
130 |
#' @seealso [DataRow()], [rrow()] |
|
131 |
#' |
|
132 |
#' @examples |
|
133 |
#' lyt <- basic_table() %>% |
|
134 |
#' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>% |
|
135 |
#' analyze("AGE") |
|
136 |
#' |
|
137 |
#' tbl <- build_table(lyt, DM) |
|
138 |
#' |
|
139 |
#' tbl2 <- insert_row_at_path( |
|
140 |
#' tbl, c("COUNTRY", "CHN", "AGE", "Mean"), |
|
141 |
#' rrow("new row", 555) |
|
142 |
#' ) |
|
143 |
#' tbl2 |
|
144 |
#' |
|
145 |
#' tbl3 <- insert_row_at_path(tbl2, c("COUNTRY", "CHN", "AGE", "Mean"), |
|
146 |
#' rrow("new row redux", 888), |
|
147 |
#' after = TRUE |
|
148 |
#' ) |
|
149 |
#' tbl3 |
|
150 |
#' |
|
151 |
#' @export |
|
152 |
setGeneric("insert_row_at_path", |
|
153 |
signature = c("tt", "value"), |
|
154 |
function(tt, path, value, after = FALSE) { |
|
155 | 6x |
standardGeneric("insert_row_at_path") |
156 |
} |
|
157 |
) |
|
158 | ||
159 |
#' @rdname insert_row_at_path |
|
160 |
setMethod( |
|
161 |
"insert_row_at_path", c("VTableTree", "DataRow"), |
|
162 |
function(tt, path, value, after = FALSE) { |
|
163 | 6x |
if (no_colinfo(value)) { |
164 | 6x |
col_info(value) <- col_info(tt) |
165 |
} else { |
|
166 | ! |
chk_compat_cinfos(tt, value) |
167 |
} |
|
168 |
## retained for debugging |
|
169 | 6x |
origpath <- path # nolint |
170 | 6x |
idx_row <- tt_at_path(tt, path) |
171 | 6x |
if (!is(idx_row, "DataRow")) { |
172 | 4x |
stop( |
173 | 4x |
"path must resolve fully to a non-content data row. Insertion of ", |
174 | 4x |
"rows elsewhere in the tree is not currently supported." |
175 |
) |
|
176 |
} |
|
177 | ||
178 | 2x |
posnm <- tail(path, 1) |
179 | ||
180 | 2x |
path <- head(path, -1) |
181 | ||
182 | 2x |
subtt <- tt_at_path(tt, path) |
183 | 2x |
kids <- tree_children(subtt) |
184 | 2x |
ind <- which(names(kids) == posnm) |
185 | 2x |
if (length(ind) != 1L) { |
186 |
## nocov start |
|
187 |
stop( |
|
188 |
"table children do not appear to be named correctly at this ", |
|
189 |
"path. This should not happen, please contact the maintainer of ", |
|
190 |
"rtables." |
|
191 |
) |
|
192 |
## nocov end |
|
193 |
} |
|
194 | 2x |
if (after) { |
195 | 1x |
ind <- ind + 1 |
196 |
} |
|
197 | ||
198 | 2x |
sq <- seq_along(kids) |
199 | 2x |
tree_children(subtt) <- c( |
200 | 2x |
kids[sq < ind], |
201 | 2x |
setNames(list(value), obj_name(value)), |
202 | 2x |
kids[sq >= ind] |
203 |
) |
|
204 | 2x |
tt_at_path(tt, path) <- subtt |
205 | 2x |
tt |
206 |
} |
|
207 |
) |
|
208 |
#' @rdname insert_row_at_path |
|
209 |
setMethod( |
|
210 |
"insert_row_at_path", c("VTableTree", "ANY"), |
|
211 |
function(tt, path, value) { |
|
212 | ! |
stop( |
213 | ! |
"Currently only insertion of DataRow objects is supported. Got ", |
214 | ! |
"object of class ", class(value), ". Please use rrow() or DataRow() ", |
215 | ! |
"to construct your row before insertion." |
216 |
) |
|
217 |
} |
|
218 |
) |
|
219 | ||
220 |
#' Label at path |
|
221 |
#' |
|
222 |
#' Accesses or sets the label at a path. |
|
223 |
#' |
|
224 |
#' @inheritParams gen_args |
|
225 |
#' |
|
226 |
#' @details |
|
227 |
#' If `path` resolves to a single row, the label for that row is retrieved or set. If, instead, `path` resolves to a |
|
228 |
#' subtable, the text for the row-label associated with that path is retrieved or set. In the subtable case, if the |
|
229 |
#' label text is set to a non-`NA` value, the `labelrow` will be set to visible, even if it was not before. Similarly, |
|
230 |
#' if the label row text for a subtable is set to `NA`, the label row will bet set to non-visible, so the row will not |
|
231 |
#' appear at all when the table is printed. |
|
232 |
#' |
|
233 |
#' @note When changing the row labels for content rows, it is important to path all the way to the *row*. Paths |
|
234 |
#' ending in `"@content"` will not exhibit the behavior you want, and are thus an error. See [row_paths()] for help |
|
235 |
#' determining the full paths to content rows. |
|
236 |
#' |
|
237 |
#' @examples |
|
238 |
#' lyt <- basic_table() %>% |
|
239 |
#' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>% |
|
240 |
#' analyze("AGE") |
|
241 |
#' |
|
242 |
#' tbl <- build_table(lyt, DM) |
|
243 |
#' |
|
244 |
#' label_at_path(tbl, c("COUNTRY", "CHN")) |
|
245 |
#' |
|
246 |
#' label_at_path(tbl, c("COUNTRY", "USA")) <- "United States" |
|
247 |
#' tbl |
|
248 |
#' |
|
249 |
#' @export |
|
250 |
label_at_path <- function(tt, path) { |
|
251 | 29x |
obj_label(tt_at_path(tt, path)) |
252 |
} |
|
253 | ||
254 |
#' @export |
|
255 |
#' @rdname label_at_path |
|
256 |
`label_at_path<-` <- function(tt, path, value) { |
|
257 | 32x |
if (!is(tt, "VTableTree")) { |
258 | ! |
stop("tt must be a TableTree or ElementaryTable object") |
259 |
} |
|
260 | 32x |
if (is.null(value) || is.na(value)) { |
261 | 1x |
value <- NA_character_ |
262 |
} |
|
263 | 32x |
subt <- tt_at_path(tt, path) |
264 | 32x |
obj_label(subt) <- value |
265 | 32x |
tt_at_path(tt, path) <- subt |
266 | 32x |
tt |
267 |
} |
|
268 | ||
269 |
#' Access or set table elements at specified path |
|
270 |
#' |
|
271 |
#' @inheritParams gen_args |
|
272 |
#' @param ... unused. |
|
273 |
#' |
|
274 |
#' @export |
|
275 |
#' @rdname ttap |
|
276 | 386x |
setGeneric("tt_at_path", function(tt, path, ...) standardGeneric("tt_at_path")) |
277 | ||
278 |
#' @inheritParams tt_at_path |
|
279 |
#' |
|
280 |
#' @export |
|
281 |
#' @rdname int_methods |
|
282 |
setMethod( |
|
283 |
"tt_at_path", "VTableTree", |
|
284 |
function(tt, path, ...) { |
|
285 | 386x |
stopifnot( |
286 | 386x |
is(path, "character"), |
287 | 386x |
length(path) > 0, |
288 | 386x |
!anyNA(path) |
289 |
) |
|
290 | ||
291 | 386x |
if (path[1] == "root" && obj_name(tt) != "root") { |
292 | 3x |
path <- path[-1] |
293 |
} |
|
294 |
## handle pathing that hits the root split by name |
|
295 | 386x |
if (obj_name(tt) == path[1]) { |
296 | 354x |
path <- path[-1] |
297 |
} |
|
298 | 386x |
cur <- tt |
299 | 386x |
curpath <- path |
300 | 386x |
while (length(curpath > 0)) { |
301 | 1311x |
kids <- tree_children(cur) |
302 | 1311x |
curname <- curpath[1] |
303 | 1311x |
if (curname == "@content") { |
304 | 69x |
cur <- content_table(cur) |
305 | 1242x |
} else if (curname %in% names(kids)) { |
306 | 1241x |
cur <- kids[[curname]] |
307 |
} else { |
|
308 | 1x |
stop("Path appears invalid for this tree at step ", curname) |
309 |
} |
|
310 | 1310x |
curpath <- curpath[-1] |
311 |
} |
|
312 | 385x |
cur |
313 |
} |
|
314 |
) |
|
315 | ||
316 |
#' @note Setting `NULL` at a defined path removes the corresponding sub-table. |
|
317 |
#' |
|
318 |
#' @examples |
|
319 |
#' # Accessing sub table. |
|
320 |
#' lyt <- basic_table() %>% |
|
321 |
#' split_cols_by("ARM") %>% |
|
322 |
#' split_rows_by("SEX") %>% |
|
323 |
#' split_rows_by("BMRKR2") %>% |
|
324 |
#' analyze("AGE") |
|
325 |
#' |
|
326 |
#' tbl <- build_table(lyt, ex_adsl) %>% prune_table() |
|
327 |
#' sub_tbl <- tt_at_path(tbl, path = c("SEX", "F", "BMRKR2")) |
|
328 |
#' |
|
329 |
#' # Removing sub table. |
|
330 |
#' tbl2 <- tbl |
|
331 |
#' tt_at_path(tbl2, path = c("SEX", "F")) <- NULL |
|
332 |
#' tbl2 |
|
333 |
#' |
|
334 |
#' # Setting sub table. |
|
335 |
#' lyt3 <- basic_table() %>% |
|
336 |
#' split_cols_by("ARM") %>% |
|
337 |
#' split_rows_by("SEX") %>% |
|
338 |
#' analyze("BMRKR2") |
|
339 |
#' |
|
340 |
#' tbl3 <- build_table(lyt3, ex_adsl) %>% prune_table() |
|
341 |
#' |
|
342 |
#' tt_at_path(tbl3, path = c("SEX", "F", "BMRKR2")) <- sub_tbl |
|
343 |
#' tbl3 |
|
344 |
#' |
|
345 |
#' @export |
|
346 |
#' @rdname ttap |
|
347 |
setGeneric( |
|
348 |
"tt_at_path<-", |
|
349 | 188x |
function(tt, path, ..., value) standardGeneric("tt_at_path<-") |
350 |
) |
|
351 | ||
352 |
#' @export |
|
353 |
#' @keywords internal |
|
354 |
#' @rdname int_methods |
|
355 |
setMethod( |
|
356 |
"tt_at_path<-", c(tt = "VTableTree", value = "VTableTree"), |
|
357 |
function(tt, path, ..., value) { |
|
358 | 80x |
do_recursive_replace(tt, path = path, value = value) |
359 |
} |
|
360 |
) |
|
361 | ||
362 |
## this one removes the child at path from the parents list of children, |
|
363 |
## because that is how lists behave. |
|
364 |
#' @export |
|
365 |
#' @keywords internal |
|
366 |
#' @rdname int_methods |
|
367 |
setMethod( |
|
368 |
"tt_at_path<-", c(tt = "VTableTree", value = "NULL"), |
|
369 |
function(tt, path, ..., value) { |
|
370 | 2x |
do_recursive_replace(tt, path = path, value = value) |
371 |
} |
|
372 |
) |
|
373 | ||
374 |
#' @export |
|
375 |
#' @keywords internal |
|
376 |
#' @rdname int_methods |
|
377 |
setMethod( |
|
378 |
"tt_at_path<-", c(tt = "VTableTree", value = "TableRow"), |
|
379 |
function(tt, path, ..., value) { |
|
380 | 106x |
stopifnot(is(tt_at_path(tt = tt, path = path), "TableRow")) |
381 | 106x |
do_recursive_replace(tt, path = path, value = value) |
382 | ||
383 |
## ##i <- .path_to_pos(path = path, seq_len(nrow(tt)), tt, NROW) |
|
384 |
## i <- .path_to_pos(path = path, tt = tt) |
|
385 | ||
386 |
## replace_rows(tt, i = i, value = list(value)) |
|
387 |
} |
|
388 |
) |
|
389 | ||
390 |
#' Retrieve and assign elements of a `TableTree` |
|
391 |
#' |
|
392 |
#' @param x (`TableTree`)\cr a `TableTree` object. |
|
393 |
#' @param i (`numeric(1)`)\cr index. |
|
394 |
#' @param j (`numeric(1)`)\cr index. |
|
395 |
#' @param drop (`flag`)\cr whether the value in the cell should be returned if one cell is selected by the |
|
396 |
#' combination of `i` and `j`. It is not possible to return a vector of values. To do so please consider using |
|
397 |
#' [cell_values()]. Defaults to `FALSE`. |
|
398 |
#' @param ... additional arguments. Includes: |
|
399 |
#' \describe{ |
|
400 |
#' \item{`keep_topleft`}{(`flag`) (`[` only) whether the top-left material for the table should be retained after |
|
401 |
#' subsetting. Defaults to `TRUE` if all rows are included (i.e. subsetting was by column), and drops it |
|
402 |
#' otherwise.} |
|
403 |
#' \item{`keep_titles`}{(`flag`) whether title information should be retained. Defaults to `FALSE`.} |
|
404 |
#' \item{`keep_footers`}{(`flag`) whether non-referential footer information should be retained. Defaults to |
|
405 |
#' `keep_titles`.} |
|
406 |
#' \item{`reindex_refs`}{(`flag`) whether referential footnotes should be re-indexed as if the resulting subset is |
|
407 |
#' the entire table. Defaults to `TRUE`.} |
|
408 |
#' } |
|
409 |
#' @param value (`list`, `TableRow`, or `TableTree`)\cr replacement value. |
|
410 |
#' |
|
411 |
#' @details |
|
412 |
#' By default, subsetting drops the information about title, subtitle, main footer, provenance footer, and `topleft`. |
|
413 |
#' If only a column is selected and all rows are kept, the `topleft` information remains as default. Any referential |
|
414 |
#' footnote is kept whenever the subset table contains the referenced element. |
|
415 |
#' |
|
416 |
#' @return A `TableTree` (or `ElementaryTable`) object, unless a single cell was selected with `drop = TRUE`, in which |
|
417 |
#' case the (possibly multi-valued) fully stripped raw value of the selected cell. |
|
418 |
#' |
|
419 |
#' @note |
|
420 |
#' Subsetting always preserve the original order, even if provided indexes do not preserve it. If sorting is needed, |
|
421 |
#' please consider using `sort_at_path()`. Also note that `character` indices are treated as paths, not vectors of |
|
422 |
#' names in both `[` and `[<-`. |
|
423 |
#' |
|
424 |
#' @seealso |
|
425 |
#' * [sort_at_path()] to understand sorting. |
|
426 |
#' * [summarize_row_groups()] to understand path structure. |
|
427 |
#' |
|
428 |
#' @examples |
|
429 |
#' lyt <- basic_table( |
|
430 |
#' title = "Title", |
|
431 |
#' subtitles = c("Sub", "titles"), |
|
432 |
#' prov_footer = "prov footer", |
|
433 |
#' main_footer = "main footer" |
|
434 |
#' ) %>% |
|
435 |
#' split_cols_by("ARM") %>% |
|
436 |
#' split_rows_by("SEX") %>% |
|
437 |
#' analyze(c("AGE")) |
|
438 |
#' |
|
439 |
#' tbl <- build_table(lyt, DM) |
|
440 |
#' top_left(tbl) <- "Info" |
|
441 |
#' tbl |
|
442 |
#' |
|
443 |
#' # As default header, footer, and topleft information is lost |
|
444 |
#' tbl[1, ] |
|
445 |
#' tbl[1:2, 2] |
|
446 |
#' |
|
447 |
#' # Also boolean filters can work |
|
448 |
#' tbl[, c(FALSE, TRUE, FALSE)] |
|
449 |
#' |
|
450 |
#' # If drop = TRUE, the content values are directly retrieved |
|
451 |
#' tbl[2, 1] |
|
452 |
#' tbl[2, 1, drop = TRUE] |
|
453 |
#' |
|
454 |
#' # Drop works also if vectors are selected, but not matrices |
|
455 |
#' tbl[, 1, drop = TRUE] |
|
456 |
#' tbl[2, , drop = TRUE] |
|
457 |
#' tbl[1, 1, drop = TRUE] # NULL because it is a label row |
|
458 |
#' tbl[2, 1:2, drop = TRUE] # vectors can be returned only with cell_values() |
|
459 |
#' tbl[1:2, 1:2, drop = TRUE] # no dropping because it is a matrix |
|
460 |
#' |
|
461 |
#' # If all rows are selected, topleft is kept by default |
|
462 |
#' tbl[, 2] |
|
463 |
#' tbl[, 1] |
|
464 |
#' |
|
465 |
#' # It is possible to deselect values |
|
466 |
#' tbl[-2, ] |
|
467 |
#' tbl[, -1] |
|
468 |
#' |
|
469 |
#' # Values can be reassigned |
|
470 |
#' tbl[2, 1] <- rcell(999) |
|
471 |
#' tbl[2, ] <- list(rrow("FFF", 888, 666, 777)) |
|
472 |
#' tbl[6, ] <- list(-111, -222, -333) |
|
473 |
#' tbl |
|
474 |
#' |
|
475 |
#' # We can keep some information from the original table if we need |
|
476 |
#' tbl[1, 2, keep_titles = TRUE] |
|
477 |
#' tbl[1, 2, keep_footers = TRUE, keep_titles = FALSE] |
|
478 |
#' tbl[1, 2, keep_footers = FALSE, keep_titles = TRUE] |
|
479 |
#' tbl[1, 2, keep_footers = TRUE] |
|
480 |
#' tbl[1, 2, keep_topleft = TRUE] |
|
481 |
#' |
|
482 |
#' # Keeps the referential footnotes when subset contains them |
|
483 |
#' fnotes_at_path(tbl, rowpath = c("SEX", "M", "AGE", "Mean")) <- "important" |
|
484 |
#' tbl[4, 1] |
|
485 |
#' tbl[2, 1] # None present |
|
486 |
#' |
|
487 |
#' # We can reindex referential footnotes, so that the new table does not depend |
|
488 |
#' # on the original one |
|
489 |
#' fnotes_at_path(tbl, rowpath = c("SEX", "U", "AGE", "Mean")) <- "important" |
|
490 |
#' tbl[, 1] # both present |
|
491 |
#' tbl[5:6, 1] # {1} because it has been indexed again |
|
492 |
#' tbl[5:6, 1, reindex_refs = FALSE] # {2} -> not reindexed |
|
493 |
#' |
|
494 |
#' # Note that order can not be changed with subsetting |
|
495 |
#' tbl[c(4, 3, 1), c(3, 1)] # It preserves order and wanted selection |
|
496 |
#' |
|
497 |
#' @name brackets |
|
498 |
NULL |
|
499 | ||
500 |
#' @exportMethod [<- |
|
501 |
#' @rdname brackets |
|
502 |
setMethod( |
|
503 |
"[<-", c("VTableTree", value = "list"), |
|
504 |
function(x, i, j, ..., value) { |
|
505 | 3x |
nr <- nrow(x) |
506 | 3x |
if (missing(i)) { |
507 | ! |
i <- seq_len(NROW(x)) |
508 | 3x |
} else if (is(i, "character")) { |
509 | ! |
i <- .path_to_pos(i, x) |
510 |
} else { |
|
511 | 3x |
i <- .j_to_posj(i, nr) |
512 |
} |
|
513 | ||
514 | 3x |
if (missing(j)) { |
515 | 1x |
j <- seq_along(col_exprs(col_info(x))) |
516 | 2x |
} else if (is(j, "character")) { |
517 | ! |
j <- .path_to_pos(j, x, cols = TRUE) |
518 |
} else { |
|
519 | 2x |
j <- .j_to_posj(j, ncol(x)) |
520 |
} |
|
521 | ||
522 | 3x |
if (length(i) > 1 && length(j) < ncol(x)) { |
523 | ! |
stop("cannot modify multiple rows in not all columns.") |
524 |
} |
|
525 | ||
526 | 3x |
if (are(value, "TableRow")) { |
527 | 1x |
value <- rep(value, length.out = length(i)) |
528 |
} else { |
|
529 | 2x |
value <- rep(value, length.out = length(i) * length(j)) |
530 |
} |
|
531 | ||
532 | 3x |
counter <- 0 |
533 |
## this has access to value, i, and j by scoping |
|
534 | 3x |
replace_rowsbynum <- function(x, i, valifnone = NULL) { |
535 | 16x |
maxi <- max(i) |
536 | 16x |
if (counter >= maxi) { |
537 | ! |
return(valifnone) |
538 |
} |
|
539 | ||
540 | 16x |
if (labelrow_visible(x)) { |
541 | 3x |
counter <<- counter + 1 |
542 | 3x |
if (counter %in% i) { |
543 | 1x |
nxtval <- value[[1]] |
544 | 1x |
if (is(nxtval, "LabelRow")) { |
545 | 1x |
tt_labelrow(x) <- nxtval |
546 |
} else { |
|
547 | ! |
stop( |
548 | ! |
"can't replace label with value of class", |
549 | ! |
class(nxtval) |
550 |
) |
|
551 |
} |
|
552 |
## we're done with this one move to |
|
553 |
## the next |
|
554 | 1x |
value <<- value[-1] |
555 |
} |
|
556 |
} |
|
557 | 16x |
if (is(x, "TableTree") && nrow(content_table(x)) > 0) { |
558 | 3x |
ctab <- content_table(x) |
559 | ||
560 | 3x |
content_table(x) <- replace_rowsbynum(ctab, i) |
561 |
} |
|
562 | 16x |
if (counter >= maxi) { # already done |
563 | 2x |
return(x) |
564 |
} |
|
565 | 14x |
kids <- tree_children(x) |
566 | ||
567 | 14x |
if (length(kids) > 0) { |
568 | 14x |
for (pos in seq_along(kids)) { |
569 | 17x |
curkid <- kids[[pos]] |
570 | 17x |
if (is(curkid, "TableRow")) { |
571 | 7x |
counter <<- counter + 1 |
572 | 7x |
if (counter %in% i) { |
573 | 3x |
nxtval <- value[[1]] |
574 | 3x |
if (is(nxtval, class(curkid))) { |
575 | 1x |
if (no_colinfo(nxtval) && length(row_values(nxtval)) == ncol(x)) { |
576 | 1x |
col_info(nxtval) <- col_info(x) |
577 |
} |
|
578 | 1x |
stopifnot(identical(col_info(x), col_info(nxtval))) |
579 | 1x |
curkid <- nxtval |
580 | 1x |
value <- value[-1] |
581 |
} else { |
|
582 | 2x |
rvs <- row_values(curkid) |
583 | 2x |
rvs[j] <- value[seq_along(j)] |
584 | 2x |
row_values(curkid) <- rvs |
585 | 2x |
value <- value[-(seq_along(j))] |
586 |
} |
|
587 | 3x |
kids[[pos]] <- curkid |
588 |
} |
|
589 |
} else { |
|
590 | 10x |
kids[[pos]] <- replace_rowsbynum(curkid, i) |
591 |
} |
|
592 | 17x |
if (counter >= maxi) { |
593 | 7x |
break |
594 |
} |
|
595 |
} |
|
596 |
} |
|
597 | 14x |
tree_children(x) <- kids |
598 | 14x |
x |
599 |
} |
|
600 | 3x |
replace_rowsbynum(x, i, ...) |
601 |
} |
|
602 |
) |
|
603 | ||
604 |
#' @inheritParams brackets |
|
605 |
#' |
|
606 |
#' @exportMethod [<- |
|
607 |
#' @rdname int_methods |
|
608 |
#' @keywords internal |
|
609 |
setMethod( |
|
610 |
"[<-", c("VTableTree", value = "CellValue"), |
|
611 |
function(x, i, j, ..., value) { |
|
612 | 1x |
x[i = i, j = j, ...] <- list(value) |
613 | 1x |
x |
614 |
} |
|
615 |
) |
|
616 | ||
617 |
## this is going to be hard :( :( :( |
|
618 | ||
619 |
### selecting/removing columns |
|
620 | ||
621 |
## we have two options here: path like we do with rows and positional |
|
622 |
## in leaf space. |
|
623 | ||
624 |
setGeneric( |
|
625 |
"subset_cols", |
|
626 |
function(tt, |
|
627 |
j, |
|
628 |
newcinfo = NULL, |
|
629 |
keep_topleft = TRUE, |
|
630 |
keep_titles = TRUE, |
|
631 |
keep_footers = keep_titles, |
|
632 |
...) { |
|
633 | 8347x |
standardGeneric("subset_cols") |
634 |
} |
|
635 |
) |
|
636 | ||
637 |
setMethod( |
|
638 |
"subset_cols", c("TableTree", "numeric"), |
|
639 |
function(tt, j, newcinfo = NULL, |
|
640 |
keep_topleft, keep_titles, keep_footers, ...) { |
|
641 | 750x |
j <- .j_to_posj(j, ncol(tt)) |
642 | 750x |
if (is.null(newcinfo)) { |
643 | 152x |
cinfo <- col_info(tt) |
644 | 152x |
newcinfo <- subset_cols(cinfo, j, |
645 | 152x |
keep_topleft = keep_topleft, ... |
646 |
) |
|
647 |
} |
|
648 |
## topleft taken care of in creation of newcinfo |
|
649 | 750x |
kids <- tree_children(tt) |
650 | 750x |
newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...) |
651 | 750x |
cont <- content_table(tt) |
652 | 750x |
newcont <- subset_cols(cont, j, newcinfo = newcinfo, ...) |
653 | 750x |
tt2 <- tt |
654 | 750x |
col_info(tt2) <- newcinfo |
655 | 750x |
content_table(tt2) <- newcont |
656 | 750x |
tree_children(tt2) <- newkids |
657 | 750x |
tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...) |
658 | ||
659 | 750x |
tt2 <- .h_copy_titles_footers_topleft( |
660 | 750x |
tt2, tt, |
661 | 750x |
keep_titles, |
662 | 750x |
keep_footers, |
663 | 750x |
keep_topleft |
664 |
) |
|
665 | 750x |
tt2 |
666 |
} |
|
667 |
) |
|
668 | ||
669 |
setMethod( |
|
670 |
"subset_cols", c("ElementaryTable", "numeric"), |
|
671 |
function(tt, j, newcinfo = NULL, |
|
672 |
keep_topleft, keep_titles, keep_footers, ...) { |
|
673 | 1544x |
j <- .j_to_posj(j, ncol(tt)) |
674 | 1544x |
if (is.null(newcinfo)) { |
675 | 91x |
cinfo <- col_info(tt) |
676 | 91x |
newcinfo <- subset_cols(cinfo, j, |
677 | 91x |
keep_topleft = keep_topleft, |
678 | 91x |
keep_titles = keep_titles, |
679 | 91x |
keep_footers = keep_footers, ... |
680 |
) |
|
681 |
} |
|
682 |
## topleft handled in creation of newcinfo |
|
683 | 1544x |
kids <- tree_children(tt) |
684 | 1544x |
newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...) |
685 | 1544x |
tt2 <- tt |
686 | 1544x |
col_info(tt2) <- newcinfo |
687 | 1544x |
tree_children(tt2) <- newkids |
688 | 1544x |
tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...) |
689 | 1544x |
tt2 <- .h_copy_titles_footers_topleft( |
690 | 1544x |
tt2, tt, |
691 | 1544x |
keep_titles, |
692 | 1544x |
keep_footers, |
693 | 1544x |
keep_topleft |
694 |
) |
|
695 | 1544x |
tt2 |
696 |
} |
|
697 |
) |
|
698 | ||
699 |
## small utility to transform any negative |
|
700 |
## indices into positive ones, given j |
|
701 |
## and total length |
|
702 | ||
703 |
.j_to_posj <- function(j, n) { |
|
704 |
## This will work for logicals, numerics, integers |
|
705 | 12610x |
j <- seq_len(n)[j] |
706 | 12610x |
j |
707 |
} |
|
708 | ||
709 |
path_collapse_sep <- "`" |
|
710 |
escape_name_padding <- function(x) { |
|
711 | 144x |
ret <- gsub("._[[", "\\._\\[\\[", x, fixed = TRUE) |
712 | 144x |
ret <- gsub("]]_.", "\\]\\]_\\.", ret, fixed = TRUE) |
713 | 144x |
ret |
714 |
} |
|
715 |
path_to_regex <- function(path) { |
|
716 | 51x |
paste(vapply(path, function(x) { |
717 | 145x |
if (identical(x, "*")) { |
718 | 1x |
paste0("[^", path_collapse_sep, "]+") |
719 |
} else { |
|
720 | 144x |
escape_name_padding(x) |
721 |
} |
|
722 | 51x |
}, ""), collapse = path_collapse_sep) |
723 |
} |
|
724 | ||
725 |
.path_to_pos <- function(path, tt, distinct_ok = TRUE, cols = FALSE) { |
|
726 | 2055x |
path <- path[!grepl("^(|root)$", path)] |
727 | 2055x |
if (cols) { |
728 | 2055x |
rowdf <- make_col_df(tt) |
729 |
} else { |
|
730 | ! |
rowdf <- make_row_df(tt) |
731 |
} |
|
732 | 2055x |
if (length(path) == 0 || identical(path, "*") || identical(path, "root")) { |
733 | 2004x |
return(seq(1, nrow(rowdf))) |
734 |
} |
|
735 | ||
736 | 51x |
paths <- rowdf$path |
737 | 51x |
pathregex <- path_to_regex(path) |
738 | 51x |
pathstrs <- vapply(paths, paste, "", collapse = path_collapse_sep) |
739 | 51x |
allmatchs <- grep(pathregex, pathstrs) |
740 | 51x |
if (length(allmatchs) == 0) { |
741 | ! |
stop( |
742 | ! |
if (cols) "column path [" else "row path [", |
743 | ! |
paste(path, collapse = "->"), |
744 | ! |
"] does not appear valid for this table" |
745 |
) |
|
746 |
} |
|
747 | ||
748 | 51x |
idxdiffs <- diff(allmatchs) |
749 | 51x |
if (!distinct_ok && length(idxdiffs) > 0 && any(idxdiffs > 1)) { |
750 | ! |
firstnon <- min(which(idxdiffs > 1)) |
751 |
## its firstnon here because we would want firstnon-1 but |
|
752 |
## the diffs are actually shifted 1 so they cancel out |
|
753 | ! |
allmatchs <- allmatchs[seq(1, firstnon)] |
754 |
} |
|
755 | 51x |
allmatchs |
756 |
} |
|
757 | ||
758 |
## fix column spans that would be invalid |
|
759 |
## after some columns are no longer there |
|
760 |
.fix_rowcspans <- function(rw, j) { |
|
761 | 3185x |
cspans <- row_cspans(rw) |
762 | 3185x |
nc <- sum(cspans) |
763 | 3185x |
j <- .j_to_posj(j, nc) |
764 |
## this is overly complicated |
|
765 |
## we need the starting indices |
|
766 |
## but the first span might not be 1, so |
|
767 |
## we pad with 1 and then take off the last |
|
768 | 3185x |
start <- cumsum(c(1, head(cspans, -1))) |
769 | 3185x |
ends <- c(tail(start, -1) - 1, nc) |
770 | 3185x |
res <- mapply(function(st, en) { |
771 | 18189x |
sum(j >= st & j <= en) |
772 | 3185x |
}, st = start, en = ends) |
773 | 3185x |
res <- res[res > 0] |
774 | 3185x |
stopifnot(sum(res) == length(j)) |
775 | 3185x |
res |
776 |
} |
|
777 | ||
778 |
select_cells_j <- function(cells, j) { |
|
779 | 3185x |
if (length(j) != length(unique(j))) { |
780 | ! |
stop("duplicate column selections is not currently supported") |
781 |
} |
|
782 | 3185x |
spans <- vapply( |
783 | 3185x |
cells, function(x) cell_cspan(x), |
784 | 3185x |
integer(1) |
785 |
) |
|
786 | 3185x |
inds <- rep(seq_along(cells), times = spans) |
787 | 3185x |
selinds <- inds[j] |
788 | 3185x |
retcells <- cells[selinds[!duplicated(selinds)]] |
789 | 3185x |
newspans <- vapply( |
790 | 3185x |
split(selinds, selinds), |
791 | 3185x |
length, |
792 | 3185x |
integer(1) |
793 |
) |
|
794 | ||
795 | 3185x |
mapply(function(cl, sp) { |
796 | 5841x |
cell_cspan(cl) <- sp |
797 | 5841x |
cl |
798 | 3185x |
}, cl = retcells, sp = newspans, SIMPLIFY = FALSE) |
799 |
} |
|
800 | ||
801 |
setMethod( |
|
802 |
"subset_cols", c("ANY", "character"), |
|
803 |
function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) { |
|
804 | 42x |
j <- .path_to_pos(path = j, tt = tt, cols = TRUE) |
805 | 42x |
subset_cols(tt, j, newcinfo = newcinfo, keep_topleft = keep_topleft, ...) |
806 |
} |
|
807 |
) |
|
808 | ||
809 |
setMethod( |
|
810 |
"subset_cols", c("TableRow", "numeric"), |
|
811 |
function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) { |
|
812 | 3185x |
j <- .j_to_posj(j, ncol(tt)) |
813 | 3185x |
if (is.null(newcinfo)) { |
814 | 16x |
cinfo <- col_info(tt) |
815 | 16x |
newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...) |
816 |
} |
|
817 | 3185x |
tt2 <- tt |
818 | 3185x |
row_cells(tt2) <- select_cells_j(row_cells(tt2), j) |
819 | ||
820 | 3185x |
if (length(row_cspans(tt2)) > 0) { |
821 | 3185x |
row_cspans(tt2) <- .fix_rowcspans(tt2, j) |
822 |
} |
|
823 | 3185x |
col_info(tt2) <- newcinfo |
824 | 3185x |
tt2 |
825 |
} |
|
826 |
) |
|
827 | ||
828 |
setMethod( |
|
829 |
"subset_cols", c("LabelRow", "numeric"), |
|
830 |
function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) { |
|
831 | 2300x |
j <- .j_to_posj(j, ncol(tt)) |
832 | 2300x |
if (is.null(newcinfo)) { |
833 | ! |
cinfo <- col_info(tt) |
834 | ! |
newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...) |
835 |
} |
|
836 | 2300x |
col_info(tt) <- newcinfo |
837 | 2300x |
tt |
838 |
} |
|
839 |
) |
|
840 | ||
841 |
setMethod( |
|
842 |
"subset_cols", c("InstantiatedColumnInfo", "numeric"), |
|
843 |
function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) { |
|
844 | 263x |
if (!is.null(newcinfo)) { |
845 | ! |
return(newcinfo) |
846 |
} |
|
847 | 263x |
j <- .j_to_posj(j, length(col_exprs(tt))) |
848 | 263x |
newctree <- subset_cols(coltree(tt), j, NULL) |
849 | 263x |
newcextra <- col_extra_args(tt)[j] |
850 | 263x |
newcsubs <- col_exprs(tt)[j] |
851 | 263x |
newcounts <- col_counts(tt)[j] |
852 | 263x |
tl <- if (keep_topleft) top_left(tt) else character() |
853 | 263x |
InstantiatedColumnInfo( |
854 | 263x |
treelyt = newctree, |
855 | 263x |
csubs = newcsubs, |
856 | 263x |
extras = newcextra, |
857 | 263x |
cnts = newcounts, |
858 | 263x |
dispcounts = disp_ccounts(tt), |
859 | 263x |
countformat = colcount_format(tt), |
860 | 263x |
topleft = tl |
861 |
) |
|
862 |
} |
|
863 |
) |
|
864 | ||
865 |
setMethod( |
|
866 |
"subset_cols", c("LayoutColTree", "numeric"), |
|
867 |
function(tt, j, newcinfo = NULL, ...) { |
|
868 | 263x |
lst <- collect_leaves(tt) |
869 | 263x |
j <- .j_to_posj(j, length(lst)) |
870 | ||
871 |
## j has only non-negative values from |
|
872 |
## this point on |
|
873 | 263x |
counter <- 0 |
874 | 263x |
prune_children <- function(x, j) { |
875 | 614x |
kids <- tree_children(x) |
876 | 614x |
newkids <- kids |
877 | 614x |
for (i in seq_along(newkids)) { |
878 | 1696x |
if (is(newkids[[i]], "LayoutColLeaf")) { |
879 | 1345x |
counter <<- counter + 1 |
880 | 1345x |
if (!(counter %in% j)) { |
881 | 959x |
newkids[[i]] <- list() |
882 | 263x |
} ## NULL removes the position entirely |
883 |
} else { |
|
884 | 351x |
newkids[[i]] <- prune_children(newkids[[i]], j) |
885 |
} |
|
886 |
} |
|
887 | ||
888 | 614x |
newkids <- newkids[sapply(newkids, function(thing) length(thing) > 0)] |
889 | 614x |
if (length(newkids) > 0) { |
890 | 444x |
tree_children(x) <- newkids |
891 | 444x |
x |
892 |
} else { |
|
893 | 170x |
list() |
894 |
} |
|
895 |
} |
|
896 | 263x |
prune_children(tt, j) |
897 |
} |
|
898 |
) |
|
899 | ||
900 |
## label rows ARE included in the count |
|
901 |
subset_by_rownum <- function(tt, |
|
902 |
i, |
|
903 |
keep_topleft = FALSE, |
|
904 |
keep_titles = TRUE, |
|
905 |
keep_footers = keep_titles, |
|
906 |
...) { |
|
907 | 188x |
stopifnot(is(tt, "VTableNodeInfo")) |
908 | 188x |
counter <- 0 |
909 | 188x |
nr <- nrow(tt) |
910 | 188x |
i <- .j_to_posj(i, nr) |
911 | 188x |
if (length(i) == 0) { |
912 | 3x |
ret <- TableTree(cinfo = col_info(tt)) |
913 | 3x |
if (isTRUE(keep_topleft)) { |
914 | 1x |
top_left(ret) <- top_left(tt) |
915 |
} |
|
916 | 3x |
return(ret) |
917 |
} |
|
918 | ||
919 | 185x |
prune_rowsbynum <- function(x, i, valifnone = NULL) { |
920 | 1370x |
maxi <- max(i) |
921 | 1370x |
if (counter > maxi) { |
922 | 138x |
return(valifnone) |
923 |
} |
|
924 | ||
925 | 1232x |
if (labelrow_visible(x)) { |
926 | 499x |
counter <<- counter + 1 |
927 | 499x |
if (!(counter %in% i)) { |
928 |
## XXX this should do whatever |
|
929 |
## is required to 'remove' the Label Row |
|
930 |
## (currently implicit based on |
|
931 |
## the value of the label but |
|
932 |
## that shold really probably change) |
|
933 | 181x |
labelrow_visible(x) <- FALSE |
934 |
} |
|
935 |
} |
|
936 | 1232x |
if (is(x, "TableTree") && nrow(content_table(x)) > 0) { |
937 | 97x |
ctab <- content_table(x) |
938 | ||
939 | 97x |
content_table(x) <- prune_rowsbynum(ctab, i, |
940 | 97x |
valifnone = ElementaryTable( |
941 | 97x |
cinfo = col_info(ctab), |
942 | 97x |
iscontent = TRUE |
943 |
) |
|
944 |
) |
|
945 |
} |
|
946 | 1232x |
kids <- tree_children(x) |
947 | 1232x |
if (counter > maxi) { # already done |
948 | 50x |
kids <- list() |
949 | 1182x |
} else if (length(kids) > 0) { |
950 | 1180x |
for (pos in seq_along(kids)) { |
951 | 4169x |
if (is(kids[[pos]], "TableRow")) { |
952 | 3081x |
counter <<- counter + 1 |
953 | 3081x |
if (!(counter %in% i)) { |
954 | 2153x |
kids[[pos]] <- list() |
955 |
} |
|
956 |
} else { |
|
957 | 1088x |
kids[[pos]] <- prune_rowsbynum(kids[[pos]], i, list()) |
958 |
} |
|
959 |
} |
|
960 | 1180x |
kids <- kids[sapply(kids, function(x) NROW(x) > 0)] |
961 |
} |
|
962 | 1232x |
if (length(kids) == 0 && NROW(content_table(x)) == 0 && !labelrow_visible(x)) { |
963 | 371x |
return(valifnone) |
964 |
} else { |
|
965 | 861x |
tree_children(x) <- kids |
966 | 861x |
x |
967 |
} |
|
968 |
## ## if(length(kids) == 0) { |
|
969 |
## ## if(!is(x, "TableTree")) |
|
970 |
## ## return(valifnone) |
|
971 |
## ## } |
|
972 |
## if(is(x, "VTableTree") && nrow(x) > 0) { |
|
973 |
## x |
|
974 |
## } else { |
|
975 |
## valifnone |
|
976 |
## } |
|
977 |
} |
|
978 | 185x |
ret <- prune_rowsbynum(tt, i) |
979 | ||
980 | 185x |
ret <- .h_copy_titles_footers_topleft( |
981 | 185x |
ret, tt, |
982 | 185x |
keep_titles, |
983 | 185x |
keep_footers, |
984 | 185x |
keep_topleft |
985 |
) |
|
986 | ||
987 | 185x |
ret |
988 |
} |
|
989 | ||
990 |
#' @exportMethod [ |
|
991 |
#' @rdname brackets |
|
992 |
setMethod( |
|
993 |
"[", c("VTableTree", "logical", "logical"), |
|
994 |
function(x, i, j, ..., drop = FALSE) { |
|
995 | 1x |
i <- .j_to_posj(i, nrow(x)) |
996 | 1x |
j <- .j_to_posj(j, ncol(x)) |
997 | 1x |
x[i, j, ..., drop = drop] |
998 |
} |
|
999 |
) |
|
1000 | ||
1001 |
#' @exportMethod [ |
|
1002 |
#' @rdname int_methods |
|
1003 |
#' @keywords internal |
|
1004 |
setMethod( |
|
1005 |
"[", c("VTableTree", "logical", "ANY"), |
|
1006 |
function(x, i, j, ..., drop = FALSE) { |
|
1007 | ! |
i <- .j_to_posj(i, nrow(x)) |
1008 | ! |
x[i, j, ..., drop = drop] |
1009 |
} |
|
1010 |
) |
|
1011 | ||
1012 |
#' @exportMethod [ |
|
1013 |
#' @rdname int_methods |
|
1014 |
#' @keywords internal |
|
1015 |
setMethod( |
|
1016 |
"[", c("VTableTree", "logical", "missing"), |
|
1017 |
function(x, i, j, ..., drop = FALSE) { |
|
1018 | 4x |
j <- seq_len(ncol(x)) |
1019 | 4x |
i <- .j_to_posj(i, nrow(x)) |
1020 | 4x |
x[i, j, ..., drop = drop] |
1021 |
} |
|
1022 |
) |
|
1023 | ||
1024 |
#' @exportMethod [ |
|
1025 |
#' @rdname int_methods |
|
1026 |
#' @keywords internal |
|
1027 |
setMethod( |
|
1028 |
"[", c("VTableTree", "ANY", "logical"), |
|
1029 |
function(x, i, j, ..., drop = FALSE) { |
|
1030 | 1x |
j <- .j_to_posj(j, ncol(x)) |
1031 | 1x |
x[i, j, ..., drop = drop] |
1032 |
} |
|
1033 |
) |
|
1034 | ||
1035 |
#' @exportMethod [ |
|
1036 |
#' @rdname int_methods |
|
1037 |
#' @keywords internal |
|
1038 |
setMethod( |
|
1039 |
"[", c("VTableTree", "ANY", "missing"), |
|
1040 |
function(x, i, j, ..., drop = FALSE) { |
|
1041 | 148x |
j <- seq_len(ncol(x)) |
1042 | 148x |
x[i = i, j = j, ..., drop = drop] |
1043 |
} |
|
1044 |
) |
|
1045 | ||
1046 |
#' @exportMethod [ |
|
1047 |
#' @rdname int_methods |
|
1048 |
#' @keywords internal |
|
1049 |
setMethod( |
|
1050 |
"[", c("VTableTree", "missing", "ANY"), |
|
1051 |
function(x, i, j, ..., drop = FALSE) { |
|
1052 | 1x |
i <- seq_len(nrow(x)) |
1053 | 1x |
x[i = i, j = j, ..., drop = drop] |
1054 |
} |
|
1055 |
) |
|
1056 | ||
1057 |
#' @exportMethod [ |
|
1058 |
#' @rdname int_methods |
|
1059 |
#' @keywords internal |
|
1060 |
setMethod( |
|
1061 |
"[", c("VTableTree", "ANY", "character"), |
|
1062 |
function(x, i, j, ..., drop = FALSE) { |
|
1063 |
## j <- .colpath_to_j(j, coltree(x)) |
|
1064 | ! |
j <- .path_to_pos(path = j, tt = x, cols = TRUE) |
1065 | ! |
x[i = i, j = j, ..., drop = drop] |
1066 |
} |
|
1067 |
) |
|
1068 | ||
1069 |
#' @exportMethod [ |
|
1070 |
#' @rdname int_methods |
|
1071 |
#' @keywords internal |
|
1072 |
setMethod( |
|
1073 |
"[", c("VTableTree", "character", "ANY"), |
|
1074 |
function(x, i, j, ..., drop = FALSE) { |
|
1075 |
## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW) |
|
1076 | ! |
i <- .path_to_pos(i, x) |
1077 | ! |
x[i = i, j = j, ..., drop = drop] |
1078 |
} |
|
1079 |
) |
|
1080 | ||
1081 |
## to avoid dispatch ambiguity. Not necessary, possibly not a good idea at all |
|
1082 |
#' @exportMethod [ |
|
1083 |
#' @rdname int_methods |
|
1084 |
#' @keywords internal |
|
1085 |
setMethod( |
|
1086 |
"[", c("VTableTree", "character", "character"), |
|
1087 |
function(x, i, j, ..., drop = FALSE) { |
|
1088 |
## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW) |
|
1089 | ! |
i <- .path_to_pos(i, x) |
1090 |
## j <- .colpath_to_j(j, coltree(x)) |
|
1091 | ! |
j <- .path_to_pos(path = j, tt = x, cols = TRUE) |
1092 | ! |
x[i = i, j = j, ..., drop = drop] |
1093 |
} |
|
1094 |
) |
|
1095 | ||
1096 |
#' @exportMethod [ |
|
1097 |
#' @rdname int_methods |
|
1098 |
#' @keywords internal |
|
1099 |
setMethod( |
|
1100 |
"[", c("VTableTree", "missing", "numeric"), |
|
1101 |
function(x, i, j, ..., drop = FALSE) { |
|
1102 | 228x |
i <- seq_len(nrow(x)) |
1103 | 228x |
x[i, j, ..., drop = drop] |
1104 |
} |
|
1105 |
) |
|
1106 | ||
1107 |
#' @exportMethod [ |
|
1108 |
#' @rdname int_methods |
|
1109 |
#' @keywords internal |
|
1110 |
setMethod( |
|
1111 |
"[", c("VTableTree", "numeric", "numeric"), |
|
1112 |
function(x, i, j, ..., drop = FALSE) { |
|
1113 |
## have to do it this way because we can't add an argument since we don't |
|
1114 |
## own the generic declaration |
|
1115 | 460x |
keep_topleft <- list(...)[["keep_topleft"]] %||% NA |
1116 | 460x |
keep_titles <- list(...)[["keep_titles"]] %||% FALSE |
1117 | 460x |
keep_footers <- list(...)[["keep_footers"]] %||% keep_titles |
1118 | 460x |
reindex_refs <- list(...)[["reindex_refs"]] %||% TRUE |
1119 | ||
1120 | 460x |
nr <- nrow(x) |
1121 | 460x |
nc <- ncol(x) |
1122 | 460x |
i <- .j_to_posj(i, nr) |
1123 | 460x |
j <- .j_to_posj(j, nc) |
1124 | ||
1125 |
## if(!missing(i) && length(i) < nr) { |
|
1126 | 460x |
if (length(i) < nr) { ## already populated by .j_to_posj |
1127 | 188x |
keep_topleft <- isTRUE(keep_topleft) |
1128 | 188x |
x <- subset_by_rownum(x, i, |
1129 | 188x |
keep_topleft = keep_topleft, |
1130 | 188x |
keep_titles = keep_titles, |
1131 | 188x |
keep_footers = keep_footers |
1132 |
) |
|
1133 | 272x |
} else if (is.na(keep_topleft)) { |
1134 | 43x |
keep_topleft <- TRUE |
1135 |
} |
|
1136 | ||
1137 |
## if(!missing(j) && length(j) < nc) |
|
1138 | 460x |
if (length(j) < nc) { |
1139 | 217x |
x <- subset_cols(x, j, |
1140 | 217x |
keep_topleft = keep_topleft, |
1141 | 217x |
keep_titles = keep_titles, |
1142 | 217x |
keep_footers = keep_footers |
1143 |
) |
|
1144 |
} |
|
1145 | ||
1146 |
# Dropping everything |
|
1147 | 460x |
if (drop) { |
1148 | 35x |
if (length(j) == 1L && length(i) == 1L) { |
1149 | 30x |
rw <- collect_leaves(x, TRUE, TRUE)[[1]] |
1150 | 30x |
if (is(rw, "LabelRow")) { |
1151 | 2x |
warning( |
1152 | 2x |
"The value selected with drop = TRUE belongs ", |
1153 | 2x |
"to a label row. NULL will be returned" |
1154 |
) |
|
1155 | 2x |
x <- NULL |
1156 |
} else { |
|
1157 | 28x |
x <- row_values(rw)[[1]] |
1158 |
} |
|
1159 |
} else { |
|
1160 | 5x |
warning( |
1161 | 5x |
"Trying to drop more than one subsetted value. ", |
1162 | 5x |
"We support this only with accessor function `cell_values()`. ", |
1163 | 5x |
"No drop will be done at this time." |
1164 |
) |
|
1165 | 5x |
drop <- FALSE |
1166 |
} |
|
1167 |
} |
|
1168 | 460x |
if (!drop) { |
1169 | 430x |
if (!keep_topleft) { |
1170 | 63x |
top_left(x) <- character() |
1171 |
} |
|
1172 | 430x |
if (reindex_refs) { |
1173 | 101x |
x <- update_ref_indexing(x) |
1174 |
} |
|
1175 |
} |
|
1176 | 460x |
x |
1177 |
} |
|
1178 |
) |
|
1179 | ||
1180 |
#' @importFrom utils compareVersion |
|
1181 | ||
1182 |
setGeneric("tail", tail) |
|
1183 | ||
1184 |
setMethod( |
|
1185 |
"tail", "VTableTree", |
|
1186 |
function(x, n = 6L, ...) { |
|
1187 |
if (compareVersion("4.0.0", as.character(getRversion())) <= 0) { |
|
1188 |
tail.matrix(x, n, keepnums = FALSE) |
|
1189 |
} else { |
|
1190 |
tail.matrix(x, n, addrownums = FALSE) |
|
1191 |
} |
|
1192 |
} |
|
1193 |
) |
|
1194 | ||
1195 |
setGeneric("head", head) |
|
1196 | ||
1197 |
setMethod( |
|
1198 |
"head", "VTableTree", |
|
1199 |
function(x, n = 6L, ...) { |
|
1200 |
head.matrix(x, n) |
|
1201 |
} |
|
1202 |
) |
|
1203 | ||
1204 |
#' Retrieve cell values by row and column path |
|
1205 |
#' |
|
1206 |
#' @inheritParams gen_args |
|
1207 |
#' @param rowpath (`character`)\cr path in row-split space to the desired row(s). Can include `"@content"`. |
|
1208 |
#' @param colpath (`character`)\cr path in column-split space to the desired column(s). Can include `"*"`. |
|
1209 |
#' @param omit_labrows (`flag`)\cr whether label rows underneath `rowpath` should be omitted (`TRUE`, the default), |
|
1210 |
#' or return empty lists of cell "values" (`FALSE`). |
|
1211 |
#' |
|
1212 |
#' @return |
|
1213 |
#' * `cell_values` returns a `list` (regardless of the type of value the cells hold). If `rowpath` defines a path to |
|
1214 |
#' a single row, `cell_values` returns the list of cell values for that row, otherwise a list of such lists, one for |
|
1215 |
#' each row captured underneath `rowpath`. This occurs after subsetting to `colpath` has occurred. |
|
1216 |
#' * `value_at` returns the "unwrapped" value of a single cell, or an error, if the combination of `rowpath` and |
|
1217 |
#' `colpath` do not define the location of a single cell in `tt`. |
|
1218 |
#' |
|
1219 |
#' @note `cell_values` will return a single cell's value wrapped in a list. Use `value_at` to receive the "bare" cell |
|
1220 |
#' value. |
|
1221 |
#' |
|
1222 |
#' @examples |
|
1223 |
#' lyt <- basic_table() %>% |
|
1224 |
#' split_cols_by("ARM") %>% |
|
1225 |
#' split_cols_by("SEX") %>% |
|
1226 |
#' split_rows_by("RACE") %>% |
|
1227 |
#' summarize_row_groups() %>% |
|
1228 |
#' split_rows_by("STRATA1") %>% |
|
1229 |
#' analyze("AGE") |
|
1230 |
#' |
|
1231 |
#' library(dplyr) ## for mutate |
|
1232 |
#' tbl <- build_table(lyt, DM %>% |
|
1233 |
#' mutate(SEX = droplevels(SEX), RACE = droplevels(RACE))) |
|
1234 |
#' |
|
1235 |
#' row_paths_summary(tbl) |
|
1236 |
#' col_paths_summary(tbl) |
|
1237 |
#' |
|
1238 |
#' cell_values( |
|
1239 |
#' tbl, c("RACE", "ASIAN", "STRATA1", "B"), |
|
1240 |
#' c("ARM", "A: Drug X", "SEX", "F") |
|
1241 |
#' ) |
|
1242 |
#' |
|
1243 |
#' # it's also possible to access multiple values by being less specific |
|
1244 |
#' cell_values( |
|
1245 |
#' tbl, c("RACE", "ASIAN", "STRATA1"), |
|
1246 |
#' c("ARM", "A: Drug X", "SEX", "F") |
|
1247 |
#' ) |
|
1248 |
#' cell_values(tbl, c("RACE", "ASIAN"), c("ARM", "A: Drug X", "SEX", "M")) |
|
1249 |
#' |
|
1250 |
#' ## any arm, male columns from the ASIAN content (i.e. summary) row |
|
1251 |
#' cell_values( |
|
1252 |
#' tbl, c("RACE", "ASIAN", "@content"), |
|
1253 |
#' c("ARM", "B: Placebo", "SEX", "M") |
|
1254 |
#' ) |
|
1255 |
#' cell_values( |
|
1256 |
#' tbl, c("RACE", "ASIAN", "@content"), |
|
1257 |
#' c("ARM", "*", "SEX", "M") |
|
1258 |
#' ) |
|
1259 |
#' |
|
1260 |
#' ## all columns |
|
1261 |
#' cell_values(tbl, c("RACE", "ASIAN", "STRATA1", "B")) |
|
1262 |
#' |
|
1263 |
#' ## all columns for the Combination arm |
|
1264 |
#' cell_values( |
|
1265 |
#' tbl, c("RACE", "ASIAN", "STRATA1", "B"), |
|
1266 |
#' c("ARM", "C: Combination") |
|
1267 |
#' ) |
|
1268 |
#' |
|
1269 |
#' cvlist <- cell_values( |
|
1270 |
#' tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"), |
|
1271 |
#' c("ARM", "B: Placebo", "SEX", "M") |
|
1272 |
#' ) |
|
1273 |
#' cvnolist <- value_at( |
|
1274 |
#' tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"), |
|
1275 |
#' c("ARM", "B: Placebo", "SEX", "M") |
|
1276 |
#' ) |
|
1277 |
#' stopifnot(identical(cvlist[[1]], cvnolist)) |
|
1278 |
#' |
|
1279 |
#' @rdname cell_values |
|
1280 |
#' @export |
|
1281 |
setGeneric("cell_values", function(tt, rowpath = NULL, colpath = NULL, omit_labrows = TRUE) { |
|
1282 | 163x |
standardGeneric("cell_values") |
1283 |
}) |
|
1284 | ||
1285 |
#' @rdname int_methods |
|
1286 |
#' @keywords internal |
|
1287 |
#' @exportMethod cell_values |
|
1288 |
setMethod( |
|
1289 |
"cell_values", "VTableTree", |
|
1290 |
function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) { |
|
1291 | 160x |
.inner_cell_value(tt, |
1292 | 160x |
rowpath = rowpath, colpath = colpath, |
1293 | 160x |
omit_labrows = omit_labrows, value_at = FALSE |
1294 |
) |
|
1295 |
} |
|
1296 |
) |
|
1297 | ||
1298 |
#' @rdname int_methods |
|
1299 |
#' @keywords internal |
|
1300 |
#' @exportMethod cell_values |
|
1301 |
setMethod( |
|
1302 |
"cell_values", "TableRow", |
|
1303 |
function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) { |
|
1304 | 2x |
if (!is.null(rowpath)) { |
1305 | 1x |
stop("cell_values on TableRow objects must have NULL rowpath") |
1306 |
} |
|
1307 | 1x |
.inner_cell_value(tt, |
1308 | 1x |
rowpath = rowpath, colpath = colpath, |
1309 | 1x |
omit_labrows = omit_labrows, value_at = FALSE |
1310 |
) |
|
1311 |
} |
|
1312 |
) |
|
1313 | ||
1314 |
#' @rdname int_methods |
|
1315 |
#' @keywords internal |
|
1316 |
#' @exportMethod cell_values |
|
1317 |
setMethod( |
|
1318 |
"cell_values", "LabelRow", |
|
1319 |
function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) { |
|
1320 | 1x |
stop("calling cell_values on LabelRow is not meaningful") |
1321 |
} |
|
1322 |
) |
|
1323 | ||
1324 |
#' @rdname cell_values |
|
1325 |
#' @export |
|
1326 |
setGeneric("value_at", function(tt, rowpath = NULL, colpath = NULL) { |
|
1327 | 8x |
standardGeneric("value_at") |
1328 |
}) |
|
1329 | ||
1330 |
#' @rdname cell_values |
|
1331 |
#' @exportMethod value_at |
|
1332 |
setMethod( |
|
1333 |
"value_at", "VTableTree", |
|
1334 |
function(tt, rowpath, colpath = NULL) { |
|
1335 | 7x |
.inner_cell_value(tt, |
1336 | 7x |
rowpath = rowpath, colpath = colpath, |
1337 | 7x |
omit_labrows = FALSE, value_at = TRUE |
1338 |
) |
|
1339 |
} |
|
1340 |
) |
|
1341 | ||
1342 |
#' @rdname int_methods |
|
1343 |
#' @keywords internal |
|
1344 |
#' @exportMethod value_at |
|
1345 |
setMethod( |
|
1346 |
"value_at", "TableRow", |
|
1347 |
function(tt, rowpath, colpath = NULL) { |
|
1348 | 1x |
.inner_cell_value(tt, |
1349 | 1x |
rowpath = rowpath, colpath = colpath, |
1350 | 1x |
omit_labrows = FALSE, value_at = TRUE |
1351 |
) |
|
1352 |
} |
|
1353 |
) |
|
1354 | ||
1355 |
#' @rdname int_methods |
|
1356 |
#' @keywords internal |
|
1357 |
#' @exportMethod value_at |
|
1358 |
setMethod( |
|
1359 |
"value_at", "LabelRow", |
|
1360 |
function(tt, rowpath, colpath = NULL) { |
|
1361 | ! |
stop("calling value_at for LabelRow objects is not meaningful") |
1362 |
} |
|
1363 |
) |
|
1364 | ||
1365 |
.inner_cell_value <- function(tt, |
|
1366 |
rowpath, |
|
1367 |
colpath = NULL, |
|
1368 |
omit_labrows = TRUE, |
|
1369 |
value_at = FALSE) { |
|
1370 | 169x |
if (is.null(rowpath)) { |
1371 | 90x |
subtree <- tt |
1372 |
} else { |
|
1373 | 79x |
subtree <- tt_at_path(tt, rowpath) |
1374 |
} |
|
1375 | 168x |
if (!is.null(colpath)) { |
1376 | 28x |
subtree <- subset_cols(subtree, colpath) |
1377 |
} |
|
1378 | ||
1379 | 168x |
rows <- collect_leaves(subtree, TRUE, !omit_labrows) |
1380 | 168x |
if (value_at && (ncol(subtree) != 1 || length(rows) != 1)) { |
1381 | 3x |
stop("Combination of rowpath and colpath does not select individual cell.\n", |
1382 | 3x |
" To retrieve more than one cell value at a time use cell_values().", |
1383 | 3x |
call. = FALSE |
1384 |
) |
|
1385 |
} |
|
1386 | 165x |
if (length(rows) == 1) { |
1387 | 92x |
ret <- row_values(rows[[1]]) |
1388 | 92x |
if (value_at && ncol(subtree) == 1) { |
1389 | 5x |
ret <- ret[[1]] |
1390 |
} |
|
1391 | 92x |
ret |
1392 |
} else { |
|
1393 | 73x |
lapply(rows, row_values) |
1394 |
} |
|
1395 |
} |
|
1396 | ||
1397 |
## empty_table is created in onLoad because it depends on other things there. |
|
1398 | ||
1399 |
# Helper function to copy or not header, footer, and topleft information |
|
1400 |
.h_copy_titles_footers_topleft <- function(new, |
|
1401 |
old, |
|
1402 |
keep_titles, |
|
1403 |
keep_footers, |
|
1404 |
keep_topleft, |
|
1405 |
reindex_refs = FALSE, |
|
1406 |
empt_tbl = empty_table) { |
|
1407 |
## Please note that the standard adopted come from an empty table |
|
1408 | ||
1409 |
# titles |
|
1410 | 2488x |
if (isTRUE(keep_titles)) { |
1411 | 2318x |
main_title(new) <- main_title(old) |
1412 | 2318x |
subtitles(new) <- subtitles(old) |
1413 |
} else { |
|
1414 | 170x |
main_title(new) <- main_title(empt_tbl) |
1415 | 170x |
subtitles(new) <- subtitles(empt_tbl) |
1416 |
} |
|
1417 | ||
1418 |
# fnotes |
|
1419 | 2488x |
if (isTRUE(keep_footers)) { |
1420 | 2324x |
main_footer(new) <- main_footer(old) |
1421 | 2324x |
prov_footer(new) <- prov_footer(old) |
1422 |
} else { |
|
1423 | 164x |
main_footer(new) <- main_footer(empt_tbl) |
1424 | 164x |
prov_footer(new) <- prov_footer(empt_tbl) |
1425 |
} |
|
1426 | ||
1427 |
# topleft |
|
1428 | 2488x |
if (isTRUE(keep_topleft)) { |
1429 | 2338x |
top_left(new) <- top_left(old) |
1430 |
} else { |
|
1431 | 150x |
top_left(new) <- top_left(empt_tbl) |
1432 |
} |
|
1433 | ||
1434 |
# reindex references |
|
1435 | 2488x |
if (reindex_refs) { |
1436 | ! |
new <- update_ref_indexing(new) |
1437 |
} |
|
1438 | ||
1439 | 2488x |
new |
1440 |
} |
|
1441 | ||
1442 |
#' Head and tail methods |
|
1443 |
#' |
|
1444 |
#' @inheritParams utils::head |
|
1445 |
#' @param keep_topleft (`flag`)\cr if `TRUE` (the default), top_left material for the table will be carried over to the |
|
1446 |
#' subset. |
|
1447 |
#' @param keep_titles (`flag`)\cr if `TRUE` (the default), all title material for the table will be carried over to the |
|
1448 |
#' subset. |
|
1449 |
#' @param keep_footers (`flag`)\cr if `TRUE`, all footer material for the table will be carried over to the subset. It |
|
1450 |
#' defaults to `keep_titles`. |
|
1451 |
#' @param reindex_refs (`flag`)\cr defaults to `FALSE`. If `TRUE`, referential footnotes will be reindexed for the |
|
1452 |
#' subset. |
|
1453 |
#' |
|
1454 |
#' @docType methods |
|
1455 |
#' @export |
|
1456 |
#' @rdname head_tail |
|
1457 |
setGeneric("head") |
|
1458 | ||
1459 |
#' @docType methods |
|
1460 |
#' @export |
|
1461 |
#' @rdname head_tail |
|
1462 |
setMethod( |
|
1463 |
"head", "VTableTree", |
|
1464 |
function(x, n = 6, ..., keep_topleft = TRUE, |
|
1465 |
keep_titles = TRUE, |
|
1466 |
keep_footers = keep_titles, |
|
1467 |
## FALSE because this is a glance |
|
1468 |
## more often than a subset op |
|
1469 |
reindex_refs = FALSE) { |
|
1470 |
## default |
|
1471 | 5x |
res <- callNextMethod() |
1472 | 5x |
res <- .h_copy_titles_footers_topleft( |
1473 | 5x |
old = x, new = res, |
1474 | 5x |
keep_topleft = keep_topleft, |
1475 | 5x |
keep_titles = keep_titles, |
1476 | 5x |
keep_footers = keep_footers, |
1477 | 5x |
reindex_refs = reindex_refs |
1478 |
) |
|
1479 | 5x |
res |
1480 |
} |
|
1481 |
) |
|
1482 | ||
1483 |
#' @docType methods |
|
1484 |
#' @export |
|
1485 |
#' @rdname head_tail |
|
1486 |
setGeneric("tail") |
|
1487 | ||
1488 |
#' @docType methods |
|
1489 |
#' @export |
|
1490 |
#' @rdname head_tail |
|
1491 |
setMethod( |
|
1492 |
"tail", "VTableTree", |
|
1493 |
function(x, n = 6, ..., keep_topleft = TRUE, |
|
1494 |
keep_titles = TRUE, |
|
1495 |
keep_footers = keep_titles, |
|
1496 |
## FALSE because this is a glance |
|
1497 |
## more often than a subset op |
|
1498 |
reindex_refs = FALSE) { |
|
1499 | 4x |
res <- callNextMethod() |
1500 | 4x |
res <- .h_copy_titles_footers_topleft( |
1501 | 4x |
old = x, new = res, |
1502 | 4x |
keep_topleft = keep_topleft, |
1503 | 4x |
keep_titles = keep_titles, |
1504 | 4x |
keep_footers = keep_footers, |
1505 | 4x |
reindex_refs = reindex_refs |
1506 |
) |
|
1507 | 4x |
res |
1508 |
} |
|
1509 |
) |
1 |
#' Create an `ElementaryTable` from a `data.frame` |
|
2 |
#' |
|
3 |
#' @param df (`data.frame`)\cr a data frame. |
|
4 |
#' |
|
5 |
#' @details |
|
6 |
#' If row names are not defined in `df` (or they are simple numbers), then the row names are taken from the column |
|
7 |
#' `label_name`, if it exists. If `label_name` exists, then it is also removed from the original data. This behavior |
|
8 |
#' is compatible with [as_result_df()], when `as_is = TRUE` and the row names are not unique. |
|
9 |
#' |
|
10 |
#' @seealso [as_result_df()] for the inverse operation. |
|
11 |
#' |
|
12 |
#' @examples |
|
13 |
#' df_to_tt(mtcars) |
|
14 |
#' |
|
15 |
#' @export |
|
16 |
df_to_tt <- function(df) { |
|
17 | 4x |
colnms <- colnames(df) |
18 | 4x |
cinfo <- manual_cols(colnms) |
19 | 4x |
rnames <- rownames(df) |
20 | 4x |
havern <- !is.null(rnames) |
21 | ||
22 | 4x |
if ((!havern || all(grepl("[0-9]+", rnames))) && "label_name" %in% colnms) { |
23 | 1x |
rnames <- df$label_name |
24 | 1x |
df <- df[, -match("label_name", colnms)] |
25 | 1x |
colnms <- colnames(df) |
26 | 1x |
cinfo <- manual_cols(colnms) |
27 | 1x |
havern <- TRUE |
28 |
} |
|
29 | ||
30 | 4x |
kids <- lapply(seq_len(nrow(df)), function(i) { |
31 | 124x |
rni <- if (havern) rnames[i] else "" |
32 | 124x |
do.call(rrow, c(list(row.name = rni), unclass(df[i, ]))) |
33 |
}) |
|
34 | ||
35 | 4x |
ElementaryTable(kids = kids, cinfo = cinfo) |
36 |
} |
1 |
## Generics and how they are used directly |
|
2 | ||
3 |
## check_validsplit - Check if the split is valid for the data, error if not |
|
4 | ||
5 |
## .apply_spl_extras - Generate Extras |
|
6 | ||
7 |
## .apply_spl_datapart - generate data partition |
|
8 | ||
9 |
## .apply_spl_rawvals - Generate raw (i.e. non SplitValue object) partition values |
|
10 | ||
11 |
setGeneric( |
|
12 |
".applysplit_rawvals", |
|
13 | 926x |
function(spl, df) standardGeneric(".applysplit_rawvals") |
14 |
) |
|
15 | ||
16 |
setGeneric( |
|
17 |
".applysplit_datapart", |
|
18 | 1000x |
function(spl, df, vals) standardGeneric(".applysplit_datapart") |
19 |
) |
|
20 | ||
21 |
setGeneric( |
|
22 |
".applysplit_extras", |
|
23 | 1000x |
function(spl, df, vals) standardGeneric(".applysplit_extras") |
24 |
) |
|
25 | ||
26 |
setGeneric( |
|
27 |
".applysplit_partlabels", |
|
28 | 999x |
function(spl, df, vals, labels) standardGeneric(".applysplit_partlabels") |
29 |
) |
|
30 | ||
31 |
setGeneric( |
|
32 |
"check_validsplit", |
|
33 | 2136x |
function(spl, df) standardGeneric("check_validsplit") |
34 |
) |
|
35 | ||
36 |
setGeneric( |
|
37 |
".applysplit_ref_vals", |
|
38 | 17x |
function(spl, df, vals) standardGeneric(".applysplit_ref_vals") |
39 |
) |
|
40 | ||
41 |
#' Custom split functions |
|
42 |
#' |
|
43 |
#' Split functions provide the work-horse for `rtables`'s generalized partitioning. These functions accept a (sub)set |
|
44 |
#' of incoming data and a split object, and return "splits" of that data. |
|
45 |
#' |
|
46 |
#' @section Custom Splitting Function Details: |
|
47 |
#' |
|
48 |
#' User-defined custom split functions can perform any type of computation on the incoming data provided that they |
|
49 |
#' meet the requirements for generating "splits" of the incoming data based on the split object. |
|
50 |
#' |
|
51 |
#' Split functions are functions that accept: |
|
52 |
#' \describe{ |
|
53 |
#' \item{df}{a `data.frame` of incoming data to be split.} |
|
54 |
#' \item{spl}{a Split object. This is largely an internal detail custom functions will not need to worry about, |
|
55 |
#' but `obj_name(spl)`, for example, will give the name of the split as it will appear in paths in the resulting |
|
56 |
#' table.} |
|
57 |
#' \item{vals}{any pre-calculated values. If given non-`NULL` values, the values returned should match these. |
|
58 |
#' Should be `NULL` in most cases and can usually be ignored.} |
|
59 |
#' \item{labels}{any pre-calculated value labels. Same as above for `values`.} |
|
60 |
#' \item{trim}{if `TRUE`, resulting splits that are empty are removed.} |
|
61 |
#' \item{(optional) .spl_context}{a `data.frame` describing previously performed splits which collectively |
|
62 |
#' arrived at `df`.} |
|
63 |
#' } |
|
64 |
#' |
|
65 |
#' The function must then output a named `list` with the following elements: |
|
66 |
#' |
|
67 |
#' \describe{ |
|
68 |
#' \item{values}{the vector of all values corresponding to the splits of `df`.} |
|
69 |
#' \item{datasplit}{a list of `data.frame`s representing the groupings of the actual observations from `df`.} |
|
70 |
#' \item{labels}{a character vector giving a string label for each value listed in the `values` element above.} |
|
71 |
#' \item{(optional) extras}{if present, extra arguments are to be passed to summary and analysis functions |
|
72 |
#' whenever they are executed on the corresponding element of `datasplit` or a subset thereof.} |
|
73 |
#' } |
|
74 |
#' |
|
75 |
#' One way to generate custom splitting functions is to wrap existing split functions and modify either the incoming |
|
76 |
#' data before they are called or their outputs. |
|
77 |
#' |
|
78 |
#' @seealso [make_split_fun()] for the API for creating custom split functions, and [split_funcs] for a variety of |
|
79 |
#' pre-defined split functions. |
|
80 |
#' |
|
81 |
#' @examples |
|
82 |
#' # Example of a picky split function. The number of values in the column variable |
|
83 |
#' # var decrees if we are going to print also the column with all observation |
|
84 |
#' # or not. |
|
85 |
#' |
|
86 |
#' picky_splitter <- function(var) { |
|
87 |
#' # Main layout function |
|
88 |
#' function(df, spl, vals, labels, trim) { |
|
89 |
#' orig_vals <- vals |
|
90 |
#' |
|
91 |
#' # Check for number of levels if all are selected |
|
92 |
#' if (is.null(vals)) { |
|
93 |
#' vec <- df[[var]] |
|
94 |
#' vals <- unique(vec) |
|
95 |
#' } |
|
96 |
#' |
|
97 |
#' # Do a split with or without All obs |
|
98 |
#' if (length(vals) == 1) { |
|
99 |
#' do_base_split(spl = spl, df = df, vals = vals, labels = labels, trim = trim) |
|
100 |
#' } else { |
|
101 |
#' fnc_tmp <- add_overall_level("Overall", label = "All Obs", first = FALSE) |
|
102 |
#' fnc_tmp(df = df, spl = spl, vals = orig_vals, trim = trim) |
|
103 |
#' } |
|
104 |
#' } |
|
105 |
#' } |
|
106 |
#' |
|
107 |
#' # Data sub-set |
|
108 |
#' d1 <- subset(ex_adsl, ARM == "A: Drug X" | (ARM == "B: Placebo" & SEX == "F")) |
|
109 |
#' d1 <- subset(d1, SEX %in% c("M", "F")) |
|
110 |
#' d1$SEX <- factor(d1$SEX) |
|
111 |
#' |
|
112 |
#' # This table uses the number of values in the SEX column to add the overall col or not |
|
113 |
#' lyt <- basic_table() %>% |
|
114 |
#' split_cols_by("ARM", split_fun = drop_split_levels) %>% |
|
115 |
#' split_cols_by("SEX", split_fun = picky_splitter("SEX")) %>% |
|
116 |
#' analyze("AGE", show_labels = "visible") |
|
117 |
#' tbl <- build_table(lyt, d1) |
|
118 |
#' tbl |
|
119 |
#' |
|
120 |
#' @name custom_split_funs |
|
121 |
NULL |
|
122 | ||
123 |
## do various cleaning, and naming, plus |
|
124 |
## ensure partinfo$values contains SplitValue objects only |
|
125 |
.fixupvals <- function(partinfo) { |
|
126 | 1020x |
if (is.factor(partinfo$labels)) { |
127 | ! |
partinfo$labels <- as.character(partinfo$labels) |
128 |
} |
|
129 | ||
130 | 1020x |
vals <- partinfo$values |
131 | 1020x |
if (is.factor(vals)) { |
132 | ! |
vals <- levels(vals)[vals] |
133 |
} |
|
134 | 1020x |
extr <- partinfo$extras |
135 | 1020x |
dpart <- partinfo$datasplit |
136 | 1020x |
labels <- partinfo$labels |
137 | 1020x |
if (is.null(labels)) { |
138 | ! |
if (!is.null(names(vals))) { |
139 | ! |
labels <- names(vals) |
140 | ! |
} else if (!is.null(names(dpart))) { |
141 | ! |
labels <- names(dpart) |
142 | ! |
} else if (!is.null(names(extr))) { |
143 | ! |
labels <- names(extr) |
144 |
} |
|
145 |
} |
|
146 | ||
147 | 1020x |
if (is.null(vals) && !is.null(extr)) { |
148 | ! |
vals <- seq_along(extr) |
149 |
} |
|
150 | ||
151 | 1020x |
if (length(vals) == 0) { |
152 | 13x |
stopifnot(length(extr) == 0) |
153 | 13x |
return(partinfo) |
154 |
} |
|
155 |
## length(vals) > 0 from here down |
|
156 | ||
157 | 1007x |
if (are(vals, "SplitValue") && !are(vals, "LevelComboSplitValue")) { |
158 | 18x |
if (!is.null(extr)) { |
159 |
## in_ref_cols is in here for some reason even though its already in the SplitValue object. |
|
160 |
## https://github.com/insightsengineering/rtables/issues/707#issuecomment-1678810598 |
|
161 |
## the if is a bandaid. |
|
162 |
## XXX FIXME RIGHT |
|
163 | 3x |
sq <- seq_along(vals) |
164 | 3x |
if (any(vapply(sq, function(i) !all(names(extr[[i]]) %in% names(splv_extra(vals[[i]]))), TRUE))) { |
165 | ! |
warning( |
166 | ! |
"Got a partinfo list with values that are ", |
167 | ! |
"already SplitValue objects and non-null extras ", |
168 | ! |
"element. This shouldn't happen" |
169 |
) |
|
170 |
} |
|
171 |
} |
|
172 |
} else { |
|
173 | 989x |
if (is.null(extr)) { |
174 | 3x |
extr <- rep(list(list()), length(vals)) |
175 |
} |
|
176 | 989x |
vals <- make_splvalue_vec(vals, extr, labels = labels) |
177 |
} |
|
178 |
## we're done with this so take it off |
|
179 | 1007x |
partinfo$extras <- NULL |
180 | ||
181 | 1007x |
vnames <- value_names(vals) |
182 | 1007x |
names(vals) <- vnames |
183 | 1007x |
partinfo$values <- vals |
184 | ||
185 | 1007x |
if (!identical(names(dpart), vnames)) { |
186 | 1007x |
names(dpart) <- vnames |
187 | 1007x |
partinfo$datasplit <- dpart |
188 |
} |
|
189 | ||
190 | 1007x |
partinfo$labels <- labels |
191 | ||
192 | 1007x |
stopifnot(length(unique(sapply(partinfo, NROW))) == 1) |
193 | 1007x |
partinfo |
194 |
} |
|
195 | ||
196 |
.add_ref_extras <- function(spl, df, partinfo) { |
|
197 |
## this is only the .in_ref_col booleans |
|
198 | 17x |
refvals <- .applysplit_ref_vals(spl, df, partinfo$values) |
199 | 17x |
ref_ind <- which(unlist(refvals)) |
200 | 17x |
stopifnot(length(ref_ind) == 1) |
201 | ||
202 | 17x |
vnames <- value_names(partinfo$values) |
203 | 17x |
if (is.null(partinfo$extras)) { |
204 | 3x |
names(refvals) <- vnames |
205 | 3x |
partinfo$extras <- refvals |
206 |
} else { |
|
207 | 14x |
newextras <- mapply( |
208 | 14x |
function(old, incol, ref_full) { |
209 | 37x |
c(old, list( |
210 | 37x |
.in_ref_col = incol, |
211 | 37x |
.ref_full = ref_full |
212 |
)) |
|
213 |
}, |
|
214 | 14x |
old = partinfo$extras, |
215 | 14x |
incol = unlist(refvals), |
216 | 14x |
MoreArgs = list(ref_full = partinfo$datasplit[[ref_ind]]), |
217 | 14x |
SIMPLIFY = FALSE |
218 |
) |
|
219 | 14x |
names(newextras) <- vnames |
220 | 14x |
partinfo$extras <- newextras |
221 |
} |
|
222 | 17x |
partinfo |
223 |
} |
|
224 | ||
225 |
#' Apply basic split (for use in custom split functions) |
|
226 |
#' |
|
227 |
#' This function is intended for use inside custom split functions. It applies the current split *as if it had no |
|
228 |
#' custom splitting function* so that those default splits can be further manipulated. |
|
229 |
#' |
|
230 |
#' @inheritParams gen_args |
|
231 |
#' @param vals (`ANY`)\cr already calculated/known values of the split. Generally should be left as `NULL`. |
|
232 |
#' @param labels (`character`)\cr labels associated with `vals`. Should be `NULL` whenever `vals` is, which should |
|
233 |
#' almost always be the case. |
|
234 |
#' @param trim (`flag`)\cr whether groups corresponding to empty data subsets should be removed. Defaults to |
|
235 |
#' `FALSE`. |
|
236 |
#' |
|
237 |
#' @return The result of the split being applied as if it had no custom split function. See [custom_split_funs]. |
|
238 |
#' |
|
239 |
#' @examples |
|
240 |
#' uneven_splfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) { |
|
241 |
#' ret <- do_base_split(spl, df, vals, labels, trim) |
|
242 |
#' if (NROW(df) == 0) { |
|
243 |
#' ret <- lapply(ret, function(x) x[1]) |
|
244 |
#' } |
|
245 |
#' ret |
|
246 |
#' } |
|
247 |
#' |
|
248 |
#' lyt <- basic_table() %>% |
|
249 |
#' split_cols_by("ARM") %>% |
|
250 |
#' split_cols_by_multivar(c("USUBJID", "AESEQ", "BMRKR1"), |
|
251 |
#' varlabels = c("N", "E", "BMR1"), |
|
252 |
#' split_fun = uneven_splfun |
|
253 |
#' ) %>% |
|
254 |
#' analyze_colvars(list( |
|
255 |
#' USUBJID = function(x, ...) length(unique(x)), |
|
256 |
#' AESEQ = max, |
|
257 |
#' BMRKR1 = mean |
|
258 |
#' )) |
|
259 |
#' |
|
260 |
#' tbl <- build_table(lyt, subset(ex_adae, as.numeric(ARM) <= 2)) |
|
261 |
#' tbl |
|
262 |
#' |
|
263 |
#' @export |
|
264 |
do_base_split <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) { |
|
265 | 12x |
spl2 <- spl |
266 | 12x |
split_fun(spl2) <- NULL |
267 | 12x |
do_split(spl2, |
268 | 12x |
df = df, vals = vals, labels = labels, trim = trim, |
269 | 12x |
spl_context = NULL |
270 |
) |
|
271 |
} |
|
272 | ||
273 |
### NB This is called at EACH level of recursive splitting |
|
274 |
do_split <- function(spl, |
|
275 |
df, |
|
276 |
vals = NULL, |
|
277 |
labels = NULL, |
|
278 |
trim = FALSE, |
|
279 |
spl_context) { |
|
280 |
## this will error if, e.g., df doesn't have columns |
|
281 |
## required by spl, or generally any time the spl |
|
282 |
## can't be applied to df |
|
283 | 1019x |
check_validsplit(spl, df) |
284 |
## note the <- here!!! |
|
285 | 1018x |
if (!is.null(splfun <- split_fun(spl))) { |
286 |
## Currently the contract is that split_functions take df, vals, labels and |
|
287 |
## return list(values=., datasplit=., labels = .), optionally with |
|
288 |
## an additional extras element |
|
289 | 338x |
if (func_takes(splfun, ".spl_context")) { |
290 | 22x |
ret <- tryCatch( |
291 | 22x |
splfun(df, spl, vals, labels, |
292 | 22x |
trim = trim, |
293 | 22x |
.spl_context = spl_context |
294 |
), |
|
295 | 22x |
error = function(e) e |
296 | 22x |
) ## rawvalues(spl_context )) |
297 |
} else { |
|
298 | 316x |
ret <- tryCatch(splfun(df, spl, vals, labels, trim = trim), |
299 | 316x |
error = function(e) e |
300 |
) |
|
301 |
} |
|
302 | 338x |
if (is(ret, "error")) { |
303 | 6x |
stop( |
304 | 6x |
"Error applying custom split function: ", ret$message, "\n\tsplit: ", |
305 | 6x |
class(spl), " (", payloadmsg(spl), ")\n", |
306 | 6x |
"\toccured at path: ", |
307 | 6x |
spl_context_to_disp_path(spl_context), "\n" |
308 |
) |
|
309 |
} |
|
310 |
} else { |
|
311 | 680x |
ret <- .apply_split_inner(df = df, spl = spl, vals = vals, labels = labels, trim = trim) |
312 |
} |
|
313 | ||
314 |
## this adds .ref_full and .in_ref_col |
|
315 | 1012x |
if (is(spl, "VarLevWBaselineSplit")) { |
316 | 17x |
ret <- .add_ref_extras(spl, df, ret) |
317 |
} |
|
318 | ||
319 |
## this: |
|
320 |
## - guarantees that ret$values contains SplitValue objects |
|
321 |
## - removes the extras element since its redundant after the above |
|
322 |
## - Ensures datasplit and values lists are named according to labels |
|
323 |
## - ensures labels are character not factor |
|
324 | 1012x |
ret <- .fixupvals(ret) |
325 |
## we didn't put this in .fixupvals because that get called withint he split functions |
|
326 |
## created by make_split_fun and its not clear this check should be happening then. |
|
327 | 1012x |
if (has_force_pag(spl) && length(ret$datasplit) == 0) { ## this means it's page_by=TRUE |
328 | 3x |
stop( |
329 | 3x |
"Page-by split resulted in zero pages (no observed values of split variable?). \n\tsplit: ", |
330 | 3x |
class(spl), " (", payloadmsg(spl), ")\n", |
331 | 3x |
"\toccured at path: ", |
332 | 3x |
spl_context_to_disp_path(spl_context), "\n" |
333 |
) |
|
334 |
} |
|
335 | 1009x |
ret |
336 |
} |
|
337 | ||
338 |
.apply_split_inner <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) { |
|
339 | 1000x |
if (is.null(vals)) { |
340 | 926x |
vals <- .applysplit_rawvals(spl, df) |
341 |
} |
|
342 | 1000x |
extr <- .applysplit_extras(spl, df, vals) |
343 | ||
344 | 1000x |
if (is.null(vals)) { |
345 | ! |
return(list( |
346 | ! |
values = list(), |
347 | ! |
datasplit = list(), |
348 | ! |
labels = list(), |
349 | ! |
extras = list() |
350 |
)) |
|
351 |
} |
|
352 | ||
353 | 1000x |
dpart <- .applysplit_datapart(spl, df, vals) |
354 | ||
355 | 1000x |
if (is.null(labels)) { |
356 | 999x |
labels <- .applysplit_partlabels(spl, df, vals, labels) |
357 |
} else { |
|
358 | 1x |
stopifnot(names(labels) == names(vals)) |
359 |
} |
|
360 |
## get rid of columns that would not have any |
|
361 |
## observations. |
|
362 |
## |
|
363 |
## But only if there were any rows to start with |
|
364 |
## if not we're in a manually constructed table |
|
365 |
## column tree |
|
366 | 1000x |
if (trim) { |
367 | ! |
hasdata <- sapply(dpart, function(x) nrow(x) > 0) |
368 | ! |
if (nrow(df) > 0 && length(dpart) > sum(hasdata)) { # some empties |
369 | ! |
dpart <- dpart[hasdata] |
370 | ! |
vals <- vals[hasdata] |
371 | ! |
extr <- extr[hasdata] |
372 | ! |
labels <- labels[hasdata] |
373 |
} |
|
374 |
} |
|
375 | ||
376 | 1000x |
if (is.null(spl_child_order(spl)) || is(spl, "AllSplit")) { |
377 | 150x |
vord <- seq_along(vals) |
378 |
} else { |
|
379 | 850x |
vord <- match( |
380 | 850x |
spl_child_order(spl), |
381 | 850x |
vals |
382 |
) |
|
383 | 850x |
vord <- vord[!is.na(vord)] |
384 |
} |
|
385 | ||
386 |
## FIXME: should be an S4 object, not a list |
|
387 | 1000x |
ret <- list( |
388 | 1000x |
values = vals[vord], |
389 | 1000x |
datasplit = dpart[vord], |
390 | 1000x |
labels = labels[vord], |
391 | 1000x |
extras = extr[vord] |
392 |
) |
|
393 | 1000x |
ret |
394 |
} |
|
395 | ||
396 |
.checkvarsok <- function(spl, df) { |
|
397 | 1912x |
vars <- spl_payload(spl) |
398 |
## could be multiple vars in the future? |
|
399 |
## no reason not to make that work here now. |
|
400 | 1912x |
if (!all(vars %in% names(df))) { |
401 | 2x |
stop( |
402 | 2x |
" variable(s) [", |
403 | 2x |
paste(setdiff(vars, names(df)), |
404 | 2x |
collapse = ", " |
405 |
), |
|
406 | 2x |
"] not present in data. (", |
407 | 2x |
class(spl), ")" |
408 |
) |
|
409 |
} |
|
410 | 1910x |
invisible(NULL) |
411 |
} |
|
412 | ||
413 |
### Methods to verify a split appears to be valid, applicable |
|
414 |
### to the ***current subset*** of the df. |
|
415 |
### |
|
416 |
### This is called at each level of recursive splitting so |
|
417 |
### do NOT make it check, e.g., if the ref_group level of |
|
418 |
### a factor is present in the data, because it may not be. |
|
419 | ||
420 |
setMethod( |
|
421 |
"check_validsplit", "VarLevelSplit", |
|
422 |
function(spl, df) { |
|
423 | 794x |
.checkvarsok(spl, df) |
424 |
} |
|
425 |
) |
|
426 | ||
427 |
setMethod( |
|
428 |
"check_validsplit", "MultiVarSplit", |
|
429 |
function(spl, df) { |
|
430 | 55x |
.checkvarsok(spl, df) |
431 |
} |
|
432 |
) |
|
433 | ||
434 |
setMethod( |
|
435 |
"check_validsplit", "VAnalyzeSplit", |
|
436 |
function(spl, df) { |
|
437 | 1117x |
if (!is.na(spl_payload(spl))) { |
438 | 1063x |
.checkvarsok(spl, df) |
439 |
} else { |
|
440 | 54x |
TRUE |
441 |
} |
|
442 |
} |
|
443 |
) |
|
444 | ||
445 |
setMethod( |
|
446 |
"check_validsplit", "CompoundSplit", |
|
447 |
function(spl, df) { |
|
448 | ! |
all(sapply(spl_payload(spl), df)) |
449 |
} |
|
450 |
) |
|
451 | ||
452 |
## default does nothing, add methods as they become |
|
453 |
## required |
|
454 |
setMethod( |
|
455 |
"check_validsplit", "Split", |
|
456 | 119x |
function(spl, df) invisible(NULL) |
457 |
) |
|
458 | ||
459 |
setMethod( |
|
460 |
".applysplit_rawvals", "VarLevelSplit", |
|
461 |
function(spl, df) { |
|
462 | 708x |
varvec <- df[[spl_payload(spl)]] |
463 | 708x |
if (is.factor(varvec)) { |
464 | 508x |
levels(varvec) |
465 |
} else { |
|
466 | 200x |
unique(varvec) |
467 |
} |
|
468 |
} |
|
469 |
) |
|
470 | ||
471 |
setMethod( |
|
472 |
".applysplit_rawvals", "MultiVarSplit", |
|
473 |
function(spl, df) { |
|
474 |
## spl_payload(spl) |
|
475 | 48x |
spl_varnames(spl) |
476 |
} |
|
477 |
) |
|
478 | ||
479 |
setMethod( |
|
480 |
".applysplit_rawvals", "AllSplit", |
|
481 | 97x |
function(spl, df) obj_name(spl) |
482 |
) # "all obs") |
|
483 | ||
484 |
setMethod( |
|
485 |
".applysplit_rawvals", "ManualSplit", |
|
486 | 51x |
function(spl, df) spl@levels |
487 |
) |
|
488 | ||
489 |
## setMethod(".applysplit_rawvals", "NULLSplit", |
|
490 |
## function(spl, df) "") |
|
491 | ||
492 |
setMethod( |
|
493 |
".applysplit_rawvals", "VAnalyzeSplit", |
|
494 | ! |
function(spl, df) spl_payload(spl) |
495 |
) |
|
496 | ||
497 |
## formfactor here is gross we're gonna have ot do this |
|
498 |
## all again in tthe data split part :-/ |
|
499 |
setMethod( |
|
500 |
".applysplit_rawvals", "VarStaticCutSplit", |
|
501 |
function(spl, df) { |
|
502 | 22x |
spl_cutlabels(spl) |
503 |
} |
|
504 |
) |
|
505 | ||
506 |
setMethod( |
|
507 |
".applysplit_datapart", "VarLevelSplit", |
|
508 |
function(spl, df, vals) { |
|
509 | 782x |
if (!(spl_payload(spl) %in% names(df))) { |
510 | ! |
stop( |
511 | ! |
"Attempted to split on values of column (", spl_payload(spl), |
512 | ! |
") not present in the data" |
513 |
) |
|
514 |
} |
|
515 | 782x |
ret <- lapply(seq_along(vals), function(i) { |
516 | 2133x |
spl_col <- df[[spl_payload(spl)]] |
517 | 2133x |
df[!is.na(spl_col) & spl_col == vals[[i]], ] |
518 |
}) |
|
519 | 782x |
names(ret) <- as.character(vals) |
520 | 782x |
ret |
521 |
} |
|
522 |
) |
|
523 | ||
524 |
setMethod( |
|
525 |
".applysplit_datapart", "MultiVarSplit", |
|
526 |
function(spl, df, vals) { |
|
527 | 48x |
allvnms <- spl_varnames(spl) |
528 | 48x |
if (!is.null(vals) && !identical(allvnms, vals)) { |
529 | ! |
incl <- match(vals, allvnms) |
530 |
} else { |
|
531 | 48x |
incl <- seq_along(allvnms) |
532 |
} |
|
533 | 48x |
vars <- spl_payload(spl)[incl] |
534 |
## don't remove nas |
|
535 |
## ret = lapply(vars, function(cl) { |
|
536 |
## df[!is.na(df[[cl]]),] |
|
537 |
## }) |
|
538 | 48x |
ret <- rep(list(df), length(vars)) |
539 | 48x |
names(ret) <- vals |
540 | 48x |
ret |
541 |
} |
|
542 |
) |
|
543 | ||
544 |
setMethod( |
|
545 |
".applysplit_datapart", "AllSplit", |
|
546 | 97x |
function(spl, df, vals) list(df) |
547 |
) |
|
548 | ||
549 |
## ## not sure I need this |
|
550 |
setMethod( |
|
551 |
".applysplit_datapart", "ManualSplit", |
|
552 | 51x |
function(spl, df, vals) rep(list(df), times = length(vals)) |
553 |
) |
|
554 | ||
555 |
## setMethod(".applysplit_datapart", "NULLSplit", |
|
556 |
## function(spl, df, vals) list(df[FALSE,])) |
|
557 | ||
558 |
setMethod( |
|
559 |
".applysplit_datapart", "VarStaticCutSplit", |
|
560 |
function(spl, df, vals) { |
|
561 |
# lbs = spl_cutlabels(spl) |
|
562 | 14x |
var <- spl_payload(spl) |
563 | 14x |
varvec <- df[[var]] |
564 | 14x |
cts <- spl_cuts(spl) |
565 | 14x |
cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs) |
566 | 14x |
split(df, cfct, drop = FALSE) |
567 |
} |
|
568 |
) |
|
569 | ||
570 |
setMethod( |
|
571 |
".applysplit_datapart", "CumulativeCutSplit", |
|
572 |
function(spl, df, vals) { |
|
573 |
# lbs = spl_cutlabels(spl) |
|
574 | 8x |
var <- spl_payload(spl) |
575 | 8x |
varvec <- df[[var]] |
576 | 8x |
cts <- spl_cuts(spl) |
577 | 8x |
cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs) |
578 | 8x |
ret <- lapply( |
579 | 8x |
seq_len(length(levels(cfct))), |
580 | 8x |
function(i) df[as.integer(cfct) <= i, ] |
581 |
) |
|
582 | 8x |
names(ret) <- levels(cfct) |
583 | 8x |
ret |
584 |
} |
|
585 |
) |
|
586 | ||
587 |
## XXX TODO *CutSplit Methods |
|
588 | ||
589 |
setClass("NullSentinel", contains = "NULL") |
|
590 |
nullsentinel <- new("NullSentinel") |
|
591 | ! |
noarg <- function() nullsentinel |
592 | ||
593 |
## Extras generation methods |
|
594 |
setMethod( |
|
595 |
".applysplit_extras", "Split", |
|
596 |
function(spl, df, vals) { |
|
597 | 949x |
splex <- split_exargs(spl) |
598 | 949x |
nvals <- length(vals) |
599 | 949x |
lapply(seq_len(nvals), function(vpos) { |
600 | 2422x |
one_ex <- lapply(splex, function(arg) { |
601 | ! |
if (length(arg) >= vpos) { |
602 | ! |
arg[[vpos]] |
603 |
} else { |
|
604 | ! |
noarg() |
605 |
} |
|
606 |
}) |
|
607 | 2422x |
names(one_ex) <- names(splex) |
608 | 2422x |
one_ex <- one_ex[!sapply(one_ex, is, "NullSentinel")] |
609 | 2422x |
one_ex |
610 |
}) |
|
611 |
} |
|
612 |
) |
|
613 | ||
614 |
setMethod( |
|
615 |
".applysplit_ref_vals", "Split", |
|
616 | ! |
function(spl, df, vals) rep(list(NULL), length(vals)) |
617 |
) |
|
618 | ||
619 |
setMethod( |
|
620 |
".applysplit_ref_vals", "VarLevWBaselineSplit", |
|
621 |
function(spl, df, vals) { |
|
622 | 17x |
bl_level <- spl@ref_group_value # XXX XXX |
623 | 17x |
vnames <- value_names(vals) |
624 | 17x |
ret <- lapply(vnames, function(vl) { |
625 | 46x |
list(.in_ref_col = vl == bl_level) |
626 |
}) |
|
627 | 17x |
names(ret) <- vnames |
628 | 17x |
ret |
629 |
} |
|
630 |
) |
|
631 | ||
632 |
## XXX TODO FIXME |
|
633 |
setMethod( |
|
634 |
".applysplit_partlabels", "Split", |
|
635 | 119x |
function(spl, df, vals, labels) as.character(vals) |
636 |
) |
|
637 | ||
638 |
setMethod( |
|
639 |
".applysplit_partlabels", "VarLevelSplit", |
|
640 |
function(spl, df, vals, labels) { |
|
641 | 781x |
varname <- spl_payload(spl) |
642 | 781x |
vlabelname <- spl_labelvar(spl) |
643 | 781x |
varvec <- df[[varname]] |
644 |
## we used to check if vals was NULL but |
|
645 |
## this is called after a short-circuit return in .apply_split_inner in that |
|
646 |
## case |
|
647 |
## so vals is guaranteed to be non-null here |
|
648 | 781x |
if (is.null(labels)) { |
649 | 781x |
if (varname == vlabelname) { |
650 | 646x |
labels <- vals |
651 |
} else { |
|
652 | 135x |
labfact <- is.factor(df[[vlabelname]]) |
653 | 135x |
lablevs <- if (labfact) levels(df[[vlabelname]]) else NULL |
654 | 135x |
labels <- sapply(vals, function(v) { |
655 | 272x |
vlabel <- unique(df[varvec == v, vlabelname, drop = TRUE]) |
656 |
## TODO remove this once 1-to-1 value-label map is enforced |
|
657 |
## elsewhere. |
|
658 | 272x |
stopifnot(length(vlabel) < 2) |
659 | 272x |
if (length(vlabel) == 0) { |
660 | ! |
vlabel <- "" |
661 | 272x |
} else if (labfact) { |
662 | 6x |
vlabel <- lablevs[vlabel] |
663 |
} |
|
664 | 272x |
vlabel |
665 |
}) |
|
666 |
} |
|
667 |
} |
|
668 | 781x |
names(labels) <- as.character(vals) |
669 | 781x |
labels |
670 |
} |
|
671 |
) |
|
672 | ||
673 |
setMethod( |
|
674 |
".applysplit_partlabels", "MultiVarSplit", |
|
675 | 48x |
function(spl, df, vals, labels) value_labels(spl) |
676 |
) |
|
677 | ||
678 |
make_splvalue_vec <- function(vals, extrs = list(list()), labels = vals) { |
|
679 | 2572x |
if (length(vals) == 0) { |
680 | 356x |
return(vals) |
681 |
} |
|
682 | ||
683 | 2216x |
if (is(extrs, "AsIs")) { |
684 | ! |
extrs <- unclass(extrs) |
685 |
} |
|
686 |
## if(are(vals, "SplitValue")) { |
|
687 | ||
688 |
## return(vals) |
|
689 |
## } |
|
690 | ||
691 | 2216x |
mapply(SplitValue, |
692 | 2216x |
val = vals, extr = extrs, |
693 | 2216x |
label = labels, |
694 | 2216x |
SIMPLIFY = FALSE |
695 |
) |
|
696 |
} |
|
697 | ||
698 |
#' Split functions |
|
699 |
#' |
|
700 |
#' @inheritParams sf_args |
|
701 |
#' @inheritParams gen_args |
|
702 |
#' @param vals (`ANY`)\cr for internal use only. |
|
703 |
#' @param labels (`character`)\cr labels to use for the remaining levels instead of the existing ones. |
|
704 |
#' @param excl (`character`)\cr levels to be excluded (they will not be reflected in the resulting table structure |
|
705 |
#' regardless of presence in the data). |
|
706 |
#' |
|
707 |
#' @inheritSection custom_split_funs Custom Splitting Function Details |
|
708 |
#' |
|
709 |
#' @inherit add_overall_level return |
|
710 |
#' |
|
711 |
#' @name split_funcs |
|
712 |
NULL |
|
713 | ||
714 | ||
715 |
#' @examples |
|
716 |
#' lyt <- basic_table() %>% |
|
717 |
#' split_cols_by("ARM") %>% |
|
718 |
#' split_rows_by("COUNTRY", |
|
719 |
#' split_fun = remove_split_levels(c( |
|
720 |
#' "USA", "CAN", |
|
721 |
#' "CHE", "BRA" |
|
722 |
#' )) |
|
723 |
#' ) %>% |
|
724 |
#' analyze("AGE") |
|
725 |
#' |
|
726 |
#' tbl <- build_table(lyt, DM) |
|
727 |
#' tbl |
|
728 |
#' |
|
729 |
#' @rdname split_funcs |
|
730 |
#' @export |
|
731 |
remove_split_levels <- function(excl) { |
|
732 | 28x |
stopifnot(is.character(excl)) |
733 | 28x |
function(df, spl, vals = NULL, labels = NULL, trim = FALSE) { |
734 | 56x |
var <- spl_payload(spl) |
735 | 56x |
df2 <- df[!(df[[var]] %in% excl), ] |
736 | 56x |
if (is.factor(df2[[var]])) { |
737 | 1x |
levels <- levels(df2[[var]]) |
738 | 1x |
levels <- levels[!(levels %in% excl)] |
739 | 1x |
df2[[var]] <- factor(df2[[var]], levels = levels) |
740 |
} |
|
741 | 56x |
.apply_split_inner(spl, df2, |
742 | 56x |
vals = vals, |
743 | 56x |
labels = labels, |
744 | 56x |
trim = trim |
745 |
) |
|
746 |
} |
|
747 |
} |
|
748 | ||
749 |
#' @param only (`character`)\cr levels to retain (all others will be dropped). |
|
750 |
#' @param reorder (`flag`)\cr whether the order of `only` should be used as the order of the children of the |
|
751 |
#' split. Defaults to `TRUE`. |
|
752 |
#' |
|
753 |
#' @examples |
|
754 |
#' lyt <- basic_table() %>% |
|
755 |
#' split_cols_by("ARM") %>% |
|
756 |
#' split_rows_by("COUNTRY", |
|
757 |
#' split_fun = keep_split_levels(c("USA", "CAN", "BRA")) |
|
758 |
#' ) %>% |
|
759 |
#' analyze("AGE") |
|
760 |
#' |
|
761 |
#' tbl <- build_table(lyt, DM) |
|
762 |
#' tbl |
|
763 |
#' |
|
764 |
#' @rdname split_funcs |
|
765 |
#' @export |
|
766 |
keep_split_levels <- function(only, reorder = TRUE) { |
|
767 | 40x |
function(df, spl, vals = NULL, labels = NULL, trim = FALSE) { |
768 | 74x |
var <- spl_payload(spl) |
769 | 74x |
varvec <- df[[var]] |
770 | 74x |
if (is.factor(varvec) && !all(only %in% levels(varvec))) { |
771 | 1x |
stop( |
772 | 1x |
"Attempted to keep invalid factor level(s) in split ", |
773 | 1x |
setdiff(only, levels(varvec)) |
774 |
) |
|
775 |
} |
|
776 | 73x |
df2 <- df[df[[var]] %in% only, ] |
777 | 73x |
if (reorder) { |
778 | 73x |
df2[[var]] <- factor(df2[[var]], levels = only) |
779 |
} |
|
780 | 73x |
spl_child_order(spl) <- only |
781 | 73x |
.apply_split_inner(spl, df2, |
782 | 73x |
vals = only, |
783 | 73x |
labels = labels, |
784 | 73x |
trim = trim |
785 |
) |
|
786 |
} |
|
787 |
} |
|
788 | ||
789 |
#' @examples |
|
790 |
#' lyt <- basic_table() %>% |
|
791 |
#' split_cols_by("ARM") %>% |
|
792 |
#' split_rows_by("SEX", split_fun = drop_split_levels) %>% |
|
793 |
#' analyze("AGE") |
|
794 |
#' |
|
795 |
#' tbl <- build_table(lyt, DM) |
|
796 |
#' tbl |
|
797 |
#' |
|
798 |
#' @rdname split_funcs |
|
799 |
#' @export |
|
800 |
drop_split_levels <- function(df, |
|
801 |
spl, |
|
802 |
vals = NULL, |
|
803 |
labels = NULL, |
|
804 |
trim = FALSE) { |
|
805 | 165x |
var <- spl_payload(spl) |
806 | 165x |
df2 <- df |
807 | 165x |
df2[[var]] <- factor(df[[var]]) |
808 | 165x |
lblvar <- spl_label_var(spl) |
809 | 165x |
if (!is.null(lblvar)) { |
810 | 165x |
df2[[lblvar]] <- factor(df[[lblvar]]) |
811 |
} |
|
812 | ||
813 | 165x |
.apply_split_inner(spl, df2, |
814 | 165x |
vals = vals, |
815 | 165x |
labels = labels, |
816 | 165x |
trim = trim |
817 |
) |
|
818 |
} |
|
819 | ||
820 |
#' @examples |
|
821 |
#' lyt <- basic_table() %>% |
|
822 |
#' split_cols_by("ARM") %>% |
|
823 |
#' split_rows_by("SEX", split_fun = drop_and_remove_levels(c("M", "U"))) %>% |
|
824 |
#' analyze("AGE") |
|
825 |
#' |
|
826 |
#' tbl <- build_table(lyt, DM) |
|
827 |
#' tbl |
|
828 |
#' |
|
829 |
#' @rdname split_funcs |
|
830 |
#' @export |
|
831 |
drop_and_remove_levels <- function(excl) { |
|
832 | 4x |
stopifnot(is.character(excl)) |
833 | 4x |
function(df, spl, vals = NULL, labels = NULL, trim = FALSE) { |
834 | 13x |
var <- spl_payload(spl) |
835 | 13x |
df2 <- df[!(df[[var]] %in% excl), ] |
836 | 13x |
df2[[var]] <- factor(df2[[var]]) |
837 | 13x |
.apply_split_inner( |
838 | 13x |
spl, |
839 | 13x |
df2, |
840 | 13x |
vals = vals, |
841 | 13x |
labels = labels, |
842 | 13x |
trim = trim |
843 |
) |
|
844 |
} |
|
845 |
} |
|
846 | ||
847 |
#' @param neworder (`character`)\cr new order of factor levels. |
|
848 |
#' @param newlabels (`character`)\cr labels for (new order of) factor levels. |
|
849 |
#' @param drlevels (`flag`)\cr whether levels in the data which do not appear in `neworder` should be dropped. |
|
850 |
#' Defaults to `TRUE`. |
|
851 |
#' |
|
852 |
#' @rdname split_funcs |
|
853 |
#' @export |
|
854 |
reorder_split_levels <- function(neworder, |
|
855 |
newlabels = neworder, |
|
856 |
drlevels = TRUE) { |
|
857 | 1x |
if (length(neworder) != length(newlabels)) { |
858 | ! |
stop("Got mismatching lengths for neworder and newlabels.") |
859 |
} |
|
860 | 1x |
function(df, spl, trim, ...) { |
861 | 1x |
df2 <- df |
862 | 1x |
valvec <- df2[[spl_payload(spl)]] |
863 | 1x |
vals <- if (is.factor(valvec)) levels(valvec) else unique(valvec) |
864 | 1x |
if (!drlevels) { |
865 | ! |
neworder <- c(neworder, setdiff(vals, neworder)) |
866 |
} |
|
867 | 1x |
df2[[spl_payload(spl)]] <- factor(valvec, levels = neworder) |
868 | 1x |
if (drlevels) { |
869 | 1x |
orig_order <- neworder |
870 | 1x |
df2[[spl_payload(spl)]] <- droplevels(df2[[spl_payload(spl)]]) |
871 | 1x |
neworder <- levels(df2[[spl_payload(spl)]]) |
872 | 1x |
newlabels <- newlabels[orig_order %in% neworder] |
873 |
} |
|
874 | 1x |
spl_child_order(spl) <- neworder |
875 | 1x |
.apply_split_inner(spl, df2, vals = neworder, labels = newlabels, trim = trim) |
876 |
} |
|
877 |
} |
|
878 | ||
879 |
#' @param innervar (`string`)\cr variable whose factor levels should be trimmed (e.g. empty levels dropped) |
|
880 |
#' *separately within each grouping defined at this point in the structure*. |
|
881 |
#' @param drop_outlevs (`flag`)\cr whether empty levels in the variable being split on (i.e. the "outer" |
|
882 |
#' variable, not `innervar`) should be dropped. Defaults to `TRUE`. |
|
883 |
#' |
|
884 |
#' @rdname split_funcs |
|
885 |
#' @export |
|
886 |
trim_levels_in_group <- function(innervar, drop_outlevs = TRUE) { |
|
887 | 3x |
myfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) { |
888 | 3x |
if (!drop_outlevs) { |
889 | ! |
ret <- .apply_split_inner(spl, df, |
890 | ! |
vals = vals, |
891 | ! |
labels = labels, trim = trim |
892 |
) |
|
893 |
} else { |
|
894 | 3x |
ret <- drop_split_levels( |
895 | 3x |
df = df, spl = spl, vals = vals, |
896 | 3x |
labels = labels, trim = trim |
897 |
) |
|
898 |
} |
|
899 | ||
900 | 3x |
ret$datasplit <- lapply(ret$datasplit, function(x) { |
901 | 8x |
coldat <- x[[innervar]] |
902 | 8x |
if (is(coldat, "character")) { |
903 | ! |
if (!is.null(vals)) { |
904 | ! |
lvs <- vals |
905 |
} else { |
|
906 | ! |
lvs <- unique(coldat) |
907 |
} |
|
908 | ! |
coldat <- factor(coldat, levels = lvs) ## otherwise |
909 |
} else { |
|
910 | 8x |
coldat <- droplevels(coldat) |
911 |
} |
|
912 | 8x |
x[[innervar]] <- coldat |
913 | 8x |
x |
914 |
}) |
|
915 | 3x |
ret$labels <- as.character(ret$labels) # TODO |
916 | 3x |
ret |
917 |
} |
|
918 | 3x |
myfun |
919 |
} |
|
920 | ||
921 |
.add_combo_part_info <- function(part, |
|
922 |
df, |
|
923 |
valuename, |
|
924 |
levels, |
|
925 |
label, |
|
926 |
extras, |
|
927 |
first = TRUE) { |
|
928 | 18x |
value <- LevelComboSplitValue(valuename, extras, |
929 | 18x |
combolevels = levels, |
930 | 18x |
label = label |
931 |
) |
|
932 | 18x |
newdat <- setNames(list(df), valuename) |
933 | 18x |
newval <- setNames(list(value), valuename) |
934 | 18x |
newextra <- setNames(list(extras), valuename) |
935 | 18x |
if (first) { |
936 | 6x |
part$datasplit <- c(newdat, part$datasplit) |
937 | 6x |
part$values <- c(newval, part$values) |
938 | 6x |
part$labels <- c(setNames(label, valuename), part$labels) |
939 | 6x |
part$extras <- c(newextra, part$extras) |
940 |
} else { |
|
941 | 12x |
part$datasplit <- c(part$datasplit, newdat) |
942 | 12x |
part$values <- c(part$values, newval) |
943 | 12x |
part$labels <- c(part$labels, setNames(label, valuename)) |
944 | 12x |
part$extras <- c(part$extras, newextra) |
945 |
} |
|
946 |
## not needed even in custom split function case. |
|
947 |
## part = .fixupvals(part) |
|
948 | 18x |
part |
949 |
} |
|
950 | ||
951 |
#' Add a virtual "overall" level to split |
|
952 |
#' |
|
953 |
#' @inheritParams lyt_args |
|
954 |
#' @inheritParams sf_args |
|
955 |
#' @param valname (`string`)\cr value to be assigned to the implicit all-observations split level. Defaults to |
|
956 |
#' `"Overall"`. |
|
957 |
#' @param first (`flag`)\cr whether the implicit level should appear first (`TRUE`) or last (`FALSE`). Defaults |
|
958 |
#' to `TRUE`. |
|
959 |
#' |
|
960 |
#' @return A closure suitable for use as a splitting function (`splfun`) when creating a table layout. |
|
961 |
#' |
|
962 |
#' @examples |
|
963 |
#' lyt <- basic_table() %>% |
|
964 |
#' split_cols_by("ARM", split_fun = add_overall_level("All Patients", |
|
965 |
#' first = FALSE |
|
966 |
#' )) %>% |
|
967 |
#' analyze("AGE") |
|
968 |
#' |
|
969 |
#' tbl <- build_table(lyt, DM) |
|
970 |
#' tbl |
|
971 |
#' |
|
972 |
#' lyt2 <- basic_table() %>% |
|
973 |
#' split_cols_by("ARM") %>% |
|
974 |
#' split_rows_by("RACE", |
|
975 |
#' split_fun = add_overall_level("All Ethnicities") |
|
976 |
#' ) %>% |
|
977 |
#' summarize_row_groups(label_fstr = "%s (n)") %>% |
|
978 |
#' analyze("AGE") |
|
979 |
#' lyt2 |
|
980 |
#' |
|
981 |
#' tbl2 <- build_table(lyt2, DM) |
|
982 |
#' tbl2 |
|
983 |
#' |
|
984 |
#' @export |
|
985 |
add_overall_level <- function(valname = "Overall", |
|
986 |
label = valname, |
|
987 |
extra_args = list(), |
|
988 |
first = TRUE, |
|
989 |
trim = FALSE) { |
|
990 | 5x |
combodf <- data.frame( |
991 | 5x |
valname = valname, |
992 | 5x |
label = label, |
993 | 5x |
levelcombo = I(list(select_all_levels)), |
994 | 5x |
exargs = I(list(extra_args)), |
995 | 5x |
stringsAsFactors = FALSE |
996 |
) |
|
997 | 5x |
add_combo_levels(combodf, |
998 | 5x |
trim = trim, first = first |
999 |
) |
|
1000 |
} |
|
1001 | ||
1002 |
setClass("AllLevelsSentinel", contains = "character") |
|
1003 | ||
1004 |
# nocov start |
|
1005 |
#' @rdname add_combo_levels |
|
1006 |
#' @export |
|
1007 |
select_all_levels <- new("AllLevelsSentinel") |
|
1008 |
# nocov end |
|
1009 | ||
1010 |
#' Add combination levels to split |
|
1011 |
#' |
|
1012 |
#' @inheritParams sf_args |
|
1013 |
#' @param combosdf (`data.frame` or `tbl_df`)\cr a data frame with columns `valname`, `label`, `levelcombo`, and |
|
1014 |
#' `exargs`. `levelcombo` and `exargs` should be list columns. Passing the `select_all_levels` object as a value in |
|
1015 |
#' `comblevels` column indicates that an overall/all-observations level should be created. |
|
1016 |
#' @param keep_levels (`character` or `NULL`)\cr if non-`NULL`, the levels to retain across both combination and |
|
1017 |
#' individual levels. |
|
1018 |
#' |
|
1019 |
#' @inherit add_overall_level return |
|
1020 |
#' |
|
1021 |
#' @note |
|
1022 |
#' Analysis or summary functions for which the order matters should never be used within the tabulation framework. |
|
1023 |
#' |
|
1024 |
#' @examples |
|
1025 |
#' library(tibble) |
|
1026 |
#' combodf <- tribble( |
|
1027 |
#' ~valname, ~label, ~levelcombo, ~exargs, |
|
1028 |
#' "A_B", "Arms A+B", c("A: Drug X", "B: Placebo"), list(), |
|
1029 |
#' "A_C", "Arms A+C", c("A: Drug X", "C: Combination"), list() |
|
1030 |
#' ) |
|
1031 |
#' |
|
1032 |
#' lyt <- basic_table(show_colcounts = TRUE) %>% |
|
1033 |
#' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>% |
|
1034 |
#' analyze("AGE") |
|
1035 |
#' |
|
1036 |
#' tbl <- build_table(lyt, DM) |
|
1037 |
#' tbl |
|
1038 |
#' |
|
1039 |
#' lyt1 <- basic_table(show_colcounts = TRUE) %>% |
|
1040 |
#' split_cols_by("ARM", |
|
1041 |
#' split_fun = add_combo_levels(combodf, |
|
1042 |
#' keep_levels = c( |
|
1043 |
#' "A_B", |
|
1044 |
#' "A_C" |
|
1045 |
#' ) |
|
1046 |
#' ) |
|
1047 |
#' ) %>% |
|
1048 |
#' analyze("AGE") |
|
1049 |
#' |
|
1050 |
#' tbl1 <- build_table(lyt1, DM) |
|
1051 |
#' tbl1 |
|
1052 |
#' |
|
1053 |
#' smallerDM <- droplevels(subset(DM, SEX %in% c("M", "F") & |
|
1054 |
#' grepl("^(A|B)", ARM))) |
|
1055 |
#' lyt2 <- basic_table(show_colcounts = TRUE) %>% |
|
1056 |
#' split_cols_by("ARM", split_fun = add_combo_levels(combodf[1, ])) %>% |
|
1057 |
#' split_cols_by("SEX", |
|
1058 |
#' split_fun = add_overall_level("SEX_ALL", "All Genders") |
|
1059 |
#' ) %>% |
|
1060 |
#' analyze("AGE") |
|
1061 |
#' |
|
1062 |
#' lyt3 <- basic_table(show_colcounts = TRUE) %>% |
|
1063 |
#' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>% |
|
1064 |
#' split_rows_by("SEX", |
|
1065 |
#' split_fun = add_overall_level("SEX_ALL", "All Genders") |
|
1066 |
#' ) %>% |
|
1067 |
#' summarize_row_groups() %>% |
|
1068 |
#' analyze("AGE") |
|
1069 |
#' |
|
1070 |
#' tbl3 <- build_table(lyt3, smallerDM) |
|
1071 |
#' tbl3 |
|
1072 |
#' |
|
1073 |
#' @export |
|
1074 |
add_combo_levels <- function(combosdf, |
|
1075 |
trim = FALSE, |
|
1076 |
first = FALSE, |
|
1077 |
keep_levels = NULL) { |
|
1078 | 10x |
myfun <- function(df, spl, vals = NULL, labels = NULL, ...) { |
1079 | 12x |
if (is(spl, "MultiVarSplit")) { |
1080 | ! |
stop("Combining levels of a MultiVarSplit does not make sense.", |
1081 | ! |
call. = FALSE |
1082 |
) |
|
1083 | 10x |
} # nocov |
1084 | 12x |
ret <- .apply_split_inner(spl, df, |
1085 | 12x |
vals = vals, |
1086 | 12x |
labels = labels, trim = trim |
1087 |
) |
|
1088 | 12x |
for (i in seq_len(nrow(combosdf))) { |
1089 | 18x |
lcombo <- combosdf[i, "levelcombo", drop = TRUE][[1]] |
1090 | 18x |
spld <- spl_payload(spl) |
1091 | 18x |
if (is(lcombo, "AllLevelsSentinel")) { |
1092 | 6x |
subdf <- df |
1093 | 12x |
} else if (is(spl, "VarLevelSplit")) { |
1094 | 12x |
subdf <- df[df[[spld]] %in% lcombo, ] |
1095 | 10x |
} else { ## this covers non-var splits, e.g. Cut-based splits |
1096 | ! |
stopifnot(all(lcombo %in% c(ret$labels, ret$vals))) |
1097 | ! |
subdf <- do.call( |
1098 | ! |
rbind, |
1099 | ! |
ret$datasplit[names(ret$datasplit) %in% lcombo | ret$vals %in% lcombo] |
1100 |
) |
|
1101 |
} |
|
1102 | 18x |
ret <- .add_combo_part_info( |
1103 | 18x |
ret, subdf, |
1104 | 18x |
combosdf[i, "valname", drop = TRUE], |
1105 | 18x |
lcombo, |
1106 | 18x |
combosdf[i, "label", drop = TRUE], |
1107 | 18x |
combosdf[i, "exargs", drop = TRUE][[1]], |
1108 | 18x |
first |
1109 |
) |
|
1110 |
} |
|
1111 | 12x |
if (!is.null(keep_levels)) { |
1112 | 3x |
keep_inds <- value_names(ret$values) %in% keep_levels |
1113 | 3x |
ret <- lapply(ret, function(x) x[keep_inds]) |
1114 |
} |
|
1115 | ||
1116 | 12x |
ret |
1117 |
} |
|
1118 | 10x |
myfun |
1119 |
} |
|
1120 | ||
1121 |
#' Trim levels to map |
|
1122 |
#' |
|
1123 |
#' This split function constructor creates a split function which trims levels of a variable to reflect restrictions |
|
1124 |
#' on the possible combinations of two or more variables which the data is split by (along the same axis) within a |
|
1125 |
#' layout. |
|
1126 |
#' |
|
1127 |
#' @param map data.frame. A data.frame defining allowed combinations of |
|
1128 |
#' variables. Any combination at the level of this split not present in the |
|
1129 |
#' map will be removed from the data, both for the variable being split and |
|
1130 |
#' those present in the data but not associated with this split or any parents |
|
1131 |
#' of it. |
|
1132 |
#' |
|
1133 |
#' @details |
|
1134 |
#' When splitting occurs, the map is subset to the values of all previously performed splits. The levels of the |
|
1135 |
#' variable being split are then pruned to only those still present within this subset of the map representing the |
|
1136 |
#' current hierarchical splitting context. |
|
1137 |
#' |
|
1138 |
#' Splitting is then performed via the [keep_split_levels()] split function. |
|
1139 |
#' |
|
1140 |
#' Each resulting element of the partition is then further trimmed by pruning values of any remaining variables |
|
1141 |
#' specified in the map to those values allowed under the combination of the previous and current split. |
|
1142 |
#' |
|
1143 |
#' @return A function that can be used as a split function. |
|
1144 |
#' |
|
1145 |
#' @seealso [trim_levels_in_group()] |
|
1146 |
#' |
|
1147 |
#' @examples |
|
1148 |
#' map <- data.frame( |
|
1149 |
#' LBCAT = c("CHEMISTRY", "CHEMISTRY", "CHEMISTRY", "IMMUNOLOGY"), |
|
1150 |
#' PARAMCD = c("ALT", "CRP", "CRP", "IGA"), |
|
1151 |
#' ANRIND = c("LOW", "LOW", "HIGH", "HIGH"), |
|
1152 |
#' stringsAsFactors = FALSE |
|
1153 |
#' ) |
|
1154 |
#' |
|
1155 |
#' lyt <- basic_table() %>% |
|
1156 |
#' split_rows_by("LBCAT") %>% |
|
1157 |
#' split_rows_by("PARAMCD", split_fun = trim_levels_to_map(map = map)) %>% |
|
1158 |
#' analyze("ANRIND") |
|
1159 |
#' tbl <- build_table(lyt, ex_adlb) |
|
1160 |
#' |
|
1161 |
#' @export |
|
1162 |
trim_levels_to_map <- function(map = NULL) { |
|
1163 | 7x |
if (is.null(map) || any(sapply(map, class) != "character")) { |
1164 | ! |
stop( |
1165 | ! |
"No map dataframe was provided or not all of the columns are of ", |
1166 | ! |
"type character." |
1167 |
) |
|
1168 |
} |
|
1169 | ||
1170 | 7x |
myfun <- function(df, |
1171 | 7x |
spl, |
1172 | 7x |
vals = NULL, |
1173 | 7x |
labels = NULL, |
1174 | 7x |
trim = FALSE, |
1175 | 7x |
.spl_context) { |
1176 | 12x |
allvars <- colnames(map) |
1177 | 12x |
splvar <- spl_payload(spl) |
1178 | ||
1179 | 12x |
allvmatches <- match(.spl_context$split, allvars) |
1180 | 12x |
outvars <- allvars[na.omit(allvmatches)] |
1181 |
## invars are variables present in data, but not in |
|
1182 |
## previous or current splits |
|
1183 | 12x |
invars <- intersect( |
1184 | 12x |
setdiff(allvars, c(outvars, splvar)), |
1185 | 12x |
names(df) |
1186 |
) |
|
1187 |
## allvarord <- c(na.omit(allvmatches), ## appear in prior splits |
|
1188 |
## which(allvars == splvar), ## this split |
|
1189 |
## allvars[-1*na.omit(allvmatches)]) ## "outvars" |
|
1190 | ||
1191 |
## allvars <- allvars[allvarord] |
|
1192 |
## outvars <- allvars[-(which(allvars == splvar):length(allvars))] |
|
1193 | 12x |
if (length(outvars) > 0) { |
1194 | 10x |
indfilters <- vapply(outvars, function(ivar) { |
1195 | 12x |
obsval <- .spl_context$value[match(ivar, .spl_context$split)] |
1196 | 12x |
sprintf("%s == '%s'", ivar, obsval) |
1197 |
}, "") |
|
1198 | ||
1199 | 10x |
allfilters <- paste(indfilters, collapse = " & ") |
1200 | 10x |
map <- map[eval(parse(text = allfilters), envir = map), ] |
1201 |
} |
|
1202 | 12x |
map_splvarpos <- which(names(map) == splvar) |
1203 | 12x |
nondup <- !duplicated(map[[splvar]]) |
1204 | 12x |
ksl_fun <- keep_split_levels( |
1205 | 12x |
only = map[[splvar]][nondup], |
1206 | 12x |
reorder = TRUE |
1207 |
) |
|
1208 | 12x |
ret <- ksl_fun(df, spl, vals, labels, trim = trim) |
1209 | ||
1210 | 12x |
if (length(ret$datasplit) == 0) { |
1211 | 1x |
msg <- paste(sprintf("%s[%s]", .spl_context$split, .spl_context$value), |
1212 | 1x |
collapse = "->" |
1213 |
) |
|
1214 | 1x |
stop( |
1215 | 1x |
"map does not allow any values present in data for split ", |
1216 | 1x |
"variable ", splvar, |
1217 | 1x |
" under the following parent splits:\n\t", msg |
1218 |
) |
|
1219 |
} |
|
1220 | ||
1221 |
## keep non-split (inner) variables levels |
|
1222 | 11x |
ret$datasplit <- lapply(ret$values, function(splvar_lev) { |
1223 | 19x |
df3 <- ret$datasplit[[splvar_lev]] |
1224 | 19x |
curmap <- map[map[[map_splvarpos]] == splvar_lev, ] |
1225 |
## loop through inner variables |
|
1226 | 19x |
for (iv in invars) { ## setdiff(colnames(map), splvar)) { |
1227 | 19x |
iv_lev <- df3[[iv]] |
1228 | 19x |
levkeep <- as.character(unique(curmap[[iv]])) |
1229 | 19x |
if (is.factor(iv_lev) && !all(levkeep %in% levels(iv_lev))) { |
1230 | ! |
stop( |
1231 | ! |
"Attempted to keep invalid factor level(s) in split ", |
1232 | ! |
setdiff(levkeep, levels(iv_lev)) |
1233 |
) |
|
1234 |
} |
|
1235 | ||
1236 | 19x |
df3 <- df3[iv_lev %in% levkeep, , drop = FALSE] |
1237 | ||
1238 | 19x |
if (is.factor(iv_lev)) { |
1239 | 19x |
df3[[iv]] <- factor(as.character(df3[[iv]]), |
1240 | 19x |
levels = levkeep |
1241 |
) |
|
1242 |
} |
|
1243 |
} |
|
1244 | ||
1245 | 19x |
df3 |
1246 |
}) |
|
1247 | 11x |
names(ret$datasplit) <- ret$values |
1248 | 11x |
ret |
1249 |
} |
|
1250 | ||
1251 | 7x |
myfun |
1252 |
} |
1 |
#' Find degenerate (sub)structures within a table |
|
2 |
#' |
|
3 |
#' @description `r lifecycle::badge("experimental")` |
|
4 |
#' |
|
5 |
#' This function returns a list with the row-paths to all structural subtables which contain no data rows (even if |
|
6 |
#' they have associated content rows). |
|
7 |
#' |
|
8 |
#' @param tt (`TableTree`)\cr a `TableTree` object. |
|
9 |
#' |
|
10 |
#' @return A list of character vectors representing the row paths, if any, to degenerate substructures within the table. |
|
11 |
#' |
|
12 |
#' @examples |
|
13 |
#' find_degen_struct(rtable("hi")) |
|
14 |
#' |
|
15 |
#' @family table structure validation functions |
|
16 |
#' @export |
|
17 |
find_degen_struct <- function(tt) { |
|
18 | 7x |
degen <- list() |
19 | ||
20 | 7x |
recurse_check <- function(tti, path) { |
21 | 103x |
if (is(tti, "VTableTree")) { |
22 | 103x |
kids <- tree_children(tti) |
23 | 103x |
if (length(kids) == 0) { |
24 | 69x |
degen <<- c(degen, list(path)) |
25 |
} else { |
|
26 | 34x |
for (i in seq_along(kids)) { |
27 | 96x |
recurse_check(kids[[i]], path = c(path, names(kids)[i])) |
28 |
} |
|
29 |
} |
|
30 |
} |
|
31 |
} |
|
32 | 7x |
recurse_check(tt, obj_name(tt) %||% "root") |
33 | 7x |
degen |
34 |
} |
|
35 | ||
36 |
#' Validate and assert valid table structure |
|
37 |
#' |
|
38 |
#' @description `r lifecycle::badge("experimental")` |
|
39 |
#' |
|
40 |
#' A `TableTree` (`rtables`-built table) is considered degenerate if: |
|
41 |
#' \enumerate{ |
|
42 |
#' \item{It contains no subtables or data rows (content rows do not count).} |
|
43 |
#' \item{It contains a subtable which is degenerate by the criterion above.} |
|
44 |
#' } |
|
45 |
#' |
|
46 |
#' `validate_table_struct` assesses whether `tt` has a valid (non-degenerate) structure. |
|
47 |
#' |
|
48 |
#' `assert_valid_table` asserts a table must have a valid structure, and throws an informative error (the default) or |
|
49 |
#' warning (if `warn_only` is `TRUE`) if the table is degenerate (has invalid structure or contains one or more |
|
50 |
#' invalid substructures. |
|
51 |
#' |
|
52 |
#' @param tt (`TableTree`)\cr a `TableTree` object. |
|
53 |
#' |
|
54 |
#' @return |
|
55 |
#' * `validate_table_struct` returns a logical value indicating valid structure. |
|
56 |
#' * `assert_valid_table` is called for its side-effect of throwing an error or warning for degenerate tables. |
|
57 |
#' |
|
58 |
#' @note This function is experimental and the exact text of the warning/error is subject to change in future releases. |
|
59 |
#' |
|
60 |
#' @examples |
|
61 |
#' validate_table_struct(rtable("hahaha")) |
|
62 |
#' \dontrun{ |
|
63 |
#' assert_valid_table(rtable("oops")) |
|
64 |
#' } |
|
65 |
#' |
|
66 |
#' @family table structure validation functions |
|
67 |
#' @export |
|
68 |
validate_table_struct <- function(tt) { |
|
69 | 1x |
degen_pths <- find_degen_struct(tt) |
70 | 1x |
length(degen_pths) == 0 |
71 |
} |
|
72 | ||
73 |
## XXX this doesn't handle content paths correctly |
|
74 |
.path_to_disp <- function(pth) { |
|
75 | 2x |
if (length(pth) == 1) { |
76 | 1x |
return(pth) |
77 |
} |
|
78 | 1x |
has_cont <- any(pth == "@content") |
79 | 1x |
if (has_cont) { |
80 | ! |
contpos <- which(pth == "@content") |
81 | ! |
cont_disp <- paste(tail(pth, length(pth) - contpos + 1), |
82 | ! |
collapse = "->" |
83 |
) |
|
84 | ! |
pth <- head(pth, contpos) |
85 |
} else { |
|
86 | 1x |
cont_disp <- character() |
87 |
} |
|
88 | ||
89 | 1x |
topaste <- character(0) |
90 | 1x |
fullpth <- pth |
91 | 1x |
while (length(pth) > 0) { |
92 | 2x |
if (length(pth) <= 1) { |
93 | ! |
topaste <- c(topaste, pth) |
94 | ! |
pth <- character() |
95 |
} else { |
|
96 | 2x |
topaste <- c(topaste, sprintf("%s[%s]", pth[1], pth[2])) |
97 | 2x |
pth <- tail(pth, -2) |
98 |
} |
|
99 |
} |
|
100 | 1x |
topaste <- c(topaste, cont_disp) |
101 | 1x |
paste(topaste, collapse = "->") |
102 |
} |
|
103 | ||
104 |
no_analyze_guess <- paste0( |
|
105 |
"Was this table created using ", |
|
106 |
"summarize_row_groups but no calls ", |
|
107 |
"to analyze?\n" |
|
108 |
) |
|
109 | ||
110 |
use_sanitize_msg <- paste(" Use sanitize_table_struct() to fix these issues") |
|
111 | ||
112 |
make_degen_message <- function(degen_pths, tt) { |
|
113 | 2x |
msg <- sprintf( |
114 | 2x |
paste0( |
115 | 2x |
"Invalid table - found %d (sub)structures which contain no data rows.", |
116 | 2x |
"\n\tThe first occured at path: %s" |
117 |
), |
|
118 | 2x |
length(degen_pths), .path_to_disp(degen_pths[[1]]) |
119 |
) |
|
120 | 2x |
if (length(degen_pths) == 1 && length(degen_pths[[1]]) == 1) { |
121 | 1x |
msg <- paste(msg, " Likely Cause: Empty data or first row split on variable with only NA values", |
122 | 1x |
sep = "\n" |
123 |
) |
|
124 | 1x |
} else if (all(make_row_df(tt)$node_class %in% c("LabelRow", "ContentRow"))) { |
125 | 1x |
msg <- paste(msg, " Cause: Layout did not contain any analyze() calls (only summarize_row_groups())", |
126 | 1x |
sep = "\n" |
127 |
) |
|
128 |
} |
|
129 | 2x |
msg <- paste(msg, use_sanitize_msg, sep = "\n") |
130 | 2x |
msg |
131 |
} |
|
132 | ||
133 |
#' @param warn_only (`flag`)\cr whether a warning should be thrown instead of an error. Defaults to `FALSE`. |
|
134 |
#' |
|
135 |
#' @rdname validate_table_struct |
|
136 |
#' @export |
|
137 |
assert_valid_table <- function(tt, warn_only = FALSE) { |
|
138 | 2x |
degen_pths <- find_degen_struct(tt) |
139 | 2x |
if (length(degen_pths) == 0) { |
140 | ! |
return(TRUE) |
141 |
} |
|
142 | ||
143 |
## we failed, now we build an informative error/warning message |
|
144 | 2x |
msg <- make_degen_message(degen_pths, tt) |
145 | ||
146 | 2x |
if (!warn_only) { |
147 | 2x |
stop(msg) |
148 |
} |
|
149 | ! |
warning(msg) |
150 | ! |
return(FALSE) |
151 |
} |
|
152 | ||
153 |
#' Sanitize degenerate table structures |
|
154 |
#' |
|
155 |
#' @description `r lifecycle::badge("experimental")` |
|
156 |
#' |
|
157 |
#' Experimental function to correct structure of degenerate tables by adding messaging rows to empty sub-structures. |
|
158 |
#' |
|
159 |
#' @param tt (`TableTree`)\cr a `TableTree` object. |
|
160 |
#' @param empty_msg (`string`)\cr the string which should be spanned across the inserted empty rows. |
|
161 |
#' |
|
162 |
#' @details |
|
163 |
#' This function locates degenerate portions of the table (including the table overall in the case of a table with no |
|
164 |
#' data rows) and inserts a row which spans all columns with the message `empty_msg` at each one, generating a table |
|
165 |
#' guaranteed to be non-degenerate. |
|
166 |
#' |
|
167 |
#' @return If `tt` is already valid, it is returned unmodified. If `tt` is degenerate, a modified, non-degenerate |
|
168 |
#' version of the table is returned. |
|
169 |
#' |
|
170 |
#' @examples |
|
171 |
#' sanitize_table_struct(rtable("cool beans")) |
|
172 |
#' |
|
173 |
#' lyt <- basic_table() %>% |
|
174 |
#' split_cols_by("ARM") %>% |
|
175 |
#' split_rows_by("SEX") %>% |
|
176 |
#' summarize_row_groups() |
|
177 |
#' |
|
178 |
#' ## Degenerate because it doesn't have any analyze calls -> no data rows |
|
179 |
#' badtab <- build_table(lyt, DM) |
|
180 |
#' sanitize_table_struct(badtab) |
|
181 |
#' |
|
182 |
#' @family table structure validation functions |
|
183 |
#' @export |
|
184 |
sanitize_table_struct <- function(tt, empty_msg = "-- This Section Contains No Data --") { |
|
185 | 4x |
rdf <- make_row_df(tt) |
186 | ||
187 | 4x |
emptyrow <- DataRow( |
188 | 4x |
vals = list(empty_msg), |
189 | 4x |
name = "empty_section", |
190 | 4x |
label = "", |
191 | 4x |
cspan = ncol(tt), |
192 | 4x |
cinfo = col_info(tt), |
193 | 4x |
format = "xx", |
194 | 4x |
table_inset = table_inset(tt) |
195 |
) |
|
196 | 4x |
degen_pths <- find_degen_struct(tt) |
197 | ||
198 | 4x |
if (identical(degen_pths, list("root"))) { |
199 | 2x |
tree_children(tt) <- list(empty_row = emptyrow) |
200 | 2x |
return(tt) |
201 |
} |
|
202 | ||
203 | 2x |
for (pth in degen_pths) { |
204 |
## FIXME this shouldn't be necessary. why is it? |
|
205 | 33x |
tti <- tt_at_path(tt, path = pth) |
206 | 33x |
tree_children(tti) <- list(empty_section = emptyrow) |
207 | 33x |
tt_at_path(tt, path = pth) <- tti |
208 |
} |
|
209 | 2x |
tt |
210 |
} |
1 |
#' @import formatters |
|
2 |
#' @importMethodsFrom formatters toString matrix_form nlines |
|
3 |
NULL |
|
4 | ||
5 |
# toString ---- |
|
6 | ||
7 |
## #' @export |
|
8 |
## setGeneric("toString", function(x,...) standardGeneric("toString")) |
|
9 | ||
10 |
## ## preserve S3 behavior |
|
11 |
## setMethod("toString", "ANY", base::toString) |
|
12 | ||
13 |
## #' @export |
|
14 |
## setMethod("print", "ANY", base::print) |
|
15 | ||
16 |
#' Convert an `rtable` object to a string |
|
17 |
#' |
|
18 |
#' @inheritParams formatters::toString |
|
19 |
#' @inheritParams gen_args |
|
20 |
#' @inherit formatters::toString |
|
21 |
#' |
|
22 |
#' @return A string representation of `x` as it appears when printed. |
|
23 |
#' |
|
24 |
#' @examples |
|
25 |
#' library(dplyr) |
|
26 |
#' |
|
27 |
#' iris2 <- iris %>% |
|
28 |
#' group_by(Species) %>% |
|
29 |
#' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>% |
|
30 |
#' ungroup() |
|
31 |
#' |
|
32 |
#' lyt <- basic_table() %>% |
|
33 |
#' split_cols_by("Species") %>% |
|
34 |
#' split_cols_by("group") %>% |
|
35 |
#' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx") |
|
36 |
#' |
|
37 |
#' tbl <- build_table(lyt, iris2) |
|
38 |
#' |
|
39 |
#' cat(toString(tbl, col_gap = 3)) |
|
40 |
#' |
|
41 |
#' @rdname tostring |
|
42 |
#' @aliases tostring toString,VTableTree-method |
|
43 |
#' @exportMethod toString |
|
44 |
setMethod("toString", "VTableTree", function(x, |
|
45 |
widths = NULL, |
|
46 |
col_gap = 3, |
|
47 |
hsep = horizontal_sep(x), |
|
48 |
indent_size = 2, |
|
49 |
tf_wrap = FALSE, |
|
50 |
max_width = NULL) { |
|
51 | 37x |
toString( |
52 | 37x |
matrix_form(x, |
53 | 37x |
indent_rownames = TRUE, |
54 | 37x |
indent_size = indent_size |
55 |
), |
|
56 | 37x |
widths = widths, col_gap = col_gap, |
57 | 37x |
hsep = hsep, |
58 | 37x |
tf_wrap = tf_wrap, |
59 | 37x |
max_width = max_width |
60 |
) |
|
61 |
}) |
|
62 | ||
63 |
#' Table shells |
|
64 |
#' |
|
65 |
#' A table shell is a rendering of the table which maintains the structure, but does not display the values, rather |
|
66 |
#' displaying the formatting instructions for each cell. |
|
67 |
#' |
|
68 |
#' @inheritParams formatters::toString |
|
69 |
#' @inheritParams gen_args |
|
70 |
#' |
|
71 |
#' @return |
|
72 |
#' * `table_shell` returns `NULL`, as the function is called for the side effect of printing the shell to the console. |
|
73 |
#' * `table_shell_str` returns the string representing the table shell. |
|
74 |
#' |
|
75 |
#' @seealso [value_formats()] for a matrix of formats for each cell in a table. |
|
76 |
#' |
|
77 |
#' @examples |
|
78 |
#' library(dplyr) |
|
79 |
#' |
|
80 |
#' iris2 <- iris %>% |
|
81 |
#' group_by(Species) %>% |
|
82 |
#' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>% |
|
83 |
#' ungroup() |
|
84 |
#' |
|
85 |
#' lyt <- basic_table() %>% |
|
86 |
#' split_cols_by("Species") %>% |
|
87 |
#' split_cols_by("group") %>% |
|
88 |
#' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx") |
|
89 |
#' |
|
90 |
#' tbl <- build_table(lyt, iris2) |
|
91 |
#' table_shell(tbl) |
|
92 |
#' |
|
93 |
#' @export |
|
94 |
table_shell <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(), |
|
95 |
tf_wrap = FALSE, max_width = NULL) { |
|
96 | 2x |
cat(table_shell_str( |
97 | 2x |
tt = tt, widths = widths, col_gap = col_gap, hsep = hsep, |
98 | 2x |
tf_wrap = tf_wrap, max_width = max_width |
99 |
)) |
|
100 |
} |
|
101 | ||
102 |
## XXX consider moving to formatters, its really just a function |
|
103 |
## of the MatrixPrintForm |
|
104 |
#' @rdname table_shell |
|
105 |
#' @export |
|
106 |
table_shell_str <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(), |
|
107 |
tf_wrap = FALSE, max_width = NULL) { |
|
108 | 2x |
matform <- matrix_form(tt, indent_rownames = TRUE) |
109 | 2x |
format_strs <- vapply( |
110 | 2x |
as.vector(matform$formats), |
111 | 2x |
function(x) { |
112 | 18x |
if (inherits(x, "function")) { |
113 | 1x |
"<fnc>" |
114 | 17x |
} else if (inherits(x, "character")) { |
115 | 17x |
x |
116 |
} else { |
|
117 | ! |
stop("Don't know how to make a shell with formats of class: ", class(x)) |
118 |
} |
|
119 |
}, "" |
|
120 |
) |
|
121 | ||
122 | 2x |
format_strs_mat <- matrix(format_strs, ncol = ncol(matform$strings)) |
123 | 2x |
format_strs_mat[, 1] <- matform$strings[, 1] |
124 | 2x |
nlh <- mf_nlheader(matform) |
125 | 2x |
format_strs_mat[seq_len(nlh), ] <- matform$strings[seq_len(nlh), ] |
126 | ||
127 | 2x |
matform$strings <- format_strs_mat |
128 | 2x |
if (is.null(widths)) { |
129 | 2x |
widths <- propose_column_widths(matform) |
130 |
} |
|
131 | 2x |
toString(matform, |
132 | 2x |
widths = widths, col_gap = col_gap, hsep = hsep, |
133 | 2x |
tf_wrap = tf_wrap, max_width = max_width |
134 |
) |
|
135 |
} |
|
136 | ||
137 |
#' Transform an `rtable` to a list of matrices which can be used for outputting |
|
138 |
#' |
|
139 |
#' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML |
|
140 |
#' it is useful to map the `rtable` to an in-between state with the formatted cells in a matrix form. |
|
141 |
#' |
|
142 |
#' @inheritParams gen_args |
|
143 |
#' @param indent_rownames (`flag`)\cr if `TRUE`, the column with the row names in the `strings` matrix of the output |
|
144 |
#' has indented row names (strings pre-fixed). |
|
145 |
#' @param expand_newlines (`flag`)\cr whether the matrix form generated should expand rows whose values contain |
|
146 |
#' newlines into multiple 'physical' rows (as they will appear when rendered into ASCII). Defaults to `TRUE`. |
|
147 |
#' |
|
148 |
#' @details |
|
149 |
#' The strings in the return object are defined as follows: row labels are those determined by `make_row_df` and cell |
|
150 |
#' values are determined using `get_formatted_cells`. (Column labels are calculated using a non-exported internal |
|
151 |
#' function. |
|
152 |
#' |
|
153 |
#' @return A list with the following elements: |
|
154 |
#' \describe{ |
|
155 |
#' \item{`strings`}{The content, as it should be printed, of the top-left material, column headers, row labels, |
|
156 |
#' and cell values of `tt`.} |
|
157 |
#' \item{`spans`}{The column-span information for each print-string in the `strings` matrix.} |
|
158 |
#' \item{`aligns`}{The text alignment for each print-string in the `strings` matrix.} |
|
159 |
#' \item{`display`}{Whether each print-string in the strings matrix should be printed.} |
|
160 |
#' \item{`row_info`}{The `data.frame` generated by `make_row_df`.} |
|
161 |
#' } |
|
162 |
#' |
|
163 |
#' With an additional `nrow_header` attribute indicating the number of pseudo "rows" that the column structure defines. |
|
164 |
#' |
|
165 |
#' @examples |
|
166 |
#' library(dplyr) |
|
167 |
#' |
|
168 |
#' iris2 <- iris %>% |
|
169 |
#' group_by(Species) %>% |
|
170 |
#' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>% |
|
171 |
#' ungroup() |
|
172 |
#' |
|
173 |
#' lyt <- basic_table() %>% |
|
174 |
#' split_cols_by("Species") %>% |
|
175 |
#' split_cols_by("group") %>% |
|
176 |
#' analyze(c("Sepal.Length", "Petal.Width"), |
|
177 |
#' afun = list_wrap_x(summary), format = "xx.xx" |
|
178 |
#' ) |
|
179 |
#' |
|
180 |
#' lyt |
|
181 |
#' |
|
182 |
#' tbl <- build_table(lyt, iris2) |
|
183 |
#' |
|
184 |
#' matrix_form(tbl) |
|
185 |
#' |
|
186 |
#' @export |
|
187 |
setMethod( |
|
188 |
"matrix_form", "VTableTree", |
|
189 |
function(obj, |
|
190 |
indent_rownames = FALSE, |
|
191 |
expand_newlines = TRUE, |
|
192 |
indent_size = 2) { |
|
193 | 298x |
stopifnot(is(obj, "VTableTree")) |
194 | 298x |
header_content <- .tbl_header_mat(obj) # first col are for row.names |
195 | ||
196 | 296x |
sr <- make_row_df(obj) |
197 | ||
198 | 296x |
body_content_strings <- if (NROW(sr) == 0) { |
199 | 5x |
character() |
200 |
} else { |
|
201 | 291x |
cbind(as.character(sr$label), get_formatted_cells(obj)) |
202 |
} |
|
203 | ||
204 | 296x |
formats_strings <- if (NROW(sr) == 0) { |
205 | 5x |
character() |
206 |
} else { |
|
207 | 291x |
cbind("", get_formatted_cells(obj, shell = TRUE)) |
208 |
} |
|
209 | ||
210 | 296x |
tsptmp <- lapply(collect_leaves(obj, TRUE, TRUE), function(rr) { |
211 | 5739x |
sp <- row_cspans(rr) |
212 | 5739x |
rep(sp, times = sp) |
213 |
}) |
|
214 | ||
215 |
## the 1 is for row labels |
|
216 | 296x |
body_spans <- if (nrow(obj) > 0) { |
217 | 291x |
cbind(1L, do.call(rbind, tsptmp)) |
218 |
} else { |
|
219 | 5x |
matrix(1, nrow = 0, ncol = ncol(obj) + 1) |
220 |
} |
|
221 | ||
222 | 296x |
body_aligns <- if (NROW(sr) == 0) { |
223 | 5x |
character() |
224 |
} else { |
|
225 | 291x |
cbind("left", get_cell_aligns(obj)) |
226 |
} |
|
227 | ||
228 | 296x |
body <- rbind(header_content$body, body_content_strings) |
229 | ||
230 | 296x |
hdr_fmt_blank <- matrix("", |
231 | 296x |
nrow = nrow(header_content$body), |
232 | 296x |
ncol = ncol(header_content$body) |
233 |
) |
|
234 | 296x |
if (disp_ccounts(obj)) { |
235 | 42x |
hdr_fmt_blank[nrow(hdr_fmt_blank), ] <- c("", rep(colcount_format(obj), ncol(obj))) |
236 |
} |
|
237 | ||
238 | 296x |
formats <- rbind(hdr_fmt_blank, formats_strings) |
239 | ||
240 | 296x |
spans <- rbind(header_content$span, body_spans) |
241 | 296x |
row.names(spans) <- NULL |
242 | ||
243 | 296x |
aligns <- rbind( |
244 | 296x |
matrix(rep("center", length(header_content$body)), |
245 | 296x |
nrow = nrow(header_content$body) |
246 |
), |
|
247 | 296x |
body_aligns |
248 |
) |
|
249 | ||
250 | 296x |
aligns[, 1] <- "left" # row names and topleft (still needed for topleft) |
251 | ||
252 | 296x |
nr_header <- nrow(header_content$body) |
253 | 296x |
if (indent_rownames) { |
254 | 226x |
body[, 1] <- indent_string(body[, 1], c(rep(0, nr_header), sr$indent), |
255 | 226x |
incr = indent_size |
256 |
) |
|
257 |
# why also formats? |
|
258 | 226x |
formats[, 1] <- indent_string(formats[, 1], c(rep(0, nr_header), sr$indent), |
259 | 226x |
incr = indent_size |
260 |
) |
|
261 | 70x |
} else if (NROW(sr) > 0) { |
262 | 66x |
sr$indent <- rep(0, NROW(sr)) |
263 |
} |
|
264 | ||
265 | 296x |
col_ref_strs <- matrix(vapply(header_content$footnotes, function(x) { |
266 | 2172x |
if (length(x) == 0) { |
267 |
"" |
|
268 |
} else { |
|
269 | 5x |
paste(vapply(x, format_fnote_ref, ""), collapse = " ") |
270 |
} |
|
271 | 296x |
}, ""), ncol = ncol(body)) |
272 | 296x |
body_ref_strs <- get_ref_matrix(obj) |
273 | ||
274 | 296x |
body <- matrix( |
275 | 296x |
paste0( |
276 | 296x |
body, |
277 | 296x |
rbind( |
278 | 296x |
col_ref_strs, |
279 | 296x |
body_ref_strs |
280 |
) |
|
281 |
), |
|
282 | 296x |
nrow = nrow(body), |
283 | 296x |
ncol = ncol(body) |
284 |
) |
|
285 | ||
286 | 296x |
ref_fnotes <- get_formatted_fnotes(obj) # pagination will not count extra lines coming from here |
287 | 296x |
pag_titles <- page_titles(obj) |
288 | ||
289 | 296x |
MatrixPrintForm( |
290 | 296x |
strings = body, |
291 | 296x |
spans = spans, |
292 | 296x |
aligns = aligns, |
293 | 296x |
formats = formats, |
294 |
## display = display, purely a function of spans, handled in constructor now |
|
295 | 296x |
row_info = sr, |
296 |
## line_grouping handled internally now line_grouping = 1:nrow(body), |
|
297 | 296x |
ref_fnotes = ref_fnotes, |
298 | 296x |
nlines_header = nr_header, ## this is fixed internally |
299 | 296x |
nrow_header = nr_header, |
300 | 296x |
expand_newlines = expand_newlines, |
301 | 296x |
has_rowlabs = TRUE, |
302 | 296x |
has_topleft = TRUE, |
303 | 296x |
main_title = main_title(obj), |
304 | 296x |
subtitles = subtitles(obj), |
305 | 296x |
page_titles = pag_titles, |
306 | 296x |
main_footer = main_footer(obj), |
307 | 296x |
prov_footer = prov_footer(obj), |
308 | 296x |
table_inset = table_inset(obj), |
309 | 296x |
header_section_div = header_section_div(obj), |
310 | 296x |
horizontal_sep = horizontal_sep(obj), |
311 | 296x |
indent_size = indent_size |
312 |
) |
|
313 |
} |
|
314 |
) |
|
315 | ||
316 |
.quick_handle_nl <- function(str_v) { |
|
317 | ! |
if (any(grepl("\n", str_v))) { |
318 | ! |
return(unlist(strsplit(str_v, "\n", fixed = TRUE))) |
319 |
} else { |
|
320 | ! |
return(str_v) |
321 |
} |
|
322 |
} |
|
323 | ||
324 |
.resolve_fn_symbol <- function(fn) { |
|
325 | 3242x |
if (!is(fn, "RefFootnote")) { |
326 | ! |
return(NULL) |
327 |
} |
|
328 | 3242x |
ret <- ref_symbol(fn) |
329 | 3242x |
if (is.na(ret)) { |
330 | 3242x |
ret <- as.character(ref_index(fn)) |
331 |
} |
|
332 | 3242x |
ret |
333 |
} |
|
334 | ||
335 |
format_fnote_ref <- function(fn) { |
|
336 | 33663x |
if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) { |
337 | 33122x |
return("") |
338 | 541x |
} else if (is.list(fn) && all(vapply(fn, is.list, TRUE))) { |
339 | ! |
return(vapply(fn, format_fnote_ref, "")) |
340 |
} |
|
341 | 541x |
if (is.list(fn)) { |
342 | 536x |
inds <- unlist(lapply(unlist(fn), .resolve_fn_symbol)) |
343 |
} else { |
|
344 | 5x |
inds <- .resolve_fn_symbol(fn) |
345 |
} |
|
346 | 541x |
if (length(inds) > 0) { |
347 | 541x |
paste0(" {", paste(unique(inds), collapse = ", "), "}") |
348 |
} else { |
|
349 |
"" |
|
350 |
} |
|
351 |
} |
|
352 | ||
353 |
format_fnote_note <- function(fn) { |
|
354 | 2691x |
if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) { |
355 | ! |
return(character()) |
356 |
} |
|
357 | 2691x |
if (is.list(fn)) { |
358 | ! |
return(unlist(lapply(unlist(fn), format_fnote_note))) |
359 |
} |
|
360 | ||
361 | 2691x |
if (is(fn, "RefFootnote")) { |
362 | 2691x |
paste0("{", .resolve_fn_symbol(fn), "} - ", ref_msg(fn)) |
363 |
} else { |
|
364 | ! |
NULL |
365 |
} |
|
366 |
} |
|
367 | ||
368 |
.fn_ind_extractor <- function(strs) { |
|
369 | ! |
res <- suppressWarnings(as.numeric(gsub("\\{([[:digit:]]+)\\}.*", "\\1", strs))) |
370 | ! |
res[res == "NA"] <- NA_character_ |
371 |
## these mixing is allowed now with symbols |
|
372 |
## if(!(sum(is.na(res)) %in% c(0L, length(res)))) |
|
373 |
## stop("Got NAs mixed with non-NAS for extracted footnote indices. This should not happen") |
|
374 | ! |
res |
375 |
} |
|
376 | ||
377 |
get_ref_matrix <- function(tt) { |
|
378 | 296x |
if (ncol(tt) == 0 || nrow(tt) == 0) { |
379 | 5x |
return(matrix("", nrow = nrow(tt), ncol = ncol(tt) + 1L)) |
380 |
} |
|
381 | 291x |
rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE) |
382 | 291x |
lst <- unlist(lapply(rows, cell_footnotes), recursive = FALSE) |
383 | 291x |
cstrs <- unlist(lapply(lst, format_fnote_ref)) |
384 | 291x |
bodymat <- matrix(cstrs, |
385 | 291x |
byrow = TRUE, |
386 | 291x |
nrow = nrow(tt), |
387 | 291x |
ncol = ncol(tt) |
388 |
) |
|
389 | 291x |
cbind(vapply(rows, function(rw) format_fnote_ref(row_footnotes(rw)), ""), bodymat) |
390 |
} |
|
391 | ||
392 |
get_formatted_fnotes <- function(tt) { |
|
393 | 296x |
colresfs <- unlist(make_col_df(tt, visible_only = FALSE)$col_fnotes) |
394 | 296x |
rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE) |
395 | 296x |
lst <- c( |
396 | 296x |
colresfs, |
397 | 296x |
unlist( |
398 | 296x |
lapply(rows, function(r) unlist(c(row_footnotes(r), cell_footnotes(r)), recursive = FALSE)), |
399 | 296x |
recursive = FALSE |
400 |
) |
|
401 |
) |
|
402 | ||
403 | 296x |
inds <- vapply(lst, ref_index, 1L) |
404 | 296x |
ord <- order(inds) |
405 | 296x |
lst <- lst[ord] |
406 | 296x |
syms <- vapply(lst, ref_symbol, "") |
407 | 296x |
keep <- is.na(syms) | !duplicated(syms) |
408 | 296x |
lst <- lst[keep] |
409 | 296x |
unique(vapply(lst, format_fnote_note, "")) |
410 | ||
411 |
## , recursive = FALSE) |
|
412 |
## rlst <- unlist(lapply(rows, row_footnotes)) |
|
413 |
## lst <- |
|
414 |
## syms <- vapply(lst, ref_symbol, "") |
|
415 |
## keep <- is.na(syms) | !duplicated(syms) |
|
416 |
## lst <- lst[keep] |
|
417 |
## inds <- vapply(lst, ref_index, 1L) |
|
418 |
## cellstrs <- unlist(lapply(lst, format_fnote_note)) |
|
419 |
## rstrs <- unlist(lapply(rows, function(rw) format_fnote_note(row_footnotes(rw)))) |
|
420 |
## allstrs <- c(colstrs, rstrs, cellstrs) |
|
421 |
## inds <- .fn_ind_extractor(allstrs) |
|
422 |
## allstrs[order(inds)] |
|
423 |
} |
|
424 | ||
425 |
.do_tbl_h_piece2 <- function(tt) { |
|
426 | 303x |
coldf <- make_col_df(tt, visible_only = FALSE) |
427 | 303x |
remain <- seq_len(nrow(coldf)) |
428 | 303x |
chunks <- list() |
429 | 303x |
cur <- 1 |
430 | ||
431 |
## each iteration of this loop identifies |
|
432 |
## all rows corresponding to one top-level column |
|
433 |
## label and its children, then processes those |
|
434 |
## with .do_header_chunk |
|
435 | 303x |
while (length(remain) > 0) { |
436 | 806x |
rw <- remain[1] |
437 | 806x |
inds <- coldf$leaf_indices[[rw]] |
438 | 806x |
endblock <- which(coldf$abs_pos == max(inds)) |
439 | ||
440 | 806x |
stopifnot(endblock >= rw) |
441 | 806x |
chunks[[cur]] <- .do_header_chunk(coldf[rw:endblock, ]) |
442 | 806x |
remain <- remain[remain > endblock] |
443 | 806x |
cur <- cur + 1 |
444 |
} |
|
445 | 303x |
chunks <- .pad_tops(chunks) |
446 | 303x |
lapply( |
447 | 303x |
seq_len(length(chunks[[1]])), |
448 | 303x |
function(i) { |
449 | 404x |
DataRow(unlist(lapply(chunks, `[[`, i), recursive = FALSE)) |
450 |
} |
|
451 |
) |
|
452 |
} |
|
453 | ||
454 |
.pad_end <- function(lst, padto, ncols) { |
|
455 | 1059x |
curcov <- sum(vapply(lst, cell_cspan, 0L)) |
456 | 1059x |
if (curcov == padto) { |
457 | 1059x |
return(lst) |
458 |
} |
|
459 | ||
460 | ! |
c(lst, list(rcell("", colspan = padto - curcov))) |
461 |
} |
|
462 | ||
463 |
.pad_tops <- function(chunks) { |
|
464 | 303x |
lens <- vapply(chunks, length, 1L) |
465 | 303x |
padto <- max(lens) |
466 | 303x |
needpad <- lens != padto |
467 | 303x |
if (all(!needpad)) { |
468 | 301x |
return(chunks) |
469 |
} |
|
470 | ||
471 | 2x |
chunks[needpad] <- lapply( |
472 | 2x |
chunks[needpad], |
473 | 2x |
function(chk) { |
474 | 4x |
span <- sum(vapply(chk[[length(chk)]], cell_cspan, 1L)) |
475 | 4x |
needed <- padto - length(chk) |
476 | 4x |
c( |
477 | 4x |
replicate(rcell("", colspan = span), |
478 | 4x |
n = needed |
479 |
), |
|
480 | 4x |
chk |
481 |
) |
|
482 |
} |
|
483 |
) |
|
484 | 2x |
chunks |
485 |
} |
|
486 | ||
487 |
.do_header_chunk <- function(coldf) { |
|
488 |
## hard assumption that coldf is a section |
|
489 |
## of a column dataframe summary that was |
|
490 |
## created with visible_only=FALSE |
|
491 | 806x |
nleafcols <- length(coldf$leaf_indices[[1]]) |
492 | ||
493 | 806x |
spldfs <- split(coldf, lengths(coldf$path)) |
494 | 806x |
toret <- lapply( |
495 | 806x |
seq_along(spldfs), |
496 | 806x |
function(i) { |
497 | 1059x |
rws <- spldfs[[i]] |
498 | ||
499 | 1059x |
thisbit <- lapply( |
500 | 1059x |
seq_len(nrow(rws)), |
501 | 1059x |
function(ri) { |
502 | 1318x |
rcell(rws[ri, "label", drop = TRUE], |
503 | 1318x |
colspan = rws$total_span[ri], |
504 | 1318x |
footnotes = rws[ri, "col_fnotes", drop = TRUE][[1]] |
505 |
) |
|
506 |
} |
|
507 |
) |
|
508 | 1059x |
.pad_end(thisbit, nleafcols) |
509 |
} |
|
510 |
) |
|
511 | ||
512 | 806x |
toret |
513 |
} |
|
514 | ||
515 |
.tbl_header_mat <- function(tt) { |
|
516 | 298x |
rows <- .do_tbl_h_piece2(tt) ## (clyt) |
517 | 298x |
cinfo <- col_info(tt) |
518 | ||
519 | 298x |
nc <- ncol(tt) |
520 | 298x |
body <- matrix(rapply(rows, function(x) { |
521 | 399x |
cs <- row_cspans(x) |
522 | ! |
if (is.null(cs)) cs <- rep(1, ncol(x)) |
523 | 399x |
rep(row_values(x), cs) |
524 | 298x |
}), ncol = nc, byrow = TRUE) |
525 | ||
526 | 298x |
span <- matrix(rapply(rows, function(x) { |
527 | 399x |
cs <- row_cspans(x) |
528 | ! |
if (is.null(cs)) cs <- rep(1, ncol(x)) |
529 | 399x |
rep(cs, cs) |
530 | 298x |
}), ncol = nc, byrow = TRUE) |
531 | ||
532 | 298x |
fnote <- do.call( |
533 | 298x |
rbind, |
534 | 298x |
lapply(rows, function(x) { |
535 | 399x |
cell_footnotes(x) |
536 |
}) |
|
537 |
) |
|
538 | ||
539 | 298x |
if (disp_ccounts(cinfo)) { |
540 | 44x |
counts <- col_counts(cinfo) |
541 | 44x |
cformat <- colcount_format(cinfo) |
542 | ||
543 |
# allow 2d column count formats (count (%) only) |
|
544 | 44x |
cfmt_dim <- names(which(sapply(formatters::list_valid_format_labels(), function(x) any(x == cformat)))) |
545 | 44x |
if (cfmt_dim == "2d") { |
546 | 3x |
if (grepl("%", cformat)) { |
547 | 2x |
counts <- lapply(counts, function(x) c(x, 1)) |
548 |
} else { |
|
549 | 1x |
stop( |
550 | 1x |
"This 2d format is not supported for column counts. ", |
551 | 1x |
"Please choose a 1d format or a 2d format that includes a % value." |
552 |
) |
|
553 |
} |
|
554 | 41x |
} else if (cfmt_dim == "3d") { |
555 | 1x |
stop("3d formats are not supported for column counts.") |
556 |
} |
|
557 | ||
558 | 42x |
body <- rbind(body, vapply(counts, format_rcell, |
559 | 42x |
character(1), |
560 | 42x |
format = cformat, |
561 | 42x |
na_str = "" |
562 |
)) |
|
563 | 42x |
span <- rbind(span, rep(1, nc)) |
564 | 42x |
fnote <- rbind(fnote, rep(list(list()), nc)) |
565 |
} |
|
566 | ||
567 | 296x |
tl <- top_left(cinfo) |
568 | 296x |
lentl <- length(tl) |
569 | 296x |
nli <- nrow(body) |
570 | 296x |
if (lentl == 0) { |
571 | 247x |
tl <- rep("", nli) |
572 | 49x |
} else if (lentl > nli) { |
573 | 19x |
tl_tmp <- paste0(tl, collapse = "\n") |
574 | 19x |
tl <- rep("", nli) |
575 | 19x |
tl[length(tl)] <- tl_tmp |
576 | 30x |
} else if (lentl < nli) { |
577 |
# We want topleft alignment that goes to the bottom! |
|
578 | 19x |
tl <- c(rep("", nli - lentl), tl) |
579 |
} |
|
580 | 296x |
list( |
581 | 296x |
body = cbind(tl, body, deparse.level = 0), span = cbind(1, span), |
582 | 296x |
footnotes = cbind(list(list()), fnote) |
583 |
) |
|
584 |
} |
|
585 | ||
586 |
# get formatted cells ---- |
|
587 | ||
588 |
#' Get formatted cells |
|
589 |
#' |
|
590 |
#' @inheritParams gen_args |
|
591 |
#' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the values with formats |
|
592 |
#' applied. Defaults to `FALSE`. |
|
593 |
#' |
|
594 |
#' @return The formatted print-strings for all (body) cells in `obj`. |
|
595 |
#' |
|
596 |
#' @examples |
|
597 |
#' library(dplyr) |
|
598 |
#' |
|
599 |
#' iris2 <- iris %>% |
|
600 |
#' group_by(Species) %>% |
|
601 |
#' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>% |
|
602 |
#' ungroup() |
|
603 |
#' |
|
604 |
#' tbl <- basic_table() %>% |
|
605 |
#' split_cols_by("Species") %>% |
|
606 |
#' split_cols_by("group") %>% |
|
607 |
#' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx") %>% |
|
608 |
#' build_table(iris2) |
|
609 |
#' |
|
610 |
#' get_formatted_cells(tbl) |
|
611 |
#' |
|
612 |
#' @export |
|
613 |
#' @rdname gfc |
|
614 | 35792x |
setGeneric("get_formatted_cells", function(obj, shell = FALSE) standardGeneric("get_formatted_cells")) |
615 | ||
616 |
#' @rdname gfc |
|
617 |
setMethod( |
|
618 |
"get_formatted_cells", "TableTree", |
|
619 |
function(obj, shell = FALSE) { |
|
620 | 2944x |
lr <- get_formatted_cells(tt_labelrow(obj), shell = shell) |
621 | ||
622 | 2944x |
ct <- get_formatted_cells(content_table(obj), shell = shell) |
623 | ||
624 | 2944x |
els <- lapply(tree_children(obj), get_formatted_cells, shell = shell) |
625 | ||
626 |
## TODO fix ncol problem for rrow() |
|
627 | 2944x |
if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) { |
628 | 811x |
ct <- lr[NULL, ] |
629 |
} |
|
630 | ||
631 | 2944x |
do.call(rbind, c(list(lr), list(ct), els)) |
632 |
} |
|
633 |
) |
|
634 | ||
635 |
#' @rdname gfc |
|
636 |
setMethod( |
|
637 |
"get_formatted_cells", "ElementaryTable", |
|
638 |
function(obj, shell = FALSE) { |
|
639 | 5509x |
lr <- get_formatted_cells(tt_labelrow(obj), shell = shell) |
640 | 5509x |
els <- lapply(tree_children(obj), get_formatted_cells, shell = shell) |
641 | 5509x |
do.call(rbind, c(list(lr), els)) |
642 |
} |
|
643 |
) |
|
644 | ||
645 |
#' @rdname gfc |
|
646 |
setMethod( |
|
647 |
"get_formatted_cells", "TableRow", |
|
648 |
function(obj, shell = FALSE) { |
|
649 |
# Parent row format and na_str |
|
650 | 18858x |
pr_row_format <- if (is.null(obj_format(obj))) "xx" else obj_format(obj) |
651 | 18858x |
pr_row_na_str <- obj_na_str(obj) %||% "NA" |
652 | ||
653 | 18858x |
matrix( |
654 | 18858x |
unlist(Map(function(val, spn, shelli) { |
655 | 86746x |
stopifnot(is(spn, "integer")) |
656 | ||
657 | 86746x |
out <- format_rcell(val, |
658 | 86746x |
pr_row_format = pr_row_format, |
659 | 86746x |
pr_row_na_str = pr_row_na_str, |
660 | 86746x |
shell = shelli |
661 |
) |
|
662 | 86746x |
if (!is.function(out) && is.character(out)) { |
663 | 86738x |
out <- paste(out, collapse = ", ") |
664 |
} |
|
665 | ||
666 | 86746x |
rep(list(out), spn) |
667 | 18858x |
}, val = row_cells(obj), spn = row_cspans(obj), shelli = shell)), |
668 | 18858x |
ncol = ncol(obj) |
669 |
) |
|
670 |
} |
|
671 |
) |
|
672 | ||
673 |
#' @rdname gfc |
|
674 |
setMethod( |
|
675 |
"get_formatted_cells", "LabelRow", |
|
676 |
function(obj, shell = FALSE) { |
|
677 | 8481x |
nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol |
678 | 8481x |
vstr <- if (shell) "-" else "" |
679 | 8481x |
if (labelrow_visible(obj)) { |
680 | 2726x |
matrix(rep(vstr, nc), ncol = nc) |
681 |
} else { |
|
682 | 5755x |
matrix(character(0), ncol = nc) |
683 |
} |
|
684 |
} |
|
685 |
) |
|
686 | ||
687 |
#' @rdname gfc |
|
688 | 12830x |
setGeneric("get_cell_aligns", function(obj) standardGeneric("get_cell_aligns")) |
689 | ||
690 |
#' @rdname gfc |
|
691 |
setMethod( |
|
692 |
"get_cell_aligns", "TableTree", |
|
693 |
function(obj) { |
|
694 | 1470x |
lr <- get_cell_aligns(tt_labelrow(obj)) |
695 | ||
696 | 1470x |
ct <- get_cell_aligns(content_table(obj)) |
697 | ||
698 | 1470x |
els <- lapply(tree_children(obj), get_cell_aligns) |
699 | ||
700 |
## TODO fix ncol problem for rrow() |
|
701 | 1470x |
if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) { |
702 | 405x |
ct <- lr[NULL, ] |
703 |
} |
|
704 | ||
705 | 1470x |
do.call(rbind, c(list(lr), list(ct), els)) |
706 |
} |
|
707 |
) |
|
708 | ||
709 |
#' @rdname gfc |
|
710 |
setMethod( |
|
711 |
"get_cell_aligns", "ElementaryTable", |
|
712 |
function(obj) { |
|
713 | 2750x |
lr <- get_cell_aligns(tt_labelrow(obj)) |
714 | 2750x |
els <- lapply(tree_children(obj), get_cell_aligns) |
715 | 2750x |
do.call(rbind, c(list(lr), els)) |
716 |
} |
|
717 |
) |
|
718 | ||
719 |
#' @rdname gfc |
|
720 |
setMethod( |
|
721 |
"get_cell_aligns", "TableRow", |
|
722 |
function(obj) { |
|
723 | 4376x |
als <- vapply(row_cells(obj), cell_align, "") |
724 | 4376x |
spns <- row_cspans(obj) |
725 | ||
726 | 4376x |
matrix(rep(als, times = spns), |
727 | 4376x |
ncol = ncol(obj) |
728 |
) |
|
729 |
} |
|
730 |
) |
|
731 | ||
732 |
#' @rdname gfc |
|
733 |
setMethod( |
|
734 |
"get_cell_aligns", "LabelRow", |
|
735 |
function(obj) { |
|
736 | 4234x |
nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol |
737 | 4234x |
if (labelrow_visible(obj)) { |
738 | 1363x |
matrix(rep("center", nc), ncol = nc) |
739 |
} else { |
|
740 | 2871x |
matrix(character(0), ncol = nc) |
741 |
} |
|
742 |
} |
|
743 |
) |
|
744 | ||
745 |
# utility functions ---- |
|
746 | ||
747 |
#' From a sorted sequence of numbers, remove numbers where diff == 1 |
|
748 |
#' |
|
749 |
#' @examples |
|
750 |
#' remove_consecutive_numbers(x = c(2, 4, 9)) |
|
751 |
#' remove_consecutive_numbers(x = c(2, 4, 5, 9)) |
|
752 |
#' remove_consecutive_numbers(x = c(2, 4, 5, 6, 9)) |
|
753 |
#' remove_consecutive_numbers(x = 4:9) |
|
754 |
#' |
|
755 |
#' @noRd |
|
756 |
remove_consecutive_numbers <- function(x) { |
|
757 |
# actually should be integer |
|
758 | ! |
stopifnot(is.wholenumber(x), is.numeric(x), !is.unsorted(x)) |
759 | ||
760 | ! |
if (length(x) == 0) { |
761 | ! |
return(integer(0)) |
762 |
} |
|
763 | ! |
if (!is.integer(x)) x <- as.integer(x) |
764 | ||
765 | ! |
x[c(TRUE, diff(x) != 1)] |
766 |
} |
|
767 | ||
768 |
#' Insert an empty string |
|
769 |
#' |
|
770 |
#' @examples |
|
771 |
#' empty_string_after(letters[1:5], 2) |
|
772 |
#' empty_string_after(letters[1:5], c(2, 4)) |
|
773 |
#' |
|
774 |
#' @noRd |
|
775 |
empty_string_after <- function(x, indices) { |
|
776 | ! |
if (length(indices) > 0) { |
777 | ! |
offset <- 0 |
778 | ! |
for (i in sort(indices)) { |
779 | ! |
x <- append(x, "", i + offset) |
780 | ! |
offset <- offset + 1 |
781 |
} |
|
782 |
} |
|
783 | ! |
x |
784 |
} |
|
785 | ||
786 |
#' Indent strings |
|
787 |
#' |
|
788 |
#' Used in rtables to indent row names for the ASCII output. |
|
789 |
#' |
|
790 |
#' @param x (`character`)\cr a character vector. |
|
791 |
#' @param indent (`numeric`)\cr a vector of non-negative integers of length `length(x)`. |
|
792 |
#' @param incr (`integer(1)`)\cr a non-negative number of spaces per indent level. |
|
793 |
#' @param including_newline (`flag`)\cr whether newlines should also be indented. |
|
794 |
#' |
|
795 |
#' @return `x`, indented with left-padding with `indent * incr` white-spaces. |
|
796 |
#' |
|
797 |
#' @examples |
|
798 |
#' indent_string("a", 0) |
|
799 |
#' indent_string("a", 1) |
|
800 |
#' indent_string(letters[1:3], 0:2) |
|
801 |
#' indent_string(paste0(letters[1:3], "\n", LETTERS[1:3]), 0:2) |
|
802 |
#' |
|
803 |
#' @export |
|
804 |
indent_string <- function(x, indent = 0, incr = 2, including_newline = TRUE) { |
|
805 | 606x |
if (length(x) > 0) { |
806 | 606x |
indent <- rep_len(indent, length.out = length(x)) |
807 | 606x |
incr <- rep_len(incr, length.out = length(x)) |
808 |
} |
|
809 | ||
810 | 606x |
indent_str <- strrep(" ", (indent > 0) * indent * incr) |
811 | ||
812 | 606x |
if (including_newline) { |
813 | 606x |
x <- unlist(mapply(function(xi, stri) { |
814 | 11120x |
gsub("\n", stri, xi, fixed = TRUE) |
815 | 606x |
}, x, paste0("\n", indent_str))) |
816 |
} |
|
817 | ||
818 | 606x |
paste0(indent_str, x) |
819 |
} |
|
820 | ||
821 |
## .paste_no_na <- function(x, ...) { |
|
822 |
## paste(na.omit(x), ...) |
|
823 |
## } |
|
824 | ||
825 |
## #' Pad a string and align within string |
|
826 |
## #' |
|
827 |
## #' @param x string |
|
828 |
## #' @param n number of character of the output string, if `n < nchar(x)` an error is thrown |
|
829 |
## #' |
|
830 |
## #' @noRd |
|
831 |
## #' |
|
832 |
## #' @examples |
|
833 |
## #' |
|
834 |
## #' padstr("abc", 3) |
|
835 |
## #' padstr("abc", 4) |
|
836 |
## #' padstr("abc", 5) |
|
837 |
## #' padstr("abc", 5, "left") |
|
838 |
## #' padstr("abc", 5, "right") |
|
839 |
## #' |
|
840 |
## #' if(interactive()){ |
|
841 |
## #' padstr("abc", 1) |
|
842 |
## #' } |
|
843 |
## #' |
|
844 |
## padstr <- function(x, n, just = c("center", "left", "right")) { |
|
845 | ||
846 |
## just <- match.arg(just) |
|
847 | ||
848 |
## if (length(x) != 1) stop("length of x needs to be 1 and not", length(x)) |
|
849 |
## if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0") |
|
850 | ||
851 |
## if (is.na(x)) x <- "<NA>" |
|
852 | ||
853 |
## nc <- nchar(x) |
|
854 | ||
855 |
## if (n < nc) stop("\"", x, "\" has more than ", n, " characters") |
|
856 | ||
857 |
## switch( |
|
858 |
## just, |
|
859 |
## center = { |
|
860 |
## pad <- (n - nc)/2 |
|
861 |
## paste0(spaces(floor(pad)), x, spaces(ceiling(pad))) |
|
862 |
## }, |
|
863 |
## left = paste0(x, spaces(n - nc)), |
|
864 |
## right = paste0(spaces(n - nc), x) |
|
865 |
## ) |
|
866 |
## } |
|
867 | ||
868 |
## spaces <- function(n) { |
|
869 |
## strrep(" ", n) |
|
870 |
## } |
|
871 | ||
872 |
#' Convert matrix of strings into a string with aligned columns |
|
873 |
#' |
|
874 |
#' Note that this function is intended to print simple rectangular matrices and not `rtable`s. |
|
875 |
#' |
|
876 |
#' @param mat (`matrix`)\cr a matrix of strings. |
|
877 |
#' @param nheader (`integer(1)`)\cr number of header rows. |
|
878 |
#' @param colsep (`string`)\cr a string that separates the columns. |
|
879 |
#' @param hsep (`character(1)`)\cr character to build line separator. |
|
880 |
#' |
|
881 |
#' @return A string. |
|
882 |
#' |
|
883 |
#' @examples |
|
884 |
#' mat <- matrix(c("A", "B", "C", "a", "b", "c"), nrow = 2, byrow = TRUE) |
|
885 |
#' cat(mat_as_string(mat)) |
|
886 |
#' cat("\n") |
|
887 |
#' |
|
888 |
#' @noRd |
|
889 |
mat_as_string <- function(mat, nheader = 1, colsep = " ", hsep = default_hsep()) { |
|
890 | 2x |
colwidths <- apply(apply(mat, c(1, 2), nchar), 2, max) |
891 | ||
892 | 2x |
rows_formatted <- apply(mat, 1, function(row) { |
893 | 36x |
paste(unlist(mapply(padstr, row, colwidths, "left")), collapse = colsep) |
894 |
}) |
|
895 | ||
896 | 2x |
header_rows <- seq_len(nheader) |
897 | 2x |
nchwidth <- nchar(rows_formatted[1]) |
898 | 2x |
paste(c( |
899 | 2x |
rows_formatted[header_rows], |
900 | 2x |
substr(strrep(hsep, nchwidth), 1, nchwidth), |
901 | 2x |
rows_formatted[-header_rows] |
902 | 2x |
), collapse = "\n") |
903 |
} |
1 |
.reindex_one_pos <- function(refs, cur_idx_fun) { |
|
2 | 2181x |
if (length(refs) == 0) { |
3 | 2067x |
return(refs) |
4 |
} |
|
5 | ||
6 | 114x |
lapply(refs, function(refi) { |
7 |
## these can be symbols, e.g. ^, †now, those are |
|
8 |
## special and don't get reindexed cause they're not numbered |
|
9 |
## to begin with |
|
10 | 119x |
idx <- ref_index(refi) |
11 | 119x |
if (is.na(idx) || !is.na(as.integer(idx))) { |
12 | 119x |
ref_index(refi) <- cur_idx_fun(refi) |
13 |
} |
|
14 | 119x |
refi |
15 |
}) |
|
16 |
} |
|
17 | ||
18 | 72x |
setGeneric(".idx_helper", function(tr, cur_idx_fun) standardGeneric(".idx_helper")) |
19 | ||
20 |
setMethod( |
|
21 |
".idx_helper", "TableRow", |
|
22 |
function(tr, cur_idx_fun) { |
|
23 | 70x |
row_footnotes(tr) <- .reindex_one_pos( |
24 | 70x |
row_footnotes(tr), |
25 | 70x |
cur_idx_fun |
26 |
) |
|
27 | ||
28 | 70x |
cell_footnotes(tr) <- lapply(cell_footnotes(tr), ## crfs, |
29 | 70x |
.reindex_one_pos, |
30 | 70x |
cur_idx_fun = cur_idx_fun |
31 |
) |
|
32 | 70x |
tr |
33 |
} |
|
34 |
) |
|
35 | ||
36 |
setMethod( |
|
37 |
".idx_helper", "VTableTree", |
|
38 |
function(tr, cur_idx_fun) { |
|
39 | 2x |
if (!labelrow_visible(tr)) { |
40 |
stop("got a row footnote on a non-visible label row. this should never happen") # nocov |
|
41 |
} |
|
42 | 2x |
lr <- tt_labelrow(tr) |
43 | ||
44 | 2x |
row_footnotes(lr) <- .reindex_one_pos( |
45 | 2x |
row_footnotes(lr), |
46 | 2x |
cur_idx_fun |
47 |
) |
|
48 | ||
49 | 2x |
tt_labelrow(tr) <- lr |
50 | ||
51 | 2x |
tr |
52 |
} |
|
53 |
) |
|
54 | ||
55 |
index_col_refs <- function(tt, cur_idx_fun) { |
|
56 | 406x |
ctree <- coltree(tt) |
57 | 406x |
ctree <- .index_col_refs_inner(ctree, cur_idx_fun) |
58 | 406x |
coltree(tt) <- ctree |
59 | 406x |
tt |
60 |
} |
|
61 | ||
62 |
.index_col_refs_inner <- function(ctree, cur_idx_fun) { |
|
63 | 1852x |
col_footnotes(ctree) <- .reindex_one_pos( |
64 | 1852x |
col_footnotes(ctree), |
65 | 1852x |
cur_idx_fun |
66 |
) |
|
67 | ||
68 | 1852x |
if (is(ctree, "LayoutColTree")) { |
69 | 691x |
tree_children(ctree) <- lapply(tree_children(ctree), |
70 | 691x |
.index_col_refs_inner, |
71 | 691x |
cur_idx_fun = cur_idx_fun |
72 |
) |
|
73 |
} |
|
74 | 1852x |
ctree |
75 |
## cfs <- col_footnotes(ctree) |
|
76 |
## if(length(unlist(cfs)) > 0) { |
|
77 |
## col_footnotes(ctree) <- .reindex_one_pos(lapply(cfs, |
|
78 |
## function(refs) lapply(refs, function(refi) { |
|
79 |
} |
|
80 | ||
81 |
#' Update footnote indices on a built table |
|
82 |
#' |
|
83 |
#' Re-indexes footnotes within a built table. |
|
84 |
#' |
|
85 |
#' @inheritParams gen_args |
|
86 |
#' |
|
87 |
#' @details |
|
88 |
#' After adding or removing referential footnotes manually, or after subsetting a table, the reference indexes |
|
89 |
#' (i.e. the number associated with specific footnotes) may be incorrect. This function recalculates these based |
|
90 |
#' on the full table. |
|
91 |
#' |
|
92 |
#' @note In the future this should not generally need to be called manually. |
|
93 |
#' |
|
94 |
#' @export |
|
95 |
update_ref_indexing <- function(tt) { |
|
96 | 406x |
col_fnotes <- c(list(row_fnotes = list()), col_footnotes(tt)) |
97 | 406x |
row_fnotes <- row_footnotes(tt) |
98 | 406x |
cell_fnotes <- cell_footnotes(tt) |
99 | 406x |
all_fns <- rbind(col_fnotes, cbind(row_fnotes, cell_fnotes)) |
100 | 406x |
all_fns <- unlist(t(all_fns)) |
101 | 406x |
unique_fnotes <- unique(sapply(all_fns, ref_msg)) |
102 | ||
103 | 406x |
cur_index <- function(ref_fn) { |
104 | 119x |
match(ref_msg(ref_fn), unique_fnotes) |
105 |
} |
|
106 | ||
107 | 406x |
if (ncol(tt) > 0) { |
108 | 406x |
tt <- index_col_refs(tt, cur_index) |
109 |
} ## col_info(tt) <- index_col_refs(col_info(tt), cur_index) |
|
110 |
## TODO when column refs are a thing we will |
|
111 |
## still need to do those here before returning!!! |
|
112 | 406x |
if (nrow(tt) == 0) { |
113 | 16x |
return(tt) |
114 |
} |
|
115 | ||
116 | 390x |
rdf <- make_row_df(tt) |
117 | ||
118 | 390x |
rdf <- rdf[rdf$nreflines > 0, ] |
119 | 390x |
if (nrow(rdf) == 0) { |
120 | 353x |
return(tt) |
121 |
} |
|
122 | ||
123 | 37x |
for (i in seq_len(nrow(rdf))) { |
124 | 72x |
path <- unname(rdf$path[[i]]) |
125 | 72x |
tt_at_path(tt, path) <- |
126 | 72x |
.idx_helper( |
127 | 72x |
tt_at_path(tt, path), |
128 | 72x |
cur_index |
129 |
) |
|
130 |
} |
|
131 | 37x |
tt |
132 |
} |
1 |
#' Score functions for sorting `TableTrees` |
|
2 |
#' |
|
3 |
#' @inheritParams gen_args |
|
4 |
#' |
|
5 |
#' @return A single numeric value indicating score according to the relevant metric for `tt`, to be used when sorting. |
|
6 |
#' |
|
7 |
#' @export |
|
8 |
#' @rdname score_funs |
|
9 |
cont_n_allcols <- function(tt) { |
|
10 | 6x |
ctab <- content_table(tt) |
11 | 6x |
if (NROW(ctab) == 0) { |
12 | 2x |
stop( |
13 | 2x |
"cont_n_allcols score function used at subtable [", |
14 | 2x |
obj_name(tt), "] that has no content table." |
15 |
) |
|
16 |
} |
|
17 | 4x |
sum(sapply( |
18 | 4x |
row_values(tree_children(ctab)[[1]]), |
19 | 4x |
function(cv) cv[1] |
20 |
)) |
|
21 |
} |
|
22 | ||
23 |
#' @param j (`numeric(1)`)\cr index of column used for scoring. |
|
24 |
#' |
|
25 |
#' @seealso For examples and details, please read the documentation for [sort_at_path()] and the |
|
26 |
#' [Sorting and Pruning](https://insightsengineering.github.io/rtables/main/articles/sorting_pruning.html) vignette. |
|
27 |
#' |
|
28 |
#' @export |
|
29 |
#' @rdname score_funs |
|
30 |
cont_n_onecol <- function(j) { |
|
31 | 2x |
function(tt) { |
32 | 6x |
ctab <- content_table(tt) |
33 | 6x |
if (NROW(ctab) == 0) { |
34 | 2x |
stop( |
35 | 2x |
"cont_n_allcols score function used at subtable [", |
36 | 2x |
obj_name(tt), "] that has no content table." |
37 |
) |
|
38 |
} |
|
39 | 4x |
row_values(tree_children(ctab)[[1]])[[j]][1] |
40 |
} |
|
41 |
} |
|
42 | ||
43 |
#' Sorting a table at a specific path |
|
44 |
#' |
|
45 |
#' Main sorting function to order the sub-structure of a `TableTree` at a particular path in the table tree. |
|
46 |
#' |
|
47 |
#' @inheritParams gen_args |
|
48 |
#' @param scorefun (`function`)\cr scoring function. Should accept the type of children directly under the position |
|
49 |
#' at `path` (either `VTableTree`, `VTableRow`, or `VTableNodeInfo`, which covers both) and return a numeric value |
|
50 |
#' to be sorted. |
|
51 |
#' @param decreasing (`flag`)\cr whether the scores generated by `scorefun` should be sorted in decreasing order. If |
|
52 |
#' unset (the default of `NA`), it is set to `TRUE` if the generated scores are numeric and `FALSE` if they are |
|
53 |
#' characters. |
|
54 |
#' @param na.pos (`string`)\cr what should be done with children (sub-trees/rows) with `NA` scores. Defaults to |
|
55 |
#' `"omit"`, which removes them. Other allowed values are `"last"` and `"first"`, which indicate where `NA` scores |
|
56 |
#' should be placed in the order. |
|
57 |
#' @param .prev_path (`character`)\cr internal detail, do not set manually. |
|
58 |
#' |
|
59 |
#' @return A `TableTree` with the same structure as `tt` with the exception that the requested sorting has been done |
|
60 |
#' at `path`. |
|
61 |
#' |
|
62 |
#' @details |
|
63 |
#' `sort_at_path`, given a path, locates the (sub)table(s) described by the path (see below for handling of the `"*"` |
|
64 |
#' wildcard). For each such subtable, it then calls `scorefun` on each direct child of the table, using the resulting |
|
65 |
#' scores to determine their sorted order. `tt` is then modified to reflect each of these one or more sorting |
|
66 |
#' operations. |
|
67 |
#' |
|
68 |
#' In `path`, a leading `"root"` element will be ignored, regardless of whether this matches the object name (and thus |
|
69 |
#' actual root path name) of `tt`. Including `"root"` in paths where it does not match the name of `tt` may mask deeper |
|
70 |
#' misunderstandings of how valid paths within a `TableTree` object correspond to the layout used to originally declare |
|
71 |
#' it, which we encourage users to avoid. |
|
72 |
#' |
|
73 |
#' `path` can include the "wildcard" `"*"` as a step, which translates roughly to *any* node/branching element and means |
|
74 |
#' that each child at that step will be *separately* sorted based on `scorefun` and the remaining `path` entries. This |
|
75 |
#' can occur multiple times in a path. |
|
76 |
#' |
|
77 |
#' A list of valid (non-wildcard) paths can be seen in the `path` column of the `data.frame` created by [make_row_df()] |
|
78 |
#' with the `visible_only` argument set to `FALSE`. It can also be inferred from the summary given by |
|
79 |
#' [table_structure()]. |
|
80 |
#' |
|
81 |
#' Note that sorting needs a deeper understanding of table structure in `rtables`. Please consider reading the related |
|
82 |
#' vignette ([Sorting and Pruning](https://insightsengineering.github.io/rtables/main/articles/sorting_pruning.html)) |
|
83 |
#' and explore table structure with useful functions like [table_structure()] and [row_paths_summary()]. It is also |
|
84 |
#' very important to understand the difference between "content" rows and "data" rows. The first one analyzes and |
|
85 |
#' describes the split variable generally and is generated with [summarize_row_groups()], while the second one is |
|
86 |
#' commonly produced by calling one of the various [analyze()] instances. |
|
87 |
#' |
|
88 |
#' Built-in score functions are [cont_n_allcols()] and [cont_n_onecol()]. They are both working with content rows |
|
89 |
#' (coming from [summarize_row_groups()]) while a custom score function needs to be used on `DataRow`s. Here, some |
|
90 |
#' useful descriptor and accessor functions (coming from related vignette): |
|
91 |
#' - [cell_values()] - Retrieves a named list of a `TableRow` or `TableTree` object's values. |
|
92 |
#' - [obj_name()] - Retrieves the name of an object. Note this can differ from the label that is displayed (if any is) |
|
93 |
#' when printing. |
|
94 |
#' - [obj_label()] - Retrieves the display label of an object. Note this can differ from the name that appears in the |
|
95 |
#' path. |
|
96 |
#' - [content_table()] - Retrieves a `TableTree` object's content table (which contains its summary rows). |
|
97 |
#' - [tree_children()] - Retrieves a `TableTree` object's direct children (either subtables, rows or possibly a mix |
|
98 |
#' thereof, though that should not happen in practice). |
|
99 |
#' |
|
100 |
#' @seealso |
|
101 |
#' * Score functions [cont_n_allcols()] and [cont_n_onecol()]. |
|
102 |
#' * [make_row_df()] and [table_structure()] for pathing information. |
|
103 |
#' * [tt_at_path()] to select a table's (sub)structure at a given path. |
|
104 |
#' |
|
105 |
#' @examples |
|
106 |
#' # Creating a table to sort |
|
107 |
#' |
|
108 |
#' # Function that gives two statistics per table-tree "leaf" |
|
109 |
#' more_analysis_fnc <- function(x) { |
|
110 |
#' in_rows( |
|
111 |
#' "median" = median(x), |
|
112 |
#' "mean" = mean(x), |
|
113 |
#' .formats = "xx.x" |
|
114 |
#' ) |
|
115 |
#' } |
|
116 |
#' |
|
117 |
#' # Main layout of the table |
|
118 |
#' raw_lyt <- basic_table() %>% |
|
119 |
#' split_cols_by("ARM") %>% |
|
120 |
#' split_rows_by( |
|
121 |
#' "RACE", |
|
122 |
#' split_fun = drop_and_remove_levels("WHITE") # dropping WHITE levels |
|
123 |
#' ) %>% |
|
124 |
#' summarize_row_groups() %>% |
|
125 |
#' split_rows_by("STRATA1") %>% |
|
126 |
#' summarize_row_groups() %>% |
|
127 |
#' analyze("AGE", afun = more_analysis_fnc) |
|
128 |
#' |
|
129 |
#' # Creating the table and pruning empty and NAs |
|
130 |
#' tbl <- build_table(raw_lyt, DM) %>% |
|
131 |
#' prune_table() |
|
132 |
#' |
|
133 |
#' # Peek at the table structure to understand how it is built |
|
134 |
#' table_structure(tbl) |
|
135 |
#' |
|
136 |
#' # Sorting only ASIAN sub-table, or, in other words, sorting STRATA elements for |
|
137 |
#' # the ASIAN group/row-split. This uses content_table() accessor function as it |
|
138 |
#' # is a "ContentRow". In this case, we also base our sorting only on the second column. |
|
139 |
#' sort_at_path(tbl, c("ASIAN", "STRATA1"), cont_n_onecol(2)) |
|
140 |
#' |
|
141 |
#' # Custom scoring function that is working on "DataRow"s |
|
142 |
#' scorefun <- function(tt) { |
|
143 |
#' # Here we could use browser() |
|
144 |
#' sum(unlist(row_values(tt))) # Different accessor function |
|
145 |
#' } |
|
146 |
#' # Sorting mean and median for all the AGE leaves! |
|
147 |
#' sort_at_path(tbl, c("RACE", "*", "STRATA1", "*", "AGE"), scorefun) |
|
148 |
#' |
|
149 |
#' @export |
|
150 |
sort_at_path <- function(tt, |
|
151 |
path, |
|
152 |
scorefun, |
|
153 |
decreasing = NA, |
|
154 |
na.pos = c("omit", "last", "first"), |
|
155 |
.prev_path = character()) { |
|
156 | 35x |
if (NROW(tt) == 0) { |
157 | 1x |
return(tt) |
158 |
} |
|
159 | ||
160 |
## XXX hacky fix this!!! |
|
161 |
## tt_at_path removes root even if actual root table isn't named root, we need to match that behavior |
|
162 | 34x |
if (path[1] == "root") { |
163 |
## always remove first root element but only add it to |
|
164 |
## .prev_path (used for error reporting) if it actually matched the name |
|
165 | 1x |
if (obj_name(tt) == "root") { |
166 | 1x |
.prev_path <- c(.prev_path, path[1]) |
167 |
} |
|
168 | 1x |
path <- path[-1] |
169 |
} |
|
170 | 34x |
if (identical(obj_name(tt), path[1])) { |
171 | 1x |
.prev_path <- c(.prev_path, path[1]) |
172 | 1x |
path <- path[-1] |
173 |
} |
|
174 | ||
175 | 34x |
curpath <- path |
176 | 34x |
subtree <- tt |
177 | 34x |
backpath <- c() |
178 | 34x |
count <- 0 |
179 | 34x |
while (length(curpath) > 0) { |
180 | 40x |
curname <- curpath[1] |
181 | 40x |
oldkids <- tree_children(subtree) |
182 |
## we sort each child separately based on the score function |
|
183 |
## and the remaining path |
|
184 | 40x |
if (curname == "*") { |
185 | 7x |
oldnames <- vapply(oldkids, obj_name, "") |
186 | 7x |
newkids <- lapply( |
187 | 7x |
seq_along(oldkids), |
188 | 7x |
function(i) { |
189 | 27x |
sort_at_path(oldkids[[i]], |
190 | 27x |
path = curpath[-1], |
191 | 27x |
scorefun = scorefun, |
192 | 27x |
decreasing = decreasing, |
193 | 27x |
na.pos = na.pos, |
194 |
## its ok to modify the "path" here because its only ever used for |
|
195 |
## informative error reporting. |
|
196 | 27x |
.prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")")) |
197 |
) |
|
198 |
} |
|
199 |
) |
|
200 | 4x |
names(newkids) <- oldnames |
201 | 4x |
newtab <- subtree |
202 | 4x |
tree_children(newtab) <- newkids |
203 | 4x |
if (length(backpath) > 0) { |
204 | 3x |
ret <- recursive_replace(tt, backpath, value = newtab) |
205 |
} else { |
|
206 | 1x |
ret <- newtab |
207 |
} |
|
208 | 4x |
return(ret) |
209 | 33x |
} else if (!(curname %in% names(oldkids))) { |
210 | 1x |
stop( |
211 | 1x |
"Unable to find child(ren) '", |
212 | 1x |
curname, "'\n\t occurred at path: ", |
213 | 1x |
paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "), |
214 | 1x |
"\n Use 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n", |
215 | 1x |
"'table_structure(obj)' to explore valid paths." |
216 |
) |
|
217 |
} |
|
218 | 32x |
subtree <- tree_children(subtree)[[curname]] |
219 | 32x |
backpath <- c(backpath, curpath[1]) |
220 | 32x |
curpath <- curpath[-1] |
221 | 32x |
count <- count + 1 |
222 |
} |
|
223 | 26x |
real_backpath <- path[seq_len(count)] |
224 | ||
225 | 26x |
na.pos <- match.arg(na.pos) |
226 |
## subtree <- tt_at_path(tt, path) |
|
227 | 26x |
kids <- tree_children(subtree) |
228 |
## relax this to allow character "scores" |
|
229 |
## scores <- vapply(kids, scorefun, NA_real_) |
|
230 | 26x |
scores <- lapply(kids, function(x) tryCatch(scorefun(x), error = function(e) e)) |
231 | 26x |
errs <- which(vapply(scores, is, class2 = "error", TRUE)) |
232 | 26x |
if (length(errs) > 0) { |
233 | 2x |
stop("Encountered at least ", length(errs), " error(s) when applying score function.\n", |
234 | 2x |
"First error: ", scores[[errs[1]]]$message, |
235 | 2x |
"\n\toccurred at path: ", |
236 | 2x |
paste(c(.prev_path, real_backpath, names(kids)[errs[1]]), collapse = " -> "), |
237 | 2x |
call. = FALSE |
238 |
) |
|
239 |
} else { |
|
240 | 24x |
scores <- unlist(scores) |
241 |
} |
|
242 | 24x |
if (!is.null(dim(scores)) || length(scores) != length(kids)) { |
243 | ! |
stop( |
244 | ! |
"Score function does not appear to have return exactly one ", |
245 | ! |
"scalar value per child" |
246 |
) |
|
247 |
} |
|
248 | 24x |
if (is.na(decreasing)) { |
249 | 8x |
decreasing <- if (is.character(scores)) FALSE else TRUE |
250 |
} |
|
251 | 24x |
ord <- order(scores, na.last = (na.pos != "first"), decreasing = decreasing) |
252 | 24x |
newkids <- kids[ord] |
253 | 24x |
if (anyNA(scores) && na.pos == "omit") { # we did na last here |
254 | ! |
newkids <- head(newkids, -1 * sum(is.na(scores))) |
255 |
} |
|
256 | ||
257 | 24x |
newtree <- subtree |
258 | 24x |
tree_children(newtree) <- newkids |
259 | 24x |
tt_at_path(tt, path) <- newtree |
260 | 24x |
tt |
261 |
} |
1 |
#' Check if an object is a valid `rtable` |
|
2 |
#' |
|
3 |
#' @param x (`ANY`)\cr an object. |
|
4 |
#' |
|
5 |
#' @return `TRUE` if `x` is a formal `TableTree` object, `FALSE` otherwise. |
|
6 |
#' |
|
7 |
#' @examples |
|
8 |
#' is_rtable(build_table(basic_table(), iris)) |
|
9 |
#' |
|
10 |
#' @export |
|
11 |
is_rtable <- function(x) { |
|
12 | 47x |
is(x, "VTableTree") |
13 |
} |
|
14 | ||
15 |
# nocov start |
|
16 |
## is each object in a collection from a class |
|
17 |
are <- function(object_collection, class2) { |
|
18 |
all(vapply(object_collection, is, logical(1), class2)) |
|
19 |
} |
|
20 | ||
21 |
num_all_equal <- function(x, tol = .Machine$double.eps^0.5) { |
|
22 |
stopifnot(is.numeric(x)) |
|
23 | ||
24 |
if (length(x) == 1) { |
|
25 |
return(TRUE) |
|
26 |
} |
|
27 | ||
28 |
y <- range(x) / mean(x) |
|
29 |
isTRUE(all.equal(y[1], y[2], tolerance = tol)) |
|
30 |
} |
|
31 | ||
32 |
# copied over from utils.nest which is not open-source |
|
33 |
all_true <- function(lst, fcn, ...) { |
|
34 |
all(vapply(lst, fcn, logical(1), ...)) |
|
35 |
} |
|
36 | ||
37 |
is_logical_single <- function(x) { |
|
38 |
!is.null(x) && |
|
39 |
is.logical(x) && |
|
40 |
length(x) == 1 && |
|
41 |
!is.na(x) |
|
42 |
} |
|
43 | ||
44 |
is_logical_vector_modif <- function(x, min_length = 1) { |
|
45 |
!is.null(x) && |
|
46 |
is.logical(x) && |
|
47 |
is.atomic(x) && |
|
48 |
!anyNA(x) && |
|
49 |
ifelse(min_length > 0, length(x) >= min_length, TRUE) |
|
50 |
} |
|
51 |
# nocov end |
|
52 | ||
53 |
# Shorthand for functions that take df as first parameter |
|
54 |
.takes_df <- function(f) { |
|
55 | 1589x |
func_takes(f, "df", is_first = TRUE) |
56 |
} |
|
57 | ||
58 |
# Checking if function takes parameters |
|
59 |
func_takes <- function(func, params, is_first = FALSE) { |
|
60 | 10785x |
if (is.list(func)) { |
61 | 2246x |
return(lapply(func, func_takes, params = params, is_first = is_first)) |
62 |
} |
|
63 | 8539x |
if (is.null(func) || !is(func, "function")) { |
64 |
# safe-net: should this fail instead? |
|
65 | 1742x |
return(setNames(rep(FALSE, length(params)), params)) |
66 |
} |
|
67 | 6797x |
f_params <- formals(func) |
68 | 6797x |
if (!is_first) { |
69 | 2240x |
return(setNames(params %in% names(f_params), params)) |
70 |
} else { |
|
71 | 4557x |
if (length(params) > 1L) { |
72 | 1x |
stop("is_first works only with one parameters.") |
73 |
} |
|
74 | 4556x |
return(!is.null(f_params) && names(f_params)[1] == params) |
75 |
} |
|
76 |
} |
|
77 | ||
78 |
#' Translate spl_context to a path to display in error messages |
|
79 |
#' |
|
80 |
#' @param ctx (`data.frame`)\cr the `spl_context` data frame where the error occurred. |
|
81 |
#' |
|
82 |
#' @return A character string containing a description of the row path corresponding to `ctx`. |
|
83 |
#' |
|
84 |
#' @export |
|
85 |
spl_context_to_disp_path <- function(ctx) { |
|
86 |
## this can happen in the first split in column space, but |
|
87 |
## should never happen in row space |
|
88 | 14x |
if (length(ctx$split) == 0) { |
89 | 3x |
return("root") |
90 |
} |
|
91 | 11x |
if (ctx$split[1] == "root" && ctx$value[1] == "root") { |
92 | 10x |
ctx <- ctx[-1, ] |
93 |
} |
|
94 | 11x |
ret <- paste(sprintf("%s[%s]", ctx[["split"]], ctx[["value"]]), |
95 | 11x |
collapse = "->" |
96 |
) |
|
97 | 11x |
if (length(ret) == 0 || nchar(ret) == 0) { |
98 | 4x |
ret <- "root" |
99 |
} |
|
100 | 11x |
ret |
101 |
} |
|
102 | ||
103 |
# Utility function to paste vector of values in a nice way |
|
104 |
paste_vec <- function(vec) { |
|
105 | 7x |
paste0('c("', paste(vec, collapse = '", "'), '")') |
106 |
} |
|
107 | ||
108 |
# Utility for checking if a package is installed |
|
109 |
check_required_packages <- function(pkgs) { |
|
110 | 28x |
for (pkgi in pkgs) { |
111 | 32x |
if (!requireNamespace(pkgi, quietly = TRUE)) { |
112 | 1x |
stop( |
113 | 1x |
"This function requires the ", pkgi, " package. ", |
114 | 1x |
"Please install it if you wish to use it" |
115 |
) |
|
116 |
} |
|
117 |
} |
|
118 |
} |
1 |
#' Default tabulation |
|
2 |
#' |
|
3 |
#' This function is used when [analyze()] is invoked. |
|
4 |
#' |
|
5 |
#' @param x (`vector`)\cr the *already split* data being tabulated for a particular cell/set of cells. |
|
6 |
#' @param ... additional parameters to pass on. |
|
7 |
#' |
|
8 |
#' @details This function has the following behavior given particular types of inputs: |
|
9 |
#' \describe{ |
|
10 |
#' \item{numeric}{calls [mean()] on `x`.} |
|
11 |
#' \item{logical}{calls [sum()] on `x`.} |
|
12 |
#' \item{factor}{calls [length()] on `x`.} |
|
13 |
#' } |
|
14 |
#' |
|
15 |
#' The [in_rows()] function is called on the resulting value(s). All other classes of input currently lead to an error. |
|
16 |
#' |
|
17 |
#' @inherit in_rows return |
|
18 |
#' |
|
19 |
#' @author Gabriel Becker and Adrian Waddell |
|
20 |
#' |
|
21 |
#' @examples |
|
22 |
#' simple_analysis(1:3) |
|
23 |
#' simple_analysis(iris$Species) |
|
24 |
#' simple_analysis(iris$Species == "setosa") |
|
25 |
#' |
|
26 |
#' @rdname rtinner |
|
27 |
#' @export |
|
28 | 1250x |
setGeneric("simple_analysis", function(x, ...) standardGeneric("simple_analysis")) |
29 | ||
30 |
#' @rdname rtinner |
|
31 |
#' @exportMethod simple_analysis |
|
32 |
setMethod( |
|
33 |
"simple_analysis", "numeric", |
|
34 | 916x |
function(x, ...) in_rows("Mean" = rcell(mean(x, ...), format = "xx.xx")) |
35 |
) |
|
36 | ||
37 |
#' @rdname rtinner |
|
38 |
#' @exportMethod simple_analysis |
|
39 |
setMethod( |
|
40 |
"simple_analysis", "logical", |
|
41 | 4x |
function(x, ...) in_rows("Count" = rcell(sum(x, ...), format = "xx")) |
42 |
) |
|
43 | ||
44 |
#' @rdname rtinner |
|
45 |
#' @exportMethod simple_analysis |
|
46 |
setMethod( |
|
47 |
"simple_analysis", "factor", |
|
48 | 330x |
function(x, ...) in_rows(.list = as.list(table(x))) |
49 |
) |
|
50 | ||
51 |
#' @rdname rtinner |
|
52 |
#' @exportMethod simple_analysis |
|
53 |
setMethod( |
|
54 |
"simple_analysis", "ANY", |
|
55 |
function(x, ...) { |
|
56 | ! |
stop("No default simple_analysis behavior for class ", class(x), " please specify FUN explicitly.") |
57 |
} |
|
58 |
) |
1 |
insert_brs <- function(vec) { |
|
2 | 875x |
if (length(vec) == 1) { |
3 | 875x |
ret <- list(vec) |
4 |
} else { |
|
5 | ! |
nout <- length(vec) * 2 - 1 |
6 | ! |
ret <- vector("list", nout) |
7 | ! |
for (i in seq_along(vec)) { |
8 | ! |
ret[[2 * i - 1]] <- vec[i] |
9 | ! |
if (2 * i < nout) { |
10 | ! |
ret[[2 * i]] <- tags$br() |
11 |
} |
|
12 |
} |
|
13 |
} |
|
14 | 875x |
ret |
15 |
} |
|
16 | ||
17 |
div_helper <- function(lst, class) { |
|
18 | 48x |
do.call(tags$div, c(list(class = paste(class, "rtables-container"), lst))) |
19 |
} |
|
20 | ||
21 |
#' Convert an `rtable` object to a `shiny.tag` HTML object |
|
22 |
#' |
|
23 |
#' The returned HTML object can be immediately used in `shiny` and `rmarkdown`. |
|
24 |
#' |
|
25 |
#' @param x (`VTableTree`)\cr a `TableTree` object. |
|
26 |
#' @param class_table (`character`)\cr class for `table` tag. |
|
27 |
#' @param class_tr (`character`)\cr class for `tr` tag. |
|
28 |
#' @param class_th (`character`)\cr class for `th` tag. |
|
29 |
#' @param width (`character`)\cr a string to indicate the desired width of the table. Common input formats include a |
|
30 |
#' percentage of the viewer window width (e.g. `"100%"`) or a distance value (e.g. `"300px"`). Defaults to `NULL`. |
|
31 |
#' @param link_label (`character`)\cr link anchor label (not including `tab:` prefix) for the table. |
|
32 |
#' @param bold (`character`)\cr elements in table output that should be bold. Options are `"main_title"`, |
|
33 |
#' `"subtitles"`, `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label |
|
34 |
#' rows). Defaults to `"header"`. |
|
35 |
#' @param header_sep_line (`flag`)\cr whether a black line should be printed to under the table header. Defaults |
|
36 |
#' to `TRUE`. |
|
37 |
#' @param no_spaces_between_cells (`flag`)\cr whether spaces between table cells should be collapsed. Defaults |
|
38 |
#' to `FALSE`. |
|
39 |
#' |
|
40 |
#' @importFrom htmltools tags |
|
41 |
#' |
|
42 |
#' @return A `shiny.tag` object representing `x` in HTML. |
|
43 |
#' |
|
44 |
#' @examples |
|
45 |
#' tbl <- rtable( |
|
46 |
#' header = LETTERS[1:3], |
|
47 |
#' format = "xx", |
|
48 |
#' rrow("r1", 1, 2, 3), |
|
49 |
#' rrow("r2", 4, 3, 2, indent = 1), |
|
50 |
#' rrow("r3", indent = 2) |
|
51 |
#' ) |
|
52 |
#' |
|
53 |
#' as_html(tbl) |
|
54 |
#' |
|
55 |
#' as_html(tbl, class_table = "table", class_tr = "row") |
|
56 |
#' |
|
57 |
#' as_html(tbl, bold = c("header", "row_names")) |
|
58 |
#' |
|
59 |
#' \dontrun{ |
|
60 |
#' Viewer(tbl) |
|
61 |
#' } |
|
62 |
#' |
|
63 |
#' @export |
|
64 |
as_html <- function(x, |
|
65 |
width = NULL, |
|
66 |
class_table = "table table-condensed table-hover", |
|
67 |
class_tr = NULL, |
|
68 |
class_th = NULL, |
|
69 |
link_label = NULL, |
|
70 |
bold = c("header"), |
|
71 |
header_sep_line = TRUE, |
|
72 |
no_spaces_between_cells = FALSE) { |
|
73 | 6x |
if (is.null(x)) { |
74 | ! |
return(tags$p("Empty Table")) |
75 |
} |
|
76 | ||
77 | 6x |
stopifnot(is(x, "VTableTree")) |
78 | ||
79 | 6x |
mat <- matrix_form(x, indent_rownames = TRUE) |
80 | ||
81 | 6x |
nlh <- mf_nlheader(mat) |
82 | 6x |
nc <- ncol(x) + 1 |
83 | ||
84 |
# Structure is a list of lists with rows (one for each line grouping) and cols as dimensions |
|
85 | 6x |
cells <- matrix(rep(list(list()), (nlh + nrow(x)) * (nc)), ncol = nc) |
86 | ||
87 | 6x |
for (i in seq_len(nrow(mat$strings))) { |
88 | 137x |
for (j in seq_len(ncol(mat$strings))) { |
89 | 875x |
curstrs <- mat$strings[i, j] |
90 | 875x |
curspn <- mat$spans[i, j] |
91 | 875x |
algn <- mat$aligns[i, j] |
92 | ||
93 | 875x |
inhdr <- i <= nlh |
94 | 875x |
tagfun <- if (inhdr) tags$th else tags$td |
95 | 875x |
cells[i, j][[1]] <- tagfun( |
96 | 875x |
class = if (inhdr) class_th else class_tr, |
97 | 875x |
style = paste0("text-align: ", algn, ";"), |
98 | 875x |
style = if (inhdr && !"header" %in% bold) "font-weight: normal;", |
99 | 875x |
style = if (i == nlh && header_sep_line) "border-bottom: 1px solid black;", |
100 | 875x |
colspan = if (curspn != 1) curspn, |
101 | 875x |
insert_brs(curstrs) |
102 |
) |
|
103 |
} |
|
104 |
} |
|
105 | ||
106 | 6x |
if (header_sep_line) { |
107 | 6x |
cells[nlh][[1]] <- htmltools::tagAppendAttributes( |
108 | 6x |
cells[nlh, 1][[1]], |
109 | 6x |
style = "border-bottom: 1px solid black;" |
110 |
) |
|
111 |
} |
|
112 | ||
113 |
# row labels style |
|
114 | 6x |
for (i in seq_len(nrow(x))) { |
115 | 127x |
indent <- mat$row_info$indent[i] |
116 | 127x |
if (indent > 0) { # indentation |
117 | 108x |
cells[i + nlh, 1][[1]] <- htmltools::tagAppendAttributes(cells[i + nlh, 1][[1]], |
118 | 108x |
style = paste0("padding-left: ", indent * 3, "ch;") |
119 |
) |
|
120 |
} |
|
121 | 127x |
if ("row_names" %in% bold) { # font weight |
122 | 3x |
cells[i + nlh, 1][[1]] <- htmltools::tagAppendAttributes( |
123 | 3x |
cells[i + nlh, 1][[1]], |
124 | 3x |
style = paste0("font-weight: bold;") |
125 |
) |
|
126 |
} |
|
127 |
} |
|
128 | ||
129 |
# label rows style |
|
130 | 6x |
if ("label_rows" %in% bold) { |
131 | ! |
which_lbl_rows <- which(mat$row_info$node_class == "LabelRow") |
132 | ! |
cells[which_lbl_rows + nlh, ] <- lapply( |
133 | ! |
cells[which_lbl_rows + nlh, ], |
134 | ! |
htmltools::tagAppendAttributes, |
135 | ! |
style = "font-weight: bold;" |
136 |
) |
|
137 |
} |
|
138 | ||
139 |
# content rows style |
|
140 | 6x |
if ("content_rows" %in% bold) { |
141 | ! |
which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow")) |
142 | ! |
cells[which_cntnt_rows + nlh, ] <- lapply( |
143 | ! |
cells[which_cntnt_rows + nlh, ], |
144 | ! |
htmltools::tagAppendAttributes, |
145 | ! |
style = "font-weight: bold;" |
146 |
) |
|
147 |
} |
|
148 | ||
149 | 6x |
if (any(!mat$display)) { |
150 |
# Check that expansion kept the same display info |
|
151 | 2x |
check_expansion <- c() |
152 | 2x |
for (ii in unique(mat$line_grouping)) { |
153 | 121x |
rows <- which(mat$line_grouping == ii) |
154 | 121x |
check_expansion <- c( |
155 | 121x |
check_expansion, |
156 | 121x |
apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x)) |
157 |
) |
|
158 |
} |
|
159 | ||
160 | 2x |
if (!all(check_expansion)) { |
161 | ! |
stop( |
162 | ! |
"Found that a group of rows have different display options even if ", |
163 | ! |
"they belong to the same line group. This should not happen. Please ", |
164 | ! |
"file an issue or report to the maintainers." |
165 | ! |
) # nocov |
166 |
} |
|
167 | ||
168 | 2x |
for (ii in unique(mat$line_grouping)) { |
169 | 121x |
rows <- which(mat$line_grouping == ii) |
170 | 121x |
should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any) |
171 | 121x |
cells[ii, !should_display_col] <- NA_integer_ |
172 |
} |
|
173 |
} |
|
174 | ||
175 | 6x |
rows <- apply(cells, 1, function(row) { |
176 | 137x |
tags$tr( |
177 | 137x |
class = class_tr, |
178 | 137x |
style = "white-space: pre;", |
179 | 137x |
Filter(function(x) !identical(x, NA_integer_), row) |
180 |
) |
|
181 |
}) |
|
182 | ||
183 | 6x |
hsep_line <- tags$hr(class = "solid") |
184 | ||
185 | 6x |
hdrtag <- div_helper( |
186 | 6x |
class = "rtables-titles-block", |
187 | 6x |
list( |
188 | 6x |
div_helper( |
189 | 6x |
class = "rtables-main-titles-block", |
190 | 6x |
lapply(main_title(x), if ("main_title" %in% bold) tags$b else tags$p, |
191 | 6x |
class = "rtables-main-title" |
192 |
) |
|
193 |
), |
|
194 | 6x |
div_helper( |
195 | 6x |
class = "rtables-subtitles-block", |
196 | 6x |
lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p, |
197 | 6x |
class = "rtables-subtitle" |
198 |
) |
|
199 |
) |
|
200 |
) |
|
201 |
) |
|
202 | ||
203 | 6x |
tabletag <- do.call( |
204 | 6x |
tags$table, |
205 | 6x |
c( |
206 | 6x |
rows, |
207 | 6x |
list( |
208 | 6x |
class = class_table, |
209 | 6x |
style = paste( |
210 | 6x |
if (no_spaces_between_cells) "border-collapse: collapse;", |
211 | 6x |
if (!is.null(width)) paste("width:", width) |
212 |
), |
|
213 | 6x |
tags$caption(sprintf("(\\#tag:%s)", link_label), |
214 | 6x |
style = "caption-side: top;", |
215 | 6x |
.noWS = "after-begin" |
216 |
) |
|
217 |
) |
|
218 |
) |
|
219 |
) |
|
220 | ||
221 | 6x |
rfnotes <- div_helper( |
222 | 6x |
class = "rtables-ref-footnotes-block", |
223 | 6x |
lapply(mat$ref_footnotes, tags$p, |
224 | 6x |
class = "rtables-referential-footnote" |
225 |
) |
|
226 |
) |
|
227 | ||
228 | 6x |
mftr <- div_helper( |
229 | 6x |
class = "rtables-main-footers-block", |
230 | 6x |
lapply(main_footer(x), tags$p, |
231 | 6x |
class = "rtables-main-footer" |
232 |
) |
|
233 |
) |
|
234 | ||
235 | 6x |
pftr <- div_helper( |
236 | 6x |
class = "rtables-prov-footers-block", |
237 | 6x |
lapply(prov_footer(x), tags$p, |
238 | 6x |
class = "rtables-prov-footer" |
239 |
) |
|
240 |
) |
|
241 | ||
242 |
## XXX this omits the divs entirely if they are empty. Do we want that or do |
|
243 |
## we want them to be there but empty?? |
|
244 | 6x |
ftrlst <- list( |
245 | 6x |
if (length(mat$ref_footnotes) > 0) rfnotes, |
246 | 6x |
if (length(mat$ref_footnotes) > 0) hsep_line, |
247 | 6x |
if (length(main_footer(x)) > 0) mftr, |
248 | 6x |
if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), # line break |
249 | 6x |
if (length(prov_footer(x)) > 0) pftr |
250 |
) |
|
251 | ||
252 | ! |
if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst) |
253 | 6x |
ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)] |
254 | ||
255 | 6x |
ftrtag <- div_helper( |
256 | 6x |
class = "rtables-footers-block", |
257 | 6x |
ftrlst |
258 |
) |
|
259 | ||
260 | 6x |
div_helper( |
261 | 6x |
class = "rtables-all-parts-block", |
262 | 6x |
list( |
263 | 6x |
hdrtag, |
264 | 6x |
tabletag, |
265 | 6x |
ftrtag |
266 |
) |
|
267 |
) |
|
268 |
} |
1 |
#' Variable associated with a split |
|
2 |
#' |
|
3 |
#' This function is intended for use when writing custom splitting logic. In cases where the split is associated with |
|
4 |
#' a single variable, the name of that variable will be returned. At time of writing this includes splits generated |
|
5 |
#' via the [split_rows_by()], [split_cols_by()], [split_rows_by_cuts()], [split_cols_by_cuts()], |
|
6 |
#' [split_rows_by_cutfun()], and [split_cols_by_cutfun()] layout directives. |
|
7 |
#' |
|
8 |
#' @param spl (`VarLevelSplit`)\cr the split object. |
|
9 |
#' |
|
10 |
#' @return For splits with a single variable associated with them, returns the split. Otherwise, an error is raised. |
|
11 |
#' |
|
12 |
#' @export |
|
13 |
#' @seealso \code{\link{make_split_fun}} |
|
14 | 2x |
setGeneric("spl_variable", function(spl) standardGeneric("spl_variable")) |
15 | ||
16 |
#' @rdname spl_variable |
|
17 |
#' @export |
|
18 | 1x |
setMethod("spl_variable", "VarLevelSplit", function(spl) spl_payload(spl)) |
19 | ||
20 |
#' @rdname spl_variable |
|
21 |
#' @export |
|
22 | ! |
setMethod("spl_variable", "VarDynCutSplit", function(spl) spl_payload(spl)) |
23 | ||
24 |
#' @rdname spl_variable |
|
25 |
#' @export |
|
26 | ! |
setMethod("spl_variable", "VarStaticCutSplit", function(spl) spl_payload(spl)) |
27 | ||
28 |
#' @rdname spl_variable |
|
29 |
#' @export |
|
30 |
setMethod( |
|
31 |
"spl_variable", "Split", |
|
32 | 1x |
function(spl) stop("Split class ", class(spl), " not associated with a single variable.") |
33 |
) |
|
34 | ||
35 |
in_col_split <- function(spl_ctx) { |
|
36 | 2x |
identical( |
37 | 2x |
names(spl_ctx), |
38 | 2x |
names(context_df_row(cinfo = NULL)) |
39 |
) |
|
40 |
} |
|
41 | ||
42 |
assert_splres_element <- function(pinfo, nm, len = NULL, component = NULL) { |
|
43 | 30x |
msg_2_append <- "" |
44 | 30x |
if (!is.null(component)) { |
45 | 24x |
msg_2_append <- paste0( |
46 | 24x |
"Invalid split function constructed by upstream call to ", |
47 | 24x |
"make_split_fun. Problem source: ", |
48 | 24x |
component, " argument." |
49 |
) |
|
50 |
} |
|
51 | 30x |
if (!(nm %in% names(pinfo))) { |
52 | ! |
stop( |
53 | ! |
"Split result does not have required element: ", nm, ".", |
54 | ! |
msg_2_append |
55 |
) |
|
56 |
} |
|
57 | 30x |
if (!is.null(len) && length(pinfo[[nm]]) != len) { |
58 | ! |
stop( |
59 | ! |
"Split result element ", nm, " does not have required length ", len, ".", |
60 | ! |
msg_2_append |
61 |
) |
|
62 |
} |
|
63 | 30x |
TRUE |
64 |
} |
|
65 | ||
66 |
validate_split_result <- function(pinfo, component = NULL) { |
|
67 | 10x |
assert_splres_element(pinfo, "datasplit", component = component) |
68 | 10x |
len <- length(pinfo$datasplit) |
69 | 10x |
assert_splres_element(pinfo, "values", len, component = component) |
70 | 10x |
assert_splres_element(pinfo, "labels", len, component = component) |
71 | 10x |
TRUE |
72 |
} |
|
73 | ||
74 |
#' Construct split result object |
|
75 |
#' |
|
76 |
#' These functions can be used to create or add to a split result in functions which implement core splitting or |
|
77 |
#' post-processing within a custom split function. |
|
78 |
#' |
|
79 |
#' @param values (`character` or `list(SplitValue)`)\cr the values associated with each facet. |
|
80 |
#' @param datasplit (`list(data.frame)`)\cr the facet data for each facet generated in the split. |
|
81 |
#' @param labels (`character`)\cr the labels associated with each facet. |
|
82 |
#' @param extras (`list` or `NULL`)\cr extra values associated with each of the facets which will be passed to |
|
83 |
#' analysis functions applied within the facet. |
|
84 |
#' |
|
85 |
#' @return A named list representing the facets generated by the split with elements `values`, `datasplit`, and |
|
86 |
#' `labels`, which are the same length and correspond to each other element-wise. |
|
87 |
#' |
|
88 |
#' @details |
|
89 |
#' These functions performs various housekeeping tasks to ensure that the split result list is as the rtables |
|
90 |
#' internals expect it, most of which are not relevant to end users. |
|
91 |
#' |
|
92 |
#' @examples |
|
93 |
#' splres <- make_split_result( |
|
94 |
#' values = c("hi", "lo"), |
|
95 |
#' datasplit = list(hi = mtcars, lo = mtcars[1:10, ]), |
|
96 |
#' labels = c("more data", "less data") |
|
97 |
#' ) |
|
98 |
#' |
|
99 |
#' splres2 <- add_to_split_result(splres, |
|
100 |
#' values = "med", |
|
101 |
#' datasplit = list(med = mtcars[1:20, ]), |
|
102 |
#' labels = "kinda some data" |
|
103 |
#' ) |
|
104 |
#' |
|
105 |
#' @family make_custom_split |
|
106 |
#' @rdname make_split_result |
|
107 |
#' @export |
|
108 |
make_split_result <- function(values, datasplit, labels, extras = NULL) { |
|
109 | 6x |
if (length(values) == 1 && is(datasplit, "data.frame")) { |
110 | ! |
datasplit <- list(datasplit) |
111 |
} |
|
112 | 6x |
ret <- list(values = values, datasplit = datasplit, labels = labels) |
113 | 6x |
if (!is.null(extras)) { |
114 | ! |
ret$extras <- extras |
115 |
} |
|
116 | 6x |
.fixupvals(ret) |
117 |
} |
|
118 | ||
119 |
#' @param splres (`list`)\cr a list representing the result of splitting. |
|
120 |
#' |
|
121 |
#' @rdname make_split_result |
|
122 |
#' @export |
|
123 |
add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL) { |
|
124 | 2x |
validate_split_result(splres) |
125 | 2x |
newstuff <- make_split_result(values, datasplit, labels, extras) |
126 | 2x |
ret <- lapply( |
127 | 2x |
names(splres), |
128 | 2x |
function(nm) c(splres[[nm]], newstuff[[nm]]) |
129 |
) |
|
130 | 2x |
names(ret) <- names(splres) |
131 | 2x |
.fixupvals(ret) |
132 |
} |
|
133 | ||
134 | 11x |
.can_take_spl_context <- function(f) any(c(".spl_context", "...") %in% names(formals(f))) |
135 | ||
136 |
#' Create a custom splitting function |
|
137 |
#' |
|
138 |
#' @param pre (`list`)\cr zero or more functions which operate on the incoming data and return a new data frame that |
|
139 |
#' should split via `core_split`. They will be called on the data in the order they appear in the list. |
|
140 |
#' @param core_split (`function` or `NULL`)\cr if non-`NULL`, a function which accepts the same arguments that |
|
141 |
#' `do_base_split` does, and returns the same type of named list. Custom functions which override this behavior |
|
142 |
#' cannot be used in column splits. |
|
143 |
#' @param post (`list`)\cr zero or more functions which should be called on the list output by splitting. |
|
144 |
#' |
|
145 |
#' @details |
|
146 |
#' Custom split functions can be thought of as (up to) 3 different types of manipulations of the splitting process: |
|
147 |
#' |
|
148 |
#' 1. Pre-processing of the incoming data to be split. |
|
149 |
#' 2. (Row-splitting only) Customization of the core mapping of incoming data to facets. |
|
150 |
#' 3. Post-processing operations on the set of facets (groups) generated by the split. |
|
151 |
#' |
|
152 |
#' This function provides an interface to create custom split functions by implementing and specifying sets of |
|
153 |
#' operations in each of those classes of customization independently. |
|
154 |
#' |
|
155 |
#' Pre-processing functions (1), must accept: `df`, `spl`, `vals`, and `labels`, and can optionally accept |
|
156 |
#' `.spl_context`. They then manipulate `df` (the incoming data for the split) and return a modified data frame. |
|
157 |
#' This modified data frame *must* contain all columns present in the incoming data frame, but can add columns if |
|
158 |
#' necessary (though we note that these new columns cannot be used in the layout as split or analysis variables, |
|
159 |
#' because they will not be present when validity checking is done). |
|
160 |
#' |
|
161 |
#' The preprocessing component is useful for things such as manipulating factor levels, e.g., to trim unobserved ones |
|
162 |
#' or to reorder levels based on observed counts, etc. |
|
163 |
#' |
|
164 |
#' Customization of core splitting (2) is currently only supported in row splits. Core splitting functions override the |
|
165 |
#' fundamental splitting procedure, and are only necessary in rare cases. These must accept `spl`, `df`, `vals`, and |
|
166 |
#' `labels`, and can optionally accept `.spl_context`. They must return a named list with elements, all of the same |
|
167 |
#' length, as follows: |
|
168 |
#' |
|
169 |
#' - `datasplit`, containing a list of `data.frame` objects. |
|
170 |
#' - `values`, containing values associated with the facets, which must be `character` or `SplitValue` objects. |
|
171 |
#' These values will appear in the paths of the resulting table. |
|
172 |
#' - `labels`, containing the character labels associated with `values` |
|
173 |
#' |
|
174 |
#' Post-processing functions (3) must accept the result of the core split as their first argument (which can be |
|
175 |
#' anything), in addition to `spl`, and `fulldf`, and can optionally accept `.spl_context`. They must each return a |
|
176 |
#' modified version of the same structure specified above for core splitting. |
|
177 |
#' |
|
178 |
#' In both the pre- and post-processing cases, multiple functions can be specified. When this happens, they are applied |
|
179 |
#' sequentially, in the order they appear in the list passed to the relevant argument (`pre` and `post`, respectively). |
|
180 |
#' |
|
181 |
#' @return A custom function that can be used as a split function. |
|
182 |
#' |
|
183 |
#' @seealso [custom_split_funs] for a more detailed discussion on what custom split functions do. |
|
184 |
#' |
|
185 |
#' @examples |
|
186 |
#' mysplitfun <- make_split_fun( |
|
187 |
#' pre = list(drop_facet_levels), |
|
188 |
#' post = list(add_overall_facet("ALL", "All Arms")) |
|
189 |
#' ) |
|
190 |
#' |
|
191 |
#' basic_table(show_colcounts = TRUE) %>% |
|
192 |
#' split_cols_by("ARM", split_fun = mysplitfun) %>% |
|
193 |
#' analyze("AGE") %>% |
|
194 |
#' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination"))) |
|
195 |
#' |
|
196 |
#' ## post (and pre) arguments can take multiple functions, here |
|
197 |
#' ## we add an overall facet and the reorder the facets |
|
198 |
#' reorder_facets <- function(splret, spl, fulldf, ...) { |
|
199 |
#' ord <- order(names(splret$values)) |
|
200 |
#' make_split_result( |
|
201 |
#' splret$values[ord], |
|
202 |
#' splret$datasplit[ord], |
|
203 |
#' splret$labels[ord] |
|
204 |
#' ) |
|
205 |
#' } |
|
206 |
#' |
|
207 |
#' mysplitfun2 <- make_split_fun( |
|
208 |
#' pre = list(drop_facet_levels), |
|
209 |
#' post = list( |
|
210 |
#' add_overall_facet("ALL", "All Arms"), |
|
211 |
#' reorder_facets |
|
212 |
#' ) |
|
213 |
#' ) |
|
214 |
#' basic_table(show_colcounts = TRUE) %>% |
|
215 |
#' split_cols_by("ARM", split_fun = mysplitfun2) %>% |
|
216 |
#' analyze("AGE") %>% |
|
217 |
#' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination"))) |
|
218 |
#' |
|
219 |
#' very_stupid_core <- function(spl, df, vals, labels, .spl_context) { |
|
220 |
#' make_split_result(c("stupid", "silly"), |
|
221 |
#' datasplit = list(df[1:10, ], df[11:30, ]), |
|
222 |
#' labels = c("first 10", "second 20") |
|
223 |
#' ) |
|
224 |
#' } |
|
225 |
#' |
|
226 |
#' dumb_30_facet <- add_combo_facet("dumb", |
|
227 |
#' label = "thirty patients", |
|
228 |
#' levels = c("stupid", "silly") |
|
229 |
#' ) |
|
230 |
#' nonsense_splfun <- make_split_fun( |
|
231 |
#' core_split = very_stupid_core, |
|
232 |
#' post = list(dumb_30_facet) |
|
233 |
#' ) |
|
234 |
#' |
|
235 |
#' ## recall core split overriding is not supported in column space |
|
236 |
#' ## currently, but we can see it in action in row space |
|
237 |
#' |
|
238 |
#' lyt_silly <- basic_table() %>% |
|
239 |
#' split_rows_by("ARM", split_fun = nonsense_splfun) %>% |
|
240 |
#' summarize_row_groups() %>% |
|
241 |
#' analyze("AGE") |
|
242 |
#' silly_table <- build_table(lyt_silly, DM) |
|
243 |
#' silly_table |
|
244 |
#' |
|
245 |
#' @family make_custom_split |
|
246 |
#' @export |
|
247 |
make_split_fun <- function(pre = list(), core_split = NULL, post = list()) { |
|
248 | 6x |
function(df, |
249 | 6x |
spl, |
250 | 6x |
vals = NULL, |
251 | 6x |
labels = NULL, |
252 | 6x |
trim = FALSE, |
253 | 6x |
.spl_context) { |
254 | 10x |
orig_columns <- names(df) |
255 | 10x |
for (pre_fn in pre) { |
256 | 5x |
if (.can_take_spl_context(pre_fn)) { |
257 | 5x |
df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels, .spl_context = .spl_context) |
258 |
} else { |
|
259 | ! |
df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels) |
260 |
} |
|
261 | 3x |
if (!is(df, "data.frame")) { |
262 | ! |
stop( |
263 | ! |
"Error in custom split function, pre-split step did not return a data.frame. ", |
264 | ! |
"See upstream call to make_split_fun for original source of error." |
265 |
) |
|
266 |
} |
|
267 |
} |
|
268 | ||
269 | 8x |
if (!all(orig_columns %in% names(df))) { |
270 | ! |
stop( |
271 | ! |
"Preprocessing functions(s) in custom split function removed a column from the incoming data.", |
272 | ! |
" This is not supported. See upstread make_split_fun call (pre argument) for original source of error." |
273 |
) |
|
274 |
} |
|
275 | ||
276 | 8x |
if (is.null(core_split)) { |
277 | 6x |
ret <- do_base_split(spl = spl, df = df, vals = vals, labels = labels) |
278 | 2x |
} else if (!in_col_split(.spl_context)) { |
279 | 1x |
ret <- core_split(spl = spl, df = df, vals = vals, labels = labels, .spl_context) |
280 | 1x |
validate_split_result(ret, component = "core_split") |
281 |
} else { |
|
282 | 1x |
stop( |
283 | 1x |
"Use of custom split functions which override core splitting ", |
284 | 1x |
"behavior is not currently supported in column space." |
285 |
) |
|
286 |
} |
|
287 | ||
288 | 7x |
for (post_fn in post) { |
289 | 6x |
if (.can_take_spl_context(post_fn)) { |
290 | 6x |
ret <- post_fn(ret, spl = spl, .spl_context = .spl_context, fulldf = df) |
291 |
} else { |
|
292 | ! |
ret <- post_fn(ret, spl = spl, fulldf = df) |
293 |
} |
|
294 |
} |
|
295 | 7x |
validate_split_result(ret, "post") |
296 | 7x |
ret |
297 |
} |
|
298 |
} |
|
299 | ||
300 |
#' Add a combination facet in post-processing |
|
301 |
#' |
|
302 |
#' Add a combination facet during the post-processing stage in a custom split fun. |
|
303 |
#' |
|
304 |
#' @param name (`string`)\cr name for the resulting facet (for use in pathing, etc.). |
|
305 |
#' @param label (`string`)\cr label for the resulting facet. |
|
306 |
#' @param levels (`character`)\cr vector of levels to combine within the resulting facet. |
|
307 |
#' @param extra (`list`)\cr extra arguments to be passed to analysis functions applied within the resulting facet. |
|
308 |
#' |
|
309 |
#' @details |
|
310 |
#' For `add_combo_facet`, the data associated with the resulting facet will be the data associated with the facets for |
|
311 |
#' each level in `levels`, row-bound together. In particular, this means that if those levels are overlapping, data |
|
312 |
#' that appears in both will be duplicated. |
|
313 |
#' |
|
314 |
#' @return A function which can be used within the `post` argument in [make_split_fun()]. |
|
315 |
#' |
|
316 |
#' @seealso [make_split_fun()] |
|
317 |
#' |
|
318 |
#' @examples |
|
319 |
#' mysplfun <- make_split_fun(post = list( |
|
320 |
#' add_combo_facet("A_B", |
|
321 |
#' label = "Arms A+B", |
|
322 |
#' levels = c("A: Drug X", "B: Placebo") |
|
323 |
#' ), |
|
324 |
#' add_overall_facet("ALL", label = "All Arms") |
|
325 |
#' )) |
|
326 |
#' |
|
327 |
#' lyt <- basic_table(show_colcounts = TRUE) %>% |
|
328 |
#' split_cols_by("ARM", split_fun = mysplfun) %>% |
|
329 |
#' analyze("AGE") |
|
330 |
#' |
|
331 |
#' tbl <- build_table(lyt, DM) |
|
332 |
#' |
|
333 |
#' @family make_custom_split |
|
334 |
#' @export |
|
335 |
add_combo_facet <- function(name, label = name, levels, extra = list()) { |
|
336 | 2x |
function(ret, spl, .spl_context, fulldf) { |
337 | 2x |
val <- LevelComboSplitValue(val = name, extr = extra, combolevels = levels, label = label) |
338 | 2x |
add_to_split_result(ret, |
339 | 2x |
values = list(val), labels = label, |
340 | 2x |
datasplit = list(do.call(rbind, ret$datasplit[levels])) |
341 |
) |
|
342 |
} |
|
343 |
} |
|
344 | ||
345 |
#' @rdname add_combo_facet |
|
346 |
#' @export |
|
347 |
add_overall_facet <- function(name, label, extra = list()) { |
|
348 | 1x |
add_combo_facet( |
349 | 1x |
name = name, label = label, levels = select_all_levels, |
350 | 1x |
extra = extra |
351 |
) |
|
352 |
} |
|
353 | ||
354 |
#' Trim levels of another variable from each facet (post-processing split step) |
|
355 |
#' |
|
356 |
#' @param innervar (`character`)\cr the variable(s) to trim (remove unobserved levels) independently within each facet. |
|
357 |
#' |
|
358 |
#' @return A function suitable for use in the `pre` (list) argument of `make_split_fun`. |
|
359 |
#' |
|
360 |
#' @seealso [make_split_fun()] |
|
361 |
#' |
|
362 |
#' @family make_custom_split |
|
363 |
#' @export |
|
364 |
trim_levels_in_facets <- function(innervar) { |
|
365 | 1x |
function(ret, ...) { |
366 | 1x |
for (var in innervar) { |
367 | 1x |
ret$datasplit <- lapply(ret$datasplit, function(df) { |
368 | 2x |
df[[var]] <- factor(df[[var]]) |
369 | 2x |
df |
370 |
}) |
|
371 |
} |
|
372 | 1x |
ret |
373 |
} |
|
374 |
} |
|
375 | ||
376 |
#' Pre-processing function for use in `make_split_fun` |
|
377 |
#' |
|
378 |
#' This function is intended for use as a pre-processing component in `make_split_fun`, and should not be called |
|
379 |
#' directly by end users. |
|
380 |
#' |
|
381 |
#' @param df (`data.frame`)\cr the incoming data corresponding with the parent facet. |
|
382 |
#' @param spl (`VarLevelSplit`)\cr the split. |
|
383 |
#' @param ... additional parameters passed internally. |
|
384 |
#' |
|
385 |
#' @seealso [make_split_fun()] |
|
386 |
#' |
|
387 |
#' @family make_custom_split |
|
388 |
#' @export |
|
389 |
drop_facet_levels <- function(df, spl, ...) { |
|
390 | 2x |
if (!is(spl, "VarLevelSplit") || is.na(spl_payload(spl))) { |
391 | ! |
stop("Unable to determine faceting variable in drop_facet_levels application.") |
392 |
} |
|
393 | 2x |
var <- spl_payload(spl) |
394 | 2x |
df[[var]] <- factor(df[[var]]) |
395 | 2x |
df |
396 |
} |
1 |
#' Change indentation of all `rrows` in an `rtable` |
|
2 |
#' |
|
3 |
#' Change indentation of all `rrows` in an `rtable` |
|
4 |
#' |
|
5 |
#' @param x (`VTableTree`)\cr an `rtable` object. |
|
6 |
#' @param by (`integer`)\cr number to increase indentation of rows by. Can be negative. If final indentation is |
|
7 |
#' less than 0, the indentation is set to 0. |
|
8 |
#' |
|
9 |
#' @return `x` with its indent modifier incremented by `by`. |
|
10 |
#' |
|
11 |
#' @examples |
|
12 |
#' is_setosa <- iris$Species == "setosa" |
|
13 |
#' m_tbl <- rtable( |
|
14 |
#' header = rheader( |
|
15 |
#' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)), |
|
16 |
#' rrow(NULL, "mean", "median", "mean", "median") |
|
17 |
#' ), |
|
18 |
#' rrow( |
|
19 |
#' row.name = "All Species", |
|
20 |
#' mean(iris$Sepal.Length), median(iris$Sepal.Length), |
|
21 |
#' mean(iris$Petal.Length), median(iris$Petal.Length), |
|
22 |
#' format = "xx.xx" |
|
23 |
#' ), |
|
24 |
#' rrow( |
|
25 |
#' row.name = "Setosa", |
|
26 |
#' mean(iris$Sepal.Length[is_setosa]), median(iris$Sepal.Length[is_setosa]), |
|
27 |
#' mean(iris$Petal.Length[is_setosa]), median(iris$Petal.Length[is_setosa]), |
|
28 |
#' format = "xx.xx" |
|
29 |
#' ) |
|
30 |
#' ) |
|
31 |
#' indent(m_tbl) |
|
32 |
#' indent(m_tbl, 2) |
|
33 |
#' |
|
34 |
#' @export |
|
35 |
indent <- function(x, by = 1) { |
|
36 | 9x |
if (nrow(x) == 0 || by == 0) { |
37 | 9x |
return(x) |
38 |
} |
|
39 | ||
40 | ! |
indent_mod(x) <- indent_mod(x) + by |
41 | ! |
x |
42 |
} |
|
43 | ||
44 |
#' Clear all indent modifiers from a table |
|
45 |
#' |
|
46 |
#' @inheritParams gen_args |
|
47 |
#' |
|
48 |
#' @return The same class as `tt`, with all indent modifiers set to zero. |
|
49 |
#' |
|
50 |
#' @examples |
|
51 |
#' lyt1 <- basic_table() %>% |
|
52 |
#' summarize_row_groups("STUDYID", label_fstr = "overall summary") %>% |
|
53 |
#' split_rows_by("AEBODSYS", child_labels = "visible") %>% |
|
54 |
#' summarize_row_groups("STUDYID", label_fstr = "subgroup summary") %>% |
|
55 |
#' analyze("AGE", indent_mod = -1L) |
|
56 |
#' |
|
57 |
#' tbl1 <- build_table(lyt1, ex_adae) |
|
58 |
#' tbl1 |
|
59 |
#' clear_indent_mods(tbl1) |
|
60 |
#' |
|
61 |
#' @export |
|
62 |
#' @rdname clear_imods |
|
63 | 40x |
setGeneric("clear_indent_mods", function(tt) standardGeneric("clear_indent_mods")) |
64 | ||
65 |
#' @export |
|
66 |
#' @rdname clear_imods |
|
67 |
setMethod( |
|
68 |
"clear_indent_mods", "VTableTree", |
|
69 |
function(tt) { |
|
70 | 25x |
ct <- content_table(tt) |
71 | 25x |
if (!is.null(ct)) { |
72 | 9x |
content_table(tt) <- clear_indent_mods(ct) |
73 |
} |
|
74 | 25x |
tree_children(tt) <- lapply(tree_children(tt), clear_indent_mods) |
75 | 25x |
indent_mod(tt) <- 0L |
76 | 25x |
tt |
77 |
} |
|
78 |
) |
|
79 | ||
80 |
#' @export |
|
81 |
#' @rdname clear_imods |
|
82 |
setMethod( |
|
83 |
"clear_indent_mods", "TableRow", |
|
84 |
function(tt) { |
|
85 | 15x |
indent_mod(tt) <- 0L |
86 | 15x |
tt |
87 |
} |
|
88 |
) |