/
tt_pos_and_access.R
1509 lines (1404 loc) · 41.4 KB
/
tt_pos_and_access.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
do_recursive_replace <- function(tab, path, incontent = FALSE, value) { ## rows = NULL,
## cols = NULL, value) {
## don't want this in the recursive function
## so thats why we have the do_ variant
if (is.character(path) && length(path) > 1) {
path <- as.list(path)
}
if (length(path) > 0 && path[[1]] == obj_name(tab)) {
path <- path[-1]
}
recursive_replace(tab, path, value) ## incontent, rows, cols,value)
}
## different cases we want to support:
## 1. Replace entire children for a particular node/position in the tree
## 2. Replace entire rows at a particular (ElementaryTable) position within the
## tree
## 3. Replace specific cell values within a set of row x column positions within
## an ElementaryTable at a particular position within the tree
## 3. replace entire content table at a node position
## 4. replace entire rows within the content table at a particular node position
## in the tree
## 5. replace data cell values for specific row/col positions within the content
## table at a particular position within the tree
## XXX This is wrong, what happens if a split (or more accurately, value)
## happens more than once in the overall tree???
recursive_replace <- function(tab, path, value) { ## incontent = FALSE, rows = NULL, cols = NULL, value) {
if (length(path) == 0) { ## done recursing
## if(is.null(rows) && is.null(cols)) { ## replacing whole subtree a this position
## if(incontent) {
## newkid = tab
## content_table(newkid) = value
## } else
newkid <- value
## newkid has either thee content table
## replaced on the old kid or is the new
## kid
# } ## else { ## rows or cols (or both) non-null
## if(incontent) {
## ctab = content_table(tab)
## ctab[rows, cols] = value
## content_table(tab) = ctab
## newkid = tab
## } else {
## allkids = tree_children(tab)
## stopifnot(are(allkids, "TableRow"))
## newkid = tab
## newkid[rows, cols] = value
## }
## }
return(newkid)
} else if (path[[1]] == "@content") {
ctb <- content_table(tab)
ctb <- recursive_replace(ctb,
path = path[-1],
## rows = rows,
## cols = cols,
value = value
)
content_table(tab) <- ctb
tab
} else { ## length(path) > 1, more recursing to do
kidel <- path[[1]]
## broken up for debugabiliity, could be a single complex
## expression
## for now only the last step supports selecting
## multiple kids
stopifnot(
length(kidel) == 1,
is.character(kidel) || is.factor(kidel)
)
knms <- names(tree_children(tab))
if (!(kidel %in% knms)) {
stop(sprintf("position element %s not in names of next level children", kidel))
} else if (sum(kidel == knms) > 1) {
stop(sprintf("position element %s appears more than once, not currently supported", kidel))
}
if (is.factor(kidel)) kidel <- levels(kidel)[kidel]
newkid <- recursive_replace(
tree_children(tab)[[kidel]],
path[-1],
## incontent = incontent,
## rows = rows,
## cols = cols,
value
)
tree_children(tab)[[kidel]] <- newkid
tab
}
}
coltree_split <- function(ctree) ctree@split
col_fnotes_at_path <- function(ctree, path, fnotes) {
if (length(path) == 0) {
col_footnotes(ctree) <- fnotes
return(ctree)
}
if (identical(path[1], obj_name(coltree_split(ctree)))) {
path <- path[-1]
} else {
stop(paste("Path appears invalid at step:", path[1]))
}
kids <- tree_children(ctree)
kidel <- path[[1]]
knms <- names(kids)
stopifnot(kidel %in% knms)
newkid <- col_fnotes_at_path(kids[[kidel]],
path[-1],
fnotes = fnotes
)
kids[[kidel]] <- newkid
tree_children(ctree) <- kids
ctree
}
#' Insert row at path
#'
#' Insert a row into an existing table directly before or directly after an existing data (i.e., non-content and
#' non-label) row, specified by its path.
#'
#' @inheritParams gen_args
#' @param after (`flag`)\cr whether `value` should be added as a row directly before (`FALSE`, the default) or after
#' (`TRUE`) the row specified by `path`.
#'
#' @seealso [DataRow()], [rrow()]
#'
#' @examples
#' lyt <- basic_table() %>%
#' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
#' analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#'
#' tbl2 <- insert_row_at_path(
#' tbl, c("COUNTRY", "CHN", "AGE", "Mean"),
#' rrow("new row", 555)
#' )
#' tbl2
#'
#' tbl3 <- insert_row_at_path(tbl2, c("COUNTRY", "CHN", "AGE", "Mean"),
#' rrow("new row redux", 888),
#' after = TRUE
#' )
#' tbl3
#'
#' @export
setGeneric("insert_row_at_path",
signature = c("tt", "value"),
function(tt, path, value, after = FALSE) {
standardGeneric("insert_row_at_path")
}
)
#' @rdname insert_row_at_path
setMethod(
"insert_row_at_path", c("VTableTree", "DataRow"),
function(tt, path, value, after = FALSE) {
if (no_colinfo(value)) {
col_info(value) <- col_info(tt)
} else {
chk_compat_cinfos(tt, value)
}
## retained for debugging
origpath <- path # nolint
idx_row <- tt_at_path(tt, path)
if (!is(idx_row, "DataRow")) {
stop(
"path must resolve fully to a non-content data row. Insertion of ",
"rows elsewhere in the tree is not currently supported."
)
}
posnm <- tail(path, 1)
path <- head(path, -1)
subtt <- tt_at_path(tt, path)
kids <- tree_children(subtt)
ind <- which(names(kids) == posnm)
if (length(ind) != 1L) {
## nocov start
stop(
"table children do not appear to be named correctly at this ",
"path. This should not happen, please contact the maintainer of ",
"rtables."
)
## nocov end
}
if (after) {
ind <- ind + 1
}
sq <- seq_along(kids)
tree_children(subtt) <- c(
kids[sq < ind],
setNames(list(value), obj_name(value)),
kids[sq >= ind]
)
tt_at_path(tt, path) <- subtt
tt
}
)
#' @rdname insert_row_at_path
setMethod(
"insert_row_at_path", c("VTableTree", "ANY"),
function(tt, path, value) {
stop(
"Currently only insertion of DataRow objects is supported. Got ",
"object of class ", class(value), ". Please use rrow() or DataRow() ",
"to construct your row before insertion."
)
}
)
#' Label at path
#'
#' Accesses or sets the label at a path.
#'
#' @inheritParams gen_args
#'
#' @details
#' If `path` resolves to a single row, the label for that row is retrieved or set. If, instead, `path` resolves to a
#' subtable, the text for the row-label associated with that path is retrieved or set. In the subtable case, if the
#' label text is set to a non-`NA` value, the `labelrow` will be set to visible, even if it was not before. Similarly,
#' 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
#' appear at all when the table is printed.
#'
#' @note When changing the row labels for content rows, it is important to path all the way to the *row*. Paths
#' ending in `"@content"` will not exhibit the behavior you want, and are thus an error. See [row_paths()] for help
#' determining the full paths to content rows.
#'
#' @examples
#' lyt <- basic_table() %>%
#' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
#' analyze("AGE")
#'
#' tbl <- build_table(lyt, DM)
#'
#' label_at_path(tbl, c("COUNTRY", "CHN"))
#'
#' label_at_path(tbl, c("COUNTRY", "USA")) <- "United States"
#' tbl
#'
#' @export
label_at_path <- function(tt, path) {
obj_label(tt_at_path(tt, path))
}
#' @export
#' @rdname label_at_path
`label_at_path<-` <- function(tt, path, value) {
if (!is(tt, "VTableTree")) {
stop("tt must be a TableTree or ElementaryTable object")
}
if (is.null(value) || is.na(value)) {
value <- NA_character_
}
subt <- tt_at_path(tt, path)
obj_label(subt) <- value
tt_at_path(tt, path) <- subt
tt
}
#' Access or set table elements at specified path
#'
#' @inheritParams gen_args
#' @param ... unused.
#'
#' @export
#' @rdname ttap
setGeneric("tt_at_path", function(tt, path, ...) standardGeneric("tt_at_path"))
#' @inheritParams tt_at_path
#'
#' @export
#' @rdname int_methods
setMethod(
"tt_at_path", "VTableTree",
function(tt, path, ...) {
stopifnot(
is(path, "character"),
length(path) > 0,
!anyNA(path)
)
if (path[1] == "root" && obj_name(tt) != "root") {
path <- path[-1]
}
## handle pathing that hits the root split by name
if (obj_name(tt) == path[1]) {
path <- path[-1]
}
cur <- tt
curpath <- path
while (length(curpath > 0)) {
kids <- tree_children(cur)
curname <- curpath[1]
if (curname == "@content") {
cur <- content_table(cur)
} else if (curname %in% names(kids)) {
cur <- kids[[curname]]
} else {
stop("Path appears invalid for this tree at step ", curname)
}
curpath <- curpath[-1]
}
cur
}
)
#' @note Setting `NULL` at a defined path removes the corresponding sub-table.
#'
#' @examples
#' # Accessing sub table.
#' lyt <- basic_table() %>%
#' split_cols_by("ARM") %>%
#' split_rows_by("SEX") %>%
#' split_rows_by("BMRKR2") %>%
#' analyze("AGE")
#'
#' tbl <- build_table(lyt, ex_adsl) %>% prune_table()
#' sub_tbl <- tt_at_path(tbl, path = c("SEX", "F", "BMRKR2"))
#'
#' # Removing sub table.
#' tbl2 <- tbl
#' tt_at_path(tbl2, path = c("SEX", "F")) <- NULL
#' tbl2
#'
#' # Setting sub table.
#' lyt3 <- basic_table() %>%
#' split_cols_by("ARM") %>%
#' split_rows_by("SEX") %>%
#' analyze("BMRKR2")
#'
#' tbl3 <- build_table(lyt3, ex_adsl) %>% prune_table()
#'
#' tt_at_path(tbl3, path = c("SEX", "F", "BMRKR2")) <- sub_tbl
#' tbl3
#'
#' @export
#' @rdname ttap
setGeneric(
"tt_at_path<-",
function(tt, path, ..., value) standardGeneric("tt_at_path<-")
)
#' @export
#' @keywords internal
#' @rdname int_methods
setMethod(
"tt_at_path<-", c(tt = "VTableTree", value = "VTableTree"),
function(tt, path, ..., value) {
do_recursive_replace(tt, path = path, value = value)
}
)
## this one removes the child at path from the parents list of children,
## because that is how lists behave.
#' @export
#' @keywords internal
#' @rdname int_methods
setMethod(
"tt_at_path<-", c(tt = "VTableTree", value = "NULL"),
function(tt, path, ..., value) {
do_recursive_replace(tt, path = path, value = value)
}
)
#' @export
#' @keywords internal
#' @rdname int_methods
setMethod(
"tt_at_path<-", c(tt = "VTableTree", value = "TableRow"),
function(tt, path, ..., value) {
stopifnot(is(tt_at_path(tt = tt, path = path), "TableRow"))
do_recursive_replace(tt, path = path, value = value)
## ##i <- .path_to_pos(path = path, seq_len(nrow(tt)), tt, NROW)
## i <- .path_to_pos(path = path, tt = tt)
## replace_rows(tt, i = i, value = list(value))
}
)
#' Retrieve and assign elements of a `TableTree`
#'
#' @param x (`TableTree`)\cr a `TableTree` object.
#' @param i (`numeric(1)`)\cr index.
#' @param j (`numeric(1)`)\cr index.
#' @param drop (`flag`)\cr whether the value in the cell should be returned if one cell is selected by the
#' combination of `i` and `j`. It is not possible to return a vector of values. To do so please consider using
#' [cell_values()]. Defaults to `FALSE`.
#' @param ... additional arguments. Includes:
#' \describe{
#' \item{`keep_topleft`}{(`flag`) (`[` only) whether the top-left material for the table should be retained after
#' subsetting. Defaults to `TRUE` if all rows are included (i.e. subsetting was by column), and drops it
#' otherwise.}
#' \item{`keep_titles`}{(`flag`) whether title information should be retained. Defaults to `FALSE`.}
#' \item{`keep_footers`}{(`flag`) whether non-referential footer information should be retained. Defaults to
#' `keep_titles`.}
#' \item{`reindex_refs`}{(`flag`) whether referential footnotes should be re-indexed as if the resulting subset is
#' the entire table. Defaults to `TRUE`.}
#' }
#' @param value (`list`, `TableRow`, or `TableTree`)\cr replacement value.
#'
#' @details
#' By default, subsetting drops the information about title, subtitle, main footer, provenance footer, and `topleft`.
#' If only a column is selected and all rows are kept, the `topleft` information remains as default. Any referential
#' footnote is kept whenever the subset table contains the referenced element.
#'
#' @return A `TableTree` (or `ElementaryTable`) object, unless a single cell was selected with `drop = TRUE`, in which
#' case the (possibly multi-valued) fully stripped raw value of the selected cell.
#'
#' @note
#' Subsetting always preserve the original order, even if provided indexes do not preserve it. If sorting is needed,
#' please consider using `sort_at_path()`. Also note that `character` indices are treated as paths, not vectors of
#' names in both `[` and `[<-`.
#'
#' @seealso
#' * [sort_at_path()] to understand sorting.
#' * [summarize_row_groups()] to understand path structure.
#'
#' @examples
#' lyt <- basic_table(
#' title = "Title",
#' subtitles = c("Sub", "titles"),
#' prov_footer = "prov footer",
#' main_footer = "main footer"
#' ) %>%
#' split_cols_by("ARM") %>%
#' split_rows_by("SEX") %>%
#' analyze(c("AGE"))
#'
#' tbl <- build_table(lyt, DM)
#' top_left(tbl) <- "Info"
#' tbl
#'
#' # As default header, footer, and topleft information is lost
#' tbl[1, ]
#' tbl[1:2, 2]
#'
#' # Also boolean filters can work
#' tbl[, c(FALSE, TRUE, FALSE)]
#'
#' # If drop = TRUE, the content values are directly retrieved
#' tbl[2, 1]
#' tbl[2, 1, drop = TRUE]
#'
#' # Drop works also if vectors are selected, but not matrices
#' tbl[, 1, drop = TRUE]
#' tbl[2, , drop = TRUE]
#' tbl[1, 1, drop = TRUE] # NULL because it is a label row
#' tbl[2, 1:2, drop = TRUE] # vectors can be returned only with cell_values()
#' tbl[1:2, 1:2, drop = TRUE] # no dropping because it is a matrix
#'
#' # If all rows are selected, topleft is kept by default
#' tbl[, 2]
#' tbl[, 1]
#'
#' # It is possible to deselect values
#' tbl[-2, ]
#' tbl[, -1]
#'
#' # Values can be reassigned
#' tbl[2, 1] <- rcell(999)
#' tbl[2, ] <- list(rrow("FFF", 888, 666, 777))
#' tbl[6, ] <- list(-111, -222, -333)
#' tbl
#'
#' # We can keep some information from the original table if we need
#' tbl[1, 2, keep_titles = TRUE]
#' tbl[1, 2, keep_footers = TRUE, keep_titles = FALSE]
#' tbl[1, 2, keep_footers = FALSE, keep_titles = TRUE]
#' tbl[1, 2, keep_footers = TRUE]
#' tbl[1, 2, keep_topleft = TRUE]
#'
#' # Keeps the referential footnotes when subset contains them
#' fnotes_at_path(tbl, rowpath = c("SEX", "M", "AGE", "Mean")) <- "important"
#' tbl[4, 1]
#' tbl[2, 1] # None present
#'
#' # We can reindex referential footnotes, so that the new table does not depend
#' # on the original one
#' fnotes_at_path(tbl, rowpath = c("SEX", "U", "AGE", "Mean")) <- "important"
#' tbl[, 1] # both present
#' tbl[5:6, 1] # {1} because it has been indexed again
#' tbl[5:6, 1, reindex_refs = FALSE] # {2} -> not reindexed
#'
#' # Note that order can not be changed with subsetting
#' tbl[c(4, 3, 1), c(3, 1)] # It preserves order and wanted selection
#'
#' @name brackets
NULL
#' @exportMethod [<-
#' @rdname brackets
setMethod(
"[<-", c("VTableTree", value = "list"),
function(x, i, j, ..., value) {
nr <- nrow(x)
if (missing(i)) {
i <- seq_len(NROW(x))
} else if (is(i, "character")) {
i <- .path_to_pos(i, x)
} else {
i <- .j_to_posj(i, nr)
}
if (missing(j)) {
j <- seq_along(col_exprs(col_info(x)))
} else if (is(j, "character")) {
j <- .path_to_pos(j, x, cols = TRUE)
} else {
j <- .j_to_posj(j, ncol(x))
}
if (length(i) > 1 && length(j) < ncol(x)) {
stop("cannot modify multiple rows in not all columns.")
}
if (are(value, "TableRow")) {
value <- rep(value, length.out = length(i))
} else {
value <- rep(value, length.out = length(i) * length(j))
}
counter <- 0
## this has access to value, i, and j by scoping
replace_rowsbynum <- function(x, i, valifnone = NULL) {
maxi <- max(i)
if (counter >= maxi) {
return(valifnone)
}
if (labelrow_visible(x)) {
counter <<- counter + 1
if (counter %in% i) {
nxtval <- value[[1]]
if (is(nxtval, "LabelRow")) {
tt_labelrow(x) <- nxtval
} else {
stop(
"can't replace label with value of class",
class(nxtval)
)
}
## we're done with this one move to
## the next
value <<- value[-1]
}
}
if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
ctab <- content_table(x)
content_table(x) <- replace_rowsbynum(ctab, i)
}
if (counter >= maxi) { # already done
return(x)
}
kids <- tree_children(x)
if (length(kids) > 0) {
for (pos in seq_along(kids)) {
curkid <- kids[[pos]]
if (is(curkid, "TableRow")) {
counter <<- counter + 1
if (counter %in% i) {
nxtval <- value[[1]]
if (is(nxtval, class(curkid))) {
if (no_colinfo(nxtval) && length(row_values(nxtval)) == ncol(x)) {
col_info(nxtval) <- col_info(x)
}
stopifnot(identical(col_info(x), col_info(nxtval)))
curkid <- nxtval
value <- value[-1]
} else {
rvs <- row_values(curkid)
rvs[j] <- value[seq_along(j)]
row_values(curkid) <- rvs
value <- value[-(seq_along(j))]
}
kids[[pos]] <- curkid
}
} else {
kids[[pos]] <- replace_rowsbynum(curkid, i)
}
if (counter >= maxi) {
break
}
}
}
tree_children(x) <- kids
x
}
replace_rowsbynum(x, i, ...)
}
)
#' @inheritParams brackets
#'
#' @exportMethod [<-
#' @rdname int_methods
#' @keywords internal
setMethod(
"[<-", c("VTableTree", value = "CellValue"),
function(x, i, j, ..., value) {
x[i = i, j = j, ...] <- list(value)
x
}
)
## this is going to be hard :( :( :(
### selecting/removing columns
## we have two options here: path like we do with rows and positional
## in leaf space.
setGeneric(
"subset_cols",
function(tt,
j,
newcinfo = NULL,
keep_topleft = TRUE,
keep_titles = TRUE,
keep_footers = keep_titles,
...) {
standardGeneric("subset_cols")
}
)
setMethod(
"subset_cols", c("TableTree", "numeric"),
function(tt, j, newcinfo = NULL,
keep_topleft, keep_titles, keep_footers, ...) {
j <- .j_to_posj(j, ncol(tt))
if (is.null(newcinfo)) {
cinfo <- col_info(tt)
newcinfo <- subset_cols(cinfo, j,
keep_topleft = keep_topleft, ...
)
}
## topleft taken care of in creation of newcinfo
kids <- tree_children(tt)
newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...)
cont <- content_table(tt)
newcont <- subset_cols(cont, j, newcinfo = newcinfo, ...)
tt2 <- tt
col_info(tt2) <- newcinfo
content_table(tt2) <- newcont
tree_children(tt2) <- newkids
tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...)
tt2 <- .h_copy_titles_footers_topleft(
tt2, tt,
keep_titles,
keep_footers,
keep_topleft
)
tt2
}
)
setMethod(
"subset_cols", c("ElementaryTable", "numeric"),
function(tt, j, newcinfo = NULL,
keep_topleft, keep_titles, keep_footers, ...) {
j <- .j_to_posj(j, ncol(tt))
if (is.null(newcinfo)) {
cinfo <- col_info(tt)
newcinfo <- subset_cols(cinfo, j,
keep_topleft = keep_topleft,
keep_titles = keep_titles,
keep_footers = keep_footers, ...
)
}
## topleft handled in creation of newcinfo
kids <- tree_children(tt)
newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...)
tt2 <- tt
col_info(tt2) <- newcinfo
tree_children(tt2) <- newkids
tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...)
tt2 <- .h_copy_titles_footers_topleft(
tt2, tt,
keep_titles,
keep_footers,
keep_topleft
)
tt2
}
)
## small utility to transform any negative
## indices into positive ones, given j
## and total length
.j_to_posj <- function(j, n) {
## This will work for logicals, numerics, integers
j <- seq_len(n)[j]
j
}
path_collapse_sep <- "`"
escape_name_padding <- function(x) {
ret <- gsub("._[[", "\\._\\[\\[", x, fixed = TRUE)
ret <- gsub("]]_.", "\\]\\]_\\.", ret, fixed = TRUE)
ret
}
path_to_regex <- function(path) {
paste(vapply(path, function(x) {
if (identical(x, "*")) {
paste0("[^", path_collapse_sep, "]+")
} else {
escape_name_padding(x)
}
}, ""), collapse = path_collapse_sep)
}
.path_to_pos <- function(path, tt, distinct_ok = TRUE, cols = FALSE) {
path <- path[!grepl("^(|root)$", path)]
if (cols) {
rowdf <- make_col_df(tt)
} else {
rowdf <- make_row_df(tt)
}
if (length(path) == 0 || identical(path, "*") || identical(path, "root")) {
return(seq(1, nrow(rowdf)))
}
paths <- rowdf$path
pathregex <- path_to_regex(path)
pathstrs <- vapply(paths, paste, "", collapse = path_collapse_sep)
allmatchs <- grep(pathregex, pathstrs)
if (length(allmatchs) == 0) {
stop(
if (cols) "column path [" else "row path [",
paste(path, collapse = "->"),
"] does not appear valid for this table"
)
}
idxdiffs <- diff(allmatchs)
if (!distinct_ok && length(idxdiffs) > 0 && any(idxdiffs > 1)) {
firstnon <- min(which(idxdiffs > 1))
## its firstnon here because we would want firstnon-1 but
## the diffs are actually shifted 1 so they cancel out
allmatchs <- allmatchs[seq(1, firstnon)]
}
allmatchs
}
## fix column spans that would be invalid
## after some columns are no longer there
.fix_rowcspans <- function(rw, j) {
cspans <- row_cspans(rw)
nc <- sum(cspans)
j <- .j_to_posj(j, nc)
## this is overly complicated
## we need the starting indices
## but the first span might not be 1, so
## we pad with 1 and then take off the last
start <- cumsum(c(1, head(cspans, -1)))
ends <- c(tail(start, -1) - 1, nc)
res <- mapply(function(st, en) {
sum(j >= st & j <= en)
}, st = start, en = ends)
res <- res[res > 0]
stopifnot(sum(res) == length(j))
res
}
select_cells_j <- function(cells, j) {
if (length(j) != length(unique(j))) {
stop("duplicate column selections is not currently supported")
}
spans <- vapply(
cells, function(x) cell_cspan(x),
integer(1)
)
inds <- rep(seq_along(cells), times = spans)
selinds <- inds[j]
retcells <- cells[selinds[!duplicated(selinds)]]
newspans <- vapply(
split(selinds, selinds),
length,
integer(1)
)
mapply(function(cl, sp) {
cell_cspan(cl) <- sp
cl
}, cl = retcells, sp = newspans, SIMPLIFY = FALSE)
}
setMethod(
"subset_cols", c("ANY", "character"),
function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
j <- .path_to_pos(path = j, tt = tt, cols = TRUE)
subset_cols(tt, j, newcinfo = newcinfo, keep_topleft = keep_topleft, ...)
}
)
setMethod(
"subset_cols", c("TableRow", "numeric"),
function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
j <- .j_to_posj(j, ncol(tt))
if (is.null(newcinfo)) {
cinfo <- col_info(tt)
newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...)
}
tt2 <- tt
row_cells(tt2) <- select_cells_j(row_cells(tt2), j)
if (length(row_cspans(tt2)) > 0) {
row_cspans(tt2) <- .fix_rowcspans(tt2, j)
}
col_info(tt2) <- newcinfo
tt2
}
)
setMethod(
"subset_cols", c("LabelRow", "numeric"),
function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
j <- .j_to_posj(j, ncol(tt))
if (is.null(newcinfo)) {
cinfo <- col_info(tt)
newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...)
}
col_info(tt) <- newcinfo
tt
}
)
setMethod(
"subset_cols", c("InstantiatedColumnInfo", "numeric"),
function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
if (!is.null(newcinfo)) {
return(newcinfo)
}
j <- .j_to_posj(j, length(col_exprs(tt)))
newctree <- subset_cols(coltree(tt), j, NULL)
newcextra <- col_extra_args(tt)[j]
newcsubs <- col_exprs(tt)[j]
newcounts <- col_counts(tt)[j]
tl <- if (keep_topleft) top_left(tt) else character()
InstantiatedColumnInfo(
treelyt = newctree,
csubs = newcsubs,
extras = newcextra,
cnts = newcounts,
dispcounts = disp_ccounts(tt),
countformat = colcount_format(tt),
topleft = tl
)
}
)
setMethod(
"subset_cols", c("LayoutColTree", "numeric"),
function(tt, j, newcinfo = NULL, ...) {
lst <- collect_leaves(tt)
j <- .j_to_posj(j, length(lst))
## j has only non-negative values from
## this point on
counter <- 0
prune_children <- function(x, j) {
kids <- tree_children(x)
newkids <- kids
for (i in seq_along(newkids)) {
if (is(newkids[[i]], "LayoutColLeaf")) {
counter <<- counter + 1
if (!(counter %in% j)) {
newkids[[i]] <- list()
} ## NULL removes the position entirely
} else {
newkids[[i]] <- prune_children(newkids[[i]], j)
}
}
newkids <- newkids[sapply(newkids, function(thing) length(thing) > 0)]
if (length(newkids) > 0) {
tree_children(x) <- newkids
x
} else {
list()
}
}
prune_children(tt, j)
}
)
## label rows ARE included in the count
subset_by_rownum <- function(tt,
i,
keep_topleft = FALSE,
keep_titles = TRUE,
keep_footers = keep_titles,
...) {
stopifnot(is(tt, "VTableNodeInfo"))
counter <- 0
nr <- nrow(tt)
i <- .j_to_posj(i, nr)
if (length(i) == 0) {
ret <- TableTree(cinfo = col_info(tt))
if (isTRUE(keep_topleft)) {
top_left(ret) <- top_left(tt)
}
return(ret)
}
prune_rowsbynum <- function(x, i, valifnone = NULL) {
maxi <- max(i)
if (counter > maxi) {
return(valifnone)
}
if (labelrow_visible(x)) {
counter <<- counter + 1
if (!(counter %in% i)) {
## XXX this should do whatever
## is required to 'remove' the Label Row
## (currently implicit based on
## the value of the label but
## that shold really probably change)
labelrow_visible(x) <- FALSE
}
}
if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
ctab <- content_table(x)
content_table(x) <- prune_rowsbynum(ctab, i,
valifnone = ElementaryTable(
cinfo = col_info(ctab),
iscontent = TRUE
)
)
}
kids <- tree_children(x)
if (counter > maxi) { # already done
kids <- list()
} else if (length(kids) > 0) {
for (pos in seq_along(kids)) {
if (is(kids[[pos]], "TableRow")) {
counter <<- counter + 1
if (!(counter %in% i)) {
kids[[pos]] <- list()
}
} else {
kids[[pos]] <- prune_rowsbynum(kids[[pos]], i, list())
}
}
kids <- kids[sapply(kids, function(x) NROW(x) > 0)]
}
if (length(kids) == 0 && NROW(content_table(x)) == 0 && !labelrow_visible(x)) {
return(valifnone)
} else {
tree_children(x) <- kids
x
}
## ## if(length(kids) == 0) {
## ## if(!is(x, "TableTree"))
## ## return(valifnone)
## ## }
## if(is(x, "VTableTree") && nrow(x) > 0) {
## x
## } else {
## valifnone
## }
}
ret <- prune_rowsbynum(tt, i)
ret <- .h_copy_titles_footers_topleft(
ret, tt,
keep_titles,
keep_footers,
keep_topleft
)
ret
}
#' @exportMethod [
#' @rdname brackets
setMethod(
"[", c("VTableTree", "logical", "logical"),
function(x, i, j, ..., drop = FALSE) {
i <- .j_to_posj(i, nrow(x))
j <- .j_to_posj(j, ncol(x))
x[i, j, ..., drop = drop]
}
)