| 1 |
- do_recursive_replace <- function(tab, path, incontent = FALSE, value) { ## rows = NULL,
+ #' Internal generics and methods |
||
| 2 |
- ## cols = NULL, value) {
+ #' |
||
| 3 |
- ## don't want this in the recursive function+ #' These are internal methods that are documented only to satisfy `R CMD check`. End users should pay no |
||
| 4 |
- ## so thats why we have the do_ variant+ #' attention to this documentation. |
||
| 5 | -168x | +
- if (is.character(path) && length(path) > 1) {
+ #' |
|
| 6 | -143x | +
- path <- as.list(path)+ #' @param x (`ANY`)\cr the object. |
|
| 7 |
- }+ #' @param obj (`ANY`)\cr the object. |
||
| 8 | -168x | +
- if (length(path) > 0 && path[[1]] == obj_name(tab)) {
+ #' |
|
| 9 | -144x | +
- path <- path[-1]+ #' @name internal_methods |
|
| 10 |
- }+ #' @rdname int_methods |
||
| 11 | -168x | +
- recursive_replace(tab, path, value) ## incontent, rows, cols,value)+ #' @aliases int_methods |
|
| 12 |
- }+ NULL |
||
| 14 |
- ## different cases we want to support:+ #' @return The number of rows (`nrow`), columns (`ncol`), or both (`dim`) of the object. |
||
| 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+ #' @rdname dimensions |
||
| 17 |
- ## tree+ #' @exportMethod nrow |
||
| 18 |
- ## 3. Replace specific cell values within a set of row x column positions within+ setMethod( |
||
| 19 |
- ## an ElementaryTable at a particular position within the tree+ "nrow", "VTableTree", |
||
| 20 | -+ | 2199x |
- ## 3. replace entire content table at a node position+ function(x) length(collect_leaves(x, TRUE, TRUE)) |
| 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+ #' @rdname int_methods |
||
| 24 |
- ## table at a particular position within the tree+ #' @exportMethod nrow |
||
| 25 |
-
+ setMethod( |
||
| 26 |
- ## XXX This is wrong, what happens if a split (or more accurately, value)+ "nrow", "TableRow", |
||
| 27 | -+ | 959x |
- ## happens more than once in the overall tree???+ function(x) 1L |
| 28 |
- recursive_replace <- function(tab, path, value) { ## incontent = FALSE, rows = NULL, cols = NULL, value) {
+ ) |
||
| 29 | -675x | +
- if (length(path) == 0) { ## done recursing
+
|
|
| 30 |
- ## if(is.null(rows) && is.null(cols)) { ## replacing whole subtree a this position
+ #' Table dimensions |
||
| 31 |
- ## if(incontent) {
+ #' |
||
| 32 |
- ## newkid = tab+ #' @param x (`TableTree` or `ElementaryTable`)\cr a table object. |
||
| 33 |
- ## content_table(newkid) = value+ #' |
||
| 34 |
- ## } else+ #' @examples |
||
| 35 | -171x | +
- newkid <- value+ #' lyt <- basic_table() %>% |
|
| 36 |
- ## newkid has either thee content table+ #' split_cols_by("ARM") %>%
|
||
| 37 |
- ## replaced on the old kid or is the new+ #' analyze(c("SEX", "AGE"))
|
||
| 38 |
- ## kid+ #' |
||
| 39 |
- # } ## else { ## rows or cols (or both) non-null
+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 40 |
- ## if(incontent) {
+ #' |
||
| 41 |
- ## ctab = content_table(tab)+ #' dim(tbl) |
||
| 42 |
- ## ctab[rows, cols] = value+ #' nrow(tbl) |
||
| 43 |
- ## content_table(tab) = ctab+ #' ncol(tbl) |
||
| 44 |
- ## newkid = tab+ #' |
||
| 45 |
-
+ #' NROW(tbl) |
||
| 46 |
- ## } else {
+ #' NCOL(tbl) |
||
| 47 |
- ## allkids = tree_children(tab)+ #' |
||
| 48 |
- ## stopifnot(are(allkids, "TableRow"))+ #' @rdname dimensions |
||
| 49 |
- ## newkid = tab+ #' @exportMethod ncol |
||
| 50 |
- ## newkid[rows, cols] = value+ setMethod( |
||
| 51 |
- ## }+ "ncol", "VTableNodeInfo", |
||
| 52 |
- ## }+ function(x) {
|
||
| 53 | -171x | +22483x |
- return(newkid)+ ncol(col_info(x)) |
| 54 | -504x | +
- } else if (path[[1]] == "@content") {
+ } |
|
| 55 | -25x | +
- ctb <- content_table(tab)+ ) |
|
| 56 | -25x | +
- ctb <- recursive_replace(ctb,+ |
|
| 57 | -25x | +
- path = path[-1],+ #' @rdname int_methods |
|
| 58 |
- ## rows = rows,+ #' @exportMethod ncol |
||
| 59 |
- ## cols = cols,+ setMethod( |
||
| 60 | -25x | +
- value = value+ "ncol", "TableRow", |
|
| 61 |
- )+ function(x) {
|
||
| 62 | -25x | +66824x |
- content_table(tab) <- ctb+ if (!no_colinfo(x)) {
|
| 63 | -25x | +65884x |
- tab+ ncol(col_info(x)) |
| 64 |
- } else { ## length(path) > 1, more recursing to do
+ } else {
|
||
| 65 | -479x | +940x |
- kidel <- path[[1]]+ length(spanned_values(x)) |
| 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 | -479x | +
- stopifnot(+ #' @rdname int_methods |
|
| 71 | -479x | +
- length(kidel) == 1,+ #' @exportMethod ncol |
|
| 72 | -479x | +
- is.character(kidel) || is.factor(kidel)+ setMethod( |
|
| 73 |
- )+ "ncol", "LabelRow", |
||
| 74 | -479x | +
- knms <- names(tree_children(tab))+ function(x) {
|
|
| 75 | -479x | +20872x |
- if (!(kidel %in% knms)) {
+ ncol(col_info(x)) |
| 76 | -! | +
- stop(sprintf("position element %s not in names of next level children", kidel))
+ } |
|
| 77 | -479x | +
- } else if (sum(kidel == knms) > 1) {
+ ) |
|
| 78 | -! | +
- stop(sprintf("position element %s appears more than once, not currently supported", kidel))
+
|
|
| 79 |
- }+ #' @rdname int_methods |
||
| 80 | -! | +
- if (is.factor(kidel)) kidel <- levels(kidel)[kidel]+ #' @exportMethod ncol |
|
| 81 | -479x | +
- newkid <- recursive_replace(+ setMethod( |
|
| 82 | -479x | +
- tree_children(tab)[[kidel]],+ "ncol", "InstantiatedColumnInfo", |
|
| 83 | -479x | +
- path[-1],+ function(x) {
|
|
| 84 | -+ | 111326x |
- ## incontent = incontent,+ length(col_exprs(x)) |
| 85 |
- ## rows = rows,+ } |
||
| 86 |
- ## cols = cols,+ ) |
||
| 87 | -479x | +
- value+ |
|
| 88 |
- )+ #' @rdname dimensions |
||
| 89 | -479x | +
- tree_children(tab)[[kidel]] <- newkid+ #' @exportMethod dim |
|
| 90 | -479x | +
- tab+ setMethod( |
|
| 91 |
- }+ "dim", "VTableNodeInfo", |
||
| 92 | -+ | 18538x |
- }+ function(x) c(nrow(x), ncol(x)) |
| 93 |
-
+ ) |
||
| 94 | -1x | +
- coltree_split <- function(ctree) ctree@split+ |
|
| 95 |
-
+ #' Retrieve or set the direct children of a tree-style object |
||
| 96 |
- col_fnotes_at_path <- function(ctree, path, fnotes) {
+ #' |
||
| 97 | -2x | +
- if (length(path) == 0) {
+ #' @param x (`TableTree` or `ElementaryTable`)\cr an object with a tree structure. |
|
| 98 | -1x | +
- col_footnotes(ctree) <- fnotes+ #' @param value (`list`)\cr new list of children. |
|
| 99 | -1x | +
- return(ctree)+ #' |
|
| 100 |
- }+ #' @return A list of direct children of `x`. |
||
| 101 |
-
+ #' |
||
| 102 | -1x | +
- if (identical(path[1], obj_name(coltree_split(ctree)))) {
+ #' @export |
|
| 103 | -1x | +
- path <- path[-1]+ #' @rdname tree_children |
|
| 104 | -+ | 239483x |
- } else {
+ setGeneric("tree_children", function(x) standardGeneric("tree_children"))
|
| 105 | -! | +
- stop(paste("Path appears invalid at step:", path[1]))
+
|
|
| 106 |
- }+ #' @exportMethod tree_children |
||
| 107 |
-
+ #' @rdname int_methods |
||
| 108 | -1x | +
- kids <- tree_children(ctree)+ setMethod( |
|
| 109 | -1x | +
- kidel <- path[[1]]+ "tree_children", c(x = "VTree"), |
|
| 110 | -1x | +! |
- knms <- names(kids)+ function(x) x@children |
| 111 | -1x | +
- stopifnot(kidel %in% knms)+ ) |
|
| 112 | -1x | +
- newkid <- col_fnotes_at_path(kids[[kidel]],+ |
|
| 113 | -1x | +
- path[-1],+ #' @exportMethod tree_children |
|
| 114 | -1x | +
- fnotes = fnotes+ #' @rdname int_methods |
|
| 115 |
- )+ setMethod( |
||
| 116 | -1x | +
- kids[[kidel]] <- newkid+ "tree_children", c(x = "VTableTree"), |
|
| 117 | -1x | +62925x |
- tree_children(ctree) <- kids+ function(x) x@children |
| 118 | -1x | +
- ctree+ ) |
|
| 119 |
- }+ |
||
| 120 |
-
+ ## this includes VLeaf but also allows for general methods |
||
| 121 |
- #' Insert row at path+ ## needed for table_inset being carried around by rows and |
||
| 122 |
- #'+ ## such. |
||
| 123 |
- #' Insert a row into an existing table directly before or directly after an existing data (i.e., non-content and+ #' @exportMethod tree_children |
||
| 124 |
- #' non-label) row, specified by its path.+ #' @rdname int_methods |
||
| 125 |
- #'+ setMethod( |
||
| 126 |
- #' @inheritParams gen_args+ "tree_children", c(x = "ANY"), ## "VLeaf"), |
||
| 127 | -+ | 12546x |
- #' @param after (`flag`)\cr whether `value` should be added as a row directly before (`FALSE`, the default) or after+ function(x) list() |
| 128 |
- #' (`TRUE`) the row specified by `path`.+ ) |
||
| 129 |
- #'+ |
||
| 130 |
- #' @seealso [DataRow()], [rrow()]+ #' @export |
||
| 131 |
- #'+ #' @rdname tree_children |
||
| 132 | -+ | 57836x |
- #' @examples+ setGeneric("tree_children<-", function(x, value) standardGeneric("tree_children<-"))
|
| 133 |
- #' lyt <- basic_table() %>%+ |
||
| 134 |
- #' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
+ #' @exportMethod tree_children<- |
||
| 135 |
- #' analyze("AGE")
+ #' @rdname int_methods |
||
| 136 |
- #'+ setMethod( |
||
| 137 |
- #' tbl <- build_table(lyt, DM)+ "tree_children<-", c(x = "VTree"), |
||
| 138 |
- #'+ function(x, value) {
|
||
| 139 | -+ | ! |
- #' tbl2 <- insert_row_at_path(+ x@children <- value |
| 140 | -+ | ! |
- #' tbl, c("COUNTRY", "CHN", "AGE", "Mean"),
+ x |
| 141 |
- #' rrow("new row", 555)
+ } |
||
| 142 |
- #' )+ ) |
||
| 143 |
- #' tbl2+ |
||
| 144 |
- #'+ #' @exportMethod tree_children<- |
||
| 145 |
- #' tbl3 <- insert_row_at_path(tbl2, c("COUNTRY", "CHN", "AGE", "Mean"),
+ #' @rdname int_methods |
||
| 146 |
- #' rrow("new row redux", 888),
+ setMethod( |
||
| 147 |
- #' after = TRUE+ "tree_children<-", c(x = "VTableTree"), |
||
| 148 |
- #' )+ function(x, value) {
|
||
| 149 | -+ | 52314x |
- #' tbl3+ x@children <- value |
| 150 | -+ | 52314x |
- #'+ x |
| 151 |
- #' @export+ } |
||
| 152 |
- setGeneric("insert_row_at_path",
+ ) |
||
| 153 |
- signature = c("tt", "value"),
+
|
||
| 154 |
- function(tt, path, value, after = FALSE) {
+ #' Retrieve or set content table from a `TableTree` |
||
| 155 | -6x | +
- standardGeneric("insert_row_at_path")
+ #' |
|
| 156 |
- }+ #' Returns the content table of `obj` if it is a `TableTree` object, or `NULL` otherwise. |
||
| 157 |
- )+ #' |
||
| 158 |
-
+ #' @param obj (`TableTree`)\cr the table object. |
||
| 159 |
- #' @rdname insert_row_at_path+ #' |
||
| 160 |
- setMethod(+ #' @return the `ElementaryTable` containing the (top level) *content rows* of `obj` (or `NULL` if `obj` is not |
||
| 161 |
- "insert_row_at_path", c("VTableTree", "DataRow"),
+ #' a formal table object). |
||
| 162 |
- function(tt, path, value, after = FALSE) {
+ #' |
||
| 163 | -6x | +
- if (no_colinfo(value)) {
+ #' @export |
|
| 164 | -6x | +
- col_info(value) <- col_info(tt)+ #' @rdname content_table |
|
| 165 | -+ | 89137x |
- } else {
+ setGeneric("content_table", function(obj) standardGeneric("content_table"))
|
| 166 | -! | +
- chk_compat_cinfos(tt, value)+ |
|
| 167 |
- }+ #' @exportMethod content_table |
||
| 168 |
- ## retained for debugging+ #' @rdname int_methods |
||
| 169 | -6x | +
- origpath <- path # nolint+ setMethod( |
|
| 170 | -6x | +
- idx_row <- tt_at_path(tt, path)+ "content_table", "TableTree", |
|
| 171 | -6x | +57424x |
- if (!is(idx_row, "DataRow")) {
+ function(obj) obj@content |
| 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."+ #' @exportMethod content_table |
|
| 175 |
- )+ #' @rdname int_methods |
||
| 176 |
- }+ setMethod( |
||
| 177 |
-
+ "content_table", "ANY", |
||
| 178 | -2x | +11260x |
- posnm <- tail(path, 1)+ function(obj) NULL |
| 179 |
-
+ ) |
||
| 180 | -2x | +
- path <- head(path, -1)+ |
|
| 181 |
-
+ #' @param value (`ElementaryTable`)\cr the new content table for `obj`. |
||
| 182 | -2x | +
- subtt <- tt_at_path(tt, path)+ #' |
|
| 183 | -2x | +
- kids <- tree_children(subtt)+ #' @export |
|
| 184 | -2x | +
- ind <- which(names(kids) == posnm)+ #' @rdname content_table |
|
| 185 | -2x | +6387x |
- if (length(ind) != 1L) {
+ setGeneric("content_table<-", function(obj, value) standardGeneric("content_table<-"))
|
| 186 |
- ## nocov start+ |
||
| 187 |
- stop(+ #' @exportMethod "content_table<-" |
||
| 188 |
- "table children do not appear to be named correctly at this ",+ #' @rdname int_methods |
||
| 189 |
- "path. This should not happen, please contact the maintainer of ",+ setMethod( |
||
| 190 |
- "rtables."+ "content_table<-", c("TableTree", "ElementaryTable"),
|
||
| 191 |
- )+ function(obj, value) {
|
||
| 192 | -+ | 6387x |
- ## nocov end+ obj@content <- value |
| 193 | -+ | 6387x |
- }+ obj |
| 194 | -2x | +
- if (after) {
+ } |
|
| 195 | -1x | +
- ind <- ind + 1+ ) |
|
| 196 |
- }+ |
||
| 197 |
-
+ #' @param for_analyze (`flag`) whether split is an analyze split. |
||
| 198 | -2x | +
- sq <- seq_along(kids)+ #' @rdname int_methods |
|
| 199 | -2x | +1139x |
- tree_children(subtt) <- c(+ setGeneric("next_rpos", function(obj, nested = TRUE, for_analyze = FALSE) standardGeneric("next_rpos"))
|
| 200 | -2x | +
- kids[sq < ind],+ |
|
| 201 | -2x | +
- setNames(list(value), obj_name(value)),+ #' @rdname int_methods |
|
| 202 | -2x | +
- kids[sq >= ind]+ setMethod( |
|
| 203 |
- )+ "next_rpos", "PreDataTableLayouts", |
||
| 204 | -2x | +
- tt_at_path(tt, path) <- subtt+ function(obj, nested, for_analyze = FALSE) next_rpos(rlayout(obj), nested, for_analyze = for_analyze) |
|
| 205 | -2x | +
- tt+ ) |
|
| 206 |
- }+ |
||
| 207 |
- )+ .check_if_nest <- function(obj, nested, for_analyze) {
|
||
| 208 | -+ | 258x |
- #' @rdname insert_row_at_path+ if (!nested) {
|
| 209 | -+ | 16x |
- setMethod(+ FALSE |
| 210 |
- "insert_row_at_path", c("VTableTree", "ANY"),
+ } else {
|
||
| 211 |
- function(tt, path, value) {
+ ## can always nest analyze splits (almost? what about colvars noncolvars mixing? prolly ok?) |
||
| 212 | -! | +242x |
- stop(+ for_analyze || |
| 213 | -! | +
- "Currently only insertion of DataRow objects is supported. Got ",+ ## If its not an analyze split it can't go under an analyze split |
|
| 214 | -! | +242x |
- "object of class ", class(value), ". Please use rrow() or DataRow() ",+ !(is(last_rowsplit(obj), "VAnalyzeSplit") || |
| 215 | -! | +242x |
- "to construct your row before insertion."+ is(last_rowsplit(obj), "AnalyzeMultiVars")) ## should this be CompoundSplit? # nolint |
| 216 |
- )+ } |
||
| 217 |
- }+ } |
||
| 218 |
- )+ |
||
| 219 |
-
+ #' @rdname int_methods |
||
| 220 |
- #' Label at path+ setMethod( |
||
| 221 |
- #'+ "next_rpos", "PreDataRowLayout", |
||
| 222 |
- #' Accesses or sets the label at a path.+ function(obj, nested, for_analyze) {
|
||
| 223 | -+ | 569x |
- #'+ l <- length(obj) |
| 224 | -+ | 569x |
- #' @inheritParams gen_args+ if (length(obj[[l]]) > 0L && !.check_if_nest(obj, nested, for_analyze)) {
|
| 225 | -+ | 25x |
- #'+ l <- l + 1L |
| 226 |
- #' @details+ } |
||
| 227 | -+ | 569x |
- #' If `path` resolves to a single row, the label for that row is retrieved or set. If, instead, `path` resolves to a+ l |
| 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.+ #' @rdname int_methods |
||
| 232 | -+ | 1x |
- #'+ setMethod("next_rpos", "ANY", function(obj, nested) 1L)
|
| 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+ #' @rdname int_methods |
||
| 235 | -+ | 645x |
- #' determining the full paths to content rows.+ setGeneric("next_cpos", function(obj, nested = TRUE) standardGeneric("next_cpos"))
|
| 236 |
- #'+ |
||
| 237 |
- #' @examples+ #' @rdname int_methods |
||
| 238 |
- #' lyt <- basic_table() %>%+ setMethod( |
||
| 239 |
- #' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
+ "next_cpos", "PreDataTableLayouts", |
||
| 240 |
- #' analyze("AGE")
+ function(obj, nested) next_cpos(clayout(obj), nested) |
||
| 241 |
- #'+ ) |
||
| 242 |
- #' tbl <- build_table(lyt, DM)+ |
||
| 243 |
- #'+ #' @rdname int_methods |
||
| 244 |
- #' label_at_path(tbl, c("COUNTRY", "CHN"))
+ setMethod( |
||
| 245 |
- #'+ "next_cpos", "PreDataColLayout", |
||
| 246 |
- #' label_at_path(tbl, c("COUNTRY", "USA")) <- "United States"
+ function(obj, nested) {
|
||
| 247 | -+ | 322x |
- #' tbl+ if (nested || length(obj[[length(obj)]]) == 0) {
|
| 248 | -+ | 314x |
- #'+ length(obj) |
| 249 |
- #' @export+ } else {
|
||
| 250 | -+ | 8x |
- label_at_path <- function(tt, path) {
+ length(obj) + 1L |
| 251 | -29x | +
- obj_label(tt_at_path(tt, path))+ } |
|
| 252 |
- }+ } |
||
| 253 |
-
+ ) |
||
| 254 |
- #' @export+ |
||
| 255 |
- #' @rdname label_at_path+ #' @rdname int_methods |
||
| 256 |
- `label_at_path<-` <- function(tt, path, value) {
+ setMethod("next_cpos", "ANY", function(obj, nested) 1L)
|
||
| 257 | -32x | +
- if (!is(tt, "VTableTree")) {
+
|
|
| 258 | -! | +
- stop("tt must be a TableTree or ElementaryTable object")
+ #' @rdname int_methods |
|
| 259 | -+ | 2660x |
- }+ setGeneric("last_rowsplit", function(obj) standardGeneric("last_rowsplit"))
|
| 260 | -32x | +
- if (is.null(value) || is.na(value)) {
+
|
|
| 261 | -1x | +
- value <- NA_character_+ #' @rdname int_methods |
|
| 262 |
- }+ setMethod( |
||
| 263 | -32x | +
- subt <- tt_at_path(tt, path)+ "last_rowsplit", "NULL", |
|
| 264 | -32x | +! |
- obj_label(subt) <- value+ function(obj) NULL |
| 265 | -32x | +
- tt_at_path(tt, path) <- subt+ ) |
|
| 266 | -32x | +
- tt+ |
|
| 267 |
- }+ #' @rdname int_methods |
||
| 268 |
-
+ setMethod( |
||
| 269 |
- #' Access or set table elements at specified path+ "last_rowsplit", "SplitVector", |
||
| 270 |
- #'+ function(obj) {
|
||
| 271 | -+ | 1042x |
- #' @inheritParams gen_args+ if (length(obj) == 0) {
|
| 272 | -+ | 230x |
- #' @param ... unused.+ NULL |
| 273 |
- #'+ } else {
|
||
| 274 | -+ | 812x |
- #' @export+ obj[[length(obj)]] |
| 275 |
- #' @rdname ttap+ } |
||
| 276 | -348x | +
- setGeneric("tt_at_path", function(tt, path, ...) standardGeneric("tt_at_path"))
+ } |
|
| 277 |
-
+ ) |
||
| 278 |
- #' @inheritParams tt_at_path+ |
||
| 279 |
- #'+ #' @rdname int_methods |
||
| 280 |
- #' @export+ setMethod( |
||
| 281 |
- #' @rdname int_methods+ "last_rowsplit", "PreDataRowLayout", |
||
| 282 |
- setMethod(+ function(obj) {
|
||
| 283 | -+ | 1042x |
- "tt_at_path", "VTableTree",+ if (length(obj) == 0) {
|
| 284 | -+ | ! |
- function(tt, path, ...) {
+ NULL |
| 285 | -348x | +
- stopifnot(+ } else {
|
|
| 286 | -348x | +1042x |
- is(path, "character"),+ last_rowsplit(obj[[length(obj)]]) |
| 287 | -348x | +
- length(path) > 0,+ } |
|
| 288 | -348x | +
- !anyNA(path)+ } |
|
| 289 |
- )+ ) |
||
| 291 | -348x | +
- if (path[1] == "root" && obj_name(tt) != "root") {
+ #' @rdname int_methods |
|
| 292 | -3x | +
- path <- path[-1]+ setMethod( |
|
| 293 |
- }+ "last_rowsplit", "PreDataTableLayouts", |
||
| 294 | -+ | 574x |
- ## handle pathing that hits the root split by name+ function(obj) last_rowsplit(rlayout(obj)) |
| 295 | -348x | +
- if (obj_name(tt) == path[1]) {
+ ) |
|
| 296 | -318x | +
- path <- path[-1]+ |
|
| 297 |
- }+ # rlayout ---- |
||
| 298 | -348x | +
- cur <- tt+ ## TODO maybe export these? |
|
| 299 | -348x | +
- curpath <- path+ |
|
| 300 | -348x | +
- while (length(curpath > 0)) {
+ #' @rdname int_methods |
|
| 301 | -1163x | +3901x |
- kids <- tree_children(cur)+ setGeneric("rlayout", function(obj) standardGeneric("rlayout"))
|
| 302 | -1163x | +
- curname <- curpath[1]+ |
|
| 303 | -1163x | +
- if (curname == "@content") {
+ #' @rdname int_methods |
|
| 304 | -65x | +
- cur <- content_table(cur)+ setMethod( |
|
| 305 | -1098x | +
- } else if (curname %in% names(kids)) {
+ "rlayout", "PreDataTableLayouts", |
|
| 306 | -1097x | +3901x |
- cur <- kids[[curname]]+ function(obj) obj@row_layout |
| 307 |
- } else {
+ ) |
||
| 308 | -1x | +
- stop("Path appears invalid for this tree at step ", curname)
+
|
|
| 309 |
- }+ #' @rdname int_methods |
||
| 310 | -1162x | +! |
- curpath <- curpath[-1]+ setMethod("rlayout", "ANY", function(obj) PreDataRowLayout())
|
| 311 |
- }+ |
||
| 312 | -347x | +
- cur+ #' @rdname int_methods |
|
| 313 | -+ | 1740x |
- }+ setGeneric("rlayout<-", function(object, value) standardGeneric("rlayout<-"))
|
| 314 |
- )+ |
||
| 315 |
-
+ #' @rdname int_methods |
||
| 316 |
- #' @note Setting `NULL` at a defined path removes the corresponding sub-table.+ setMethod( |
||
| 317 |
- #'+ "rlayout<-", "PreDataTableLayouts", |
||
| 318 |
- #' @examples+ function(object, value) {
|
||
| 319 | -+ | 1740x |
- #' # Accessing sub table.+ object@row_layout <- value |
| 320 | -+ | 1740x |
- #' lyt <- basic_table() %>%+ object |
| 321 |
- #' split_cols_by("ARM") %>%
+ } |
||
| 322 |
- #' split_rows_by("SEX") %>%
+ ) |
||
| 323 |
- #' split_rows_by("BMRKR2") %>%
+
|
||
| 324 |
- #' analyze("AGE")
+ #' @rdname int_methods |
||
| 325 | -+ | 64201x |
- #'+ setGeneric("tree_pos", function(obj) standardGeneric("tree_pos"))
|
| 326 |
- #' tbl <- build_table(lyt, ex_adsl) %>% prune_table()+ |
||
| 327 |
- #' sub_tbl <- tt_at_path(tbl, path = c("SEX", "F", "BMRKR2"))
+ ## setMethod("tree_pos", "VNodeInfo",
|
||
| 328 |
- #'+ ## function(obj) obj@pos_in_tree) |
||
| 329 |
- #' # Removing sub table.+ |
||
| 330 |
- #' tbl2 <- tbl+ #' @rdname int_methods |
||
| 331 |
- #' tt_at_path(tbl2, path = c("SEX", "F")) <- NULL
+ setMethod( |
||
| 332 |
- #' tbl2+ "tree_pos", "VLayoutNode", |
||
| 333 | -+ | ! |
- #'+ function(obj) obj@pos_in_tree |
| 334 |
- #' # Setting sub table.+ ) |
||
| 335 |
- #' lyt3 <- basic_table() %>%+ |
||
| 336 |
- #' split_cols_by("ARM") %>%
+ #' @rdname int_methods |
||
| 337 | -+ | 1422x |
- #' split_rows_by("SEX") %>%
+ setGeneric("pos_subset", function(obj) standardGeneric("pos_subset"))
|
| 338 |
- #' analyze("BMRKR2")
+
|
||
| 339 |
- #'+ #' @rdname int_methods |
||
| 340 |
- #' tbl3 <- build_table(lyt3, ex_adsl) %>% prune_table()+ setMethod( |
||
| 341 |
- #'+ "pos_subset", "TreePos", |
||
| 342 | -+ | 1422x |
- #' tt_at_path(tbl3, path = c("SEX", "F", "BMRKR2")) <- sub_tbl
+ function(obj) obj@subset |
| 343 |
- #' tbl3+ ) |
||
| 344 |
- #'+ |
||
| 345 |
- #' @export+ #' @rdname int_methods |
||
| 346 | -+ | 101x |
- #' @rdname ttap+ setGeneric("tree_pos<-", function(obj, value) standardGeneric("tree_pos<-"))
|
| 347 |
- setGeneric(+ |
||
| 348 |
- "tt_at_path<-",+ #' @rdname int_methods |
||
| 349 | -168x | +
- function(tt, path, ..., value) standardGeneric("tt_at_path<-")
+ setMethod( |
|
| 350 |
- )+ "tree_pos<-", "VLayoutNode", |
||
| 351 |
-
+ function(obj, value) {
|
||
| 352 | -+ | 101x |
- #' @export+ obj@pos_in_tree <- value |
| 353 | -+ | 101x |
- #' @keywords internal+ obj |
| 354 |
- #' @rdname int_methods+ } |
||
| 355 |
- setMethod(+ ) |
||
| 356 |
- "tt_at_path<-", c(tt = "VTableTree", value = "VTableTree"),+ |
||
| 357 |
- function(tt, path, ..., value) {
+ ## setMethod("pos_subset", "VNodeInfo",
|
||
| 358 | -78x | +
- do_recursive_replace(tt, path = path, value = value)+ ## function(obj) pos_subset(tree_pos(obj))) |
|
| 359 |
- }+ |
||
| 360 |
- )+ #' @rdname int_methods |
||
| 361 |
-
+ setMethod( |
||
| 362 |
- ## this one removes the child at path from the parents list of children,+ "pos_subset", "VLayoutNode", |
||
| 363 | -+ | ! |
- ## because that is how lists behave.+ function(obj) pos_subset(tree_pos(obj)) |
| 364 |
- #' @export+ ) |
||
| 365 |
- #' @keywords internal+ |
||
| 367 | -+ | 52225x |
- setMethod(+ setGeneric("pos_splits", function(obj) standardGeneric("pos_splits"))
|
| 368 |
- "tt_at_path<-", c(tt = "VTableTree", value = "NULL"),+ |
||
| 369 |
- function(tt, path, ..., value) {
+ #' @rdname int_methods |
||
| 370 | -2x | +
- do_recursive_replace(tt, path = path, value = value)+ setMethod( |
|
| 371 |
- }+ "pos_splits", "TreePos", |
||
| 372 | -+ | 52225x |
- )+ function(obj) obj@splits |
| 373 |
-
+ ) |
||
| 374 |
- #' @export+ |
||
| 375 |
- #' @keywords internal+ ## setMethod("pos_splits", "VNodeInfo",
|
||
| 376 |
- #' @rdname int_methods+ ## function(obj) pos_splits(tree_pos(obj))) |
||
| 377 |
- setMethod(+ |
||
| 378 |
- "tt_at_path<-", c(tt = "VTableTree", value = "TableRow"),+ #' @rdname int_methods |
||
| 379 |
- function(tt, path, ..., value) {
+ setMethod( |
||
| 380 | -88x | +
- stopifnot(is(tt_at_path(tt = tt, path = path), "TableRow"))+ "pos_splits", "VLayoutNode", |
|
| 381 | -88x | +! |
- do_recursive_replace(tt, path = path, value = value)+ function(obj) pos_splits(tree_pos(obj)) |
| 382 |
-
+ ) |
||
| 383 |
- ## ##i <- .path_to_pos(path = path, seq_len(nrow(tt)), tt, NROW)+ |
||
| 384 |
- ## i <- .path_to_pos(path = path, tt = tt)+ #' @rdname int_methods |
||
| 385 | -+ | 101x |
-
+ setGeneric("pos_splits<-", function(obj, value) standardGeneric("pos_splits<-"))
|
| 386 |
- ## replace_rows(tt, i = i, value = list(value))+ |
||
| 387 |
- }+ #' @rdname int_methods |
||
| 388 |
- )+ setMethod( |
||
| 389 |
-
+ "pos_splits<-", "TreePos", |
||
| 390 |
- #' Retrieve and assign elements of a `TableTree`+ function(obj, value) {
|
||
| 391 | -+ | 101x |
- #'+ obj@splits <- value |
| 392 | -+ | 101x |
- #' @param x (`TableTree`)\cr a `TableTree` object.+ obj |
| 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+ #' @rdname int_methods |
||
| 397 |
- #' [cell_values()]. Defaults to `FALSE`.+ setMethod( |
||
| 398 |
- #' @param ... additional arguments. Includes:+ "pos_splits<-", "VLayoutNode", |
||
| 399 |
- #' \describe{
+ function(obj, value) {
|
||
| 400 | -+ | ! |
- #' \item{`keep_topleft`}{(`flag`) (`[` only) whether the top-left material for the table should be retained after
+ pos <- tree_pos(obj) |
| 401 | -+ | ! |
- #' subsetting. Defaults to `TRUE` if all rows are included (i.e. subsetting was by column), and drops it+ pos_splits(pos) <- value |
| 402 | -+ | ! |
- #' otherwise.}+ tree_pos(obj) <- pos |
| 403 | -+ | ! |
- #' \item{`keep_titles`}{(`flag`) whether title information should be retained. Defaults to `FALSE`.}
+ obj |
| 404 | -+ | ! |
- #' \item{`keep_footers`}{(`flag`) whether non-referential footer information should be retained. Defaults to
+ obj |
| 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+ #' @rdname int_methods |
||
| 412 | -+ | 58608x |
- #' By default, subsetting drops the information about title, subtitle, main footer, provenance footer, and `topleft`.+ setGeneric("pos_splvals", function(obj) standardGeneric("pos_splvals"))
|
| 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.+ #' @rdname int_methods |
||
| 415 |
- #'+ setMethod( |
||
| 416 |
- #' @return A `TableTree` (or `ElementaryTable`) object, unless a single cell was selected with `drop = TRUE`, in which+ "pos_splvals", "TreePos", |
||
| 417 | -+ | 58608x |
- #' case the (possibly multi-valued) fully stripped raw value of the selected cell.+ function(obj) obj@s_values |
| 418 |
- #'+ ) |
||
| 419 |
- #' @note+ |
||
| 420 |
- #' Subsetting always preserve the original order, even if provided indexes do not preserve it. If sorting is needed,+ ## setMethod("pos_splvals", "VNodeInfo",
|
||
| 421 |
- #' please consider using `sort_at_path()`. Also note that `character` indices are treated as paths, not vectors of+ ## function(obj) pos_splvals(tree_pos(obj))) |
||
| 422 |
- #' names in both `[` and `[<-`.+ |
||
| 423 |
- #'+ #' @rdname int_methods |
||
| 424 |
- #' @seealso+ setMethod( |
||
| 425 |
- #' * [sort_at_path()] to understand sorting.+ "pos_splvals", "VLayoutNode", |
||
| 426 | -+ | ! |
- #' * [summarize_row_groups()] to understand path structure.+ function(obj) pos_splvals(tree_pos(obj)) |
| 427 |
- #'+ ) |
||
| 428 |
- #' @examples+ |
||
| 429 |
- #' lyt <- basic_table(+ #' @rdname int_methods |
||
| 430 | -+ | 101x |
- #' title = "Title",+ setGeneric("pos_splvals<-", function(obj, value) standardGeneric("pos_splvals<-"))
|
| 431 |
- #' subtitles = c("Sub", "titles"),
+
|
||
| 432 |
- #' prov_footer = "prov footer",+ #' @rdname int_methods |
||
| 433 |
- #' main_footer = "main footer"+ setMethod( |
||
| 434 |
- #' ) %>%+ "pos_splvals<-", "TreePos", |
||
| 435 |
- #' split_cols_by("ARM") %>%
+ function(obj, value) {
|
||
| 436 | -+ | 101x |
- #' split_rows_by("SEX") %>%
+ obj@s_values <- value |
| 437 | -+ | 101x |
- #' analyze(c("AGE"))
+ obj |
| 438 |
- #'+ } |
||
| 439 |
- #' tbl <- build_table(lyt, DM)+ ) |
||
| 440 |
- #' top_left(tbl) <- "Info"+ |
||
| 441 |
- #' tbl+ ## setMethod("pos_splvals", "VNodeInfo",
|
||
| 442 |
- #'+ ## function(obj) pos_splvals(tree_pos(obj))) |
||
| 443 |
- #' # As default header, footer, and topleft information is lost+ |
||
| 444 |
- #' tbl[1, ]+ #' @rdname int_methods |
||
| 445 |
- #' tbl[1:2, 2]+ setMethod( |
||
| 446 |
- #'+ "pos_splvals<-", "VLayoutNode", |
||
| 447 |
- #' # Also boolean filters can work+ function(obj, value) {
|
||
| 448 | -+ | ! |
- #' tbl[, c(FALSE, TRUE, FALSE)]+ pos <- tree_pos(obj) |
| 449 | -+ | ! |
- #'+ pos_splvals(pos) <- value |
| 450 | -+ | ! |
- #' # If drop = TRUE, the content values are directly retrieved+ tree_pos(obj) <- pos |
| 451 | -+ | ! |
- #' tbl[2, 1]+ obj |
| 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]+ #' @rdname int_methods |
||
| 457 | -+ | 1422x |
- #' tbl[1, 1, drop = TRUE] # NULL because it is a label row+ setGeneric("pos_splval_labels", function(obj) standardGeneric("pos_splval_labels"))
|
| 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+ #' @rdname int_methods |
||
| 460 |
- #'+ setMethod( |
||
| 461 |
- #' # If all rows are selected, topleft is kept by default+ "pos_splval_labels", "TreePos", |
||
| 462 | -+ | 1422x |
- #' tbl[, 2]+ function(obj) obj@sval_labels |
| 463 |
- #' tbl[, 1]+ ) |
||
| 464 |
- #'+ ## no longer used |
||
| 465 |
- #' # It is possible to deselect values+ |
||
| 466 |
- #' tbl[-2, ]+ ## setMethod("pos_splval_labels", "VNodeInfo",
|
||
| 467 |
- #' tbl[, -1]+ ## function(obj) pos_splval_labels(tree_pos(obj))) |
||
| 468 |
- #'+ ## #' @rdname int_methods |
||
| 469 |
- #' # Values can be reassigned+ ## setMethod("pos_splval_labels", "VLayoutNode",
|
||
| 470 |
- #' tbl[2, 1] <- rcell(999)+ ## function(obj) pos_splval_labels(tree_pos(obj))) |
||
| 471 |
- #' tbl[2, ] <- list(rrow("FFF", 888, 666, 777))
+
|
||
| 472 |
- #' tbl[6, ] <- list(-111, -222, -333)+ #' @rdname int_methods |
||
| 473 | -+ | 15374x |
- #' tbl+ setGeneric("spl_payload", function(obj) standardGeneric("spl_payload"))
|
| 474 |
- #'+ |
||
| 475 |
- #' # We can keep some information from the original table if we need+ #' @rdname int_methods |
||
| 476 | -+ | 15374x |
- #' tbl[1, 2, keep_titles = TRUE]+ setMethod("spl_payload", "Split", function(obj) obj@payload)
|
| 477 |
- #' tbl[1, 2, keep_footers = TRUE, keep_titles = FALSE]+ |
||
| 478 |
- #' tbl[1, 2, keep_footers = FALSE, keep_titles = TRUE]+ #' @rdname int_methods |
||
| 479 | -+ | 3x |
- #' tbl[1, 2, keep_footers = TRUE]+ setGeneric("spl_payload<-", function(obj, value) standardGeneric("spl_payload<-"))
|
| 480 |
- #' tbl[1, 2, keep_topleft = TRUE]+ |
||
| 481 |
- #'+ #' @rdname int_methods |
||
| 482 |
- #' # Keeps the referential footnotes when subset contains them+ setMethod("spl_payload<-", "Split", function(obj, value) {
|
||
| 483 | -+ | 3x |
- #' fnotes_at_path(tbl, rowpath = c("SEX", "M", "AGE", "Mean")) <- "important"
+ obj@payload <- value |
| 484 | -+ | 3x |
- #' tbl[4, 1]+ obj |
| 485 |
- #' tbl[2, 1] # None present+ }) |
||
| 486 |
- #'+ |
||
| 487 |
- #' # We can reindex referential footnotes, so that the new table does not depend+ #' @rdname int_methods |
||
| 488 | -+ | 732x |
- #' # on the original one+ setGeneric("spl_label_var", function(obj) standardGeneric("spl_label_var"))
|
| 489 |
- #' fnotes_at_path(tbl, rowpath = c("SEX", "U", "AGE", "Mean")) <- "important"
+
|
||
| 490 |
- #' tbl[, 1] # both present+ #' @rdname int_methods |
||
| 491 | -+ | 729x |
- #' tbl[5:6, 1] # {1} because it has been indexed again
+ setMethod("spl_label_var", "VarLevelSplit", function(obj) obj@value_label_var)
|
| 492 |
- #' tbl[5:6, 1, reindex_refs = FALSE] # {2} -> not reindexed
+
|
||
| 493 |
- #'+ ## TODO revisit. do we want to do this? used in vars_in_layout, but only |
||
| 494 |
- #' # Note that order can not be changed with subsetting+ ## for convenience. |
||
| 495 |
- #' tbl[c(4, 3, 1), c(3, 1)] # It preserves order and wanted selection+ #' @rdname int_methods |
||
| 496 | -+ | 3x |
- #'+ setMethod("spl_label_var", "Split", function(obj) NULL)
|
| 497 |
- #' @name brackets+ |
||
| 498 |
- NULL+ ### name related things |
||
| 499 |
-
+ # #' @inherit formatters::formatter_methods |
||
| 500 |
- #' @exportMethod [<-+ #' Methods for generics in the `formatters` package |
||
| 501 |
- #' @rdname brackets+ #' |
||
| 502 |
- setMethod(+ #' See the `formatters` documentation for descriptions of these generics. |
||
| 503 |
- "[<-", c("VTableTree", value = "list"),
+ #' |
||
| 504 |
- function(x, i, j, ..., value) {
+ #' @inheritParams gen_args |
||
| 505 | -3x | +
- nr <- nrow(x)+ #' |
|
| 506 | -3x | +
- if (missing(i)) {
+ #' @return |
|
| 507 | -! | +
- i <- seq_len(NROW(x))+ #' * Accessor functions return the current value of the component being accessed of `obj` |
|
| 508 | -3x | +
- } else if (is(i, "character")) {
+ #' * Setter functions return a modified copy of `obj` with the new value. |
|
| 509 | -! | +
- i <- .path_to_pos(i, x)+ #' |
|
| 510 |
- } else {
+ #' @rdname formatters_methods |
||
| 511 | -3x | +
- i <- .j_to_posj(i, nr)+ #' @aliases formatters_methods |
|
| 512 |
- }+ #' @exportMethod obj_name |
||
| 513 |
-
+ setMethod( |
||
| 514 | -3x | +
- if (missing(j)) {
+ "obj_name", "VNodeInfo", |
|
| 515 | -1x | +46544x |
- j <- seq_along(col_exprs(col_info(x)))+ function(obj) obj@name |
| 516 | -2x | +
- } else if (is(j, "character")) {
+ ) |
|
| 517 | -! | +
- j <- .path_to_pos(j, x, cols = TRUE)+ |
|
| 518 |
- } else {
+ #' @rdname formatters_methods |
||
| 519 | -2x | +
- j <- .j_to_posj(j, ncol(x))+ #' @exportMethod obj_name |
|
| 520 |
- }+ setMethod( |
||
| 521 |
-
+ "obj_name", "Split", |
||
| 522 | -3x | +114141x |
- if (length(i) > 1 && length(j) < ncol(x)) {
+ function(obj) obj@name |
| 523 | -! | +
- stop("cannot modify multiple rows in not all columns.")
+ ) |
|
| 524 |
- }+ |
||
| 525 |
-
+ #' @rdname formatters_methods |
||
| 526 | -3x | +
- if (are(value, "TableRow")) {
+ #' @exportMethod obj_name<- |
|
| 527 | -1x | +
- value <- rep(value, length.out = length(i))+ setMethod( |
|
| 528 |
- } else {
+ "obj_name<-", "VNodeInfo", |
||
| 529 | -2x | +
- value <- rep(value, length.out = length(i) * length(j))+ function(obj, value) {
|
|
| 530 | -+ | 21x |
- }+ obj@name <- value |
| 531 | -+ | 21x |
-
+ obj |
| 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)+ #' @rdname formatters_methods |
|
| 536 | -16x | +
- if (counter >= maxi) {
+ #' @exportMethod obj_name<- |
|
| 537 | -! | +
- return(valifnone)+ setMethod( |
|
| 538 |
- }+ "obj_name<-", "Split", |
||
| 539 |
-
+ function(obj, value) {
|
||
| 540 | -16x | +3x |
- if (labelrow_visible(x)) {
+ obj@name <- value |
| 541 | 3x |
- counter <<- counter + 1+ obj |
|
| 542 | -3x | +
- if (counter %in% i) {
+ } |
|
| 543 | -1x | +
- nxtval <- value[[1]]+ ) |
|
| 544 | -1x | +
- if (is(nxtval, "LabelRow")) {
+
|
|
| 545 | -1x | +
- tt_labelrow(x) <- nxtval+ ### Label related things |
|
| 546 |
- } else {
+ #' @rdname formatters_methods |
||
| 547 | -! | +
- stop(+ #' @exportMethod obj_label |
|
| 548 | -! | +2158x |
- "can't replace label with value of class",+ setMethod("obj_label", "Split", function(obj) obj@split_label)
|
| 549 | -! | +
- class(nxtval)+ |
|
| 550 |
- )+ #' @rdname formatters_methods |
||
| 551 |
- }+ #' @exportMethod obj_label |
||
| 552 | -+ | 40418x |
- ## we're done with this one move to+ setMethod("obj_label", "TableRow", function(obj) obj@label)
|
| 553 |
- ## the next+ |
||
| 554 | -1x | +
- value <<- value[-1]+ ## XXX Do we want a convenience for VTableTree that |
|
| 555 |
- }+ ## grabs the label from the LabelRow or will |
||
| 556 |
- }+ ## that just muddy the waters? |
||
| 557 | -16x | +
- if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
+ #' @rdname formatters_methods |
|
| 558 | -3x | +
- ctab <- content_table(x)+ #' @exportMethod obj_label |
|
| 559 |
-
+ setMethod( |
||
| 560 | -3x | +
- content_table(x) <- replace_rowsbynum(ctab, i)+ "obj_label", "VTableTree", |
|
| 561 | -+ | 308x |
- }+ function(obj) obj_label(tt_labelrow(obj)) |
| 562 | -16x | +
- if (counter >= maxi) { # already done
+ ) |
|
| 563 | -2x | +
- return(x)+ |
|
| 564 |
- }+ #' @rdname formatters_methods |
||
| 565 | -14x | +
- kids <- tree_children(x)+ #' @exportMethod obj_label |
|
| 566 | -+ | ! |
-
+ setMethod("obj_label", "ValueWrapper", function(obj) obj@label)
|
| 567 | -14x | +
- if (length(kids) > 0) {
+
|
|
| 568 | -14x | +
- for (pos in seq_along(kids)) {
+ #' @rdname formatters_methods |
|
| 569 | -17x | +
- curkid <- kids[[pos]]+ #' @exportMethod obj_label<- |
|
| 570 | -17x | +
- if (is(curkid, "TableRow")) {
+ setMethod( |
|
| 571 | -7x | +
- counter <<- counter + 1+ "obj_label<-", "Split", |
|
| 572 | -7x | +
- if (counter %in% i) {
+ function(obj, value) {
|
|
| 573 | -3x | +1x |
- nxtval <- value[[1]]+ obj@split_label <- value |
| 574 | -3x | +1x |
- if (is(nxtval, class(curkid))) {
+ obj |
| 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)))+ #' @rdname formatters_methods |
|
| 579 | -1x | +
- curkid <- nxtval+ #' @exportMethod obj_label<- |
|
| 580 | -1x | +
- value <- value[-1]+ setMethod( |
|
| 581 |
- } else {
+ "obj_label<-", "TableRow", |
||
| 582 | -2x | +
- rvs <- row_values(curkid)+ function(obj, value) {
|
|
| 583 | -2x | +32x |
- rvs[j] <- value[seq_along(j)]+ obj@label <- value |
| 584 | -2x | +32x |
- row_values(curkid) <- rvs+ obj |
| 585 | -2x | +
- value <- value[-(seq_along(j))]+ } |
|
| 586 |
- }+ ) |
||
| 587 | -3x | +
- kids[[pos]] <- curkid+ |
|
| 588 |
- }+ #' @rdname formatters_methods |
||
| 589 |
- } else {
+ #' @exportMethod obj_label<- |
||
| 590 | -10x | +
- kids[[pos]] <- replace_rowsbynum(curkid, i)+ setMethod( |
|
| 591 |
- }+ "obj_label<-", "ValueWrapper", |
||
| 592 | -17x | +
- if (counter >= maxi) {
+ function(obj, value) {
|
|
| 593 | -7x | +! |
- break+ obj@label <- value |
| 594 | -+ | ! |
- }+ obj |
| 595 |
- }+ } |
||
| 596 |
- }+ ) |
||
| 597 | -14x | +
- tree_children(x) <- kids+ |
|
| 598 | -14x | +
- x+ #' @rdname formatters_methods |
|
| 599 |
- }+ #' @exportMethod obj_label<- |
||
| 600 | -3x | +
- replace_rowsbynum(x, i, ...)+ setMethod( |
|
| 601 |
- }+ "obj_label<-", "VTableTree", |
||
| 602 |
- )+ function(obj, value) {
|
||
| 603 | -+ | 11x |
-
+ lr <- tt_labelrow(obj) |
| 604 | -+ | 11x |
- #' @inheritParams brackets+ obj_label(lr) <- value |
| 605 | -+ | 11x |
- #'+ if (!is.na(value) && nzchar(value)) {
|
| 606 | -+ | 10x |
- #' @exportMethod [<-+ labelrow_visible(lr) <- TRUE |
| 607 | -+ | 1x |
- #' @rdname int_methods+ } else if (is.na(value)) {
|
| 608 | -+ | 1x |
- #' @keywords internal+ labelrow_visible(lr) <- FALSE |
| 609 |
- setMethod(+ } |
||
| 610 | -+ | 11x |
- "[<-", c("VTableTree", value = "CellValue"),
+ tt_labelrow(obj) <- lr |
| 611 | -+ | 11x |
- function(x, i, j, ..., value) {
+ obj |
| 612 | -1x | +
- x[i = i, j = j, ...] <- list(value)+ } |
|
| 613 | -1x | +
- x+ ) |
|
| 614 |
- }+ |
||
| 615 |
- )+ ### Label rows. |
||
| 616 |
-
+ #' @rdname int_methods |
||
| 617 | -+ | 130261x |
- ## this is going to be hard :( :( :(+ setGeneric("tt_labelrow", function(obj) standardGeneric("tt_labelrow"))
|
| 619 |
- ### selecting/removing columns+ #' @rdname int_methods |
||
| 620 |
-
+ setMethod( |
||
| 621 |
- ## we have two options here: path like we do with rows and positional+ "tt_labelrow", "VTableTree", |
||
| 622 | -+ | 46312x |
- ## in leaf space.+ function(obj) obj@labelrow |
| 623 |
-
+ ) |
||
| 624 |
- setGeneric(+ |
||
| 625 |
- "subset_cols",+ #' @rdname int_methods |
||
| 626 | -+ | 4095x |
- function(tt,+ setGeneric("tt_labelrow<-", function(obj, value) standardGeneric("tt_labelrow<-"))
|
| 627 |
- j,+ |
||
| 628 |
- newcinfo = NULL,+ #' @rdname int_methods |
||
| 629 |
- keep_topleft = TRUE,+ setMethod( |
||
| 630 |
- keep_titles = TRUE,+ "tt_labelrow<-", c("VTableTree", "LabelRow"),
|
||
| 631 |
- keep_footers = keep_titles,+ function(obj, value) {
|
||
| 632 | -+ | 4095x |
- ...) {
+ if (no_colinfo(value)) {
|
| 633 | -9970x | +1x |
- standardGeneric("subset_cols")
+ col_info(value) <- col_info(obj) |
| 634 |
- }+ } |
||
| 635 | -+ | 4095x |
- )+ obj@labelrow <- value |
| 636 | -+ | 4095x |
-
+ obj |
| 637 |
- setMethod(+ } |
||
| 638 |
- "subset_cols", c("TableTree", "numeric"),
+ ) |
||
| 639 |
- function(tt, j, newcinfo = NULL,+ |
||
| 640 |
- keep_topleft, keep_titles, keep_footers, ...) {
+ #' @rdname int_methods |
||
| 641 | -867x | +197189x |
- j <- .j_to_posj(j, ncol(tt))+ setGeneric("labelrow_visible", function(obj) standardGeneric("labelrow_visible"))
|
| 642 | -867x | +
- if (is.null(newcinfo)) {
+
|
|
| 643 | -161x | +
- cinfo <- col_info(tt)+ #' @rdname int_methods |
|
| 644 | -161x | +
- newcinfo <- subset_cols(cinfo, j,+ setMethod( |
|
| 645 | -161x | +
- keep_topleft = keep_topleft, ...+ "labelrow_visible", "VTableTree", |
|
| 646 |
- )+ function(obj) {
|
||
| 647 | -+ | 28286x |
- }+ labelrow_visible(tt_labelrow(obj)) |
| 648 |
- ## topleft taken care of in creation of newcinfo+ } |
||
| 649 | -867x | +
- kids <- tree_children(tt)+ ) |
|
| 650 | -867x | +
- newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...)+ |
|
| 651 | -867x | +
- cont <- content_table(tt)+ #' @rdname int_methods |
|
| 652 | -867x | +
- newcont <- subset_cols(cont, j, newcinfo = newcinfo, ...)+ setMethod( |
|
| 653 | -867x | +
- tt2 <- tt+ "labelrow_visible", "LabelRow", |
|
| 654 | -867x | +107388x |
- col_info(tt2) <- newcinfo+ function(obj) obj@visible |
| 655 | -867x | +
- content_table(tt2) <- newcont+ ) |
|
| 656 | -867x | +
- tree_children(tt2) <- newkids+ |
|
| 657 | -867x | +
- tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...)+ #' @rdname int_methods |
|
| 658 |
-
+ setMethod( |
||
| 659 | -867x | +
- tt2 <- .h_copy_titles_footers_topleft(+ "labelrow_visible", "VAnalyzeSplit", |
|
| 660 | -867x | +1423x |
- tt2, tt,+ function(obj) .labelkids_helper(obj@var_label_position) |
| 661 | -867x | +
- keep_titles,+ ) |
|
| 662 | -867x | +
- keep_footers,+ |
|
| 663 | -867x | +
- keep_topleft+ #' @rdname int_methods |
|
| 664 | -+ | 2960x |
- )+ setGeneric("labelrow_visible<-", function(obj, value) standardGeneric("labelrow_visible<-"))
|
| 665 | -867x | +
- tt2+ |
|
| 666 |
- }+ #' @rdname int_methods |
||
| 667 |
- )+ setMethod( |
||
| 668 |
-
+ "labelrow_visible<-", "VTableTree", |
||
| 669 |
- setMethod(+ function(obj, value) {
|
||
| 670 | -+ | 1341x |
- "subset_cols", c("ElementaryTable", "numeric"),
+ lr <- tt_labelrow(obj) |
| 671 | -+ | 1341x |
- function(tt, j, newcinfo = NULL,+ labelrow_visible(lr) <- value |
| 672 | -+ | 1341x |
- keep_topleft, keep_titles, keep_footers, ...) {
+ tt_labelrow(obj) <- lr |
| 673 | -1829x | +1341x |
- j <- .j_to_posj(j, ncol(tt))+ obj |
| 674 | -1829x | +
- if (is.null(newcinfo)) {
+ } |
|
| 675 | -97x | +
- cinfo <- col_info(tt)+ ) |
|
| 676 | -97x | +
- newcinfo <- subset_cols(cinfo, j,+ |
|
| 677 | -97x | +
- keep_topleft = keep_topleft,+ #' @rdname int_methods |
|
| 678 | -97x | +
- keep_titles = keep_titles,+ setMethod( |
|
| 679 | -97x | +
- keep_footers = keep_footers, ...+ "labelrow_visible<-", "LabelRow", |
|
| 680 |
- )+ function(obj, value) {
|
||
| 681 | -+ | 1352x |
- }+ obj@visible <- value |
| 682 | -+ | 1352x |
- ## topleft handled in creation of newcinfo+ obj |
| 683 | -1829x | +
- kids <- tree_children(tt)+ } |
|
| 684 | -1829x | +
- newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...)+ ) |
|
| 685 | -1829x | +
- tt2 <- tt+ |
|
| 686 | -1829x | +
- col_info(tt2) <- newcinfo+ #' @rdname int_methods |
|
| 687 | -1829x | +
- tree_children(tt2) <- newkids+ setMethod( |
|
| 688 | -1829x | +
- tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...)+ "labelrow_visible<-", "VAnalyzeSplit", |
|
| 689 | -1829x | +
- tt2 <- .h_copy_titles_footers_topleft(+ function(obj, value) {
|
|
| 690 | -1829x | +267x |
- tt2, tt,+ obj@var_label_position <- value |
| 691 | -1829x | +267x |
- keep_titles,+ obj |
| 692 | -1829x | +
- keep_footers,+ } |
|
| 693 | -1829x | +
- keep_topleft+ ) |
|
| 694 |
- )+ |
||
| 695 | -1829x | +
- tt2+ ## TRUE is always, FALSE is never, NA is only when no |
|
| 696 |
- }+ ## content function (or rows in an instantiated table) is present |
||
| 697 |
- )+ #' @rdname int_methods |
||
| 698 | -+ | 1554x |
-
+ setGeneric("label_kids", function(spl) standardGeneric("label_kids"))
|
| 699 |
- ## small utility to transform any negative+ |
||
| 700 |
- ## indices into positive ones, given j+ #' @rdname int_methods |
||
| 701 | -+ | 1554x |
- ## and total length+ setMethod("label_kids", "Split", function(spl) spl@label_children)
|
| 703 |
- .j_to_posj <- function(j, n) {
+ #' @rdname int_methods |
||
| 704 | -+ | 3x |
- ## This will work for logicals, numerics, integers+ setGeneric("label_kids<-", function(spl, value) standardGeneric("label_kids<-"))
|
| 705 | -15040x | +
- j <- seq_len(n)[j]+ |
|
| 706 | -15040x | +
- j+ #' @rdname int_methods |
|
| 707 |
- }+ setMethod("label_kids<-", c("Split", "character"), function(spl, value) {
|
||
| 708 | -+ | 1x |
-
+ label_kids(spl) <- .labelkids_helper(value) |
| 709 | -+ | 1x |
- path_collapse_sep <- "`"+ spl |
| 710 |
- escape_name_padding <- function(x) {
+ }) |
||
| 711 | -141x | +
- ret <- gsub("._[[", "\\._\\[\\[", x, fixed = TRUE)
+
|
|
| 712 | -141x | +
- ret <- gsub("]]_.", "\\]\\]_\\.", ret, fixed = TRUE)
+ #' @rdname int_methods |
|
| 713 | -141x | +
- ret+ setMethod("label_kids<-", c("Split", "logical"), function(spl, value) {
|
|
| 714 | -+ | 2x |
- }+ spl@label_children <- value |
| 715 | -+ | 2x |
- path_to_regex <- function(path) {
+ spl |
| 716 | -51x | +
- paste(vapply(path, function(x) {
+ }) |
|
| 717 | -142x | +
- if (identical(x, "*")) {
+
|
|
| 718 | -1x | +
- paste0("[^", path_collapse_sep, "]+")
+ #' @rdname int_methods |
|
| 719 | -+ | 410x |
- } else {
+ setGeneric("vis_label", function(spl) standardGeneric("vis_label"))
|
| 720 | -141x | +
- escape_name_padding(x)+ |
|
| 721 |
- }+ #' @rdname int_methods |
||
| 722 | -51x | +
- }, ""), collapse = path_collapse_sep)+ setMethod("vis_label", "Split", function(spl) {
|
|
| 723 | -+ | 410x |
- }+ .labelkids_helper(label_position(spl)) |
| 724 |
-
+ }) |
||
| 725 |
- .path_to_pos <- function(path, tt, distinct_ok = TRUE, cols = FALSE) {
+
|
||
| 726 | -51x | +
- path <- path[!grepl("^(|root)$", path)]
+ ## #' @rdname int_methods |
|
| 727 | -51x | +
- if (cols) {
+ ## setGeneric("vis_label<-", function(spl, value) standardGeneric("vis_label<-"))
|
|
| 728 | -51x | +
- rowdf <- make_col_df(tt)+ ## #' @rdname int_methods |
|
| 729 |
- } else {
+ ## setMethod("vis_label<-", "Split", function(spl, value) {
|
||
| 730 | -! | +
- rowdf <- make_row_df(tt)+ ## stop("defunct")
|
|
| 731 |
- }+ ## if(is.na(value)) |
||
| 732 | -51x | +
- if (length(path) == 0 || identical(path, "*") || identical(path, "root")) {
+ ## stop("split label visibility must be TRUE or FALSE, got NA")
|
|
| 733 | -! | +
- return(seq(1, nrow(rowdf)))+ ## # spl@split_label_visible <- value |
|
| 734 |
- }+ ## spl |
||
| 735 |
-
+ ## }) |
||
| 736 | -51x | +
- paths <- rowdf$path+ |
|
| 737 | -51x | +
- pathregex <- path_to_regex(path)+ #' @rdname int_methods |
|
| 738 | -51x | +1055x |
- pathstrs <- vapply(paths, paste, "", collapse = path_collapse_sep)+ setGeneric("label_position", function(spl) standardGeneric("label_position"))
|
| 739 | -51x | +
- allmatchs <- grep(pathregex, pathstrs)+ |
|
| 740 | -51x | +
- if (length(allmatchs) == 0) {
+ #' @rdname int_methods |
|
| 741 | -! | +726x |
- stop(+ setMethod("label_position", "Split", function(spl) spl@split_label_position)
|
| 742 | -! | +
- if (cols) "column path [" else "row path [",+ |
|
| 743 | -! | +
- paste(path, collapse = "->"),+ #' @rdname int_methods |
|
| 744 | -! | +329x |
- "] does not appear valid for this table"+ setMethod("label_position", "VAnalyzeSplit", function(spl) spl@var_label_position) ## split_label_position)
|
| 745 |
- )+ |
||
| 746 |
- }+ #' @rdname int_methods |
||
| 747 | -+ | 50x |
-
+ setGeneric("label_position<-", function(spl, value) standardGeneric("label_position<-"))
|
| 748 | -51x | +
- idxdiffs <- diff(allmatchs)+ |
|
| 749 | -51x | +
- if (!distinct_ok && length(idxdiffs) > 0 && any(idxdiffs > 1)) {
+ #' @rdname int_methods |
|
| 750 | -! | +
- firstnon <- min(which(idxdiffs > 1))+ setMethod("label_position<-", "Split", function(spl, value) {
|
|
| 751 | -+ | 50x |
- ## its firstnon here because we would want firstnon-1 but+ value <- match.arg(value, valid_lbl_pos) |
| 752 | -+ | 50x |
- ## the diffs are actually shifted 1 so they cancel out+ spl@split_label_position <- value |
| 753 | -! | +50x |
- allmatchs <- allmatchs[seq(1, firstnon)]+ spl |
| 754 |
- }+ }) |
||
| 755 | -51x | +
- allmatchs+ |
|
| 756 |
- }+ ### Function accessors (summary, tabulation and split) ---- |
||
| 758 |
- ## fix column spans that would be invalid+ #' @rdname int_methods |
||
| 759 | -+ | 3376x |
- ## after some columns are no longer there+ setGeneric("content_fun", function(obj) standardGeneric("content_fun"))
|
| 760 |
- .fix_rowcspans <- function(rw, j) {
+
|
||
| 761 | -3974x | +
- cspans <- row_cspans(rw)+ #' @rdname int_methods |
|
| 762 | -3974x | +3324x |
- nc <- sum(cspans)+ setMethod("content_fun", "Split", function(obj) obj@content_fun)
|
| 763 | -3974x | +
- j <- .j_to_posj(j, nc)+ |
|
| 764 |
- ## this is overly complicated+ #' @rdname int_methods |
||
| 765 | -+ | 116x |
- ## we need the starting indices+ setGeneric("content_fun<-", function(object, value) standardGeneric("content_fun<-"))
|
| 766 |
- ## but the first span might not be 1, so+ |
||
| 767 |
- ## we pad with 1 and then take off the last+ #' @rdname int_methods |
||
| 768 | -3974x | +
- start <- cumsum(c(1, head(cspans, -1)))+ setMethod("content_fun<-", "Split", function(object, value) {
|
|
| 769 | -3974x | +116x |
- ends <- c(tail(start, -1) - 1, nc)+ object@content_fun <- value |
| 770 | -3974x | +116x |
- res <- mapply(function(st, en) {
+ object |
| 771 | -22905x | +
- sum(j >= st & j <= en)+ }) |
|
| 772 | -3974x | +
- }, st = start, en = ends)+ |
|
| 773 | -3974x | +
- res <- res[res > 0]+ #' @rdname int_methods |
|
| 774 | -3974x | +1743x |
- stopifnot(sum(res) == length(j))+ setGeneric("analysis_fun", function(obj) standardGeneric("analysis_fun"))
|
| 775 | -3974x | +
- res+ |
|
| 776 |
- }+ #' @rdname int_methods |
||
| 777 | -+ | 1648x |
-
+ setMethod("analysis_fun", "AnalyzeVarSplit", function(obj) obj@analysis_fun)
|
| 778 |
- select_cells_j <- function(cells, j) {
+
|
||
| 779 | -3974x | +
- if (length(j) != length(unique(j))) {
+ #' @rdname int_methods |
|
| 780 | -! | +95x |
- stop("duplicate column selections is not currently supported")
+ setMethod("analysis_fun", "AnalyzeColVarSplit", function(obj) obj@analysis_fun)
|
| 781 |
- }+ |
||
| 782 | -3974x | +
- spans <- vapply(+ ## not used and probably not needed |
|
| 783 | -3974x | +
- cells, function(x) cell_cspan(x),+ ## #' @rdname int_methods |
|
| 784 | -3974x | +
- integer(1)+ ## setGeneric("analysis_fun<-", function(object, value) standardGeneric("analysis_fun<-"))
|
|
| 785 |
- )+ |
||
| 786 | -3974x | +
- inds <- rep(seq_along(cells), times = spans)+ ## #' @rdname int_methods |
|
| 787 | -3974x | +
- selinds <- inds[j]+ ## setMethod("analysis_fun<-", "AnalyzeVarSplit", function(object, value) {
|
|
| 788 | -3974x | +
- retcells <- cells[selinds[!duplicated(selinds)]]+ ## object@analysis_fun <- value |
|
| 789 | -3974x | +
- newspans <- vapply(+ ## object |
|
| 790 | -3974x | +
- split(selinds, selinds),+ ## }) |
|
| 791 | -3974x | +
- length,+ ## #' @rdname int_methods |
|
| 792 | -3974x | +
- integer(1)+ ## setMethod("analysis_fun<-", "AnalyzeColVarSplit", function(object, value) {
|
|
| 793 |
- )+ ## if(is(value, "function")) |
||
| 794 |
-
+ ## value <- list(value) |
||
| 795 | -3974x | +
- mapply(function(cl, sp) {
+ ## object@analysis_fun <- value |
|
| 796 | -6891x | +
- cell_cspan(cl) <- sp+ ## object |
|
| 797 | -6891x | +
- cl+ ## }) |
|
| 798 | -3974x | +
- }, cl = retcells, sp = newspans, SIMPLIFY = FALSE)+ |
|
| 799 |
- }+ #' @rdname int_methods |
||
| 800 | -+ | 1119x |
-
+ setGeneric("split_fun", function(obj) standardGeneric("split_fun"))
|
| 801 |
- setMethod(+ |
||
| 802 |
- "subset_cols", c("ANY", "character"),
+ #' @rdname int_methods |
||
| 803 | -+ | 936x |
- function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
+ setMethod("split_fun", "CustomizableSplit", function(obj) obj@split_fun)
|
| 804 | -42x | +
- j <- .path_to_pos(path = j, tt = tt, cols = TRUE)+ |
|
| 805 | -42x | +
- subset_cols(tt, j, newcinfo = newcinfo, keep_topleft = keep_topleft, ...)+ ## Only that type of split currently has the slot |
|
| 806 |
- }+ ## this should probably change? for now define |
||
| 807 |
- )+ ## an accessor that just returns NULL |
||
| 808 |
-
+ #' @rdname int_methods |
||
| 809 | -+ | 131x |
- setMethod(+ setMethod("split_fun", "Split", function(obj) NULL)
|
| 810 |
- "subset_cols", c("TableRow", "numeric"),
+
|
||
| 811 |
- function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
+ #' @rdname int_methods |
||
| 812 | -3974x | +13x |
- j <- .j_to_posj(j, ncol(tt))+ setGeneric("split_fun<-", function(obj, value) standardGeneric("split_fun<-"))
|
| 813 | -3974x | +
- if (is.null(newcinfo)) {
+
|
|
| 814 | -16x | +
- cinfo <- col_info(tt)+ #' @rdname int_methods |
|
| 815 | -16x | +
- newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...)+ setMethod("split_fun<-", "CustomizableSplit", function(obj, value) {
|
|
| 816 | -+ | 13x |
- }+ obj@split_fun <- value |
| 817 | -3974x | +13x |
- tt2 <- tt+ obj |
| 818 | -3974x | +
- row_cells(tt2) <- select_cells_j(row_cells(tt2), j)+ }) |
|
| 820 | -3974x | +
- if (length(row_cspans(tt2)) > 0) {
+ # nocov start |
|
| 821 | -3974x | +
- row_cspans(tt2) <- .fix_rowcspans(tt2, j)+ ## Only that type of split currently has the slot |
|
| 822 |
- }+ ## this should probably change? for now define |
||
| 823 | -3974x | +
- col_info(tt2) <- newcinfo+ ## an accessor that just returns NULL |
|
| 824 | -3974x | +
- tt2+ #' @rdname int_methods |
|
| 825 |
- }+ setMethod( |
||
| 826 |
- )+ "split_fun<-", "Split", |
||
| 827 |
-
+ function(obj, value) {
|
||
| 828 |
- setMethod(+ stop( |
||
| 829 |
- "subset_cols", c("LabelRow", "numeric"),
+ "Attempted to set a custom split function on a non-customizable split.", |
||
| 830 |
- function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
+ "This should not happen, please contact the maintainers." |
||
| 831 | -2702x | +
- j <- .j_to_posj(j, ncol(tt))+ ) |
|
| 832 | -2702x | +
- if (is.null(newcinfo)) {
+ } |
|
| 833 | -! | +
- cinfo <- col_info(tt)+ ) |
|
| 834 | -! | +
- newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...)+ # nocov end |
|
| 835 |
- }+ |
||
| 836 | -2702x | +
- col_info(tt) <- newcinfo+ ## Content specification related accessors ---- |
|
| 837 | -2702x | +
- tt+ |
|
| 838 |
- }+ #' @rdname int_methods |
||
| 839 | -+ | 477x |
- )+ setGeneric("content_extra_args", function(obj) standardGeneric("content_extra_args"))
|
| 841 |
- setMethod(+ #' @rdname int_methods |
||
| 842 | -+ | 477x |
- "subset_cols", c("InstantiatedColumnInfo", "numeric"),
+ setMethod("content_extra_args", "Split", function(obj) obj@content_extra_args)
|
| 843 |
- function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
+
|
||
| 844 | -278x | +
- if (!is.null(newcinfo)) {
+ #' @rdname int_methods |
|
| 845 | -! | +116x |
- return(newcinfo)+ setGeneric("content_extra_args<-", function(object, value) standardGeneric("content_extra_args<-"))
|
| 846 |
- }+ |
||
| 847 | -278x | +
- j <- .j_to_posj(j, length(col_exprs(tt)))+ #' @rdname int_methods |
|
| 848 | -278x | +
- newctree <- subset_cols(coltree(tt), j, NULL)+ setMethod("content_extra_args<-", "Split", function(object, value) {
|
|
| 849 | -278x | +116x |
- newcextra <- col_extra_args(tt)[j]+ object@content_extra_args <- value |
| 850 | -278x | +116x |
- newcsubs <- col_exprs(tt)[j]+ object |
| 851 | -278x | +
- newcounts <- col_counts(tt)[j]+ }) |
|
| 852 | -278x | +
- tl <- if (keep_topleft) top_left(tt) else character()+ |
|
| 853 | -278x | +
- InstantiatedColumnInfo(+ #' @rdname int_methods |
|
| 854 | -278x | +1883x |
- treelyt = newctree,+ setGeneric("content_var", function(obj) standardGeneric("content_var"))
|
| 855 | -278x | +
- csubs = newcsubs,+ |
|
| 856 | -278x | +
- extras = newcextra,+ #' @rdname int_methods |
|
| 857 | -278x | +1883x |
- cnts = newcounts,+ setMethod("content_var", "Split", function(obj) obj@content_var)
|
| 858 | -278x | +
- dispcounts = disp_ccounts(tt),+ |
|
| 859 | -278x | +
- countformat = colcount_format(tt),+ #' @rdname int_methods |
|
| 860 | -278x | +116x |
- topleft = tl+ setGeneric("content_var<-", function(object, value) standardGeneric("content_var<-"))
|
| 861 |
- )+ |
||
| 862 |
- }+ #' @rdname int_methods |
||
| 863 |
- )+ setMethod("content_var<-", "Split", function(object, value) {
|
||
| 864 | -+ | 116x |
-
+ object@content_var <- value |
| 865 | -+ | 116x |
- setMethod(+ object |
| 866 |
- "subset_cols", c("LayoutColTree", "numeric"),
+ }) |
||
| 867 |
- function(tt, j, newcinfo = NULL, ...) {
+
|
||
| 868 | -278x | +
- lst <- collect_leaves(tt)+ ### Miscellaneous accessors ---- |
|
| 869 | -278x | +
- j <- .j_to_posj(j, length(lst))+ |
|
| 870 |
-
+ #' @rdname int_methods |
||
| 871 | -+ | 1149x |
- ## j has only non-negative values from+ setGeneric("avar_inclNAs", function(obj) standardGeneric("avar_inclNAs"))
|
| 872 |
- ## this point on+ |
||
| 873 | -278x | +
- counter <- 0+ #' @rdname int_methods |
|
| 874 | -278x | +
- prune_children <- function(x, j) {
+ setMethod( |
|
| 875 | -674x | +
- kids <- tree_children(x)+ "avar_inclNAs", "VAnalyzeSplit", |
|
| 876 | -674x | +1149x |
- newkids <- kids+ function(obj) obj@include_NAs |
| 877 | -674x | +
- for (i in seq_along(newkids)) {
+ ) |
|
| 878 | -1813x | +
- if (is(newkids[[i]], "LayoutColLeaf")) {
+
|
|
| 879 | -1417x | +
- counter <<- counter + 1+ #' @rdname int_methods |
|
| 880 | -1417x | +! |
- if (!(counter %in% j)) {
+ setGeneric("avar_inclNAs<-", function(obj, value) standardGeneric("avar_inclNAs<-"))
|
| 881 | -1013x | +
- newkids[[i]] <- list()+ |
|
| 882 | -278x | +
- } ## NULL removes the position entirely+ #' @rdname int_methods |
|
| 883 |
- } else {
+ setMethod( |
||
| 884 | -396x | +
- newkids[[i]] <- prune_children(newkids[[i]], j)+ "avar_inclNAs<-", "VAnalyzeSplit", |
|
| 885 |
- }+ function(obj, value) {
|
||
| 886 | -+ | ! |
- }+ obj@include_NAs <- value |
| 887 |
-
+ } |
||
| 888 | -674x | +
- newkids <- newkids[sapply(newkids, function(thing) length(thing) > 0)]+ ) |
|
| 889 | -674x | +
- if (length(newkids) > 0) {
+
|
|
| 890 | -474x | +
- tree_children(x) <- newkids+ #' @rdname int_methods |
|
| 891 | -474x | +848x |
- x+ setGeneric("spl_labelvar", function(obj) standardGeneric("spl_labelvar"))
|
| 892 |
- } else {
+
|
||
| 893 | -200x | +
- list()+ #' @rdname int_methods |
|
| 894 | -+ | 848x |
- }+ setMethod("spl_labelvar", "VarLevelSplit", function(obj) obj@value_label_var)
|
| 895 |
- }+ |
||
| 896 | -278x | +
- prune_children(tt, j)+ #' @rdname int_methods |
|
| 897 | -+ | 2867x |
- }+ setGeneric("spl_child_order", function(obj) standardGeneric("spl_child_order"))
|
| 898 |
- )+ |
||
| 899 |
-
+ #' @rdname int_methods |
||
| 900 | -+ | 2566x |
- ## label rows ARE included in the count+ setMethod("spl_child_order", "VarLevelSplit", function(obj) obj@value_order)
|
| 901 |
- subset_by_rownum <- function(tt,+ |
||
| 902 |
- i,+ #' @rdname int_methods |
||
| 903 |
- keep_topleft = FALSE,+ setGeneric( |
||
| 904 |
- keep_titles = TRUE,+ "spl_child_order<-", |
||
| 905 | -+ | 649x |
- keep_footers = keep_titles,+ function(obj, value) standardGeneric("spl_child_order<-")
|
| 906 |
- ...) {
+ ) |
||
| 907 | -184x | +
- stopifnot(is(tt, "VTableNodeInfo"))+ |
|
| 908 | -184x | +
- counter <- 0+ #' @rdname int_methods |
|
| 909 | -184x | +
- nr <- nrow(tt)+ setMethod( |
|
| 910 | -184x | +
- i <- .j_to_posj(i, nr)+ "spl_child_order<-", "VarLevelSplit", |
|
| 911 | -184x | +
- if (length(i) == 0) {
+ function(obj, value) {
|
|
| 912 | -3x | +649x |
- ret <- TableTree(cinfo = col_info(tt))+ obj@value_order <- value |
| 913 | -3x | +649x |
- if (isTRUE(keep_topleft)) {
+ obj |
| 914 | -1x | +
- top_left(ret) <- top_left(tt)+ } |
|
| 915 |
- }+ ) |
||
| 916 | -3x | +
- return(ret)+ |
|
| 917 |
- }+ #' @rdname int_methods |
||
| 918 |
-
+ setMethod( |
||
| 919 | -181x | +
- prune_rowsbynum <- function(x, i, valifnone = NULL) {
+ "spl_child_order", |
|
| 920 | -1321x | +
- maxi <- max(i)+ "ManualSplit", |
|
| 921 | -1321x | +52x |
- if (counter > maxi) {
+ function(obj) obj@levels |
| 922 | -137x | +
- return(valifnone)+ ) |
|
| 923 |
- }+ |
||
| 924 |
-
+ #' @rdname int_methods |
||
| 925 | -1184x | +
- if (labelrow_visible(x)) {
+ setMethod( |
|
| 926 | -489x | +
- counter <<- counter + 1+ "spl_child_order", |
|
| 927 | -489x | +
- if (!(counter %in% i)) {
+ "MultiVarSplit", |
|
| 928 | -+ | 96x |
- ## XXX this should do whatever+ function(obj) spl_varnames(obj) |
| 929 |
- ## is required to 'remove' the Label Row+ ) |
||
| 930 |
- ## (currently implicit based on+ |
||
| 931 |
- ## the value of the label but+ #' @rdname int_methods |
||
| 932 |
- ## that shold really probably change)+ setMethod( |
||
| 933 | -177x | +
- labelrow_visible(x) <- FALSE+ "spl_child_order", |
|
| 934 |
- }+ "AllSplit", |
||
| 935 | -+ | 109x |
- }+ function(obj) character() |
| 936 | -1184x | +
- if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
+ ) |
|
| 937 | -90x | +
- ctab <- content_table(x)+ |
|
| 938 |
-
+ #' @rdname int_methods |
||
| 939 | -90x | +
- content_table(x) <- prune_rowsbynum(ctab, i,+ setMethod( |
|
| 940 | -90x | +
- valifnone = ElementaryTable(+ "spl_child_order", |
|
| 941 | -90x | +
- cinfo = col_info(ctab),+ "VarStaticCutSplit", |
|
| 942 | -90x | +44x |
- iscontent = TRUE+ function(obj) spl_cutlabels(obj) |
| 943 |
- )+ ) |
||
| 944 |
- )+ |
||
| 945 |
- }+ #' @rdname int_methods |
||
| 946 | -1184x | +1010x |
- kids <- tree_children(x)+ setGeneric("root_spl", function(obj) standardGeneric("root_spl"))
|
| 947 | -1184x | +
- if (counter > maxi) { # already done
+
|
|
| 948 | -49x | +
- kids <- list()+ #' @rdname int_methods |
|
| 949 | -1135x | +
- } else if (length(kids) > 0) {
+ setMethod( |
|
| 950 | -1133x | +
- for (pos in seq_along(kids)) {
+ "root_spl", "PreDataAxisLayout", |
|
| 951 | -4102x | +1010x |
- if (is(kids[[pos]], "TableRow")) {
+ function(obj) obj@root_split |
| 952 | -3052x | +
- counter <<- counter + 1+ ) |
|
| 953 | -3052x | +
- if (!(counter %in% i)) {
+
|
|
| 954 | -2144x | +
- kids[[pos]] <- list()+ #' @rdname int_methods |
|
| 955 | -+ | 9x |
- }+ setGeneric("root_spl<-", function(obj, value) standardGeneric("root_spl<-"))
|
| 956 |
- } else {
+
|
||
| 957 | -1050x | +
- kids[[pos]] <- prune_rowsbynum(kids[[pos]], i, list())+ #' @rdname int_methods |
|
| 958 |
- }+ setMethod( |
||
| 959 |
- }+ "root_spl<-", "PreDataAxisLayout", |
||
| 960 | -1133x | +
- kids <- kids[sapply(kids, function(x) NROW(x) > 0)]+ function(obj, value) {
|
|
| 961 | -+ | 9x |
- }+ obj@root_split <- value |
| 962 | -1184x | +9x |
- if (length(kids) == 0 && NROW(content_table(x)) == 0 && !labelrow_visible(x)) {
+ obj |
| 963 | -359x | +
- return(valifnone)+ } |
|
| 964 |
- } else {
+ ) |
||
| 965 | -825x | +
- tree_children(x) <- kids+ |
|
| 966 | -825x | +
- x+ #' Row attribute accessors |
|
| 967 |
- }+ #' |
||
| 968 |
- ## ## if(length(kids) == 0) {
+ #' @inheritParams gen_args |
||
| 969 |
- ## ## if(!is(x, "TableTree"))+ #' |
||
| 970 |
- ## ## return(valifnone)+ #' @return Various return values depending on the accessor called. |
||
| 971 |
- ## ## }+ #' |
||
| 972 |
- ## if(is(x, "VTableTree") && nrow(x) > 0) {
+ #' @export |
||
| 973 |
- ## x+ #' @rdname row_accessors |
||
| 974 | -+ | 72x |
- ## } else {
+ setGeneric("obj_avar", function(obj) standardGeneric("obj_avar"))
|
| 975 |
- ## valifnone+ |
||
| 976 |
- ## }+ #' @rdname row_accessors |
||
| 977 |
- }+ #' @exportMethod obj_avar |
||
| 978 | -181x | +55x |
- ret <- prune_rowsbynum(tt, i)+ setMethod("obj_avar", "TableRow", function(obj) obj@var_analyzed)
|
| 980 | -181x | +
- ret <- .h_copy_titles_footers_topleft(+ #' @rdname row_accessors |
|
| 981 | -181x | +
- ret, tt,+ #' @exportMethod obj_avar |
|
| 982 | -181x | +17x |
- keep_titles,+ setMethod("obj_avar", "ElementaryTable", function(obj) obj@var_analyzed)
|
| 983 | -181x | +
- keep_footers,+ |
|
| 984 | -181x | +
- keep_topleft+ #' @export |
|
| 985 |
- )+ #' @rdname row_accessors |
||
| 986 | -+ | 68468x |
-
+ setGeneric("row_cells", function(obj) standardGeneric("row_cells"))
|
| 987 | -181x | +
- ret+ |
|
| 988 |
- }+ #' @rdname row_accessors |
||
| 989 |
-
+ #' @exportMethod row_cells |
||
| 990 | -+ | 7465x |
- #' @exportMethod [+ setMethod("row_cells", "TableRow", function(obj) obj@leaf_value)
|
| 991 |
- #' @rdname brackets+ |
||
| 992 |
- setMethod(+ #' @rdname row_accessors |
||
| 993 | -+ | 4034x |
- "[", c("VTableTree", "logical", "logical"),
+ setGeneric("row_cells<-", function(obj, value) standardGeneric("row_cells<-"))
|
| 994 |
- function(x, i, j, ..., drop = FALSE) {
+
|
||
| 995 | -1x | +
- i <- .j_to_posj(i, nrow(x))+ #' @rdname row_accessors |
|
| 996 | -1x | +
- j <- .j_to_posj(j, ncol(x))+ #' @exportMethod row_cells |
|
| 997 | -1x | +
- x[i, j, ..., drop = drop]+ setMethod("row_cells<-", "TableRow", function(obj, value) {
|
|
| 998 | -+ | 4034x |
- }+ obj@leaf_value <- value |
| 999 | -+ | 4034x |
- )+ obj |
| 1000 |
-
+ }) |
||
| 1001 |
- #' @exportMethod [+ |
||
| 1002 |
- #' @rdname int_methods+ #' @export |
||
| 1003 |
- #' @keywords internal+ #' @rdname row_accessors |
||
| 1004 | -+ | 2438x |
- setMethod(+ setGeneric("row_values", function(obj) standardGeneric("row_values"))
|
| 1005 |
- "[", c("VTableTree", "logical", "ANY"),
+
|
||
| 1006 |
- function(x, i, j, ..., drop = FALSE) {
+ #' @rdname row_accessors |
||
| 1007 | -! | +
- i <- .j_to_posj(i, nrow(x))+ #' @exportMethod row_values |
|
| 1008 | -! | +530x |
- x[i, j, ..., drop = drop]+ setMethod("row_values", "TableRow", function(obj) rawvalues(obj@leaf_value))
|
| 1009 |
- }+ |
||
| 1010 |
- )+ |
||
| 1011 |
-
+ #' @rdname row_accessors |
||
| 1012 |
- #' @exportMethod [+ #' @exportMethod row_values<- |
||
| 1013 | -+ | 1226x |
- #' @rdname int_methods+ setGeneric("row_values<-", function(obj, value) standardGeneric("row_values<-"))
|
| 1014 |
- #' @keywords internal+ |
||
| 1015 |
- setMethod(+ #' @rdname row_accessors |
||
| 1016 |
- "[", c("VTableTree", "logical", "missing"),
+ #' @exportMethod row_values<- |
||
| 1017 |
- function(x, i, j, ..., drop = FALSE) {
+ setMethod( |
||
| 1018 | -4x | +
- j <- seq_len(ncol(x))+ "row_values<-", "TableRow", |
|
| 1019 | -4x | +
- i <- .j_to_posj(i, nrow(x))+ function(obj, value) {
|
|
| 1020 | -4x | +1226x |
- x[i, j, ..., drop = drop]+ obj@leaf_value <- lapply(value, rcell) |
| 1021 | -+ | 1226x |
- }+ obj |
| 1022 |
- )+ } |
||
| 1023 |
-
+ ) |
||
| 1024 |
- #' @exportMethod [+ |
||
| 1025 |
- #' @rdname int_methods+ #' @rdname row_accessors |
||
| 1026 |
- #' @keywords internal+ #' @exportMethod row_values<- |
||
| 1028 |
- "[", c("VTableTree", "ANY", "logical"),
+ "row_values<-", "LabelRow", |
||
| 1029 |
- function(x, i, j, ..., drop = FALSE) {
+ function(obj, value) {
|
||
| 1030 | -1x | +! |
- j <- .j_to_posj(j, ncol(x))+ stop("LabelRows cannot have row values.")
|
| 1031 | -1x | +
- x[i, j, ..., drop = drop]+ } |
|
| 1032 |
- }+ ) |
||
| 1033 |
- )+ |
||
| 1034 |
-
+ #' @rdname int_methods |
||
| 1035 | -+ | 941x |
- #' @exportMethod [+ setGeneric("spanned_values", function(obj) standardGeneric("spanned_values"))
|
| 1036 |
- #' @rdname int_methods+ |
||
| 1037 |
- #' @keywords internal+ #' @rdname int_methods |
||
| 1039 |
- "[", c("VTableTree", "ANY", "missing"),
+ "spanned_values", "TableRow", |
||
| 1040 |
- function(x, i, j, ..., drop = FALSE) {
+ function(obj) {
|
||
| 1041 | -146x | +941x |
- j <- seq_len(ncol(x))+ rawvalues(spanned_cells(obj)) |
| 1042 | -146x | +
- x[i = i, j = j, ..., drop = drop]+ } |
|
| 1043 |
- }+ ) |
||
| 1044 |
- )+ |
||
| 1045 |
-
+ #' @rdname int_methods |
||
| 1046 |
- #' @exportMethod [+ setMethod( |
||
| 1047 |
- #' @rdname int_methods+ "spanned_values", "LabelRow", |
||
| 1048 |
- #' @keywords internal+ function(obj) {
|
||
| 1049 | -+ | ! |
- setMethod(+ rep(list(NULL), ncol(obj)) |
| 1050 |
- "[", c("VTableTree", "missing", "ANY"),
+ } |
||
| 1051 |
- function(x, i, j, ..., drop = FALSE) {
+ ) |
||
| 1052 | -4x | +
- i <- seq_len(nrow(x))+ |
|
| 1053 | -4x | +
- x[i = i, j = j, ..., drop = drop]+ #' @rdname int_methods |
|
| 1054 | -+ | 941x |
- }+ setGeneric("spanned_cells", function(obj) standardGeneric("spanned_cells"))
|
| 1055 |
- )+ |
||
| 1056 |
-
+ #' @rdname int_methods |
||
| 1057 |
- #' @exportMethod [+ setMethod( |
||
| 1058 |
- #' @rdname int_methods+ "spanned_cells", "TableRow", |
||
| 1059 |
- #' @keywords internal+ function(obj) {
|
||
| 1060 | -+ | 941x |
- setMethod(+ sp <- row_cspans(obj) |
| 1061 | -+ | 941x |
- "[", c("VTableTree", "ANY", "character"),
+ rvals <- row_cells(obj) |
| 1062 | -+ | 941x |
- function(x, i, j, ..., drop = FALSE) {
+ unlist( |
| 1063 | -+ | 941x |
- ## j <- .colpath_to_j(j, coltree(x))+ mapply(function(v, s) rep(list(v), times = s), |
| 1064 | -3x | +941x |
- j <- .path_to_pos(path = j, tt = x, cols = TRUE)+ v = rvals, s = sp |
| 1065 | -3x | +
- x[i = i, j = j, ..., drop = drop]+ ), |
|
| 1066 | -+ | 941x |
- }+ recursive = FALSE |
| 1067 |
- )+ ) |
||
| 1068 |
-
+ } |
||
| 1069 |
- #' @exportMethod [+ ) |
||
| 1070 |
- #' @rdname int_methods+ |
||
| 1071 |
- #' @keywords internal+ #' @rdname int_methods |
||
| 1073 |
- "[", c("VTableTree", "character", "ANY"),
+ "spanned_cells", "LabelRow", |
||
| 1074 |
- function(x, i, j, ..., drop = FALSE) {
+ function(obj) {
|
||
| 1075 | -+ | ! |
- ## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW)+ rep(list(NULL), ncol(obj)) |
| 1076 | -! | +
- i <- .path_to_pos(i, x)+ } |
|
| 1077 | -! | +
- x[i = i, j = j, ..., drop = drop]+ ) |
|
| 1078 |
- }+ |
||
| 1079 |
- )+ #' @rdname int_methods |
||
| 1080 | -+ | 3x |
-
+ setGeneric("spanned_values<-", function(obj, value) standardGeneric("spanned_values<-"))
|
| 1081 |
- ## to avoid dispatch ambiguity. Not necessary, possibly not a good idea at all+ |
||
| 1082 |
- #' @exportMethod [+ #' @rdname int_methods |
||
| 1083 |
- #' @rdname int_methods+ setMethod( |
||
| 1084 |
- #' @keywords internal+ "spanned_values<-", "TableRow", |
||
| 1085 |
- setMethod(+ function(obj, value) {
|
||
| 1086 | -+ | 2x |
- "[", c("VTableTree", "character", "character"),
+ sp <- row_cspans(obj) |
| 1087 |
- function(x, i, j, ..., drop = FALSE) {
+ ## this is 3 times too clever!!! |
||
| 1088 | -+ | 2x |
- ## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW)+ valindices <- unlist(lapply(sp, function(x) c(TRUE, rep(FALSE, x - 1)))) |
| 1089 | -! | +
- i <- .path_to_pos(i, x)+ |
|
| 1090 | -+ | 2x |
- ## j <- .colpath_to_j(j, coltree(x))+ splvec <- cumsum(valindices) |
| 1091 | -! | +2x |
- j <- .path_to_pos(path = j, tt = x, cols = TRUE)+ lapply( |
| 1092 | -! | +2x |
- x[i = i, j = j, ..., drop = drop]+ split(value, splvec), |
| 1093 | -+ | 2x |
- }+ function(v) {
|
| 1094 | -+ | 3x |
- )+ if (length(unique(v)) > 1) {
|
| 1095 | -+ | 1x |
-
+ stop( |
| 1096 | -+ | 1x |
- #' @exportMethod [+ "Got more than one unique value within a span, ", |
| 1097 | -+ | 1x |
- #' @rdname int_methods+ "new spanned values do not appear to match the ", |
| 1098 | -+ | 1x |
- #' @keywords internal+ "existing spanning pattern of the row (",
|
| 1099 | -+ | 1x |
- setMethod(+ paste(sp, collapse = " "), ")" |
| 1100 |
- "[", c("VTableTree", "missing", "numeric"),
+ ) |
||
| 1101 |
- function(x, i, j, ..., drop = FALSE) {
+ } |
||
| 1102 | -238x | +
- i <- seq_len(nrow(x))+ } |
|
| 1103 | -238x | +
- x[i, j, ..., drop = drop]+ ) |
|
| 1104 | -+ | 1x |
- }+ rvals <- value[valindices] |
| 1105 |
- )+ |
||
| 1106 |
-
+ ## rvals = lapply(split(value, splvec), |
||
| 1107 |
- #' @exportMethod [+ ## function(v) {
|
||
| 1108 |
- #' @rdname int_methods+ ## if(length(v) == 1) |
||
| 1109 |
- #' @keywords internal+ ## return(v) |
||
| 1110 |
- setMethod(+ ## stopifnot(length(unique(v)) == 1L) |
||
| 1111 |
- "[", c("VTableTree", "numeric", "numeric"),
+ ## rcell(unique(v), colspan<- length(v)) |
||
| 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+ ## if(any(splvec > 1)) |
||
| 1114 |
- ## own the generic declaration+ ## rvals <- lapply(rvals, function(x) x[[1]]) |
||
| 1115 | -471x | +1x |
- keep_topleft <- list(...)[["keep_topleft"]] %||% NA+ row_values(obj) <- rvals |
| 1116 | -471x | +1x |
- keep_titles <- list(...)[["keep_titles"]] %||% FALSE+ obj |
| 1117 | -471x | +
- keep_footers <- list(...)[["keep_footers"]] %||% keep_titles+ } |
|
| 1118 | -471x | +
- reindex_refs <- list(...)[["reindex_refs"]] %||% TRUE+ ) |
|
| 1120 | -471x | +
- nr <- nrow(x)+ #' @rdname int_methods |
|
| 1121 | -471x | +
- nc <- ncol(x)+ setMethod( |
|
| 1122 | -471x | +
- i <- .j_to_posj(i, nr)+ "spanned_values<-", "LabelRow", |
|
| 1123 | -471x | +
- j <- .j_to_posj(j, nc)+ function(obj, value) {
|
|
| 1124 | -+ | 1x |
-
+ if (!is.null(value)) {
|
| 1125 | -+ | 1x |
- ## if(!missing(i) && length(i) < nr) {
+ stop("Label rows can't have non-null cell values, got", value)
|
| 1126 | -471x | +
- if (length(i) < nr) { ## already populated by .j_to_posj
+ } |
|
| 1127 | -184x | +! |
- keep_topleft <- isTRUE(keep_topleft)+ obj |
| 1128 | -184x | +
- x <- subset_by_rownum(x, i,+ } |
|
| 1129 | -184x | +
- keep_topleft = keep_topleft,+ ) |
|
| 1130 | -184x | +
- keep_titles = keep_titles,+ |
|
| 1131 | -184x | +
- keep_footers = keep_footers+ ### Format manipulation |
|
| 1132 |
- )+ ### obj_format<- is not recursive |
||
| 1133 | -287x | +
- } else if (is.na(keep_topleft)) {
+ ## TODO export these? |
|
| 1134 | -49x | +
- keep_topleft <- TRUE+ #' @rdname formatters_methods |
|
| 1135 |
- }+ #' @export |
||
| 1136 | -+ | 6405x |
-
+ setMethod("obj_format", "VTableNodeInfo", function(obj) obj@format)
|
| 1137 |
- ## if(!missing(j) && length(j) < nc)+ |
||
| 1138 | -471x | +
- if (length(j) < nc) {
+ #' @rdname formatters_methods |
|
| 1139 | -232x | +
- x <- subset_cols(x, j,+ #' @export |
|
| 1140 | -232x | +107591x |
- keep_topleft = keep_topleft,+ setMethod("obj_format", "CellValue", function(obj) attr(obj, "format", exact = TRUE))
|
| 1141 | -232x | +
- keep_titles = keep_titles,+ |
|
| 1142 | -232x | +
- keep_footers = keep_footers+ #' @rdname formatters_methods |
|
| 1143 |
- )+ #' @export |
||
| 1144 | -+ | 2337x |
- }+ setMethod("obj_format", "Split", function(obj) obj@split_format)
|
| 1146 |
- # Dropping everything+ #' @rdname formatters_methods |
||
| 1147 | -471x | +
- if (drop) {
+ #' @export |
|
| 1148 | -35x | +
- if (length(j) == 1L && length(i) == 1L) {
+ setMethod("obj_format<-", "VTableNodeInfo", function(obj, value) {
|
|
| 1149 | -30x | +1664x |
- rw <- collect_leaves(x, TRUE, TRUE)[[1]]+ obj@format <- value |
| 1150 | -30x | +1664x |
- if (is(rw, "LabelRow")) {
+ obj |
| 1151 | -2x | +
- warning(+ }) |
|
| 1152 | -2x | +
- "The value selected with drop = TRUE belongs ",+ |
|
| 1153 | -2x | +
- "to a label row. NULL will be returned"+ #' @rdname formatters_methods |
|
| 1154 |
- )+ #' @export |
||
| 1155 | -2x | +
- x <- NULL+ setMethod("obj_format<-", "Split", function(obj, value) {
|
|
| 1156 | -+ | 1x |
- } else {
+ obj@split_format <- value |
| 1157 | -28x | +1x |
- x <- row_values(rw)[[1]]+ obj |
| 1158 |
- }+ }) |
||
| 1159 |
- } else {
+
|
||
| 1160 | -5x | +
- warning(+ #' @rdname formatters_methods |
|
| 1161 | -5x | +
- "Trying to drop more than one subsetted value. ",+ #' @export |
|
| 1162 | -5x | +
- "We support this only with accessor function `cell_values()`. ",+ setMethod("obj_format<-", "CellValue", function(obj, value) {
|
|
| 1163 | -5x | +1173x |
- "No drop will be done at this time."+ attr(obj, "format") <- value |
| 1164 | -+ | 1173x |
- )+ obj |
| 1165 | -5x | +
- drop <- FALSE+ }) |
|
| 1166 |
- }+ |
||
| 1167 |
- }+ #' @rdname int_methods |
||
| 1168 | -471x | +
- if (!drop) {
+ #' @export |
|
| 1169 | -441x | +
- if (!keep_topleft) {
+ setMethod("obj_na_str<-", "CellValue", function(obj, value) {
|
|
| 1170 | -61x | +4170x |
- top_left(x) <- character()+ attr(obj, "format_na_str") <- value |
| 1171 | -+ | 4170x |
- }+ obj |
| 1172 | -441x | +
- if (reindex_refs) {
+ }) |
|
| 1173 | -105x | +
- x <- update_ref_indexing(x)+ |
|
| 1174 |
- }+ #' @rdname int_methods |
||
| 1175 |
- }+ #' @export |
||
| 1176 | -471x | +
- x+ setMethod("obj_na_str<-", "VTableNodeInfo", function(obj, value) {
|
|
| 1177 | -+ | 26x |
- }+ obj@na_str <- value |
| 1178 | -+ | 26x |
- )+ obj |
| 1179 |
-
+ }) |
||
| 1180 |
- #' @importFrom utils compareVersion+ |
||
| 1181 |
-
+ #' @rdname int_methods |
||
| 1182 |
- setGeneric("tail", tail)
+ #' @export |
||
| 1183 |
-
+ setMethod("obj_na_str<-", "Split", function(obj, value) {
|
||
| 1184 | -+ | ! |
- setMethod(+ obj@split_na_str <- value |
| 1185 | -+ | ! |
- "tail", "VTableTree",+ obj |
| 1186 |
- function(x, n = 6L, ...) {
+ }) |
||
| 1187 |
- if (compareVersion("4.0.0", as.character(getRversion())) <= 0) {
+
|
||
| 1188 |
- tail.matrix(x, n, keepnums = FALSE)+ #' @rdname int_methods |
||
| 1189 |
- } else {
+ #' @export |
||
| 1190 | -+ | 28097x |
- tail.matrix(x, n, addrownums = FALSE)+ setMethod("obj_na_str", "VTableNodeInfo", function(obj) obj@na_str)
|
| 1191 |
- }+ |
||
| 1192 |
- }+ #' @rdname formatters_methods |
||
| 1193 |
- )+ #' @export |
||
| 1194 | -+ | 1189x |
-
+ setMethod("obj_na_str", "Split", function(obj) obj@split_na_str)
|
| 1195 |
- setGeneric("head", head)
+
|
||
| 1196 |
-
+ .no_na_str <- function(x) {
|
||
| 1197 | -+ | 15284x |
- setMethod(+ if (!is.character(x)) {
|
| 1198 | -+ | 6138x |
- "head", "VTableTree",+ x <- obj_na_str(x) |
| 1199 |
- function(x, n = 6L, ...) {
+ } |
||
| 1200 | -+ | 15284x |
- head.matrix(x, n)+ length(x) == 0 || all(is.na(x)) |
| 1201 |
- }+ } |
||
| 1202 |
- )+ |
||
| 1203 |
-
+ #' @rdname int_methods |
||
| 1204 |
- #' Retrieve cell values by row and column path+ setGeneric("set_format_recursive", function(obj, format, na_str, override = FALSE) {
|
||
| 1205 | -+ | 9139x |
- #'+ standardGeneric("set_format_recursive")
|
| 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 `"*"`.+ #' @param override (`flag`)\cr whether to override attribute. |
||
| 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`).+ #' @rdname int_methods |
||
| 1211 |
- #'+ setMethod( |
||
| 1212 |
- #' @return+ "set_format_recursive", "TableRow", |
||
| 1213 |
- #' * `cell_values` returns a `list` (regardless of the type of value the cells hold). If `rowpath` defines a path to+ function(obj, format, na_str, override = FALSE) {
|
||
| 1214 | -+ | 1064x |
- #' a single row, `cell_values` returns the list of cell values for that row, otherwise a list of such lists, one for+ if (is.null(format) && .no_na_str(na_str)) {
|
| 1215 | -+ | 532x |
- #' each row captured underneath `rowpath`. This occurs after subsetting to `colpath` has occurred.+ return(obj) |
| 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 | -+ | 532x |
- #'+ if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
|
| 1219 | -+ | 532x |
- #' @note `cell_values` will return a single cell's value wrapped in a list. Use `value_at` to receive the "bare" cell+ obj_format(obj) <- format |
| 1220 |
- #' value.+ } |
||
| 1221 | -+ | 532x |
- #'+ if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
|
| 1222 | -+ | ! |
- #' @examples+ obj_na_str(obj) <- na_str |
| 1223 |
- #' lyt <- basic_table() %>%+ } |
||
| 1224 | -+ | 532x |
- #' split_cols_by("ARM") %>%
+ lcells <- row_cells(obj) |
| 1225 | -+ | 532x |
- #' split_cols_by("SEX") %>%
+ lvals <- lapply(lcells, function(x) {
|
| 1226 | -+ | 1951x |
- #' split_rows_by("RACE") %>%
+ if (!is.null(x) && (override || is.null(obj_format(x)))) {
|
| 1227 | -+ | 53x |
- #' summarize_row_groups() %>%+ obj_format(x) <- obj_format(obj) |
| 1228 |
- #' split_rows_by("STRATA1") %>%
+ } |
||
| 1229 | -+ | 1951x |
- #' analyze("AGE")
+ if (!is.null(x) && (override || .no_na_str(x))) {
|
| 1230 | -+ | 1951x |
- #'+ obj_na_str(x) <- obj_na_str(obj) |
| 1231 |
- #' @examplesIf require(dplyr)+ } |
||
| 1232 | -+ | 1951x |
- #' library(dplyr) ## for mutate+ x |
| 1233 |
- #' tbl <- build_table(lyt, DM %>%+ }) |
||
| 1234 | -+ | 532x |
- #' mutate(SEX = droplevels(SEX), RACE = droplevels(RACE)))+ row_values(obj) <- lvals |
| 1235 | -+ | 532x |
- #'+ obj |
| 1236 |
- #' row_paths_summary(tbl)+ } |
||
| 1237 |
- #' col_paths_summary(tbl)+ ) |
||
| 1238 |
- #'+ |
||
| 1239 |
- #' cell_values(+ #' @rdname int_methods |
||
| 1240 |
- #' tbl, c("RACE", "ASIAN", "STRATA1", "B"),
+ setMethod( |
||
| 1241 |
- #' c("ARM", "A: Drug X", "SEX", "F")
+ "set_format_recursive", "LabelRow", |
||
| 1242 | -+ | 11x |
- #' )+ function(obj, format, override = FALSE) obj |
| 1243 |
- #'+ ) |
||
| 1244 |
- #' # it's also possible to access multiple values by being less specific+ |
||
| 1245 |
- #' cell_values(+ setMethod( |
||
| 1246 |
- #' tbl, c("RACE", "ASIAN", "STRATA1"),
+ "set_format_recursive", "VTableTree", |
||
| 1247 |
- #' c("ARM", "A: Drug X", "SEX", "F")
+ function(obj, format, na_str, override = FALSE) {
|
||
| 1248 | -+ | 1714x |
- #' )+ force(format) |
| 1249 | -+ | 1714x |
- #' cell_values(tbl, c("RACE", "ASIAN"), c("ARM", "A: Drug X", "SEX", "M"))
+ if (is.null(format) && .no_na_str(na_str)) {
|
| 1250 | -+ | 1707x |
- #'+ return(obj) |
| 1251 |
- #' ## any arm, male columns from the ASIAN content (i.e. summary) row+ } |
||
| 1252 |
- #' cell_values(+ |
||
| 1253 | -+ | 7x |
- #' tbl, c("RACE", "ASIAN", "@content"),
+ if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
|
| 1254 | -+ | 7x |
- #' c("ARM", "B: Placebo", "SEX", "M")
+ obj_format(obj) <- format |
| 1255 |
- #' )+ } |
||
| 1256 | -+ | 7x |
- #' cell_values(+ if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
|
| 1257 | -+ | ! |
- #' tbl, c("RACE", "ASIAN", "@content"),
+ obj_na_str(obj) <- na_str |
| 1258 |
- #' c("ARM", "*", "SEX", "M")
+ } |
||
| 1259 |
- #' )+ |
||
| 1260 | -+ | 7x |
- #'+ kids <- tree_children(obj) |
| 1261 | -+ | 7x |
- #' ## all columns+ kids <- lapply(kids, function(x, format2, na_str2, oride) {
|
| 1262 | -+ | 33x |
- #' cell_values(tbl, c("RACE", "ASIAN", "STRATA1", "B"))
+ set_format_recursive(x, |
| 1263 | -+ | 33x |
- #'+ format = format2, na_str = na_str2, override = oride |
| 1264 |
- #' ## all columns for the Combination arm+ ) |
||
| 1265 |
- #' cell_values(+ }, |
||
| 1266 | -+ | 7x |
- #' tbl, c("RACE", "ASIAN", "STRATA1", "B"),
+ format2 = obj_format(obj), na_str2 = obj_na_str(obj), oride = override |
| 1267 |
- #' c("ARM", "C: Combination")
+ ) |
||
| 1268 | -+ | 7x |
- #' )+ tree_children(obj) <- kids |
| 1269 | -+ | 7x |
- #'+ obj |
| 1270 |
- #' cvlist <- cell_values(+ } |
||
| 1271 |
- #' tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"),
+ ) |
||
| 1272 |
- #' c("ARM", "B: Placebo", "SEX", "M")
+
|
||
| 1273 |
- #' )+ #' @rdname int_methods |
||
| 1274 | -+ | 1875x |
- #' cvnolist <- value_at(+ setGeneric("content_format", function(obj) standardGeneric("content_format"))
|
| 1275 |
- #' tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"),
+
|
||
| 1276 |
- #' c("ARM", "B: Placebo", "SEX", "M")
+ #' @rdname int_methods |
||
| 1277 | -+ | 1875x |
- #' )+ setMethod("content_format", "Split", function(obj) obj@content_format)
|
| 1278 |
- #' stopifnot(identical(cvlist[[1]], cvnolist))+ |
||
| 1279 |
- #'+ #' @rdname int_methods |
||
| 1280 | -+ | 116x |
- #' @rdname cell_values+ setGeneric("content_format<-", function(obj, value) standardGeneric("content_format<-"))
|
| 1281 |
- #' @export+ |
||
| 1282 |
- setGeneric("cell_values", function(tt, rowpath = NULL, colpath = NULL, omit_labrows = TRUE) {
+ #' @rdname int_methods |
||
| 1283 | -163x | +
- standardGeneric("cell_values")
+ setMethod("content_format<-", "Split", function(obj, value) {
|
|
| 1284 | -+ | 116x |
- })+ obj@content_format <- value |
| 1285 | -+ | 116x |
-
+ obj |
| 1286 |
- #' @rdname int_methods+ }) |
||
| 1287 |
- #' @keywords internal+ |
||
| 1288 |
- #' @exportMethod cell_values+ #' @rdname int_methods |
||
| 1289 | -+ | 1875x |
- setMethod(+ setGeneric("content_na_str", function(obj) standardGeneric("content_na_str"))
|
| 1290 |
- "cell_values", "VTableTree",+ |
||
| 1291 |
- function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
+ #' @rdname int_methods |
||
| 1292 | -160x | +1875x |
- .inner_cell_value(tt,+ setMethod("content_na_str", "Split", function(obj) obj@content_na_str)
|
| 1293 | -160x | +
- rowpath = rowpath, colpath = colpath,+ |
|
| 1294 | -160x | +
- omit_labrows = omit_labrows, value_at = FALSE+ #' @rdname int_methods |
|
| 1295 | -+ | ! |
- )+ setGeneric("content_na_str<-", function(obj, value) standardGeneric("content_na_str<-"))
|
| 1296 |
- }+ |
||
| 1297 |
- )+ #' @rdname int_methods |
||
| 1298 |
-
+ setMethod("content_na_str<-", "Split", function(obj, value) {
|
||
| 1299 | -+ | ! |
- #' @rdname int_methods+ obj@content_na_str <- value |
| 1300 | -+ | ! |
- #' @keywords internal+ obj |
| 1301 |
- #' @exportMethod cell_values+ }) |
||
| 1302 |
- setMethod(+ |
||
| 1303 |
- "cell_values", "TableRow",+ #' Value formats |
||
| 1304 |
- function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
+ #' |
||
| 1305 | -2x | +
- if (!is.null(rowpath)) {
+ #' Returns a matrix of formats for the cells in a table. |
|
| 1306 | -1x | +
- stop("cell_values on TableRow objects must have NULL rowpath")
+ #' |
|
| 1307 |
- }+ #' @param obj (`VTableTree` or `TableRow`)\cr a table or row object. |
||
| 1308 | -1x | +
- .inner_cell_value(tt,+ #' @param default (`string`, `function`, or `list`)\cr default format. |
|
| 1309 | -1x | +
- rowpath = rowpath, colpath = colpath,+ #' |
|
| 1310 | -1x | +
- omit_labrows = omit_labrows, value_at = FALSE+ #' @return Matrix (storage mode list) containing the effective format for each cell position in the table |
|
| 1311 |
- )+ #' (including 'virtual' cells implied by label rows, whose formats are always `NULL`). |
||
| 1312 |
- }+ #' |
||
| 1313 |
- )+ #' @seealso [table_shell()] and [table_shell_str()] for information on the table format structure. |
||
| 1314 |
-
+ #' |
||
| 1315 |
- #' @rdname int_methods+ #' @examples |
||
| 1316 |
- #' @keywords internal+ #' lyt <- basic_table() %>% |
||
| 1317 |
- #' @exportMethod cell_values+ #' split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
|
||
| 1318 |
- setMethod(+ #' analyze("AGE")
|
||
| 1319 |
- "cell_values", "LabelRow",+ #' |
||
| 1320 |
- function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
+ #' tbl <- build_table(lyt, DM) |
||
| 1321 | -1x | +
- stop("calling cell_values on LabelRow is not meaningful")
+ #' value_formats(tbl) |
|
| 1322 |
- }+ #' |
||
| 1323 |
- )+ #' @export |
||
| 1324 | -+ | 1123x |
-
+ setGeneric("value_formats", function(obj, default = obj_format(obj)) standardGeneric("value_formats"))
|
| 1325 |
- #' @rdname cell_values+ |
||
| 1326 |
- #' @export+ #' @rdname value_formats |
||
| 1327 |
- setGeneric("value_at", function(tt, rowpath = NULL, colpath = NULL) {
+ setMethod( |
||
| 1328 | -8x | +
- standardGeneric("value_at")
+ "value_formats", "ANY", |
|
| 1329 |
- })+ function(obj, default) {
|
||
| 1330 | -+ | 762x |
-
+ obj_format(obj) %||% default |
| 1331 |
- #' @rdname cell_values+ } |
||
| 1332 |
- #' @exportMethod value_at+ ) |
||
| 1333 |
- setMethod(+ |
||
| 1334 |
- "value_at", "VTableTree",+ #' @rdname value_formats |
||
| 1335 |
- function(tt, rowpath, colpath = NULL) {
+ setMethod( |
||
| 1336 | -7x | +
- .inner_cell_value(tt,+ "value_formats", "TableRow", |
|
| 1337 | -7x | +
- rowpath = rowpath, colpath = colpath,+ function(obj, default) {
|
|
| 1338 | -7x | +245x |
- omit_labrows = FALSE, value_at = TRUE+ if (!is.null(obj_format(obj))) {
|
| 1339 | -+ | 215x |
- )+ default <- obj_format(obj) |
| 1340 |
- }+ } |
||
| 1341 | -+ | 245x |
- )+ formats <- lapply(row_cells(obj), function(x) value_formats(x) %||% default) |
| 1342 | -+ | 245x |
-
+ formats |
| 1343 |
- #' @rdname int_methods+ } |
||
| 1344 |
- #' @keywords internal+ ) |
||
| 1345 |
- #' @exportMethod value_at+ |
||
| 1346 |
- setMethod(+ #' @rdname value_formats |
||
| 1347 |
- "value_at", "TableRow",+ setMethod( |
||
| 1348 |
- function(tt, rowpath, colpath = NULL) {
+ "value_formats", "LabelRow", |
||
| 1349 | -1x | +
- .inner_cell_value(tt,+ function(obj, default) {
|
|
| 1350 | -1x | +102x |
- rowpath = rowpath, colpath = colpath,+ rep(list(NULL), ncol(obj)) |
| 1351 | -1x | +
- omit_labrows = FALSE, value_at = TRUE+ } |
|
| 1352 |
- )+ ) |
||
| 1353 |
- }+ |
||
| 1354 |
- )+ #' @rdname value_formats |
||
| 1355 |
-
+ setMethod( |
||
| 1356 |
- #' @rdname int_methods+ "value_formats", "VTableTree", |
||
| 1357 |
- #' @keywords internal+ function(obj, default) {
|
||
| 1358 | -+ | 14x |
- #' @exportMethod value_at+ if (!is.null(obj_format(obj))) {
|
| 1359 | -+ | ! |
- setMethod(+ default <- obj_format(obj) |
| 1360 |
- "value_at", "LabelRow",+ } |
||
| 1361 | -+ | 14x |
- function(tt, rowpath, colpath = NULL) {
+ rws <- collect_leaves(obj, TRUE, TRUE) |
| 1362 | -! | +14x |
- stop("calling value_at for LabelRow objects is not meaningful")
+ formatrws <- lapply(rws, value_formats, default = default) |
| 1363 | -+ | 14x |
- }+ mat <- do.call(rbind, formatrws) |
| 1364 | -+ | 14x |
- )+ row.names(mat) <- row.names(obj) |
| 1365 | -+ | 14x |
-
+ mat |
| 1366 |
- .inner_cell_value <- function(tt,+ } |
||
| 1367 |
- rowpath,+ ) |
||
| 1368 |
- colpath = NULL,+ |
||
| 1369 |
- omit_labrows = TRUE,+ ### Collect all leaves of a current tree |
||
| 1370 |
- value_at = FALSE) {
+ ### This is a workhorse function in various |
||
| 1371 | -169x | +
- if (is.null(rowpath)) {
+ ### places |
|
| 1372 | -90x | +
- subtree <- tt+ ### NB this is written generally enought o |
|
| 1373 |
- } else {
+ ### be used on all tree-based structures in the |
||
| 1374 | -79x | +
- subtree <- tt_at_path(tt, rowpath)+ ### framework. |
|
| 1375 |
- }+ |
||
| 1376 | -168x | +
- if (!is.null(colpath)) {
+ #' Collect leaves of a `TableTree` |
|
| 1377 | -28x | +
- subtree <- subset_cols(subtree, colpath)+ #' |
|
| 1378 |
- }+ #' @inheritParams gen_args |
||
| 1379 |
-
+ #' @param incl.cont (`flag`)\cr whether to include rows from content tables within the tree. Defaults to `TRUE`. |
||
| 1380 | -168x | +
- rows <- collect_leaves(subtree, TRUE, !omit_labrows)+ #' @param add.labrows (`flag`)\cr whether to include label rows. Defaults to `FALSE`. |
|
| 1381 | -168x | +
- if (value_at && (ncol(subtree) != 1 || length(rows) != 1)) {
+ #' |
|
| 1382 | -3x | +
- stop("Combination of rowpath and colpath does not select individual cell.\n",
+ #' @return A list of `TableRow` objects for all rows in the table. |
|
| 1383 | -3x | +
- " To retrieve more than one cell value at a time use cell_values().",+ #' |
|
| 1384 | -3x | +
- call. = FALSE+ #' @export |
|
| 1385 |
- )+ setGeneric("collect_leaves",
|
||
| 1386 |
- }+ function(tt, incl.cont = TRUE, add.labrows = FALSE) {
|
||
| 1387 | -165x | +109182x |
- if (length(rows) == 1) {
+ standardGeneric("collect_leaves")
|
| 1388 | -92x | +
- ret <- row_values(rows[[1]])+ }, |
|
| 1389 | -92x | +
- if (value_at && ncol(subtree) == 1) {
+ signature = "tt" |
|
| 1390 | -5x | +
- ret <- ret[[1]]+ ) |
|
| 1391 |
- }+ |
||
| 1392 | -92x | +
- ret+ #' @inheritParams collect_leaves |
|
| 1393 |
- } else {
+ #' |
||
| 1394 | -73x | +
- lapply(rows, row_values)+ #' @rdname int_methods |
|
| 1395 |
- }+ #' @exportMethod collect_leaves |
||
| 1396 |
- }+ setMethod( |
||
| 1397 |
-
+ "collect_leaves", "TableTree", |
||
| 1398 |
- ## empty_table is created in onLoad because it depends on other things there.+ function(tt, incl.cont = TRUE, add.labrows = FALSE) {
|
||
| 1399 | -+ | 23679x |
-
+ ret <- c( |
| 1400 | -+ | 23679x |
- # Helper function to copy or not header, footer, and topleft information+ if (add.labrows && labelrow_visible(tt)) {
|
| 1401 | -+ | 9771x |
- .h_copy_titles_footers_topleft <- function(new,+ tt_labelrow(tt) |
| 1402 |
- old,+ }, |
||
| 1403 | -+ | 23679x |
- keep_titles,+ if (incl.cont) {
|
| 1404 | -+ | 23679x |
- keep_footers,+ tree_children(content_table(tt)) |
| 1405 |
- keep_topleft,+ }, |
||
| 1406 | -+ | 23679x |
- reindex_refs = FALSE,+ lapply(tree_children(tt), |
| 1407 | -+ | 23679x |
- empt_tbl = empty_table) {
+ collect_leaves, |
| 1408 | -+ | 23679x |
- ## Please note that the standard adopted come from an empty table+ incl.cont = incl.cont, add.labrows = add.labrows |
| 1409 |
-
+ ) |
||
| 1410 |
- # titles+ ) |
||
| 1411 | -2886x | +23679x |
- if (isTRUE(keep_titles)) {
+ unlist(ret, recursive = TRUE) |
| 1412 | -2712x | +
- main_title(new) <- main_title(old)+ } |
|
| 1413 | -2712x | +
- subtitles(new) <- subtitles(old)+ ) |
|
| 1414 |
- } else {
+
|
||
| 1415 | -174x | +
- main_title(new) <- main_title(empt_tbl)+ #' @rdname int_methods |
|
| 1416 | -174x | +
- subtitles(new) <- subtitles(empt_tbl)+ #' @exportMethod collect_leaves |
|
| 1417 |
- }+ setMethod( |
||
| 1418 |
-
+ "collect_leaves", "ElementaryTable", |
||
| 1419 |
- # fnotes+ function(tt, incl.cont = TRUE, add.labrows = FALSE) {
|
||
| 1420 | -2886x | +55000x |
- if (isTRUE(keep_footers)) {
+ ret <- tree_children(tt) |
| 1421 | -2718x | +55000x |
- main_footer(new) <- main_footer(old)+ if (add.labrows && labelrow_visible(tt)) {
|
| 1422 | -2718x | +10700x |
- prov_footer(new) <- prov_footer(old)+ ret <- c(tt_labelrow(tt), ret) |
| 1423 |
- } else {
+ } |
||
| 1424 | -168x | +55000x |
- main_footer(new) <- main_footer(empt_tbl)+ ret |
| 1425 | -168x | +
- prov_footer(new) <- prov_footer(empt_tbl)+ } |
|
| 1426 |
- }+ ) |
||
| 1428 |
- # topleft+ #' @rdname int_methods |
||
| 1429 | -2886x | +
- if (isTRUE(keep_topleft)) {
+ #' @exportMethod collect_leaves |
|
| 1430 | -2738x | +
- top_left(new) <- top_left(old)+ setMethod( |
|
| 1431 |
- } else {
+ "collect_leaves", "VTree", |
||
| 1432 | -148x | +
- top_left(new) <- top_left(empt_tbl)+ function(tt, incl.cont, add.labrows) {
|
|
| 1433 | -+ | ! |
- }+ ret <- lapply( |
| 1434 | -+ | ! |
-
+ tree_children(tt), |
| 1435 | -+ | ! |
- # reindex references+ collect_leaves |
| 1436 | -2886x | +
- if (reindex_refs) {
+ ) |
|
| 1437 | ! |
- new <- update_ref_indexing(new)+ unlist(ret, recursive = TRUE) |
|
| 1439 |
-
+ ) |
||
| 1440 | -2886x | +
- new+ |
|
| 1441 |
- }+ #' @rdname int_methods |
||
| 1442 |
-
+ #' @exportMethod collect_leaves |
||
| 1443 |
- #' Head and tail methods+ setMethod( |
||
| 1444 |
- #'+ "collect_leaves", "VLeaf", |
||
| 1445 |
- #' @inheritParams utils::head+ function(tt, incl.cont, add.labrows) {
|
||
| 1446 | -+ | 686x |
- #' @param keep_topleft (`flag`)\cr if `TRUE` (the default), top_left material for the table will be carried over to the+ list(tt) |
| 1447 |
- #' subset.+ } |
||
| 1448 |
- #' @param keep_titles (`flag`)\cr if `TRUE` (the default), all title material for the table will be carried over to the+ ) |
||
| 1449 |
- #' subset.+ |
||
| 1450 |
- #' @param keep_footers (`flag`)\cr if `TRUE`, all footer material for the table will be carried over to the subset. It+ #' @rdname int_methods |
||
| 1451 |
- #' defaults to `keep_titles`.+ #' @exportMethod collect_leaves |
||
| 1452 |
- #' @param reindex_refs (`flag`)\cr defaults to `FALSE`. If `TRUE`, referential footnotes will be reindexed for the+ setMethod( |
||
| 1453 |
- #' subset.+ "collect_leaves", "NULL", |
||
| 1454 |
- #'+ function(tt, incl.cont, add.labrows) {
|
||
| 1455 | -+ | ! |
- #' @docType methods+ list() |
| 1456 |
- #' @export+ } |
||
| 1457 |
- #' @rdname head_tail+ ) |
||
| 1458 |
- setGeneric("head")
+
|
||
| 1459 |
-
+ #' @rdname int_methods |
||
| 1460 |
- #' @docType methods+ #' @exportMethod collect_leaves |
||
| 1461 |
- #' @export+ setMethod( |
||
| 1462 |
- #' @rdname head_tail+ "collect_leaves", "ANY", |
||
| 1463 |
- setMethod(+ function(tt, incl.cont, add.labrows) {
|
||
| 1464 | -+ | ! |
- "head", "VTableTree",+ stop("class ", class(tt), " does not inherit from VTree or VLeaf")
|
| 1465 |
- function(x, n = 6, ..., keep_topleft = TRUE,+ } |
||
| 1466 |
- keep_titles = TRUE,+ ) |
||
| 1467 |
- keep_footers = keep_titles,+ |
||
| 1468 |
- ## FALSE because this is a glance+ n_leaves <- function(tt, ...) {
|
||
| 1469 | -+ | 202x |
- ## more often than a subset op+ length(collect_leaves(tt, ...)) |
| 1470 |
- reindex_refs = FALSE) {
+ } |
||
| 1471 |
- ## default+ |
||
| 1472 | -5x | +
- res <- callNextMethod()+ ### Spanning information ---- |
|
| 1473 | -5x | +
- res <- .h_copy_titles_footers_topleft(+ |
|
| 1474 | -5x | +
- old = x, new = res,+ #' @rdname int_methods |
|
| 1475 | -5x | +53605x |
- keep_topleft = keep_topleft,+ setGeneric("row_cspans", function(obj) standardGeneric("row_cspans"))
|
| 1476 | -5x | +
- keep_titles = keep_titles,+ |
|
| 1477 | -5x | +
- keep_footers = keep_footers,+ #' @rdname int_methods |
|
| 1478 | -5x | +4548x |
- reindex_refs = reindex_refs+ setMethod("row_cspans", "TableRow", function(obj) obj@colspans)
|
| 1479 |
- )+ |
||
| 1480 | -5x | +
- res+ #' @rdname int_methods |
|
| 1481 |
- }+ setMethod( |
||
| 1482 |
- )+ "row_cspans", "LabelRow", |
||
| 1483 | -+ | 1494x |
-
+ function(obj) rep(1L, ncol(obj)) |
| 1484 |
- #' @docType methods+ ) |
||
| 1485 |
- #' @export+ |
||
| 1486 |
- #' @rdname head_tail+ #' @rdname int_methods |
||
| 1487 | -+ | 3974x |
- setGeneric("tail")
+ setGeneric("row_cspans<-", function(obj, value) standardGeneric("row_cspans<-"))
|
| 1489 |
- #' @docType methods+ #' @rdname int_methods |
||
| 1490 |
- #' @export+ setMethod("row_cspans<-", "TableRow", function(obj, value) {
|
||
| 1491 | -+ | 3974x |
- #' @rdname head_tail+ obj@colspans <- value |
| 1492 | -+ | 3974x |
- setMethod(+ obj |
| 1493 |
- "tail", "VTableTree",+ }) |
||
| 1494 |
- function(x, n = 6, ..., keep_topleft = TRUE,+ |
||
| 1495 |
- keep_titles = TRUE,+ #' @rdname int_methods |
||
| 1496 |
- keep_footers = keep_titles,+ setMethod("row_cspans<-", "LabelRow", function(obj, value) {
|
||
| 1497 |
- ## FALSE because this is a glance+ stop("attempted to set colspans for LabelRow") # nocov
|
||
| 1498 |
- ## more often than a subset op+ }) |
||
| 1499 |
- reindex_refs = FALSE) {
+
|
||
| 1500 | -4x | +
- res <- callNextMethod()+ ## XXX TODO colapse with above? |
|
| 1501 | -4x | +
- res <- .h_copy_titles_footers_topleft(+ #' @rdname int_methods |
|
| 1502 | -4x | +48091x |
- old = x, new = res,+ setGeneric("cell_cspan", function(obj) standardGeneric("cell_cspan"))
|
| 1503 | -4x | +
- keep_topleft = keep_topleft,+ |
|
| 1504 | -4x | +
- keep_titles = keep_titles,+ #' @rdname int_methods |
|
| 1505 | -4x | +
- keep_footers = keep_footers,+ setMethod( |
|
| 1506 | -4x | +
- reindex_refs = reindex_refs+ "cell_cspan", "CellValue", |
|
| 1507 | -+ | 48091x |
- )+ function(obj) attr(obj, "colspan", exact = TRUE) |
| 1508 | -4x | +
- res+ ) ## obj@colspan) |
|
| 1509 |
- }+ |
||
| 1510 |
- )+ #' @rdname int_methods |
| 1 | +1511 |
- #' @import formatters+ setGeneric( |
||
| 2 | +1512 |
- #' @importMethodsFrom formatters toString matrix_form nlines+ "cell_cspan<-",+ |
+ ||
| 1513 | +6892x | +
+ function(obj, value) standardGeneric("cell_cspan<-")
|
||
| 3 | +1514 |
- NULL+ ) |
||
| 4 | +1515 | |||
| 5 | +1516 |
- # toString ----+ #' @rdname int_methods |
||
| 6 | +1517 |
-
+ setMethod("cell_cspan<-", "CellValue", function(obj, value) {
|
||
| 7 | +1518 |
- ## #' @export+ ## obj@colspan <- value+ |
+ ||
| 1519 | +6892x | +
+ attr(obj, "colspan") <- value+ |
+ ||
| 1520 | +6892x | +
+ obj |
||
| 8 | +1521 |
- ## setGeneric("toString", function(x,...) standardGeneric("toString"))
+ }) |
||
| 9 | +1522 | |||
| 10 | +1523 |
- ## ## preserve S3 behavior+ #' @rdname int_methods |
||
| 11 | -+ | |||
| 1524 | +26628x |
- ## setMethod("toString", "ANY", base::toString)
+ setGeneric("cell_align", function(obj) standardGeneric("cell_align"))
|
||
| 12 | +1525 | |||
| 13 | +1526 |
- ## #' @export+ #' @rdname int_methods |
||
| 14 | +1527 |
- ## setMethod("print", "ANY", base::print)
+ setMethod( |
||
| 15 | +1528 |
-
+ "cell_align", "CellValue", |
||
| 16 | -+ | |||
| 1529 | +26628x |
- #' Convert an `rtable` object to a string+ function(obj) attr(obj, "align", exact = TRUE) %||% "center" |
||
| 17 | +1530 |
- #'+ ) ## obj@colspan) |
||
| 18 | +1531 |
- #' @inheritParams formatters::toString+ |
||
| 19 | +1532 |
- #' @inheritParams gen_args+ #' @rdname int_methods |
||
| 20 | +1533 |
- #' @inherit formatters::toString+ setGeneric( |
||
| 21 | +1534 |
- #'+ "cell_align<-", |
||
| 22 | -+ | |||
| 1535 | +56x |
- #' @return A string representation of `x` as it appears when printed.+ function(obj, value) standardGeneric("cell_align<-")
|
||
| 23 | +1536 |
- #'+ ) |
||
| 24 | +1537 |
- #' @examplesIf require(dplyr)+ |
||
| 25 | +1538 |
- #' library(dplyr)+ #' @rdname int_methods |
||
| 26 | +1539 |
- #'+ setMethod("cell_align<-", "CellValue", function(obj, value) {
|
||
| 27 | +1540 |
- #' iris2 <- iris %>%+ ## obj@colspan <- value |
||
| 28 | -+ | |||
| 1541 | +56x |
- #' group_by(Species) %>%+ if (is.null(value)) {
|
||
| 29 | -+ | |||
| 1542 | +! |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ value <- "center" |
||
| 30 | +1543 |
- #' ungroup()+ } else {
|
||
| 31 | -+ | |||
| 1544 | +56x |
- #'+ value <- tolower(value) |
||
| 32 | +1545 |
- #' lyt <- basic_table() %>%+ } |
||
| 33 | -+ | |||
| 1546 | +56x |
- #' split_cols_by("Species") %>%
+ check_aligns(value) |
||
| 34 | -+ | |||
| 1547 | +56x |
- #' split_cols_by("group") %>%
+ attr(obj, "align") <- value |
||
| 35 | -+ | |||
| 1548 | +56x |
- #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
+ obj |
||
| 36 | +1549 |
- #'+ }) |
||
| 37 | +1550 |
- #' tbl <- build_table(lyt, iris2)+ |
||
| 38 | +1551 |
- #'+ ### Level (indent) in tree structure ---- |
||
| 39 | +1552 |
- #' cat(toString(tbl, col_gap = 3))+ |
||
| 40 | +1553 |
- #'+ #' @rdname int_methods |
||
| 41 | -+ | |||
| 1554 | +209x |
- #' @rdname tostring+ setGeneric("tt_level", function(obj) standardGeneric("tt_level"))
|
||
| 42 | +1555 |
- #' @aliases tostring toString,VTableTree-method+ |
||
| 43 | +1556 |
- #' @exportMethod toString+ ## this will hit everything via inheritence |
||
| 44 | +1557 |
- setMethod("toString", "VTableTree", function(x,
+ #' @rdname int_methods |
||
| 45 | -+ | |||
| 1558 | +209x |
- widths = NULL,+ setMethod("tt_level", "VNodeInfo", function(obj) obj@level)
|
||
| 46 | +1559 |
- col_gap = 3,+ |
||
| 47 | +1560 |
- hsep = horizontal_sep(x),+ #' @rdname int_methods |
||
| 48 | -+ | |||
| 1561 | +2x |
- indent_size = 2,+ setGeneric("tt_level<-", function(obj, value) standardGeneric("tt_level<-"))
|
||
| 49 | +1562 |
- tf_wrap = FALSE,+ |
||
| 50 | +1563 |
- max_width = NULL,+ ## this will hit everyhing via inheritence |
||
| 51 | +1564 |
- fontspec = font_spec(),+ #' @rdname int_methods |
||
| 52 | +1565 |
- ttype_ok = FALSE) {
+ setMethod("tt_level<-", "VNodeInfo", function(obj, value) {
|
||
| 53 | -40x | +1566 | +1x |
- toString(+ obj@level <- as.integer(value) |
| 54 | -40x | +1567 | +1x |
- matrix_form(x,+ obj |
| 55 | -40x | +|||
| 1568 | +
- indent_rownames = TRUE,+ }) |
|||
| 56 | -40x | +|||
| 1569 | +
- indent_size = indent_size,+ |
|||
| 57 | -40x | +|||
| 1570 | +
- fontspec = fontspec,+ #' @rdname int_methods |
|||
| 58 | -40x | +|||
| 1571 | +
- col_gap = col_gap+ setMethod( |
|||
| 59 | +1572 |
- ),+ "tt_level<-", "VTableTree", |
||
| 60 | -40x | +|||
| 1573 | +
- widths = widths, col_gap = col_gap,+ function(obj, value) {
|
|||
| 61 | -40x | +1574 | +1x |
- hsep = hsep,+ obj@level <- as.integer(value) |
| 62 | -40x | +1575 | +1x |
- tf_wrap = tf_wrap,+ tree_children(obj) <- lapply(tree_children(obj), |
| 63 | -40x | +1576 | +1x |
- max_width = max_width,+ `tt_level<-`, |
| 64 | -40x | +1577 | +1x |
- fontspec = fontspec,+ value = as.integer(value) + 1L+ |
+
| 1578 | ++ |
+ ) |
||
| 65 | -40x | +1579 | +1x |
- ttype_ok = ttype_ok+ obj |
| 66 | +1580 |
- )+ } |
||
| 67 | +1581 |
- })+ ) |
||
| 68 | +1582 | |||
| 69 | +1583 |
- #' Table shells+ #' @rdname int_methods |
||
| 70 | +1584 |
- #'+ #' @export |
||
| 71 | -+ | |||
| 1585 | +55475x |
- #' A table shell is a rendering of the table which maintains the structure, but does not display the values, rather+ setGeneric("indent_mod", function(obj) standardGeneric("indent_mod"))
|
||
| 72 | +1586 |
- #' displaying the formatting instructions for each cell.+ |
||
| 73 | +1587 |
- #'+ #' @rdname int_methods |
||
| 74 | +1588 |
- #' @inheritParams formatters::toString+ setMethod( |
||
| 75 | +1589 |
- #' @inheritParams gen_args+ "indent_mod", "Split", |
||
| 76 | -+ | |||
| 1590 | +2986x |
- #'+ function(obj) obj@indent_modifier |
||
| 77 | +1591 |
- #' @return+ ) |
||
| 78 | +1592 |
- #' * `table_shell` returns `NULL`, as the function is called for the side effect of printing the shell to the console.+ |
||
| 79 | +1593 |
- #' * `table_shell_str` returns the string representing the table shell.+ #' @rdname int_methods |
||
| 80 | +1594 |
- #'+ setMethod( |
||
| 81 | +1595 |
- #' @seealso [value_formats()] for a matrix of formats for each cell in a table.+ "indent_mod", "VTableNodeInfo", |
||
| 82 | -+ | |||
| 1596 | +24773x |
- #'+ function(obj) obj@indent_modifier |
||
| 83 | +1597 |
- #' @examplesIf require(dplyr)+ ) |
||
| 84 | +1598 |
- #' library(dplyr)+ |
||
| 85 | +1599 |
- #'+ #' @rdname int_methods |
||
| 86 | +1600 |
- #' iris2 <- iris %>%+ setMethod( |
||
| 87 | +1601 |
- #' group_by(Species) %>%+ "indent_mod", "ANY", |
||
| 88 | -- |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ | ||
| 1602 | +24360x | +
+ function(obj) attr(obj, "indent_mod", exact = TRUE) %||% 0L |
||
| 89 | +1603 |
- #' ungroup()+ ) |
||
| 90 | +1604 |
- #'+ |
||
| 91 | +1605 |
- #' lyt <- basic_table() %>%+ #' @rdname int_methods |
||
| 92 | +1606 |
- #' split_cols_by("Species") %>%
+ setMethod( |
||
| 93 | +1607 |
- #' split_cols_by("group") %>%
+ "indent_mod", "RowsVerticalSection", |
||
| 94 | +1608 |
- #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
+ ## function(obj) setNames(obj@indent_mods,names(obj))) |
||
| 95 | +1609 |
- #'+ function(obj) {
|
||
| 96 | -+ | |||
| 1610 | +1647x |
- #' tbl <- build_table(lyt, iris2)+ val <- attr(obj, "indent_mods", exact = TRUE) %||% |
||
| 97 | -+ | |||
| 1611 | +1647x |
- #' table_shell(tbl)+ vapply(obj, indent_mod, 1L) ## rep(0L, length(obj)) |
||
| 98 | -+ | |||
| 1612 | +1647x |
- #'+ setNames(val, names(obj)) |
||
| 99 | +1613 |
- #' @export+ } |
||
| 100 | +1614 |
- table_shell <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(),+ ) |
||
| 101 | +1615 |
- tf_wrap = FALSE, max_width = NULL) {
+
|
||
| 102 | -2x | +|||
| 1616 | +
- cat(table_shell_str(+ #' @examples |
|||
| 103 | -2x | +|||
| 1617 | +
- tt = tt, widths = widths, col_gap = col_gap, hsep = hsep,+ #' lyt <- basic_table() %>% |
|||
| 104 | -2x | +|||
| 1618 | +
- tf_wrap = tf_wrap, max_width = max_width+ #' split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
|
|||
| 105 | +1619 |
- ))+ #' analyze("AGE")
|
||
| 106 | +1620 |
- }+ #' |
||
| 107 | +1621 |
-
+ #' tbl <- build_table(lyt, DM) |
||
| 108 | +1622 |
- ## XXX consider moving to formatters, its really just a function+ #' indent_mod(tbl) |
||
| 109 | +1623 |
- ## of the MatrixPrintForm+ #' indent_mod(tbl) <- 1L |
||
| 110 | +1624 |
- #' @rdname table_shell+ #' tbl |
||
| 111 | +1625 |
- #' @export+ #' |
||
| 112 | +1626 |
- table_shell_str <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(),+ #' @rdname int_methods |
||
| 113 | +1627 |
- tf_wrap = FALSE, max_width = NULL) {
+ #' @export |
||
| 114 | -2x | +1628 | +1474x |
- matform <- matrix_form(tt, indent_rownames = TRUE)+ setGeneric("indent_mod<-", function(obj, value) standardGeneric("indent_mod<-"))
|
| 115 | -2x | +|||
| 1629 | +
- format_strs <- vapply(+ |
|||
| 116 | -2x | +|||
| 1630 | +
- as.vector(matform$formats),+ #' @rdname int_methods |
|||
| 117 | -2x | +|||
| 1631 | +
- function(x) {
+ setMethod( |
|||
| 118 | -18x | +|||
| 1632 | +
- if (inherits(x, "function")) {
+ "indent_mod<-", "Split", |
|||
| 119 | -1x | +|||
| 1633 | +
- "<fnc>"+ function(obj, value) {
|
|||
| 120 | -17x | +1634 | +1x |
- } else if (inherits(x, "character")) {
+ obj@indent_modifier <- as.integer(value) |
| 121 | -17x | +1635 | +1x |
- x+ obj |
| 122 | +1636 |
- } else {
+ } |
||
| 123 | -! | +|||
| 1637 | +
- stop("Don't know how to make a shell with formats of class: ", class(x))
+ ) |
|||
| 124 | +1638 |
- }+ |
||
| 125 | +1639 |
- }, ""+ #' @rdname int_methods |
||
| 126 | +1640 |
- )+ setMethod( |
||
| 127 | +1641 |
-
+ "indent_mod<-", "VTableNodeInfo", |
||
| 128 | -2x | +|||
| 1642 | +
- format_strs_mat <- matrix(format_strs, ncol = ncol(matform$strings))+ function(obj, value) {
|
|||
| 129 | -2x | +1643 | +1470x |
- format_strs_mat[, 1] <- matform$strings[, 1]+ obj@indent_modifier <- as.integer(value) |
| 130 | -2x | +1644 | +1470x |
- nlh <- mf_nlheader(matform)+ obj |
| 131 | -2x | +|||
| 1645 | +
- format_strs_mat[seq_len(nlh), ] <- matform$strings[seq_len(nlh), ]+ } |
|||
| 132 | +1646 |
-
+ ) |
||
| 133 | -2x | +|||
| 1647 | +
- matform$strings <- format_strs_mat+ |
|||
| 134 | -2x | +|||
| 1648 | +
- if (is.null(widths)) {
+ #' @rdname int_methods |
|||
| 135 | -2x | +|||
| 1649 | +
- widths <- propose_column_widths(matform)+ setMethod( |
|||
| 136 | +1650 |
- }+ "indent_mod<-", "CellValue", |
||
| 137 | -2x | +|||
| 1651 | +
- toString(matform,+ function(obj, value) {
|
|||
| 138 | +1652 | 2x |
- widths = widths, col_gap = col_gap, hsep = hsep,+ attr(obj, "indent_mod") <- as.integer(value) |
|
| 139 | +1653 | 2x |
- tf_wrap = tf_wrap, max_width = max_width+ obj |
|
| 140 | +1654 |
- )+ } |
||
| 141 | +1655 |
- }+ ) |
||
| 142 | +1656 | |||
| 143 | +1657 |
- #' Transform an `rtable` to a list of matrices which can be used for outputting+ #' @rdname int_methods |
||
| 144 | +1658 |
- #'+ setMethod( |
||
| 145 | +1659 |
- #' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML+ "indent_mod<-", "RowsVerticalSection", |
||
| 146 | +1660 |
- #' it is useful to map the `rtable` to an in-between state with the formatted cells in a matrix form.+ function(obj, value) {
|
||
| 147 | -+ | |||
| 1661 | +1x |
- #'+ if (length(value) != 1 && length(value) != length(obj)) {
|
||
| 148 | -+ | |||
| 1662 | +! |
- #' @inheritParams gen_args+ stop( |
||
| 149 | -+ | |||
| 1663 | +! |
- #' @param indent_rownames (`flag`)\cr if `TRUE`, the column with the row names in the `strings` matrix of the output+ "When setting indent mods on a RowsVerticalSection the value ", |
||
| 150 | -+ | |||
| 1664 | +! |
- #' has indented row names (strings pre-fixed).+ "must have length 1 or the number of rows" |
||
| 151 | +1665 |
- #' @param expand_newlines (`flag`)\cr whether the matrix form generated should expand rows whose values contain+ ) |
||
| 152 | +1666 |
- #' newlines into multiple 'physical' rows (as they will appear when rendered into ASCII). Defaults to `TRUE`.+ } |
||
| 153 | -+ | |||
| 1667 | +1x |
- #' @param fontspec (`font_spec`)\cr The font that should be used by default when+ attr(obj, "indent_mods") <- as.integer(value) |
||
| 154 | -+ | |||
| 1668 | +1x |
- #' rendering this `MatrixPrintForm` object, or NULL (the default).+ obj |
||
| 155 | +1669 |
- #' @param col_gap (`numeric(1)`)]\cr The number of spaces (in the font specified+ |
||
| 156 | +1670 |
- #' by `fontspec`) that should be placed between columns when the table+ ## obj@indent_mods <- value |
||
| 157 | +1671 |
- #' is rendered directly to text (e.g., by `toString` or `export_as_txt`). Defaults+ ## obj |
||
| 158 | +1672 |
- #' to `3`.+ } |
||
| 159 | +1673 |
- #'+ ) |
||
| 160 | +1674 |
- #' @details+ |
||
| 161 | +1675 |
- #' The strings in the return object are defined as follows: row labels are those determined by `make_row_df` and cell+ #' @rdname int_methods |
||
| 162 | +1676 |
- #' values are determined using `get_formatted_cells`. (Column labels are calculated using a non-exported internal+ setGeneric( |
||
| 163 | +1677 |
- #' function.+ "content_indent_mod", |
||
| 164 | -+ | |||
| 1678 | +1219x |
- #'+ function(obj) standardGeneric("content_indent_mod")
|
||
| 165 | +1679 |
- #' @return A list with the following elements:+ ) |
||
| 166 | +1680 |
- #' \describe{
+
|
||
| 167 | +1681 |
- #' \item{`strings`}{The content, as it should be printed, of the top-left material, column headers, row labels,
+ #' @rdname int_methods |
||
| 168 | +1682 |
- #' and cell values of `tt`.}+ setMethod( |
||
| 169 | +1683 |
- #' \item{`spans`}{The column-span information for each print-string in the `strings` matrix.}
+ "content_indent_mod", "Split", |
||
| 170 | -+ | |||
| 1684 | +1219x |
- #' \item{`aligns`}{The text alignment for each print-string in the `strings` matrix.}
+ function(obj) obj@content_indent_modifier |
||
| 171 | +1685 |
- #' \item{`display`}{Whether each print-string in the strings matrix should be printed.}
+ ) |
||
| 172 | +1686 |
- #' \item{`row_info`}{The `data.frame` generated by `make_row_df`.}
+
|
||
| 173 | +1687 |
- #' }+ #' @rdname int_methods |
||
| 174 | +1688 |
- #'+ setMethod( |
||
| 175 | +1689 |
- #' With an additional `nrow_header` attribute indicating the number of pseudo "rows" that the column structure defines.+ "content_indent_mod", "VTableNodeInfo", |
||
| 176 | -+ | |||
| 1690 | +! |
- #'+ function(obj) obj@content_indent_modifier |
||
| 177 | +1691 |
- #' @examplesIf require(dplyr)+ ) |
||
| 178 | +1692 |
- #' library(dplyr)+ |
||
| 179 | +1693 |
- #'+ #' @rdname int_methods |
||
| 180 | +1694 |
- #' iris2 <- iris %>%+ setGeneric( |
||
| 181 | +1695 |
- #' group_by(Species) %>%+ "content_indent_mod<-", |
||
| 182 | -+ | |||
| 1696 | +116x |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ function(obj, value) standardGeneric("content_indent_mod<-")
|
||
| 183 | +1697 |
- #' ungroup()+ ) |
||
| 184 | +1698 |
- #'+ |
||
| 185 | +1699 |
- #' lyt <- basic_table() %>%+ #' @rdname int_methods |
||
| 186 | +1700 |
- #' split_cols_by("Species") %>%
+ setMethod( |
||
| 187 | +1701 |
- #' split_cols_by("group") %>%
+ "content_indent_mod<-", "Split", |
||
| 188 | +1702 |
- #' analyze(c("Sepal.Length", "Petal.Width"),
+ function(obj, value) {
|
||
| 189 | -+ | |||
| 1703 | +116x |
- #' afun = list_wrap_x(summary), format = "xx.xx"+ obj@content_indent_modifier <- as.integer(value) |
||
| 190 | -+ | |||
| 1704 | +116x |
- #' )+ obj |
||
| 191 | +1705 |
- #'+ } |
||
| 192 | +1706 |
- #' lyt+ ) |
||
| 193 | +1707 |
- #'+ |
||
| 194 | +1708 |
- #' tbl <- build_table(lyt, iris2)+ #' @rdname int_methods |
||
| 195 | +1709 |
- #'+ setMethod( |
||
| 196 | +1710 |
- #' matrix_form(tbl)+ "content_indent_mod<-", "VTableNodeInfo", |
||
| 197 | +1711 |
- #'+ function(obj, value) {
+ |
+ ||
| 1712 | +! | +
+ obj@content_indent_modifier <- as.integer(value)+ |
+ ||
| 1713 | +! | +
+ obj |
||
| 198 | +1714 |
- #' @export+ } |
||
| 199 | +1715 |
- setMethod(+ ) |
||
| 200 | +1716 |
- "matrix_form", "VTableTree",+ |
||
| 201 | +1717 |
- function(obj,+ ## TODO export these? |
||
| 202 | +1718 |
- indent_rownames = FALSE,+ #' @rdname int_methods |
||
| 203 | +1719 |
- expand_newlines = TRUE,+ #' @export+ |
+ ||
| 1720 | +169681x | +
+ setGeneric("rawvalues", function(obj) standardGeneric("rawvalues"))
|
||
| 204 | +1721 |
- indent_size = 2,+ |
||
| 205 | +1722 |
- fontspec = NULL,+ #' @rdname int_methods+ |
+ ||
| 1723 | +! | +
+ setMethod("rawvalues", "ValueWrapper", function(obj) obj@value)
|
||
| 206 | +1724 |
- col_gap = 3L) {
+
|
||
| 207 | -301x | +|||
| 1725 | +
- stopifnot(is(obj, "VTableTree"))+ #' @rdname int_methods |
|||
| 208 | -301x | +1726 | +66x |
- check_ccount_vis_ok(obj)+ setMethod("rawvalues", "LevelComboSplitValue", function(obj) obj@combolevels)
|
| 209 | -300x | +|||
| 1727 | +
- header_content <- .tbl_header_mat(obj) # first col are for row.names+ |
|||
| 210 | +1728 |
-
+ #' @rdname int_methods |
||
| 211 | -298x | +1729 | +3607x |
- sr <- make_row_df(obj, fontspec = fontspec)+ setMethod("rawvalues", "list", function(obj) lapply(obj, rawvalues))
|
| 212 | +1730 | |||
| 213 | -298x | +|||
| 1731 | +
- body_content_strings <- if (NROW(sr) == 0) {
+ #' @rdname int_methods |
|||
| 214 | -5x | +1732 | +4466x |
- character()+ setMethod("rawvalues", "ANY", function(obj) obj)
|
| 215 | +1733 |
- } else {
+
|
||
| 216 | -293x | +|||
| 1734 | +
- cbind(as.character(sr$label), get_formatted_cells(obj))+ #' @rdname int_methods |
|||
| 217 | -+ | |||
| 1735 | +85450x |
- }+ setMethod("rawvalues", "CellValue", function(obj) obj[[1]])
|
||
| 218 | +1736 | |||
| 219 | -298x | +|||
| 1737 | +
- formats_strings <- if (NROW(sr) == 0) {
+ #' @rdname int_methods |
|||
| 220 | -5x | +|||
| 1738 | +
- character()+ setMethod( |
|||
| 221 | +1739 |
- } else {
+ "rawvalues", "TreePos", |
||
| 222 | -293x | +1740 | +228x |
- cbind("", get_formatted_cells(obj, shell = TRUE))
+ function(obj) rawvalues(pos_splvals(obj)) |
| 223 | +1741 |
- }+ ) |
||
| 224 | +1742 | |||
| 225 | -298x | +|||
| 1743 | +
- tsptmp <- lapply(collect_leaves(obj, TRUE, TRUE), function(rr) {
+ #' @rdname int_methods |
|||
| 226 | -6584x | +|||
| 1744 | +
- sp <- row_cspans(rr)+ setMethod(+ |
+ |||
| 1745 | ++ |
+ "rawvalues", "RowsVerticalSection", |
||
| 227 | -6584x | +1746 | +2x |
- rep(sp, times = sp)+ function(obj) unlist(obj, recursive = FALSE) |
| 228 | +1747 |
- })+ ) |
||
| 229 | +1748 | |||
| 230 | +1749 |
- ## the 1 is for row labels+ #' @rdname int_methods |
||
| 231 | -298x | +|||
| 1750 | +
- body_spans <- if (nrow(obj) > 0) {
+ #' @export |
|||
| 232 | -293x | +1751 | +85075x |
- cbind(1L, do.call(rbind, tsptmp))+ setGeneric("value_names", function(obj) standardGeneric("value_names"))
|
| 233 | +1752 |
- } else {
+
|
||
| 234 | -5x | +|||
| 1753 | +
- matrix(1, nrow = 0, ncol = ncol(obj) + 1)+ #' @rdname int_methods |
|||
| 235 | +1754 |
- }+ setMethod( |
||
| 236 | +1755 |
-
+ "value_names", "ANY", |
||
| 237 | -298x | +1756 | +38x |
- body_aligns <- if (NROW(sr) == 0) {
+ function(obj) as.character(rawvalues(obj)) |
| 238 | -5x | +|||
| 1757 | +
- character()+ ) |
|||
| 239 | +1758 |
- } else {
+
|
||
| 240 | -293x | +|||
| 1759 | +
- cbind("left", get_cell_aligns(obj))
+ #' @rdname int_methods |
|||
| 241 | +1760 |
- }+ setMethod( |
||
| 242 | +1761 |
-
+ "value_names", "TreePos", |
||
| 243 | -298x | +1762 | +1418x |
- body <- rbind(header_content$body, body_content_strings)+ function(obj) value_names(pos_splvals(obj)) |
| 244 | +1763 | - - | -||
| 245 | -298x | -
- hdr_fmt_blank <- matrix("",
+ ) |
||
| 246 | -298x | +|||
| 1764 | +
- nrow = nrow(header_content$body),+ |
|||
| 247 | -298x | +|||
| 1765 | +
- ncol = ncol(header_content$body)+ #' @rdname int_methods |
|||
| 248 | +1766 |
- )+ setMethod( |
||
| 249 | -298x | +|||
| 1767 | +
- if (disp_ccounts(obj)) {
+ "value_names", "list", |
|||
| 250 | -36x | +1768 | +6793x |
- hdr_fmt_blank[nrow(hdr_fmt_blank), ] <- c("", rep(colcount_format(obj), ncol(obj)))
+ function(obj) lapply(obj, value_names) |
| 251 | +1769 |
- }+ ) |
||
| 252 | +1770 | |||
| 253 | -298x | +|||
| 1771 | +
- formats <- rbind(hdr_fmt_blank, formats_strings)+ #' @rdname int_methods |
|||
| 254 | +1772 |
-
+ setMethod( |
||
| 255 | -298x | +|||
| 1773 | +
- spans <- rbind(header_content$span, body_spans)+ "value_names", "ValueWrapper", |
|||
| 256 | -298x | +|||
| 1774 | +! |
- row.names(spans) <- NULL+ function(obj) rawvalues(obj) |
||
| 257 | +1775 |
-
+ ) |
||
| 258 | -298x | +|||
| 1776 | +
- aligns <- rbind(+ |
|||
| 259 | -298x | +|||
| 1777 | +
- matrix(rep("center", length(header_content$body)),
+ #' @rdname int_methods |
|||
| 260 | -298x | +|||
| 1778 | +
- nrow = nrow(header_content$body)+ setMethod( |
|||
| 261 | +1779 |
- ),+ "value_names", "LevelComboSplitValue", |
||
| 262 | -298x | +1780 | +1601x |
- body_aligns+ function(obj) obj@value |
| 263 | +1781 |
- )+ ) ## obj@comboname) |
||
| 264 | +1782 | |||
| 265 | -298x | +|||
| 1783 | +
- aligns[, 1] <- "left" # row names and topleft (still needed for topleft)+ #' @rdname int_methods |
|||
| 266 | +1784 |
-
+ setMethod( |
||
| 267 | -298x | +|||
| 1785 | +
- nr_header <- nrow(header_content$body)+ "value_names", "RowsVerticalSection", |
|||
| 268 | -298x | +1786 | +3270x |
- if (indent_rownames) {
+ function(obj) attr(obj, "row_names", exact = TRUE) |
| 269 | -223x | +|||
| 1787 | +
- body[, 1] <- indent_string(body[, 1], c(rep(0, nr_header), sr$indent),+ ) ## obj@row_names) |
|||
| 270 | -223x | +|||
| 1788 | +
- incr = indent_size+ |
|||
| 271 | +1789 |
- )+ ## not sure if I need these anywhere |
||
| 272 | +1790 |
- # why also formats?+ ## XXX |
||
| 273 | -223x | +|||
| 1791 | +
- formats[, 1] <- indent_string(formats[, 1], c(rep(0, nr_header), sr$indent),+ #' @rdname int_methods |
|||
| 274 | -223x | +1792 | +5554x |
- incr = indent_size+ setGeneric("value_labels", function(obj) standardGeneric("value_labels"))
|
| 275 | +1793 |
- )+ |
||
| 276 | -75x | +|||
| 1794 | +
- } else if (NROW(sr) > 0) {
+ #' @rdname int_methods |
|||
| 277 | -71x | +|||
| 1795 | +! |
- sr$indent <- rep(0, NROW(sr))+ setMethod("value_labels", "ANY", function(obj) as.character(obj_label(obj)))
|
||
| 278 | +1796 |
- }+ |
||
| 279 | +1797 | - - | -||
| 280 | -298x | -
- col_ref_strs <- matrix(vapply(header_content$footnotes, function(x) {
- |
- ||
| 281 | -2771x | -
- if (length(x) == 0) {
+ #' @rdname int_methods |
||
| 282 | +1798 |
- ""+ setMethod( |
||
| 283 | +1799 |
- } else {
+ "value_labels", "TreePos", |
||
| 284 | -5x | +|||
| 1800 | +! |
- paste(vapply(x, format_fnote_ref, ""), collapse = " ")+ function(obj) sapply(pos_splvals(obj), obj_label) |
||
| 285 | +1801 |
- }+ ) |
||
| 286 | -298x | +|||
| 1802 | +
- }, ""), ncol = ncol(body))+ |
|||
| 287 | -298x | +|||
| 1803 | +
- body_ref_strs <- get_ref_matrix(obj)+ #' @rdname int_methods |
|||
| 288 | +1804 |
-
+ setMethod("value_labels", "list", function(obj) {
|
||
| 289 | -298x | +1805 | +3858x |
- body <- matrix(+ ret <- lapply(obj, obj_label) |
| 290 | -298x | +|||
| 1806 | +
- paste0(+ if (!is.null(names(obj))) {
|
|||
| 291 | -298x | +1807 | +528x |
- body,+ inds <- vapply(ret, function(x) length(x) == 0, NA) |
| 292 | -298x | +1808 | +528x |
- rbind(+ ret[inds] <- names(obj)[inds] |
| 293 | -298x | +|||
| 1809 | +
- col_ref_strs,+ } |
|||
| 294 | -298x | +1810 | +3858x |
- body_ref_strs+ ret |
| 295 | +1811 |
- )+ }) |
||
| 296 | +1812 |
- ),+ |
||
| 297 | -298x | +|||
| 1813 | +
- nrow = nrow(body),+ #' @rdname int_methods |
|||
| 298 | -298x | +|||
| 1814 | +
- ncol = ncol(body)+ setMethod( |
|||
| 299 | +1815 |
- )+ "value_labels", |
||
| 300 | +1816 |
-
+ "RowsVerticalSection", |
||
| 301 | -298x | +1817 | +1648x |
- ref_fnotes <- get_formatted_fnotes(obj) # pagination will not count extra lines coming from here+ function(obj) setNames(attr(obj, "row_labels", exact = TRUE), value_names(obj)) |
| 302 | -298x | +|||
| 1818 | +
- pag_titles <- page_titles(obj)+ ) |
|||
| 303 | +1819 | |||
| 304 | -298x | +|||
| 1820 | +
- MatrixPrintForm(+ #' @rdname int_methods |
|||
| 305 | -298x | +|||
| 1821 | +! |
- strings = body,+ setMethod("value_labels", "ValueWrapper", function(obj) obj_label(obj))
|
||
| 306 | -298x | +|||
| 1822 | +
- spans = spans,+ |
|||
| 307 | -298x | +|||
| 1823 | +
- aligns = aligns,+ #' @rdname int_methods |
|||
| 308 | -298x | +|||
| 1824 | +
- formats = formats,+ setMethod( |
|||
| 309 | +1825 |
- ## display = display, purely a function of spans, handled in constructor now+ "value_labels", "LevelComboSplitValue", |
||
| 310 | -298x | +|||
| 1826 | +! |
- row_info = sr,+ function(obj) obj_label(obj) |
||
| 311 | -298x | +|||
| 1827 | +
- colpaths = make_col_df(obj)[["path"]],+ ) |
|||
| 312 | +1828 |
- ## line_grouping handled internally now line_grouping = 1:nrow(body),+ |
||
| 313 | -298x | +|||
| 1829 | +
- ref_fnotes = ref_fnotes,+ #' @rdname int_methods |
|||
| 314 | -298x | +1830 | +48x |
- nlines_header = nr_header, ## this is fixed internally+ setMethod("value_labels", "MultiVarSplit", function(obj) obj@var_labels)
|
| 315 | -298x | +|||
| 1831 | +
- nrow_header = nr_header,+ |
|||
| 316 | -298x | +|||
| 1832 | +
- expand_newlines = expand_newlines,+ #' @rdname int_methods |
|||
| 317 | -298x | +1833 | +5714x |
- has_rowlabs = TRUE,+ setGeneric("value_expr", function(obj) standardGeneric("value_expr"))
|
| 318 | -298x | +|||
| 1834 | +
- has_topleft = TRUE,+ #' @rdname int_methods |
|||
| 319 | -298x | +1835 | +110x |
- main_title = main_title(obj),+ setMethod("value_expr", "ValueWrapper", function(obj) obj@subset_expression)
|
| 320 | -298x | +|||
| 1836 | +
- subtitles = subtitles(obj),+ #' @rdname int_methods |
|||
| 321 | -298x | +|||
| 1837 | +! |
- page_titles = pag_titles,+ setMethod("value_expr", "ANY", function(obj) NULL)
|
||
| 322 | -298x | +|||
| 1838 | +
- main_footer = main_footer(obj),+ ## no setters for now, we'll see about that. |
|||
| 323 | -298x | +|||
| 1839 | +
- prov_footer = prov_footer(obj),+ |
|||
| 324 | -298x | +|||
| 1840 | +
- table_inset = table_inset(obj),+ #' @rdname int_methods |
|||
| 325 | -298x | +1841 | +6x |
- header_section_div = header_section_div(obj),+ setGeneric("spl_varlabels", function(obj) standardGeneric("spl_varlabels"))
|
| 326 | -298x | +|||
| 1842 | +
- horizontal_sep = horizontal_sep(obj),+ |
|||
| 327 | -298x | +|||
| 1843 | +
- indent_size = indent_size,+ #' @rdname int_methods |
|||
| 328 | -298x | +1844 | +6x |
- fontspec = fontspec,+ setMethod("spl_varlabels", "MultiVarSplit", function(obj) obj@var_labels)
|
| 329 | -298x | +|||
| 1845 | +
- col_gap = col_gap+ |
|||
| 330 | +1846 |
- )+ #' @rdname int_methods |
||
| 331 | +1847 |
- }+ setGeneric( |
||
| 332 | +1848 |
- )+ "spl_varlabels<-", |
||
| 333 | -+ | |||
| 1849 | +2x |
-
+ function(object, value) standardGeneric("spl_varlabels<-")
|
||
| 334 | +1850 |
-
+ ) |
||
| 335 | +1851 |
- check_ccount_vis_ok <- function(tt) {
+
|
||
| 336 | -301x | +|||
| 1852 | +
- ctree <- coltree(tt)+ #' @rdname int_methods |
|||
| 337 | -301x | +|||
| 1853 | +
- tlkids <- tree_children(ctree)+ setMethod("spl_varlabels<-", "MultiVarSplit", function(object, value) {
|
|||
| 338 | -301x | +1854 | +2x |
- lapply(tlkids, ccvis_check_subtree)+ object@var_labels <- value |
| 339 | -300x | +1855 | +2x |
- invisible(NULL)+ object |
| 340 | +1856 |
- }+ }) |
||
| 341 | +1857 | |||
| 342 | +1858 |
- ccvis_check_subtree <- function(ctree) {
- |
- ||
| 343 | -1508x | -
- kids <- tree_children(ctree)- |
- ||
| 344 | -1508x | -
- if (is.null(kids)) {
+ ## These two are similar enough we could probably combine |
||
| 345 | -! | +|||
| 1859 | +
- return(invisible(NULL))+ ## them but conceptually they are pretty different |
|||
| 346 | +1860 |
- }+ ## split_exargs is a list of extra arguments that apply |
||
| 347 | -1508x | +|||
| 1861 | +
- vals <- vapply(kids, disp_ccounts, TRUE)+ ## to *all the chidlren*, |
|||
| 348 | -1508x | +|||
| 1862 | +
- if (length(unique(vals)) > 1) {
+ ## while splv_extra is for *child-specific* extra arguments, |
|||
| 349 | -1x | +|||
| 1863 | +
- unmatch <- which(!duplicated(vals))[1:2]+ ## associated with specific values of the split |
|||
| 350 | -1x | +|||
| 1864 | +
- stop(+ #' @rdname int_methods |
|||
| 351 | -1x | +1865 | +3749x |
- "Detected different colcount visibility among sibling facets (those ",+ setGeneric("splv_extra", function(obj) standardGeneric("splv_extra"))
|
| 352 | -1x | +|||
| 1866 | +
- "arising from the same split_cols_by* layout instruction). This is ",+ |
|||
| 353 | -1x | +|||
| 1867 | +
- "not supported.\n",+ #' @rdname int_methods |
|||
| 354 | -1x | +|||
| 1868 | +
- "Set count values to NA if you want a blank space to appear as the ",+ setMethod( |
|||
| 355 | -1x | +|||
| 1869 | +
- "displayed count for particular facets.\n",+ "splv_extra", "SplitValue", |
|||
| 356 | -1x | +1870 | +3749x |
- "First disagreement occured at paths:\n",+ function(obj) obj@extra |
| 357 | -1x | +|||
| 1871 | +
- .path_to_disp(pos_to_path(tree_pos(kids[[unmatch[1]]]))), "\n",+ ) |
|||
| 358 | -1x | +|||
| 1872 | +
- .path_to_disp(pos_to_path(tree_pos(kids[[unmatch[2]]])))+ |
|||
| 359 | +1873 |
- )+ #' @rdname int_methods |
||
| 360 | +1874 |
- }+ setGeneric( |
||
| 361 | -1507x | +|||
| 1875 | +
- lapply(kids, ccvis_check_subtree)+ "splv_extra<-", |
|||
| 362 | -1507x | +1876 | +2086x |
- invisible(NULL)+ function(obj, value) standardGeneric("splv_extra<-")
|
| 363 | +1877 |
- }+ ) |
||
| 364 | +1878 |
-
+ #' @rdname int_methods |
||
| 365 | +1879 |
- .resolve_fn_symbol <- function(fn) {
- |
- ||
| 366 | -448x | -
- if (!is(fn, "RefFootnote")) {
- |
- ||
| 367 | -! | -
- return(NULL)+ setMethod( |
||
| 368 | +1880 |
- }+ "splv_extra<-", "SplitValue", |
||
| 369 | -448x | +|||
| 1881 | +
- ret <- ref_symbol(fn)+ function(obj, value) {
|
|||
| 370 | -448x | +1882 | +2086x |
- if (is.na(ret)) {
+ obj@extra <- value |
| 371 | -448x | +1883 | +2086x |
- ret <- as.character(ref_index(fn))+ obj |
| 372 | +1884 |
} |
||
| 373 | -448x | -
- ret- |
- ||
| 374 | +1885 |
- }+ ) |
||
| 375 | +1886 | |||
| 376 | +1887 |
- format_fnote_ref <- function(fn) {
+ #' @rdname int_methods |
||
| 377 | -40237x | +1888 | +2233x |
- if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
+ setGeneric("split_exargs", function(obj) standardGeneric("split_exargs"))
|
| 378 | -40173x | +|||
| 1889 | +
- return("")
+
|
|||
| 379 | -64x | +|||
| 1890 | +
- } else if (is.list(fn) && all(vapply(fn, is.list, TRUE))) {
+ #' @rdname int_methods |
|||
| 380 | -! | +|||
| 1891 | +
- return(vapply(fn, format_fnote_ref, ""))+ setMethod( |
|||
| 381 | +1892 |
- }+ "split_exargs", "Split", |
||
| 382 | -64x | +1893 | +2181x |
- if (is.list(fn)) {
+ function(obj) obj@extra_args |
| 383 | -59x | +|||
| 1894 | +
- inds <- unlist(lapply(unlist(fn), .resolve_fn_symbol))+ ) |
|||
| 384 | +1895 |
- } else {
+
|
||
| 385 | -5x | +|||
| 1896 | +
- inds <- .resolve_fn_symbol(fn)+ #' @rdname int_methods |
|||
| 386 | +1897 |
- }+ setGeneric( |
||
| 387 | -64x | +|||
| 1898 | +
- if (length(inds) > 0) {
+ "split_exargs<-", |
|||
| 388 | -64x | +1899 | +1x |
- paste0(" {", paste(unique(inds), collapse = ", "), "}")
+ function(obj, value) standardGeneric("split_exargs<-")
|
| 389 | +1900 |
- } else {
+ ) |
||
| 390 | +1901 |
- ""+ |
||
| 391 | +1902 |
- }+ #' @rdname int_methods |
||
| 392 | +1903 |
- }+ setMethod( |
||
| 393 | +1904 |
-
+ "split_exargs<-", "Split", |
||
| 394 | +1905 |
- format_fnote_note <- function(fn) {
+ function(obj, value) {
|
||
| 395 | -373x | +1906 | +1x |
- if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
+ obj@extra_args <- value |
| 396 | -! | +|||
| 1907 | +1x |
- return(character())+ obj |
||
| 397 | +1908 |
} |
||
| 398 | -373x | +|||
| 1909 | +
- if (is.list(fn)) {
+ )+ |
+ |||
| 1910 | ++ | + | ||
| 399 | +1911 | ! |
- return(unlist(lapply(unlist(fn), format_fnote_note)))+ is_labrow <- function(obj) is(obj, "LabelRow") |
|
| 400 | +1912 |
- }+ |
||
| 401 | +1913 |
-
+ spl_ref_group <- function(obj) {
|
||
| 402 | -373x | +1914 | +17x |
- if (is(fn, "RefFootnote")) {
+ stopifnot(is(obj, "VarLevWBaselineSplit")) |
| 403 | -373x | +1915 | +17x |
- paste0("{", .resolve_fn_symbol(fn), "} - ", ref_msg(fn))
+ obj@ref_group_value |
| 404 | +1916 |
- } else {
- |
- ||
| 405 | -! | -
- NULL+ } |
||
| 406 | +1917 |
- }+ |
||
| 407 | +1918 |
- }+ ### column info |
||
| 408 | +1919 | |||
| 409 | +1920 |
- .fn_ind_extractor <- function(strs) {
+ #' Column information/structure accessors |
||
| 410 | -! | +|||
| 1921 | +
- res <- suppressWarnings(as.numeric(gsub("\\{([[:digit:]]+)\\}.*", "\\1", strs)))
+ #' |
|||
| 411 | -! | +|||
| 1922 | +
- res[res == "NA"] <- NA_character_+ #' @inheritParams gen_args |
|||
| 412 | +1923 |
- ## these mixing is allowed now with symbols+ #' @param df (`data.frame` or `NULL`)\cr data to use if the column information is being |
||
| 413 | +1924 |
- ## if(!(sum(is.na(res)) %in% c(0L, length(res))))+ #' generated from a pre-data layout object. |
||
| 414 | +1925 |
- ## stop("Got NAs mixed with non-NAS for extracted footnote indices. This should not happen")
+ #' @param path (`character` or `NULL`)\cr `col_counts` accessor and setter only. |
||
| 415 | -! | +|||
| 1926 | +
- res+ #' Path (in column structure). |
|||
| 416 | +1927 |
- }+ #' @param rtpos (`TreePos`)\cr root position. |
||
| 417 | +1928 |
-
+ #' |
||
| 418 | +1929 |
- get_ref_matrix <- function(tt) {
+ #' @return A `LayoutColTree` object. |
||
| 419 | -298x | +|||
| 1930 | +
- if (ncol(tt) == 0 || nrow(tt) == 0) {
+ #' |
|||
| 420 | -5x | +|||
| 1931 | +
- return(matrix("", nrow = nrow(tt), ncol = ncol(tt) + 1L))
+ #' @rdname col_accessors |
|||
| 421 | +1932 |
- }+ #' @export |
||
| 422 | -293x | +1933 | +4054x |
- rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE)+ setGeneric("clayout", function(obj) standardGeneric("clayout"))
|
| 423 | -293x | +|||
| 1934 | +
- lst <- unlist(lapply(rows, cell_footnotes), recursive = FALSE)+ |
|||
| 424 | -293x | +|||
| 1935 | +
- cstrs <- unlist(lapply(lst, format_fnote_ref))+ #' @rdname col_accessors |
|||
| 425 | -293x | +|||
| 1936 | +
- bodymat <- matrix(cstrs,+ #' @exportMethod clayout |
|||
| 426 | -293x | +|||
| 1937 | +
- byrow = TRUE,+ setMethod( |
|||
| 427 | -293x | +|||
| 1938 | +
- nrow = nrow(tt),+ "clayout", "VTableNodeInfo", |
|||
| 428 | -293x | +1939 | +14x |
- ncol = ncol(tt)+ function(obj) coltree(col_info(obj)) |
| 429 | +1940 |
- )+ ) |
||
| 430 | -293x | +|||
| 1941 | +
- cbind(vapply(rows, function(rw) format_fnote_ref(row_footnotes(rw)), ""), bodymat)+ |
|||
| 431 | +1942 |
- }+ #' @rdname col_accessors |
||
| 432 | +1943 |
-
+ #' @exportMethod clayout |
||
| 433 | +1944 |
- get_formatted_fnotes <- function(tt) {
+ setMethod( |
||
| 434 | -298x | +|||
| 1945 | +
- colresfs <- unlist(make_col_df(tt, visible_only = FALSE)$col_fnotes)+ "clayout", "PreDataTableLayouts", |
|||
| 435 | -298x | +1946 | +4040x |
- rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE)+ function(obj) obj@col_layout |
| 436 | -298x | +|||
| 1947 | +
- lst <- c(+ ) |
|||
| 437 | -298x | +|||
| 1948 | +
- colresfs,+ |
|||
| 438 | -298x | +|||
| 1949 | +
- unlist(+ ## useful convenience for the cascading methods in colby_constructors |
|||
| 439 | -298x | +|||
| 1950 | +
- lapply(rows, function(r) unlist(c(row_footnotes(r), cell_footnotes(r)), recursive = FALSE)),+ #' @rdname col_accessors |
|||
| 440 | -298x | +|||
| 1951 | +
- recursive = FALSE+ #' @exportMethod clayout+ |
+ |||
| 1952 | +! | +
+ setMethod("clayout", "ANY", function(obj) PreDataColLayout())
|
||
| 441 | +1953 |
- )+ |
||
| 442 | +1954 |
- )+ #' @rdname col_accessors |
||
| 443 | +1955 |
-
+ #' @export |
||
| 444 | -298x | +1956 | +1456x |
- inds <- vapply(lst, ref_index, 1L)+ setGeneric("clayout<-", function(object, value) standardGeneric("clayout<-"))
|
| 445 | -298x | +|||
| 1957 | +
- ord <- order(inds)+ |
|||
| 446 | -298x | +|||
| 1958 | +
- lst <- lst[ord]+ #' @rdname col_accessors |
|||
| 447 | -298x | +|||
| 1959 | +
- syms <- vapply(lst, ref_symbol, "")+ #' @exportMethod clayout<- |
|||
| 448 | -298x | +|||
| 1960 | +
- keep <- is.na(syms) | !duplicated(syms)+ setMethod( |
|||
| 449 | -298x | +|||
| 1961 | +
- lst <- lst[keep]+ "clayout<-", "PreDataTableLayouts",+ |
+ |||
| 1962 | ++ |
+ function(object, value) {
|
||
| 450 | -298x | +1963 | +1456x |
- unique(vapply(lst, format_fnote_note, ""))+ object@col_layout <- value |
| 451 | -+ | |||
| 1964 | +1456x |
-
+ object |
||
| 452 | +1965 |
- ## , recursive = FALSE)+ } |
||
| 453 | +1966 |
- ## rlst <- unlist(lapply(rows, row_footnotes))+ ) |
||
| 454 | +1967 |
- ## lst <-+ |
||
| 455 | +1968 |
- ## syms <- vapply(lst, ref_symbol, "")+ #' @rdname col_accessors |
||
| 456 | +1969 |
- ## keep <- is.na(syms) | !duplicated(syms)+ #' @export |
||
| 457 | -+ | |||
| 1970 | +263546x |
- ## lst <- lst[keep]+ setGeneric("col_info", function(obj) standardGeneric("col_info"))
|
||
| 458 | +1971 |
- ## inds <- vapply(lst, ref_index, 1L)+ |
||
| 459 | +1972 |
- ## cellstrs <- unlist(lapply(lst, format_fnote_note))+ #' @rdname col_accessors |
||
| 460 | +1973 |
- ## rstrs <- unlist(lapply(rows, function(rw) format_fnote_note(row_footnotes(rw))))+ #' @exportMethod col_info |
||
| 461 | +1974 |
- ## allstrs <- c(colstrs, rstrs, cellstrs)+ setMethod( |
||
| 462 | +1975 |
- ## inds <- .fn_ind_extractor(allstrs)+ "col_info", "VTableNodeInfo", |
||
| 463 | -+ | |||
| 1976 | +232460x |
- ## allstrs[order(inds)]+ function(obj) obj@col_info |
||
| 464 | +1977 |
- }+ ) |
||
| 465 | +1978 | |||
| 466 | +1979 |
- .do_tbl_h_piece2 <- function(tt) {
+ ### XXX I've made this recursive. Do we ALWAYS want it to be? |
||
| 467 | -306x | +|||
| 1980 | +
- coldf <- make_col_df(tt, visible_only = FALSE)+ ### |
|||
| 468 | -306x | +|||
| 1981 | +
- remain <- seq_len(nrow(coldf))+ ### I think we do. |
|||
| 469 | -306x | +|||
| 1982 | +
- chunks <- list()+ #' @rdname col_accessors |
|||
| 470 | -306x | +|||
| 1983 | +
- cur <- 1+ #' @export |
|||
| 471 | -306x | +1984 | +70378x |
- na_str <- colcount_na_str(tt)+ setGeneric("col_info<-", function(obj, value) standardGeneric("col_info<-"))
|
| 472 | +1985 | |||
| 473 | +1986 |
- ## XXX this would be better as the facet-associated+ #' @return Returns various information about columns, depending on the accessor used. |
||
| 474 | +1987 |
- ## format but I don't know that we need to+ #' |
||
| 475 | +1988 |
- ## support that level of differentiation anyway...- |
- ||
| 476 | -306x | -
- cc_format <- colcount_format(tt)+ #' @exportMethod col_info<- |
||
| 477 | +1989 |
- ## each iteration of this loop identifies+ #' @rdname col_accessors |
||
| 478 | +1990 |
- ## all rows corresponding to one top-level column+ setMethod( |
||
| 479 | +1991 |
- ## label and its children, then processes those+ "col_info<-", "TableRow", |
||
| 480 | +1992 |
- ## with .do_header_chunk+ function(obj, value) {
|
||
| 481 | -306x | +1993 | +42168x |
- while (length(remain) > 0) {
+ obj@col_info <- value |
| 482 | -823x | +1994 | +42168x |
- rw <- remain[1]+ obj |
| 483 | -823x | +|||
| 1995 | +
- inds <- coldf$leaf_indices[[rw]]+ } |
|||
| 484 | -823x | +|||
| 1996 | +
- endblock <- which(coldf$abs_pos == max(inds))+ ) |
|||
| 485 | +1997 | |||
| 486 | -823x | +|||
| 1998 | +
- stopifnot(endblock >= rw)+ .set_cinfo_kids <- function(obj) {
|
|||
| 487 | -823x | +1999 | +21842x |
- chunk_res <- .do_header_chunk(coldf[rw:endblock, ], cc_format, na_str = na_str)+ kids <- lapply( |
| 488 | -821x | +2000 | +21842x |
- chunk_res <- unlist(chunk_res, recursive = FALSE)+ tree_children(obj), |
| 489 | -821x | +2001 | +21842x |
- chunks[[cur]] <- chunk_res+ function(x) {
|
| 490 | -821x | +2002 | +51771x |
- remain <- remain[remain > endblock]+ col_info(x) <- col_info(obj) |
| 491 | -821x | +2003 | +51771x |
- cur <- cur + 1+ x |
| 492 | +2004 |
- }+ } |
||
| 493 | -304x | +|||
| 2005 | +
- chunks <- .pad_tops(chunks)+ ) |
|||
| 494 | -304x | +2006 | +21842x |
- lapply(+ tree_children(obj) <- kids |
| 495 | -304x | +2007 | +21842x |
- seq_len(length(chunks[[1]])),+ obj |
| 496 | -304x | +|||
| 2008 | +
- function(i) {
+ } |
|||
| 497 | -466x | +|||
| 2009 | +
- DataRow(unlist(lapply(chunks, `[[`, i), recursive = FALSE))+ |
|||
| 498 | +2010 |
- }+ #' @rdname col_accessors |
||
| 499 | +2011 |
- )+ #' @exportMethod col_info<- |
||
| 500 | +2012 |
- }+ setMethod( |
||
| 501 | +2013 |
-
+ "col_info<-", "ElementaryTable", |
||
| 502 | +2014 |
- .pad_end <- function(lst, padto, ncols) {
+ function(obj, value) {
|
||
| 503 | -1259x | +2015 | +14165x |
- curcov <- sum(vapply(lst, cell_cspan, 0L))+ obj@col_info <- value |
| 504 | -1259x | +2016 | +14165x |
- if (curcov == padto) {
+ .set_cinfo_kids(obj) |
| 505 | -1259x | +|||
| 2017 | +
- return(lst)+ } |
|||
| 506 | +2018 |
- }+ ) |
||
| 507 | +2019 | |||
| 508 | -! | +|||
| 2020 | +
- c(lst, list(rcell("", colspan = padto - curcov)))
+ #' @rdname col_accessors |
|||
| 509 | +2021 |
- }+ #' @exportMethod col_info<- |
||
| 510 | +2022 |
-
+ setMethod( |
||
| 511 | +2023 |
- .pad_tops <- function(chunks) {
+ "col_info<-", "TableTree", |
||
| 512 | -304x | +|||
| 2024 | +
- lens <- vapply(chunks, length, 1L)+ function(obj, value) {
|
|||
| 513 | -304x | +2025 | +7677x |
- padto <- max(lens)+ obj@col_info <- value |
| 514 | -304x | +2026 | +7677x |
- needpad <- lens != padto+ if (nrow(content_table(obj))) {
|
| 515 | -304x | +2027 | +2000x |
- if (all(!needpad)) {
+ ct <- content_table(obj) |
| 516 | -298x | +2028 | +2000x |
- return(chunks)+ col_info(ct) <- value |
| 517 | -+ | |||
| 2029 | +2000x |
- }+ content_table(obj) <- ct |
||
| 518 | +2030 | - - | -||
| 519 | -6x | -
- for (i in seq_along(lens)) {
+ } |
||
| 520 | -25x | +2031 | +7677x |
- if (lens[i] < padto) {
+ .set_cinfo_kids(obj) |
| 521 | -10x | +|||
| 2032 | +
- chk <- chunks[[i]]+ } |
|||
| 522 | -10x | +|||
| 2033 | +
- span <- sum(vapply(chk[[length(chk)]], cell_cspan, 1L))+ ) |
|||
| 523 | -10x | +|||
| 2034 | +
- chunks[[i]] <- c(+ |
|||
| 524 | -10x | +|||
| 2035 | +
- replicate(list(list(rcell("", colspan = span))),
+ #' @rdname col_accessors |
|||
| 525 | -10x | +|||
| 2036 | +
- n = padto - lens[i]+ #' @param ccount_format (`FormatSpec`)\cr The format to be used by default for column |
|||
| 526 | +2037 |
- ),+ #' counts throughout this column tree (i.e. if not overridden by a more specific format |
||
| 527 | -10x | +|||
| 2038 | +
- chk+ #' specification). |
|||
| 528 | +2039 |
- )+ #' @export |
||
| 529 | +2040 |
- }+ setGeneric( |
||
| 530 | +2041 |
- }+ "coltree", |
||
| 531 | -6x | +2042 | +12097x |
- chunks+ function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format = "(N=xx)") standardGeneric("coltree")
|
| 532 | +2043 |
- }+ ) |
||
| 533 | +2044 | |||
| 534 | +2045 |
- .do_header_chunk <- function(coldf, cc_format, na_str) {
+ #' @rdname col_accessors |
||
| 535 | +2046 |
- ## hard assumption that coldf is a section+ #' @exportMethod coltree |
||
| 536 | +2047 |
- ## of a column dataframe summary that was+ setMethod( |
||
| 537 | +2048 |
- ## created with visible_only=FALSE- |
- ||
| 538 | -823x | -
- nleafcols <- length(coldf$leaf_indices[[1]])+ "coltree", "InstantiatedColumnInfo", |
||
| 539 | +2049 |
-
+ function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format) {
|
||
| 540 | -823x | +2050 | +8006x |
- spldfs <- split(coldf, lengths(coldf$path))+ if (!is.null(df)) {
|
| 541 | -823x | +|||
| 2051 | +! |
- toret <- lapply(+ warning("Ignoring df argument and retrieving already-computed LayoutColTree")
|
||
| 542 | -823x | +|||
| 2052 | +
- seq_along(spldfs),+ } |
|||
| 543 | -823x | +2053 | +8006x |
- function(i) {
+ obj@tree_layout |
| 544 | -1122x | +|||
| 2054 | +
- rws <- spldfs[[i]]+ } |
|||
| 545 | -1122x | +|||
| 2055 | +
- thisbit_vals <- lapply(+ ) |
|||
| 546 | -1122x | +|||
| 2056 | +
- seq_len(nrow(rws)),+ |
|||
| 547 | -1122x | +|||
| 2057 | +
- function(ri) {
+ #' @rdname col_accessors |
|||
| 548 | -1520x | +|||
| 2058 | +
- cellii <- rcell(rws[ri, "label", drop = TRUE],+ #' @export coltree |
|||
| 549 | -1520x | +|||
| 2059 | +
- colspan = rws$total_span[ri],+ setMethod( |
|||
| 550 | -1520x | +|||
| 2060 | +
- footnotes = rws[ri, "col_fnotes", drop = TRUE][[1]]+ "coltree", "PreDataTableLayouts", |
|||
| 551 | +2061 |
- )+ function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
|
||
| 552 | -1520x | +2062 | +1x |
- cellii+ coltree(clayout(obj), df, rtpos, alt_counts_df = alt_counts_df, ccount_format = ccount_format) |
| 553 | +2063 |
- }+ } |
||
| 554 | +2064 |
- )+ ) |
||
| 555 | -1122x | +|||
| 2065 | +
- ret <- list(.pad_end(thisbit_vals, padto = nleafcols))+ |
|||
| 556 | -1122x | +|||
| 2066 | +
- anycounts <- any(rws$ccount_visible)+ #' @rdname col_accessors |
|||
| 557 | -1122x | +|||
| 2067 | +
- if (anycounts) {
+ #' @export coltree |
|||
| 558 | -139x | +|||
| 2068 | +
- thisbit_ns <- lapply(+ setMethod( |
|||
| 559 | -139x | +|||
| 2069 | +
- seq_len(nrow(rws)),+ "coltree", "PreDataColLayout", |
|||
| 560 | -139x | +|||
| 2070 | +
- function(ri) {
+ function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
|
|||
| 561 | -287x | +2071 | +334x |
- vis_ri <- rws$ccount_visible[ri]+ obj <- set_def_child_ord(obj, df) |
| 562 | -287x | +2072 | +334x |
- val <- if (vis_ri) rws$col_count[ri] else NULL+ kids <- lapply( |
| 563 | -287x | +2073 | +334x |
- fmt <- rws$ccount_format[ri]+ obj, |
| 564 | -287x | +2074 | +334x |
- if (is.character(fmt)) {
+ function(x) {
|
| 565 | -287x | +2075 | +342x |
- cfmt_dim <- names(which(sapply(formatters::list_valid_format_labels(), function(x) any(x == fmt))))+ splitvec_to_coltree( |
| 566 | -287x | +2076 | +342x |
- if (cfmt_dim == "2d") {
+ df = df, |
| 567 | -7x | +2077 | +342x |
- if (grepl("%", fmt)) {
+ splvec = x, |
| 568 | -6x | -
- val <- c(val, 1) ## XXX This is the old behavior but it doesn't take into account parent counts...- |
- ||
| 569 | -+ | 2078 | +342x |
- } else {
+ pos = rtpos, |
| 570 | -1x | +2079 | +342x |
- stop(+ alt_counts_df = alt_counts_df, |
| 571 | -1x | +2080 | +342x |
- "This 2d format is not supported for column counts. ",+ global_cc_format = ccount_format |
| 572 | -1x | +|||
| 2081 | +
- "Please choose a 1d format or a 2d format that includes a % value."+ ) |
|||
| 573 | +2082 |
- )+ } |
||
| 574 | +2083 |
- }+ ) |
||
| 575 | -280x | +2084 | +327x |
- } else if (cfmt_dim == "3d") {
+ if (length(kids) == 1) {
|
| 576 | -1x | -
- stop("3d formats are not supported for column counts.")
- |
- ||
| 577 | -+ | 2085 | +320x |
- }+ res <- kids[[1]] |
| 578 | +2086 |
- }+ } else {
|
||
| 579 | -285x | +2087 | +7x |
- cellii <- rcell(+ res <- LayoutColTree( |
| 580 | -285x | +2088 | +7x |
- val,+ lev = 0L, |
| 581 | -285x | +2089 | +7x |
- colspan = rws$total_span[ri],+ kids = kids, |
| 582 | -285x | +2090 | +7x |
- format = fmt, # cc_format,+ tpos = rtpos, |
| 583 | -285x | +2091 | +7x |
- format_na_str = na_str+ spl = RootSplit(), |
| 584 | -+ | |||
| 2092 | +7x |
- )+ colcount = NROW(alt_counts_df), |
||
| 585 | -285x | +2093 | +7x |
- cellii+ colcount_format = ccount_format |
| 586 | +2094 |
- }+ ) |
||
| 587 | +2095 |
- )+ } |
||
| 588 | -137x | +2096 | +327x |
- ret <- c(ret, list(.pad_end(thisbit_ns, padto = nleafcols)))+ disp_ccounts(res) <- disp_ccounts(obj) |
| 589 | -+ | |||
| 2097 | +327x |
- }+ res |
||
| 590 | -1120x | +|||
| 2098 | +
- ret+ } |
|||
| 591 | +2099 |
- }+ ) |
||
| 592 | +2100 |
- )+ |
||
| 593 | -821x | +|||
| 2101 | +
- toret+ #' @rdname col_accessors |
|||
| 594 | +2102 |
- }+ #' @export coltree |
||
| 595 | +2103 |
-
+ setMethod( |
||
| 596 | +2104 |
- .tbl_header_mat <- function(tt) {
+ "coltree", "LayoutColTree", |
||
| 597 | -300x | +|||
| 2105 | +
- rows <- .do_tbl_h_piece2(tt) ## (clyt)+ function(obj, df, rtpos, alt_counts_df, ccount_format) obj |
|||
| 598 | -298x | +|||
| 2106 | +
- cinfo <- col_info(tt)+ ) |
|||
| 599 | +2107 | |||
| 600 | -298x | +|||
| 2108 | +
- nc <- ncol(tt)+ #' @rdname col_accessors |
|||
| 601 | -298x | +|||
| 2109 | +
- body <- matrix(rapply(rows, function(x) {
+ #' @export coltree |
|||
| 602 | -456x | +|||
| 2110 | +
- cs <- row_cspans(x)+ setMethod( |
|||
| 603 | -456x | +|||
| 2111 | +
- strs <- get_formatted_cells(x)+ "coltree", "VTableTree", |
|||
| 604 | -456x | +|||
| 2112 | +
- strs+ function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj)) |
|||
| 605 | -298x | +|||
| 2113 | +
- }), ncol = nc, byrow = TRUE)+ ) |
|||
| 606 | +2114 | |||
| 607 | -298x | -
- span <- matrix(rapply(rows, function(x) {
- |
- ||
| 608 | -456x | -
- cs <- row_cspans(x)- |
- ||
| 609 | -! | +|||
| 2115 | +
- if (is.null(cs)) cs <- rep(1, ncol(x))+ #' @rdname col_accessors |
|||
| 610 | -456x | +|||
| 2116 | +
- rep(cs, cs)+ #' @export coltree |
|||
| 611 | -298x | +|||
| 2117 | +
- }), ncol = nc, byrow = TRUE)+ setMethod( |
|||
| 612 | +2118 |
-
+ "coltree", "TableRow", |
||
| 613 | -298x | +|||
| 2119 | +
- fnote <- do.call(+ function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj)) |
|||
| 614 | -298x | +|||
| 2120 | +
- rbind,+ ) |
|||
| 615 | -298x | +|||
| 2121 | +
- lapply(rows, function(x) {
+
|
|||
| 616 | -456x | +2122 | +931x |
- cell_footnotes(x)+ setGeneric("coltree<-", function(obj, value) standardGeneric("coltree<-"))
|
| 617 | +2123 |
- })+ setMethod( |
||
| 618 | +2124 |
- )+ "coltree<-", c("InstantiatedColumnInfo", "LayoutColTree"),
|
||
| 619 | +2125 |
-
+ function(obj, value) {
|
||
| 620 | -298x | +2126 | +502x |
- tl <- top_left(cinfo)+ obj@tree_layout <- value |
| 621 | -298x | +2127 | +502x |
- lentl <- length(tl)+ obj |
| 622 | -298x | +|||
| 2128 | +
- nli <- nrow(body)+ } |
|||
| 623 | -298x | +|||
| 2129 | +
- if (lentl == 0) {
+ ) |
|||
| 624 | -262x | +|||
| 2130 | +
- tl <- rep("", nli)
+
|
|||
| 625 | -36x | +|||
| 2131 | +
- } else if (lentl > nli) {
+ setMethod( |
|||
| 626 | -20x | +|||
| 2132 | +
- tl_tmp <- paste0(tl, collapse = "\n")+ "coltree<-", c("VTableTree", "LayoutColTree"),
|
|||
| 627 | -20x | +|||
| 2133 | +
- tl <- rep("", nli)
+ function(obj, value) {
|
|||
| 628 | -20x | +2134 | +429x |
- tl[length(tl)] <- tl_tmp+ cinfo <- col_info(obj) |
| 629 | -16x | +2135 | +429x |
- } else if (lentl < nli) {
+ coltree(cinfo) <- value |
| 630 | -+ | |||
| 2136 | +429x |
- # We want topleft alignment that goes to the bottom!+ col_info(obj) <- cinfo |
||
| 631 | -7x | +2137 | +429x |
- tl <- c(rep("", nli - lentl), tl)
+ obj |
| 632 | +2138 |
} |
||
| 633 | -298x | +|||
| 2139 | +
- list(+ ) |
|||
| 634 | -298x | +|||
| 2140 | +
- body = cbind(tl, body, deparse.level = 0), span = cbind(1, span),+ |
|||
| 635 | -298x | +|||
| 2141 | +
- footnotes = cbind(list(list()), fnote)+ #' @rdname col_accessors |
|||
| 636 | +2142 |
- )+ #' @export |
||
| 637 | -+ | |||
| 2143 | +117582x |
- }+ setGeneric("col_exprs", function(obj, df = NULL) standardGeneric("col_exprs"))
|
||
| 638 | +2144 | |||
| 639 | +2145 |
- # get formatted cells ----+ #' @rdname col_accessors |
||
| 640 | +2146 |
-
+ #' @export col_exprs |
||
| 641 | +2147 |
- #' Get formatted cells+ setMethod( |
||
| 642 | +2148 |
- #'+ "col_exprs", "PreDataTableLayouts", |
||
| 643 | -+ | |||
| 2149 | +1x |
- #' @inheritParams gen_args+ function(obj, df = NULL) col_exprs(clayout(obj), df) |
||
| 644 | +2150 |
- #' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the values with formats+ ) |
||
| 645 | +2151 |
- #' applied. Defaults to `FALSE`.+ |
||
| 646 | +2152 |
- #'+ #' @rdname col_accessors |
||
| 647 | +2153 |
- #' @return The formatted print-strings for all (body) cells in `obj`.+ #' @export col_exprs |
||
| 648 | +2154 |
- #'+ setMethod( |
||
| 649 | +2155 |
- #' @examplesIf require(dplyr)+ "col_exprs", "PreDataColLayout", |
||
| 650 | +2156 |
- #' library(dplyr)+ function(obj, df = NULL) {
|
||
| 651 | -+ | |||
| 2157 | +1x |
- #'+ if (is.null(df)) {
|
||
| 652 | -+ | |||
| 2158 | +! |
- #' iris2 <- iris %>%+ stop("can't determine col_exprs without data")
|
||
| 653 | +2159 |
- #' group_by(Species) %>%+ } |
||
| 654 | -+ | |||
| 2160 | +1x |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ ct <- coltree(obj, df = df) |
||
| 655 | -+ | |||
| 2161 | +1x |
- #' ungroup()+ make_col_subsets(ct, df = df) |
||
| 656 | +2162 |
- #'+ } |
||
| 657 | +2163 |
- #' tbl <- basic_table() %>%+ ) |
||
| 658 | +2164 |
- #' split_cols_by("Species") %>%
+
|
||
| 659 | +2165 |
- #' split_cols_by("group") %>%
+ #' @rdname col_accessors |
||
| 660 | +2166 |
- #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx") %>%
+ #' @export col_exprs |
||
| 661 | +2167 |
- #' build_table(iris2)+ setMethod( |
||
| 662 | +2168 |
- #'+ "col_exprs", "InstantiatedColumnInfo", |
||
| 663 | +2169 |
- #' get_formatted_cells(tbl)+ function(obj, df = NULL) {
|
||
| 664 | -+ | |||
| 2170 | +117580x |
- #'+ if (!is.null(df)) {
|
||
| 665 | -+ | |||
| 2171 | +! |
- #' @export+ warning("Ignoring df method when extracted precomputed column subsetting expressions.")
|
||
| 666 | +2172 |
- #' @rdname gfc+ } |
||
| 667 | -37395x | +2173 | +117580x |
- setGeneric("get_formatted_cells", function(obj, shell = FALSE) standardGeneric("get_formatted_cells"))
+ obj@subset_exprs |
| 668 | +2174 |
-
+ } |
||
| 669 | +2175 |
- #' @rdname gfc+ ) |
||
| 670 | +2176 |
- setMethod(+ |
||
| 671 | +2177 |
- "get_formatted_cells", "TableTree",+ #' @rdname int_methods+ |
+ ||
| 2178 | +2603x | +
+ setGeneric("col_extra_args", function(obj, df = NULL) standardGeneric("col_extra_args"))
|
||
| 672 | +2179 |
- function(obj, shell = FALSE) {
+
|
||
| 673 | -2732x | +|||
| 2180 | +
- lr <- get_formatted_cells(tt_labelrow(obj), shell = shell)+ #' @rdname int_methods |
|||
| 674 | +2181 |
-
+ setMethod( |
||
| 675 | -2732x | +|||
| 2182 | +
- ct <- get_formatted_cells(content_table(obj), shell = shell)+ "col_extra_args", "InstantiatedColumnInfo", |
|||
| 676 | +2183 |
-
+ function(obj, df) {
|
||
| 677 | -2732x | +2184 | +2276x |
- els <- lapply(tree_children(obj), get_formatted_cells, shell = shell)+ if (!is.null(df)) {
|
| 678 | -+ | |||
| 2185 | +! |
-
+ warning("Ignorning df when retrieving already-computed column extra arguments.")
|
||
| 679 | +2186 |
- ## TODO fix ncol problem for rrow()+ } |
||
| 680 | -2732x | +2187 | +2276x |
- if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
+ obj@cextra_args |
| 681 | -751x | +|||
| 2188 | +
- ct <- lr[NULL, ]+ } |
|||
| 682 | +2189 |
- }+ ) |
||
| 683 | +2190 | |||
| 684 | -2732x | +|||
| 2191 | +
- do.call(rbind, c(list(lr), list(ct), els))+ #' @rdname int_methods |
|||
| 685 | +2192 |
- }+ setMethod( |
||
| 686 | +2193 |
- )+ "col_extra_args", "PreDataTableLayouts", |
||
| 687 | +2194 |
-
+ function(obj, df) col_extra_args(clayout(obj), df) |
||
| 688 | +2195 |
- #' @rdname gfc+ ) |
||
| 689 | +2196 |
- setMethod(+ |
||
| 690 | +2197 |
- "get_formatted_cells", "ElementaryTable",+ #' @rdname int_methods |
||
| 691 | +2198 |
- function(obj, shell = FALSE) {
+ setMethod( |
||
| 692 | -5433x | +|||
| 2199 | +
- lr <- get_formatted_cells(tt_labelrow(obj), shell = shell)+ "col_extra_args", "PreDataColLayout", |
|||
| 693 | -5433x | +|||
| 2200 | +
- els <- lapply(tree_children(obj), get_formatted_cells, shell = shell)+ function(obj, df) {
|
|||
| 694 | -5433x | +|||
| 2201 | +! |
- do.call(rbind, c(list(lr), els))+ col_extra_args(coltree(obj, df), NULL) |
||
| 695 | +2202 |
} |
||
| 696 | +2203 |
) |
||
| 697 | +2204 | |||
| 698 | +2205 |
- #' @rdname gfc+ #' @rdname int_methods |
||
| 699 | +2206 |
setMethod( |
||
| 700 | -- |
- "get_formatted_cells", "TableRow",- |
- ||
| 701 | +2207 |
- function(obj, shell = FALSE) {
+ "col_extra_args", "LayoutColTree", |
||
| 702 | +2208 |
- # Parent row format and na_str+ function(obj, df) {
|
||
| 703 | -21037x | +2209 | +327x |
- pr_row_format <- if (is.null(obj_format(obj))) "xx" else obj_format(obj)+ if (!is.null(df)) {
|
| 704 | -21037x | +|||
| 2210 | +! |
- pr_row_na_str <- obj_na_str(obj) %||% "NA"+ warning("Ignoring df argument and returning already calculated extra arguments")
|
||
| 705 | +2211 |
-
+ } |
||
| 706 | -21037x | +2212 | +327x |
- matrix(+ get_col_extras(obj) |
| 707 | -21037x | +|||
| 2213 | +
- unlist(Map(function(val, spn, shelli) {
+ } |
|||
| 708 | -100818x | +|||
| 2214 | +
- stopifnot(is(spn, "integer"))+ ) |
|||
| 709 | +2215 | |||
| 710 | -100818x | -
- out <- format_rcell(val,- |
- ||
| 711 | -100818x | +|||
| 2216 | +
- pr_row_format = pr_row_format,+ #' @rdname int_methods |
|||
| 712 | -100818x | +|||
| 2217 | +
- pr_row_na_str = pr_row_na_str,+ setMethod( |
|||
| 713 | -100818x | +|||
| 2218 | +
- shell = shelli+ "col_extra_args", "LayoutColLeaf", |
|||
| 714 | +2219 |
- )+ function(obj, df) {
|
||
| 715 | -100818x | +|||
| 2220 | +! |
- if (!is.function(out) && is.character(out)) {
+ if (!is.null(df)) {
|
||
| 716 | -100810x | +|||
| 2221 | +! |
- out <- paste(out, collapse = ", ")+ warning("Ignoring df argument and returning already calculated extra arguments")
|
||
| 717 | +2222 |
- }+ } |
||
| 718 | +2223 | |||
| 719 | -100818x | +|||
| 2224 | +! |
- rep(list(out), spn)+ get_pos_extra(pos = tree_pos(obj)) |
||
| 720 | -21037x | +|||
| 2225 | +
- }, val = row_cells(obj), spn = row_cspans(obj), shelli = shell)),+ } |
|||
| 721 | -21037x | +|||
| 2226 | +
- ncol = ncol(obj)+ ) |
|||
| 722 | +2227 |
- )+ |
||
| 723 | +2228 |
- }+ #' @seealso [facet_colcount()] |
||
| 724 | +2229 |
- )+ #' @export |
||
| 725 | +2230 | ++ |
+ #' @rdname col_accessors+ |
+ |
| 2231 | +2052x | +
+ setGeneric("col_counts", function(obj, path = NULL) standardGeneric("col_counts"))
+ |
+ ||
| 2232 | ||||
| 726 | +2233 |
- #' @rdname gfc+ #' @export |
||
| 727 | +2234 |
- setMethod(+ #' @rdname col_accessors |
||
| 728 | +2235 |
- "get_formatted_cells", "LabelRow",+ setMethod( |
||
| 729 | +2236 |
- function(obj, shell = FALSE) {
+ "col_counts", "InstantiatedColumnInfo", |
||
| 730 | -8193x | +|||
| 2237 | +
- nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
+ function(obj, path = NULL) {
|
|||
| 731 | -8193x | +2238 | +2035x |
- vstr <- if (shell) "-" else ""+ if (is.null(path)) {
|
| 732 | -8193x | +2239 | +2034x |
- if (labelrow_visible(obj)) {
+ lfs <- collect_leaves(coltree(obj)) |
| 733 | -2988x | +2240 | +2034x |
- matrix(rep(vstr, nc), ncol = nc)+ ret <- vapply(lfs, facet_colcount, 1L, path = NULL) |
| 734 | +2241 |
} else {
|
||
| 735 | -5205x | +2242 | +1x |
- matrix(character(0), ncol = nc)+ ret <- facet_colcount(obj, path) |
| 736 | +2243 |
} |
||
| 737 | +2244 |
- }+ ## required for strict backwards compatibility, |
||
| 738 | +2245 |
- )+ ## even though its undesirable behavior. |
||
| 739 | -+ | |||
| 2246 | +2035x |
-
+ unname(ret) |
||
| 740 | +2247 |
- #' @rdname gfc+ } |
||
| 741 | -13256x | +|||
| 2248 | +
- setGeneric("get_cell_aligns", function(obj) standardGeneric("get_cell_aligns"))
+ ) |
|||
| 742 | +2249 | |||
| 743 | +2250 |
- #' @rdname gfc+ #' @export |
||
| 744 | +2251 |
- setMethod(+ #' @rdname col_accessors |
||
| 745 | +2252 |
- "get_cell_aligns", "TableTree",+ setMethod( |
||
| 746 | +2253 |
- function(obj) {
+ "col_counts", "VTableNodeInfo", |
||
| 747 | -1364x | +2254 | +17x |
- lr <- get_cell_aligns(tt_labelrow(obj))+ function(obj, path = NULL) col_counts(col_info(obj), path = path) |
| 748 | +2255 | - - | -||
| 749 | -1364x | -
- ct <- get_cell_aligns(content_table(obj))+ ) |
||
| 750 | +2256 | |||
| 751 | -1364x | -
- els <- lapply(tree_children(obj), get_cell_aligns)- |
- ||
| 752 | +2257 |
-
+ #' @export |
||
| 753 | +2258 |
- ## TODO fix ncol problem for rrow()+ #' @rdname col_accessors |
||
| 754 | -1364x | +2259 | +14x |
- if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
+ setGeneric("col_counts<-", function(obj, path = NULL, value) standardGeneric("col_counts<-"))
|
| 755 | -375x | +|||
| 2260 | +
- ct <- lr[NULL, ]+ |
|||
| 756 | +2261 |
- }+ #' @export |
||
| 757 | +2262 |
-
+ #' @rdname col_accessors |
||
| 758 | -1364x | +|||
| 2263 | +
- do.call(rbind, c(list(lr), list(ct), els))+ setMethod( |
|||
| 759 | +2264 |
- }+ "col_counts<-", "InstantiatedColumnInfo", |
||
| 760 | +2265 |
- )+ function(obj, path = NULL, value) {
|
||
| 761 | +2266 |
-
+ ## obj@counts[.path_to_pos(path, obj, cols = TRUE)] <- value |
||
| 762 | +2267 |
- #' @rdname gfc+ ## obj |
||
| 763 | -+ | |||
| 2268 | +9x |
- setMethod(+ if (!is.null(path)) {
|
||
| 764 | -+ | |||
| 2269 | +1x |
- "get_cell_aligns", "ElementaryTable",+ all_paths <- list(path) |
||
| 765 | +2270 |
- function(obj) {
+ } else {
|
||
| 766 | -2712x | +2271 | +8x |
- lr <- get_cell_aligns(tt_labelrow(obj))+ all_paths <- make_col_df(obj, visible_only = TRUE)$path |
| 767 | -2712x | +|||
| 2272 | +
- els <- lapply(tree_children(obj), get_cell_aligns)+ } |
|||
| 768 | -2712x | +2273 | +9x |
- do.call(rbind, c(list(lr), els))+ if (length(value) != length(all_paths)) {
|
| 769 | -+ | |||
| 2274 | +! |
- }+ stop( |
||
| 770 | -+ | |||
| 2275 | +! |
- )+ "Got ", length(value), " values for ", |
||
| 771 | -+ | |||
| 2276 | +! |
-
+ length(all_paths), " column paths", |
||
| 772 | -+ | |||
| 2277 | +! |
- #' @rdname gfc+ if (is.null(path)) " (from path = NULL)", |
||
| 773 | +2278 |
- setMethod(+ "." |
||
| 774 | +2279 |
- "get_cell_aligns", "TableRow",+ ) |
||
| 775 | +2280 |
- function(obj) {
+ } |
||
| 776 | -5090x | +2281 | +9x |
- als <- vapply(row_cells(obj), cell_align, "")+ ctree <- coltree(obj) |
| 777 | -5090x | +2282 | +9x |
- spns <- row_cspans(obj)+ for (i in seq_along(all_paths)) {
+ |
+
| 2283 | +73x | +
+ facet_colcount(ctree, all_paths[[i]]) <- value[i] |
||
| 778 | +2284 |
-
+ } |
||
| 779 | -5090x | +2285 | +9x |
- matrix(rep(als, times = spns),+ coltree(obj) <- ctree |
| 780 | -5090x | +2286 | +9x |
- ncol = ncol(obj)+ obj |
| 781 | +2287 |
- )+ } |
||
| 782 | +2288 |
- }+ ) |
||
| 783 | +2289 |
- )+ |
||
| 784 | +2290 |
-
+ #' @export |
||
| 785 | +2291 |
- #' @rdname gfc+ #' @rdname col_accessors |
||
| 786 | +2292 |
setMethod( |
||
| 787 | +2293 |
- "get_cell_aligns", "LabelRow",+ "col_counts<-", "VTableNodeInfo", |
||
| 788 | +2294 |
- function(obj) {
+ function(obj, path = NULL, value) {
|
||
| 789 | -4090x | +2295 | +5x |
- nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
+ cinfo <- col_info(obj) |
| 790 | -4090x | +2296 | +5x |
- if (labelrow_visible(obj)) {
+ col_counts(cinfo, path = path) <- value |
| 791 | -1494x | -
- matrix(rep("center", nc), ncol = nc)
- |
- ||
| 792 | -+ | 2297 | +5x |
- } else {
+ col_info(obj) <- cinfo |
| 793 | -2596x | +2298 | +5x |
- matrix(character(0), ncol = nc)+ obj |
| 794 | +2299 |
- }+ } |
||
| 795 | +2300 |
- }+ ) |
||
| 796 | +2301 |
- )+ |
||
| 797 | +2302 |
-
+ #' @export |
||
| 798 | +2303 |
- # utility functions ----+ #' @rdname col_accessors+ |
+ ||
| 2304 | +1628x | +
+ setGeneric("col_total", function(obj) standardGeneric("col_total"))
|
||
| 799 | +2305 | |||
| 800 | +2306 |
- #' From a sorted sequence of numbers, remove numbers where diff == 1+ #' @export |
||
| 801 | +2307 |
- #'+ #' @rdname col_accessors |
||
| 802 | +2308 |
- #' @examples+ setMethod( |
||
| 803 | +2309 |
- #' remove_consecutive_numbers(x = c(2, 4, 9))+ "col_total", "InstantiatedColumnInfo", |
||
| 804 | -+ | |||
| 2310 | +1627x |
- #' remove_consecutive_numbers(x = c(2, 4, 5, 9))+ function(obj) obj@total_count |
||
| 805 | +2311 |
- #' remove_consecutive_numbers(x = c(2, 4, 5, 6, 9))+ ) |
||
| 806 | +2312 |
- #' remove_consecutive_numbers(x = 4:9)+ |
||
| 807 | +2313 |
- #'+ #' @export |
||
| 808 | +2314 |
- #' @noRd+ #' @rdname col_accessors |
||
| 809 | +2315 |
- remove_consecutive_numbers <- function(x) {
+ setMethod( |
||
| 810 | +2316 |
- # actually should be integer+ "col_total", "VTableNodeInfo", |
||
| 811 | -! | +|||
| 2317 | +1x |
- stopifnot(is.wholenumber(x), is.numeric(x), !is.unsorted(x))+ function(obj) col_total(col_info(obj)) |
||
| 812 | +2318 |
-
+ ) |
||
| 813 | -! | +|||
| 2319 | +
- if (length(x) == 0) {
+
|
|||
| 814 | -! | +|||
| 2320 | +
- return(integer(0))+ #' @export |
|||
| 815 | +2321 |
- }+ #' @rdname col_accessors |
||
| 816 | -! | +|||
| 2322 | +2x |
- if (!is.integer(x)) x <- as.integer(x)+ setGeneric("col_total<-", function(obj, value) standardGeneric("col_total<-"))
|
||
| 817 | +2323 | |||
| 818 | -! | +|||
| 2324 | +
- x[c(TRUE, diff(x) != 1)]+ #' @export |
|||
| 819 | +2325 |
- }+ #' @rdname col_accessors |
||
| 820 | +2326 |
-
+ setMethod( |
||
| 821 | +2327 |
- #' Insert an empty string+ "col_total<-", "InstantiatedColumnInfo", |
||
| 822 | +2328 |
- #'+ function(obj, value) {
|
||
| 823 | +2329 |
- #' @examples+ ## all methods funnel to this one so ensure integer-ness here. |
||
| 824 | -+ | |||
| 2330 | +1x |
- #' empty_string_after(letters[1:5], 2)+ obj@total_count <- as.integer(value)+ |
+ ||
| 2331 | +1x | +
+ obj |
||
| 825 | +2332 |
- #' empty_string_after(letters[1:5], c(2, 4))+ } |
||
| 826 | +2333 |
- #'+ ) |
||
| 827 | +2334 |
- #' @noRd+ |
||
| 828 | +2335 |
- empty_string_after <- function(x, indices) {
+ #' @export |
||
| 829 | -! | +|||
| 2336 | +
- if (length(indices) > 0) {
+ #' @rdname col_accessors |
|||
| 830 | -! | +|||
| 2337 | +
- offset <- 0+ setMethod( |
|||
| 831 | -! | +|||
| 2338 | +
- for (i in sort(indices)) {
+ "col_total<-", "VTableNodeInfo", |
|||
| 832 | -! | +|||
| 2339 | +
- x <- append(x, "", i + offset)+ function(obj, value) {
|
|||
| 833 | -! | +|||
| 2340 | +1x |
- offset <- offset + 1+ cinfo <- col_info(obj) |
||
| 834 | -+ | |||
| 2341 | +1x |
- }+ col_total(cinfo) <- value |
||
| 835 | -+ | |||
| 2342 | +1x |
- }+ col_info(obj) <- cinfo |
||
| 836 | -! | +|||
| 2343 | +1x |
- x+ obj |
||
| 837 | +2344 |
- }+ } |
||
| 838 | +2345 |
-
+ ) |
||
| 839 | +2346 |
- #' Indent strings+ |
||
| 840 | +2347 |
- #'+ #' @rdname int_methods |
||
| 841 | -+ | |||
| 2348 | +19164x |
- #' Used in rtables to indent row names for the ASCII output.+ setGeneric("disp_ccounts", function(obj) standardGeneric("disp_ccounts"))
|
||
| 842 | +2349 |
- #'+ |
||
| 843 | +2350 |
- #' @param x (`character`)\cr a character vector.+ #' @rdname int_methods |
||
| 844 | +2351 |
- #' @param indent (`numeric`)\cr a vector of non-negative integers of length `length(x)`.+ setMethod( |
||
| 845 | +2352 |
- #' @param incr (`integer(1)`)\cr a non-negative number of spaces per indent level.+ "disp_ccounts", "VTableTree", |
||
| 846 | -+ | |||
| 2353 | +313x |
- #' @param including_newline (`flag`)\cr whether newlines should also be indented.+ function(obj) disp_ccounts(col_info(obj)) |
||
| 847 | +2354 |
- #'+ ) |
||
| 848 | +2355 |
- #' @return `x`, indented with left-padding with `indent * incr` white-spaces.+ |
||
| 849 | +2356 |
- #'+ #' @rdname int_methods |
||
| 850 | +2357 |
- #' @examples+ setMethod( |
||
| 851 | +2358 |
- #' indent_string("a", 0)
+ "disp_ccounts", "InstantiatedColumnInfo", |
||
| 852 | -+ | |||
| 2359 | +610x |
- #' indent_string("a", 1)
+ function(obj) obj@display_columncounts |
||
| 853 | +2360 |
- #' indent_string(letters[1:3], 0:2)+ ) |
||
| 854 | +2361 |
- #' indent_string(paste0(letters[1:3], "\n", LETTERS[1:3]), 0:2)+ |
||
| 855 | +2362 |
- #'+ #' @rdname int_methods |
||
| 856 | +2363 |
- #' @export+ setMethod( |
||
| 857 | +2364 |
- indent_string <- function(x, indent = 0, incr = 2, including_newline = TRUE) {
- |
- ||
| 858 | -598x | -
- if (length(x) > 0) {
- |
- ||
| 859 | -598x | -
- indent <- rep_len(indent, length.out = length(x))+ "disp_ccounts", "PreDataTableLayouts", |
||
| 860 | -598x | +2365 | +976x |
- incr <- rep_len(incr, length.out = length(x))+ function(obj) disp_ccounts(clayout(obj)) |
| 861 | +2366 |
- }+ ) |
||
| 862 | +2367 | |||
| 863 | -598x | -
- indent_str <- strrep(" ", (indent > 0) * indent * incr)
- |
- ||
| 864 | +2368 | - - | -||
| 865 | -598x | -
- if (including_newline) {
- |
- ||
| 866 | -598x | -
- x <- unlist(mapply(function(xi, stri) {
- |
- ||
| 867 | -12796x | -
- gsub("\n", stri, xi, fixed = TRUE)
- |
- ||
| 868 | -598x | -
- }, x, paste0("\n", indent_str)))
+ #' @rdname int_methods |
||
| 869 | +2369 |
- }+ setMethod( |
||
| 870 | +2370 |
-
+ "disp_ccounts", "PreDataColLayout", |
||
| 871 | -598x | +2371 | +1303x |
- paste0(indent_str, x)+ function(obj) obj@display_columncounts |
| 872 | +2372 |
- }+ ) |
||
| 873 | +2373 | |||
| 874 | +2374 |
- ## .paste_no_na <- function(x, ...) {
+ #' @rdname int_methods |
||
| 875 | +2375 |
- ## paste(na.omit(x), ...)+ setMethod( |
||
| 876 | +2376 |
- ## }+ "disp_ccounts", "LayoutColTree", |
||
| 877 | -+ | |||
| 2377 | +717x |
-
+ function(obj) obj@display_columncounts |
||
| 878 | +2378 |
- ## #' Pad a string and align within string+ ) |
||
| 879 | +2379 |
- ## #'+ |
||
| 880 | +2380 |
- ## #' @param x string+ #' @rdname int_methods |
||
| 881 | +2381 |
- ## #' @param n number of character of the output string, if `n < nchar(x)` an error is thrown+ setMethod( |
||
| 882 | +2382 |
- ## #'+ "disp_ccounts", "LayoutColLeaf", |
||
| 883 | -+ | |||
| 2383 | +13829x |
- ## #' @noRd+ function(obj) obj@display_columncounts |
||
| 884 | +2384 |
- ## #'+ ) |
||
| 885 | +2385 |
- ## #' @examples+ |
||
| 886 | +2386 |
- ## #'+ #' @rdname int_methods |
||
| 887 | +2387 |
- ## #' padstr("abc", 3)
+ setMethod( |
||
| 888 | +2388 |
- ## #' padstr("abc", 4)
+ "disp_ccounts", "Split", |
||
| 889 | -+ | |||
| 2389 | +1269x |
- ## #' padstr("abc", 5)
+ function(obj) obj@child_show_colcounts |
||
| 890 | +2390 |
- ## #' padstr("abc", 5, "left")
+ ) |
||
| 891 | +2391 |
- ## #' padstr("abc", 5, "right")
+
|
||
| 892 | +2392 |
- ## #'+ #' @rdname int_methods |
||
| 893 | -+ | |||
| 2393 | +2266x |
- ## #' if(interactive()){
+ setGeneric("disp_ccounts<-", function(obj, value) standardGeneric("disp_ccounts<-"))
|
||
| 894 | +2394 |
- ## #' padstr("abc", 1)
+
|
||
| 895 | +2395 |
- ## #' }+ #' @rdname int_methods |
||
| 896 | +2396 |
- ## #'+ setMethod( |
||
| 897 | +2397 |
- ## padstr <- function(x, n, just = c("center", "left", "right")) {
+ "disp_ccounts<-", "VTableTree", |
||
| 898 | +2398 |
-
+ function(obj, value) {
|
||
| 899 | -+ | |||
| 2399 | +1x |
- ## just <- match.arg(just)+ cinfo <- col_info(obj) |
||
| 900 | -+ | |||
| 2400 | +1x |
-
+ disp_ccounts(cinfo) <- value |
||
| 901 | -+ | |||
| 2401 | +1x |
- ## if (length(x) != 1) stop("length of x needs to be 1 and not", length(x))
+ col_info(obj) <- cinfo |
||
| 902 | -+ | |||
| 2402 | +1x |
- ## if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0")
+ obj |
||
| 903 | +2403 |
-
+ } |
||
| 904 | +2404 |
- ## if (is.na(x)) x <- "<NA>"+ ) |
||
| 905 | +2405 | |||
| 906 | +2406 |
- ## nc <- nchar(x)+ #' @rdname int_methods |
||
| 907 | +2407 |
-
+ setMethod( |
||
| 908 | +2408 |
- ## if (n < nc) stop("\"", x, "\" has more than ", n, " characters")
+ "disp_ccounts<-", "InstantiatedColumnInfo", |
||
| 909 | +2409 |
-
+ function(obj, value) {
|
||
| 910 | -+ | |||
| 2410 | +2x |
- ## switch(+ obj@display_columncounts <- value |
||
| 911 | -+ | |||
| 2411 | +2x |
- ## just,+ obj |
||
| 912 | +2412 |
- ## center = {
+ } |
||
| 913 | +2413 |
- ## pad <- (n - nc)/2+ ) |
||
| 914 | +2414 |
- ## paste0(spaces(floor(pad)), x, spaces(ceiling(pad)))+ |
||
| 915 | +2415 |
- ## },+ #' @rdname int_methods |
||
| 916 | +2416 |
- ## left = paste0(x, spaces(n - nc)),+ setMethod( |
||
| 917 | +2417 |
- ## right = paste0(spaces(n - nc), x)+ "disp_ccounts<-", "PreDataColLayout", |
||
| 918 | +2418 |
- ## )+ function(obj, value) {
|
||
| 919 | -+ | |||
| 2419 | +332x |
- ## }+ obj@display_columncounts <- value |
||
| 920 | -+ | |||
| 2420 | +332x |
-
+ obj |
||
| 921 | +2421 |
- ## spaces <- function(n) {
+ } |
||
| 922 | +2422 |
- ## strrep(" ", n)
+ ) |
||
| 923 | +2423 |
- ## }+ |
||
| 924 | +2424 |
-
+ #' @rdname int_methods |
||
| 925 | +2425 |
- #' Convert matrix of strings into a string with aligned columns+ setMethod( |
||
| 926 | +2426 |
- #'+ "disp_ccounts<-", "LayoutColTree", |
||
| 927 | +2427 |
- #' Note that this function is intended to print simple rectangular matrices and not `rtable`s.+ function(obj, value) {
|
||
| 928 | -+ | |||
| 2428 | +328x |
- #'+ obj@display_columncounts <- value |
||
| 929 | -+ | |||
| 2429 | +328x |
- #' @param mat (`matrix`)\cr a matrix of strings.+ obj |
||
| 930 | +2430 |
- #' @param nheader (`integer(1)`)\cr number of header rows.+ } |
||
| 931 | +2431 |
- #' @param colsep (`string`)\cr a string that separates the columns.+ ) |
||
| 932 | +2432 |
- #' @param hsep (`character(1)`)\cr character to build line separator.+ |
||
| 933 | +2433 |
- #'+ #' @rdname int_methods |
||
| 934 | +2434 |
- #' @return A string.+ setMethod( |
||
| 935 | +2435 |
- #'+ "disp_ccounts<-", "LayoutColLeaf", |
||
| 936 | +2436 |
- #' @examples+ function(obj, value) {
|
||
| 937 | -+ | |||
| 2437 | +1271x |
- #' mat <- matrix(c("A", "B", "C", "a", "b", "c"), nrow = 2, byrow = TRUE)
+ obj@display_columncounts <- value |
||
| 938 | -+ | |||
| 2438 | +1271x |
- #' cat(mat_as_string(mat))+ obj |
||
| 939 | +2439 |
- #' cat("\n")
+ } |
||
| 940 | +2440 |
- #'+ ) |
||
| 941 | +2441 |
- #' @noRd+ |
||
| 942 | +2442 |
- mat_as_string <- function(mat, nheader = 1, colsep = " ", hsep = default_hsep()) {
- |
- ||
| 943 | -2x | -
- colwidths <- apply(apply(mat, c(1, 2), nchar), 2, max)+ #' @rdname int_methods |
||
| 944 | +2443 | - - | -||
| 945 | -2x | -
- rows_formatted <- apply(mat, 1, function(row) {
- |
- ||
| 946 | -36x | -
- paste(unlist(mapply(padstr, row, colwidths, "left")), collapse = colsep)+ setMethod( |
||
| 947 | +2444 |
- })+ "disp_ccounts<-", "PreDataTableLayouts", |
||
| 948 | +2445 |
-
+ function(obj, value) {
|
||
| 949 | -2x | +2446 | +332x |
- header_rows <- seq_len(nheader)+ clyt <- clayout(obj) |
| 950 | -2x | +2447 | +332x |
- nchwidth <- nchar(rows_formatted[1])+ disp_ccounts(clyt) <- value |
| 951 | -2x | +2448 | +332x |
- paste(c(+ clayout(obj) <- clyt |
| 952 | -2x | +2449 | +332x |
- rows_formatted[header_rows],+ obj |
| 953 | -2x | +|||
| 2450 | +
- substr(strrep(hsep, nchwidth), 1, nchwidth),+ } |
|||
| 954 | -2x | +|||
| 2451 | +
- rows_formatted[-header_rows]+ ) |
|||
| 955 | -2x | +|||
| 2452 | +
- ), collapse = "\n")+ |
|||
| 956 | +2453 |
- }+ |
| 1 | +2454 |
- #' Internal generics and methods+ ## this is a horrible hack but when we have non-nested siblings at the top level |
||
| 2 | +2455 |
- #'+ ## the beginning of the "path <-> position" relationship breaks down. |
||
| 3 | +2456 |
- #' These are internal methods that are documented only to satisfy `R CMD check`. End users should pay no+ ## we probably *should* have e.g., c("root", "top_level_splname_1",
|
||
| 4 | +2457 |
- #' attention to this documentation.+ ## "top_level_splname_1, "top_level_splname_1_value", ...) |
||
| 5 | +2458 |
- #'+ ## but its pretty clear why no one will be happy with that, I think |
||
| 6 | +2459 |
- #' @param x (`ANY`)\cr the object.+ ## so we punt on the problem for now with an explicit workaround |
||
| 7 | +2460 |
- #' @param obj (`ANY`)\cr the object.+ ## |
||
| 8 | +2461 |
- #'+ ## those first non-nested siblings currently have (incorrect) |
||
| 9 | +2462 |
- #' @name internal_methods+ ## empty tree_pos elements so we just look at the obj_name |
||
| 10 | +2463 |
- #' @rdname int_methods+ |
||
| 11 | +2464 |
- #' @aliases int_methods+ pos_singleton_path <- function(obj) {
|
||
| 12 | -+ | |||
| 2465 | +5963x |
- NULL+ pos <- tree_pos(obj) |
||
| 13 | -+ | |||
| 2466 | +5963x |
-
+ splvals <- pos_splvals(pos) |
||
| 14 | -+ | |||
| 2467 | +5963x |
- #' @return The number of rows (`nrow`), columns (`ncol`), or both (`dim`) of the object.+ length(splvals) == 0 ||+ |
+ ||
| 2468 | +5963x | +
+ (length(splvals) == 1 && is.na(unlist(value_names(splvals)))) |
||
| 15 | +2469 |
- #'+ } |
||
| 16 | +2470 |
- #' @rdname dimensions+ |
||
| 17 | +2471 |
- #' @exportMethod nrow+ ## close to a duplicate of tt_at_path, but... not quite :( |
||
| 18 | +2472 |
- setMethod(+ #' @rdname int_methods |
||
| 19 | +2473 |
- "nrow", "VTableTree",+ coltree_at_path <- function(obj, path, ...) {
|
||
| 20 | -2189x | +2474 | +3020x |
- function(x) length(collect_leaves(x, TRUE, TRUE))+ if (length(path) == 0) {
|
| 21 | -+ | |||
| 2475 | +644x |
- )+ return(obj) |
||
| 22 | +2476 |
-
+ } |
||
| 23 | -+ | |||
| 2477 | +2376x |
- #' @rdname int_methods+ stopifnot( |
||
| 24 | -+ | |||
| 2478 | +2376x |
- #' @exportMethod nrow+ is(path, "character"), |
||
| 25 | -+ | |||
| 2479 | +2376x |
- setMethod(+ length(path) > 0 |
||
| 26 | +2480 |
- "nrow", "TableRow",+ ) |
||
| 27 | -959x | +2481 | +2376x |
- function(x) 1L+ if (any(grepl("@content", path, fixed = TRUE))) {
|
| 28 | -+ | |||
| 2482 | +! |
- )+ stop("@content token is not valid for column paths.")
|
||
| 29 | +2483 |
-
+ } |
||
| 30 | +2484 |
- #' Table dimensions+ |
||
| 31 | -+ | |||
| 2485 | +2376x |
- #'+ cur <- obj |
||
| 32 | -+ | |||
| 2486 | +2376x |
- #' @param x (`TableTree` or `ElementaryTable`)\cr a table object.+ curpath <- pos_to_path(tree_pos(obj)) # path |
||
| 33 | -+ | |||
| 2487 | +2376x |
- #'+ num_consume_path <- 2 |
||
| 34 | -+ | |||
| 2488 | +2376x |
- #' @examples+ while (!identical(curpath, path) && !is(cur, "LayoutColLeaf")) { # length(curpath) > 0) {
|
||
| 35 | -+ | |||
| 2489 | +4137x |
- #' lyt <- basic_table() %>%+ kids <- tree_children(cur) |
||
| 36 | -+ | |||
| 2490 | +4137x |
- #' split_cols_by("ARM") %>%
+ kidmatch <- find_kid_path_match(kids, path) |
||
| 37 | -+ | |||
| 2491 | +4137x |
- #' analyze(c("SEX", "AGE"))
+ if (length(kidmatch) == 0) {
|
||
| 38 | -+ | |||
| 2492 | +! |
- #'+ stop( |
||
| 39 | -+ | |||
| 2493 | +! |
- #' tbl <- build_table(lyt, ex_adsl)+ "unable to match full path: ", paste(path, sep = "->"), |
||
| 40 | -+ | |||
| 2494 | +! |
- #'+ "\n path of last match: ", paste(curpath, sep = "->") |
||
| 41 | +2495 |
- #' dim(tbl)+ ) |
||
| 42 | +2496 |
- #' nrow(tbl)+ } |
||
| 43 | -+ | |||
| 2497 | +4137x |
- #' ncol(tbl)+ cur <- kids[[kidmatch]] |
||
| 44 | -+ | |||
| 2498 | +4137x |
- #'+ curpath <- pos_to_path(tree_pos(cur)) |
||
| 45 | +2499 |
- #' NROW(tbl)+ } |
||
| 46 | -+ | |||
| 2500 | +2376x |
- #' NCOL(tbl)+ cur |
||
| 47 | +2501 |
- #'+ } |
||
| 48 | +2502 |
- #' @rdname dimensions+ |
||
| 49 | +2503 |
- #' @exportMethod ncol+ find_kid_path_match <- function(kids, path) {
|
||
| 50 | -+ | |||
| 2504 | +8270x |
- setMethod(+ if (length(kids) == 0) {
|
||
| 51 | -+ | |||
| 2505 | +! |
- "ncol", "VTableNodeInfo",+ return(integer()) |
||
| 52 | +2506 |
- function(x) {
+ } |
||
| 53 | -22113x | +2507 | +8270x |
- ncol(col_info(x))+ kidpaths <- lapply(kids, function(k) pos_to_path(tree_pos(k))) |
| 54 | +2508 | ++ | + + | +|
| 2509 | +8270x | +
+ matches <- vapply(kidpaths, function(kpth) identical(path[seq_along(kpth)], kpth), NA)+ |
+ ||
| 2510 | +8270x | +
+ firstkidpos <- tree_pos(kids[[1]])+ |
+ ||
| 2511 | +8270x | +
+ if (all(matches) && pos_singleton_path(kids[[1]])) {
+ |
+ ||
| 2512 | +660x | +
+ kidpaths <- lapply(seq_along(kidpaths), function(i) c(kidpaths[[i]], obj_name(kids[[i]])))+ |
+ ||
| 2513 | +660x | +
+ matches <- vapply(kidpaths, function(kpth) identical(path[seq_along(kpth)], kpth), NA)+ |
+ ||
| 2514 |
} |
|||
| 2515 | +8270x | +
+ which(matches)+ |
+ ||
| 55 | +2516 |
- )+ } |
||
| 56 | +2517 | |||
| 57 | +2518 |
- #' @rdname int_methods+ |
||
| 58 | +2519 |
- #' @exportMethod ncol+ ## almost a duplicate of recursive_replace, but I spent a bunch |
||
| 59 | +2520 |
- setMethod(+ ## of time ramming my head against the different way pathing happens |
||
| 60 | +2521 |
- "ncol", "TableRow",+ ## in column space (unfortunately) before giving up building |
||
| 61 | +2522 |
- function(x) {
+ ## coltree_at_path around recursive_replace, so here we are.+ |
+ ||
| 2523 | ++ | + + | +||
| 2524 | ++ |
+ ct_recursive_replace <- function(ctree, path, value, pos = 1) {
|
||
| 62 | -65956x | +2525 | +6507x |
- if (!no_colinfo(x)) {
+ pos <- tree_pos(ctree) |
| 63 | -65016x | +2526 | +6507x |
- ncol(col_info(x))+ curpth <- pos_to_path(pos) |
| 64 | -+ | |||
| 2527 | +6507x |
- } else {
+ if (identical(path, curpth)) {
|
||
| 65 | -940x | +2528 | +2374x |
- length(spanned_values(x))+ return(value) |
| 66 | -+ | |||
| 2529 | +4133x |
- }+ } else if (is(ctree, "LayoutColLeaf")) {
|
||
| 67 | -+ | |||
| 2530 | +! |
- }+ stop( |
||
| 68 | -+ | |||
| 2531 | +! |
- )+ "unable to match full path: ", paste(path, sep = "->"), |
||
| 69 | -+ | |||
| 2532 | +! |
-
+ "\n path at leaf: ", paste(curpth, sep = "->") |
||
| 70 | +2533 |
- #' @rdname int_methods+ ) |
||
| 71 | +2534 |
- #' @exportMethod ncol+ } |
||
| 72 | -+ | |||
| 2535 | +4133x |
- setMethod(+ kids <- tree_children(ctree) |
||
| 73 | -+ | |||
| 2536 | +4133x |
- "ncol", "LabelRow",+ kids_singl <- pos_singleton_path(kids[[1]])+ |
+ ||
| 2537 | +4133x | +
+ kidind <- find_kid_path_match(kids, path) |
||
| 74 | +2538 |
- function(x) {
+
|
||
| 75 | -20806x | +2539 | +4133x |
- ncol(col_info(x))+ if (length(kidind) == 0) {
|
| 76 | -+ | |||
| 2540 | +! |
- }+ stop("Path appears invalid for this tree at step ", path[1])
|
||
| 77 | -+ | |||
| 2541 | +4133x |
- )+ } else if (length(kidind) > 1) {
|
||
| 78 | -+ | |||
| 2542 | +! |
-
+ stop( |
||
| 79 | -+ | |||
| 2543 | +! |
- #' @rdname int_methods+ "singleton step (root, cbind_root, etc) in path appears to have matched multiple children. ", |
||
| 80 | -+ | |||
| 2544 | +! |
- #' @exportMethod ncol+ "This shouldn't happen, please contact the maintainers." |
||
| 81 | +2545 |
- setMethod(+ ) |
||
| 82 | +2546 |
- "ncol", "InstantiatedColumnInfo",+ } |
||
| 83 | +2547 |
- function(x) {
+
|
||
| 84 | -109959x | +2548 | +4133x |
- length(col_exprs(x))+ kids[[kidind]] <- ct_recursive_replace( |
| 85 | -+ | |||
| 2549 | +4133x |
- }+ kids[[kidind]], |
||
| 86 | -+ | |||
| 2550 | +4133x |
- )+ path, value |
||
| 87 | +2551 |
-
+ ) |
||
| 88 | -+ | |||
| 2552 | +4133x |
- #' @rdname dimensions+ tree_children(ctree) <- kids+ |
+ ||
| 2553 | +4133x | +
+ ctree |
||
| 89 | +2554 |
- #' @exportMethod dim+ } |
||
| 90 | +2555 |
- setMethod(+ |
||
| 91 | +2556 |
- "dim", "VTableNodeInfo",+ `coltree_at_path<-` <- function(obj, path, value) {
|
||
| 92 | -18177x | +2557 | +2374x |
- function(x) c(nrow(x), ncol(x))+ obj <- ct_recursive_replace(obj, path, value)+ |
+
| 2558 | +2374x | +
+ obj |
||
| 93 | +2559 |
- )+ } |
||
| 94 | +2560 | |||
| 95 | +2561 |
- #' Retrieve or set the direct children of a tree-style object+ #' Set visibility of column counts for a group of sibling facets |
||
| 96 | +2562 |
#' |
||
| 97 | +2563 |
- #' @param x (`TableTree` or `ElementaryTable`)\cr an object with a tree structure.+ #' @inheritParams gen_args |
||
| 98 | +2564 |
- #' @param value (`list`)\cr new list of children.+ #' @param path (`character`)\cr the path *to the parent of the |
||
| 99 | +2565 |
- #'+ #' desired siblings*. The last element in the path should |
||
| 100 | +2566 |
- #' @return A list of direct children of `x`.+ #' be a split name. |
||
| 101 | +2567 |
- #'+ #' @return obj, modified with the desired column count. |
||
| 102 | +2568 |
- #' @export+ #' display behavior |
||
| 103 | +2569 |
- #' @rdname tree_children+ #' |
||
| 104 | -235165x | +|||
| 2570 | +
- setGeneric("tree_children", function(x) standardGeneric("tree_children"))
+ #' @seealso [colcount_visible()] |
|||
| 105 | +2571 |
-
+ #' |
||
| 106 | +2572 |
- #' @exportMethod tree_children+ #' @export |
||
| 107 | +2573 |
- #' @rdname int_methods+ `facet_colcounts_visible<-` <- function(obj, path, value) {
|
||
| 108 | -+ | |||
| 2574 | +1x |
- setMethod(+ coldf <- make_col_df(obj, visible_only = FALSE) |
||
| 109 | -+ | |||
| 2575 | +1x |
- "tree_children", c(x = "VTree"),+ allpaths <- coldf$path |
||
| 110 | -! | +|||
| 2576 | +1x |
- function(x) x@children+ lenpath <- length(path) |
||
| 111 | -+ | |||
| 2577 | +1x |
- )+ match_paths <- vapply(allpaths, function(path_i) {
|
||
| 112 | -+ | |||
| 2578 | +10x |
-
+ (length(path_i) == lenpath + 1) && |
||
| 113 | -+ | |||
| 2579 | +10x |
- #' @exportMethod tree_children+ (all(head(path_i, -1) == path)) |
||
| 114 | -+ | |||
| 2580 | +1x |
- #' @rdname int_methods+ }, TRUE) |
||
| 115 | -+ | |||
| 2581 | +1x |
- setMethod(+ for (curpath in allpaths[match_paths]) {
+ |
+ ||
| 2582 | +2x | +
+ colcount_visible(obj, curpath) <- value |
||
| 116 | +2583 |
- "tree_children", c(x = "VTableTree"),+ } |
||
| 117 | -62144x | +2584 | +1x |
- function(x) x@children+ obj |
| 118 | +2585 |
- )+ } |
||
| 119 | +2586 | |||
| 120 | +2587 |
- ## this includes VLeaf but also allows for general methods+ #' Get or set column count for a facet in column space |
||
| 121 | +2588 |
- ## needed for table_inset being carried around by rows and+ #' |
||
| 122 | +2589 |
- ## such.+ #' @inheritParams gen_args |
||
| 123 | +2590 |
- #' @exportMethod tree_children+ #' @param path character. This path must end on a |
||
| 124 | +2591 |
- #' @rdname int_methods+ #' split value, e.g., the level of a categorical variable |
||
| 125 | +2592 |
- setMethod(+ #' that was split on in column space, but it need not |
||
| 126 | +2593 |
- "tree_children", c(x = "ANY"), ## "VLeaf"),+ #' be the path to an individual column. |
||
| 127 | -11926x | +|||
| 2594 | +
- function(x) list()+ #' |
|||
| 128 | +2595 |
- )+ #' @return for `facet_colcount` the current count associated |
||
| 129 | +2596 |
-
+ #' with that facet in column space, for `facet_colcount<-`, |
||
| 130 | +2597 |
- #' @export+ #' `obj` modified with the new column count for the specified |
||
| 131 | +2598 |
- #' @rdname tree_children+ #' facet. |
||
| 132 | -56884x | +|||
| 2599 | +
- setGeneric("tree_children<-", function(x, value) standardGeneric("tree_children<-"))
+ #' |
|||
| 133 | +2600 |
-
+ #' @note Updating a lower-level (more specific) |
||
| 134 | +2601 |
- #' @exportMethod tree_children<-+ #' column count manually **will not** update the |
||
| 135 | +2602 |
- #' @rdname int_methods+ #' counts for its parent facets. This cannot be made |
||
| 136 | +2603 |
- setMethod(+ #' automatic because the rtables framework does not |
||
| 137 | +2604 |
- "tree_children<-", c(x = "VTree"),+ #' require sibling facets to be mutually exclusive |
||
| 138 | +2605 |
- function(x, value) {
+ #' (e.g., total "arm", faceting into cumulative |
||
| 139 | -! | +|||
| 2606 | +
- x@children <- value+ #' quantiles, etc) and thus the count of a parent facet |
|||
| 140 | -! | +|||
| 2607 | +
- x+ #' will not always be simply the sum of the counts for |
|||
| 141 | +2608 |
- }+ #' all of its children. |
||
| 142 | +2609 |
- )+ #' |
||
| 143 | +2610 |
-
+ #' @seealso [col_counts()] |
||
| 144 | +2611 |
- #' @exportMethod tree_children<-+ #' |
||
| 145 | +2612 |
- #' @rdname int_methods+ #' @examples |
||
| 146 | +2613 |
- setMethod(+ #' lyt <- basic_table() %>% |
||
| 147 | +2614 |
- "tree_children<-", c(x = "VTableTree"),+ #' split_cols_by("ARM", show_colcounts = TRUE) %>%
|
||
| 148 | +2615 |
- function(x, value) {
+ #' split_cols_by("SEX",
|
||
| 149 | -51444x | +|||
| 2616 | +
- x@children <- value+ #' split_fun = keep_split_levels(c("F", "M")),
|
|||
| 150 | -51444x | +|||
| 2617 | +
- x+ #' show_colcounts = TRUE |
|||
| 151 | +2618 |
- }+ #' ) %>% |
||
| 152 | +2619 |
- )+ #' split_cols_by("STRATA1", show_colcounts = TRUE) %>%
|
||
| 153 | +2620 |
-
+ #' analyze("AGE")
|
||
| 154 | +2621 |
- #' Retrieve or set content table from a `TableTree`+ #' |
||
| 155 | +2622 |
- #'+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 156 | +2623 |
- #' Returns the content table of `obj` if it is a `TableTree` object, or `NULL` otherwise.+ #' |
||
| 157 | +2624 |
- #'+ #' facet_colcount(tbl, c("ARM", "A: Drug X"))
|
||
| 158 | +2625 |
- #' @param obj (`TableTree`)\cr the table object.+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F"))
|
||
| 159 | +2626 |
- #'+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A"))
|
||
| 160 | +2627 |
- #' @return the `ElementaryTable` containing the (top level) *content rows* of `obj` (or `NULL` if `obj` is not+ #' |
||
| 161 | +2628 |
- #' a formal table object).+ #' ## modify specific count after table creation |
||
| 162 | +2629 |
- #'+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A")) <- 25
|
||
| 163 | +2630 |
- #' @export+ #' |
||
| 164 | +2631 |
- #' @rdname content_table+ #' ## show black space for certain counts by assign NA |
||
| 165 | -87310x | +|||
| 2632 | +
- setGeneric("content_table", function(obj) standardGeneric("content_table"))
+ #' |
|||
| 166 | +2633 |
-
+ #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "C")) <- NA
|
||
| 167 | +2634 |
- #' @exportMethod content_table+ #' |
||
| 168 | +2635 |
- #' @rdname int_methods+ #' @export |
||
| 169 | +2636 |
- setMethod(+ setGeneric( |
||
| 170 | +2637 |
- "content_table", "TableTree",+ "facet_colcount", |
||
| 171 | -56779x | +2638 | +21084x |
- function(obj) obj@content+ function(obj, path) standardGeneric("facet_colcount")
|
| 172 | +2639 |
) |
||
| 173 | +2640 | |||
| 174 | +2641 |
- #' @exportMethod content_table+ #' @rdname facet_colcount |
||
| 175 | +2642 |
- #' @rdname int_methods+ #' @export |
||
| 176 | +2643 |
setMethod( |
||
| 177 | +2644 |
- "content_table", "ANY",- |
- ||
| 178 | -10708x | -
- function(obj) NULL+ "facet_colcount", "LayoutColTree", |
||
| 179 | +2645 |
- )+ function(obj, path = NULL) {
|
||
| 180 | +2646 |
-
+ ## if(length(path) == 0L) |
||
| 181 | +2647 |
- #' @param value (`ElementaryTable`)\cr the new content table for `obj`.+ ## stop("face_colcount requires a non-null path") #nocov
|
||
| 182 | -+ | |||
| 2648 | +645x |
- #'+ subtree <- coltree_at_path(obj, path) |
||
| 183 | -+ | |||
| 2649 | +645x |
- #' @export+ subtree@column_count |
||
| 184 | +2650 |
- #' @rdname content_table+ } |
||
| 185 | -6315x | +|||
| 2651 | +
- setGeneric("content_table<-", function(obj, value) standardGeneric("content_table<-"))
+ ) |
|||
| 186 | +2652 | |||
| 187 | +2653 |
- #' @exportMethod "content_table<-"+ #' @rdname facet_colcount |
||
| 188 | +2654 |
- #' @rdname int_methods+ #' @export |
||
| 189 | +2655 |
setMethod( |
||
| 190 | +2656 |
- "content_table<-", c("TableTree", "ElementaryTable"),
+ "facet_colcount", "LayoutColLeaf", |
||
| 191 | +2657 |
- function(obj, value) {
+ function(obj, path = NULL) {
|
||
| 192 | -6315x | +|||
| 2658 | +
- obj@content <- value+ ## not sure if we should check for null here as above |
|||
| 193 | -6315x | +2659 | +20438x |
- obj+ obj@column_count |
| 194 | +2660 |
} |
||
| 195 | +2661 |
) |
||
| 196 | +2662 | |||
| 197 | +2663 |
- #' @param for_analyze (`flag`) whether split is an analyze split.+ #' @rdname facet_colcount |
||
| 198 | +2664 |
- #' @rdname int_methods+ #' @export |
||
| 199 | -1111x | +|||
| 2665 | +
- setGeneric("next_rpos", function(obj, nested = TRUE, for_analyze = FALSE) standardGeneric("next_rpos"))
+ setMethod( |
|||
| 200 | +2666 |
-
+ "facet_colcount", "VTableTree", |
||
| 201 | -+ | |||
| 2667 | +! |
- #' @rdname int_methods+ function(obj, path) facet_colcount(coltree(obj), path = path) |
||
| 202 | +2668 |
- setMethod(+ ) |
||
| 203 | +2669 |
- "next_rpos", "PreDataTableLayouts",+ |
||
| 204 | +2670 |
- function(obj, nested, for_analyze = FALSE) next_rpos(rlayout(obj), nested, for_analyze = for_analyze)+ #' @rdname facet_colcount |
||
| 205 | +2671 |
- )+ #' @export |
||
| 206 | +2672 |
-
+ setMethod( |
||
| 207 | +2673 |
- .check_if_nest <- function(obj, nested, for_analyze) {
+ "facet_colcount", "InstantiatedColumnInfo", |
||
| 208 | -251x | +2674 | +1x |
- if (!nested) {
+ function(obj, path) facet_colcount(coltree(obj), path = path) |
| 209 | -16x | +|||
| 2675 | +
- FALSE+ ) |
|||
| 210 | +2676 |
- } else {
+
|
||
| 211 | +2677 |
- ## can always nest analyze splits (almost? what about colvars noncolvars mixing? prolly ok?)+ #' @rdname facet_colcount |
||
| 212 | -235x | +|||
| 2678 | +
- for_analyze ||+ #' @export |
|||
| 213 | +2679 |
- ## If its not an analyze split it can't go under an analyze split+ setGeneric( |
||
| 214 | -235x | +|||
| 2680 | +
- !(is(last_rowsplit(obj), "VAnalyzeSplit") ||+ "facet_colcount<-", |
|||
| 215 | -235x | +2681 | +1104x |
- is(last_rowsplit(obj), "AnalyzeMultiVars")) ## should this be CompoundSplit? # nolint+ function(obj, path, value) standardGeneric("facet_colcount<-")
|
| 216 | +2682 |
- }+ ) |
||
| 217 | +2683 |
- }+ |
||
| 218 | +2684 |
-
+ #' @rdname facet_colcount |
||
| 219 | +2685 |
- #' @rdname int_methods+ #' @export |
||
| 220 | +2686 |
setMethod( |
||
| 221 | +2687 |
- "next_rpos", "PreDataRowLayout",+ "facet_colcount<-", "LayoutColTree", |
||
| 222 | +2688 |
- function(obj, nested, for_analyze) {
+ function(obj, path, value) {
|
||
| 223 | -555x | +2689 | +1102x |
- l <- length(obj)+ ct <- coltree_at_path(obj, path) |
| 224 | -555x | +2690 | +1102x |
- if (length(obj[[l]]) > 0L && !.check_if_nest(obj, nested, for_analyze)) {
+ ct@column_count <- as.integer(value) |
| 225 | -25x | -
- l <- l + 1L- |
- ||
| 226 | -+ | 2691 | +1102x |
- }+ coltree_at_path(obj, path) <- ct |
| 227 | -555x | +2692 | +1102x |
- l+ obj |
| 228 | +2693 |
} |
||
| 229 | +2694 |
) |
||
| 230 | +2695 | |||
| 231 | +2696 |
- #' @rdname int_methods- |
- ||
| 232 | -1x | -
- setMethod("next_rpos", "ANY", function(obj, nested) 1L)
+ #' @rdname facet_colcount |
||
| 233 | +2697 |
-
+ #' @export |
||
| 234 | +2698 |
- #' @rdname int_methods+ setMethod( |
||
| 235 | -625x | +|||
| 2699 | +
- setGeneric("next_cpos", function(obj, nested = TRUE) standardGeneric("next_cpos"))
+ "facet_colcount<-", "LayoutColLeaf", |
|||
| 236 | +2700 |
-
+ function(obj, path, value) {
|
||
| 237 | -+ | |||
| 2701 | +! |
- #' @rdname int_methods+ obj@column_count <- as.integer(value) |
||
| 238 | -+ | |||
| 2702 | +! |
- setMethod(+ obj |
||
| 239 | +2703 |
- "next_cpos", "PreDataTableLayouts",+ } |
||
| 240 | +2704 |
- function(obj, nested) next_cpos(clayout(obj), nested)+ ) |
||
| 241 | +2705 |
- )+ |
||
| 242 | +2706 |
-
+ #' @rdname facet_colcount |
||
| 243 | +2707 |
- #' @rdname int_methods+ #' @export |
||
| 244 | +2708 |
setMethod( |
||
| 245 | +2709 |
- "next_cpos", "PreDataColLayout",+ "facet_colcount<-", "VTableTree", |
||
| 246 | +2710 |
- function(obj, nested) {
+ function(obj, path, value) {
|
||
| 247 | -312x | +2711 | +1x |
- if (nested || length(obj[[length(obj)]]) == 0) {
+ cinfo <- col_info(obj) |
| 248 | -304x | +2712 | +1x |
- length(obj)+ facet_colcount(cinfo, path) <- value |
| 249 | -+ | |||
| 2713 | +1x |
- } else {
+ col_info(obj) <- cinfo |
||
| 250 | -8x | +2714 | +1x |
- length(obj) + 1L+ obj |
| 251 | +2715 |
- }+ } |
||
| 252 | +2716 |
- }+ ) |
||
| 253 | +2717 |
- )+ |
||
| 254 | +2718 |
-
+ #' @rdname facet_colcount |
||
| 255 | +2719 |
- #' @rdname int_methods+ #' @export |
||
| 256 | +2720 |
- setMethod("next_cpos", "ANY", function(obj, nested) 1L)
+ setMethod( |
||
| 257 | +2721 |
-
+ "facet_colcount<-", "InstantiatedColumnInfo", |
||
| 258 | +2722 |
- #' @rdname int_methods+ function(obj, path, value) {
|
||
| 259 | -2587x | +2723 | +1x |
- setGeneric("last_rowsplit", function(obj) standardGeneric("last_rowsplit"))
+ ct <- coltree(obj) |
| 260 | -+ | |||
| 2724 | +1x |
-
+ facet_colcount(ct, path) <- value |
||
| 261 | -+ | |||
| 2725 | +1x |
- #' @rdname int_methods+ coltree(obj) <- ct |
||
| 262 | -+ | |||
| 2726 | +1x |
- setMethod(+ obj |
||
| 263 | +2727 |
- "last_rowsplit", "NULL",- |
- ||
| 264 | -! | -
- function(obj) NULL+ } |
||
| 265 | +2728 |
) |
||
| 266 | +2729 | |||
| 267 | +2730 |
- #' @rdname int_methods+ #' Value and Visibility of specific column counts by path |
||
| 268 | +2731 |
- setMethod(+ #' |
||
| 269 | +2732 |
- "last_rowsplit", "SplitVector",+ #' @inheritParams gen_args |
||
| 270 | +2733 |
- function(obj) {
- |
- ||
| 271 | -1013x | -
- if (length(obj) == 0) {
- |
- ||
| 272 | -224x | -
- NULL+ #' |
||
| 273 | +2734 |
- } else {
- |
- ||
| 274 | -789x | -
- obj[[length(obj)]]+ #' @return for `colcount_visible` a logical scalar |
||
| 275 | +2735 |
- }+ #' indicating whether the specified position in |
||
| 276 | +2736 |
- }+ #' the column hierarchy is set to display its column count; |
||
| 277 | +2737 |
- )+ #' for `colcount_visible<-`, `obj` updated with |
||
| 278 | +2738 |
-
+ #' the specified count displaying behavior set. |
||
| 279 | +2739 |
- #' @rdname int_methods+ #' |
||
| 280 | +2740 |
- setMethod(+ #' @note Users generally should not call `colcount_visible` |
||
| 281 | +2741 |
- "last_rowsplit", "PreDataRowLayout",+ #' directly, as setting sibling facets to have differing |
||
| 282 | +2742 |
- function(obj) {
- |
- ||
| 283 | -1013x | -
- if (length(obj) == 0) {
- |
- ||
| 284 | -! | -
- NULL+ #' column count visibility will result in an error when |
||
| 285 | +2743 |
- } else {
+ #' printing or paginating the table. |
||
| 286 | -1013x | +|||
| 2744 | +
- last_rowsplit(obj[[length(obj)]])+ #' |
|||
| 287 | +2745 |
- }+ #' @export |
||
| 288 | -+ | |||
| 2746 | +2x |
- }+ setGeneric("colcount_visible", function(obj, path) standardGeneric("colcount_visible"))
|
||
| 289 | +2747 |
- )+ |
||
| 290 | +2748 |
-
+ #' @rdname colcount_visible |
||
| 291 | +2749 |
- #' @rdname int_methods+ #' @export |
||
| 292 | +2750 |
setMethod( |
||
| 293 | +2751 |
- "last_rowsplit", "PreDataTableLayouts",+ "colcount_visible", "VTableTree", |
||
| 294 | -559x | +2752 | +1x |
- function(obj) last_rowsplit(rlayout(obj))+ function(obj, path) colcount_visible(coltree(obj), path) |
| 295 | +2753 |
) |
||
| 296 | +2754 | |||
| 297 | +2755 |
- # rlayout ----+ #' @rdname colcount_visible |
||
| 298 | +2756 |
- ## TODO maybe export these?+ #' @export |
||
| 299 | +2757 |
-
+ setMethod( |
||
| 300 | +2758 |
- #' @rdname int_methods+ "colcount_visible", "InstantiatedColumnInfo", |
||
| 301 | -3813x | +|||
| 2759 | +! |
- setGeneric("rlayout", function(obj) standardGeneric("rlayout"))
+ function(obj, path) colcount_visible(coltree(obj), path) |
||
| 302 | +2760 |
-
+ ) |
||
| 303 | +2761 |
- #' @rdname int_methods+ |
||
| 304 | +2762 |
- setMethod(+ #' @rdname colcount_visible |
||
| 305 | +2763 |
- "rlayout", "PreDataTableLayouts",- |
- ||
| 306 | -3813x | -
- function(obj) obj@row_layout+ #' @export |
||
| 307 | +2764 |
- )+ setMethod( |
||
| 308 | +2765 |
-
+ "colcount_visible", "LayoutColTree", |
||
| 309 | +2766 |
- #' @rdname int_methods+ function(obj, path) {
|
||
| 310 | -! | +|||
| 2767 | +1x |
- setMethod("rlayout", "ANY", function(obj) PreDataRowLayout())
+ subtree <- coltree_at_path(obj, path) |
||
| 311 | -+ | |||
| 2768 | +1x |
-
+ disp_ccounts(subtree) |
||
| 312 | +2769 |
- #' @rdname int_methods+ } |
||
| 313 | -1702x | +|||
| 2770 | +
- setGeneric("rlayout<-", function(object, value) standardGeneric("rlayout<-"))
+ ) |
|||
| 314 | +2771 | |||
| 315 | +2772 |
- #' @rdname int_methods+ #' @rdname colcount_visible |
||
| 316 | +2773 |
- setMethod(+ #' @export |
||
| 317 | -+ | |||
| 2774 | +1296x |
- "rlayout<-", "PreDataTableLayouts",+ setGeneric("colcount_visible<-", function(obj, path, value) standardGeneric("colcount_visible<-"))
|
||
| 318 | +2775 |
- function(object, value) {
- |
- ||
| 319 | -1702x | -
- object@row_layout <- value+ |
||
| 320 | -1702x | +|||
| 2776 | +
- object+ #' @rdname colcount_visible |
|||
| 321 | +2777 |
- }+ #' @export |
||
| 322 | +2778 |
- )+ setMethod( |
||
| 323 | +2779 |
-
+ "colcount_visible<-", "VTableTree", |
||
| 324 | +2780 |
- #' @rdname int_methods+ function(obj, path, value) {
|
||
| 325 | -62991x | +2781 | +3x |
- setGeneric("tree_pos", function(obj) standardGeneric("tree_pos"))
+ ctree <- coltree(obj) |
| 326 | -+ | |||
| 2782 | +3x |
-
+ colcount_visible(ctree, path) <- value |
||
| 327 | -+ | |||
| 2783 | +3x |
- ## setMethod("tree_pos", "VNodeInfo",
+ coltree(obj) <- ctree |
||
| 328 | -+ | |||
| 2784 | +3x |
- ## function(obj) obj@pos_in_tree)+ obj |
||
| 329 | +2785 |
-
+ } |
||
| 330 | +2786 |
- #' @rdname int_methods+ ) |
||
| 331 | +2787 |
- setMethod(+ |
||
| 332 | +2788 |
- "tree_pos", "VLayoutNode",+ #' @rdname colcount_visible |
||
| 333 | -! | +|||
| 2789 | +
- function(obj) obj@pos_in_tree+ #' @export |
|||
| 334 | +2790 |
- )+ setMethod( |
||
| 335 | +2791 |
-
+ "colcount_visible<-", "InstantiatedColumnInfo", |
||
| 336 | +2792 |
- #' @rdname int_methods+ function(obj, path, value) {
|
||
| 337 | -1379x | +2793 | +21x |
- setGeneric("pos_subset", function(obj) standardGeneric("pos_subset"))
+ ctree <- coltree(obj) |
| 338 | -+ | |||
| 2794 | +21x |
-
+ colcount_visible(ctree, path) <- value |
||
| 339 | -+ | |||
| 2795 | +21x |
- #' @rdname int_methods+ coltree(obj) <- ctree |
||
| 340 | -+ | |||
| 2796 | +21x |
- setMethod(+ obj |
||
| 341 | +2797 |
- "pos_subset", "TreePos",- |
- ||
| 342 | -1379x | -
- function(obj) obj@subset+ } |
||
| 343 | +2798 |
) |
||
| 344 | +2799 | |||
| 345 | +2800 |
- #' @rdname int_methods- |
- ||
| 346 | -101x | -
- setGeneric("tree_pos<-", function(obj, value) standardGeneric("tree_pos<-"))
+
|
||
| 347 | +2801 |
-
+ #' @rdname colcount_visible |
||
| 348 | +2802 |
- #' @rdname int_methods+ #' @export |
||
| 349 | +2803 |
setMethod( |
||
| 350 | +2804 |
- "tree_pos<-", "VLayoutNode",+ "colcount_visible<-", "LayoutColTree", |
||
| 351 | +2805 |
- function(obj, value) {
+ function(obj, path, value) {
|
||
| 352 | -101x | +2806 | +1272x |
- obj@pos_in_tree <- value+ subtree <- coltree_at_path(obj, path) |
| 353 | -101x | +2807 | +1272x | +
+ disp_ccounts(subtree) <- value+ |
+
| 2808 | +1272x | +
+ coltree_at_path(obj, path) <- subtree+ |
+ ||
| 2809 | +1272x |
obj |
||
| 354 | +2810 |
} |
||
| 355 | +2811 |
) |
||
| 356 | +2812 | |||
| 357 | +2813 |
- ## setMethod("pos_subset", "VNodeInfo",
+ #' @rdname int_methods |
||
| 358 | +2814 |
- ## function(obj) pos_subset(tree_pos(obj)))+ #' @export+ |
+ ||
| 2815 | +16154x | +
+ setGeneric("colcount_format", function(obj) standardGeneric("colcount_format"))
|
||
| 359 | +2816 | |||
| 360 | +2817 |
#' @rdname int_methods |
||
| 361 | +2818 | ++ |
+ #' @export+ |
+ |
| 2819 |
setMethod( |
|||
| 362 | +2820 |
- "pos_subset", "VLayoutNode",+ "colcount_format", "InstantiatedColumnInfo", |
||
| 363 | -! | +|||
| 2821 | +631x |
- function(obj) pos_subset(tree_pos(obj))+ function(obj) obj@columncount_format |
||
| 364 | +2822 |
) |
||
| 365 | +2823 | |||
| 366 | +2824 |
#' @rdname int_methods |
||
| 367 | -51154x | -
- setGeneric("pos_splits", function(obj) standardGeneric("pos_splits"))
- |
- ||
| 368 | -- | - - | -||
| 369 | +2825 |
- #' @rdname int_methods+ #' @export |
||
| 370 | +2826 |
setMethod( |
||
| 371 | +2827 |
- "pos_splits", "TreePos",+ "colcount_format", "VTableNodeInfo", |
||
| 372 | -51154x | +2828 | +338x |
- function(obj) obj@splits+ function(obj) colcount_format(col_info(obj)) |
| 373 | +2829 |
) |
||
| 374 | +2830 | |||
| 375 | +2831 |
- ## setMethod("pos_splits", "VNodeInfo",
+ #' @rdname int_methods |
||
| 376 | +2832 |
- ## function(obj) pos_splits(tree_pos(obj)))+ #' @export |
||
| 377 | +2833 |
-
+ setMethod( |
||
| 378 | +2834 |
- #' @rdname int_methods+ "colcount_format", "PreDataColLayout",+ |
+ ||
| 2835 | +332x | +
+ function(obj) obj@columncount_format |
||
| 379 | +2836 |
- setMethod(+ ) |
||
| 380 | +2837 |
- "pos_splits", "VLayoutNode",+ |
||
| 381 | -! | +|||
| 2838 | +
- function(obj) pos_splits(tree_pos(obj))+ #' @rdname int_methods |
|||
| 382 | +2839 |
- )+ #' @export |
||
| 383 | +2840 |
-
+ setMethod( |
||
| 384 | +2841 |
- #' @rdname int_methods+ "colcount_format", "PreDataTableLayouts", |
||
| 385 | -101x | +2842 | +332x |
- setGeneric("pos_splits<-", function(obj, value) standardGeneric("pos_splits<-"))
+ function(obj) colcount_format(clayout(obj)) |
| 386 | +2843 |
-
+ ) |
||
| 387 | +2844 |
- #' @rdname int_methods+ |
||
| 388 | +2845 |
- setMethod(+ #' @rdname int_methods |
||
| 389 | +2846 |
- "pos_splits<-", "TreePos",+ #' @export |
||
| 390 | +2847 |
- function(obj, value) {
+ setMethod( |
||
| 391 | -101x | +|||
| 2848 | +
- obj@splits <- value+ "colcount_format", "Split", |
|||
| 392 | -101x | -
- obj- |
- ||
| 393 | -+ | 2849 | +1269x |
- }+ function(obj) obj@child_colcount_format |
| 394 | +2850 |
) |
||
| 395 | +2851 | |||
| 396 | +2852 |
#' @rdname int_methods |
||
| 397 | +2853 |
- setMethod(+ #' @export |
||
| 398 | +2854 |
- "pos_splits<-", "VLayoutNode",+ setMethod( |
||
| 399 | +2855 |
- function(obj, value) {
+ "colcount_format", "LayoutColTree", |
||
| 400 | -! | +|||
| 2856 | +644x |
- pos <- tree_pos(obj)+ function(obj) obj@columncount_format |
||
| 401 | -! | +|||
| 2857 | +
- pos_splits(pos) <- value+ ) |
|||
| 402 | -! | +|||
| 2858 | +
- tree_pos(obj) <- pos+ |
|||
| 403 | -! | +|||
| 2859 | +
- obj+ #' @rdname int_methods |
|||
| 404 | -! | +|||
| 2860 | +
- obj+ #' @export |
|||
| 405 | +2861 |
- }+ setMethod( |
||
| 406 | +2862 |
- )+ "colcount_format", "LayoutColLeaf", |
||
| 407 | -+ | |||
| 2863 | +12461x |
-
+ function(obj) obj@columncount_format |
||
| 408 | +2864 |
-
+ ) |
||
| 409 | +2865 | |||
| 410 | +2866 | |||
| 411 | +2867 |
- #' @rdname int_methods- |
- ||
| 412 | -57398x | -
- setGeneric("pos_splvals", function(obj) standardGeneric("pos_splvals"))
+
|
||
| 413 | +2868 |
-
+ #' @rdname int_methods |
||
| 414 | +2869 |
- #' @rdname int_methods+ #' @export |
||
| 415 | +2870 |
- setMethod(+ setGeneric( |
||
| 416 | +2871 |
- "pos_splvals", "TreePos",+ "colcount_format<-", |
||
| 417 | -57398x | +2872 | +666x |
- function(obj) obj@s_values+ function(obj, value) standardGeneric("colcount_format<-")
|
| 418 | +2873 |
) |
||
| 419 | +2874 | |||
| 420 | +2875 |
- ## setMethod("pos_splvals", "VNodeInfo",
+ #' @export |
||
| 421 | +2876 |
- ## function(obj) pos_splvals(tree_pos(obj)))+ #' @rdname int_methods |
||
| 422 | +2877 |
-
+ setMethod( |
||
| 423 | +2878 |
- #' @rdname int_methods+ "colcount_format<-", "InstantiatedColumnInfo", |
||
| 424 | +2879 |
- setMethod(+ function(obj, value) {
|
||
| 425 | -+ | |||
| 2880 | +1x |
- "pos_splvals", "VLayoutNode",+ obj@columncount_format <- value |
||
| 426 | -! | +|||
| 2881 | +1x |
- function(obj) pos_splvals(tree_pos(obj))+ obj |
||
| 427 | +2882 |
- )+ } |
||
| 428 | +2883 |
-
+ ) |
||
| 429 | +2884 |
- #' @rdname int_methods- |
- ||
| 430 | -101x | -
- setGeneric("pos_splvals<-", function(obj, value) standardGeneric("pos_splvals<-"))
+
|
||
| 431 | +2885 |
-
+ #' @rdname int_methods |
||
| 432 | +2886 |
- #' @rdname int_methods+ #' @export |
||
| 433 | +2887 |
setMethod( |
||
| 434 | +2888 |
- "pos_splvals<-", "TreePos",+ "colcount_format<-", "VTableNodeInfo", |
||
| 435 | +2889 |
function(obj, value) {
|
||
| 436 | -101x | +2890 | +1x |
- obj@s_values <- value+ cinfo <- col_info(obj) |
| 437 | -101x | +2891 | +1x |
- obj+ colcount_format(cinfo) <- value |
| 438 | -+ | |||
| 2892 | +1x |
- }+ col_info(obj) <- cinfo |
||
| 439 | -+ | |||
| 2893 | +1x |
- )+ obj |
||
| 440 | +2894 |
-
+ } |
||
| 441 | +2895 |
- ## setMethod("pos_splvals", "VNodeInfo",
+ ) |
||
| 442 | +2896 |
- ## function(obj) pos_splvals(tree_pos(obj)))+ |
||
| 443 | +2897 |
-
+ #' @rdname int_methods |
||
| 444 | +2898 |
- #' @rdname int_methods+ #' @export |
||
| 445 | +2899 |
setMethod( |
||
| 446 | +2900 |
- "pos_splvals<-", "VLayoutNode",+ "colcount_format<-", "PreDataColLayout", |
||
| 447 | +2901 |
function(obj, value) {
|
||
| 448 | -! | -
- pos <- tree_pos(obj)- |
- ||
| 449 | -! | -
- pos_splvals(pos) <- value- |
- ||
| 450 | -! | +|||
| 2902 | +332x |
- tree_pos(obj) <- pos+ obj@columncount_format <- value |
||
| 451 | -! | +|||
| 2903 | +332x |
obj |
||
| 452 | +2904 |
} |
||
| 453 | +2905 |
) |
||
| 454 | +2906 | |||
| 455 | +2907 |
-
+ #' @rdname int_methods |
||
| 456 | +2908 |
- #' @rdname int_methods+ #' @export |
||
| 457 | -1379x | +|||
| 2909 | +
- setGeneric("pos_splval_labels", function(obj) standardGeneric("pos_splval_labels"))
+ setMethod( |
|||
| 458 | +2910 |
-
+ "colcount_format<-", "PreDataTableLayouts", |
||
| 459 | +2911 |
- #' @rdname int_methods+ function(obj, value) {
|
||
| 460 | -+ | |||
| 2912 | +332x |
- setMethod(+ clyt <- clayout(obj) |
||
| 461 | -+ | |||
| 2913 | +332x |
- "pos_splval_labels", "TreePos",+ colcount_format(clyt) <- value |
||
| 462 | -1379x | +2914 | +332x |
- function(obj) obj@sval_labels+ clayout(obj) <- clyt+ |
+
| 2915 | +332x | +
+ obj |
||
| 463 | +2916 |
- )+ } |
||
| 464 | +2917 |
- ## no longer used+ ) |
||
| 465 | +2918 | |||
| 466 | +2919 |
- ## setMethod("pos_splval_labels", "VNodeInfo",
+ ## It'd probably be better if this had the full set of methods as above |
||
| 467 | +2920 |
- ## function(obj) pos_splval_labels(tree_pos(obj)))+ ## but its not currently modelled in the class and probably isn't needed |
||
| 468 | +2921 |
- ## #' @rdname int_methods+ ## super much |
||
| 469 | +2922 |
- ## setMethod("pos_splval_labels", "VLayoutNode",
+ #' @rdname int_methods |
||
| 470 | +2923 |
- ## function(obj) pos_splval_labels(tree_pos(obj)))+ #' @export+ |
+ ||
| 2924 | +610x | +
+ setGeneric("colcount_na_str", function(obj) standardGeneric("colcount_na_str"))
|
||
| 471 | +2925 | |||
| 472 | +2926 |
#' @rdname int_methods |
||
| 473 | -14906x | +|||
| 2927 | +
- setGeneric("spl_payload", function(obj) standardGeneric("spl_payload"))
+ #' @export |
|||
| 474 | +2928 |
-
+ setMethod( |
||
| 475 | +2929 |
- #' @rdname int_methods+ "colcount_na_str", "InstantiatedColumnInfo", |
||
| 476 | -14906x | +2930 | +308x |
- setMethod("spl_payload", "Split", function(obj) obj@payload)
+ function(obj) obj@columncount_na_str |
| 477 | +2931 | ++ |
+ )+ |
+ |
| 2932 | ||||
| 478 | +2933 |
#' @rdname int_methods |
||
| 479 | -3x | +|||
| 2934 | +
- setGeneric("spl_payload<-", function(obj, value) standardGeneric("spl_payload<-"))
+ #' @export |
|||
| 480 | +2935 |
-
+ setMethod( |
||
| 481 | +2936 |
- #' @rdname int_methods+ "colcount_na_str", "VTableNodeInfo",+ |
+ ||
| 2937 | +302x | +
+ function(obj) colcount_na_str(col_info(obj)) |
||
| 482 | +2938 |
- setMethod("spl_payload<-", "Split", function(obj, value) {
+ ) |
||
| 483 | -3x | +|||
| 2939 | +
- obj@payload <- value+ |
|||
| 484 | -3x | +|||
| 2940 | +
- obj+ #' @rdname int_methods |
|||
| 485 | +2941 |
- })+ #' @export |
||
| 486 | +2942 |
-
+ setGeneric( |
||
| 487 | +2943 |
- #' @rdname int_methods+ "colcount_na_str<-", |
||
| 488 | -715x | +2944 | +4x |
- setGeneric("spl_label_var", function(obj) standardGeneric("spl_label_var"))
+ function(obj, value) standardGeneric("colcount_na_str<-")
|
| 489 | +2945 |
-
+ ) |
||
| 490 | +2946 |
- #' @rdname int_methods+ |
||
| 491 | -712x | +|||
| 2947 | +
- setMethod("spl_label_var", "VarLevelSplit", function(obj) obj@value_label_var)
+ #' @export |
|||
| 492 | +2948 |
-
+ #' @rdname int_methods |
||
| 493 | +2949 |
- ## TODO revisit. do we want to do this? used in vars_in_layout, but only+ setMethod( |
||
| 494 | +2950 |
- ## for convenience.+ "colcount_na_str<-", "InstantiatedColumnInfo", |
||
| 495 | +2951 |
- #' @rdname int_methods+ function(obj, value) {
|
||
| 496 | -3x | +2952 | +2x |
- setMethod("spl_label_var", "Split", function(obj) NULL)
+ obj@columncount_na_str <- value+ |
+
| 2953 | +2x | +
+ obj |
||
| 497 | +2954 |
-
+ } |
||
| 498 | +2955 |
- ### name related things+ ) |
||
| 499 | +2956 |
- # #' @inherit formatters::formatter_methods+ |
||
| 500 | +2957 |
- #' Methods for generics in the `formatters` package+ #' @rdname int_methods |
||
| 501 | +2958 |
- #'+ #' @export |
||
| 502 | +2959 |
- #' See the `formatters` documentation for descriptions of these generics.+ setMethod( |
||
| 503 | +2960 |
- #'+ "colcount_na_str<-", "VTableNodeInfo", |
||
| 504 | +2961 |
- #' @inheritParams gen_args+ function(obj, value) {
+ |
+ ||
| 2962 | +2x | +
+ cinfo <- col_info(obj)+ |
+ ||
| 2963 | +2x | +
+ colcount_na_str(cinfo) <- value+ |
+ ||
| 2964 | +2x | +
+ col_info(obj) <- cinfo+ |
+ ||
| 2965 | +2x | +
+ obj |
||
| 505 | +2966 |
- #'+ } |
||
| 506 | +2967 |
- #' @return+ ) |
||
| 507 | +2968 |
- #' * Accessor functions return the current value of the component being accessed of `obj`+ |
||
| 508 | +2969 |
- #' * Setter functions return a modified copy of `obj` with the new value.+ #' Exported for use in `tern` |
||
| 509 | +2970 |
#' |
||
| 510 | +2971 |
- #' @rdname formatters_methods+ #' Does the `table`/`row`/`InstantiatedColumnInfo` object contain no column structure information? |
||
| 511 | +2972 |
- #' @aliases formatters_methods+ #' |
||
| 512 | +2973 |
- #' @exportMethod obj_name+ #' @inheritParams gen_args |
||
| 513 | +2974 |
- setMethod(+ #' |
||
| 514 | +2975 |
- "obj_name", "VNodeInfo",+ #' @return `TRUE` if the object has no/empty instantiated column information, `FALSE` otherwise. |
||
| 515 | -45305x | +|||
| 2976 | +
- function(obj) obj@name+ #' |
|||
| 516 | +2977 |
- )+ #' @rdname no_info |
||
| 517 | +2978 | ++ |
+ #' @export+ |
+ |
| 2979 | +175490x | +
+ setGeneric("no_colinfo", function(obj) standardGeneric("no_colinfo"))
+ |
+ ||
| 2980 | ||||
| 518 | +2981 |
- #' @rdname formatters_methods+ #' @exportMethod no_colinfo |
||
| 519 | +2982 |
- #' @exportMethod obj_name+ #' @rdname no_info |
||
| 520 | +2983 |
setMethod( |
||
| 521 | +2984 |
- "obj_name", "Split",+ "no_colinfo", "VTableNodeInfo", |
||
| 522 | -111118x | +2985 | +74518x |
- function(obj) obj@name+ function(obj) no_colinfo(col_info(obj)) |
| 523 | +2986 |
) |
||
| 524 | +2987 | |||
| 525 | +2988 |
- #' @rdname formatters_methods+ #' @exportMethod no_colinfo |
||
| 526 | +2989 |
- #' @exportMethod obj_name<-+ #' @rdname no_info |
||
| 527 | +2990 |
setMethod( |
||
| 528 | +2991 |
- "obj_name<-", "VNodeInfo",+ "no_colinfo", "InstantiatedColumnInfo", |
||
| 529 | -+ | |||
| 2992 | +90781x |
- function(obj, value) {
+ function(obj) length(obj@subset_exprs) == 0 |
||
| 530 | -21x | +|||
| 2993 | +
- obj@name <- value+ ) ## identical(obj, EmptyColInfo)) |
|||
| 531 | -21x | +|||
| 2994 | +
- obj+ |
|||
| 532 | +2995 |
- }+ #' Names of a `TableTree` |
||
| 533 | +2996 |
- )+ #' |
||
| 534 | +2997 |
-
+ #' @param x (`TableTree`)\cr the object. |
||
| 535 | +2998 |
- #' @rdname formatters_methods+ #' |
||
| 536 | +2999 |
- #' @exportMethod obj_name<-+ #' @details |
||
| 537 | +3000 |
- setMethod(+ #' For `TableTree`s with more than one level of splitting in columns, the names are defined to be the top-level |
||
| 538 | +3001 |
- "obj_name<-", "Split",+ #' split values repped out across the columns that they span. |
||
| 539 | +3002 |
- function(obj, value) {
+ #' |
||
| 540 | -3x | +|||
| 3003 | +
- obj@name <- value+ #' @return The column names of `x`, as defined in the details above. |
|||
| 541 | -3x | +|||
| 3004 | +
- obj+ #' |
|||
| 542 | +3005 |
- }+ #' @exportMethod names |
||
| 543 | +3006 |
- )+ #' @rdname names |
||
| 544 | +3007 |
-
+ setMethod( |
||
| 545 | +3008 |
- ### Label related things+ "names", "VTableNodeInfo",+ |
+ ||
| 3009 | +109x | +
+ function(x) names(col_info(x)) |
||
| 546 | +3010 |
- #' @rdname formatters_methods+ ) |
||
| 547 | +3011 |
- #' @exportMethod obj_label+ |
||
| 548 | -2086x | +|||
| 3012 | +
- setMethod("obj_label", "Split", function(obj) obj@split_label)
+ #' @rdname names |
|||
| 549 | +3013 |
-
+ #' @exportMethod names |
||
| 550 | +3014 |
- #' @rdname formatters_methods+ setMethod( |
||
| 551 | +3015 |
- #' @exportMethod obj_label+ "names", "InstantiatedColumnInfo", |
||
| 552 | -39364x | +3016 | +127x |
- setMethod("obj_label", "TableRow", function(obj) obj@label)
+ function(x) names(coltree(x)) |
| 553 | +3017 |
-
+ ) |
||
| 554 | +3018 |
- ## XXX Do we want a convenience for VTableTree that+ |
||
| 555 | +3019 |
- ## grabs the label from the LabelRow or will+ #' @rdname names |
||
| 556 | +3020 |
- ## that just muddy the waters?+ #' @exportMethod names |
||
| 557 | +3021 |
- #' @rdname formatters_methods+ setMethod( |
||
| 558 | +3022 |
- #' @exportMethod obj_label+ "names", "LayoutColTree", |
||
| 559 | +3023 |
- setMethod(+ function(x) {
|
||
| 560 | -+ | |||
| 3024 | +163x |
- "obj_label", "VTableTree",+ unname(unlist(lapply( |
||
| 561 | -262x | +3025 | +163x |
- function(obj) obj_label(tt_labelrow(obj))+ tree_children(x), |
| 562 | -+ | |||
| 3026 | +163x |
- )+ function(obj) {
+ |
+ ||
| 3027 | +202x | +
+ nm <- obj_name(obj)+ |
+ ||
| 3028 | +202x | +
+ rep(nm, n_leaves(obj)) |
||
| 563 | +3029 |
-
+ } |
||
| 564 | +3030 |
- #' @rdname formatters_methods+ ))) |
||
| 565 | +3031 |
- #' @exportMethod obj_label+ } |
||
| 566 | -! | +|||
| 3032 | +
- setMethod("obj_label", "ValueWrapper", function(obj) obj@label)
+ ) |
|||
| 567 | +3033 | |||
| 568 | +3034 |
- #' @rdname formatters_methods+ #' @rdname names |
||
| 569 | +3035 |
- #' @exportMethod obj_label<-+ #' @exportMethod row.names |
||
| 570 | +3036 |
setMethod( |
||
| 571 | +3037 |
- "obj_label<-", "Split",+ "row.names", "VTableTree", |
||
| 572 | +3038 |
- function(obj, value) {
+ function(x) {
|
||
| 573 | -1x | +3039 | +104x |
- obj@split_label <- value+ unname(sapply(collect_leaves(x, add.labrows = TRUE), |
| 574 | -1x | +3040 | +104x |
- obj+ obj_label,+ |
+
| 3041 | +104x | +
+ USE.NAMES = FALSE+ |
+ ||
| 3042 | +104x | +
+ )) ## XXXX this should probably be obj_name??? |
||
| 575 | +3043 |
} |
||
| 576 | +3044 |
) |
||
| 577 | +3045 | |||
| 578 | +3046 |
- #' @rdname formatters_methods+ #' Convert to a vector |
||
| 579 | +3047 |
- #' @exportMethod obj_label<-+ #' |
||
| 580 | +3048 |
- setMethod(+ #' Convert an `rtables` framework object into a vector, if possible. This is unlikely to be useful in |
||
| 581 | +3049 |
- "obj_label<-", "TableRow",+ #' realistic scenarios. |
||
| 582 | +3050 |
- function(obj, value) {
+ #' |
||
| 583 | -32x | +|||
| 3051 | +
- obj@label <- value+ #' @param x (`ANY`)\cr the object to be converted to a vector. |
|||
| 584 | -32x | +|||
| 3052 | +
- obj+ #' @param mode (`string`)\cr passed on to [as.vector()]. |
|||
| 585 | +3053 |
- }+ #' |
||
| 586 | +3054 |
- )+ #' @return A vector of the chosen mode (or an error is raised if more than one row was present). |
||
| 587 | +3055 |
-
+ #' |
||
| 588 | +3056 |
- #' @rdname formatters_methods+ #' @note This only works for a table with a single row or a row object. |
||
| 589 | +3057 |
- #' @exportMethod obj_label<-+ #' |
||
| 590 | +3058 |
- setMethod(+ #' @name asvec |
||
| 591 | +3059 |
- "obj_label<-", "ValueWrapper",+ #' @aliases as.vector,VTableTree-method |
||
| 592 | +3060 |
- function(obj, value) {
+ #' @exportMethod as.vector |
||
| 593 | -! | +|||
| 3061 | +
- obj@label <- value+ setMethod("as.vector", "VTableTree", function(x, mode) {
+ |
+ |||
| 3062 | +12x | +
+ stopifnot(nrow(x) == 1L)+ |
+ ||
| 3063 | +12x | +
+ if (nrow(content_table(x)) == 1L) {
|
||
| 594 | +3064 | ! |
- obj+ tab <- content_table(x) |
|
| 595 | +3065 |
- }+ } else {
|
||
| 596 | -+ | |||
| 3066 | +12x |
- )+ tab <- x |
||
| 597 | +3067 |
-
+ } |
||
| 598 | -+ | |||
| 3068 | +12x |
- #' @rdname formatters_methods+ as.vector(tree_children(tab)[[1]], mode = mode) |
||
| 599 | +3069 |
- #' @exportMethod obj_label<-+ }) |
||
| 600 | +3070 |
- setMethod(+ |
||
| 601 | +3071 |
- "obj_label<-", "VTableTree",+ #' @inheritParams asvec |
||
| 602 | +3072 |
- function(obj, value) {
+ #' |
||
| 603 | -11x | +|||
| 3073 | +
- lr <- tt_labelrow(obj)+ #' @rdname int_methods |
|||
| 604 | -11x | +|||
| 3074 | +
- obj_label(lr) <- value+ #' @exportMethod as.vector |
|||
| 605 | -11x | +|||
| 3075 | +
- if (!is.na(value) && nzchar(value)) {
+ setMethod("as.vector", "TableRow", function(x, mode) as.vector(unlist(row_values(x)), mode = mode))
|
|||
| 606 | -10x | +|||
| 3076 | +
- labelrow_visible(lr) <- TRUE+ |
|||
| 607 | -1x | +|||
| 3077 | +
- } else if (is.na(value)) {
+ #' @rdname int_methods |
|||
| 608 | -1x | +|||
| 3078 | +
- labelrow_visible(lr) <- FALSE+ #' @exportMethod as.vector |
|||
| 609 | +3079 |
- }+ setMethod("as.vector", "ElementaryTable", function(x, mode) {
|
||
| 610 | -11x | +3080 | +2x |
- tt_labelrow(obj) <- lr+ stopifnot(nrow(x) == 1L) |
| 611 | -11x | +3081 | +2x |
- obj+ as.vector(tree_children(x)[[1]], mode = mode) |
| 612 | +3082 |
- }+ }) |
||
| 613 | +3083 |
- )+ |
||
| 614 | +3084 |
-
+ ## cuts ---- |
||
| 615 | +3085 |
- ### Label rows.+ |
||
| 616 | +3086 |
#' @rdname int_methods |
||
| 617 | -128557x | +3087 | +220x |
- setGeneric("tt_labelrow", function(obj) standardGeneric("tt_labelrow"))
+ setGeneric("spl_cuts", function(obj) standardGeneric("spl_cuts"))
|
| 618 | +3088 | |||
| 619 | +3089 |
#' @rdname int_methods |
||
| 620 | +3090 |
setMethod( |
||
| 621 | +3091 |
- "tt_labelrow", "VTableTree",+ "spl_cuts", "VarStaticCutSplit", |
||
| 622 | -45950x | +3092 | +220x |
- function(obj) obj@labelrow+ function(obj) obj@cuts |
| 623 | +3093 |
) |
||
| 624 | +3094 | |||
| 625 | +3095 |
#' @rdname int_methods |
||
| 626 | -4048x | +3096 | +264x |
- setGeneric("tt_labelrow<-", function(obj, value) standardGeneric("tt_labelrow<-"))
+ setGeneric("spl_cutlabels", function(obj) standardGeneric("spl_cutlabels"))
|
| 627 | +3097 | |||
| 628 | +3098 |
#' @rdname int_methods |
||
| 629 | +3099 |
setMethod( |
||
| 630 | +3100 |
- "tt_labelrow<-", c("VTableTree", "LabelRow"),
+ "spl_cutlabels", "VarStaticCutSplit",+ |
+ ||
| 3101 | +264x | +
+ function(obj) obj@cut_labels |
||
| 631 | +3102 |
- function(obj, value) {
+ ) |
||
| 632 | -4048x | +|||
| 3103 | +
- if (no_colinfo(value)) {
+
+ |
+ |||
| 3104 | ++ |
+ #' @rdname int_methods |
||
| 633 | -1x | +3105 | +5x |
- col_info(value) <- col_info(obj)+ setGeneric("spl_cutfun", function(obj) standardGeneric("spl_cutfun"))
|
| 634 | +3106 |
- }+ |
||
| 635 | -4048x | +|||
| 3107 | +
- obj@labelrow <- value+ #' @rdname int_methods |
|||
| 636 | -4048x | +|||
| 3108 | +
- obj+ setMethod( |
|||
| 637 | +3109 |
- }+ "spl_cutfun", "VarDynCutSplit",+ |
+ ||
| 3110 | +5x | +
+ function(obj) obj@cut_fun |
||
| 638 | +3111 |
) |
||
| 639 | +3112 | |||
| 640 | +3113 |
#' @rdname int_methods |
||
| 641 | -194549x | +3114 | +5x |
- setGeneric("labelrow_visible", function(obj) standardGeneric("labelrow_visible"))
+ setGeneric("spl_cutlabelfun", function(obj) standardGeneric("spl_cutlabelfun"))
|
| 642 | +3115 | |||
| 643 | +3116 |
#' @rdname int_methods |
||
| 644 | +3117 |
setMethod( |
||
| 645 | +3118 |
- "labelrow_visible", "VTableTree",+ "spl_cutlabelfun", "VarDynCutSplit", |
||
| 646 | -+ | |||
| 3119 | +5x |
- function(obj) {
+ function(obj) obj@cut_label_fun |
||
| 647 | -28067x | +|||
| 3120 | +
- labelrow_visible(tt_labelrow(obj))+ ) |
|||
| 648 | +3121 |
- }+ |
||
| 649 | +3122 |
- )+ #' @rdname int_methods+ |
+ ||
| 3123 | +5x | +
+ setGeneric("spl_is_cmlcuts", function(obj) standardGeneric("spl_is_cmlcuts"))
|
||
| 650 | +3124 | |||
| 651 | +3125 |
#' @rdname int_methods |
||
| 652 | +3126 |
setMethod( |
||
| 653 | +3127 |
- "labelrow_visible", "LabelRow",+ "spl_is_cmlcuts", "VarDynCutSplit", |
||
| 654 | -105960x | +3128 | +5x |
- function(obj) obj@visible+ function(obj) obj@cumulative_cuts |
| 655 | +3129 |
) |
||
| 656 | +3130 | |||
| 657 | +3131 |
#' @rdname int_methods |
||
| 658 | +3132 |
- setMethod(+ setGeneric( |
||
| 659 | +3133 |
- "labelrow_visible", "VAnalyzeSplit",+ "spl_varnames", |
||
| 660 | -1375x | +3134 | +198x |
- function(obj) .labelkids_helper(obj@var_label_position)+ function(obj) standardGeneric("spl_varnames")
|
| 661 | +3135 |
) |
||
| 662 | +3136 | |||
| 663 | +3137 |
#' @rdname int_methods |
||
| 664 | -2865x | +|||
| 3138 | +
- setGeneric("labelrow_visible<-", function(obj, value) standardGeneric("labelrow_visible<-"))
+ setMethod( |
|||
| 665 | +3139 |
-
+ "spl_varnames", "MultiVarSplit", |
||
| 666 | -+ | |||
| 3140 | +198x |
- #' @rdname int_methods+ function(obj) obj@var_names |
||
| 667 | +3141 |
- setMethod(+ ) |
||
| 668 | +3142 |
- "labelrow_visible<-", "VTableTree",+ |
||
| 669 | +3143 |
- function(obj, value) {
+ #' @rdname int_methods |
||
| 670 | -1294x | -
- lr <- tt_labelrow(obj)- |
- ||
| 671 | -1294x | +|||
| 3144 | +
- labelrow_visible(lr) <- value+ setGeneric( |
|||
| 672 | -1294x | +|||
| 3145 | +
- tt_labelrow(obj) <- lr+ "spl_varnames<-", |
|||
| 673 | -1294x | -
- obj- |
- ||
| 674 | -+ | 3146 | +2x |
- }+ function(object, value) standardGeneric("spl_varnames<-")
|
| 675 | +3147 |
) |
||
| 676 | +3148 | |||
| 677 | +3149 |
#' @rdname int_methods |
||
| 678 | +3150 |
setMethod( |
||
| 679 | +3151 |
- "labelrow_visible<-", "LabelRow",+ "spl_varnames<-", "MultiVarSplit", |
||
| 680 | +3152 |
- function(obj, value) {
+ function(object, value) {
|
||
| 681 | -1305x | +3153 | +2x |
- obj@visible <- value+ oldvnms <- spl_varnames(object) |
| 682 | -1305x | +3154 | +2x |
- obj+ oldvlbls <- spl_varlabels(object) |
| 683 | -+ | |||
| 3155 | +2x |
- }+ object@var_names <- value |
||
| 684 | -+ | |||
| 3156 | +2x |
- )+ if (identical(oldvnms, oldvlbls)) {
|
||
| 685 | -+ | |||
| 3157 | +1x |
-
+ spl_varlabels(object) <- value |
||
| 686 | +3158 |
- #' @rdname int_methods+ } |
||
| 687 | -+ | |||
| 3159 | +2x |
- setMethod(+ object |
||
| 688 | +3160 |
- "labelrow_visible<-", "VAnalyzeSplit",+ } |
||
| 689 | +3161 |
- function(obj, value) {
+ ) |
||
| 690 | -266x | +|||
| 3162 | +
- obj@var_label_position <- value+ |
|||
| 691 | -266x | +|||
| 3163 | +
- obj+ #' Top left material |
|||
| 692 | +3164 |
- }+ #' |
||
| 693 | +3165 |
- )+ #' A `TableTree` object can have *top left material* which is a sequence of strings which are printed in the |
||
| 694 | +3166 |
-
+ #' area of the table between the column header display and the label of the first row. These functions access |
||
| 695 | +3167 |
- ## TRUE is always, FALSE is never, NA is only when no+ #' and modify that material. |
||
| 696 | +3168 |
- ## content function (or rows in an instantiated table) is present+ #' |
||
| 697 | +3169 |
- #' @rdname int_methods+ #' @inheritParams gen_args |
||
| 698 | -1519x | +|||
| 3170 | +
- setGeneric("label_kids", function(spl) standardGeneric("label_kids"))
+ #' |
|||
| 699 | +3171 |
-
+ #' @return A character vector representing the top-left material of `obj` (or `obj` after modification, in the |
||
| 700 | +3172 |
- #' @rdname int_methods+ #' case of the setter). |
||
| 701 | -1519x | +|||
| 3173 | +
- setMethod("label_kids", "Split", function(spl) spl@label_children)
+ #' |
|||
| 702 | +3174 |
-
+ #' @export |
||
| 703 | +3175 |
- #' @rdname int_methods+ #' @rdname top_left |
||
| 704 | -3x | +3176 | +6894x |
- setGeneric("label_kids<-", function(spl, value) standardGeneric("label_kids<-"))
+ setGeneric("top_left", function(obj) standardGeneric("top_left"))
|
| 705 | +3177 | |||
| 706 | +3178 |
- #' @rdname int_methods+ #' @export |
||
| 707 | +3179 |
- setMethod("label_kids<-", c("Split", "character"), function(spl, value) {
- |
- ||
| 708 | -1x | -
- label_kids(spl) <- .labelkids_helper(value)+ #' @rdname top_left |
||
| 709 | -1x | -
- spl- |
- ||
| 710 | -+ | 3180 | +2993x |
- })+ setMethod("top_left", "VTableTree", function(obj) top_left(col_info(obj)))
|
| 711 | +3181 | |||
| 712 | +3182 |
- #' @rdname int_methods+ #' @export |
||
| 713 | +3183 |
- setMethod("label_kids<-", c("Split", "logical"), function(spl, value) {
- |
- ||
| 714 | -2x | -
- spl@label_children <- value+ #' @rdname top_left |
||
| 715 | -2x | +3184 | +3568x |
- spl+ setMethod("top_left", "InstantiatedColumnInfo", function(obj) obj@top_left)
|
| 716 | +3185 |
- })+ |
||
| 717 | +3186 |
-
+ #' @export |
||
| 718 | +3187 |
- #' @rdname int_methods+ #' @rdname top_left |
||
| 719 | -399x | +3188 | +333x |
- setGeneric("vis_label", function(spl) standardGeneric("vis_label"))
+ setMethod("top_left", "PreDataTableLayouts", function(obj) obj@top_left)
|
| 720 | +3189 | |||
| 721 | +3190 |
- #' @rdname int_methods+ #' @export |
||
| 722 | +3191 |
- setMethod("vis_label", "Split", function(spl) {
+ #' @rdname top_left |
||
| 723 | -399x | +3192 | +5909x |
- .labelkids_helper(label_position(spl))+ setGeneric("top_left<-", function(obj, value) standardGeneric("top_left<-"))
|
| 724 | +3193 |
- })+ |
||
| 725 | +3194 |
-
+ #' @export |
||
| 726 | +3195 |
- ## #' @rdname int_methods+ #' @rdname top_left |
||
| 727 | +3196 |
- ## setGeneric("vis_label<-", function(spl, value) standardGeneric("vis_label<-"))
+ setMethod("top_left<-", "VTableTree", function(obj, value) {
|
||
| 728 | -+ | |||
| 3197 | +2954x |
- ## #' @rdname int_methods+ cinfo <- col_info(obj) |
||
| 729 | -+ | |||
| 3198 | +2954x |
- ## setMethod("vis_label<-", "Split", function(spl, value) {
+ top_left(cinfo) <- value |
||
| 730 | -+ | |||
| 3199 | +2954x |
- ## stop("defunct")
+ col_info(obj) <- cinfo |
||
| 731 | -+ | |||
| 3200 | +2954x |
- ## if(is.na(value))+ obj |
||
| 732 | +3201 |
- ## stop("split label visibility must be TRUE or FALSE, got NA")
+ }) |
||
| 733 | +3202 |
- ## # spl@split_label_visible <- value+ |
||
| 734 | +3203 |
- ## spl+ #' @export |
||
| 735 | +3204 |
- ## })+ #' @rdname top_left |
||
| 736 | +3205 |
-
+ setMethod("top_left<-", "InstantiatedColumnInfo", function(obj, value) {
|
||
| 737 | -+ | |||
| 3206 | +2954x |
- #' @rdname int_methods+ obj@top_left <- value |
||
| 738 | -1028x | +3207 | +2954x |
- setGeneric("label_position", function(spl) standardGeneric("label_position"))
+ obj |
| 739 | +3208 |
-
+ }) |
||
| 740 | +3209 |
- #' @rdname int_methods+ |
||
| 741 | -703x | +|||
| 3210 | +
- setMethod("label_position", "Split", function(spl) spl@split_label_position)
+ #' @export |
|||
| 742 | +3211 |
-
+ #' @rdname top_left |
||
| 743 | +3212 |
- #' @rdname int_methods+ setMethod("top_left<-", "PreDataTableLayouts", function(obj, value) {
|
||
| 744 | -325x | +3213 | +1x |
- setMethod("label_position", "VAnalyzeSplit", function(spl) spl@var_label_position) ## split_label_position)
+ obj@top_left <- value |
| 745 | -+ | |||
| 3214 | +1x |
-
+ obj |
||
| 746 | +3215 |
- #' @rdname int_methods- |
- ||
| 747 | -48x | -
- setGeneric("label_position<-", function(spl, value) standardGeneric("label_position<-"))
+ }) |
||
| 748 | +3216 | |||
| 749 | +3217 |
- #' @rdname int_methods+ vil_collapse <- function(x) {
|
||
| 750 | -+ | |||
| 3218 | +14x |
- setMethod("label_position<-", "Split", function(spl, value) {
+ x <- unlist(x) |
||
| 751 | -48x | +3219 | +14x |
- value <- match.arg(value, valid_lbl_pos)+ x <- x[!is.na(x)] |
| 752 | -48x | +3220 | +14x |
- spl@split_label_position <- value+ x <- unique(x) |
| 753 | -48x | +3221 | +14x |
- spl+ x[nzchar(x)] |
| 754 | +3222 |
- })+ } |
||
| 755 | +3223 | |||
| 756 | +3224 |
- ### Function accessors (summary, tabulation and split) ----+ #' List variables required by a pre-data table layout |
||
| 757 | +3225 |
-
+ #' |
||
| 758 | +3226 |
- #' @rdname int_methods+ #' @param lyt (`PreDataTableLayouts`)\cr the layout (or a component thereof). |
||
| 759 | -3280x | +|||
| 3227 | +
- setGeneric("content_fun", function(obj) standardGeneric("content_fun"))
+ #' |
|||
| 760 | +3228 |
-
+ #' @details |
||
| 761 | +3229 |
- #' @rdname int_methods+ #' This will walk the layout declaration and return a vector of the names of the unique variables that are used |
||
| 762 | -3228x | +|||
| 3230 | +
- setMethod("content_fun", "Split", function(obj) obj@content_fun)
+ #' in any of the following ways: |
|||
| 763 | +3231 |
-
+ #' |
||
| 764 | +3232 |
- #' @rdname int_methods+ #' * Variable being split on (directly or via cuts) |
||
| 765 | -114x | +|||
| 3233 | +
- setGeneric("content_fun<-", function(object, value) standardGeneric("content_fun<-"))
+ #' * Element of a Multi-variable column split |
|||
| 766 | +3234 |
-
+ #' * Content variable |
||
| 767 | +3235 |
- #' @rdname int_methods+ #' * Value-label variable |
||
| 768 | +3236 |
- setMethod("content_fun<-", "Split", function(object, value) {
+ #' |
||
| 769 | -114x | +|||
| 3237 | +
- object@content_fun <- value+ #' @return A character vector containing the unique variables explicitly used in the layout (see the notes below). |
|||
| 770 | -114x | +|||
| 3238 | +
- object+ #' |
|||
| 771 | +3239 |
- })+ #' @note |
||
| 772 | +3240 |
-
+ #' * This function will not detect dependencies implicit in analysis or summary functions which accept `x` |
||
| 773 | +3241 |
- #' @rdname int_methods+ #' or `df` and then rely on the existence of particular variables not being split on/analyzed. |
||
| 774 | -1695x | +|||
| 3242 | +
- setGeneric("analysis_fun", function(obj) standardGeneric("analysis_fun"))
+ #' * The order these variable names appear within the return vector is undefined and should not be relied upon. |
|||
| 775 | +3243 |
-
+ #' |
||
| 776 | +3244 |
- #' @rdname int_methods+ #' @examples |
||
| 777 | -1600x | +|||
| 3245 | +
- setMethod("analysis_fun", "AnalyzeVarSplit", function(obj) obj@analysis_fun)
+ #' lyt <- basic_table() %>% |
|||
| 778 | +3246 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 779 | +3247 |
- #' @rdname int_methods+ #' split_cols_by("SEX") %>%
|
||
| 780 | -95x | +|||
| 3248 | +
- setMethod("analysis_fun", "AnalyzeColVarSplit", function(obj) obj@analysis_fun)
+ #' summarize_row_groups(label_fstr = "Overall (N)") %>% |
|||
| 781 | +3249 |
-
+ #' split_rows_by("RACE",
|
||
| 782 | +3250 |
- ## not used and probably not needed+ #' split_label = "Ethnicity", labels_var = "ethn_lab", |
||
| 783 | +3251 |
- ## #' @rdname int_methods+ #' split_fun = drop_split_levels |
||
| 784 | +3252 |
- ## setGeneric("analysis_fun<-", function(object, value) standardGeneric("analysis_fun<-"))
+ #' ) %>% |
||
| 785 | +3253 |
-
+ #' summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
|
||
| 786 | +3254 |
- ## #' @rdname int_methods+ #' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
|
||
| 787 | +3255 |
- ## setMethod("analysis_fun<-", "AnalyzeVarSplit", function(object, value) {
+ #' |
||
| 788 | +3256 |
- ## object@analysis_fun <- value+ #' vars_in_layout(lyt) |
||
| 789 | +3257 |
- ## object+ #' |
||
| 790 | +3258 |
- ## })+ #' @export |
||
| 791 | +3259 |
- ## #' @rdname int_methods+ #' @rdname vil |
||
| 792 | -+ | |||
| 3260 | +15x |
- ## setMethod("analysis_fun<-", "AnalyzeColVarSplit", function(object, value) {
+ setGeneric("vars_in_layout", function(lyt) standardGeneric("vars_in_layout"))
|
||
| 793 | +3261 |
- ## if(is(value, "function"))+ |
||
| 794 | +3262 |
- ## value <- list(value)+ #' @rdname vil |
||
| 795 | +3263 |
- ## object@analysis_fun <- value+ setMethod( |
||
| 796 | +3264 |
- ## object+ "vars_in_layout", "PreDataTableLayouts", |
||
| 797 | +3265 |
- ## })+ function(lyt) {
|
||
| 798 | -+ | |||
| 3266 | +1x |
-
+ vil_collapse(c( |
||
| 799 | -+ | |||
| 3267 | +1x |
- #' @rdname int_methods+ vars_in_layout(clayout(lyt)), |
||
| 800 | -1092x | +3268 | +1x |
- setGeneric("split_fun", function(obj) standardGeneric("split_fun"))
+ vars_in_layout(rlayout(lyt)) |
| 801 | +3269 |
-
+ )) |
||
| 802 | +3270 |
- #' @rdname int_methods+ } |
||
| 803 | -909x | +|||
| 3271 | +
- setMethod("split_fun", "CustomizableSplit", function(obj) obj@split_fun)
+ ) |
|||
| 804 | +3272 | |||
| 805 | +3273 |
- ## Only that type of split currently has the slot+ #' @rdname vil |
||
| 806 | +3274 |
- ## this should probably change? for now define+ setMethod( |
||
| 807 | +3275 |
- ## an accessor that just returns NULL+ "vars_in_layout", "PreDataAxisLayout", |
||
| 808 | +3276 |
- #' @rdname int_methods+ function(lyt) {
|
||
| 809 | -131x | +3277 | +2x |
- setMethod("split_fun", "Split", function(obj) NULL)
+ vil_collapse(lapply(lyt, vars_in_layout)) |
| 810 | +3278 |
-
+ } |
||
| 811 | +3279 |
- #' @rdname int_methods+ ) |
||
| 812 | -13x | +|||
| 3280 | +
- setGeneric("split_fun<-", function(obj, value) standardGeneric("split_fun<-"))
+
|
|||
| 813 | +3281 |
-
+ #' @rdname vil |
||
| 814 | +3282 |
- #' @rdname int_methods+ setMethod( |
||
| 815 | +3283 |
- setMethod("split_fun<-", "CustomizableSplit", function(obj, value) {
+ "vars_in_layout", "SplitVector", |
||
| 816 | -13x | +|||
| 3284 | +
- obj@split_fun <- value+ function(lyt) {
|
|||
| 817 | -13x | +3285 | +3x |
- obj+ vil_collapse(lapply(lyt, vars_in_layout)) |
| 818 | +3286 |
- })+ } |
||
| 819 | +3287 |
-
+ ) |
||
| 820 | +3288 |
- # nocov start+ |
||
| 821 | +3289 |
- ## Only that type of split currently has the slot+ #' @rdname vil |
||
| 822 | +3290 |
- ## this should probably change? for now define+ setMethod( |
||
| 823 | +3291 |
- ## an accessor that just returns NULL+ "vars_in_layout", "Split", |
||
| 824 | +3292 |
- #' @rdname int_methods+ function(lyt) {
+ |
+ ||
| 3293 | +7x | +
+ vil_collapse(c(+ |
+ ||
| 3294 | +7x | +
+ spl_payload(lyt), |
||
| 825 | +3295 |
- setMethod(+ ## for an AllSplit/RootSplit |
||
| 826 | +3296 |
- "split_fun<-", "Split",+ ## doesn't have to be same as payload+ |
+ ||
| 3297 | +7x | +
+ content_var(lyt),+ |
+ ||
| 3298 | +7x | +
+ spl_label_var(lyt) |
||
| 827 | +3299 |
- function(obj, value) {
+ )) |
||
| 828 | +3300 |
- stop(+ } |
||
| 829 | +3301 |
- "Attempted to set a custom split function on a non-customizable split.",+ ) |
||
| 830 | +3302 |
- "This should not happen, please contact the maintainers."+ |
||
| 831 | +3303 |
- )+ #' @rdname vil |
||
| 832 | +3304 |
- }+ setMethod( |
||
| 833 | +3305 |
- )+ "vars_in_layout", "CompoundSplit",+ |
+ ||
| 3306 | +1x | +
+ function(lyt) vil_collapse(lapply(spl_payload(lyt), vars_in_layout)) |
||
| 834 | +3307 |
- # nocov end+ ) |
||
| 835 | +3308 | |||
| 836 | +3309 |
- ## Content specification related accessors ----+ #' @rdname vil |
||
| 837 | +3310 |
-
+ setMethod( |
||
| 838 | +3311 |
- #' @rdname int_methods+ "vars_in_layout", "ManualSplit", |
||
| 839 | -469x | +3312 | +1x |
- setGeneric("content_extra_args", function(obj) standardGeneric("content_extra_args"))
+ function(lyt) character() |
| 840 | +3313 |
-
+ ) |
||
| 841 | +3314 |
- #' @rdname int_methods+ |
||
| 842 | -469x | +|||
| 3315 | +
- setMethod("content_extra_args", "Split", function(obj) obj@content_extra_args)
+ ## Titles and footers ---- |
|||
| 843 | +3316 | |||
| 844 | +3317 |
- #' @rdname int_methods- |
- ||
| 845 | -114x | -
- setGeneric("content_extra_args<-", function(object, value) standardGeneric("content_extra_args<-"))
+ # ##' Titles and Footers |
||
| 846 | +3318 |
-
+ # ##' |
||
| 847 | +3319 |
- #' @rdname int_methods+ # ##' Get or set the titles and footers on an object |
||
| 848 | +3320 |
- setMethod("content_extra_args<-", "Split", function(object, value) {
+ # ##' |
||
| 849 | -114x | +|||
| 3321 | +
- object@content_extra_args <- value+ # ##' @inheritParams gen_args |
|||
| 850 | -114x | +|||
| 3322 | +
- object+ # ##' |
|||
| 851 | +3323 |
- })+ # ##' @rdname title_footer |
||
| 852 | +3324 |
-
+ # ##' @export |
||
| 853 | +3325 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 854 | -1841x | +|||
| 3326 | +
- setGeneric("content_var", function(obj) standardGeneric("content_var"))
+ #' @export |
|||
| 855 | +3327 |
-
+ setMethod( |
||
| 856 | +3328 |
- #' @rdname int_methods+ "main_title", "VTitleFooter", |
||
| 857 | -1841x | +3329 | +3567x |
- setMethod("content_var", "Split", function(obj) obj@content_var)
+ function(obj) obj@main_title |
| 858 | +3330 | ++ |
+ )+ |
+ |
| 3331 | ||||
| 859 | +3332 |
- #' @rdname int_methods+ ##' @rdname formatters_methods |
||
| 860 | -114x | +|||
| 3333 | +
- setGeneric("content_var<-", function(object, value) standardGeneric("content_var<-"))
+ ##' @export |
|||
| 861 | +3334 |
-
+ setMethod( |
||
| 862 | +3335 |
- #' @rdname int_methods+ "main_title<-", "VTitleFooter", |
||
| 863 | +3336 |
- setMethod("content_var<-", "Split", function(object, value) {
+ function(obj, value) {
|
||
| 864 | -114x | +3337 | +3173x |
- object@content_var <- value+ stopifnot(length(value) == 1) |
| 865 | -114x | +3338 | +3173x |
- object+ obj@main_title <- value |
| 866 | -+ | |||
| 3339 | +3173x |
- })+ obj |
||
| 867 | +3340 |
-
+ } |
||
| 868 | +3341 |
- ### Miscellaneous accessors ----+ ) |
||
| 869 | +3342 | |||
| 870 | +3343 |
- #' @rdname int_methods- |
- ||
| 871 | -1102x | -
- setGeneric("avar_inclNAs", function(obj) standardGeneric("avar_inclNAs"))
+ # Getters for TableRow is here for convenience for binding (no need of setters) |
||
| 872 | +3344 |
-
+ #' @rdname formatters_methods |
||
| 873 | +3345 |
- #' @rdname int_methods+ #' @export |
||
| 874 | +3346 |
setMethod( |
||
| 875 | +3347 |
- "avar_inclNAs", "VAnalyzeSplit",+ "main_title", "TableRow", |
||
| 876 | -1102x | +3348 | +6x |
- function(obj) obj@include_NAs+ function(obj) "" |
| 877 | +3349 |
) |
||
| 878 | +3350 | |||
| 879 | +3351 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 880 | -! | +|||
| 3352 | +
- setGeneric("avar_inclNAs<-", function(obj, value) standardGeneric("avar_inclNAs<-"))
+ #' @export |
|||
| 881 | +3353 |
-
+ setMethod( |
||
| 882 | +3354 |
- #' @rdname int_methods+ "subtitles", "VTitleFooter", |
||
| 883 | -+ | |||
| 3355 | +3557x |
- setMethod(+ function(obj) obj@subtitles |
||
| 884 | +3356 |
- "avar_inclNAs<-", "VAnalyzeSplit",+ ) |
||
| 885 | +3357 |
- function(obj, value) {
+
|
||
| 886 | -! | +|||
| 3358 | +
- obj@include_NAs <- value+ #' @rdname formatters_methods |
|||
| 887 | +3359 |
- }+ #' @export |
||
| 888 | +3360 |
- )+ setMethod( |
||
| 889 | +3361 |
-
+ "subtitles<-", "VTitleFooter", |
||
| 890 | +3362 |
- #' @rdname int_methods+ function(obj, value) {
|
||
| 891 | -821x | +3363 | +3168x |
- setGeneric("spl_labelvar", function(obj) standardGeneric("spl_labelvar"))
+ obj@subtitles <- value |
| 892 | -+ | |||
| 3364 | +3168x |
-
+ obj |
||
| 893 | +3365 |
- #' @rdname int_methods+ } |
||
| 894 | -821x | +|||
| 3366 | +
- setMethod("spl_labelvar", "VarLevelSplit", function(obj) obj@value_label_var)
+ ) |
|||
| 895 | +3367 | |||
| 896 | +3368 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 897 | -2786x | +|||
| 3369 | +
- setGeneric("spl_child_order", function(obj) standardGeneric("spl_child_order"))
+ #' @export |
|||
| 898 | +3370 |
-
+ setMethod( |
||
| 899 | +3371 |
- #' @rdname int_methods+ "subtitles", "TableRow", # Only getter: see main_title for TableRow |
||
| 900 | -2485x | +3372 | +6x |
- setMethod("spl_child_order", "VarLevelSplit", function(obj) obj@value_order)
+ function(obj) character() |
| 901 | +3373 | ++ |
+ )+ |
+ |
| 3374 | ||||
| 902 | +3375 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 903 | +3376 |
- setGeneric(+ #' @export |
||
| 904 | +3377 |
- "spl_child_order<-",+ setMethod(+ |
+ ||
| 3378 | ++ |
+ "main_footer", "VTitleFooter", |
||
| 905 | -630x | +3379 | +3575x |
- function(obj, value) standardGeneric("spl_child_order<-")
+ function(obj) obj@main_footer |
| 906 | +3380 |
) |
||
| 907 | +3381 | |||
| 908 | +3382 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 909 | +3383 | ++ |
+ #' @export+ |
+ |
| 3384 |
setMethod( |
|||
| 910 | +3385 |
- "spl_child_order<-", "VarLevelSplit",+ "main_footer<-", "VTitleFooter", |
||
| 911 | +3386 |
function(obj, value) {
|
||
| 912 | -630x | +3387 | +3173x |
- obj@value_order <- value+ obj@main_footer <- value |
| 913 | -630x | +3388 | +3173x |
obj |
| 914 | +3389 |
} |
||
| 915 | +3390 |
) |
||
| 916 | +3391 | |||
| 917 | +3392 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 918 | +3393 |
- setMethod(+ #' @export |
||
| 919 | +3394 |
- "spl_child_order",+ setMethod( |
||
| 920 | +3395 |
- "ManualSplit",+ "main_footer", "TableRow", # Only getter: see main_title for TableRow |
||
| 921 | -52x | +3396 | +6x |
- function(obj) obj@levels+ function(obj) character() |
| 922 | +3397 |
) |
||
| 923 | +3398 | |||
| 924 | +3399 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 925 | +3400 |
- setMethod(+ #' @export |
||
| 926 | +3401 |
- "spl_child_order",+ setMethod( |
||
| 927 | +3402 |
- "MultiVarSplit",+ "prov_footer", "VTitleFooter", |
||
| 928 | -96x | +3403 | +3556x |
- function(obj) spl_varnames(obj)+ function(obj) obj@provenance_footer |
| 929 | +3404 |
) |
||
| 930 | +3405 | |||
| 931 | +3406 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 932 | +3407 | ++ |
+ #' @export+ |
+ |
| 3408 |
setMethod( |
|||
| 933 | +3409 |
- "spl_child_order",+ "prov_footer<-", "VTitleFooter", |
||
| 934 | +3410 |
- "AllSplit",+ function(obj, value) {
|
||
| 935 | -109x | +3411 | +3167x |
- function(obj) character()+ obj@provenance_footer <- value+ |
+
| 3412 | +3167x | +
+ obj |
||
| 936 | +3413 | ++ |
+ }+ |
+ |
| 3414 |
) |
|||
| 937 | +3415 | |||
| 938 | +3416 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 939 | +3417 |
- setMethod(+ #' @export |
||
| 940 | +3418 |
- "spl_child_order",+ setMethod( |
||
| 941 | +3419 |
- "VarStaticCutSplit",+ "prov_footer", "TableRow", # Only getter: see main_title for TableRow |
||
| 942 | -44x | +3420 | +6x |
- function(obj) spl_cutlabels(obj)+ function(obj) character() |
| 943 | +3421 |
) |
||
| 944 | +3422 | |||
| 945 | +3423 |
- #' @rdname int_methods+ make_ref_value <- function(value) {
|
||
| 946 | -989x | +3424 | +3306x |
- setGeneric("root_spl", function(obj) standardGeneric("root_spl"))
+ if (is(value, "RefFootnote")) {
|
| 947 | -+ | |||
| 3425 | +! |
-
+ value <- list(value) |
||
| 948 | -+ | |||
| 3426 | +3306x |
- #' @rdname int_methods+ } else if (!is.list(value) || any(!sapply(value, is, "RefFootnote"))) {
|
||
| 949 | -+ | |||
| 3427 | +10x |
- setMethod(+ value <- lapply(value, RefFootnote) |
||
| 950 | +3428 |
- "root_spl", "PreDataAxisLayout",+ } |
||
| 951 | -989x | +3429 | +3306x |
- function(obj) obj@root_split+ value |
| 952 | +3430 |
- )+ } |
||
| 953 | +3431 | |||
| 954 | +3432 |
- #' @rdname int_methods+ #' Referential footnote accessors |
||
| 955 | -9x | +|||
| 3433 | +
- setGeneric("root_spl<-", function(obj, value) standardGeneric("root_spl<-"))
+ #' |
|||
| 956 | +3434 |
-
+ #' Access and set the referential footnotes aspects of a built table. |
||
| 957 | +3435 |
- #' @rdname int_methods+ #' |
||
| 958 | +3436 |
- setMethod(+ #' @inheritParams gen_args |
||
| 959 | +3437 |
- "root_spl<-", "PreDataAxisLayout",+ #' |
||
| 960 | +3438 |
- function(obj, value) {
+ #' @export |
||
| 961 | -9x | +|||
| 3439 | +
- obj@root_split <- value+ #' @rdname ref_fnotes |
|||
| 962 | -9x | +3440 | +51397x |
- obj+ setGeneric("row_footnotes", function(obj) standardGeneric("row_footnotes"))
|
| 963 | +3441 |
- }+ |
||
| 964 | +3442 |
- )+ #' @export |
||
| 965 | +3443 |
-
+ #' @rdname int_methods |
||
| 966 | +3444 |
- #' Row attribute accessors+ setMethod( |
||
| 967 | +3445 |
- #'+ "row_footnotes", "TableRow",+ |
+ ||
| 3446 | +49348x | +
+ function(obj) obj@row_footnotes |
||
| 968 | +3447 |
- #' @inheritParams gen_args+ ) |
||
| 969 | +3448 |
- #'+ |
||
| 970 | +3449 |
- #' @return Various return values depending on the accessor called.+ #' @export |
||
| 971 | +3450 |
- #'+ #' @rdname int_methods |
||
| 972 | +3451 |
- #' @export+ setMethod( |
||
| 973 | +3452 |
- #' @rdname row_accessors+ "row_footnotes", "RowsVerticalSection", |
||
| 974 | -72x | +3453 | +1622x |
- setGeneric("obj_avar", function(obj) standardGeneric("obj_avar"))
+ function(obj) attr(obj, "row_footnotes", exact = TRUE) %||% list() |
| 975 | +3454 | ++ |
+ )+ |
+ |
| 3455 | ||||
| 976 | +3456 |
- #' @rdname row_accessors+ #' @export |
||
| 977 | +3457 |
- #' @exportMethod obj_avar+ #' @rdname ref_fnotes |
||
| 978 | -55x | +3458 | +65x |
- setMethod("obj_avar", "TableRow", function(obj) obj@var_analyzed)
+ setGeneric("row_footnotes<-", function(obj, value) standardGeneric("row_footnotes<-"))
|
| 979 | +3459 | |||
| 980 | +3460 |
- #' @rdname row_accessors+ #' @export |
||
| 981 | +3461 |
- #' @exportMethod obj_avar- |
- ||
| 982 | -17x | -
- setMethod("obj_avar", "ElementaryTable", function(obj) obj@var_analyzed)
+ #' @rdname int_methods |
||
| 983 | +3462 |
-
+ setMethod( |
||
| 984 | +3463 |
- #' @export+ "row_footnotes<-", "TableRow", |
||
| 985 | +3464 |
- #' @rdname row_accessors+ function(obj, value) {
|
||
| 986 | -67468x | +3465 | +65x |
- setGeneric("row_cells", function(obj) standardGeneric("row_cells"))
+ obj@row_footnotes <- make_ref_value(value) |
| 987 | -+ | |||
| 3466 | +65x |
-
+ obj |
||
| 988 | +3467 |
- #' @rdname row_accessors+ } |
||
| 989 | +3468 |
- #' @exportMethod row_cells- |
- ||
| 990 | -7393x | -
- setMethod("row_cells", "TableRow", function(obj) obj@leaf_value)
+ ) |
||
| 991 | +3469 | |||
| 992 | +3470 |
- #' @rdname row_accessors+ #' @export |
||
| 993 | -4034x | +|||
| 3471 | +
- setGeneric("row_cells<-", function(obj, value) standardGeneric("row_cells<-"))
+ #' @rdname int_methods |
|||
| 994 | +3472 |
-
+ setMethod( |
||
| 995 | +3473 |
- #' @rdname row_accessors+ "row_footnotes", "VTableTree", |
||
| 996 | +3474 |
- #' @exportMethod row_cells+ function(obj) {
|
||
| 997 | -+ | |||
| 3475 | +427x |
- setMethod("row_cells<-", "TableRow", function(obj, value) {
+ rws <- collect_leaves(obj, TRUE, TRUE) |
||
| 998 | -4034x | +3476 | +427x |
- obj@leaf_value <- value+ cells <- lapply(rws, row_footnotes) |
| 999 | -4034x | +3477 | +427x |
- obj+ cells |
| 1000 | +3478 |
- })+ } |
||
| 1001 | +3479 | ++ |
+ )+ |
+ |
| 3480 | ||||
| 1002 | +3481 |
#' @export |
||
| 1003 | +3482 |
- #' @rdname row_accessors+ #' @rdname ref_fnotes |
||
| 1004 | -2314x | +3483 | +202583x |
- setGeneric("row_values", function(obj) standardGeneric("row_values"))
+ setGeneric("cell_footnotes", function(obj) standardGeneric("cell_footnotes"))
|
| 1005 | +3484 | |||
| 1006 | +3485 |
- #' @rdname row_accessors+ #' @export |
||
| 1007 | +3486 |
- #' @exportMethod row_values- |
- ||
| 1008 | -522x | -
- setMethod("row_values", "TableRow", function(obj) rawvalues(obj@leaf_value))
+ #' @rdname int_methods |
||
| 1009 | +3487 |
-
+ setMethod( |
||
| 1010 | +3488 |
-
+ "cell_footnotes", "CellValue", |
||
| 1011 | -+ | |||
| 3489 | +162431x |
- #' @rdname row_accessors+ function(obj) attr(obj, "footnotes", exact = TRUE) %||% list() |
||
| 1012 | +3490 |
- #' @exportMethod row_values<-- |
- ||
| 1013 | -1218x | -
- setGeneric("row_values<-", function(obj, value) standardGeneric("row_values<-"))
+ ) |
||
| 1014 | +3491 | |||
| 1015 | +3492 |
- #' @rdname row_accessors+ #' @export |
||
| 1016 | +3493 |
- #' @exportMethod row_values<-+ #' @rdname int_methods |
||
| 1017 | +3494 |
setMethod( |
||
| 1018 | +3495 |
- "row_values<-", "TableRow",+ "cell_footnotes", "TableRow", |
||
| 1019 | +3496 |
- function(obj, value) {
+ function(obj) {
|
||
| 1020 | -1218x | +3497 | +35455x |
- obj@leaf_value <- lapply(value, rcell)+ ret <- lapply(row_cells(obj), cell_footnotes) |
| 1021 | -1218x | +3498 | +35455x |
- obj+ if (length(ret) != ncol(obj)) {
+ |
+
| 3499 | +144x | +
+ ret <- rep(ret, row_cspans(obj)) |
||
| 1022 | +3500 | ++ |
+ }+ |
+ |
| 3501 | +35455x | +
+ ret+ |
+ ||
| 3502 |
} |
|||
| 1023 | +3503 |
) |
||
| 1024 | +3504 | |||
| 1025 | +3505 |
- #' @rdname row_accessors+ #' @export |
||
| 1026 | +3506 |
- #' @exportMethod row_values<-+ #' @rdname int_methods |
||
| 1027 | +3507 |
setMethod( |
||
| 1028 | +3508 |
- "row_values<-", "LabelRow",+ "cell_footnotes", "LabelRow", |
||
| 1029 | +3509 |
- function(obj, value) {
+ function(obj) {
|
||
| 1030 | -! | +|||
| 3510 | +4270x |
- stop("LabelRows cannot have row values.")
+ rep(list(list()), ncol(obj)) |
||
| 1031 | +3511 |
} |
||
| 1032 | +3512 |
) |
||
| 1033 | +3513 | |||
| 1034 | +3514 |
- #' @rdname int_methods+ #' @export |
||
| 1035 | -941x | +|||
| 3515 | +
- setGeneric("spanned_values", function(obj) standardGeneric("spanned_values"))
+ #' @rdname int_methods |
|||
| 1036 | +3516 |
-
+ setMethod( |
||
| 1037 | +3517 |
- #' @rdname int_methods+ "cell_footnotes", "VTableTree", |
||
| 1038 | +3518 |
- setMethod(+ function(obj) {
|
||
| 1039 | -+ | |||
| 3519 | +427x |
- "spanned_values", "TableRow",+ rws <- collect_leaves(obj, TRUE, TRUE) |
||
| 1040 | -+ | |||
| 3520 | +427x |
- function(obj) {
+ cells <- lapply(rws, cell_footnotes) |
||
| 1041 | -941x | +3521 | +427x |
- rawvalues(spanned_cells(obj))+ do.call(rbind, cells) |
| 1042 | +3522 |
} |
||
| 1043 | +3523 |
) |
||
| 1044 | +3524 | |||
| 1045 | +3525 |
- #' @rdname int_methods+ #' @export |
||
| 1046 | +3526 |
- setMethod(+ #' @rdname ref_fnotes |
||
| 1047 | -+ | |||
| 3527 | +625x |
- "spanned_values", "LabelRow",+ setGeneric("cell_footnotes<-", function(obj, value) standardGeneric("cell_footnotes<-"))
|
||
| 1048 | +3528 |
- function(obj) {
+
|
||
| 1049 | -! | +|||
| 3529 | +
- rep(list(NULL), ncol(obj))+ #' @export |
|||
| 1050 | +3530 |
- }+ #' @rdname int_methods |
||
| 1051 | +3531 |
- )+ setMethod( |
||
| 1052 | +3532 |
-
+ "cell_footnotes<-", "CellValue", |
||
| 1053 | +3533 |
- #' @rdname int_methods+ function(obj, value) {
|
||
| 1054 | -941x | +3534 | +565x |
- setGeneric("spanned_cells", function(obj) standardGeneric("spanned_cells"))
+ attr(obj, "footnotes") <- make_ref_value(value)+ |
+
| 3535 | +565x | +
+ obj |
||
| 1055 | +3536 |
-
+ } |
||
| 1056 | +3537 |
- #' @rdname int_methods+ ) |
||
| 1057 | +3538 |
- setMethod(+ |
||
| 1058 | +3539 |
- "spanned_cells", "TableRow",+ .cfn_set_helper <- function(obj, value) {
+ |
+ ||
| 3540 | +60x | +
+ if (length(value) != ncol(obj)) {
+ |
+ ||
| 3541 | +! | +
+ stop("Did not get the right number of footnote ref values for cell_footnotes<- on a full row.")
|
||
| 1059 | +3542 |
- function(obj) {
+ } |
||
| 1060 | -941x | +|||
| 3543 | +
- sp <- row_cspans(obj)+ |
|||
| 1061 | -941x | +3544 | +60x |
- rvals <- row_cells(obj)+ row_cells(obj) <- mapply( |
| 1062 | -941x | +3545 | +60x |
- unlist(+ function(cell, fns) {
|
| 1063 | -941x | +3546 | +191x |
- mapply(function(v, s) rep(list(v), times = s),+ if (is.list(fns)) {
|
| 1064 | -941x | +3547 | +185x |
- v = rvals, s = sp+ cell_footnotes(cell) <- lapply(fns, RefFootnote) |
| 1065 | +3548 |
- ),+ } else {
|
||
| 1066 | -941x | +3549 | +6x |
- recursive = FALSE+ cell_footnotes(cell) <- list(RefFootnote(fns)) |
| 1067 | +3550 |
- )+ } |
||
| 1068 | -+ | |||
| 3551 | +191x |
- }+ cell |
||
| 1069 | +3552 |
- )+ },+ |
+ ||
| 3553 | +60x | +
+ cell = row_cells(obj),+ |
+ ||
| 3554 | +60x | +
+ fns = value, SIMPLIFY = FALSE |
||
| 1070 | +3555 |
-
+ )+ |
+ ||
| 3556 | +60x | +
+ obj |
||
| 1071 | +3557 |
- #' @rdname int_methods+ } |
||
| 1072 | +3558 |
- setMethod(+ |
||
| 1073 | +3559 |
- "spanned_cells", "LabelRow",+ #' @export |
||
| 1074 | +3560 |
- function(obj) {
+ #' @rdname int_methods |
||
| 1075 | -! | +|||
| 3561 | +
- rep(list(NULL), ncol(obj))+ setMethod("cell_footnotes<-", "DataRow",
|
|||
| 1076 | +3562 |
- }+ definition = .cfn_set_helper |
||
| 1077 | +3563 |
) |
||
| 1078 | +3564 | |||
| 1079 | +3565 |
- #' @rdname int_methods+ #' @export |
||
| 1080 | -3x | +|||
| 3566 | +
- setGeneric("spanned_values<-", function(obj, value) standardGeneric("spanned_values<-"))
+ #' @rdname int_methods |
|||
| 1081 | +3567 |
-
+ setMethod("cell_footnotes<-", "ContentRow",
|
||
| 1082 | +3568 |
- #' @rdname int_methods+ definition = .cfn_set_helper |
||
| 1083 | +3569 |
- setMethod(+ ) |
||
| 1084 | +3570 |
- "spanned_values<-", "TableRow",+ |
||
| 1085 | +3571 |
- function(obj, value) {
+ # Deprecated methods ---- |
||
| 1086 | -2x | +|||
| 3572 | +
- sp <- row_cspans(obj)+ |
|||
| 1087 | +3573 |
- ## this is 3 times too clever!!!- |
- ||
| 1088 | -2x | -
- valindices <- unlist(lapply(sp, function(x) c(TRUE, rep(FALSE, x - 1))))+ #' @export |
||
| 1089 | +3574 | - - | -||
| 1090 | -2x | -
- splvec <- cumsum(valindices)- |
- ||
| 1091 | -2x | -
- lapply(- |
- ||
| 1092 | -2x | -
- split(value, splvec),- |
- ||
| 1093 | -2x | -
- function(v) {
- |
- ||
| 1094 | -3x | -
- if (length(unique(v)) > 1) {
- |
- ||
| 1095 | -1x | -
- stop(- |
- ||
| 1096 | -1x | -
- "Got more than one unique value within a span, ",- |
- ||
| 1097 | -1x | -
- "new spanned values do not appear to match the ",- |
- ||
| 1098 | -1x | -
- "existing spanning pattern of the row (",
+ #' @rdname ref_fnotes |
||
| 1099 | -1x | +|||
| 3575 | +! |
- paste(sp, collapse = " "), ")"+ setGeneric("col_fnotes_here", function(obj) standardGeneric("col_fnotes_here"))
|
||
| 1100 | +3576 |
- )+ |
||
| 1101 | +3577 |
- }+ #' @export |
||
| 1102 | +3578 |
- }+ #' @rdname ref_fnotes |
||
| 1103 | +3579 |
- )- |
- ||
| 1104 | -1x | -
- rvals <- value[valindices]+ setMethod("col_fnotes_here", "ANY", function(obj) {
|
||
| 1105 | -+ | |||
| 3580 | +! |
-
+ lifecycle::deprecate_warn( |
||
| 1106 | -+ | |||
| 3581 | +! |
- ## rvals = lapply(split(value, splvec),+ when = "0.6.6", |
||
| 1107 | -+ | |||
| 3582 | +! |
- ## function(v) {
+ what = "col_fnotes_here()", |
||
| 1108 | -+ | |||
| 3583 | +! |
- ## if(length(v) == 1)+ with = "col_footnotes()" |
||
| 1109 | +3584 |
- ## return(v)+ ) |
||
| 1110 | -+ | |||
| 3585 | +! |
- ## stopifnot(length(unique(v)) == 1L)+ col_footnotes(obj) |
||
| 1111 | +3586 |
- ## rcell(unique(v), colspan<- length(v))+ }) |
||
| 1112 | +3587 |
- ## })+ |
||
| 1113 | +3588 |
- ## if(any(splvec > 1))+ #' @export |
||
| 1114 | +3589 |
- ## rvals <- lapply(rvals, function(x) x[[1]])- |
- ||
| 1115 | -1x | -
- row_values(obj) <- rvals- |
- ||
| 1116 | -1x | -
- obj+ #' @rdname ref_fnotes |
||
| 1117 | -+ | |||
| 3590 | +! |
- }+ setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-"))
|
||
| 1118 | +3591 |
- )+ |
||
| 1119 | +3592 |
-
+ #' @export |
||
| 1120 | +3593 |
#' @rdname int_methods |
||
| 1121 | +3594 |
- setMethod(+ setMethod("col_fnotes_here<-", "ANY", function(obj, value) {
|
||
| 1122 | -+ | |||
| 3595 | +! |
- "spanned_values<-", "LabelRow",+ lifecycle::deprecate_warn( |
||
| 1123 | -+ | |||
| 3596 | +! |
- function(obj, value) {
+ when = "0.6.6", |
||
| 1124 | -1x | +|||
| 3597 | +! |
- if (!is.null(value)) {
+ what = I("col_fnotes_here()<-"),
|
||
| 1125 | -1x | +|||
| 3598 | +! |
- stop("Label rows can't have non-null cell values, got", value)
+ with = I("col_footnotes()<-")
|
||
| 1126 | +3599 |
- }+ ) |
||
| 1127 | +3600 | ! |
- obj+ col_footnotes(obj) <- value |
|
| 1128 | +3601 |
- }+ }) |
||
| 1129 | +3602 |
- )+ |
||
| 1130 | +3603 |
-
+ #' @export |
||
| 1131 | +3604 |
- ### Format manipulation+ #' @rdname ref_fnotes |
||
| 1132 | -+ | |||
| 3605 | +16828x |
- ### obj_format<- is not recursive+ setGeneric("col_footnotes", function(obj) standardGeneric("col_footnotes"))
|
||
| 1133 | +3606 |
- ## TODO export these?+ |
||
| 1134 | +3607 |
- #' @rdname formatters_methods+ #' @export |
||
| 1135 | +3608 |
- #' @export+ #' @rdname int_methods |
||
| 1136 | -6348x | +3609 | +1423x |
- setMethod("obj_format", "VTableNodeInfo", function(obj) obj@format)
+ setMethod("col_footnotes", "LayoutColTree", function(obj) obj@col_footnotes)
|
| 1137 | +3610 | |||
| 1138 | +3611 |
- #' @rdname formatters_methods+ #' @export |
||
| 1139 | +3612 |
- #' @export+ #' @rdname int_methods |
||
| 1140 | -105881x | +3613 | +14979x |
- setMethod("obj_format", "CellValue", function(obj) attr(obj, "format", exact = TRUE))
+ setMethod("col_footnotes", "LayoutColLeaf", function(obj) obj@col_footnotes)
|
| 1141 | +3614 | |||
| 1142 | +3615 |
- #' @rdname formatters_methods+ #' @export |
||
| 1143 | +3616 |
- #' @export+ #' @rdname ref_fnotes |
||
| 1144 | -2243x | +3617 | +2049x |
- setMethod("obj_format", "Split", function(obj) obj@split_format)
+ setGeneric("col_footnotes<-", function(obj, value) standardGeneric("col_footnotes<-"))
|
| 1145 | +3618 | |||
| 1146 | +3619 |
- #' @rdname formatters_methods+ #' @export |
||
| 1147 | +3620 |
- #' @export+ #' @rdname int_methods |
||
| 1148 | +3621 |
- setMethod("obj_format<-", "VTableNodeInfo", function(obj, value) {
+ setMethod("col_footnotes<-", "LayoutColTree", function(obj, value) {
|
||
| 1149 | -1647x | +3622 | +763x |
- obj@format <- value+ obj@col_footnotes <- make_ref_value(value) |
| 1150 | -1647x | +3623 | +763x |
obj |
| 1151 | +3624 |
}) |
||
| 1152 | +3625 | |||
| 1153 | +3626 |
- #' @rdname formatters_methods+ #' @export |
||
| 1154 | +3627 |
- #' @export+ #' @rdname int_methods |
||
| 1155 | +3628 |
- setMethod("obj_format<-", "Split", function(obj, value) {
+ setMethod("col_footnotes<-", "LayoutColLeaf", function(obj, value) {
|
||
| 1156 | -1x | +3629 | +1286x |
- obj@split_format <- value+ obj@col_footnotes <- make_ref_value(value) |
| 1157 | -1x | +3630 | +1286x |
obj |
| 1158 | +3631 |
}) |
||
| 1159 | +3632 | |||
| 1160 | +3633 |
- #' @rdname formatters_methods+ #' @export |
||
| 1161 | +3634 |
- #' @export+ #' @rdname int_methods |
||
| 1162 | +3635 |
- setMethod("obj_format<-", "CellValue", function(obj, value) {
+ setMethod(+ |
+ ||
| 3636 | ++ |
+ "col_footnotes", "VTableTree",+ |
+ ||
| 3637 | ++ |
+ function(obj) {
|
||
| 1163 | -1173x | +3638 | +426x |
- attr(obj, "format") <- value+ ctree <- coltree(obj) |
| 1164 | -1173x | +3639 | +426x |
- obj+ cols <- tree_children(ctree) |
| 1165 | -+ | |||
| 3640 | +426x |
- })+ while (all(sapply(cols, is, "LayoutColTree"))) {
|
||
| 1166 | -+ | |||
| 3641 | +140x |
-
+ cols <- lapply(cols, tree_children) |
||
| 1167 | -+ | |||
| 3642 | +140x |
- #' @rdname int_methods+ cols <- unlist(cols, recursive = FALSE) |
||
| 1168 | +3643 |
- #' @export+ } |
||
| 1169 | -+ | |||
| 3644 | +426x |
- setMethod("obj_na_str<-", "CellValue", function(obj, value) {
+ all_col_fnotes <- lapply(cols, col_footnotes) |
||
| 1170 | -4098x | +3645 | +426x |
- attr(obj, "format_na_str") <- value+ if (is.null(unlist(all_col_fnotes))) {
|
| 1171 | -4098x | +3646 | +421x |
- obj+ return(NULL) |
| 1172 | +3647 |
- })+ } |
||
| 1173 | +3648 | |||
| 1174 | -+ | |||
| 3649 | +5x |
- #' @rdname int_methods+ return(all_col_fnotes) |
||
| 1175 | +3650 |
- #' @export+ } |
||
| 1176 | +3651 |
- setMethod("obj_na_str<-", "VTableNodeInfo", function(obj, value) {
+ ) |
||
| 1177 | -26x | +|||
| 3652 | +
- obj@na_str <- value+ |
|||
| 1178 | -26x | +|||
| 3653 | +
- obj+ #' @export |
|||
| 1179 | +3654 |
- })+ #' @rdname ref_fnotes+ |
+ ||
| 3655 | +594x | +
+ setGeneric("ref_index", function(obj) standardGeneric("ref_index"))
|
||
| 1180 | +3656 | |||
| 1181 | +3657 |
- #' @rdname int_methods+ #' @export |
||
| 1182 | +3658 |
- #' @export+ #' @rdname int_methods |
||
| 1183 | +3659 |
- setMethod("obj_na_str<-", "Split", function(obj, value) {
+ setMethod( |
||
| 1184 | -! | +|||
| 3660 | +
- obj@split_na_str <- value+ "ref_index", "RefFootnote", |
|||
| 1185 | -! | +|||
| 3661 | +594x |
- obj+ function(obj) obj@index |
||
| 1186 | +3662 |
- })+ ) |
||
| 1187 | +3663 | |||
| 1188 | +3664 |
- #' @rdname int_methods+ #' @export |
||
| 1189 | +3665 |
- #' @export+ #' @rdname ref_fnotes |
||
| 1190 | -27752x | +3666 | +71x |
- setMethod("obj_na_str", "VTableNodeInfo", function(obj) obj@na_str)
+ setGeneric("ref_index<-", function(obj, value) standardGeneric("ref_index<-"))
|
| 1191 | +3667 | |||
| 1192 | +3668 |
- #' @rdname formatters_methods+ #' @export |
||
| 1193 | +3669 |
- #' @export+ #' @rdname int_methods |
||
| 1194 | -1142x | +|||
| 3670 | +
- setMethod("obj_na_str", "Split", function(obj) obj@split_na_str)
+ setMethod( |
|||
| 1195 | +3671 |
-
+ "ref_index<-", "RefFootnote", |
||
| 1196 | +3672 |
- .no_na_str <- function(x) {
+ function(obj, value) {
|
||
| 1197 | -14933x | +3673 | +71x |
- if (!is.character(x)) {
+ obj@index <- value |
| 1198 | -6049x | +3674 | +71x |
- x <- obj_na_str(x)+ obj |
| 1199 | +3675 |
} |
||
| 1200 | -14933x | -
- length(x) == 0 || all(is.na(x))- |
- ||
| 1201 | +3676 |
- }+ ) |
||
| 1202 | +3677 | |||
| 1203 | +3678 |
- #' @rdname int_methods+ #' @export |
||
| 1204 | +3679 |
- setGeneric("set_format_recursive", function(obj, format, na_str, override = FALSE) {
+ #' @rdname ref_fnotes |
||
| 1205 | -8877x | -
- standardGeneric("set_format_recursive")
- |
- ||
| 1206 | -+ | 3680 | +523x |
- })+ setGeneric("ref_symbol", function(obj) standardGeneric("ref_symbol"))
|
| 1207 | +3681 | |||
| 1208 | -- |
- #' @param override (`flag`)\cr whether to override attribute.- |
- ||
| 1209 | +3682 |
- #'+ #' @export |
||
| 1210 | +3683 |
#' @rdname int_methods |
||
| 1211 | +3684 |
setMethod( |
||
| 1212 | -- |
- "set_format_recursive", "TableRow",- |
- ||
| 1213 | +3685 |
- function(obj, format, na_str, override = FALSE) {
- |
- ||
| 1214 | -1048x | -
- if (is.null(format) && .no_na_str(na_str)) {
+ "ref_symbol", "RefFootnote", |
||
| 1215 | -524x | +3686 | +523x |
- return(obj)+ function(obj) obj@symbol |
| 1216 | +3687 |
- }+ ) |
||
| 1217 | +3688 | |||
| 1218 | -524x | -
- if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
- |
- ||
| 1219 | -524x | -
- obj_format(obj) <- format- |
- ||
| 1220 | +3689 |
- }+ #' @export |
||
| 1221 | -524x | +|||
| 3690 | +
- if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
+ #' @rdname ref_fnotes |
|||
| 1222 | +3691 | ! |
- obj_na_str(obj) <- na_str+ setGeneric("ref_symbol<-", function(obj, value) standardGeneric("ref_symbol<-"))
|
|
| 1223 | +3692 |
- }+ |
||
| 1224 | -524x | +|||
| 3693 | +
- lcells <- row_cells(obj)+ #' @export |
|||
| 1225 | -524x | +|||
| 3694 | +
- lvals <- lapply(lcells, function(x) {
+ #' @rdname int_methods |
|||
| 1226 | -1879x | +|||
| 3695 | +
- if (!is.null(x) && (override || is.null(obj_format(x)))) {
+ setMethod( |
|||
| 1227 | -53x | +|||
| 3696 | +
- obj_format(x) <- obj_format(obj)+ "ref_symbol<-", "RefFootnote", |
|||
| 1228 | +3697 |
- }+ function(obj, value) {
|
||
| 1229 | -1879x | +|||
| 3698 | +! |
- if (!is.null(x) && (override || .no_na_str(x))) {
+ obj@symbol <- value |
||
| 1230 | -1879x | +|||
| 3699 | +! |
- obj_na_str(x) <- obj_na_str(obj)+ obj |
||
| 1231 | +3700 |
- }+ } |
||
| 1232 | -1879x | +|||
| 3701 | +
- x+ ) |
|||
| 1233 | +3702 |
- })+ |
||
| 1234 | -524x | +|||
| 3703 | +
- row_values(obj) <- lvals+ #' @export |
|||
| 1235 | -524x | +|||
| 3704 | +
- obj+ #' @rdname ref_fnotes |
|||
| 1236 | -+ | |||
| 3705 | +515x |
- }+ setGeneric("ref_msg", function(obj) standardGeneric("ref_msg"))
|
||
| 1237 | +3706 |
- )+ |
||
| 1238 | +3707 |
-
+ #' @export |
||
| 1239 | +3708 |
#' @rdname int_methods |
||
| 1240 | +3709 |
setMethod( |
||
| 1241 | +3710 |
- "set_format_recursive", "LabelRow",+ "ref_msg", "RefFootnote", |
||
| 1242 | -11x | +3711 | +515x |
- function(obj, format, override = FALSE) obj+ function(obj) obj@value |
| 1243 | +3712 |
) |
||
| 1244 | +3713 | |||
| 1245 | -+ | |||
| 3714 | +20x |
- setMethod(+ setGeneric(".fnote_set_inner<-", function(ttrp, colpath, value) standardGeneric(".fnote_set_inner<-"))
|
||
| 1246 | +3715 |
- "set_format_recursive", "VTableTree",+ |
||
| 1247 | +3716 |
- function(obj, format, na_str, override = FALSE) {
- |
- ||
| 1248 | -1673x | -
- force(format)- |
- ||
| 1249 | -1673x | -
- if (is.null(format) && .no_na_str(na_str)) {
- |
- ||
| 1250 | -1666x | -
- return(obj)+ setMethod( |
||
| 1251 | +3717 |
- }+ ".fnote_set_inner<-", c("TableRow", "NULL"),
|
||
| 1252 | +3718 |
-
+ function(ttrp, colpath, value) {
|
||
| 1253 | +3719 | 7x |
- if ((is.null(obj_format(obj)) && !is.null(format)) || override) {
+ row_footnotes(ttrp) <- value |
|
| 1254 | +3720 | 7x |
- obj_format(obj) <- format+ ttrp |
|
| 1255 | +3721 |
- }- |
- ||
| 1256 | -7x | -
- if ((.no_na_str(obj) && !.no_na_str(na_str)) || override) {
- |
- ||
| 1257 | -! | -
- obj_na_str(obj) <- na_str+ } |
||
| 1258 | +3722 |
- }+ ) |
||
| 1259 | +3723 | |||
| 1260 | -7x | -
- kids <- tree_children(obj)- |
- ||
| 1261 | -7x | -
- kids <- lapply(kids, function(x, format2, na_str2, oride) {
- |
- ||
| 1262 | -33x | +|||
| 3724 | +
- set_format_recursive(x,+ setMethod( |
|||
| 1263 | -33x | +|||
| 3725 | +
- format = format2, na_str = na_str2, override = oride+ ".fnote_set_inner<-", c("TableRow", "character"),
|
|||
| 1264 | +3726 |
- )+ function(ttrp, colpath, value) {
|
||
| 1265 | -+ | |||
| 3727 | +6x |
- },+ ind <- .path_to_pos(path = colpath, tt = ttrp, cols = TRUE) |
||
| 1266 | -7x | +3728 | +6x |
- format2 = obj_format(obj), na_str2 = obj_na_str(obj), oride = override+ cfns <- cell_footnotes(ttrp) |
| 1267 | -+ | |||
| 3729 | +6x |
- )+ cfns[[ind]] <- value |
||
| 1268 | -7x | +3730 | +6x |
- tree_children(obj) <- kids+ cell_footnotes(ttrp) <- cfns |
| 1269 | -7x | +3731 | +6x |
- obj+ ttrp |
| 1270 | +3732 |
} |
||
| 1271 | +3733 |
) |
||
| 1272 | +3734 | |||
| 1273 | +3735 |
- #' @rdname int_methods+ setMethod( |
||
| 1274 | -1833x | +|||
| 3736 | +
- setGeneric("content_format", function(obj) standardGeneric("content_format"))
+ ".fnote_set_inner<-", c("InstantiatedColumnInfo", "character"),
|
|||
| 1275 | +3737 |
-
+ function(ttrp, colpath, value) {
|
||
| 1276 | -+ | |||
| 3738 | +1x |
- #' @rdname int_methods+ ctree <- col_fnotes_at_path(coltree(ttrp), colpath, fnotes = value) |
||
| 1277 | -1833x | +3739 | +1x |
- setMethod("content_format", "Split", function(obj) obj@content_format)
+ coltree(ttrp) <- ctree+ |
+
| 3740 | +1x | +
+ ttrp |
||
| 1278 | +3741 |
-
+ } |
||
| 1279 | +3742 |
- #' @rdname int_methods+ ) |
||
| 1280 | -114x | +|||
| 3743 | +
- setGeneric("content_format<-", function(obj, value) standardGeneric("content_format<-"))
+
|
|||
| 1281 | +3744 |
-
+ setMethod( |
||
| 1282 | +3745 |
- #' @rdname int_methods+ ".fnote_set_inner<-", c("VTableTree", "ANY"),
|
||
| 1283 | +3746 |
- setMethod("content_format<-", "Split", function(obj, value) {
+ function(ttrp, colpath, value) {
|
||
| 1284 | -114x | +3747 | +6x |
- obj@content_format <- value+ if (labelrow_visible(ttrp) && !is.null(value)) {
|
| 1285 | -114x | +3748 | +2x |
- obj+ lblrw <- tt_labelrow(ttrp) |
| 1286 | -+ | |||
| 3749 | +2x |
- })+ row_footnotes(lblrw) <- value |
||
| 1287 | -+ | |||
| 3750 | +2x |
-
+ tt_labelrow(ttrp) <- lblrw |
||
| 1288 | -+ | |||
| 3751 | +4x |
- #' @rdname int_methods+ } else if (NROW(content_table(ttrp)) == 1L) {
|
||
| 1289 | -1833x | +3752 | +4x |
- setGeneric("content_na_str", function(obj) standardGeneric("content_na_str"))
+ ctbl <- content_table(ttrp) |
| 1290 | -+ | |||
| 3753 | +4x |
-
+ pth <- make_row_df(ctbl)$path[[1]] |
||
| 1291 | -+ | |||
| 3754 | +4x |
- #' @rdname int_methods+ fnotes_at_path(ctbl, pth, colpath) <- value |
||
| 1292 | -1833x | +3755 | +4x |
- setMethod("content_na_str", "Split", function(obj) obj@content_na_str)
+ content_table(ttrp) <- ctbl |
| 1293 | +3756 |
-
+ } else {
|
||
| 1294 | +3757 |
- #' @rdname int_methods+ stop("an error occurred. this shouldn't happen. please contact the maintainer") # nocov
|
||
| 1295 | -! | +|||
| 3758 | +
- setGeneric("content_na_str<-", function(obj, value) standardGeneric("content_na_str<-"))
+ } |
|||
| 1296 | -+ | |||
| 3759 | +6x |
-
+ ttrp |
||
| 1297 | +3760 |
- #' @rdname int_methods+ } |
||
| 1298 | +3761 |
- setMethod("content_na_str<-", "Split", function(obj, value) {
+ ) |
||
| 1299 | -! | +|||
| 3762 | +
- obj@content_na_str <- value+ |
|||
| 1300 | -! | +|||
| 3763 | +
- obj+ #' @param rowpath (`character` or `NULL`)\cr path within row structure. `NULL` indicates the footnote should |
|||
| 1301 | +3764 |
- })+ #' go on the column rather than cell. |
||
| 1302 | +3765 |
-
+ #' @param colpath (`character` or `NULL`)\cr path within column structure. `NULL` indicates footnote should go |
||
| 1303 | +3766 |
- #' Value formats+ #' on the row rather than cell. |
||
| 1304 | +3767 |
- #'+ #' @param reset_idx (`flag`)\cr whether the numbering for referential footnotes should be immediately |
||
| 1305 | +3768 |
- #' Returns a matrix of formats for the cells in a table.+ #' recalculated. Defaults to `TRUE`. |
||
| 1306 | +3769 |
#' |
||
| 1307 | +3770 |
- #' @param obj (`VTableTree` or `TableRow`)\cr a table or row object.+ #' @examples |
||
| 1308 | +3771 |
- #' @param default (`string`, `function`, or `list`)\cr default format.+ #' # How to add referencial footnotes after having created a table |
||
| 1309 | +3772 |
- #'+ #' lyt <- basic_table() %>% |
||
| 1310 | +3773 |
- #' @return Matrix (storage mode list) containing the effective format for each cell position in the table+ #' split_rows_by("SEX", page_by = TRUE) %>%
|
||
| 1311 | +3774 |
- #' (including 'virtual' cells implied by label rows, whose formats are always `NULL`).+ #' analyze("AGE")
|
||
| 1312 | +3775 |
#' |
||
| 1313 | +3776 |
- #' @seealso [table_shell()] and [table_shell_str()] for information on the table format structure.+ #' tbl <- build_table(lyt, DM) |
||
| 1314 | +3777 |
- #'+ #' tbl <- trim_rows(tbl) |
||
| 1315 | +3778 |
- #' @examples+ #' # Check the row and col structure to add precise references |
||
| 1316 | +3779 |
- #' lyt <- basic_table() %>%+ #' # row_paths(tbl) |
||
| 1317 | +3780 |
- #' split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
+ #' # col_paths(t) |
||
| 1318 | +3781 |
- #' analyze("AGE")
+ #' # row_paths_summary(tbl) |
||
| 1319 | +3782 |
- #'+ #' # col_paths_summary(tbl) |
||
| 1320 | +3783 |
- #' tbl <- build_table(lyt, DM)+ #' |
||
| 1321 | +3784 |
- #' value_formats(tbl)+ #' # Add the citation numbers on the table and relative references in the footnotes |
||
| 1322 | +3785 |
- #'+ #' fnotes_at_path(tbl, rowpath = c("SEX", "F", "AGE", "Mean")) <- "Famous paper 1"
|
||
| 1323 | +3786 |
- #' @export+ #' fnotes_at_path(tbl, rowpath = c("SEX", "UNDIFFERENTIATED")) <- "Unfamous paper 2"
|
||
| 1324 | -1123x | +|||
| 3787 | +
- setGeneric("value_formats", function(obj, default = obj_format(obj)) standardGeneric("value_formats"))
+ #' # tbl |
|||
| 1325 | +3788 |
-
+ #' |
||
| 1326 | +3789 |
- #' @rdname value_formats+ #' @seealso [row_paths()], [col_paths()], [row_paths_summary()], [col_paths_summary()] |
||
| 1327 | +3790 |
- setMethod(+ #' |
||
| 1328 | +3791 |
- "value_formats", "ANY",+ #' @export |
||
| 1329 | +3792 |
- function(obj, default) {
+ #' @rdname ref_fnotes |
||
| 1330 | -762x | +|||
| 3793 | +
- obj_format(obj) %||% default+ setGeneric("fnotes_at_path<-", function(obj,
|
|||
| 1331 | +3794 |
- }+ rowpath = NULL, |
||
| 1332 | +3795 |
- )+ colpath = NULL, |
||
| 1333 | +3796 |
-
+ reset_idx = TRUE, |
||
| 1334 | +3797 |
- #' @rdname value_formats+ value) {
+ |
+ ||
| 3798 | +20x | +
+ standardGeneric("fnotes_at_path<-")
|
||
| 1335 | +3799 |
- setMethod(+ }) |
||
| 1336 | +3800 |
- "value_formats", "TableRow",+ |
||
| 1337 | +3801 |
- function(obj, default) {
+ ## non-null rowpath, null or non-null colpath |
||
| 1338 | -245x | +|||
| 3802 | +
- if (!is.null(obj_format(obj))) {
+ #' @inheritParams fnotes_at_path<- |
|||
| 1339 | -215x | +|||
| 3803 | +
- default <- obj_format(obj)+ #' |
|||
| 1340 | +3804 |
- }+ #' @export |
||
| 1341 | -245x | +|||
| 3805 | +
- formats <- lapply(row_cells(obj), function(x) value_formats(x) %||% default)+ #' @rdname int_methods |
|||
| 1342 | -245x | +|||
| 3806 | +
- formats+ setMethod( |
|||
| 1343 | +3807 |
- }+ "fnotes_at_path<-", c("VTableTree", "character"),
|
||
| 1344 | +3808 |
- )+ function(obj, |
||
| 1345 | +3809 |
-
+ rowpath = NULL, |
||
| 1346 | +3810 |
- #' @rdname value_formats+ colpath = NULL, |
||
| 1347 | +3811 |
- setMethod(+ reset_idx = TRUE, |
||
| 1348 | +3812 |
- "value_formats", "LabelRow",+ value) {
+ |
+ ||
| 3813 | +19x | +
+ rw <- tt_at_path(obj, rowpath)+ |
+ ||
| 3814 | +19x | +
+ .fnote_set_inner(rw, colpath) <- value+ |
+ ||
| 3815 | +19x | +
+ tt_at_path(obj, rowpath) <- rw+ |
+ ||
| 3816 | +19x | +
+ if (reset_idx) {
+ |
+ ||
| 3817 | +19x | +
+ obj <- update_ref_indexing(obj) |
||
| 1349 | +3818 |
- function(obj, default) {
+ } |
||
| 1350 | -102x | +3819 | +19x |
- rep(list(NULL), ncol(obj))+ obj |
| 1351 | +3820 |
} |
||
| 1352 | +3821 |
) |
||
| 1353 | +3822 | |||
| 1354 | +3823 |
- #' @rdname value_formats+ #' @export |
||
| 1355 | +3824 |
- setMethod(+ #' @rdname int_methods |
||
| 1356 | +3825 |
- "value_formats", "VTableTree",+ setMethod( |
||
| 1357 | +3826 |
- function(obj, default) {
+ "fnotes_at_path<-", c("VTableTree", "NULL"),
|
||
| 1358 | -14x | +|||
| 3827 | +
- if (!is.null(obj_format(obj))) {
+ function(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE, value) {
|
|||
| 1359 | -! | +|||
| 3828 | +1x |
- default <- obj_format(obj)+ cinfo <- col_info(obj) |
||
| 1360 | -+ | |||
| 3829 | +1x |
- }+ .fnote_set_inner(cinfo, colpath) <- value |
||
| 1361 | -14x | +3830 | +1x |
- rws <- collect_leaves(obj, TRUE, TRUE)+ col_info(obj) <- cinfo |
| 1362 | -14x | +3831 | +1x |
- formatrws <- lapply(rws, value_formats, default = default)+ if (reset_idx) {
|
| 1363 | -14x | +3832 | +1x |
- mat <- do.call(rbind, formatrws)+ obj <- update_ref_indexing(obj) |
| 1364 | -14x | +|||
| 3833 | +
- row.names(mat) <- row.names(obj)+ } |
|||
| 1365 | -14x | +3834 | +1x |
- mat+ obj |
| 1366 | +3835 |
} |
||
| 1367 | +3836 |
) |
||
| 1368 | +3837 | |||
| 1369 | -+ | |||
| 3838 | +2930x |
- ### Collect all leaves of a current tree+ setGeneric("has_force_pag", function(obj) standardGeneric("has_force_pag"))
|
||
| 1370 | +3839 |
- ### This is a workhorse function in various+ |
||
| 1371 | -+ | |||
| 3840 | +349x |
- ### places+ setMethod("has_force_pag", "TableTree", function(obj) !is.na(ptitle_prefix(obj)))
|
||
| 1372 | +3841 |
- ### NB this is written generally enought o+ |
||
| 1373 | -+ | |||
| 3842 | +1615x |
- ### be used on all tree-based structures in the+ setMethod("has_force_pag", "Split", function(obj) !is.na(ptitle_prefix(obj)))
|
||
| 1374 | +3843 |
- ### framework.+ + |
+ ||
| 3844 | +914x | +
+ setMethod("has_force_pag", "VTableNodeInfo", function(obj) FALSE)
|
||
| 1375 | +3845 | |||
| 1376 | -+ | |||
| 3846 | +2434x |
- #' Collect leaves of a `TableTree`+ setGeneric("ptitle_prefix", function(obj) standardGeneric("ptitle_prefix"))
|
||
| 1377 | +3847 |
- #'+ |
||
| 1378 | -+ | |||
| 3848 | +357x |
- #' @inheritParams gen_args+ setMethod("ptitle_prefix", "TableTree", function(obj) obj@page_title_prefix)
|
||
| 1379 | +3849 |
- #' @param incl.cont (`flag`)\cr whether to include rows from content tables within the tree. Defaults to `TRUE`.+ |
||
| 1380 | -+ | |||
| 3850 | +2025x |
- #' @param add.labrows (`flag`)\cr whether to include label rows. Defaults to `FALSE`.+ setMethod("ptitle_prefix", "Split", function(obj) obj@page_title_prefix)
|
||
| 1381 | +3851 |
- #'+ |
||
| 1382 | -+ | |||
| 3852 | +! |
- #' @return A list of `TableRow` objects for all rows in the table.+ setMethod("ptitle_prefix", "ANY", function(obj) NULL)
|
||
| 1383 | +3853 |
- #'+ |
||
| 1384 | -+ | |||
| 3854 | +344x |
- #' @export+ setMethod("page_titles", "VTableTree", function(obj) obj@page_titles)
|
||
| 1385 | +3855 |
- setGeneric("collect_leaves",
+
|
||
| 1386 | +3856 |
- function(tt, incl.cont = TRUE, add.labrows = FALSE) {
+ setMethod("page_titles<-", "VTableTree", function(obj, value) {
|
||
| 1387 | -106796x | +3857 | +19x |
- standardGeneric("collect_leaves")
+ obj@page_titles <- value+ |
+
| 3858 | +19x | +
+ obj |
||
| 1388 | +3859 |
- },+ }) |
||
| 1389 | +3860 |
- signature = "tt"+ |
||
| 1390 | +3861 |
- )+ ## Horizontal separator -------------------------------------------------------- |
||
| 1391 | +3862 | |||
| 1392 | +3863 |
- #' @inheritParams collect_leaves+ #' Access or recursively set header-body separator for tables |
||
| 1393 | +3864 |
#' |
||
| 1394 | +3865 |
- #' @rdname int_methods+ #' @inheritParams gen_args |
||
| 1395 | +3866 |
- #' @exportMethod collect_leaves+ #' @param value (`string`)\cr string to use as new header/body separator. |
||
| 1396 | +3867 |
- setMethod(+ #' |
||
| 1397 | +3868 |
- "collect_leaves", "TableTree",+ #' @return |
||
| 1398 | +3869 |
- function(tt, incl.cont = TRUE, add.labrows = FALSE) {
+ #' * `horizontal_sep` returns the string acting as the header separator. |
||
| 1399 | -23460x | +|||
| 3870 | +
- ret <- c(+ #' * `horizontal_sep<-` returns `obj`, with the new header separator applied recursively to it and all its |
|||
| 1400 | -23460x | +|||
| 3871 | +
- if (add.labrows && labelrow_visible(tt)) {
+ #' subtables. |
|||
| 1401 | -9684x | +|||
| 3872 | +
- tt_labelrow(tt)+ #' |
|||
| 1402 | +3873 |
- },+ #' @export |
||
| 1403 | -23460x | +3874 | +345x |
- if (incl.cont) {
+ setGeneric("horizontal_sep", function(obj) standardGeneric("horizontal_sep"))
|
| 1404 | -23460x | +|||
| 3875 | +
- tree_children(content_table(tt))+ |
|||
| 1405 | +3876 |
- },+ #' @rdname horizontal_sep |
||
| 1406 | -23460x | +|||
| 3877 | +
- lapply(tree_children(tt),+ #' @export |
|||
| 1407 | -23460x | +|||
| 3878 | +
- collect_leaves,+ setMethod(+ |
+ |||
| 3879 | ++ |
+ "horizontal_sep", "VTableTree", |
||
| 1408 | -23460x | +3880 | +345x |
- incl.cont = incl.cont, add.labrows = add.labrows+ function(obj) obj@horizontal_sep |
| 1409 | +3881 |
- )+ ) |
||
| 1410 | +3882 |
- )+ |
||
| 1411 | -23460x | +|||
| 3883 | +
- unlist(ret, recursive = TRUE)+ #' @rdname horizontal_sep |
|||
| 1412 | +3884 |
- }+ #' @export |
||
| 1413 | -+ | |||
| 3885 | +24408x |
- )+ setGeneric("horizontal_sep<-", function(obj, value) standardGeneric("horizontal_sep<-"))
|
||
| 1414 | +3886 | |||
| 1415 | +3887 |
- #' @rdname int_methods+ #' @rdname horizontal_sep |
||
| 1416 | +3888 |
- #' @exportMethod collect_leaves+ #' @export |
||
| 1417 | +3889 |
setMethod( |
||
| 1418 | +3890 |
- "collect_leaves", "ElementaryTable",+ "horizontal_sep<-", "VTableTree", |
||
| 1419 | +3891 |
- function(tt, incl.cont = TRUE, add.labrows = FALSE) {
+ function(obj, value) {
|
||
| 1420 | -54071x | +3892 | +13527x |
- ret <- tree_children(tt)+ cont <- content_table(obj) |
| 1421 | -54071x | +3893 | +13527x |
- if (add.labrows && labelrow_visible(tt)) {
+ if (NROW(cont) > 0) {
|
| 1422 | -10488x | -
- ret <- c(tt_labelrow(tt), ret)- |
- ||
| 1423 | -+ | 3894 | +1926x |
- }+ horizontal_sep(cont) <- value |
| 1424 | -54071x | -
- ret- |
- ||
| 1425 | -+ | 3895 | +1926x |
- }+ content_table(obj) <- cont |
| 1426 | +3896 |
- )+ } |
||
| 1427 | +3897 | |||
| 1428 | -+ | |||
| 3898 | +13527x |
- #' @rdname int_methods+ kids <- lapply(tree_children(obj), |
||
| 1429 | -+ | |||
| 3899 | +13527x |
- #' @exportMethod collect_leaves+ `horizontal_sep<-`, |
||
| 1430 | -+ | |||
| 3900 | +13527x |
- setMethod(+ value = value |
||
| 1431 | +3901 |
- "collect_leaves", "VTree",+ ) |
||
| 1432 | +3902 |
- function(tt, incl.cont, add.labrows) {
- |
- ||
| 1433 | -! | -
- ret <- lapply(- |
- ||
| 1434 | -! | -
- tree_children(tt),+ |
||
| 1435 | -! | +|||
| 3903 | +13527x |
- collect_leaves+ tree_children(obj) <- kids |
||
| 1436 | -+ | |||
| 3904 | +13527x |
- )+ obj@horizontal_sep <- value |
||
| 1437 | -! | +|||
| 3905 | +13527x |
- unlist(ret, recursive = TRUE)+ obj |
||
| 1438 | +3906 |
} |
||
| 1439 | +3907 |
) |
||
| 1440 | +3908 | |||
| 1441 | +3909 |
- #' @rdname int_methods+ #' @rdname horizontal_sep |
||
| 1442 | +3910 |
- #' @exportMethod collect_leaves+ #' @export |
||
| 1443 | +3911 |
setMethod( |
||
| 1444 | -- |
- "collect_leaves", "VLeaf",- |
- ||
| 1445 | +3912 |
- function(tt, incl.cont, add.labrows) {
+ "horizontal_sep<-", "TableRow", |
||
| 1446 | -686x | +3913 | +10881x |
- list(tt)+ function(obj, value) obj |
| 1447 | +3914 |
- }+ ) |
||
| 1448 | +3915 |
- )+ |
||
| 1449 | +3916 |
-
+ ## Section dividers ------------------------------------------------------------ |
||
| 1450 | +3917 |
- #' @rdname int_methods+ |
||
| 1451 | +3918 |
- #' @exportMethod collect_leaves+ # Used for splits |
||
| 1452 | -+ | |||
| 3919 | +1680x |
- setMethod(+ setGeneric("spl_section_div", function(obj) standardGeneric("spl_section_div"))
|
||
| 1453 | +3920 |
- "collect_leaves", "NULL",+ |
||
| 1454 | +3921 |
- function(tt, incl.cont, add.labrows) {
+ setMethod( |
||
| 1455 | -! | +|||
| 3922 | +
- list()+ "spl_section_div", "Split", |
|||
| 1456 | -+ | |||
| 3923 | +1680x |
- }+ function(obj) obj@child_section_div |
||
| 1457 | +3924 |
) |
||
| 1458 | +3925 | |||
| 1459 | -+ | |||
| 3926 | +! |
- #' @rdname int_methods+ setGeneric("spl_section_div<-", function(obj, value) standardGeneric("spl_section_div<-"))
|
||
| 1460 | +3927 |
- #' @exportMethod collect_leaves+ |
||
| 1461 | +3928 |
setMethod( |
||
| 1462 | +3929 |
- "collect_leaves", "ANY",+ "spl_section_div<-", "Split", |
||
| 1463 | +3930 |
- function(tt, incl.cont, add.labrows) {
+ function(obj, value) {
|
||
| 1464 | +3931 | ! |
- stop("class ", class(tt), " does not inherit from VTree or VLeaf")
+ obj@child_section_div <- value+ |
+ |
| 3932 | +! | +
+ obj |
||
| 1465 | +3933 |
} |
||
| 1466 | +3934 |
) |
||
| 1467 | +3935 | |||
| 1468 | +3936 |
- n_leaves <- function(tt, ...) {
+ # Used for table object parts |
||
| 1469 | -202x | +3937 | +25017x |
- length(collect_leaves(tt, ...))+ setGeneric("trailing_section_div", function(obj) standardGeneric("trailing_section_div"))
|
| 1470 | -+ | |||
| 3938 | +9607x |
- }+ setMethod("trailing_section_div", "VTableTree", function(obj) obj@trailing_section_div)
|
||
| 1471 | -+ | |||
| 3939 | +4726x |
-
+ setMethod("trailing_section_div", "LabelRow", function(obj) obj@trailing_section_div)
|
||
| 1472 | -+ | |||
| 3940 | +10684x |
- ### Spanning information ----+ setMethod("trailing_section_div", "TableRow", function(obj) obj@trailing_section_div)
|
||
| 1473 | +3941 | |||
| 3942 | +1475x | +
+ setGeneric("trailing_section_div<-", function(obj, value) standardGeneric("trailing_section_div<-"))
+ |
+ ||
| 1474 | +3943 |
- #' @rdname int_methods+ setMethod("trailing_section_div<-", "VTableTree", function(obj, value) {
|
||
| 1475 | -53109x | +3944 | +1376x |
- setGeneric("row_cspans", function(obj) standardGeneric("row_cspans"))
+ obj@trailing_section_div <- value+ |
+
| 3945 | +1376x | +
+ obj |
||
| 1476 | +3946 |
-
+ }) |
||
| 1477 | +3947 |
- #' @rdname int_methods+ setMethod("trailing_section_div<-", "LabelRow", function(obj, value) {
|
||
| 1478 | -4516x | +3948 | +40x |
- setMethod("row_cspans", "TableRow", function(obj) obj@colspans)
+ obj@trailing_section_div <- value |
| 1479 | -+ | |||
| 3949 | +40x |
-
+ obj |
||
| 1480 | +3950 |
- #' @rdname int_methods+ }) |
||
| 1481 | +3951 |
- setMethod(+ setMethod("trailing_section_div<-", "TableRow", function(obj, value) {
|
||
| 1482 | -+ | |||
| 3952 | +59x |
- "row_cspans", "LabelRow",+ obj@trailing_section_div <- value |
||
| 1483 | -1494x | +3953 | +59x |
- function(obj) rep(1L, ncol(obj))+ obj |
| 1484 | +3954 |
- )+ }) |
||
| 1485 | +3955 | |||
| 1486 | +3956 |
- #' @rdname int_methods- |
- ||
| 1487 | -3974x | -
- setGeneric("row_cspans<-", function(obj, value) standardGeneric("row_cspans<-"))
+ #' Section dividers accessor and setter |
||
| 1488 | +3957 |
-
+ #' |
||
| 1489 | +3958 |
- #' @rdname int_methods+ #' `section_div` can be used to set or get the section divider for a table object |
||
| 1490 | +3959 |
- setMethod("row_cspans<-", "TableRow", function(obj, value) {
- |
- ||
| 1491 | -3974x | -
- obj@colspans <- value- |
- ||
| 1492 | -3974x | -
- obj+ #' produced by [build_table()]. When assigned in post-processing (`section_div<-`) |
||
| 1493 | +3960 |
- })+ #' the table can have a section divider after every row, each assigned independently. |
||
| 1494 | +3961 |
-
+ #' If assigning during layout creation, only [split_rows_by()] (and its related row-wise |
||
| 1495 | +3962 |
- #' @rdname int_methods+ #' splits) and [analyze()] have a `section_div` parameter that will produce separators |
||
| 1496 | +3963 |
- setMethod("row_cspans<-", "LabelRow", function(obj, value) {
+ #' between split sections and data subgroups, respectively. |
||
| 1497 | +3964 |
- stop("attempted to set colspans for LabelRow") # nocov
+ #' |
||
| 1498 | +3965 |
- })+ #' @param obj (`VTableTree`)\cr table object. This can be of any class that inherits from `VTableTree` |
||
| 1499 | +3966 |
-
+ #' or `TableRow`/`LabelRow`. |
||
| 1500 | +3967 |
- ## XXX TODO colapse with above?+ #' @param only_sep_sections (`flag`)\cr defaults to `FALSE` for `section_div<-`. Allows |
||
| 1501 | +3968 |
- #' @rdname int_methods- |
- ||
| 1502 | -46453x | -
- setGeneric("cell_cspan", function(obj) standardGeneric("cell_cspan"))
+ #' you to set the section divider only for sections that are splits or analyses if the number of |
||
| 1503 | +3969 |
-
+ #' values is less than the number of rows in the table. If `TRUE`, the section divider will |
||
| 1504 | +3970 |
- #' @rdname int_methods+ #' be set for all rows of the table. |
||
| 1505 | +3971 |
- setMethod(+ #' @param value (`character`)\cr vector of single characters to use as section dividers. Each character |
||
| 1506 | +3972 |
- "cell_cspan", "CellValue",- |
- ||
| 1507 | -46453x | -
- function(obj) attr(obj, "colspan", exact = TRUE)+ #' is repeated such that all section dividers span the width of the table. Each character that is |
||
| 1508 | +3973 |
- ) ## obj@colspan)+ #' not `NA_character_` will produce a trailing separator for each row of the table. `value` length |
||
| 1509 | +3974 |
-
+ #' should reflect the number of rows, or be between 1 and the number of splits/levels. |
||
| 1510 | +3975 |
- #' @rdname int_methods+ #' See the Details section below for more information. |
||
| 1511 | +3976 |
- setGeneric(+ #' |
||
| 1512 | +3977 |
- "cell_cspan<-",- |
- ||
| 1513 | -6892x | -
- function(obj, value) standardGeneric("cell_cspan<-")
+ #' @return The section divider string. Each line that does not have a trailing separator |
||
| 1514 | +3978 |
- )+ #' will have `NA_character_` as section divider. |
||
| 1515 | +3979 |
-
+ #' |
||
| 1516 | +3980 |
- #' @rdname int_methods+ #' @seealso [basic_table()] parameter `header_section_div` and `top_level_section_div` for global |
||
| 1517 | +3981 |
- setMethod("cell_cspan<-", "CellValue", function(obj, value) {
+ #' section dividers. |
||
| 1518 | +3982 |
- ## obj@colspan <- value- |
- ||
| 1519 | -6892x | -
- attr(obj, "colspan") <- value- |
- ||
| 1520 | -6892x | -
- obj+ #' |
||
| 1521 | +3983 |
- })+ #' @details |
||
| 1522 | +3984 |
-
+ #' Assigned value to section divider must be a character vector. If any value is `NA_character_` |
||
| 1523 | +3985 |
- #' @rdname int_methods- |
- ||
| 1524 | -26628x | -
- setGeneric("cell_align", function(obj) standardGeneric("cell_align"))
+ #' the section divider will be absent for that row or section. When you want to only affect sections |
||
| 1525 | +3986 |
-
+ #' or splits, please use `only_sep_sections` or provide a shorter vector than the number of rows. |
||
| 1526 | +3987 |
- #' @rdname int_methods+ #' Ideally, the length of the vector should be less than the number of splits with, eventually, the |
||
| 1527 | +3988 |
- setMethod(+ #' leaf-level, i.e. `DataRow` where analyze results are. Note that if only one value is inserted, |
||
| 1528 | +3989 |
- "cell_align", "CellValue",+ #' only the first split will be affected. |
||
| 1529 | -26628x | +|||
| 3990 | +
- function(obj) attr(obj, "align", exact = TRUE) %||% "center"+ #' If `only_sep_sections = TRUE`, which is the default for `section_div()` produced from the table |
|||
| 1530 | +3991 |
- ) ## obj@colspan)+ #' construction, the section divider will be set for all the splits and eventually analyses, but |
||
| 1531 | +3992 |
-
+ #' not for the header or each row of the table. This can be set with `header_section_div` in |
||
| 1532 | +3993 |
- #' @rdname int_methods+ #' [basic_table()] or, eventually, with `hsep` in [build_table()]. If `FALSE`, the section |
||
| 1533 | +3994 |
- setGeneric(+ #' divider will be set for all the rows of the table. |
||
| 1534 | +3995 |
- "cell_align<-",+ #' |
||
| 1535 | -56x | +|||
| 3996 | +
- function(obj, value) standardGeneric("cell_align<-")
+ #' @examples |
|||
| 1536 | +3997 |
- )+ #' # Data |
||
| 1537 | +3998 |
-
+ #' df <- data.frame( |
||
| 1538 | +3999 |
- #' @rdname int_methods+ #' cat = c( |
||
| 1539 | +4000 |
- setMethod("cell_align<-", "CellValue", function(obj, value) {
+ #' "really long thing its so ", "long" |
||
| 1540 | +4001 |
- ## obj@colspan <- value+ #' ), |
||
| 1541 | -56x | +|||
| 4002 | +
- if (is.null(value)) {
+ #' value = c(6, 3, 10, 1) |
|||
| 1542 | -! | +|||
| 4003 | +
- value <- "center"+ #' ) |
|||
| 1543 | +4004 |
- } else {
+ #' fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2)
|
||
| 1544 | -56x | +|||
| 4005 | +
- value <- tolower(value)+ #' |
|||
| 1545 | +4006 |
- }+ #' tbl <- basic_table() %>% |
||
| 1546 | -56x | +|||
| 4007 | +
- check_aligns(value)+ #' split_rows_by("cat", section_div = "~") %>%
|
|||
| 1547 | -56x | +|||
| 4008 | +
- attr(obj, "align") <- value+ #' analyze("value", afun = fast_afun, section_div = " ") %>%
|
|||
| 1548 | -56x | +|||
| 4009 | +
- obj+ #' build_table(df) |
|||
| 1549 | +4010 |
- })+ #' |
||
| 1550 | +4011 |
-
+ #' # Getter |
||
| 1551 | +4012 |
- ### Level (indent) in tree structure ----+ #' section_div(tbl) |
||
| 1552 | +4013 |
-
+ #' |
||
| 1553 | +4014 |
- #' @rdname int_methods+ #' # Setter |
||
| 1554 | -209x | +|||
| 4015 | +
- setGeneric("tt_level", function(obj) standardGeneric("tt_level"))
+ #' section_div(tbl) <- letters[seq_len(nrow(tbl))] |
|||
| 1555 | +4016 |
-
+ #' tbl |
||
| 1556 | +4017 |
- ## this will hit everything via inheritence+ #' |
||
| 1557 | +4018 |
- #' @rdname int_methods+ #' # last letter can appear if there is another table |
||
| 1558 | -209x | +|||
| 4019 | +
- setMethod("tt_level", "VNodeInfo", function(obj) obj@level)
+ #' rbind(tbl, tbl) |
|||
| 1559 | +4020 |
-
+ #' |
||
| 1560 | +4021 |
- #' @rdname int_methods+ #' # header_section_div |
||
| 1561 | -2x | +|||
| 4022 | +
- setGeneric("tt_level<-", function(obj, value) standardGeneric("tt_level<-"))
+ #' header_section_div(tbl) <- "+" |
|||
| 1562 | +4023 |
-
+ #' tbl |
||
| 1563 | +4024 |
- ## this will hit everyhing via inheritence+ #' |
||
| 1564 | +4025 |
- #' @rdname int_methods+ #' @docType methods |
||
| 1565 | +4026 |
- setMethod("tt_level<-", "VNodeInfo", function(obj, value) {
+ #' @rdname section_div |
||
| 1566 | -1x | +|||
| 4027 | +
- obj@level <- as.integer(value)+ #' @export |
|||
| 1567 | -1x | +4028 | +362x |
- obj+ setGeneric("section_div", function(obj) standardGeneric("section_div"))
|
| 1568 | +4029 |
- })+ |
||
| 1569 | +4030 |
-
+ #' @rdname section_div |
||
| 1570 | +4031 |
- #' @rdname int_methods+ #' @aliases section_div,VTableTree-method |
||
| 1571 | +4032 |
- setMethod(+ setMethod("section_div", "VTableTree", function(obj) {
|
||
| 1572 | -+ | |||
| 4033 | +150x |
- "tt_level<-", "VTableTree",+ content_row_tbl <- content_table(obj) |
||
| 1573 | -+ | |||
| 4034 | +150x |
- function(obj, value) {
+ is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 # otherwise NA or NULL |
||
| 1574 | -1x | +4035 | +150x |
- obj@level <- as.integer(value)+ if (labelrow_visible(obj) || is_content_table) {
|
| 1575 | -1x | +4036 | +67x |
- tree_children(obj) <- lapply(tree_children(obj),+ section_div <- trailing_section_div(obj) |
| 1576 | -1x | +4037 | +67x |
- `tt_level<-`,+ labelrow_div <- trailing_section_div(tt_labelrow(obj)) |
| 1577 | -1x | +4038 | +67x |
- value = as.integer(value) + 1L+ rest_of_tree <- section_div(tree_children(obj)) |
| 1578 | +4039 |
- )+ # Case it is the section itself and not the labels to have a trailing sep |
||
| 1579 | -1x | +4040 | +67x |
- obj+ if (!is.na(section_div)) {
|
| 1580 | -+ | |||
| 4041 | +45x |
- }+ rest_of_tree[length(rest_of_tree)] <- section_div |
||
| 1581 | +4042 |
- )+ } |
||
| 1582 | -+ | |||
| 4043 | +67x |
-
+ unname(c(labelrow_div, rest_of_tree)) |
||
| 1583 | +4044 |
- #' @rdname int_methods+ } else {
+ |
+ ||
| 4045 | +83x | +
+ unname(section_div(tree_children(obj))) |
||
| 1584 | +4046 |
- #' @export+ } |
||
| 1585 | -52957x | +|||
| 4047 | +
- setGeneric("indent_mod", function(obj) standardGeneric("indent_mod"))
+ }) |
|||
| 1586 | +4048 | |||
| 1587 | +4049 |
- #' @rdname int_methods+ #' @rdname section_div |
||
| 1588 | +4050 |
- setMethod(+ #' @aliases section_div,list-method |
||
| 1589 | +4051 |
- "indent_mod", "Split",+ setMethod("section_div", "list", function(obj) {
|
||
| 1590 | -2876x | +4052 | +150x |
- function(obj) obj@indent_modifier+ unlist(lapply(obj, section_div)) |
| 1591 | +4053 |
- )+ }) |
||
| 1592 | +4054 | |||
| 1593 | +4055 |
- #' @rdname int_methods+ #' @rdname section_div |
||
| 1594 | +4056 |
- setMethod(+ #' @aliases section_div,TableRow-method |
||
| 1595 | +4057 |
- "indent_mod", "VTableNodeInfo",+ setMethod("section_div", "TableRow", function(obj) {
|
||
| 1596 | -24185x | +4058 | +62x |
- function(obj) obj@indent_modifier+ trailing_section_div(obj) |
| 1597 | +4059 |
- )+ }) |
||
| 1598 | +4060 | |||
| 1599 | +4061 |
- #' @rdname int_methods+ # section_div setter from table object |
||
| 1600 | +4062 |
- setMethod(+ #' @rdname section_div |
||
| 1601 | +4063 |
- "indent_mod", "ANY",+ #' @export+ |
+ ||
| 4064 | ++ |
+ setGeneric("section_div<-", function(obj, only_sep_sections = FALSE, value) {
|
||
| 1602 | -22595x | +4065 | +217x |
- function(obj) attr(obj, "indent_mod", exact = TRUE) %||% 0L+ standardGeneric("section_div<-")
|
| 1603 | +4066 |
- )+ }) |
||
| 1604 | +4067 | |||
| 1605 | +4068 |
- #' @rdname int_methods+ #' @rdname section_div |
||
| 1606 | +4069 |
- setMethod(+ #' @aliases section_div<-,VTableTree-method |
||
| 1607 | +4070 |
- "indent_mod", "RowsVerticalSection",+ setMethod("section_div<-", "VTableTree", function(obj, only_sep_sections = FALSE, value) {
|
||
| 1608 | -+ | |||
| 4071 | +90x |
- ## function(obj) setNames(obj@indent_mods,names(obj)))+ char_v <- as.character(value) |
||
| 1609 | -+ | |||
| 4072 | +90x |
- function(obj) {
+ tree_depths <- unname(vapply(collect_leaves(obj), tt_level, numeric(1))) |
||
| 1610 | -1592x | +4073 | +90x |
- val <- attr(obj, "indent_mods", exact = TRUE) %||%+ max_tree_depth <- max(tree_depths) |
| 1611 | -1592x | +4074 | +90x |
- vapply(obj, indent_mod, 1L) ## rep(0L, length(obj))+ stopifnot(is.logical(only_sep_sections)) |
| 1612 | -1592x | +4075 | +90x |
- setNames(val, names(obj))+ .check_char_vector_for_section_div(char_v, max_tree_depth, nrow(obj)) |
| 1613 | +4076 |
- }+ |
||
| 1614 | +4077 |
- )+ # Automatic establishment of intent |
||
| 1615 | -+ | |||
| 4078 | +90x |
-
+ if (length(char_v) < nrow(obj)) {
|
||
| 1616 | -+ | |||
| 4079 | +3x |
- #' @examples+ only_sep_sections <- TRUE |
||
| 1617 | +4080 |
- #' lyt <- basic_table() %>%+ } |
||
| 1618 | +4081 |
- #' split_rows_by("RACE", split_fun = keep_split_levels(c("ASIAN", "WHITE"))) %>%
+
|
||
| 1619 | +4082 |
- #' analyze("AGE")
+ # Case where only separators or splits need to change externally |
||
| 1620 | -+ | |||
| 4083 | +90x |
- #'+ if (only_sep_sections && length(char_v) < nrow(obj)) {
|
||
| 1621 | +4084 |
- #' tbl <- build_table(lyt, DM)+ # Case where char_v is longer than the max depth |
||
| 1622 | -+ | |||
| 4085 | +3x |
- #' indent_mod(tbl)+ char_v <- char_v[seq_len(min(max_tree_depth, length(char_v)))] |
||
| 1623 | +4086 |
- #' indent_mod(tbl) <- 1L+ # Filling up with NAs the rest of the tree depth section div chr vector |
||
| 1624 | -+ | |||
| 4087 | +3x |
- #' tbl+ missing_char_v_len <- max_tree_depth - length(char_v)+ |
+ ||
| 4088 | +3x | +
+ char_v <- c(char_v, rep(NA_character_, missing_char_v_len)) |
||
| 1625 | +4089 |
- #'+ } |
||
| 1626 | +4090 |
- #' @rdname int_methods+ |
||
| 1627 | +4091 |
- #' @export+ # Retrieving if it is a contentRow (no need for labelrow to be visible in this case) |
||
| 1628 | -1422x | +4092 | +90x |
- setGeneric("indent_mod<-", function(obj, value) standardGeneric("indent_mod<-"))
+ content_row_tbl <- content_table(obj)+ |
+
| 4093 | +90x | +
+ is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 |
||
| 1629 | +4094 | |||
| 1630 | +4095 |
- #' @rdname int_methods+ # Main table structure change |
||
| 1631 | -+ | |||
| 4096 | +90x |
- setMethod(+ if (labelrow_visible(obj) || is_content_table) {
|
||
| 1632 | -+ | |||
| 4097 | +40x |
- "indent_mod<-", "Split",+ if (only_sep_sections) {
|
||
| 1633 | +4098 |
- function(obj, value) {
+ # Only tables are modified |
||
| 1634 | -1x | +4099 | +34x |
- obj@indent_modifier <- as.integer(value)+ trailing_section_div(tt_labelrow(obj)) <- NA_character_ |
| 1635 | -1x | +4100 | +34x |
- obj+ trailing_section_div(obj) <- char_v[1] |
| 1636 | -+ | |||
| 4101 | +34x |
- }+ section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1] |
||
| 1637 | +4102 |
- )+ } else {
|
||
| 1638 | +4103 |
-
+ # All leaves are modified |
||
| 1639 | -+ | |||
| 4104 | +6x |
- #' @rdname int_methods+ trailing_section_div(tt_labelrow(obj)) <- char_v[1] |
||
| 1640 | -+ | |||
| 4105 | +6x |
- setMethod(+ trailing_section_div(obj) <- NA_character_ |
||
| 1641 | -+ | |||
| 4106 | +6x |
- "indent_mod<-", "VTableNodeInfo",+ section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1] |
||
| 1642 | +4107 |
- function(obj, value) {
+ } |
||
| 1643 | -1418x | +|||
| 4108 | +
- obj@indent_modifier <- as.integer(value)+ } else {
|
|||
| 1644 | -1418x | +4109 | +50x |
- obj+ section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v |
| 1645 | +4110 |
} |
||
| 1646 | -+ | |||
| 4111 | +90x |
- )+ obj |
||
| 1647 | +4112 |
-
+ }) |
||
| 1648 | +4113 |
- #' @rdname int_methods+ |
||
| 1649 | +4114 |
- setMethod(+ #' @rdname section_div |
||
| 1650 | +4115 |
- "indent_mod<-", "CellValue",+ #' @aliases section_div<-,list-method |
||
| 1651 | +4116 |
- function(obj, value) {
+ setMethod("section_div<-", "list", function(obj, only_sep_sections = FALSE, value) {
|
||
| 1652 | -2x | +4117 | +90x |
- attr(obj, "indent_mod") <- as.integer(value)+ char_v <- as.character(value) |
| 1653 | -2x | -
- obj- |
- ||
| 1654 | -+ | 4118 | +90x |
- }+ for (i in seq_along(obj)) {
|
| 1655 | -+ | |||
| 4119 | +121x |
- )+ stopifnot(is(obj[[i]], "VTableTree") || is(obj[[i]], "TableRow") || is(obj[[i]], "LabelRow")) |
||
| 1656 | -+ | |||
| 4120 | +121x |
-
+ list_element_size <- nrow(obj[[i]]) |
||
| 1657 | -+ | |||
| 4121 | +121x |
- #' @rdname int_methods+ if (only_sep_sections) {
|
||
| 1658 | -+ | |||
| 4122 | +97x |
- setMethod(+ char_v_i <- char_v[seq_len(min(list_element_size, length(char_v)))] |
||
| 1659 | -+ | |||
| 4123 | +97x |
- "indent_mod<-", "RowsVerticalSection",+ char_v_i <- c(char_v_i, rep(NA_character_, list_element_size - length(char_v_i))) |
||
| 1660 | +4124 |
- function(obj, value) {
+ } else {
|
||
| 1661 | -1x | +4125 | +24x |
- if (length(value) != 1 && length(value) != length(obj)) {
+ init <- (i - 1) * list_element_size + 1 |
| 1662 | -! | +|||
| 4126 | +24x |
- stop(+ chunk_of_char_v_to_take <- seq(init, init + list_element_size - 1) |
||
| 1663 | -! | +|||
| 4127 | +24x |
- "When setting indent mods on a RowsVerticalSection the value ",+ char_v_i <- char_v[chunk_of_char_v_to_take] |
||
| 1664 | -! | +|||
| 4128 | +
- "must have length 1 or the number of rows"+ } |
|||
| 1665 | -+ | |||
| 4129 | +121x |
- )+ section_div(obj[[i]], only_sep_sections = only_sep_sections) <- char_v_i |
||
| 1666 | +4130 |
- }+ } |
||
| 1667 | -1x | +4131 | +90x |
- attr(obj, "indent_mods") <- as.integer(value)+ obj |
| 1668 | -1x | +|||
| 4132 | +
- obj+ }) |
|||
| 1669 | +4133 | |||
| 1670 | +4134 |
- ## obj@indent_mods <- value+ #' @rdname section_div |
||
| 1671 | +4135 |
- ## obj+ #' @aliases section_div<-,TableRow-method |
||
| 1672 | +4136 |
- }+ setMethod("section_div<-", "TableRow", function(obj, only_sep_sections = FALSE, value) {
+ |
+ ||
| 4137 | +37x | +
+ trailing_section_div(obj) <- value+ |
+ ||
| 4138 | +37x | +
+ obj |
||
| 1673 | +4139 |
- )+ }) |
||
| 1674 | +4140 | |||
| 1675 | +4141 |
- #' @rdname int_methods+ #' @rdname section_div |
||
| 1676 | +4142 |
- setGeneric(+ #' @aliases section_div<-,LabelRow-method |
||
| 1677 | +4143 |
- "content_indent_mod",+ setMethod("section_div<-", "LabelRow", function(obj, only_sep_sections = FALSE, value) {
|
||
| 1678 | -1191x | +|||
| 4144 | +! |
- function(obj) standardGeneric("content_indent_mod")
+ trailing_section_div(obj) <- value+ |
+ ||
| 4145 | +! | +
+ obj |
||
| 1679 | +4146 |
- )+ }) |
||
| 1680 | +4147 | |||
| 1681 | +4148 |
- #' @rdname int_methods+ # Helper check function |
||
| 1682 | +4149 |
- setMethod(+ .check_char_vector_for_section_div <- function(char_v, min_splits, max) {
+ |
+ ||
| 4150 | +90x | +
+ lcv <- length(char_v)+ |
+ ||
| 4151 | +90x | +
+ if (lcv < 1 || lcv > max) {
+ |
+ ||
| 4152 | +! | +
+ stop("section_div must be a vector of length between 1 and numer of table rows.")
|
||
| 1683 | +4153 |
- "content_indent_mod", "Split",+ } |
||
| 1684 | -1191x | +4154 | +90x |
- function(obj) obj@content_indent_modifier+ if (lcv > min_splits && lcv < max) {
+ |
+
| 4155 | +! | +
+ warning(+ |
+ ||
| 4156 | +! | +
+ "section_div will be truncated to the number of splits (", min_splits, ")",
+ |
+ ||
| 4157 | +! | +
+ " because it is shorter than the number of rows (", max, ")."
|
||
| 1685 | +4158 |
- )+ ) |
||
| 1686 | +4159 |
-
+ }+ |
+ ||
| 4160 | +90x | +
+ nchar_check_v <- nchar(char_v)+ |
+ ||
| 4161 | +90x | +
+ if (any(nchar_check_v > 1, na.rm = TRUE)) {
+ |
+ ||
| 4162 | +! | +
+ stop("section_div must be a vector of single characters or NAs")
|
||
| 1687 | +4163 |
- #' @rdname int_methods+ } |
||
| 1688 | +4164 |
- setMethod(+ } |
||
| 1689 | +4165 |
- "content_indent_mod", "VTableNodeInfo",+ |
||
| 1690 | -! | +|||
| 4166 | +
- function(obj) obj@content_indent_modifier+ #' @rdname section_div |
|||
| 1691 | +4167 |
- )+ #' @export+ |
+ ||
| 4168 | +603x | +
+ setGeneric("header_section_div", function(obj) standardGeneric("header_section_div"))
|
||
| 1692 | +4169 | |||
| 1693 | +4170 |
- #' @rdname int_methods+ #' @rdname section_div |
||
| 1694 | +4171 |
- setGeneric(+ #' @aliases header_section_div,PreDataTableLayouts-method |
||
| 1695 | +4172 |
- "content_indent_mod<-",+ setMethod(+ |
+ ||
| 4173 | ++ |
+ "header_section_div", "PreDataTableLayouts", |
||
| 1696 | -114x | +4174 | +303x |
- function(obj, value) standardGeneric("content_indent_mod<-")
+ function(obj) obj@header_section_div |
| 1697 | +4175 |
) |
||
| 1698 | +4176 | |||
| 1699 | +4177 |
- #' @rdname int_methods+ #' @rdname section_div |
||
| 1700 | +4178 |
- setMethod(+ #' @aliases header_section_div,PreDataTableLayouts-method |
||
| 1701 | +4179 |
- "content_indent_mod<-", "Split",+ setMethod( |
||
| 1702 | +4180 |
- function(obj, value) {
+ "header_section_div", "VTableTree", |
||
| 1703 | -114x | +4181 | +300x |
- obj@content_indent_modifier <- as.integer(value)+ function(obj) obj@header_section_div |
| 1704 | -114x | +|||
| 4182 | +
- obj+ ) |
|||
| 1705 | +4183 |
- }+ |
||
| 1706 | +4184 |
- )+ #' @rdname section_div |
||
| 1707 | +4185 | ++ |
+ #' @export+ |
+ |
| 4186 | +260x | +
+ setGeneric("header_section_div<-", function(obj, value) standardGeneric("header_section_div<-"))
+ |
+ ||
| 4187 | ||||
| 1708 | +4188 |
- #' @rdname int_methods+ #' @rdname section_div |
||
| 1709 | +4189 | ++ |
+ #' @aliases header_section_div<-,PreDataTableLayouts-method+ |
+ |
| 4190 |
setMethod( |
|||
| 1710 | +4191 |
- "content_indent_mod<-", "VTableNodeInfo",+ "header_section_div<-", "PreDataTableLayouts", |
||
| 1711 | +4192 |
function(obj, value) {
|
||
| 1712 | -! | +|||
| 4193 | +1x |
- obj@content_indent_modifier <- as.integer(value)+ .check_header_section_div(value) |
||
| 1713 | -! | +|||
| 4194 | +1x | +
+ obj@header_section_div <- value+ |
+ ||
| 4195 | +1x |
obj |
||
| 1714 | +4196 |
} |
||
| 1715 | +4197 |
) |
||
| 1716 | +4198 | |||
| 1717 | +4199 |
- ## TODO export these?+ #' @rdname section_div |
||
| 1718 | +4200 |
- #' @rdname int_methods+ #' @aliases header_section_div<-,PreDataTableLayouts-method |
||
| 1719 | +4201 |
- #' @export- |
- ||
| 1720 | -165200x | -
- setGeneric("rawvalues", function(obj) standardGeneric("rawvalues"))
+ setMethod( |
||
| 1721 | +4202 |
-
+ "header_section_div<-", "VTableTree", |
||
| 1722 | +4203 |
- #' @rdname int_methods- |
- ||
| 1723 | -! | -
- setMethod("rawvalues", "ValueWrapper", function(obj) obj@value)
+ function(obj, value) {
|
||
| 1724 | -+ | |||
| 4204 | +259x |
-
+ .check_header_section_div(value) |
||
| 1725 | -+ | |||
| 4205 | +259x |
- #' @rdname int_methods+ obj@header_section_div <- value |
||
| 1726 | -66x | +4206 | +259x |
- setMethod("rawvalues", "LevelComboSplitValue", function(obj) obj@combolevels)
+ obj |
| 1727 | +4207 |
-
+ } |
||
| 1728 | +4208 |
- #' @rdname int_methods- |
- ||
| 1729 | -3483x | -
- setMethod("rawvalues", "list", function(obj) lapply(obj, rawvalues))
+ ) |
||
| 1730 | +4209 | |||
| 1731 | +4210 |
- #' @rdname int_methods+ .check_header_section_div <- function(chr) {
|
||
| 1732 | -4466x | +4211 | +587x |
- setMethod("rawvalues", "ANY", function(obj) obj)
+ if (!is.na(chr) && (!is.character(chr) || length(chr) > 1 || nchar(chr) > 1 || nchar(chr) == 0)) {
|
| 1733 | -+ | |||
| 4212 | +! |
-
+ stop("header_section_div must be a single character or NA_character_ if not used")
|
||
| 1734 | +4213 |
- #' @rdname int_methods+ } |
||
| 1735 | -82993x | +4214 | +587x |
- setMethod("rawvalues", "CellValue", function(obj) obj[[1]])
+ invisible(TRUE) |
| 1736 | +4215 |
-
+ } |
||
| 1737 | +4216 |
- #' @rdname int_methods+ |
||
| 1738 | +4217 |
- setMethod(+ #' @rdname section_div |
||
| 1739 | +4218 |
- "rawvalues", "TreePos",+ #' @export |
||
| 1740 | -228x | +4219 | +307x |
- function(obj) rawvalues(pos_splvals(obj))+ setGeneric("top_level_section_div", function(obj) standardGeneric("top_level_section_div"))
|
| 1741 | +4220 |
- )+ |
||
| 1742 | +4221 |
-
+ #' @rdname section_div |
||
| 1743 | +4222 |
- #' @rdname int_methods+ #' @aliases top_level_section_div,PreDataTableLayouts-method |
||
| 1744 | +4223 |
setMethod( |
||
| 1745 | +4224 |
- "rawvalues", "RowsVerticalSection",+ "top_level_section_div", "PreDataTableLayouts", |
||
| 1746 | -2x | +4225 | +307x |
- function(obj) unlist(obj, recursive = FALSE)+ function(obj) obj@top_level_section_div |
| 1747 | +4226 |
) |
||
| 1748 | +4227 | |||
| 1749 | +4228 |
- #' @rdname int_methods+ #' @rdname section_div |
||
| 1750 | +4229 |
#' @export |
||
| 1751 | -83027x | +4230 | +1x |
- setGeneric("value_names", function(obj) standardGeneric("value_names"))
+ setGeneric("top_level_section_div<-", function(obj, value) standardGeneric("top_level_section_div<-"))
|
| 1752 | +4231 | |||
| 1753 | +4232 |
- #' @rdname int_methods+ #' @rdname section_div |
||
| 1754 | +4233 |
- setMethod(+ #' @aliases top_level_section_div<-,PreDataTableLayouts-method |
||
| 1755 | +4234 |
- "value_names", "ANY",+ setMethod( |
||
| 1756 | -38x | +|||
| 4235 | +
- function(obj) as.character(rawvalues(obj))+ "top_level_section_div<-", "PreDataTableLayouts", |
|||
| 1757 | +4236 |
- )+ function(obj, value) {
|
||
| 1758 | -+ | |||
| 4237 | +1x |
-
+ checkmate::assert_character(value, len = 1, n.chars = 1)+ |
+ ||
| 4238 | +1x | +
+ obj@top_level_section_div <- value+ |
+ ||
| 4239 | +1x | +
+ obj |
||
| 1759 | +4240 |
- #' @rdname int_methods+ } |
||
| 1760 | +4241 |
- setMethod(+ ) |
||
| 1761 | +4242 |
- "value_names", "TreePos",+ |
||
| 1762 | -1375x | +|||
| 4243 | +
- function(obj) value_names(pos_splvals(obj))+ ## table_inset ---------------------------------------------------------- |
|||
| 1763 | +4244 |
- )+ |
||
| 1764 | +4245 |
-
+ #' @rdname formatters_methods |
||
| 1765 | +4246 |
- #' @rdname int_methods+ #' @export |
||
| 1766 | +4247 |
setMethod( |
||
| 1767 | +4248 |
- "value_names", "list",+ "table_inset", "VTableNodeInfo", ## VTableTree", |
||
| 1768 | -6654x | +4249 | +305x |
- function(obj) lapply(obj, value_names)+ function(obj) obj@table_inset |
| 1769 | +4250 |
) |
||
| 1770 | +4251 | |||
| 1771 | +4252 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 1772 | +4253 | ++ |
+ #' @export+ |
+ |
| 4254 |
setMethod( |
|||
| 1773 | +4255 |
- "value_names", "ValueWrapper",+ "table_inset", "PreDataTableLayouts", |
||
| 1774 | -! | +|||
| 4256 | +302x |
- function(obj) rawvalues(obj)+ function(obj) obj@table_inset |
||
| 1775 | +4257 |
) |
||
| 1776 | +4258 | |||
| 1777 | +4259 |
- #' @rdname int_methods+ ## #' @rdname formatters_methods |
||
| 1778 | +4260 |
- setMethod(+ ## #' @export |
||
| 1779 | +4261 |
- "value_names", "LevelComboSplitValue",- |
- ||
| 1780 | -1601x | -
- function(obj) obj@value+ ## setMethod("table_inset", "InstantiatedColumnInfo",
|
||
| 1781 | +4262 |
- ) ## obj@comboname)+ ## function(obj) obj@table_inset) |
||
| 1782 | +4263 | |||
| 1783 | +4264 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 1784 | +4265 |
- setMethod(+ #' @export |
||
| 1785 | +4266 |
- "value_names", "RowsVerticalSection",- |
- ||
| 1786 | -3160x | -
- function(obj) attr(obj, "row_names", exact = TRUE)+ setMethod( |
||
| 1787 | +4267 |
- ) ## obj@row_names)+ "table_inset<-", "VTableNodeInfo", ## "VTableTree", |
||
| 1788 | +4268 |
-
+ function(obj, value) {
|
||
| 1789 | -+ | |||
| 4269 | +16391x |
- ## not sure if I need these anywhere+ if (!is.integer(value)) {
|
||
| 1790 | -+ | |||
| 4270 | +5x |
- ## XXX+ value <- as.integer(value) |
||
| 1791 | +4271 |
- #' @rdname int_methods+ } |
||
| 1792 | -5423x | +4272 | +16391x |
- setGeneric("value_labels", function(obj) standardGeneric("value_labels"))
+ if (is.na(value) || value < 0) {
|
| 1793 | -+ | |||
| 4273 | +! |
-
+ stop("Got invalid table_inset value, must be an integer > 0")
|
||
| 1794 | +4274 |
- #' @rdname int_methods+ } |
||
| 1795 | -! | +|||
| 4275 | +16391x |
- setMethod("value_labels", "ANY", function(obj) as.character(obj_label(obj)))
+ cont <- content_table(obj) |
||
| 1796 | -+ | |||
| 4276 | +16391x |
-
+ if (NROW(cont) > 0) {
|
||
| 1797 | -+ | |||
| 4277 | +1463x |
- #' @rdname int_methods+ table_inset(cont) <- value+ |
+ ||
| 4278 | +1463x | +
+ content_table(obj) <- cont |
||
| 1798 | +4279 |
- setMethod(+ } |
||
| 1799 | +4280 |
- "value_labels", "TreePos",+ |
||
| 1800 | -! | +|||
| 4281 | +16391x |
- function(obj) sapply(pos_splvals(obj), obj_label)+ if (length(tree_children(obj)) > 0) {
|
||
| 1801 | -+ | |||
| 4282 | +4851x |
- )+ kids <- lapply(tree_children(obj), |
||
| 1802 | -+ | |||
| 4283 | +4851x |
-
+ `table_inset<-`, |
||
| 1803 | -+ | |||
| 4284 | +4851x |
- #' @rdname int_methods+ value = value |
||
| 1804 | +4285 |
- setMethod("value_labels", "list", function(obj) {
+ ) |
||
| 1805 | -3782x | +4286 | +4851x |
- ret <- lapply(obj, obj_label)+ tree_children(obj) <- kids |
| 1806 | +4287 |
- if (!is.null(names(obj))) {
+ } |
||
| 1807 | -528x | +4288 | +16391x |
- inds <- vapply(ret, function(x) length(x) == 0, NA)+ obj@table_inset <- value |
| 1808 | -528x | +4289 | +16391x |
- ret[inds] <- names(obj)[inds]+ obj |
| 1809 | +4290 |
} |
||
| 1810 | -3782x | +|||
| 4291 | +
- ret+ ) |
|||
| 1811 | +4292 |
- })+ |
||
| 1812 | +4293 |
-
+ #' @rdname formatters_methods |
||
| 1813 | +4294 |
- #' @rdname int_methods+ #' @export |
||
| 1814 | +4295 |
setMethod( |
||
| 1815 | +4296 |
- "value_labels",+ "table_inset<-", "PreDataTableLayouts", |
||
| 1816 | +4297 |
- "RowsVerticalSection",+ function(obj, value) {
|
||
| 1817 | -1593x | +|||
| 4298 | +! |
- function(obj) setNames(attr(obj, "row_labels", exact = TRUE), value_names(obj))+ if (!is.integer(value)) {
|
||
| 1818 | -+ | |||
| 4299 | +! |
- )+ value <- as.integer(value) |
||
| 1819 | +4300 |
-
+ } |
||
| 1820 | -+ | |||
| 4301 | +! |
- #' @rdname int_methods+ if (is.na(value) || value < 0) {
|
||
| 1821 | +4302 | ! |
- setMethod("value_labels", "ValueWrapper", function(obj) obj_label(obj))
+ stop("Got invalid table_inset value, must be an integer > 0")
|
|
| 1822 | +4303 |
-
+ } |
||
| 1823 | +4304 |
- #' @rdname int_methods+ |
||
| 1824 | -+ | |||
| 4305 | +! |
- setMethod(+ obj@table_inset <- value |
||
| 1825 | -+ | |||
| 4306 | +! |
- "value_labels", "LevelComboSplitValue",+ obj |
||
| 1826 | -! | +|||
| 4307 | +
- function(obj) obj_label(obj)+ } |
|||
| 1827 | +4308 |
) |
||
| 1828 | +4309 | |||
| 1829 | +4310 |
- #' @rdname int_methods+ #' @rdname formatters_methods |
||
| 1830 | -48x | +|||
| 4311 | +
- setMethod("value_labels", "MultiVarSplit", function(obj) obj@var_labels)
+ #' @export |
|||
| 1831 | +4312 |
-
+ setMethod( |
||
| 1832 | +4313 |
- #' @rdname int_methods+ "table_inset<-", "InstantiatedColumnInfo", |
||
| 1833 | -5503x | +|||
| 4314 | +
- setGeneric("value_expr", function(obj) standardGeneric("value_expr"))
+ function(obj, value) {
+ |
+ |||
| 4315 | +! | +
+ if (!is.integer(value)) {
+ |
+ ||
| 4316 | +! | +
+ value <- as.integer(value) |
||
| 1834 | +4317 |
- #' @rdname int_methods+ } |
||
| 1835 | -110x | +|||
| 4318 | +! |
- setMethod("value_expr", "ValueWrapper", function(obj) obj@subset_expression)
+ if (is.na(value) || value < 0) {
+ |
+ ||
| 4319 | +! | +
+ stop("Got invalid table_inset value, must be an integer > 0")
|
||
| 1836 | +4320 |
- #' @rdname int_methods+ } |
||
| 1837 | +4321 | ! |
- setMethod("value_expr", "ANY", function(obj) NULL)
+ obj@table_inset <- value+ |
+ |
| 4322 | +! | +
+ obj |
||
| 1838 | +4323 |
- ## no setters for now, we'll see about that.+ } |
||
| 1839 | +4324 |
-
+ ) |
||
| 1840 | +4325 |
- #' @rdname int_methods+ |
||
| 1841 | -6x | +|||
| 4326 | +
- setGeneric("spl_varlabels", function(obj) standardGeneric("spl_varlabels"))
+ # stat_names for ARD ----------------------------------------------------------- |
|||
| 1842 | +4327 |
-
+ # |
||
| 1843 | +4328 |
#' @rdname int_methods |
||
| 1844 | -6x | +|||
| 4329 | +
- setMethod("spl_varlabels", "MultiVarSplit", function(obj) obj@var_labels)
+ #' @export |
|||
| 1845 | -+ | |||
| 4330 | +822x |
-
+ setGeneric("obj_stat_names", function(obj) standardGeneric("obj_stat_names"))
|
||
| 1846 | +4331 |
- #' @rdname int_methods+ # |
||
| 1847 | +4332 |
- setGeneric(+ #' @rdname int_methods |
||
| 1848 | +4333 |
- "spl_varlabels<-",+ #' @export |
||
| 1849 | -2x | +4334 | +8x |
- function(object, value) standardGeneric("spl_varlabels<-")
+ setGeneric("obj_stat_names<-", function(obj, value) standardGeneric("obj_stat_names<-"))
|
| 1850 | +4335 |
- )+ |
||
| 1851 | +4336 |
-
+ #' @rdname int_methods |
||
| 1852 | +4337 |
- #' @rdname int_methods+ #' @export |
||
| 1853 | +4338 |
- setMethod("spl_varlabels<-", "MultiVarSplit", function(object, value) {
+ setMethod("obj_stat_names<-", "CellValue", function(obj, value) {
|
||
| 1854 | -2x | +4339 | +8x |
- object@var_labels <- value+ attr(obj, "stat_names") <- value |
| 1855 | -2x | +4340 | +8x |
- object+ obj |
| 1856 | +4341 |
}) |
||
| 1857 | +4342 | |||
| 1858 | +4343 |
- ## These two are similar enough we could probably combine+ #' @rdname int_methods |
||
| 1859 | +4344 |
- ## them but conceptually they are pretty different+ #' @export+ |
+ ||
| 4345 | +822x | +
+ setMethod("obj_stat_names", "CellValue", function(obj) attr(obj, "stat_names"))
|
||
| 1860 | +4346 |
- ## split_exargs is a list of extra arguments that apply+ |
||
| 1861 | +4347 |
- ## to *all the chidlren*,+ #' @rdname int_methods |
||
| 1862 | +4348 |
- ## while splv_extra is for *child-specific* extra arguments,+ #' @export |
||
| 1863 | +4349 |
- ## associated with specific values of the split+ setMethod( |
||
| 1864 | +4350 |
- #' @rdname int_methods+ "obj_stat_names", "RowsVerticalSection", |
||
| 1865 | -3624x | +|||
| 4351 | +! |
- setGeneric("splv_extra", function(obj) standardGeneric("splv_extra"))
+ function(obj) lapply(obj, obj_stat_names) |
||
| 1866 | +4352 |
-
+ ) |
| 1867 | +1 |
- #' @rdname int_methods+ label_pos_values <- c("hidden", "visible", "topleft")
|
||
| 1868 | +2 |
- setMethod(+ |
||
| 1869 | +3 |
- "splv_extra", "SplitValue",+ #' @name internal_methods |
||
| 1870 | -3624x | +|||
| 4 | +
- function(obj) obj@extra+ #' @rdname int_methods |
|||
| 1871 | +5 |
- )+ NULL |
||
| 1872 | +6 | |||
| 1873 | +7 |
- #' @rdname int_methods+ #' Combine `SplitVector` objects |
||
| 1874 | +8 |
- setGeneric(+ #' |
||
| 1875 | +9 |
- "splv_extra<-",+ #' @param x (`SplitVector`)\cr a `SplitVector` object. |
||
| 1876 | -2019x | +|||
| 10 | +
- function(obj, value) standardGeneric("splv_extra<-")
+ #' @param ... splits or `SplitVector` objects. |
|||
| 1877 | +11 |
- )+ #' |
||
| 1878 | +12 |
- #' @rdname int_methods+ #' @return Various, but should be considered implementation details. |
||
| 1879 | +13 |
- setMethod(+ #' |
||
| 1880 | +14 |
- "splv_extra<-", "SplitValue",+ #' @rdname int_methods |
||
| 1881 | +15 |
- function(obj, value) {
+ #' @exportMethod c+ |
+ ||
| 16 | ++ |
+ setMethod("c", "SplitVector", function(x, ...) {
|
||
| 1882 | -2019x | +17 | +419x |
- obj@extra <- value+ arglst <- list(...) |
| 1883 | -2019x | +18 | +419x |
- obj+ stopifnot(all(sapply(arglst, is, "Split"))) |
| 1884 | -+ | |||
| 19 | +419x |
- }+ tmp <- c(unclass(x), arglst)+ |
+ ||
| 20 | +419x | +
+ SplitVector(lst = tmp) |
||
| 1885 | +21 |
- )+ }) |
||
| 1886 | +22 | |||
| 1887 | +23 |
- #' @rdname int_methods+ ## split_rows and split_cols are "recursive method stacks" which follow |
||
| 1888 | -2159x | +|||
| 24 | +
- setGeneric("split_exargs", function(obj) standardGeneric("split_exargs"))
+ ## the general pattern of accept object -> call add_*_split on slot of object -> |
|||
| 1889 | +25 |
-
+ ## update object with value returned from slot method, return object. |
||
| 1890 | +26 |
- #' @rdname int_methods+ ## |
||
| 1891 | +27 |
- setMethod(+ ## Thus each of the methods is idempotent, returning an updated object of the |
||
| 1892 | +28 |
- "split_exargs", "Split",+ ## same class it was passed. The exception for idempotency is the NULL method |
||
| 1893 | -2107x | +|||
| 29 | +
- function(obj) obj@extra_args+ ## which constructs a PreDataTableLayouts object with the specified split in the |
|||
| 1894 | +30 |
- )+ ## correct place. |
||
| 1895 | +31 | |||
| 1896 | +32 |
- #' @rdname int_methods+ ## The cascading (by class) in this case is as follows for the row case: |
||
| 1897 | +33 |
- setGeneric(+ ## PreDataTableLayouts -> PreDataRowLayout -> SplitVector |
||
| 1898 | +34 |
- "split_exargs<-",+ #' @param cmpnd_fun (`function`)\cr intended for internal use. |
||
| 1899 | -1x | +|||
| 35 | +
- function(obj, value) standardGeneric("split_exargs<-")
+ #' @param pos (`numeric(1)`)\cr intended for internal use. |
|||
| 1900 | +36 |
- )+ #' @param spl (`Split`)\cr the split. |
||
| 1901 | +37 |
-
+ #' |
||
| 1902 | +38 |
#' @rdname int_methods |
||
| 1903 | +39 |
- setMethod(+ setGeneric( |
||
| 1904 | +40 |
- "split_exargs<-", "Split",+ "split_rows", |
||
| 1905 | +41 |
- function(obj, value) {
+ function(lyt = NULL, spl, pos, |
||
| 1906 | -1x | +|||
| 42 | +
- obj@extra_args <- value+ cmpnd_fun = AnalyzeMultiVars) {
|
|||
| 1907 | -1x | +43 | +1683x |
- obj+ standardGeneric("split_rows")
|
| 1908 | +44 |
} |
||
| 1909 | +45 |
) |
||
| 1910 | +46 | |||
| 1911 | -! | +|||
| 47 | +
- is_labrow <- function(obj) is(obj, "LabelRow")+ #' @rdname int_methods |
|||
| 1912 | +48 |
-
+ setMethod("split_rows", "NULL", function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
|
||
| 1913 | -+ | |||
| 49 | +1x |
- spl_ref_group <- function(obj) {
+ lifecycle::deprecate_warn( |
||
| 1914 | -17x | +50 | +1x |
- stopifnot(is(obj, "VarLevWBaselineSplit"))+ when = "0.3.8", |
| 1915 | -17x | +51 | +1x |
- obj@ref_group_value+ what = I("split_rows(NULL)"),
|
| 1916 | -+ | |||
| 52 | +1x |
- }+ with = "basic_table()", |
||
| 1917 | -+ | |||
| 53 | +1x |
-
+ details = "Initializing layouts via `NULL` is no longer supported." |
||
| 1918 | +54 |
- ### column info+ ) |
||
| 1919 | -+ | |||
| 55 | +1x |
-
+ rl <- PreDataRowLayout(SplitVector(spl)) |
||
| 1920 | -+ | |||
| 56 | +1x |
- #' Column information/structure accessors+ cl <- PreDataColLayout() |
||
| 1921 | -+ | |||
| 57 | +1x |
- #'+ PreDataTableLayouts(rlayout = rl, clayout = cl) |
||
| 1922 | +58 |
- #' @inheritParams gen_args+ }) |
||
| 1923 | +59 |
- #' @param df (`data.frame` or `NULL`)\cr data to use if the column information is being+ |
||
| 1924 | +60 |
- #' generated from a pre-data layout object.+ #' @rdname int_methods |
||
| 1925 | +61 |
- #' @param path (`character` or `NULL`)\cr `col_counts` accessor and setter only.+ setMethod( |
||
| 1926 | +62 |
- #' Path (in column structure).+ "split_rows", "PreDataRowLayout", |
||
| 1927 | +63 |
- #' @param rtpos (`TreePos`)\cr root position.+ function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
|
||
| 1928 | -+ | |||
| 64 | +569x |
- #'+ stopifnot(pos > 0 && pos <= length(lyt) + 1) |
||
| 1929 | -+ | |||
| 65 | +569x |
- #' @return A `LayoutColTree` object.+ tmp <- if (pos <= length(lyt)) {
|
||
| 1930 | -+ | |||
| 66 | +544x |
- #'+ split_rows(lyt[[pos]], spl, pos, cmpnd_fun) |
||
| 1931 | +67 |
- #' @rdname col_accessors+ } else {
|
||
| 1932 | -+ | |||
| 68 | +25x |
- #' @export+ if (pos != 1 && has_force_pag(spl)) {
|
||
| 1933 | -3963x | +69 | +1x |
- setGeneric("clayout", function(obj) standardGeneric("clayout"))
+ stop("page_by splits cannot have top-level siblings",
|
| 1934 | -+ | |||
| 70 | +1x |
-
+ call. = FALSE |
||
| 1935 | +71 |
- #' @rdname col_accessors+ ) |
||
| 1936 | +72 |
- #' @exportMethod clayout+ } |
||
| 1937 | -+ | |||
| 73 | +24x |
- setMethod(+ SplitVector(spl) |
||
| 1938 | +74 |
- "clayout", "VTableNodeInfo",+ } |
||
| 1939 | -7x | +75 | +567x |
- function(obj) coltree(col_info(obj))+ lyt[[pos]] <- tmp |
| 1940 | -+ | |||
| 76 | +567x |
- )+ lyt |
||
| 1941 | +77 |
-
+ } |
||
| 1942 | +78 |
- #' @rdname col_accessors+ ) |
||
| 1943 | +79 |
- #' @exportMethod clayout+ |
||
| 1944 | +80 |
- setMethod(+ is_analysis_spl <- function(spl) {
+ |
+ ||
| 81 | +! | +
+ is(spl, "VAnalyzeSplit") || is(spl, "AnalyzeMultiVars") |
||
| 1945 | +82 |
- "clayout", "PreDataTableLayouts",+ } |
||
| 1946 | -3956x | +|||
| 83 | +
- function(obj) obj@col_layout+ |
|||
| 1947 | +84 |
- )+ ## note "pos" is ignored here because it is for which nest-chain |
||
| 1948 | +85 |
-
+ ## spl should be placed in, NOIT for where in that chain it should go |
||
| 1949 | +86 |
- ## useful convenience for the cascading methods in colby_constructors+ #' @rdname int_methods |
||
| 1950 | +87 |
- #' @rdname col_accessors+ setMethod( |
||
| 1951 | +88 |
- #' @exportMethod clayout+ "split_rows", "SplitVector", |
||
| 1952 | -! | +|||
| 89 | +
- setMethod("clayout", "ANY", function(obj) PreDataColLayout())
+ function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
|
|||
| 1953 | +90 |
-
+ ## if(is_analysis_spl(spl) && |
||
| 1954 | +91 |
- #' @rdname col_accessors+ ## is_analysis_spl(last_rowsplit(lyt))) {
|
||
| 1955 | +92 |
- #' @export+ ## return(cmpnd_last_rowsplit(lyt, spl, cmpnd_fun)) |
||
| 1956 | -1428x | +|||
| 93 | +
- setGeneric("clayout<-", function(object, value) standardGeneric("clayout<-"))
+ ## } |
|||
| 1957 | +94 | |||
| 1958 | -+ | |||
| 95 | +544x |
- #' @rdname col_accessors+ if (has_force_pag(spl) && length(lyt) > 0 && !has_force_pag(lyt[[length(lyt)]])) {
|
||
| 1959 | -+ | |||
| 96 | +1x |
- #' @exportMethod clayout<-+ stop("page_by splits cannot be nested within non-page_by splits",
|
||
| 1960 | -+ | |||
| 97 | +1x |
- setMethod(+ call. = FALSE |
||
| 1961 | +98 |
- "clayout<-", "PreDataTableLayouts",+ ) |
||
| 1962 | +99 |
- function(object, value) {
+ } |
||
| 1963 | -1428x | +100 | +543x |
- object@col_layout <- value+ tmp <- c(unclass(lyt), spl) |
| 1964 | -1428x | +101 | +543x |
- object+ SplitVector(lst = tmp) |
| 1965 | +102 |
} |
||
| 1966 | +103 |
) |
||
| 1967 | +104 | |||
| 1968 | +105 |
- #' @rdname col_accessors+ #' @rdname int_methods |
||
| 1969 | +106 |
- #' @export+ setMethod( |
||
| 1970 | -260281x | +|||
| 107 | +
- setGeneric("col_info", function(obj) standardGeneric("col_info"))
+ "split_rows", "PreDataTableLayouts", |
|||
| 1971 | +108 |
-
+ function(lyt, spl, pos) {
|
||
| 1972 | -+ | |||
| 109 | +569x |
- #' @rdname col_accessors+ rlyt <- rlayout(lyt) |
||
| 1973 | -+ | |||
| 110 | +569x |
- #' @exportMethod col_info+ addtl <- FALSE |
||
| 1974 | -+ | |||
| 111 | +569x |
- setMethod(+ split_label <- obj_label(spl) |
||
| 1975 | +112 |
- "col_info", "VTableNodeInfo",+ if ( |
||
| 1976 | -229485x | +113 | +569x |
- function(obj) obj@col_info+ is(spl, "Split") && ## exclude existing tables that are being tacked in |
| 1977 | -+ | |||
| 114 | +569x |
- )+ identical(label_position(spl), "topleft") && |
||
| 1978 | -+ | |||
| 115 | +569x |
-
+ length(split_label) == 1 && nzchar(split_label) |
||
| 1979 | +116 |
- ### XXX I've made this recursive. Do we ALWAYS want it to be?+ ) {
|
||
| 1980 | -+ | |||
| 117 | +17x |
- ###+ addtl <- TRUE |
||
| 1981 | +118 |
- ### I think we do.+ ## label_position(spl) <- "hidden" |
||
| 1982 | +119 |
- #' @rdname col_accessors+ } |
||
| 1983 | +120 |
- #' @export+ |
||
| 1984 | -70058x | +121 | +569x |
- setGeneric("col_info<-", function(obj, value) standardGeneric("col_info<-"))
+ rlyt <- split_rows(rlyt, spl, pos) |
| 1985 | -+ | |||
| 122 | +567x |
-
+ rlayout(lyt) <- rlyt+ |
+ ||
| 123 | +567x | +
+ if (addtl) {
+ |
+ ||
| 124 | +17x | +
+ lyt <- append_topleft(lyt, indent_string(split_label, .tl_indent(lyt))) |
||
| 1986 | +125 |
- #' @return Returns various information about columns, depending on the accessor used.+ }+ |
+ ||
| 126 | +567x | +
+ lyt |
||
| 1987 | +127 |
- #'+ } |
||
| 1988 | +128 |
- #' @exportMethod col_info<-+ ) |
||
| 1989 | +129 |
- #' @rdname col_accessors+ |
||
| 1990 | +130 |
- setMethod(+ #' @rdname int_methods |
||
| 1991 | +131 |
- "col_info<-", "TableRow",+ setMethod( |
||
| 1992 | +132 |
- function(obj, value) {
+ "split_rows", "ANY", |
||
| 1993 | -42044x | +|||
| 133 | +
- obj@col_info <- value+ function(lyt, spl, pos) {
|
|||
| 1994 | -42044x | +|||
| 134 | +! |
- obj+ stop("nope. can't add a row split to that (", class(lyt), "). contact the maintaner.")
|
||
| 1995 | +135 |
} |
||
| 1996 | +136 |
) |
||
| 1997 | +137 | |||
| 1998 | +138 |
- .set_cinfo_kids <- function(obj) {
+ ## cmpnd_last_rowsplit ===== |
||
| 1999 | -21746x | +|||
| 139 | +
- kids <- lapply(+ |
|||
| 2000 | -21746x | +|||
| 140 | +
- tree_children(obj),+ #' @rdname int_methods |
|||
| 2001 | -21746x | +|||
| 141 | +
- function(x) {
+ #' |
|||
| 2002 | -51566x | +|||
| 142 | +
- col_info(x) <- col_info(obj)+ #' @param constructor (`function`)\cr constructor function. |
|||
| 2003 | -51566x | +143 | +82x |
- x+ setGeneric("cmpnd_last_rowsplit", function(lyt, spl, constructor) standardGeneric("cmpnd_last_rowsplit"))
|
| 2004 | +144 |
- }+ |
||
| 2005 | +145 |
- )- |
- ||
| 2006 | -21746x | -
- tree_children(obj) <- kids+ #' @rdname int_methods |
||
| 2007 | -21746x | +|||
| 146 | +
- obj+ setMethod("cmpnd_last_rowsplit", "NULL", function(lyt, spl, constructor) {
|
|||
| 2008 | +147 |
- }+ stop("no existing splits to compound with. contact the maintainer") # nocov
|
||
| 2009 | +148 |
-
+ }) |
||
| 2010 | +149 |
- #' @rdname col_accessors+ |
||
| 2011 | +150 |
- #' @exportMethod col_info<-+ #' @rdname int_methods |
||
| 2012 | +151 |
setMethod( |
||
| 2013 | +152 |
- "col_info<-", "ElementaryTable",+ "cmpnd_last_rowsplit", "PreDataRowLayout", |
||
| 2014 | +153 |
- function(obj, value) {
+ function(lyt, spl, constructor) {
|
||
| 2015 | -14110x | +154 | +27x |
- obj@col_info <- value+ pos <- length(lyt) |
| 2016 | -14110x | +155 | +27x |
- .set_cinfo_kids(obj)+ tmp <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor) |
| 2017 | -+ | |||
| 156 | +27x |
- }+ lyt[[pos]] <- tmp |
||
| 2018 | -+ | |||
| 157 | +27x |
- )+ lyt |
||
| 2019 | +158 |
-
+ } |
||
| 2020 | +159 |
- #' @rdname col_accessors+ ) |
||
| 2021 | +160 |
- #' @exportMethod col_info<-+ #' @rdname int_methods |
||
| 2022 | +161 |
setMethod( |
||
| 2023 | +162 |
- "col_info<-", "TableTree",+ "cmpnd_last_rowsplit", "SplitVector", |
||
| 2024 | +163 |
- function(obj, value) {
+ function(lyt, spl, constructor) {
|
||
| 2025 | -7636x | +164 | +28x |
- obj@col_info <- value+ pos <- length(lyt) |
| 2026 | -7636x | +165 | +28x |
- if (nrow(content_table(obj))) {
+ lst <- lyt[[pos]] |
| 2027 | -1992x | +166 | +28x |
- ct <- content_table(obj)+ tmp <- if (is(lst, "CompoundSplit")) {
|
| 2028 | -1992x | +167 | +3x |
- col_info(ct) <- value+ spl_payload(lst) <- c( |
| 2029 | -1992x | -
- content_table(obj) <- ct- |
- ||
| 2030 | -+ | 168 | +3x |
- }+ .uncompound(spl_payload(lst)), |
| 2031 | -7636x | -
- .set_cinfo_kids(obj)- |
- ||
| 2032 | -+ | 169 | +3x |
- }+ .uncompound(spl) |
| 2033 | +170 |
- )+ ) |
||
| 2034 | -+ | |||
| 171 | +3x |
-
+ obj_name(lst) <- make_ma_name(spl = lst) |
||
| 2035 | -+ | |||
| 172 | +3x |
- #' @rdname col_accessors+ lst |
||
| 2036 | +173 |
- #' @param ccount_format (`FormatSpec`)\cr The format to be used by default for column+ ## XXX never reached because AnalzyeMultiVars inherits from |
||
| 2037 | +174 |
- #' counts throughout this column tree (i.e. if not overridden by a more specific format+ ## CompoundSplit??? |
||
| 2038 | +175 |
- #' specification).+ } else {
|
||
| 2039 | -+ | |||
| 176 | +25x |
- #' @export+ constructor(.payload = list(lst, spl)) |
||
| 2040 | +177 |
- setGeneric(+ } |
||
| 2041 | -+ | |||
| 178 | +28x |
- "coltree",+ lyt[[pos]] <- tmp |
||
| 2042 | -11883x | +179 | +28x |
- function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format = "(N=xx)") standardGeneric("coltree")
+ lyt |
| 2043 | +180 |
- )+ } |
||
| 2044 | +181 |
-
+ ) |
||
| 2045 | +182 |
- #' @rdname col_accessors+ |
||
| 2046 | +183 |
- #' @exportMethod coltree+ #' @rdname int_methods |
||
| 2047 | +184 |
setMethod( |
||
| 2048 | +185 |
- "coltree", "InstantiatedColumnInfo",+ "cmpnd_last_rowsplit", "PreDataTableLayouts", |
||
| 2049 | +186 |
- function(obj, df = NULL, rtpos = TreePos(), alt_counts_df = df, ccount_format) {
+ function(lyt, spl, constructor) {
|
||
| 2050 | -7833x | +187 | +27x |
- if (!is.null(df)) {
+ rlyt <- rlayout(lyt) |
| 2051 | -! | +|||
| 188 | +27x |
- warning("Ignoring df argument and retrieving already-computed LayoutColTree")
+ rlyt <- cmpnd_last_rowsplit(rlyt, spl, constructor) |
||
| 2052 | -+ | |||
| 189 | +27x |
- }+ rlayout(lyt) <- rlyt |
||
| 2053 | -7833x | +190 | +27x |
- obj@tree_layout+ lyt |
| 2054 | +191 |
} |
||
| 2055 | +192 |
) |
||
| 2056 | +193 |
-
+ #' @rdname int_methods |
||
| 2057 | +194 |
- #' @rdname col_accessors+ setMethod( |
||
| 2058 | +195 |
- #' @export coltree+ "cmpnd_last_rowsplit", "ANY", |
||
| 2059 | +196 |
- setMethod(+ function(lyt, spl, constructor) {
|
||
| 2060 | -+ | |||
| 197 | +! |
- "coltree", "PreDataTableLayouts",+ stop( |
||
| 2061 | -+ | |||
| 198 | +! |
- function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
+ "nope. can't do cmpnd_last_rowsplit to that (",
|
||
| 2062 | -1x | +|||
| 199 | +! |
- coltree(clayout(obj), df, rtpos, alt_counts_df = alt_counts_df, ccount_format = ccount_format)+ class(lyt), "). contact the maintaner." |
||
| 2063 | +200 | ++ |
+ )+ |
+ |
| 201 |
} |
|||
| 2064 | +202 |
) |
||
| 2065 | +203 | |||
| 2066 | +204 |
- #' @rdname col_accessors+ ## split_cols ==== |
||
| 2067 | +205 |
- #' @export coltree+ |
||
| 2068 | +206 |
- setMethod(+ #' @rdname int_methods |
||
| 2069 | +207 |
- "coltree", "PreDataColLayout",+ setGeneric( |
||
| 2070 | +208 |
- function(obj, df, rtpos, alt_counts_df = df, ccount_format) {
+ "split_cols", |
||
| 2071 | -327x | +|||
| 209 | +
- obj <- set_def_child_ord(obj, df)+ function(lyt = NULL, spl, pos) {
|
|||
| 2072 | -327x | +210 | +1064x |
- kids <- lapply(+ standardGeneric("split_cols")
|
| 2073 | -327x | -
- obj,- |
- ||
| 2074 | -327x | -
- function(x) {
- |
- ||
| 2075 | -335x | -
- splitvec_to_coltree(- |
- ||
| 2076 | -335x | -
- df = df,- |
- ||
| 2077 | -335x | -
- splvec = x,- |
- ||
| 2078 | -335x | -
- pos = rtpos,- |
- ||
| 2079 | -335x | +|||
| 211 | +
- alt_counts_df = alt_counts_df,+ } |
|||
| 2080 | -335x | +|||
| 212 | +
- global_cc_format = ccount_format+ ) |
|||
| 2081 | +213 |
- )+ |
||
| 2082 | +214 |
- }+ #' @rdname int_methods |
||
| 2083 | +215 |
- )+ setMethod("split_cols", "NULL", function(lyt, spl, pos) {
|
||
| 2084 | -320x | +216 | +1x |
- if (length(kids) == 1) {
+ lifecycle::deprecate_warn( |
| 2085 | -313x | -
- res <- kids[[1]]- |
- ||
| 2086 | -+ | 217 | +1x |
- } else {
+ when = "0.3.8", |
| 2087 | -7x | +218 | +1x |
- res <- LayoutColTree(+ what = I("split_cols(NULL)"),
|
| 2088 | -7x | +219 | +1x |
- lev = 0L,+ with = "basic_table()", |
| 2089 | -7x | +220 | +1x |
- kids = kids,+ details = "Initializing layouts via `NULL` is no longer supported." |
| 2090 | -7x | +|||
| 221 | +
- tpos = rtpos,+ ) |
|||
| 2091 | -7x | +222 | +1x |
- spl = RootSplit(),+ cl <- PreDataColLayout(SplitVector(spl)) |
| 2092 | -7x | +223 | +1x |
- colcount = NROW(alt_counts_df),+ rl <- PreDataRowLayout() |
| 2093 | -7x | +224 | +1x |
- colcount_format = ccount_format+ PreDataTableLayouts(rlayout = rl, clayout = cl) |
| 2094 | +225 |
- )+ }) |
||
| 2095 | +226 |
- }- |
- ||
| 2096 | -320x | -
- disp_ccounts(res) <- disp_ccounts(obj)+ |
||
| 2097 | -320x | +|||
| 227 | +
- res+ #' @rdname int_methods |
|||
| 2098 | +228 |
- }+ setMethod( |
||
| 2099 | +229 |
- )+ "split_cols", "PreDataColLayout", |
||
| 2100 | +230 |
-
+ function(lyt, spl, pos) {
|
||
| 2101 | -+ | |||
| 231 | +322x |
- #' @rdname col_accessors+ stopifnot(pos > 0 && pos <= length(lyt) + 1) |
||
| 2102 | -+ | |||
| 232 | +322x |
- #' @export coltree+ tmp <- if (pos <= length(lyt)) {
|
||
| 2103 | -+ | |||
| 233 | +314x |
- setMethod(+ split_cols(lyt[[pos]], spl, pos) |
||
| 2104 | +234 |
- "coltree", "LayoutColTree",+ } else {
|
||
| 2105 | -+ | |||
| 235 | +8x |
- function(obj, df, rtpos, alt_counts_df, ccount_format) obj+ SplitVector(spl) |
||
| 2106 | +236 |
- )+ } |
||
| 2107 | +237 | |||
| 2108 | -+ | |||
| 238 | +322x |
- #' @rdname col_accessors+ lyt[[pos]] <- tmp |
||
| 2109 | -+ | |||
| 239 | +322x |
- #' @export coltree+ lyt |
||
| 2110 | +240 |
- setMethod(+ } |
||
| 2111 | +241 |
- "coltree", "VTableTree",+ ) |
||
| 2112 | +242 |
- function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj))+ |
||
| 2113 | +243 |
- )+ #' @rdname int_methods |
||
| 2114 | +244 |
-
+ setMethod( |
||
| 2115 | +245 |
- #' @rdname col_accessors+ "split_cols", "SplitVector", |
||
| 2116 | +246 |
- #' @export coltree+ function(lyt, spl, pos) {
|
||
| 2117 | -+ | |||
| 247 | +419x |
- setMethod(+ tmp <- c(lyt, spl) |
||
| 2118 | -+ | |||
| 248 | +419x |
- "coltree", "TableRow",+ SplitVector(lst = tmp) |
||
| 2119 | +249 |
- function(obj, df, rtpos, alt_counts_df, ccount_format) coltree(col_info(obj))+ } |
||
| 2120 | +250 |
) |
||
| 2121 | +251 | |||
| 2122 | -917x | +|||
| 252 | +
- setGeneric("coltree<-", function(obj, value) standardGeneric("coltree<-"))
+ #' @rdname int_methods |
|||
| 2123 | +253 |
setMethod( |
||
| 2124 | +254 |
- "coltree<-", c("InstantiatedColumnInfo", "LayoutColTree"),
+ "split_cols", "PreDataTableLayouts", |
||
| 2125 | +255 |
- function(obj, value) {
+ function(lyt, spl, pos) {
|
||
| 2126 | -495x | +256 | +322x |
- obj@tree_layout <- value+ rlyt <- lyt@col_layout |
| 2127 | -495x | +257 | +322x |
- obj+ rlyt <- split_cols(rlyt, spl, pos)+ |
+
| 258 | +322x | +
+ lyt@col_layout <- rlyt+ |
+ ||
| 259 | +322x | +
+ lyt |
||
| 2128 | +260 |
} |
||
| 2129 | +261 |
) |
||
| 2130 | +262 | |||
| 2131 | +263 | ++ |
+ #' @rdname int_methods+ |
+ |
| 264 |
setMethod( |
|||
| 2132 | +265 |
- "coltree<-", c("VTableTree", "LayoutColTree"),
+ "split_cols", "ANY", |
||
| 2133 | +266 |
- function(obj, value) {
+ function(lyt, spl, pos) {
|
||
| 2134 | -422x | +|||
| 267 | +! |
- cinfo <- col_info(obj)+ stop( |
||
| 2135 | -422x | +|||
| 268 | +! |
- coltree(cinfo) <- value+ "nope. can't add a col split to that (", class(lyt),
|
||
| 2136 | -422x | +|||
| 269 | +! |
- col_info(obj) <- cinfo+ "). contact the maintaner." |
||
| 2137 | -422x | +|||
| 270 | +
- obj+ ) |
|||
| 2138 | +271 |
} |
||
| 2139 | +272 |
) |
||
| 2140 | +273 | |||
| 2141 | +274 |
- #' @rdname col_accessors+ # Constructors ===== |
||
| 2142 | +275 |
- #' @export+ |
||
| 2143 | -116071x | +|||
| 276 | +
- setGeneric("col_exprs", function(obj, df = NULL) standardGeneric("col_exprs"))
+ ## Pipe-able functions to add the various types of splits to the current layout |
|||
| 2144 | +277 |
-
+ ## for both row and column. These all act as wrappers to the split_cols and |
||
| 2145 | +278 |
- #' @rdname col_accessors+ ## split_rows method stacks. |
||
| 2146 | +279 |
- #' @export col_exprs+ |
||
| 2147 | +280 |
- setMethod(+ #' Declaring a column-split based on levels of a variable |
||
| 2148 | +281 |
- "col_exprs", "PreDataTableLayouts",+ #' |
||
| 2149 | -1x | +|||
| 282 | +
- function(obj, df = NULL) col_exprs(clayout(obj), df)+ #' Will generate children for each subset of a categorical variable. |
|||
| 2150 | +283 |
- )+ #' |
||
| 2151 | +284 |
-
+ #' @inheritParams lyt_args |
||
| 2152 | +285 |
- #' @rdname col_accessors+ #' @param ref_group (`string` or `NULL`)\cr level of `var` that should be considered `ref_group`/reference. |
||
| 2153 | +286 |
- #' @export col_exprs+ #' |
||
| 2154 | +287 |
- setMethod(+ #' @return A `PreDataTableLayouts` object suitable for passing to further layouting functions, and to [build_table()]. |
||
| 2155 | +288 |
- "col_exprs", "PreDataColLayout",+ #' |
||
| 2156 | +289 |
- function(obj, df = NULL) {
+ #' @inheritSection custom_split_funs Custom Splitting Function Details |
||
| 2157 | -1x | +|||
| 290 | +
- if (is.null(df)) {
+ #' |
|||
| 2158 | -! | +|||
| 291 | +
- stop("can't determine col_exprs without data")
+ #' @examples |
|||
| 2159 | +292 |
- }+ #' lyt <- basic_table() %>% |
||
| 2160 | -1x | +|||
| 293 | +
- ct <- coltree(obj, df = df)+ #' split_cols_by("ARM") %>%
|
|||
| 2161 | -1x | +|||
| 294 | +
- make_col_subsets(ct, df = df)+ #' analyze(c("AGE", "BMRKR2"))
|
|||
| 2162 | +295 |
- }+ #' |
||
| 2163 | +296 |
- )+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 2164 | +297 |
-
+ #' tbl |
||
| 2165 | +298 |
- #' @rdname col_accessors+ #' |
||
| 2166 | +299 |
- #' @export col_exprs+ #' # Let's look at the splits in more detail |
||
| 2167 | +300 |
- setMethod(+ #' |
||
| 2168 | +301 |
- "col_exprs", "InstantiatedColumnInfo",+ #' lyt1 <- basic_table() %>% split_cols_by("ARM")
|
||
| 2169 | +302 |
- function(obj, df = NULL) {
+ #' lyt1 |
||
| 2170 | -116069x | +|||
| 303 | +
- if (!is.null(df)) {
+ #' |
|||
| 2171 | -! | +|||
| 304 | +
- warning("Ignoring df method when extracted precomputed column subsetting expressions.")
+ #' # add an analysis (summary) |
|||
| 2172 | +305 |
- }+ #' lyt2 <- lyt1 %>% |
||
| 2173 | -116069x | +|||
| 306 | +
- obj@subset_exprs+ #' analyze(c("AGE", "COUNTRY"),
|
|||
| 2174 | +307 |
- }+ #' afun = list_wrap_x(summary), |
||
| 2175 | +308 |
- )+ #' format = "xx.xx" |
||
| 2176 | +309 |
-
+ #' ) |
||
| 2177 | +310 |
- #' @rdname int_methods+ #' lyt2 |
||
| 2178 | -2534x | +|||
| 311 | +
- setGeneric("col_extra_args", function(obj, df = NULL) standardGeneric("col_extra_args"))
+ #' |
|||
| 2179 | +312 |
-
+ #' tbl2 <- build_table(lyt2, DM) |
||
| 2180 | +313 |
- #' @rdname int_methods+ #' tbl2 |
||
| 2181 | +314 |
- setMethod(+ #' |
||
| 2182 | +315 |
- "col_extra_args", "InstantiatedColumnInfo",+ #' @examplesIf require(dplyr) |
||
| 2183 | +316 |
- function(obj, df) {
+ #' # By default sequentially adding layouts results in nesting |
||
| 2184 | -2214x | +|||
| 317 | +
- if (!is.null(df)) {
+ #' library(dplyr) |
|||
| 2185 | -! | +|||
| 318 | +
- warning("Ignorning df when retrieving already-computed column extra arguments.")
+ #' |
|||
| 2186 | +319 |
- }+ #' DM_MF <- DM %>% |
||
| 2187 | -2214x | +|||
| 320 | +
- obj@cextra_args+ #' filter(SEX %in% c("M", "F")) %>%
|
|||
| 2188 | +321 |
- }+ #' mutate(SEX = droplevels(SEX)) |
||
| 2189 | +322 |
- )+ #' |
||
| 2190 | +323 |
-
+ #' lyt3 <- basic_table() %>% |
||
| 2191 | +324 |
- #' @rdname int_methods+ #' split_cols_by("ARM") %>%
|
||
| 2192 | +325 |
- setMethod(+ #' split_cols_by("SEX") %>%
|
||
| 2193 | +326 |
- "col_extra_args", "PreDataTableLayouts",+ #' analyze(c("AGE", "COUNTRY"),
|
||
| 2194 | +327 |
- function(obj, df) col_extra_args(clayout(obj), df)+ #' afun = list_wrap_x(summary), |
||
| 2195 | +328 |
- )+ #' format = "xx.xx" |
||
| 2196 | +329 |
-
+ #' ) |
||
| 2197 | +330 |
- #' @rdname int_methods+ #' lyt3 |
||
| 2198 | +331 |
- setMethod(+ #' |
||
| 2199 | +332 |
- "col_extra_args", "PreDataColLayout",+ #' tbl3 <- build_table(lyt3, DM_MF) |
||
| 2200 | +333 |
- function(obj, df) {
+ #' tbl3 |
||
| 2201 | -! | +|||
| 334 | +
- col_extra_args(coltree(obj, df), NULL)+ #' |
|||
| 2202 | +335 |
- }+ #' # nested=TRUE vs not |
||
| 2203 | +336 |
- )+ #' lyt4 <- basic_table() %>% |
||
| 2204 | +337 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 2205 | +338 |
- #' @rdname int_methods+ #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
|
||
| 2206 | +339 |
- setMethod(+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
|
||
| 2207 | +340 |
- "col_extra_args", "LayoutColTree",+ #' analyze("AGE")
|
||
| 2208 | +341 |
- function(obj, df) {
+ #' lyt4 |
||
| 2209 | -320x | +|||
| 342 | +
- if (!is.null(df)) {
+ #' |
|||
| 2210 | -! | +|||
| 343 | +
- warning("Ignoring df argument and returning already calculated extra arguments")
+ #' tbl4 <- build_table(lyt4, DM) |
|||
| 2211 | +344 |
- }+ #' tbl4 |
||
| 2212 | -320x | +|||
| 345 | +
- get_col_extras(obj)+ #' |
|||
| 2213 | +346 |
- }+ #' lyt5 <- basic_table() %>% |
||
| 2214 | +347 |
- )+ #' split_cols_by("ARM") %>%
|
||
| 2215 | +348 |
-
+ #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
|
||
| 2216 | +349 |
- #' @rdname int_methods+ #' analyze("AGE") %>%
|
||
| 2217 | +350 |
- setMethod(+ #' split_rows_by("RACE", nested = FALSE, split_fun = drop_split_levels) %>%
|
||
| 2218 | +351 |
- "col_extra_args", "LayoutColLeaf",+ #' analyze("AGE")
|
||
| 2219 | +352 |
- function(obj, df) {
+ #' lyt5 |
||
| 2220 | -! | +|||
| 353 | +
- if (!is.null(df)) {
+ #' |
|||
| 2221 | -! | +|||
| 354 | +
- warning("Ignoring df argument and returning already calculated extra arguments")
+ #' tbl5 <- build_table(lyt5, DM) |
|||
| 2222 | +355 |
- }+ #' tbl5 |
||
| 2223 | +356 |
-
+ #' |
||
| 2224 | -! | +|||
| 357 | +
- get_pos_extra(pos = tree_pos(obj))+ #' @author Gabriel Becker |
|||
| 2225 | +358 |
- }+ #' @export |
||
| 2226 | +359 |
- )+ split_cols_by <- function(lyt, |
||
| 2227 | +360 |
-
+ var, |
||
| 2228 | +361 |
- #' @seealso [facet_colcount()]+ labels_var = var, |
||
| 2229 | +362 |
- #' @export+ split_label = var, |
||
| 2230 | +363 |
- #' @rdname col_accessors+ split_fun = NULL, |
||
| 2231 | -1993x | +|||
| 364 | +
- setGeneric("col_counts", function(obj, path = NULL) standardGeneric("col_counts"))
+ format = NULL, |
|||
| 2232 | +365 |
-
+ nested = TRUE, |
||
| 2233 | +366 |
- #' @export+ child_labels = c("default", "visible", "hidden"),
|
||
| 2234 | +367 |
- #' @rdname col_accessors+ extra_args = list(), |
||
| 2235 | +368 |
- setMethod(+ ref_group = NULL, |
||
| 2236 | +369 |
- "col_counts", "InstantiatedColumnInfo",+ show_colcounts = FALSE, |
||
| 2237 | +370 |
- function(obj, path = NULL) {
+ colcount_format = NULL) { ## ,
|
||
| 2238 | -1978x | +371 | +287x |
- if (is.null(path)) {
+ if (is.null(ref_group)) {
|
| 2239 | -1977x | +372 | +278x |
- lfs <- collect_leaves(coltree(obj))+ spl <- VarLevelSplit( |
| 2240 | -1977x | +373 | +278x |
- ret <- vapply(lfs, facet_colcount, 1L, path = NULL)+ var = var, |
| 2241 | -+ | |||
| 374 | +278x |
- } else {
+ split_label = split_label, |
||
| 2242 | -1x | +375 | +278x |
- ret <- facet_colcount(obj, path)+ labels_var = labels_var, |
| 2243 | -+ | |||
| 376 | +278x |
- }+ split_format = format, |
||
| 2244 | -+ | |||
| 377 | +278x |
- ## required for strict backwards compatibility,+ child_labels = child_labels, |
||
| 2245 | -+ | |||
| 378 | +278x |
- ## even though its undesirable behavior.+ split_fun = split_fun, |
||
| 2246 | -1978x | +379 | +278x |
- unname(ret)+ extra_args = extra_args, |
| 2247 | -+ | |||
| 380 | +278x |
- }+ show_colcounts = show_colcounts, |
||
| 2248 | -+ | |||
| 381 | +278x |
- )+ colcount_format = colcount_format |
||
| 2249 | +382 |
-
+ ) |
||
| 2250 | +383 |
- #' @export+ } else {
|
||
| 2251 | -+ | |||
| 384 | +9x |
- #' @rdname col_accessors+ spl <- VarLevWBaselineSplit( |
||
| 2252 | -+ | |||
| 385 | +9x |
- setMethod(+ var = var, |
||
| 2253 | -+ | |||
| 386 | +9x |
- "col_counts", "VTableNodeInfo",+ ref_group = ref_group, |
||
| 2254 | -15x | +387 | +9x |
- function(obj, path = NULL) col_counts(col_info(obj), path = path)+ split_label = split_label, |
| 2255 | -+ | |||
| 388 | +9x |
- )+ split_fun = split_fun, |
||
| 2256 | -+ | |||
| 389 | +9x |
-
+ labels_var = labels_var, |
||
| 2257 | -+ | |||
| 390 | +9x |
- #' @export+ split_format = format, |
||
| 2258 | -+ | |||
| 391 | +9x |
- #' @rdname col_accessors+ show_colcounts = show_colcounts, |
||
| 2259 | -14x | +392 | +9x |
- setGeneric("col_counts<-", function(obj, path = NULL, value) standardGeneric("col_counts<-"))
+ colcount_format = colcount_format |
| 2260 | +393 |
-
+ ) |
||
| 2261 | +394 |
- #' @export+ } |
||
| 2262 | -+ | |||
| 395 | +287x |
- #' @rdname col_accessors+ pos <- next_cpos(lyt, nested) |
||
| 2263 | -+ | |||
| 396 | +287x |
- setMethod(+ split_cols(lyt, spl, pos) |
||
| 2264 | +397 |
- "col_counts<-", "InstantiatedColumnInfo",+ } |
||
| 2265 | +398 |
- function(obj, path = NULL, value) {
+
|
||
| 2266 | +399 |
- ## obj@counts[.path_to_pos(path, obj, cols = TRUE)] <- value+ ## .tl_indent ==== |
||
| 2267 | +400 |
- ## obj+ |
||
| 2268 | -9x | +401 | +51x |
- if (!is.null(path)) {
- |
-
| 2269 | -1x | -
- all_paths <- list(path)+ setGeneric(".tl_indent_inner", function(lyt) standardGeneric(".tl_indent_inner"))
|
||
| 2270 | +402 |
- } else {
+
|
||
| 2271 | -8x | +|||
| 403 | +
- all_paths <- make_col_df(obj, visible_only = TRUE)$path+ setMethod( |
|||
| 2272 | +404 |
- }+ ".tl_indent_inner", "PreDataTableLayouts", |
||
| 2273 | -9x | -
- if (length(value) != length(all_paths)) {
- |
- ||
| 2274 | -! | -
- stop(- |
- ||
| 2275 | -! | -
- "Got ", length(value), " values for ",- |
- ||
| 2276 | -! | -
- length(all_paths), " column paths",- |
- ||
| 2277 | -! | +405 | +17x |
- if (is.null(path)) " (from path = NULL)",+ function(lyt) .tl_indent_inner(rlayout(lyt)) |
| 2278 | +406 |
- "."+ ) |
||
| 2279 | +407 |
- )+ setMethod( |
||
| 2280 | +408 |
- }+ ".tl_indent_inner", "PreDataRowLayout", |
||
| 2281 | -9x | +|||
| 409 | +
- ctree <- coltree(obj)+ function(lyt) {
|
|||
| 2282 | -9x | +410 | +17x |
- for (i in seq_along(all_paths)) {
+ if (length(lyt) == 0 || length(lyt[[1]]) == 0) {
|
| 2283 | -73x | +|||
| 411 | +! |
- facet_colcount(ctree, all_paths[[i]]) <- value[i]+ 0L |
||
| 2284 | +412 |
- }+ } else {
|
||
| 2285 | -9x | +413 | +17x |
- coltree(obj) <- ctree+ .tl_indent_inner(lyt[[length(lyt)]]) |
| 2286 | -9x | +|||
| 414 | +
- obj+ } |
|||
| 2287 | +415 |
} |
||
| 2288 | +416 |
) |
||
| 2289 | +417 | |||
| 2290 | +418 |
- #' @export+ setMethod( |
||
| 2291 | +419 |
- #' @rdname col_accessors+ ".tl_indent_inner", "SplitVector", |
||
| 2292 | +420 |
- setMethod(+ function(lyt) {
|
||
| 2293 | -+ | |||
| 421 | +17x |
- "col_counts<-", "VTableNodeInfo",+ sum(vapply(lyt, function(x) label_position(x) == "topleft", TRUE)) - 1L |
||
| 2294 | +422 |
- function(obj, path = NULL, value) {
+ } |
||
| 2295 | -5x | +|||
| 423 | +
- cinfo <- col_info(obj)+ ) ## length(lyt) - 1L) |
|||
| 2296 | -5x | +|||
| 424 | +
- col_counts(cinfo, path = path) <- value+ |
|||
| 2297 | -5x | +|||
| 425 | +
- col_info(obj) <- cinfo+ .tl_indent <- function(lyt, nested = TRUE) {
|
|||
| 2298 | -5x | +426 | +17x |
- obj+ if (!nested) {
|
| 2299 | -+ | |||
| 427 | +! |
- }+ 0L |
||
| 2300 | +428 |
- )+ } else {
|
||
| 2301 | -+ | |||
| 429 | +17x |
-
+ .tl_indent_inner(lyt) |
||
| 2302 | +430 |
- #' @export+ } |
||
| 2303 | +431 |
- #' @rdname col_accessors- |
- ||
| 2304 | -1573x | -
- setGeneric("col_total", function(obj) standardGeneric("col_total"))
+ } |
||
| 2305 | +432 | |||
| 2306 | +433 |
- #' @export+ #' Add rows according to levels of a variable |
||
| 2307 | +434 |
- #' @rdname col_accessors+ #' |
||
| 2308 | +435 |
- setMethod(+ #' @inheritParams lyt_args |
||
| 2309 | +436 |
- "col_total", "InstantiatedColumnInfo",- |
- ||
| 2310 | -1572x | -
- function(obj) obj@total_count+ #' |
||
| 2311 | +437 |
- )+ #' @inherit split_cols_by return |
||
| 2312 | +438 |
-
+ #' |
||
| 2313 | +439 |
- #' @export+ #' @inheritSection custom_split_funs Custom Splitting Function Details |
||
| 2314 | +440 |
- #' @rdname col_accessors+ #' |
||
| 2315 | +441 |
- setMethod(+ #' @note |
||
| 2316 | +442 |
- "col_total", "VTableNodeInfo",+ #' If `var` is a factor with empty unobserved levels and `labels_var` is specified, it must also be a factor |
||
| 2317 | -1x | +|||
| 443 | +
- function(obj) col_total(col_info(obj))+ #' with the same number of levels as `var`. Currently the error that occurs when this is not the case is not very |
|||
| 2318 | +444 |
- )+ #' informative, but that will change in the future. |
||
| 2319 | +445 |
-
+ #' |
||
| 2320 | +446 |
- #' @export+ #' @examples |
||
| 2321 | +447 |
- #' @rdname col_accessors+ #' lyt <- basic_table() %>% |
||
| 2322 | -2x | +|||
| 448 | +
- setGeneric("col_total<-", function(obj, value) standardGeneric("col_total<-"))
+ #' split_cols_by("ARM") %>%
|
|||
| 2323 | +449 |
-
+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
|
||
| 2324 | +450 |
- #' @export+ #' analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
|
||
| 2325 | +451 |
- #' @rdname col_accessors+ #' |
||
| 2326 | +452 |
- setMethod(+ #' tbl <- build_table(lyt, DM) |
||
| 2327 | +453 |
- "col_total<-", "InstantiatedColumnInfo",+ #' tbl |
||
| 2328 | +454 |
- function(obj, value) {
+ #' |
||
| 2329 | +455 |
- ## all methods funnel to this one so ensure integer-ness here.+ #' lyt2 <- basic_table() %>% |
||
| 2330 | -1x | +|||
| 456 | +
- obj@total_count <- as.integer(value)+ #' split_cols_by("ARM") %>%
|
|||
| 2331 | -1x | +|||
| 457 | +
- obj+ #' split_rows_by("RACE") %>%
|
|||
| 2332 | +458 |
- }+ #' analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
|
||
| 2333 | +459 |
- )+ #' |
||
| 2334 | +460 |
-
+ #' tbl2 <- build_table(lyt2, DM) |
||
| 2335 | +461 |
- #' @export+ #' tbl2 |
||
| 2336 | +462 |
- #' @rdname col_accessors+ #' |
||
| 2337 | +463 |
- setMethod(+ #' lyt3 <- basic_table() %>% |
||
| 2338 | +464 |
- "col_total<-", "VTableNodeInfo",+ #' split_cols_by("ARM") %>%
|
||
| 2339 | +465 |
- function(obj, value) {
+ #' split_cols_by("SEX") %>%
|
||
| 2340 | -1x | +|||
| 466 | +
- cinfo <- col_info(obj)+ #' summarize_row_groups(label_fstr = "Overall (N)") %>% |
|||
| 2341 | -1x | +|||
| 467 | +
- col_total(cinfo) <- value+ #' split_rows_by("RACE",
|
|||
| 2342 | -1x | +|||
| 468 | +
- col_info(obj) <- cinfo+ #' split_label = "Ethnicity", labels_var = "ethn_lab", |
|||
| 2343 | -1x | +|||
| 469 | +
- obj+ #' split_fun = drop_split_levels |
|||
| 2344 | +470 |
- }+ #' ) %>% |
||
| 2345 | +471 |
- )+ #' summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
|
||
| 2346 | +472 |
-
+ #' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
|
||
| 2347 | +473 |
- #' @rdname int_methods+ #' |
||
| 2348 | -18620x | +|||
| 474 | +
- setGeneric("disp_ccounts", function(obj) standardGeneric("disp_ccounts"))
+ #' lyt3 |
|||
| 2349 | +475 |
-
+ #' |
||
| 2350 | +476 |
- #' @rdname int_methods+ #' @examplesIf require(dplyr) |
||
| 2351 | +477 |
- setMethod(+ #' library(dplyr) |
||
| 2352 | +478 |
- "disp_ccounts", "VTableTree",+ #' |
||
| 2353 | -306x | +|||
| 479 | +
- function(obj) disp_ccounts(col_info(obj))+ #' DM2 <- DM %>% |
|||
| 2354 | +480 |
- )+ #' filter(SEX %in% c("M", "F")) %>%
|
||
| 2355 | +481 |
-
+ #' mutate( |
||
| 2356 | +482 |
- #' @rdname int_methods+ #' SEX = droplevels(SEX), |
||
| 2357 | +483 |
- setMethod(+ #' gender_lab = c( |
||
| 2358 | +484 |
- "disp_ccounts", "InstantiatedColumnInfo",+ #' "F" = "Female", "M" = "Male", |
||
| 2359 | -603x | +|||
| 485 | +
- function(obj) obj@display_columncounts+ #' "U" = "Unknown", |
|||
| 2360 | +486 |
- )+ #' "UNDIFFERENTIATED" = "Undifferentiated" |
||
| 2361 | +487 |
-
+ #' )[SEX], |
||
| 2362 | +488 |
- #' @rdname int_methods+ #' ethn_lab = c( |
||
| 2363 | +489 |
- setMethod(+ #' "ASIAN" = "Asian", |
||
| 2364 | +490 |
- "disp_ccounts", "PreDataTableLayouts",+ #' "BLACK OR AFRICAN AMERICAN" = "Black or African American", |
||
| 2365 | -958x | +|||
| 491 | +
- function(obj) disp_ccounts(clayout(obj))+ #' "WHITE" = "White", |
|||
| 2366 | +492 |
- )+ #' "AMERICAN INDIAN OR ALASKA NATIVE" = "American Indian or Alaska Native", |
||
| 2367 | +493 |
-
+ #' "MULTIPLE" = "Multiple", |
||
| 2368 | +494 |
- #' @rdname int_methods+ #' "NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER" = |
||
| 2369 | +495 |
- setMethod(+ #' "Native Hawaiian or Other Pacific Islander", |
||
| 2370 | +496 |
- "disp_ccounts", "PreDataColLayout",+ #' "OTHER" = "Other", "UNKNOWN" = "Unknown" |
||
| 2371 | -1278x | +|||
| 497 | +
- function(obj) obj@display_columncounts+ #' )[RACE] |
|||
| 2372 | +498 |
- )+ #' ) |
||
| 2373 | +499 |
-
+ #' |
||
| 2374 | +500 |
- #' @rdname int_methods+ #' tbl3 <- build_table(lyt3, DM2) |
||
| 2375 | +501 |
- setMethod(+ #' tbl3 |
||
| 2376 | +502 |
- "disp_ccounts", "LayoutColTree",+ #' |
||
| 2377 | -717x | +|||
| 503 | +
- function(obj) obj@display_columncounts+ #' @author Gabriel Becker |
|||
| 2378 | +504 |
- )+ #' @export |
||
| 2379 | +505 |
-
+ split_rows_by <- function(lyt, |
||
| 2380 | +506 |
- #' @rdname int_methods+ var, |
||
| 2381 | +507 |
- setMethod(+ labels_var = var, |
||
| 2382 | +508 |
- "disp_ccounts", "LayoutColLeaf",+ split_label = var, |
||
| 2383 | -13385x | +|||
| 509 | +
- function(obj) obj@display_columncounts+ split_fun = NULL, |
|||
| 2384 | +510 |
- )+ format = NULL, |
||
| 2385 | +511 |
-
+ na_str = NA_character_, |
||
| 2386 | +512 |
- #' @rdname int_methods+ nested = TRUE, |
||
| 2387 | +513 |
- setMethod(+ child_labels = c("default", "visible", "hidden"),
|
||
| 2388 | +514 |
- "disp_ccounts", "Split",+ label_pos = "hidden", |
||
| 2389 | -1226x | +|||
| 515 | +
- function(obj) obj@child_show_colcounts+ indent_mod = 0L, |
|||
| 2390 | +516 |
- )+ page_by = FALSE, |
||
| 2391 | +517 |
-
+ page_prefix = split_label, |
||
| 2392 | +518 |
- #' @rdname int_methods+ section_div = NA_character_) {
|
||
| 2393 | -2237x | -
- setGeneric("disp_ccounts<-", function(obj, value) standardGeneric("disp_ccounts<-"))
- |
- ||
| 2394 | -+ | 519 | +256x |
-
+ label_pos <- match.arg(label_pos, label_pos_values) |
| 2395 | -+ | |||
| 520 | +256x |
- #' @rdname int_methods+ child_labels <- match.arg(child_labels) |
||
| 2396 | -+ | |||
| 521 | +256x |
- setMethod(+ spl <- VarLevelSplit( |
||
| 2397 | -+ | |||
| 522 | +256x |
- "disp_ccounts<-", "VTableTree",+ var = var, |
||
| 2398 | -+ | |||
| 523 | +256x |
- function(obj, value) {
+ split_label = split_label, |
||
| 2399 | -1x | +524 | +256x |
- cinfo <- col_info(obj)+ label_pos = label_pos, |
| 2400 | -1x | +525 | +256x |
- disp_ccounts(cinfo) <- value+ labels_var = labels_var, |
| 2401 | -1x | +526 | +256x |
- col_info(obj) <- cinfo+ split_fun = split_fun, |
| 2402 | -1x | +527 | +256x |
- obj+ split_format = format, |
| 2403 | -+ | |||
| 528 | +256x |
- }+ split_na_str = na_str, |
||
| 2404 | -+ | |||
| 529 | +256x |
- )+ child_labels = child_labels, |
||
| 2405 | -+ | |||
| 530 | +256x |
-
+ indent_mod = indent_mod, |
||
| 2406 | -+ | |||
| 531 | +256x |
- #' @rdname int_methods+ page_prefix = if (page_by) page_prefix else NA_character_, |
||
| 2407 | -+ | |||
| 532 | +256x |
- setMethod(+ section_div = section_div |
||
| 2408 | +533 |
- "disp_ccounts<-", "InstantiatedColumnInfo",+ ) |
||
| 2409 | +534 |
- function(obj, value) {
+
|
||
| 2410 | -2x | +535 | +256x |
- obj@display_columncounts <- value+ pos <- next_rpos(lyt, nested) |
| 2411 | -2x | +536 | +256x |
- obj+ ret <- split_rows(lyt, spl, pos) |
| 2412 | +537 |
- }+ + |
+ ||
| 538 | +254x | +
+ ret |
||
| 2413 | +539 |
- )+ } |
||
| 2414 | +540 | |||
| 2415 | +541 |
- #' @rdname int_methods+ #' Associate multiple variables with columns |
||
| 2416 | +542 |
- setMethod(+ #' |
||
| 2417 | +543 |
- "disp_ccounts<-", "PreDataColLayout",+ #' In some cases, the variable to be ultimately analyzed is most naturally defined on a column, not a row, basis. |
||
| 2418 | +544 |
- function(obj, value) {
+ #' When we need columns to reflect different variables entirely, rather than different levels of a single |
||
| 2419 | -325x | +|||
| 545 | +
- obj@display_columncounts <- value+ #' variable, we use `split_cols_by_multivar`. |
|||
| 2420 | -325x | +|||
| 546 | +
- obj+ #' |
|||
| 2421 | +547 |
- }+ #' @inheritParams lyt_args |
||
| 2422 | +548 |
- )+ #' |
||
| 2423 | +549 |
-
+ #' @inherit split_cols_by return |
||
| 2424 | +550 |
- #' @rdname int_methods+ #' |
||
| 2425 | +551 |
- setMethod(+ #' @seealso [analyze_colvars()] |
||
| 2426 | +552 |
- "disp_ccounts<-", "LayoutColTree",+ #' |
||
| 2427 | +553 |
- function(obj, value) {
+ #' @examplesIf require(dplyr) |
||
| 2428 | -321x | +|||
| 554 | +
- obj@display_columncounts <- value+ #' library(dplyr) |
|||
| 2429 | -321x | +|||
| 555 | +
- obj+ #' |
|||
| 2430 | +556 |
- }+ #' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n())) |
||
| 2431 | +557 |
- )+ #' |
||
| 2432 | +558 |
-
+ #' ## toy example where we take the mean of the first variable and the |
||
| 2433 | +559 |
- #' @rdname int_methods+ #' ## count of >.5 for the second. |
||
| 2434 | +560 |
- setMethod(+ #' colfuns <- list( |
||
| 2435 | +561 |
- "disp_ccounts<-", "LayoutColLeaf",+ #' function(x) in_rows(mean = mean(x), .formats = "xx.x"), |
||
| 2436 | +562 |
- function(obj, value) {
+ #' function(x) in_rows("# x > 5" = sum(x > .5), .formats = "xx")
|
||
| 2437 | -1263x | +|||
| 563 | +
- obj@display_columncounts <- value+ #' ) |
|||
| 2438 | -1263x | +|||
| 564 | +
- obj+ #' |
|||
| 2439 | +565 |
- }+ #' lyt <- basic_table() %>% |
||
| 2440 | +566 |
- )+ #' split_cols_by("ARM") %>%
|
||
| 2441 | +567 |
-
+ #' split_cols_by_multivar(c("value", "pctdiff")) %>%
|
||
| 2442 | +568 |
- #' @rdname int_methods+ #' split_rows_by("RACE",
|
||
| 2443 | +569 |
- setMethod(+ #' split_label = "ethnicity", |
||
| 2444 | +570 |
- "disp_ccounts<-", "PreDataTableLayouts",+ #' split_fun = drop_split_levels |
||
| 2445 | +571 |
- function(obj, value) {
+ #' ) %>% |
||
| 2446 | -325x | +|||
| 572 | +
- clyt <- clayout(obj)+ #' summarize_row_groups() %>% |
|||
| 2447 | -325x | +|||
| 573 | +
- disp_ccounts(clyt) <- value+ #' analyze_colvars(afun = colfuns) |
|||
| 2448 | -325x | +|||
| 574 | +
- clayout(obj) <- clyt+ #' lyt |
|||
| 2449 | -325x | +|||
| 575 | +
- obj+ #' |
|||
| 2450 | +576 |
- }+ #' tbl <- build_table(lyt, ANL) |
||
| 2451 | +577 |
- )+ #' tbl |
||
| 2452 | +578 |
-
+ #' |
||
| 2453 | +579 |
-
+ #' @author Gabriel Becker |
||
| 2454 | +580 |
- ## this is a horrible hack but when we have non-nested siblings at the top level+ #' @export |
||
| 2455 | +581 |
- ## the beginning of the "path <-> position" relationship breaks down.+ split_cols_by_multivar <- function(lyt, |
||
| 2456 | +582 |
- ## we probably *should* have e.g., c("root", "top_level_splname_1",
+ vars, |
||
| 2457 | +583 |
- ## "top_level_splname_1, "top_level_splname_1_value", ...)+ split_fun = NULL, |
||
| 2458 | +584 |
- ## but its pretty clear why no one will be happy with that, I think+ varlabels = vars, |
||
| 2459 | +585 |
- ## so we punt on the problem for now with an explicit workaround+ varnames = NULL, |
||
| 2460 | +586 |
- ##+ nested = TRUE, |
||
| 2461 | +587 |
- ## those first non-nested siblings currently have (incorrect)+ extra_args = list(), |
||
| 2462 | +588 |
- ## empty tree_pos elements so we just look at the obj_name+ ## for completeness even though it doesn't make sense |
||
| 2463 | +589 |
-
+ show_colcounts = FALSE, |
||
| 2464 | +590 |
- pos_singleton_path <- function(obj) {
+ colcount_format = NULL) {
|
||
| 2465 | -5897x | +591 | +24x |
- pos <- tree_pos(obj)+ spl <- MultiVarSplit( |
| 2466 | -5897x | +592 | +24x |
- splvals <- pos_splvals(pos)+ vars = vars, split_label = "", |
| 2467 | -5897x | +593 | +24x |
- length(splvals) == 0 ||+ varlabels = varlabels, |
| 2468 | -5897x | +594 | +24x |
- (length(splvals) == 1 && is.na(unlist(value_names(splvals))))+ varnames = varnames, |
| 2469 | -+ | |||
| 595 | +24x |
- }+ split_fun = split_fun, |
||
| 2470 | -+ | |||
| 596 | +24x | - - | -||
| 2471 | -- |
- ## close to a duplicate of tt_at_path, but... not quite :(- |
- ||
| 2472 | -- |
- #' @rdname int_methods- |
- ||
| 2473 | -- |
- coltree_at_path <- function(obj, path, ...) {
+ extra_args = extra_args, |
||
| 2474 | -2978x | +597 | +24x |
- if (length(path) == 0) {
+ show_colcounts = show_colcounts, |
| 2475 | -644x | +598 | +24x |
- return(obj)+ colcount_format = colcount_format |
| 2476 | +599 |
- }- |
- ||
| 2477 | -2334x | -
- stopifnot(+ ) |
||
| 2478 | -2334x | +600 | +24x |
- is(path, "character"),+ pos <- next_cpos(lyt, nested) |
| 2479 | -2334x | +601 | +24x |
- length(path) > 0+ split_cols(lyt, spl, pos) |
| 2480 | +602 |
- )- |
- ||
| 2481 | -2334x | -
- if (any(grepl("@content", path, fixed = TRUE))) {
- |
- ||
| 2482 | -! | -
- stop("@content token is not valid for column paths.")
+ } |
||
| 2483 | +603 |
- }+ |
||
| 2484 | +604 | - - | -||
| 2485 | -2334x | -
- cur <- obj- |
- ||
| 2486 | -2334x | -
- curpath <- pos_to_path(tree_pos(obj)) # path- |
- ||
| 2487 | -2334x | -
- num_consume_path <- 2- |
- ||
| 2488 | -2334x | -
- while (!identical(curpath, path) && !is(cur, "LayoutColLeaf")) { # length(curpath) > 0) {
- |
- ||
| 2489 | -4071x | -
- kids <- tree_children(cur)- |
- ||
| 2490 | -4071x | -
- kidmatch <- find_kid_path_match(kids, path)+ #' Associate multiple variables with rows |
||
| 2491 | -4071x | +|||
| 605 | +
- if (length(kidmatch) == 0) {
+ #' |
|||
| 2492 | -! | +|||
| 606 | +
- stop(+ #' When we need rows to reflect different variables rather than different |
|||
| 2493 | -! | +|||
| 607 | +
- "unable to match full path: ", paste(path, sep = "->"),+ #' levels of a single variable, we use `split_rows_by_multivar`. |
|||
| 2494 | -! | +|||
| 608 | +
- "\n path of last match: ", paste(curpath, sep = "->")+ #' |
|||
| 2495 | +609 |
- )+ #' @inheritParams lyt_args |
||
| 2496 | +610 |
- }+ #' |
||
| 2497 | -4071x | +|||
| 611 | +
- cur <- kids[[kidmatch]]+ #' @inherit split_rows_by return |
|||
| 2498 | -4071x | +|||
| 612 | +
- curpath <- pos_to_path(tree_pos(cur))+ #' |
|||
| 2499 | +613 |
- }+ #' @seealso [split_rows_by()] for typical row splitting, and [split_cols_by_multivar()] to perform the same type of |
||
| 2500 | -2334x | +|||
| 614 | +
- cur+ #' split on a column basis. |
|||
| 2501 | +615 |
- }+ #' |
||
| 2502 | +616 |
-
+ #' @examples |
||
| 2503 | +617 |
- find_kid_path_match <- function(kids, path) {
+ #' lyt <- basic_table() %>% |
||
| 2504 | -8138x | +|||
| 618 | +
- if (length(kids) == 0) {
+ #' split_cols_by("ARM") %>%
|
|||
| 2505 | -! | +|||
| 619 | +
- return(integer())+ #' split_rows_by_multivar(c("SEX", "STRATA1")) %>%
|
|||
| 2506 | +620 |
- }+ #' summarize_row_groups() %>% |
||
| 2507 | -8138x | +|||
| 621 | +
- kidpaths <- lapply(kids, function(k) pos_to_path(tree_pos(k)))+ #' analyze(c("AGE", "SEX"))
|
|||
| 2508 | +622 |
-
+ #' |
||
| 2509 | -8138x | +|||
| 623 | +
- matches <- vapply(kidpaths, function(kpth) identical(path[seq_along(kpth)], kpth), NA)+ #' tbl <- build_table(lyt, DM) |
|||
| 2510 | -8138x | +|||
| 624 | +
- firstkidpos <- tree_pos(kids[[1]])+ #' tbl |
|||
| 2511 | -8138x | +|||
| 625 | +
- if (all(matches) && pos_singleton_path(kids[[1]])) {
+ #' |
|||
| 2512 | -660x | +|||
| 626 | +
- kidpaths <- lapply(seq_along(kidpaths), function(i) c(kidpaths[[i]], obj_name(kids[[i]])))+ #' @export |
|||
| 2513 | -660x | +|||
| 627 | +
- matches <- vapply(kidpaths, function(kpth) identical(path[seq_along(kpth)], kpth), NA)+ split_rows_by_multivar <- function(lyt, |
|||
| 2514 | +628 |
- }+ vars, |
||
| 2515 | -8138x | +|||
| 629 | +
- which(matches)+ split_fun = NULL, |
|||
| 2516 | +630 |
- }+ split_label = "", |
||
| 2517 | +631 |
-
+ varlabels = vars, |
||
| 2518 | +632 |
-
+ format = NULL, |
||
| 2519 | +633 |
- ## almost a duplicate of recursive_replace, but I spent a bunch+ na_str = NA_character_, |
||
| 2520 | +634 |
- ## of time ramming my head against the different way pathing happens+ nested = TRUE, |
||
| 2521 | +635 |
- ## in column space (unfortunately) before giving up building+ child_labels = c("default", "visible", "hidden"),
|
||
| 2522 | +636 |
- ## coltree_at_path around recursive_replace, so here we are.+ indent_mod = 0L, |
||
| 2523 | +637 |
-
+ section_div = NA_character_, |
||
| 2524 | +638 |
- ct_recursive_replace <- function(ctree, path, value, pos = 1) {
+ extra_args = list()) {
|
||
| 2525 | -6399x | +639 | +3x |
- pos <- tree_pos(ctree)+ child_labels <- match.arg(child_labels) |
| 2526 | -6399x | +640 | +3x |
- curpth <- pos_to_path(pos)+ spl <- MultiVarSplit( |
| 2527 | -6399x | +641 | +3x |
- if (identical(path, curpth)) {
+ vars = vars, split_label = split_label, varlabels, |
| 2528 | -2332x | +642 | +3x |
- return(value)+ split_format = format, |
| 2529 | -4067x | -
- } else if (is(ctree, "LayoutColLeaf")) {
- |
- ||
| 2530 | -! | -
- stop(- |
- ||
| 2531 | -! | -
- "unable to match full path: ", paste(path, sep = "->"),- |
- ||
| 2532 | -! | +643 | +3x |
- "\n path at leaf: ", paste(curpth, sep = "->")+ split_na_str = na_str, |
| 2533 | -+ | |||
| 644 | +3x |
- )+ child_labels = child_labels, |
||
| 2534 | -+ | |||
| 645 | +3x |
- }+ indent_mod = indent_mod, |
||
| 2535 | -4067x | +646 | +3x |
- kids <- tree_children(ctree)+ split_fun = split_fun, |
| 2536 | -4067x | +647 | +3x |
- kids_singl <- pos_singleton_path(kids[[1]])+ section_div = section_div, |
| 2537 | -4067x | +648 | +3x |
- kidind <- find_kid_path_match(kids, path)+ extra_args = extra_args |
| 2538 | +649 |
-
+ ) |
||
| 2539 | -4067x | -
- if (length(kidind) == 0) {
- |
- ||
| 2540 | -! | +650 | +3x |
- stop("Path appears invalid for this tree at step ", path[1])
+ pos <- next_rpos(lyt, nested) |
| 2541 | -4067x | +651 | +3x |
- } else if (length(kidind) > 1) {
+ split_rows(lyt, spl, pos) |
| 2542 | -! | +|||
| 652 | +
- stop(+ } |
|||
| 2543 | -! | +|||
| 653 | +
- "singleton step (root, cbind_root, etc) in path appears to have matched multiple children. ",+ |
|||
| 2544 | -! | +|||
| 654 | +
- "This shouldn't happen, please contact the maintainers."+ #' Split on static or dynamic cuts of the data |
|||
| 2545 | +655 |
- )+ #' |
||
| 2546 | +656 |
- }+ #' Create columns (or row splits) based on values (such as quartiles) of `var`. |
||
| 2547 | +657 |
-
+ #' |
||
| 2548 | -4067x | +|||
| 658 | +
- kids[[kidind]] <- ct_recursive_replace(+ #' @inheritParams lyt_args |
|||
| 2549 | -4067x | +|||
| 659 | +
- kids[[kidind]],+ #' |
|||
| 2550 | -4067x | +|||
| 660 | +
- path, value+ #' @details For dynamic cuts, the cut is transformed into a static cut by [build_table()] *based on the full dataset*, |
|||
| 2551 | +661 |
- )+ #' before proceeding. Thus even when nested within another split in column/row space, the resulting split will reflect |
||
| 2552 | -4067x | +|||
| 662 | +
- tree_children(ctree) <- kids+ #' the overall values (e.g., quartiles) in the dataset, NOT the values for subset it is nested under. |
|||
| 2553 | -4067x | +|||
| 663 | +
- ctree+ #' |
|||
| 2554 | +664 |
- }+ #' @inherit split_cols_by return |
||
| 2555 | +665 |
-
+ #' |
||
| 2556 | +666 |
- `coltree_at_path<-` <- function(obj, path, value) {
+ #' @examplesIf require(dplyr) |
||
| 2557 | -2332x | +|||
| 667 | +
- obj <- ct_recursive_replace(obj, path, value)+ #' library(dplyr) |
|||
| 2558 | -2332x | +|||
| 668 | +
- obj+ #' |
|||
| 2559 | +669 |
- }+ #' # split_cols_by_cuts |
||
| 2560 | +670 |
-
+ #' lyt <- basic_table() %>% |
||
| 2561 | +671 |
- #' Set visibility of column counts for a group of sibling facets+ #' split_cols_by("ARM") %>%
|
||
| 2562 | +672 |
- #'+ #' split_cols_by_cuts("AGE",
|
||
| 2563 | +673 |
- #' @inheritParams gen_args+ #' split_label = "Age", |
||
| 2564 | +674 |
- #' @param path (`character`)\cr the path *to the parent of the+ #' cuts = c(0, 25, 35, 1000), |
||
| 2565 | +675 |
- #' desired siblings*. The last element in the path should+ #' cutlabels = c("young", "medium", "old")
|
||
| 2566 | +676 |
- #' be a split name.+ #' ) %>% |
||
| 2567 | +677 |
- #' @return obj, modified with the desired column count.+ #' analyze(c("BMRKR2", "STRATA2")) %>%
|
||
| 2568 | +678 |
- #' display behavior+ #' append_topleft("counts")
|
||
| 2569 | +679 |
#' |
||
| 2570 | +680 |
- #' @seealso [colcount_visible()]+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 2571 | +681 |
- #'+ #' tbl |
||
| 2572 | +682 |
- #' @export+ #' |
||
| 2573 | +683 |
- `facet_colcounts_visible<-` <- function(obj, path, value) {
- |
- ||
| 2574 | -1x | -
- coldf <- make_col_df(obj, visible_only = FALSE)+ #' # split_rows_by_cuts |
||
| 2575 | -1x | +|||
| 684 | +
- allpaths <- coldf$path+ #' lyt2 <- basic_table() %>% |
|||
| 2576 | -1x | +|||
| 685 | +
- lenpath <- length(path)+ #' split_cols_by("ARM") %>%
|
|||
| 2577 | -1x | +|||
| 686 | +
- match_paths <- vapply(allpaths, function(path_i) {
+ #' split_rows_by_cuts("AGE",
|
|||
| 2578 | -10x | +|||
| 687 | +
- (length(path_i) == lenpath + 1) &&+ #' split_label = "Age", |
|||
| 2579 | -10x | +|||
| 688 | +
- (all(head(path_i, -1) == path))+ #' cuts = c(0, 25, 35, 1000), |
|||
| 2580 | -1x | +|||
| 689 | +
- }, TRUE)+ #' cutlabels = c("young", "medium", "old")
|
|||
| 2581 | -1x | +|||
| 690 | +
- for (curpath in allpaths[match_paths]) {
+ #' ) %>% |
|||
| 2582 | -2x | +|||
| 691 | +
- colcount_visible(obj, curpath) <- value+ #' analyze(c("BMRKR2", "STRATA2")) %>%
|
|||
| 2583 | +692 |
- }+ #' append_topleft("counts")
|
||
| 2584 | -1x | +|||
| 693 | +
- obj+ #' |
|||
| 2585 | +694 |
- }+ #' |
||
| 2586 | +695 |
-
+ #' tbl2 <- build_table(lyt2, ex_adsl) |
||
| 2587 | +696 |
- #' Get or set column count for a facet in column space+ #' tbl2 |
||
| 2588 | +697 |
#' |
||
| 2589 | +698 |
- #' @inheritParams gen_args+ #' # split_cols_by_quartiles |
||
| 2590 | +699 |
- #' @param path character. This path must end on a+ #' |
||
| 2591 | +700 |
- #' split value, e.g., the level of a categorical variable+ #' lyt3 <- basic_table() %>% |
||
| 2592 | +701 |
- #' that was split on in column space, but it need not+ #' split_cols_by("ARM") %>%
|
||
| 2593 | +702 |
- #' be the path to an individual column.+ #' split_cols_by_quartiles("AGE", split_label = "Age") %>%
|
||
| 2594 | +703 |
- #'+ #' analyze(c("BMRKR2", "STRATA2")) %>%
|
||
| 2595 | +704 |
- #' @return for `facet_colcount` the current count associated+ #' append_topleft("counts")
|
||
| 2596 | +705 |
- #' with that facet in column space, for `facet_colcount<-`,+ #' |
||
| 2597 | +706 |
- #' `obj` modified with the new column count for the specified+ #' tbl3 <- build_table(lyt3, ex_adsl) |
||
| 2598 | +707 |
- #' facet.+ #' tbl3 |
||
| 2599 | +708 |
#' |
||
| 2600 | +709 |
- #' @note Updating a lower-level (more specific)+ #' # split_rows_by_quartiles |
||
| 2601 | +710 |
- #' column count manually **will not** update the+ #' lyt4 <- basic_table(show_colcounts = TRUE) %>% |
||
| 2602 | +711 |
- #' counts for its parent facets. This cannot be made+ #' split_cols_by("ARM") %>%
|
||
| 2603 | +712 |
- #' automatic because the rtables framework does not+ #' split_rows_by_quartiles("AGE", split_label = "Age") %>%
|
||
| 2604 | +713 |
- #' require sibling facets to be mutually exclusive+ #' analyze("BMRKR2") %>%
|
||
| 2605 | +714 |
- #' (e.g., total "arm", faceting into cumulative+ #' append_topleft(c("Age Quartiles", " Counts BMRKR2"))
|
||
| 2606 | +715 |
- #' quantiles, etc) and thus the count of a parent facet+ #' |
||
| 2607 | +716 |
- #' will not always be simply the sum of the counts for+ #' tbl4 <- build_table(lyt4, ex_adsl) |
||
| 2608 | +717 |
- #' all of its children.+ #' tbl4 |
||
| 2609 | +718 |
#' |
||
| 2610 | +719 |
- #' @seealso [col_counts()]+ #' # split_cols_by_cutfun |
||
| 2611 | +720 |
- #'+ #' cutfun <- function(x) {
|
||
| 2612 | +721 |
- #' @examples+ #' cutpoints <- c( |
||
| 2613 | +722 |
- #' lyt <- basic_table() %>%+ #' min(x), |
||
| 2614 | +723 |
- #' split_cols_by("ARM", show_colcounts = TRUE) %>%
+ #' mean(x), |
||
| 2615 | +724 |
- #' split_cols_by("SEX",
+ #' max(x) |
||
| 2616 | +725 |
- #' split_fun = keep_split_levels(c("F", "M")),
+ #' ) |
||
| 2617 | +726 |
- #' show_colcounts = TRUE+ #' |
||
| 2618 | +727 |
- #' ) %>%+ #' names(cutpoints) <- c("", "Younger", "Older")
|
||
| 2619 | +728 |
- #' split_cols_by("STRATA1", show_colcounts = TRUE) %>%
+ #' cutpoints |
||
| 2620 | +729 |
- #' analyze("AGE")
+ #' } |
||
| 2621 | +730 |
#' |
||
| 2622 | +731 |
- #' tbl <- build_table(lyt, ex_adsl)+ #' lyt5 <- basic_table() %>% |
||
| 2623 | +732 |
- #'+ #' split_cols_by_cutfun("AGE", cutfun = cutfun) %>%
|
||
| 2624 | +733 |
- #' facet_colcount(tbl, c("ARM", "A: Drug X"))
+ #' analyze("SEX")
|
||
| 2625 | +734 |
- #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F"))
+ #' |
||
| 2626 | +735 |
- #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A"))
+ #' tbl5 <- build_table(lyt5, ex_adsl) |
||
| 2627 | +736 |
- #'+ #' tbl5 |
||
| 2628 | +737 |
- #' ## modify specific count after table creation+ #' |
||
| 2629 | +738 |
- #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "A")) <- 25
+ #' # split_rows_by_cutfun |
||
| 2630 | +739 |
- #'+ #' lyt6 <- basic_table() %>% |
||
| 2631 | +740 |
- #' ## show black space for certain counts by assign NA+ #' split_cols_by("SEX") %>%
|
||
| 2632 | +741 |
- #'+ #' split_rows_by_cutfun("AGE", cutfun = cutfun) %>%
|
||
| 2633 | +742 |
- #' facet_colcount(tbl, c("ARM", "A: Drug X", "SEX", "F", "STRATA1", "C")) <- NA
+ #' analyze("BMRKR2")
|
||
| 2634 | +743 |
#' |
||
| 2635 | +744 |
- #' @export+ #' tbl6 <- build_table(lyt6, ex_adsl) |
||
| 2636 | +745 |
- setGeneric(+ #' tbl6 |
||
| 2637 | +746 |
- "facet_colcount",+ #' |
||
| 2638 | -20294x | +|||
| 747 | +
- function(obj, path) standardGeneric("facet_colcount")
+ #' @author Gabriel Becker |
|||
| 2639 | +748 |
- )+ #' @export |
||
| 2640 | +749 |
-
+ #' @rdname varcuts |
||
| 2641 | +750 |
- #' @rdname facet_colcount+ split_cols_by_cuts <- function(lyt, var, cuts, |
||
| 2642 | +751 |
- #' @export+ cutlabels = NULL, |
||
| 2643 | +752 |
- setMethod(+ split_label = var, |
||
| 2644 | +753 |
- "facet_colcount", "LayoutColTree",+ nested = TRUE, |
||
| 2645 | +754 |
- function(obj, path = NULL) {
+ cumulative = FALSE, |
||
| 2646 | +755 |
- ## if(length(path) == 0L)+ show_colcounts = FALSE, |
||
| 2647 | +756 |
- ## stop("face_colcount requires a non-null path") #nocov
+ colcount_format = NULL) {
|
||
| 2648 | -645x | +757 | +3x |
- subtree <- coltree_at_path(obj, path)+ spl <- make_static_cut_split( |
| 2649 | -645x | +758 | +3x |
- subtree@column_count+ var = var, |
| 2650 | -+ | |||
| 759 | +3x |
- }+ split_label = split_label, |
||
| 2651 | -+ | |||
| 760 | +3x |
- )+ cuts = cuts, |
||
| 2652 | -+ | |||
| 761 | +3x |
-
+ cutlabels = cutlabels, |
||
| 2653 | -+ | |||
| 762 | +3x |
- #' @rdname facet_colcount+ cumulative = cumulative, |
||
| 2654 | -+ | |||
| 763 | +3x |
- #' @export+ show_colcounts = show_colcounts, |
||
| 2655 | -+ | |||
| 764 | +3x |
- setMethod(+ colcount_format = colcount_format |
||
| 2656 | +765 |
- "facet_colcount", "LayoutColLeaf",+ ) |
||
| 2657 | +766 |
- function(obj, path = NULL) {
+ ## if(cumulative) |
||
| 2658 | +767 |
- ## not sure if we should check for null here as above+ ## spl = as(spl, "CumulativeCutSplit") |
||
| 2659 | -19648x | +768 | +3x |
- obj@column_count+ pos <- next_cpos(lyt, nested) |
| 2660 | -+ | |||
| 769 | +3x |
- }+ split_cols(lyt, spl, pos) |
||
| 2661 | +770 |
- )+ } |
||
| 2662 | +771 | |||
| 2663 | +772 |
- #' @rdname facet_colcount+ #' @export |
||
| 2664 | +773 |
- #' @export+ #' @rdname varcuts |
||
| 2665 | +774 |
- setMethod(+ split_rows_by_cuts <- function(lyt, var, cuts, |
||
| 2666 | +775 |
- "facet_colcount", "VTableTree",+ cutlabels = NULL, |
||
| 2667 | -! | +|||
| 776 | +
- function(obj, path) facet_colcount(coltree(obj), path = path)+ split_label = var, |
|||
| 2668 | +777 |
- )+ format = NULL, |
||
| 2669 | +778 |
-
+ na_str = NA_character_, |
||
| 2670 | +779 |
- #' @rdname facet_colcount+ nested = TRUE, |
||
| 2671 | +780 |
- #' @export+ cumulative = FALSE, |
||
| 2672 | +781 |
- setMethod(+ label_pos = "hidden", |
||
| 2673 | +782 |
- "facet_colcount", "InstantiatedColumnInfo",+ section_div = NA_character_) {
|
||
| 2674 | -1x | +783 | +2x |
- function(obj, path) facet_colcount(coltree(obj), path = path)+ label_pos <- match.arg(label_pos, label_pos_values) |
| 2675 | +784 |
- )+ ## VarStaticCutSplit( |
||
| 2676 | -+ | |||
| 785 | +2x |
-
+ spl <- make_static_cut_split(var, split_label, |
||
| 2677 | -+ | |||
| 786 | +2x |
- #' @rdname facet_colcount+ cuts = cuts, |
||
| 2678 | -+ | |||
| 787 | +2x |
- #' @export+ cutlabels = cutlabels, |
||
| 2679 | -+ | |||
| 788 | +2x |
- setGeneric(+ split_format = format, |
||
| 2680 | -+ | |||
| 789 | +2x |
- "facet_colcount<-",+ split_na_str = na_str, |
||
| 2681 | -1070x | +790 | +2x |
- function(obj, path, value) standardGeneric("facet_colcount<-")
+ label_pos = label_pos, |
| 2682 | -+ | |||
| 791 | +2x |
- )+ cumulative = cumulative, |
||
| 2683 | -+ | |||
| 792 | +2x |
-
+ section_div = section_div |
||
| 2684 | +793 |
- #' @rdname facet_colcount+ ) |
||
| 2685 | +794 |
- #' @export+ ## if(cumulative) |
||
| 2686 | +795 |
- setMethod(+ ## spl = as(spl, "CumulativeCutSplit") |
||
| 2687 | -+ | |||
| 796 | +2x |
- "facet_colcount<-", "LayoutColTree",+ pos <- next_rpos(lyt, nested) |
||
| 2688 | -+ | |||
| 797 | +2x |
- function(obj, path, value) {
+ split_rows(lyt, spl, pos) |
||
| 2689 | -1068x | +|||
| 798 | +
- ct <- coltree_at_path(obj, path)+ } |
|||
| 2690 | -1068x | +|||
| 799 | +
- ct@column_count <- as.integer(value)+ |
|||
| 2691 | -1068x | +|||
| 800 | +
- coltree_at_path(obj, path) <- ct+ #' @export |
|||
| 2692 | -1068x | +|||
| 801 | +
- obj+ #' @rdname varcuts |
|||
| 2693 | +802 |
- }+ split_cols_by_cutfun <- function(lyt, var, |
||
| 2694 | +803 |
- )+ cutfun = qtile_cuts, |
||
| 2695 | +804 |
-
+ cutlabelfun = function(x) NULL, |
||
| 2696 | +805 |
- #' @rdname facet_colcount+ split_label = var, |
||
| 2697 | +806 |
- #' @export+ nested = TRUE, |
||
| 2698 | +807 |
- setMethod(+ extra_args = list(), |
||
| 2699 | +808 |
- "facet_colcount<-", "LayoutColLeaf",+ cumulative = FALSE, |
||
| 2700 | +809 |
- function(obj, path, value) {
+ show_colcounts = FALSE, |
||
| 2701 | -! | +|||
| 810 | +
- obj@column_count <- as.integer(value)+ colcount_format = NULL) {
|
|||
| 2702 | -! | +|||
| 811 | +3x |
- obj+ spl <- VarDynCutSplit(var, split_label, |
||
| 2703 | -+ | |||
| 812 | +3x |
- }+ cutfun = cutfun, |
||
| 2704 | -+ | |||
| 813 | +3x |
- )+ cutlabelfun = cutlabelfun, |
||
| 2705 | -+ | |||
| 814 | +3x |
-
+ extra_args = extra_args, |
||
| 2706 | -+ | |||
| 815 | +3x |
- #' @rdname facet_colcount+ cumulative = cumulative, |
||
| 2707 | -+ | |||
| 816 | +3x |
- #' @export+ label_pos = "hidden", |
||
| 2708 | -+ | |||
| 817 | +3x |
- setMethod(+ show_colcounts = show_colcounts, |
||
| 2709 | -+ | |||
| 818 | +3x |
- "facet_colcount<-", "VTableTree",+ colcount_format = colcount_format |
||
| 2710 | +819 |
- function(obj, path, value) {
+ ) |
||
| 2711 | -1x | +820 | +3x |
- cinfo <- col_info(obj)+ pos <- next_cpos(lyt, nested) |
| 2712 | -1x | +821 | +3x |
- facet_colcount(cinfo, path) <- value+ split_cols(lyt, spl, pos) |
| 2713 | -1x | +|||
| 822 | +
- col_info(obj) <- cinfo+ } |
|||
| 2714 | -1x | +|||
| 823 | +
- obj+ |
|||
| 2715 | +824 |
- }+ #' @export |
||
| 2716 | +825 |
- )+ #' @rdname varcuts |
||
| 2717 | +826 |
-
+ split_cols_by_quartiles <- function(lyt, var, split_label = var, |
||
| 2718 | +827 |
- #' @rdname facet_colcount+ nested = TRUE, |
||
| 2719 | +828 |
- #' @export+ extra_args = list(), |
||
| 2720 | +829 |
- setMethod(+ cumulative = FALSE, |
||
| 2721 | +830 |
- "facet_colcount<-", "InstantiatedColumnInfo",+ show_colcounts = FALSE, |
||
| 2722 | +831 |
- function(obj, path, value) {
+ colcount_format = NULL) {
|
||
| 2723 | -1x | +832 | +2x |
- ct <- coltree(obj)+ split_cols_by_cutfun( |
| 2724 | -1x | +833 | +2x |
- facet_colcount(ct, path) <- value+ lyt = lyt, |
| 2725 | -1x | +834 | +2x |
- coltree(obj) <- ct+ var = var, |
| 2726 | -1x | +835 | +2x |
- obj+ split_label = split_label, |
| 2727 | -+ | |||
| 836 | +2x |
- }+ cutfun = qtile_cuts, |
||
| 2728 | -+ | |||
| 837 | +2x |
- )+ cutlabelfun = function(x) {
|
||
| 2729 | -+ | |||
| 838 | +2x |
-
+ c( |
||
| 2730 | -+ | |||
| 839 | +2x |
- #' Value and Visibility of specific column counts by path+ "[min, Q1]", |
||
| 2731 | -+ | |||
| 840 | +2x |
- #'+ "(Q1, Q2]", |
||
| 2732 | -+ | |||
| 841 | +2x |
- #' @inheritParams gen_args+ "(Q2, Q3]", |
||
| 2733 | -+ | |||
| 842 | +2x |
- #'+ "(Q3, max]" |
||
| 2734 | +843 |
- #' @return for `colcount_visible` a logical scalar+ ) |
||
| 2735 | +844 |
- #' indicating whether the specified position in+ }, |
||
| 2736 | -+ | |||
| 845 | +2x |
- #' the column hierarchy is set to display its column count;+ nested = nested, |
||
| 2737 | -+ | |||
| 846 | +2x |
- #' for `colcount_visible<-`, `obj` updated with+ extra_args = extra_args, |
||
| 2738 | -+ | |||
| 847 | +2x |
- #' the specified count displaying behavior set.+ cumulative = cumulative, |
||
| 2739 | -+ | |||
| 848 | +2x |
- #'+ show_colcounts = show_colcounts, |
||
| 2740 | -+ | |||
| 849 | +2x |
- #' @note Users generally should not call `colcount_visible`+ colcount_format = colcount_format |
||
| 2741 | +850 |
- #' directly, as setting sibling facets to have differing+ ) |
||
| 2742 | +851 |
- #' column count visibility will result in an error when+ ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts, |
||
| 2743 | +852 |
- #' printing or paginating the table.+ ## cutlabelfun = function(x) c("[min, Q1]",
|
||
| 2744 | +853 |
- #'+ ## "(Q1, Q2]", |
||
| 2745 | +854 |
- #' @export+ ## "(Q2, Q3]", |
||
| 2746 | -2x | +|||
| 855 | +
- setGeneric("colcount_visible", function(obj, path) standardGeneric("colcount_visible"))
+ ## "(Q3, max]"), |
|||
| 2747 | +856 |
-
+ ## split_format = format, |
||
| 2748 | +857 |
- #' @rdname colcount_visible+ ## extra_args = extra_args, |
||
| 2749 | +858 |
- #' @export+ ## cumulative = cumulative, |
||
| 2750 | +859 |
- setMethod(+ ## label_pos = "hidden") |
||
| 2751 | +860 |
- "colcount_visible", "VTableTree",+ ## pos = next_cpos(lyt, nested) |
||
| 2752 | -1x | +|||
| 861 | +
- function(obj, path) colcount_visible(coltree(obj), path)+ ## split_cols(lyt, spl, pos) |
|||
| 2753 | +862 |
- )+ } |
||
| 2754 | +863 | |||
| 2755 | +864 |
- #' @rdname colcount_visible+ #' @export |
||
| 2756 | +865 |
- #' @export+ #' @rdname varcuts |
||
| 2757 | +866 |
- setMethod(+ split_rows_by_quartiles <- function(lyt, var, split_label = var, |
||
| 2758 | +867 |
- "colcount_visible", "InstantiatedColumnInfo",+ format = NULL, |
||
| 2759 | -! | +|||
| 868 | +
- function(obj, path) colcount_visible(coltree(obj), path)+ na_str = NA_character_, |
|||
| 2760 | +869 |
- )+ nested = TRUE, |
||
| 2761 | +870 |
-
+ child_labels = c("default", "visible", "hidden"),
|
||
| 2762 | +871 |
- #' @rdname colcount_visible+ extra_args = list(), |
||
| 2763 | +872 |
- #' @export+ cumulative = FALSE, |
||
| 2764 | +873 |
- setMethod(+ indent_mod = 0L, |
||
| 2765 | +874 |
- "colcount_visible", "LayoutColTree",+ label_pos = "hidden", |
||
| 2766 | +875 |
- function(obj, path) {
+ section_div = NA_character_) {
|
||
| 2767 | -1x | +876 | +2x |
- subtree <- coltree_at_path(obj, path)+ split_rows_by_cutfun( |
| 2768 | -1x | +877 | +2x |
- disp_ccounts(subtree)+ lyt = lyt, |
| 2769 | -+ | |||
| 878 | +2x |
- }+ var = var, |
||
| 2770 | -+ | |||
| 879 | +2x |
- )+ split_label = split_label, |
||
| 2771 | -+ | |||
| 880 | +2x |
-
+ format = format, |
||
| 2772 | -+ | |||
| 881 | +2x |
- #' @rdname colcount_visible+ na_str = na_str, |
||
| 2773 | -+ | |||
| 882 | +2x |
- #' @export+ cutfun = qtile_cuts, |
||
| 2774 | -1288x | +883 | +2x |
- setGeneric("colcount_visible<-", function(obj, path, value) standardGeneric("colcount_visible<-"))
+ cutlabelfun = function(x) {
|
| 2775 | -+ | |||
| 884 | +2x |
-
+ c( |
||
| 2776 | -+ | |||
| 885 | +2x |
- #' @rdname colcount_visible+ "[min, Q1]", |
||
| 2777 | -+ | |||
| 886 | +2x |
- #' @export+ "(Q1, Q2]", |
||
| 2778 | -+ | |||
| 887 | +2x |
- setMethod(+ "(Q2, Q3]",+ |
+ ||
| 888 | +2x | +
+ "(Q3, max]" |
||
| 2779 | +889 |
- "colcount_visible<-", "VTableTree",+ ) |
||
| 2780 | +890 |
- function(obj, path, value) {
+ }, |
||
| 2781 | -3x | +891 | +2x |
- ctree <- coltree(obj)+ nested = nested, |
| 2782 | -3x | +892 | +2x |
- colcount_visible(ctree, path) <- value+ child_labels = child_labels, |
| 2783 | -3x | +893 | +2x |
- coltree(obj) <- ctree+ extra_args = extra_args, |
| 2784 | -3x | +894 | +2x |
- obj+ cumulative = cumulative, |
| 2785 | -+ | |||
| 895 | +2x |
- }+ indent_mod = indent_mod, |
||
| 2786 | -+ | |||
| 896 | +2x |
- )+ label_pos = label_pos, |
||
| 2787 | -+ | |||
| 897 | +2x |
-
+ section_div = section_div |
||
| 2788 | +898 |
- #' @rdname colcount_visible+ ) |
||
| 2789 | +899 |
- #' @export+ |
||
| 2790 | +900 |
- setMethod(+ ## label_pos <- match.arg(label_pos, label_pos_values) |
||
| 2791 | +901 |
- "colcount_visible<-", "InstantiatedColumnInfo",+ ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts, |
||
| 2792 | +902 |
- function(obj, path, value) {
+ ## cutlabelfun = , |
||
| 2793 | -21x | +|||
| 903 | +
- ctree <- coltree(obj)+ ## split_format = format, |
|||
| 2794 | -21x | +|||
| 904 | +
- colcount_visible(ctree, path) <- value+ ## child_labels = child_labels, |
|||
| 2795 | -21x | +|||
| 905 | +
- coltree(obj) <- ctree+ ## extra_args = extra_args, |
|||
| 2796 | -21x | +|||
| 906 | +
- obj+ ## cumulative = cumulative, |
|||
| 2797 | +907 |
- }+ ## indent_mod = indent_mod, |
||
| 2798 | +908 |
- )+ ## label_pos = label_pos) |
||
| 2799 | +909 |
-
+ ## pos = next_rpos(lyt, nested) |
||
| 2800 | +910 |
-
+ ## split_rows(lyt, spl, pos) |
||
| 2801 | +911 |
- #' @rdname colcount_visible+ } |
||
| 2802 | +912 |
- #' @export+ |
||
| 2803 | +913 |
- setMethod(+ qtile_cuts <- function(x) {
|
||
| 2804 | -+ | |||
| 914 | +6x |
- "colcount_visible<-", "LayoutColTree",+ ret <- quantile(x)+ |
+ ||
| 915 | +6x | +
+ names(ret) <- c( |
||
| 2805 | +916 |
- function(obj, path, value) {
+ "", |
||
| 2806 | -1264x | +917 | +6x |
- subtree <- coltree_at_path(obj, path)+ "1st qrtile", |
| 2807 | -1264x | +918 | +6x |
- disp_ccounts(subtree) <- value+ "2nd qrtile", |
| 2808 | -1264x | +919 | +6x |
- coltree_at_path(obj, path) <- subtree+ "3rd qrtile", |
| 2809 | -1264x | +920 | +6x |
- obj+ "4th qrtile" |
| 2810 | +921 |
- }+ )+ |
+ ||
| 922 | +6x | +
+ ret |
||
| 2811 | +923 |
- )+ } |
||
| 2812 | +924 | |||
| 2813 | +925 |
- #' @rdname int_methods+ #' @export |
||
| 2814 | +926 |
- #' @export+ #' @rdname varcuts |
||
| 2815 | -15683x | +|||
| 927 | +
- setGeneric("colcount_format", function(obj) standardGeneric("colcount_format"))
+ split_rows_by_cutfun <- function(lyt, var, |
|||
| 2816 | +928 |
-
+ cutfun = qtile_cuts, |
||
| 2817 | +929 |
- #' @rdname int_methods+ cutlabelfun = function(x) NULL, |
||
| 2818 | +930 |
- #' @export+ split_label = var, |
||
| 2819 | +931 |
- setMethod(+ format = NULL, |
||
| 2820 | +932 |
- "colcount_format", "InstantiatedColumnInfo",+ na_str = NA_character_, |
||
| 2821 | -631x | +|||
| 933 | +
- function(obj) obj@columncount_format+ nested = TRUE, |
|||
| 2822 | +934 |
- )+ child_labels = c("default", "visible", "hidden"),
|
||
| 2823 | +935 |
-
+ extra_args = list(), |
||
| 2824 | +936 |
- #' @rdname int_methods+ cumulative = FALSE, |
||
| 2825 | +937 |
- #' @export+ indent_mod = 0L, |
||
| 2826 | +938 |
- setMethod(+ label_pos = "hidden", |
||
| 2827 | +939 |
- "colcount_format", "VTableNodeInfo",+ section_div = NA_character_) {
|
||
| 2828 | -338x | +940 | +2x |
- function(obj) colcount_format(col_info(obj))+ label_pos <- match.arg(label_pos, label_pos_values) |
| 2829 | -+ | |||
| 941 | +2x |
- )+ child_labels <- match.arg(child_labels) |
||
| 2830 | -+ | |||
| 942 | +2x |
-
+ spl <- VarDynCutSplit(var, split_label, |
||
| 2831 | -+ | |||
| 943 | +2x |
- #' @rdname int_methods+ cutfun = cutfun, |
||
| 2832 | -+ | |||
| 944 | +2x |
- #' @export+ cutlabelfun = cutlabelfun, |
||
| 2833 | -+ | |||
| 945 | +2x |
- setMethod(+ split_format = format, |
||
| 2834 | -+ | |||
| 946 | +2x |
- "colcount_format", "PreDataColLayout",+ split_na_str = na_str, |
||
| 2835 | -325x | +947 | +2x |
- function(obj) obj@columncount_format+ child_labels = child_labels, |
| 2836 | -+ | |||
| 948 | +2x |
- )+ extra_args = extra_args, |
||
| 2837 | -+ | |||
| 949 | +2x |
-
+ cumulative = cumulative, |
||
| 2838 | -+ | |||
| 950 | +2x |
- #' @rdname int_methods+ indent_mod = indent_mod, |
||
| 2839 | -+ | |||
| 951 | +2x |
- #' @export+ label_pos = label_pos, |
||
| 2840 | -+ | |||
| 952 | +2x |
- setMethod(+ section_div = section_div |
||
| 2841 | +953 |
- "colcount_format", "PreDataTableLayouts",+ ) |
||
| 2842 | -325x | +954 | +2x |
- function(obj) colcount_format(clayout(obj))+ pos <- next_rpos(lyt, nested)+ |
+
| 955 | +2x | +
+ split_rows(lyt, spl, pos) |
||
| 2843 | +956 |
- )+ } |
||
| 2844 | +957 | |||
| 2845 | +958 |
- #' @rdname int_methods+ #' .spl_context within analysis and split functions |
||
| 2846 | +959 |
- #' @export+ #' |
||
| 2847 | +960 |
- setMethod(+ #' `.spl_context` is an optional parameter for any of rtables' special functions, i.e. `afun` (analysis function |
||
| 2848 | +961 |
- "colcount_format", "Split",- |
- ||
| 2849 | -1226x | -
- function(obj) obj@child_colcount_format+ #' in [analyze()]), `cfun` (content or label function in [summarize_row_groups()]), or `split_fun` (e.g. for |
||
| 2850 | +962 |
- )+ #' [split_rows_by()]). |
||
| 2851 | +963 |
-
+ #' |
||
| 2852 | +964 |
- #' @rdname int_methods+ #' @details |
||
| 2853 | +965 |
- #' @export+ #' The `.spl_context` `data.frame` gives information about the subsets of data corresponding to the splits within |
||
| 2854 | +966 |
- setMethod(+ #' which the current `analyze` action is nested. Taken together, these correspond to the path that the resulting (set |
||
| 2855 | +967 |
- "colcount_format", "LayoutColTree",- |
- ||
| 2856 | -644x | -
- function(obj) obj@columncount_format+ #' of) rows the analysis function is creating, although the information is in a slightly different form. Each split |
||
| 2857 | +968 |
- )+ #' (which correspond to groups of rows in the resulting table), as well as the initial 'root' "split", is represented |
||
| 2858 | +969 |
-
+ #' via the following columns: |
||
| 2859 | +970 |
- #' @rdname int_methods+ #' |
||
| 2860 | +971 |
- #' @export+ #' \describe{
|
||
| 2861 | +972 |
- setMethod(+ #' \item{split}{The name of the split (often the variable being split).}
|
||
| 2862 | +973 |
- "colcount_format", "LayoutColLeaf",+ #' \item{value}{The string representation of the value at that split (`split`).}
|
||
| 2863 | -12047x | +|||
| 974 | +
- function(obj) obj@columncount_format+ #' \item{full_parent_df}{A `data.frame` containing the full data (i.e. across all columns) corresponding to the path
|
|||
| 2864 | +975 |
- )+ #' defined by the combination of `split` and `value` of this row *and all rows above this row*.} |
||
| 2865 | +976 |
-
+ #' \item{all_cols_n}{The number of observations corresponding to the row grouping (union of all columns).}
|
||
| 2866 | +977 |
-
+ #' \item{column for each column in the table structure (*row-split and analyze contexts only*)}{These list columns
|
||
| 2867 | +978 |
-
+ #' (named the same as `names(col_exprs(tab))`) contain logical vectors corresponding to the subset of this row's |
||
| 2868 | +979 |
- #' @rdname int_methods+ #' `full_parent_df` corresponding to the column.} |
||
| 2869 | +980 |
- #' @export+ #' \item{cur_col_id}{Identifier of the current column. This may be an internal name, constructed by pasting the
|
||
| 2870 | +981 |
- setGeneric(+ #' column path together.} |
||
| 2871 | +982 |
- "colcount_format<-",+ #' \item{cur_col_subset}{List column containing logical vectors indicating the subset of this row's `full_parent_df`
|
||
| 2872 | -652x | +|||
| 983 | +
- function(obj, value) standardGeneric("colcount_format<-")
+ #' for the column currently being created by the analysis function.} |
|||
| 2873 | +984 |
- )+ #' \item{cur_col_expr}{List of current column expression. This may be used to filter `.alt_df_row`, or any external
|
||
| 2874 | +985 |
-
+ #' data, by column. Filtering `.alt_df_row` by columns produces `.alt_df`.} |
||
| 2875 | +986 |
- #' @export+ #' \item{cur_col_n}{Integer column containing the observation counts for that split.}
|
||
| 2876 | +987 |
- #' @rdname int_methods+ #' \item{cur_col_split}{Current column split names. This is recovered from the current column path.}
|
||
| 2877 | +988 |
- setMethod(+ #' \item{cur_col_split_val}{Current column split values. This is recovered from the current column path.}
|
||
| 2878 | +989 |
- "colcount_format<-", "InstantiatedColumnInfo",+ #' } |
||
| 2879 | +990 |
- function(obj, value) {
+ #' |
||
| 2880 | -1x | +|||
| 991 | +
- obj@columncount_format <- value+ #' @note |
|||
| 2881 | -1x | +|||
| 992 | +
- obj+ #' Within analysis functions that accept `.spl_context`, the `all_cols_n` and `cur_col_n` columns of the data frame |
|||
| 2882 | +993 |
- }+ #' will contain the 'true' observation counts corresponding to the row-group and row-group x column subsets of the |
||
| 2883 | +994 |
- )+ #' data. These numbers will not, and currently cannot, reflect alternate column observation counts provided by the |
||
| 2884 | +995 |
-
+ #' `alt_counts_df`, `col_counts` or `col_total` arguments to [build_table()]. |
||
| 2885 | +996 |
- #' @rdname int_methods+ #' |
||
| 2886 | +997 |
- #' @export+ #' @name spl_context |
||
| 2887 | +998 |
- setMethod(+ NULL |
||
| 2888 | +999 |
- "colcount_format<-", "VTableNodeInfo",+ |
||
| 2889 | +1000 |
- function(obj, value) {
+ #' Additional parameters within analysis and content functions (`afun`/`cfun`) |
||
| 2890 | -1x | +|||
| 1001 | +
- cinfo <- col_info(obj)+ #' |
|||
| 2891 | -1x | +|||
| 1002 | +
- colcount_format(cinfo) <- value+ #' @description |
|||
| 2892 | -1x | +|||
| 1003 | +
- col_info(obj) <- cinfo+ #' It is possible to add specific parameters to `afun` and `cfun`, in [analyze()] and [summarize_row_groups()], |
|||
| 2893 | -1x | +|||
| 1004 | +
- obj+ #' respectively. These parameters grant access to relevant information like the row split structure (see |
|||
| 2894 | +1005 |
- }+ #' [spl_context]) and the predefined baseline (`.ref_group`). |
||
| 2895 | +1006 |
- )+ #' |
||
| 2896 | +1007 |
-
+ #' @details |
||
| 2897 | +1008 |
- #' @rdname int_methods+ #' We list and describe all the parameters that can be added to a custom analysis function below: |
||
| 2898 | +1009 |
- #' @export+ #' |
||
| 2899 | +1010 |
- setMethod(+ #' \describe{
|
||
| 2900 | +1011 |
- "colcount_format<-", "PreDataColLayout",+ #' \item{.N_col}{Column-wise N (column count) for the full column being tabulated within.}
|
||
| 2901 | +1012 |
- function(obj, value) {
+ #' \item{.N_total}{Overall N (all observation count, defined as sum of column counts) for the tabulation.}
|
||
| 2902 | -325x | +|||
| 1013 | +
- obj@columncount_format <- value+ #' \item{.N_row}{Row-wise N (row group count) for the group of observations being analyzed (i.e. with no
|
|||
| 2903 | -325x | +|||
| 1014 | +
- obj+ #' column-based subsetting).} |
|||
| 2904 | +1015 |
- }+ #' \item{.df_row}{`data.frame` for observations in the row group being analyzed (i.e. with no column-based
|
||
| 2905 | +1016 |
- )+ #' subsetting).} |
||
| 2906 | +1017 |
-
+ #' \item{.var}{Variable being analyzed.}
|
||
| 2907 | +1018 |
- #' @rdname int_methods+ #' \item{.ref_group}{`data.frame` or vector of subset corresponding to the `ref_group` column including subsetting
|
||
| 2908 | +1019 |
- #' @export+ #' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.} |
||
| 2909 | +1020 |
- setMethod(+ #' \item{.ref_full}{`data.frame` or vector of subset corresponding to the `ref_group` column without subsetting
|
||
| 2910 | +1021 |
- "colcount_format<-", "PreDataTableLayouts",+ #' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.} |
||
| 2911 | +1022 |
- function(obj, value) {
+ #' \item{.in_ref_col}{Boolean indicating if calculation is done for cells within the reference column.}
|
||
| 2912 | -325x | +|||
| 1023 | +
- clyt <- clayout(obj)+ #' \item{.spl_context}{`data.frame` where each row gives information about a previous 'ancestor' split state.
|
|||
| 2913 | -325x | +|||
| 1024 | +
- colcount_format(clyt) <- value+ #' See [spl_context].} |
|||
| 2914 | -325x | +|||
| 1025 | +
- clayout(obj) <- clyt+ #' \item{.alt_df_row}{`data.frame`, i.e. the `alt_count_df` after row splitting. It can be used with
|
|||
| 2915 | -325x | +|||
| 1026 | +
- obj+ #' `.all_col_exprs` and `.spl_context` information to retrieve current faceting, but for `alt_count_df`. |
|||
| 2916 | +1027 |
- }+ #' It can be an empty table if all the entries are filtered out.} |
||
| 2917 | +1028 |
- )+ #' \item{.alt_df}{`data.frame`, `.alt_df_row` but filtered by columns expression. This data present the same
|
||
| 2918 | +1029 |
-
+ #' faceting of main data `df`. This also filters `NA`s out if related parameters are set to do so (e.g. `inclNAs` |
||
| 2919 | +1030 |
- ## It'd probably be better if this had the full set of methods as above+ #' in [analyze()]). Similarly to `.alt_df_row`, it can be an empty table if all the entries are filtered out.} |
||
| 2920 | +1031 |
- ## but its not currently modelled in the class and probably isn't needed+ #' \item{.all_col_exprs}{List of expressions. Each of them represents a different column splitting.}
|
||
| 2921 | +1032 |
- ## super much+ #' \item{.all_col_counts}{Vector of integers. Each of them represents the global count for each column. It differs
|
||
| 2922 | +1033 |
- #' @rdname int_methods+ #' if `alt_counts_df` is used (see [build_table()]).} |
||
| 2923 | +1034 |
- #' @export+ #' } |
||
| 2924 | -610x | +|||
| 1035 | +
- setGeneric("colcount_na_str", function(obj) standardGeneric("colcount_na_str"))
+ #' |
|||
| 2925 | +1036 |
-
+ #' @note If any of these formals is specified incorrectly or not present in the tabulation machinery, it will be |
||
| 2926 | +1037 |
- #' @rdname int_methods+ #' treated as if missing. For example, `.ref_group` will be missing if no baseline is previously defined during |
||
| 2927 | +1038 |
- #' @export+ #' data splitting (via `ref_group` parameters in, e.g., [split_rows_by()]). Similarly, if no `alt_counts_df` is |
||
| 2928 | +1039 |
- setMethod(+ #' provided to [build_table()], `.alt_df_row` and `.alt_df` will not be present. |
||
| 2929 | +1040 |
- "colcount_na_str", "InstantiatedColumnInfo",+ #' |
||
| 2930 | -308x | +|||
| 1041 | +
- function(obj) obj@columncount_na_str+ #' @name additional_fun_params |
|||
| 2931 | +1042 |
- )+ NULL |
||
| 2932 | +1043 | |||
| 2933 | +1044 |
- #' @rdname int_methods+ #' Generate rows analyzing variables across columns |
||
| 2934 | +1045 |
- #' @export+ #' |
||
| 2935 | +1046 |
- setMethod(+ #' Adding *analyzed variables* to our table layout defines the primary tabulation to be performed. We do this by |
||
| 2936 | +1047 |
- "colcount_na_str", "VTableNodeInfo",- |
- ||
| 2937 | -302x | -
- function(obj) colcount_na_str(col_info(obj))+ #' adding calls to `analyze` and/or [analyze_colvars()] into our layout pipeline. As with adding further splitting, |
||
| 2938 | +1048 |
- )+ #' the tabulation will occur at the current/next level of nesting by default. |
||
| 2939 | +1049 |
-
+ #' |
||
| 2940 | +1050 |
- #' @rdname int_methods+ #' @inheritParams lyt_args |
||
| 2941 | +1051 |
- #' @export+ #' |
||
| 2942 | +1052 |
- setGeneric(+ #' @inherit split_cols_by return |
||
| 2943 | +1053 |
- "colcount_na_str<-",- |
- ||
| 2944 | -4x | -
- function(obj, value) standardGeneric("colcount_na_str<-")
+ #' |
||
| 2945 | +1054 |
- )+ #' @details |
||
| 2946 | +1055 |
-
+ #' When non-`NULL`, `format` is used to specify formats for all generated rows, and can be a character vector, a |
||
| 2947 | +1056 |
- #' @export+ #' function, or a list of functions. It will be repped out to the number of rows once this is calculated during the |
||
| 2948 | +1057 |
- #' @rdname int_methods+ #' tabulation process, but will be overridden by formats specified within `rcell` calls in `afun`. |
||
| 2949 | +1058 |
- setMethod(+ #' |
||
| 2950 | +1059 |
- "colcount_na_str<-", "InstantiatedColumnInfo",+ #' The analysis function (`afun`) should take as its first parameter either `x` or `df`. Whichever of these the |
||
| 2951 | +1060 |
- function(obj, value) {
- |
- ||
| 2952 | -2x | -
- obj@columncount_na_str <- value- |
- ||
| 2953 | -2x | -
- obj+ #' function accepts will change the behavior when tabulation is performed as follows: |
||
| 2954 | +1061 |
- }+ #' |
||
| 2955 | +1062 |
- )+ #' - If `afun`'s first parameter is `x`, it will receive the corresponding subset *vector* of data from the relevant |
||
| 2956 | +1063 |
-
+ #' column (from `var` here) of the raw data being used to build the table. |
||
| 2957 | +1064 |
- #' @rdname int_methods+ #' - If `afun`'s first parameter is `df`, it will receive the corresponding subset *data frame* (i.e. all columns) of |
||
| 2958 | +1065 |
- #' @export+ #' the raw data being tabulated. |
||
| 2959 | +1066 |
- setMethod(+ #' |
||
| 2960 | +1067 |
- "colcount_na_str<-", "VTableNodeInfo",+ #' In addition to differentiation on the first argument, the analysis function can optionally accept a number of |
||
| 2961 | +1068 |
- function(obj, value) {
- |
- ||
| 2962 | -2x | -
- cinfo <- col_info(obj)- |
- ||
| 2963 | -2x | -
- colcount_na_str(cinfo) <- value+ #' other parameters which, *if and only if* present in the formals, will be passed to the function by the tabulation |
||
| 2964 | -2x | +|||
| 1069 | +
- col_info(obj) <- cinfo+ #' machinery. These are listed and described in [additional_fun_params]. |
|||
| 2965 | -2x | +|||
| 1070 | +
- obj+ #' |
|||
| 2966 | +1071 |
- }+ #' @note None of the arguments described in the Details section can be overridden via `extra_args` or when calling |
||
| 2967 | +1072 |
- )+ #' [make_afun()]. `.N_col` and `.N_total` can be overridden via the `col_counts` argument to [build_table()]. |
||
| 2968 | +1073 |
-
+ #' Alternative values for the others must be calculated within `afun` based on a combination of extra arguments and |
||
| 2969 | +1074 |
- #' Exported for use in `tern`+ #' the unmodified values provided by the tabulation framework. |
||
| 2970 | +1075 |
#' |
||
| 2971 | +1076 |
- #' Does the `table`/`row`/`InstantiatedColumnInfo` object contain no column structure information?+ #' @examples |
||
| 2972 | +1077 |
- #'+ #' lyt <- basic_table() %>% |
||
| 2973 | +1078 |
- #' @inheritParams gen_args+ #' split_cols_by("ARM") %>%
|
||
| 2974 | +1079 |
- #'+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
|
||
| 2975 | +1080 |
- #' @return `TRUE` if the object has no/empty instantiated column information, `FALSE` otherwise.+ #' lyt |
||
| 2976 | +1081 |
#' |
||
| 2977 | +1082 |
- #' @rdname no_info+ #' tbl <- build_table(lyt, DM) |
||
| 2978 | +1083 |
- #' @export+ #' tbl |
||
| 2979 | -172487x | +|||
| 1084 | +
- setGeneric("no_colinfo", function(obj) standardGeneric("no_colinfo"))
+ #' |
|||
| 2980 | +1085 |
-
+ #' lyt2 <- basic_table() %>% |
||
| 2981 | +1086 |
- #' @exportMethod no_colinfo+ #' split_cols_by("Species") %>%
|
||
| 2982 | +1087 |
- #' @rdname no_info+ #' analyze(head(names(iris), -1), afun = function(x) {
|
||
| 2983 | +1088 |
- setMethod(+ #' list( |
||
| 2984 | +1089 |
- "no_colinfo", "VTableNodeInfo",+ #' "mean / sd" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), |
||
| 2985 | -73329x | +|||
| 1090 | +
- function(obj) no_colinfo(col_info(obj))+ #' "range" = rcell(diff(range(x)), format = "xx.xx") |
|||
| 2986 | +1091 |
- )+ #' ) |
||
| 2987 | +1092 |
-
+ #' }) |
||
| 2988 | +1093 |
- #' @exportMethod no_colinfo+ #' lyt2 |
||
| 2989 | +1094 |
- #' @rdname no_info+ #' |
||
| 2990 | +1095 |
- setMethod(+ #' tbl2 <- build_table(lyt2, iris) |
||
| 2991 | +1096 |
- "no_colinfo", "InstantiatedColumnInfo",+ #' tbl2 |
||
| 2992 | -89191x | +|||
| 1097 | +
- function(obj) length(obj@subset_exprs) == 0+ #' |
|||
| 2993 | +1098 |
- ) ## identical(obj, EmptyColInfo))+ #' @author Gabriel Becker |
||
| 2994 | +1099 |
-
+ #' @export |
||
| 2995 | +1100 |
- #' Names of a `TableTree`+ analyze <- function(lyt, |
||
| 2996 | +1101 |
- #'+ vars, |
||
| 2997 | +1102 |
- #' @param x (`TableTree`)\cr the object.+ afun = simple_analysis, |
||
| 2998 | +1103 |
- #'+ var_labels = vars, |
||
| 2999 | +1104 |
- #' @details+ table_names = vars, |
||
| 3000 | +1105 |
- #' For `TableTree`s with more than one level of splitting in columns, the names are defined to be the top-level+ format = NULL, |
||
| 3001 | +1106 |
- #' split values repped out across the columns that they span.+ na_str = NA_character_, |
||
| 3002 | +1107 |
- #'+ nested = TRUE, |
||
| 3003 | +1108 |
- #' @return The column names of `x`, as defined in the details above.+ ## can't name this na_rm symbol conflict with possible afuns!! |
||
| 3004 | +1109 |
- #'+ inclNAs = FALSE, |
||
| 3005 | +1110 |
- #' @exportMethod names+ extra_args = list(), |
||
| 3006 | +1111 |
- #' @rdname names+ show_labels = c("default", "visible", "hidden"),
|
||
| 3007 | +1112 |
- setMethod(+ indent_mod = 0L, |
||
| 3008 | +1113 |
- "names", "VTableNodeInfo",+ section_div = NA_character_) {
|
||
| 3009 | -109x | +1114 | +313x |
- function(x) names(col_info(x))+ show_labels <- match.arg(show_labels) |
| 3010 | -+ | |||
| 1115 | +313x |
- )+ subafun <- substitute(afun) |
||
| 3011 | +1116 |
-
+ # R treats a single NA value as a logical atomic. The below |
||
| 3012 | +1117 |
- #' @rdname names+ # maps all the NAs in `var_labels` to NA_character_ required by `Split` |
||
| 3013 | +1118 |
- #' @exportMethod names+ # and avoids the error when `var_labels` is just c(NA). |
||
| 3014 | -+ | |||
| 1119 | +313x |
- setMethod(+ var_labels <- vapply(var_labels, function(label) ifelse(is.na(label), NA_character_, label), character(1)) |
||
| 3015 | +1120 |
- "names", "InstantiatedColumnInfo",+ if ( |
||
| 3016 | -127x | +1121 | +313x |
- function(x) names(coltree(x))+ is.name(subafun) && |
| 3017 | -+ | |||
| 1122 | +313x |
- )+ is.function(afun) && |
||
| 3018 | +1123 |
-
+ ## this is gross. basically testing |
||
| 3019 | +1124 |
- #' @rdname names+ ## if the symbol we have corresponds |
||
| 3020 | +1125 |
- #' @exportMethod names+ ## in some meaningful way to the function |
||
| 3021 | +1126 |
- setMethod(+ ## we will be calling. |
||
| 3022 | -+ | |||
| 1127 | +313x |
- "names", "LayoutColTree",+ identical( |
||
| 3023 | -+ | |||
| 1128 | +313x |
- function(x) {
+ mget( |
||
| 3024 | -163x | +1129 | +313x |
- unname(unlist(lapply(+ as.character(subafun), |
| 3025 | -163x | +1130 | +313x |
- tree_children(x),+ mode = "function", |
| 3026 | -163x | +1131 | +313x |
- function(obj) {
+ ifnotfound = list(NULL), |
| 3027 | -202x | +1132 | +313x |
- nm <- obj_name(obj)+ inherits = TRUE |
| 3028 | -202x | +1133 | +313x |
- rep(nm, n_leaves(obj))+ )[[1]], afun |
| 3029 | +1134 |
- }+ ) |
||
| 3030 | +1135 |
- )))+ ) {
|
||
| 3031 | -+ | |||
| 1136 | +178x |
- }+ defrowlab <- as.character(subafun) |
||
| 3032 | +1137 |
- )+ } else {
|
||
| 3033 | -+ | |||
| 1138 | +135x |
-
+ defrowlab <- var_labels |
||
| 3034 | +1139 |
- #' @rdname names+ } |
||
| 3035 | +1140 |
- #' @exportMethod row.names+ |
||
| 3036 | -+ | |||
| 1141 | +313x |
- setMethod(+ spl <- AnalyzeMultiVars(vars, var_labels, |
||
| 3037 | -+ | |||
| 1142 | +313x |
- "row.names", "VTableTree",+ afun = afun, |
||
| 3038 | -+ | |||
| 1143 | +313x |
- function(x) {
+ split_format = format, |
||
| 3039 | -104x | +1144 | +313x |
- unname(sapply(collect_leaves(x, add.labrows = TRUE),+ split_na_str = na_str, |
| 3040 | -104x | +1145 | +313x |
- obj_label,+ defrowlab = defrowlab, |
| 3041 | -104x | +1146 | +313x |
- USE.NAMES = FALSE+ inclNAs = inclNAs, |
| 3042 | -104x | +1147 | +313x |
- )) ## XXXX this should probably be obj_name???+ extra_args = extra_args, |
| 3043 | -+ | |||
| 1148 | +313x |
- }+ indent_mod = indent_mod, |
||
| 3044 | -+ | |||
| 1149 | +313x |
- )+ child_names = table_names, |
||
| 3045 | -+ | |||
| 1150 | +313x |
-
+ child_labels = show_labels, |
||
| 3046 | -+ | |||
| 1151 | +313x |
- #' Convert to a vector+ section_div = section_div |
||
| 3047 | +1152 |
- #'+ ) |
||
| 3048 | +1153 |
- #' Convert an `rtables` framework object into a vector, if possible. This is unlikely to be useful in+ |
||
| 3049 | -+ | |||
| 1154 | +313x |
- #' realistic scenarios.+ if (nested && (is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars"))) {
|
||
| 3050 | -+ | |||
| 1155 | +27x |
- #'+ cmpnd_last_rowsplit(lyt, spl, AnalyzeMultiVars) |
||
| 3051 | +1156 |
- #' @param x (`ANY`)\cr the object to be converted to a vector.+ } else {
|
||
| 3052 | +1157 |
- #' @param mode (`string`)\cr passed on to [as.vector()].+ ## analysis compounding now done in split_rows |
||
| 3053 | -+ | |||
| 1158 | +284x |
- #'+ pos <- next_rpos(lyt, nested) |
||
| 3054 | -+ | |||
| 1159 | +284x |
- #' @return A vector of the chosen mode (or an error is raised if more than one row was present).+ split_rows(lyt, spl, pos) |
||
| 3055 | +1160 |
- #'+ } |
||
| 3056 | +1161 |
- #' @note This only works for a table with a single row or a row object.+ } |
||
| 3057 | +1162 |
- #'+ |
||
| 3058 | +1163 |
- #' @name asvec+ get_acolvar_name <- function(lyt) {
|
||
| 3059 | +1164 |
- #' @aliases as.vector,VTableTree-method+ ## clyt <- clayout(lyt) |
||
| 3060 | +1165 |
- #' @exportMethod as.vector+ ## stopifnot(length(clyt) == 1L) |
||
| 3061 | +1166 |
- setMethod("as.vector", "VTableTree", function(x, mode) {
+ ## vec = clyt[[1]] |
||
| 3062 | -12x | +|||
| 1167 | +
- stopifnot(nrow(x) == 1L)+ ## vcls = vapply(vec, class, "") |
|||
| 3063 | -12x | +|||
| 1168 | +
- if (nrow(content_table(x)) == 1L) {
+ ## pos = max(which(vcls == "MultiVarSplit")) |
|||
| 3064 | -! | +|||
| 1169 | +22x |
- tab <- content_table(x)+ paste(c("ac", get_acolvar_vars(lyt)), collapse = "_")
|
||
| 3065 | +1170 |
- } else {
+ } |
||
| 3066 | -12x | +|||
| 1171 | +
- tab <- x+ |
|||
| 3067 | +1172 |
- }+ get_acolvar_vars <- function(lyt) {
|
||
| 3068 | -12x | +1173 | +35x |
- as.vector(tree_children(tab)[[1]], mode = mode)+ clyt <- clayout(lyt) |
| 3069 | -+ | |||
| 1174 | +35x |
- })+ stopifnot(length(clyt) == 1L) |
||
| 3070 | -+ | |||
| 1175 | +35x |
-
+ vec <- clyt[[1]] |
||
| 3071 | -+ | |||
| 1176 | +35x |
- #' @inheritParams asvec+ vcls <- vapply(vec, class, "") |
||
| 3072 | -+ | |||
| 1177 | +35x |
- #'+ pos <- which(vcls == "MultiVarSplit") |
||
| 3073 | -+ | |||
| 1178 | +35x |
- #' @rdname int_methods+ if (length(pos) > 0) {
|
||
| 3074 | -+ | |||
| 1179 | +35x |
- #' @exportMethod as.vector+ spl_payload(vec[[pos]]) |
||
| 3075 | +1180 |
- setMethod("as.vector", "TableRow", function(x, mode) as.vector(unlist(row_values(x)), mode = mode))
+ } else {
|
||
| 3076 | -+ | |||
| 1181 | +! |
-
+ "non_multivar" |
||
| 3077 | +1182 |
- #' @rdname int_methods+ } |
||
| 3078 | +1183 |
- #' @exportMethod as.vector+ } |
||
| 3079 | +1184 |
- setMethod("as.vector", "ElementaryTable", function(x, mode) {
+
|
||
| 3080 | -2x | +|||
| 1185 | +
- stopifnot(nrow(x) == 1L)+ #' Generate rows analyzing different variables across columns |
|||
| 3081 | -2x | +|||
| 1186 | +
- as.vector(tree_children(x)[[1]], mode = mode)+ #' |
|||
| 3082 | +1187 |
- })+ #' @inheritParams lyt_args |
||
| 3083 | +1188 |
-
+ #' @param afun (`function` or `list`)\cr function(s) to be used to calculate the values in each column. The list |
||
| 3084 | +1189 |
- ## cuts ----+ #' will be repped out as needed and matched by position with the columns during tabulation. This functions |
||
| 3085 | +1190 |
-
+ #' accepts the same parameters as [analyze()] like `afun` and `format`. For further information see |
||
| 3086 | +1191 |
- #' @rdname int_methods+ #' [additional_fun_params]. |
||
| 3087 | -220x | +|||
| 1192 | +
- setGeneric("spl_cuts", function(obj) standardGeneric("spl_cuts"))
+ #' |
|||
| 3088 | +1193 |
-
+ #' @inherit split_cols_by return |
||
| 3089 | +1194 |
- #' @rdname int_methods+ #' |
||
| 3090 | +1195 |
- setMethod(+ #' @seealso [split_cols_by_multivar()] |
||
| 3091 | +1196 |
- "spl_cuts", "VarStaticCutSplit",+ #' |
||
| 3092 | -220x | +|||
| 1197 | +
- function(obj) obj@cuts+ #' @examplesIf require(dplyr) |
|||
| 3093 | +1198 |
- )+ #' library(dplyr) |
||
| 3094 | +1199 |
-
+ #' |
||
| 3095 | +1200 |
- #' @rdname int_methods+ #' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n())) |
||
| 3096 | -264x | +|||
| 1201 | +
- setGeneric("spl_cutlabels", function(obj) standardGeneric("spl_cutlabels"))
+ #' |
|||
| 3097 | +1202 |
-
+ #' ## toy example where we take the mean of the first variable and the |
||
| 3098 | +1203 |
- #' @rdname int_methods+ #' ## count of >.5 for the second. |
||
| 3099 | +1204 |
- setMethod(+ #' colfuns <- list( |
||
| 3100 | +1205 |
- "spl_cutlabels", "VarStaticCutSplit",+ #' function(x) rcell(mean(x), format = "xx.x"), |
||
| 3101 | -264x | +|||
| 1206 | +
- function(obj) obj@cut_labels+ #' function(x) rcell(sum(x > .5), format = "xx") |
|||
| 3102 | +1207 |
- )+ #' ) |
||
| 3103 | +1208 |
-
+ #' |
||
| 3104 | +1209 |
- #' @rdname int_methods+ #' lyt <- basic_table() %>% |
||
| 3105 | -5x | +|||
| 1210 | +
- setGeneric("spl_cutfun", function(obj) standardGeneric("spl_cutfun"))
+ #' split_cols_by("ARM") %>%
|
|||
| 3106 | +1211 |
-
+ #' split_cols_by_multivar(c("value", "pctdiff")) %>%
|
||
| 3107 | +1212 |
- #' @rdname int_methods+ #' split_rows_by("RACE",
|
||
| 3108 | +1213 |
- setMethod(+ #' split_label = "ethnicity", |
||
| 3109 | +1214 |
- "spl_cutfun", "VarDynCutSplit",+ #' split_fun = drop_split_levels |
||
| 3110 | -5x | +|||
| 1215 | +
- function(obj) obj@cut_fun+ #' ) %>% |
|||
| 3111 | +1216 |
- )+ #' summarize_row_groups() %>% |
||
| 3112 | +1217 |
-
+ #' analyze_colvars(afun = colfuns) |
||
| 3113 | +1218 |
- #' @rdname int_methods+ #' lyt |
||
| 3114 | -5x | +|||
| 1219 | +
- setGeneric("spl_cutlabelfun", function(obj) standardGeneric("spl_cutlabelfun"))
+ #' |
|||
| 3115 | +1220 |
-
+ #' tbl <- build_table(lyt, ANL) |
||
| 3116 | +1221 |
- #' @rdname int_methods+ #' tbl |
||
| 3117 | +1222 |
- setMethod(+ #' |
||
| 3118 | +1223 |
- "spl_cutlabelfun", "VarDynCutSplit",+ #' lyt2 <- basic_table() %>% |
||
| 3119 | -5x | +|||
| 1224 | +
- function(obj) obj@cut_label_fun+ #' split_cols_by("ARM") %>%
|
|||
| 3120 | +1225 |
- )+ #' split_cols_by_multivar(c("value", "pctdiff"),
|
||
| 3121 | +1226 |
-
+ #' varlabels = c("Measurement", "Pct Diff")
|
||
| 3122 | +1227 |
- #' @rdname int_methods+ #' ) %>% |
||
| 3123 | -5x | +|||
| 1228 | +
- setGeneric("spl_is_cmlcuts", function(obj) standardGeneric("spl_is_cmlcuts"))
+ #' split_rows_by("RACE",
|
|||
| 3124 | +1229 |
-
+ #' split_label = "ethnicity", |
||
| 3125 | +1230 |
- #' @rdname int_methods+ #' split_fun = drop_split_levels |
||
| 3126 | +1231 |
- setMethod(+ #' ) %>% |
||
| 3127 | +1232 |
- "spl_is_cmlcuts", "VarDynCutSplit",+ #' summarize_row_groups() %>% |
||
| 3128 | -5x | +|||
| 1233 | +
- function(obj) obj@cumulative_cuts+ #' analyze_colvars(afun = mean, format = "xx.xx") |
|||
| 3129 | +1234 |
- )+ #' |
||
| 3130 | +1235 |
-
+ #' tbl2 <- build_table(lyt2, ANL) |
||
| 3131 | +1236 |
- #' @rdname int_methods+ #' tbl2 |
||
| 3132 | +1237 |
- setGeneric(+ #' |
||
| 3133 | +1238 |
- "spl_varnames",+ #' @author Gabriel Becker |
||
| 3134 | -198x | +|||
| 1239 | +
- function(obj) standardGeneric("spl_varnames")
+ #' @export |
|||
| 3135 | +1240 |
- )+ analyze_colvars <- function(lyt, |
||
| 3136 | +1241 |
-
+ afun, |
||
| 3137 | +1242 |
- #' @rdname int_methods+ format = NULL, |
||
| 3138 | +1243 |
- setMethod(+ na_str = NA_character_, |
||
| 3139 | +1244 |
- "spl_varnames", "MultiVarSplit",+ nested = TRUE, |
||
| 3140 | -198x | +|||
| 1245 | +
- function(obj) obj@var_names+ extra_args = list(), |
|||
| 3141 | +1246 |
- )+ indent_mod = 0L, |
||
| 3142 | +1247 |
-
+ inclNAs = FALSE) {
|
||
| 3143 | -+ | |||
| 1248 | +22x |
- #' @rdname int_methods+ if (is.function(afun)) {
|
||
| 3144 | -+ | |||
| 1249 | +13x |
- setGeneric(+ subafun <- substitute(afun) |
||
| 3145 | +1250 |
- "spl_varnames<-",+ if ( |
||
| 3146 | -2x | +1251 | +13x |
- function(object, value) standardGeneric("spl_varnames<-")
+ is.name(subafun) && |
| 3147 | -+ | |||
| 1252 | +13x |
- )+ is.function(afun) && |
||
| 3148 | +1253 |
-
+ ## this is gross. basically testing |
||
| 3149 | +1254 |
- #' @rdname int_methods+ ## if the symbol we have corresponds |
||
| 3150 | +1255 |
- setMethod(+ ## in some meaningful way to the function |
||
| 3151 | +1256 |
- "spl_varnames<-", "MultiVarSplit",+ ## we will be calling. |
||
| 3152 | -+ | |||
| 1257 | +13x |
- function(object, value) {
+ identical( |
||
| 3153 | -2x | +1258 | +13x |
- oldvnms <- spl_varnames(object)+ mget( |
| 3154 | -2x | +1259 | +13x |
- oldvlbls <- spl_varlabels(object)+ as.character(subafun), |
| 3155 | -2x | +1260 | +13x |
- object@var_names <- value+ mode = "function", |
| 3156 | -2x | +1261 | +13x |
- if (identical(oldvnms, oldvlbls)) {
+ ifnotfound = list(NULL), |
| 3157 | -1x | +1262 | +13x |
- spl_varlabels(object) <- value+ inherits = TRUE |
| 3158 | -+ | |||
| 1263 | +13x |
- }+ )[[1]], |
||
| 3159 | -2x | +1264 | +13x |
- object+ afun |
| 3160 | +1265 |
- }+ ) |
||
| 3161 | +1266 |
- )+ ) {
|
||
| 3162 | -+ | |||
| 1267 | +13x |
-
+ defrowlab <- as.character(subafun) |
||
| 3163 | +1268 |
- #' Top left material+ } else {
|
||
| 3164 | -+ | |||
| 1269 | +! |
- #'+ defrowlab <- "" |
||
| 3165 | +1270 |
- #' A `TableTree` object can have *top left material* which is a sequence of strings which are printed in the+ } |
||
| 3166 | -+ | |||
| 1271 | +13x |
- #' area of the table between the column header display and the label of the first row. These functions access+ afun <- lapply( |
||
| 3167 | -+ | |||
| 1272 | +13x |
- #' and modify that material.+ get_acolvar_vars(lyt), |
||
| 3168 | -+ | |||
| 1273 | +13x |
- #'+ function(x) afun |
||
| 3169 | +1274 |
- #' @inheritParams gen_args+ ) |
||
| 3170 | +1275 |
- #'+ } else {
|
||
| 3171 | -+ | |||
| 1276 | +9x |
- #' @return A character vector representing the top-left material of `obj` (or `obj` after modification, in the+ defrowlab <- "" |
||
| 3172 | +1277 |
- #' case of the setter).+ } |
||
| 3173 | -+ | |||
| 1278 | +22x |
- #'+ spl <- AnalyzeColVarSplit( |
||
| 3174 | -+ | |||
| 1279 | +22x |
- #' @export+ afun = afun, |
||
| 3175 | -+ | |||
| 1280 | +22x |
- #' @rdname top_left+ defrowlab = defrowlab, |
||
| 3176 | -6887x | +1281 | +22x |
- setGeneric("top_left", function(obj) standardGeneric("top_left"))
+ split_format = format, |
| 3177 | -+ | |||
| 1282 | +22x |
-
+ split_na_str = na_str, |
||
| 3178 | -+ | |||
| 1283 | +22x |
- #' @export+ split_name = get_acolvar_name(lyt), |
||
| 3179 | -+ | |||
| 1284 | +22x |
- #' @rdname top_left+ indent_mod = indent_mod, |
||
| 3180 | -2993x | +1285 | +22x |
- setMethod("top_left", "VTableTree", function(obj) top_left(col_info(obj)))
+ extra_args = extra_args, |
| 3181 | -+ | |||
| 1286 | +22x |
-
+ inclNAs = inclNAs |
||
| 3182 | +1287 |
- #' @export+ ) |
||
| 3183 | -+ | |||
| 1288 | +22x |
- #' @rdname top_left+ pos <- next_rpos(lyt, nested, for_analyze = TRUE) |
||
| 3184 | -3568x | +1289 | +22x |
- setMethod("top_left", "InstantiatedColumnInfo", function(obj) obj@top_left)
+ split_rows(lyt, spl, pos) |
| 3185 | +1290 |
-
+ } |
||
| 3186 | +1291 |
- #' @export+ |
||
| 3187 | +1292 |
- #' @rdname top_left+ ## Add a total column at the next **top level** spot in |
||
| 3188 | -326x | +|||
| 1293 | +
- setMethod("top_left", "PreDataTableLayouts", function(obj) obj@top_left)
+ ## the column layout. |
|||
| 3189 | +1294 | |||
| 3190 | +1295 |
- #' @export+ #' Add overall column |
||
| 3191 | +1296 |
- #' @rdname top_left- |
- ||
| 3192 | -5909x | -
- setGeneric("top_left<-", function(obj, value) standardGeneric("top_left<-"))
+ #' |
||
| 3193 | +1297 |
-
+ #' This function will *only* add an overall column at the *top* level of splitting, NOT within existing column splits. |
||
| 3194 | +1298 |
- #' @export+ #' See [add_overall_level()] for the recommended way to add overall columns more generally within existing splits. |
||
| 3195 | +1299 |
- #' @rdname top_left+ #' |
||
| 3196 | +1300 |
- setMethod("top_left<-", "VTableTree", function(obj, value) {
- |
- ||
| 3197 | -2954x | -
- cinfo <- col_info(obj)- |
- ||
| 3198 | -2954x | -
- top_left(cinfo) <- value- |
- ||
| 3199 | -2954x | -
- col_info(obj) <- cinfo- |
- ||
| 3200 | -2954x | -
- obj+ #' @inheritParams lyt_args |
||
| 3201 | +1301 |
- })+ #' |
||
| 3202 | +1302 |
-
+ #' @inherit split_cols_by return |
||
| 3203 | +1303 |
- #' @export+ #' |
||
| 3204 | +1304 |
- #' @rdname top_left+ #' @seealso [add_overall_level()] |
||
| 3205 | +1305 |
- setMethod("top_left<-", "InstantiatedColumnInfo", function(obj, value) {
+ #' |
||
| 3206 | -2954x | +|||
| 1306 | +
- obj@top_left <- value+ #' @examples |
|||
| 3207 | -2954x | +|||
| 1307 | +
- obj+ #' lyt <- basic_table() %>% |
|||
| 3208 | +1308 |
- })+ #' split_cols_by("ARM") %>%
|
||
| 3209 | +1309 |
-
+ #' add_overall_col("All Patients") %>%
|
||
| 3210 | +1310 |
- #' @export+ #' analyze("AGE")
|
||
| 3211 | +1311 |
- #' @rdname top_left+ #' lyt |
||
| 3212 | +1312 |
- setMethod("top_left<-", "PreDataTableLayouts", function(obj, value) {
+ #' |
||
| 3213 | -1x | +|||
| 1313 | +
- obj@top_left <- value+ #' tbl <- build_table(lyt, DM) |
|||
| 3214 | -1x | +|||
| 1314 | +
- obj+ #' tbl |
|||
| 3215 | +1315 |
- })+ #' |
||
| 3216 | +1316 |
-
+ #' @export |
||
| 3217 | +1317 |
- vil_collapse <- function(x) {
+ add_overall_col <- function(lyt, label) {
|
||
| 3218 | -14x | +1318 | +111x |
- x <- unlist(x)+ spl <- AllSplit(label) |
| 3219 | -14x | +1319 | +111x |
- x <- x[!is.na(x)]+ split_cols( |
| 3220 | -14x | +1320 | +111x |
- x <- unique(x)+ lyt, |
| 3221 | -14x | +1321 | +111x |
- x[nzchar(x)]+ spl, |
| 3222 | -+ | |||
| 1322 | +111x |
- }+ next_cpos(lyt, FALSE) |
||
| 3223 | +1323 |
-
+ ) |
||
| 3224 | +1324 |
- #' List variables required by a pre-data table layout+ } |
||
| 3225 | +1325 |
- #'+ |
||
| 3226 | +1326 |
- #' @param lyt (`PreDataTableLayouts`)\cr the layout (or a component thereof).+ ## add_row_summary ==== |
||
| 3227 | +1327 |
- #'+ |
||
| 3228 | +1328 |
- #' @details+ #' @inheritParams lyt_args |
||
| 3229 | +1329 |
- #' This will walk the layout declaration and return a vector of the names of the unique variables that are used+ #' |
||
| 3230 | +1330 |
- #' in any of the following ways:+ #' @export |
||
| 3231 | +1331 |
#' |
||
| 3232 | +1332 |
- #' * Variable being split on (directly or via cuts)+ #' @rdname int_methods |
||
| 3233 | +1333 |
- #' * Element of a Multi-variable column split+ setGeneric( |
||
| 3234 | +1334 |
- #' * Content variable+ ".add_row_summary", |
||
| 3235 | +1335 |
- #' * Value-label variable+ function(lyt, |
||
| 3236 | +1336 |
- #'+ label, |
||
| 3237 | +1337 |
- #' @return A character vector containing the unique variables explicitly used in the layout (see the notes below).+ cfun, |
||
| 3238 | +1338 |
- #'+ child_labels = c("default", "visible", "hidden"),
|
||
| 3239 | +1339 |
- #' @note+ cformat = NULL, |
||
| 3240 | +1340 |
- #' * This function will not detect dependencies implicit in analysis or summary functions which accept `x`+ cna_str = "-", |
||
| 3241 | +1341 |
- #' or `df` and then rely on the existence of particular variables not being split on/analyzed.+ indent_mod = 0L, |
||
| 3242 | +1342 |
- #' * The order these variable names appear within the return vector is undefined and should not be relied upon.+ cvar = "", |
||
| 3243 | +1343 |
- #'+ extra_args = list()) {
|
||
| 3244 | -+ | |||
| 1344 | +455x |
- #' @examples+ standardGeneric(".add_row_summary")
|
||
| 3245 | +1345 |
- #' lyt <- basic_table() %>%+ } |
||
| 3246 | +1346 |
- #' split_cols_by("ARM") %>%
+ ) |
||
| 3247 | +1347 |
- #' split_cols_by("SEX") %>%
+
|
||
| 3248 | +1348 |
- #' summarize_row_groups(label_fstr = "Overall (N)") %>%+ #' @rdname int_methods |
||
| 3249 | +1349 |
- #' split_rows_by("RACE",
+ setMethod( |
||
| 3250 | +1350 |
- #' split_label = "Ethnicity", labels_var = "ethn_lab",+ ".add_row_summary", "PreDataTableLayouts", |
||
| 3251 | +1351 |
- #' split_fun = drop_split_levels+ function(lyt, |
||
| 3252 | +1352 |
- #' ) %>%+ label, |
||
| 3253 | +1353 |
- #' summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
+ cfun, |
||
| 3254 | +1354 |
- #' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
+ child_labels = c("default", "visible", "hidden"),
|
||
| 3255 | +1355 |
- #'+ cformat = NULL, |
||
| 3256 | +1356 |
- #' vars_in_layout(lyt)+ cna_str = "-", |
||
| 3257 | +1357 |
- #'+ indent_mod = 0L, |
||
| 3258 | +1358 |
- #' @export+ cvar = "", |
||
| 3259 | +1359 |
- #' @rdname vil+ extra_args = list()) {
|
||
| 3260 | -15x | +1360 | +116x |
- setGeneric("vars_in_layout", function(lyt) standardGeneric("vars_in_layout"))
+ child_labels <- match.arg(child_labels) |
| 3261 | -+ | |||
| 1361 | +116x |
-
+ tmp <- .add_row_summary(rlayout(lyt), label, cfun, |
||
| 3262 | -+ | |||
| 1362 | +116x |
- #' @rdname vil+ child_labels = child_labels, |
||
| 3263 | -+ | |||
| 1363 | +116x |
- setMethod(+ cformat = cformat, |
||
| 3264 | -+ | |||
| 1364 | +116x |
- "vars_in_layout", "PreDataTableLayouts",+ cna_str = cna_str, |
||
| 3265 | -+ | |||
| 1365 | +116x |
- function(lyt) {
+ indent_mod = indent_mod, |
||
| 3266 | -1x | +1366 | +116x |
- vil_collapse(c(+ cvar = cvar, |
| 3267 | -1x | +1367 | +116x |
- vars_in_layout(clayout(lyt)),+ extra_args = extra_args+ |
+
| 1368 | ++ |
+ ) |
||
| 3268 | -1x | +1369 | +116x |
- vars_in_layout(rlayout(lyt))+ rlayout(lyt) <- tmp |
| 3269 | -+ | |||
| 1370 | +116x |
- ))+ lyt |
||
| 3270 | +1371 |
} |
||
| 3271 | +1372 |
) |
||
| 3272 | +1373 | |||
| 3273 | +1374 |
- #' @rdname vil+ #' @rdname int_methods |
||
| 3274 | +1375 |
setMethod( |
||
| 3275 | +1376 |
- "vars_in_layout", "PreDataAxisLayout",+ ".add_row_summary", "PreDataRowLayout", |
||
| 3276 | +1377 |
- function(lyt) {
+ function(lyt, |
||
| 3277 | -2x | +|||
| 1378 | +
- vil_collapse(lapply(lyt, vars_in_layout))+ label, |
|||
| 3278 | +1379 |
- }+ cfun, |
||
| 3279 | +1380 |
- )+ child_labels = c("default", "visible", "hidden"),
|
||
| 3280 | +1381 |
-
+ cformat = NULL, |
||
| 3281 | +1382 |
- #' @rdname vil+ cna_str = "-", |
||
| 3282 | +1383 |
- setMethod(+ indent_mod = 0L, |
||
| 3283 | +1384 |
- "vars_in_layout", "SplitVector",+ cvar = "", |
||
| 3284 | +1385 |
- function(lyt) {
+ extra_args = list()) {
|
||
| 3285 | -3x | +1386 | +116x |
- vil_collapse(lapply(lyt, vars_in_layout))+ child_labels <- match.arg(child_labels) |
| 3286 | -+ | |||
| 1387 | +116x |
- }+ if (length(lyt) == 0 || (length(lyt) == 1 && length(lyt[[1]]) == 0)) {
|
||
| 3287 | +1388 |
- )+ ## XXX ignoring indent mod here |
||
| 3288 | -+ | |||
| 1389 | +9x |
-
+ rt <- root_spl(lyt) |
||
| 3289 | -+ | |||
| 1390 | +9x |
- #' @rdname vil+ rt <- .add_row_summary(rt, |
||
| 3290 | -+ | |||
| 1391 | +9x |
- setMethod(+ label, |
||
| 3291 | -+ | |||
| 1392 | +9x |
- "vars_in_layout", "Split",+ cfun, |
||
| 3292 | -+ | |||
| 1393 | +9x |
- function(lyt) {
+ child_labels = child_labels, |
||
| 3293 | -7x | +1394 | +9x |
- vil_collapse(c(+ cformat = cformat, |
| 3294 | -7x | +1395 | +9x |
- spl_payload(lyt),+ cna_str = cna_str,+ |
+
| 1396 | +9x | +
+ cvar = cvar,+ |
+ ||
| 1397 | +9x | +
+ extra_args = extra_args |
||
| 3295 | +1398 |
- ## for an AllSplit/RootSplit+ )+ |
+ ||
| 1399 | +9x | +
+ root_spl(lyt) <- rt |
||
| 3296 | +1400 |
- ## doesn't have to be same as payload+ } else {
|
||
| 3297 | -7x | +1401 | +107x |
- content_var(lyt),+ ind <- length(lyt) |
| 3298 | -7x | +1402 | +107x |
- spl_label_var(lyt)+ tmp <- .add_row_summary(lyt[[ind]], label, cfun, |
| 3299 | -+ | |||
| 1403 | +107x |
- ))+ child_labels = child_labels, |
||
| 3300 | -+ | |||
| 1404 | +107x |
- }+ cformat = cformat, |
||
| 3301 | -+ | |||
| 1405 | +107x |
- )+ cna_str = cna_str, |
||
| 3302 | -+ | |||
| 1406 | +107x |
-
+ indent_mod = indent_mod, |
||
| 3303 | -+ | |||
| 1407 | +107x |
- #' @rdname vil+ cvar = cvar, |
||
| 3304 | -+ | |||
| 1408 | +107x |
- setMethod(+ extra_args = extra_args |
||
| 3305 | +1409 |
- "vars_in_layout", "CompoundSplit",+ ) |
||
| 3306 | -1x | +1410 | +107x |
- function(lyt) vil_collapse(lapply(spl_payload(lyt), vars_in_layout))+ lyt[[ind]] <- tmp |
| 3307 | +1411 |
- )+ } |
||
| 3308 | -+ | |||
| 1412 | +116x |
-
+ lyt |
||
| 3309 | +1413 |
- #' @rdname vil+ } |
||
| 3310 | +1414 |
- setMethod(+ ) |
||
| 3311 | +1415 |
- "vars_in_layout", "ManualSplit",+ |
||
| 3312 | -1x | +|||
| 1416 | +
- function(lyt) character()+ #' @rdname int_methods |
|||
| 3313 | +1417 |
- )+ setMethod( |
||
| 3314 | +1418 |
-
+ ".add_row_summary", "SplitVector", |
||
| 3315 | +1419 |
- ## Titles and footers ----+ function(lyt, |
||
| 3316 | +1420 |
-
+ label, |
||
| 3317 | +1421 |
- # ##' Titles and Footers+ cfun, |
||
| 3318 | +1422 |
- # ##'+ child_labels = c("default", "visible", "hidden"),
|
||
| 3319 | +1423 |
- # ##' Get or set the titles and footers on an object+ cformat = NULL, |
||
| 3320 | +1424 |
- # ##'+ cna_str = "-", |
||
| 3321 | +1425 |
- # ##' @inheritParams gen_args+ indent_mod = 0L, |
||
| 3322 | +1426 |
- # ##'+ cvar = "", |
||
| 3323 | +1427 |
- # ##' @rdname title_footer+ extra_args = list()) {
|
||
| 3324 | -+ | |||
| 1428 | +107x |
- # ##' @export+ child_labels <- match.arg(child_labels) |
||
| 3325 | -+ | |||
| 1429 | +107x |
- #' @rdname formatters_methods+ ind <- length(lyt) |
||
| 3326 | -+ | |||
| 1430 | +! |
- #' @export+ if (ind == 0) stop("no split to add content rows at")
+ |
+ ||
| 1431 | +107x | +
+ spl <- lyt[[ind]] |
||
| 3327 | +1432 |
- setMethod(+ # if(is(spl, "AnalyzeVarSplit")) |
||
| 3328 | +1433 |
- "main_title", "VTitleFooter",+ # stop("can't add content rows to analyze variable split")
|
||
| 3329 | -3560x | +1434 | +107x |
- function(obj) obj@main_title+ tmp <- .add_row_summary(spl, |
| 3330 | -+ | |||
| 1435 | +107x |
- )+ label, |
||
| 3331 | -+ | |||
| 1436 | +107x |
-
+ cfun, |
||
| 3332 | -+ | |||
| 1437 | +107x |
- ##' @rdname formatters_methods+ child_labels = child_labels, |
||
| 3333 | -+ | |||
| 1438 | +107x |
- ##' @export+ cformat = cformat, |
||
| 3334 | -+ | |||
| 1439 | +107x |
- setMethod(+ cna_str = cna_str, |
||
| 3335 | -+ | |||
| 1440 | +107x |
- "main_title<-", "VTitleFooter",+ indent_mod = indent_mod, |
||
| 3336 | -+ | |||
| 1441 | +107x |
- function(obj, value) {
+ cvar = cvar, |
||
| 3337 | -3166x | +1442 | +107x |
- stopifnot(length(value) == 1)+ extra_args = extra_args+ |
+
| 1443 | ++ |
+ ) |
||
| 3338 | -3166x | +1444 | +107x |
- obj@main_title <- value+ lyt[[ind]] <- tmp |
| 3339 | -3166x | +1445 | +107x |
- obj+ lyt |
| 3340 | +1446 |
} |
||
| 3341 | +1447 |
) |
||
| 3342 | +1448 | |||
| 3343 | +1449 |
- # Getters for TableRow is here for convenience for binding (no need of setters)+ #' @rdname int_methods |
||
| 3344 | +1450 |
- #' @rdname formatters_methods+ setMethod( |
||
| 3345 | +1451 |
- #' @export+ ".add_row_summary", "Split", |
||
| 3346 | +1452 |
- setMethod(+ function(lyt, |
||
| 3347 | +1453 |
- "main_title", "TableRow",+ label, |
||
| 3348 | -6x | +|||
| 1454 | +
- function(obj) ""+ cfun, |
|||
| 3349 | +1455 |
- )+ child_labels = c("default", "visible", "hidden"),
|
||
| 3350 | +1456 |
-
+ cformat = NULL, |
||
| 3351 | +1457 |
- #' @rdname formatters_methods+ cna_str = "-", |
||
| 3352 | +1458 |
- #' @export+ indent_mod = 0L, |
||
| 3353 | +1459 |
- setMethod(+ cvar = "", |
||
| 3354 | +1460 |
- "subtitles", "VTitleFooter",+ extra_args = list()) {
|
||
| 3355 | -3550x | +1461 | +116x |
- function(obj) obj@subtitles+ child_labels <- match.arg(child_labels) |
| 3356 | +1462 |
- )+ # lbl_kids = .labelkids_helper(child_labels) |
||
| 3357 | -+ | |||
| 1463 | +116x |
-
+ content_fun(lyt) <- cfun |
||
| 3358 | -+ | |||
| 1464 | +116x |
- #' @rdname formatters_methods+ content_indent_mod(lyt) <- indent_mod |
||
| 3359 | -+ | |||
| 1465 | +116x |
- #' @export+ content_var(lyt) <- cvar |
||
| 3360 | +1466 |
- setMethod(+ ## obj_format(lyt) = cformat |
||
| 3361 | -+ | |||
| 1467 | +116x |
- "subtitles<-", "VTitleFooter",+ content_format(lyt) <- cformat+ |
+ ||
| 1468 | +116x | +
+ if (!identical(child_labels, "default") && !identical(child_labels, label_kids(lyt))) {
+ |
+ ||
| 1469 | +! | +
+ label_kids(lyt) <- child_labels |
||
| 3362 | +1470 |
- function(obj, value) {
+ } |
||
| 3363 | -3161x | +1471 | +116x |
- obj@subtitles <- value+ content_na_str <- cna_str |
| 3364 | -3161x | +1472 | +116x |
- obj+ content_extra_args(lyt) <- extra_args+ |
+
| 1473 | +116x | +
+ lyt |
||
| 3365 | +1474 |
} |
||
| 3366 | +1475 |
) |
||
| 3367 | +1476 | |||
| 3368 | +1477 |
- #' @rdname formatters_methods+ .count_raw_constr <- function(var, format, label_fstr) {
|
||
| 3369 | -+ | |||
| 1478 | +1x |
- #' @export+ function(df, labelstr = "") {
|
||
| 3370 | -+ | |||
| 1479 | +3x |
- setMethod(+ if (grepl("%s", label_fstr, fixed = TRUE)) {
+ |
+ ||
| 1480 | +! | +
+ label <- sprintf(label_fstr, labelstr) |
||
| 3371 | +1481 |
- "subtitles", "TableRow", # Only getter: see main_title for TableRow+ } else {
|
||
| 3372 | -6x | +1482 | +3x |
- function(obj) character()+ label <- label_fstr |
| 3373 | +1483 |
- )+ } |
||
| 3374 | -+ | |||
| 1484 | +3x |
-
+ if (is(df, "data.frame")) {
|
||
| 3375 | -+ | |||
| 1485 | +3x |
- #' @rdname formatters_methods+ if (!is.null(var) && nzchar(var)) {
|
||
| 3376 | -+ | |||
| 1486 | +3x |
- #' @export+ cnt <- sum(!is.na(df[[var]])) |
||
| 3377 | +1487 |
- setMethod(+ } else {
+ |
+ ||
| 1488 | +! | +
+ cnt <- nrow(df) |
||
| 3378 | +1489 |
- "main_footer", "VTitleFooter",+ } |
||
| 3379 | -3568x | +1490 | +1x |
- function(obj) obj@main_footer+ } else { # df is the data column vector
|
| 3380 | -+ | |||
| 1491 | +! |
- )+ cnt <- sum(!is.na(df)) |
||
| 3381 | +1492 |
-
+ } |
||
| 3382 | -+ | |||
| 1493 | +3x |
- #' @rdname formatters_methods+ ret <- rcell(cnt, |
||
| 3383 | -+ | |||
| 1494 | +3x |
- #' @export+ format = format, |
||
| 3384 | -+ | |||
| 1495 | +3x |
- setMethod(+ label = label, |
||
| 3385 | -+ | |||
| 1496 | +3x |
- "main_footer<-", "VTitleFooter",+ stat_names = "n" |
||
| 3386 | +1497 |
- function(obj, value) {
- |
- ||
| 3387 | -3166x | -
- obj@main_footer <- value+ ) |
||
| 3388 | -3166x | +1498 | +3x |
- obj+ ret |
| 3389 | +1499 |
} |
||
| 3390 | +1500 |
- )+ } |
||
| 3391 | +1501 | |||
| 3392 | -- |
- #' @rdname formatters_methods- |
- ||
| 3393 | +1502 |
- #' @export+ .count_wpcts_constr <- function(var, format, label_fstr) {
|
||
| 3394 | -+ | |||
| 1503 | +102x |
- setMethod(+ function(df, labelstr = "", .N_col) {
|
||
| 3395 | -+ | |||
| 1504 | +1579x |
- "main_footer", "TableRow", # Only getter: see main_title for TableRow+ if (grepl("%s", label_fstr, fixed = TRUE)) {
|
||
| 3396 | -6x | +1505 | +1555x |
- function(obj) character()+ label <- sprintf(label_fstr, labelstr) |
| 3397 | +1506 |
- )+ } else {
|
||
| 3398 | -+ | |||
| 1507 | +24x |
-
+ label <- label_fstr |
||
| 3399 | +1508 |
- #' @rdname formatters_methods+ } |
||
| 3400 | -+ | |||
| 1509 | +1579x |
- #' @export+ if (is(df, "data.frame")) {
|
||
| 3401 | -+ | |||
| 1510 | +1579x |
- setMethod(+ if (!is.null(var) && nzchar(var)) {
+ |
+ ||
| 1511 | +383x | +
+ cnt <- sum(!is.na(df[[var]])) |
||
| 3402 | +1512 |
- "prov_footer", "VTitleFooter",+ } else {
|
||
| 3403 | -3549x | +1513 | +1196x |
- function(obj) obj@provenance_footer+ cnt <- nrow(df) |
| 3404 | +1514 |
- )+ } |
||
| 3405 | -+ | |||
| 1515 | +102x |
-
+ } else { # df is the data column vector
|
||
| 3406 | -+ | |||
| 1516 | +! |
- #' @rdname formatters_methods+ cnt <- sum(!is.na(df)) |
||
| 3407 | +1517 |
- #' @export+ } |
||
| 3408 | +1518 |
- setMethod(+ ## the formatter does the *100 so we don't here. |
||
| 3409 | +1519 |
- "prov_footer<-", "VTitleFooter",+ ## Elements are named with stat_names so that ARD generation has access to them |
||
| 3410 | -+ | |||
| 1520 | +1579x |
- function(obj, value) {
+ ret <- rcell(c(cnt, cnt / .N_col), |
||
| 3411 | -3160x | +1521 | +1579x |
- obj@provenance_footer <- value+ format = format, |
| 3412 | -3160x | +1522 | +1579x |
- obj+ label = label, |
| 3413 | -+ | |||
| 1523 | +1579x |
- }+ stat_names = c("n", "p")
|
||
| 3414 | +1524 |
- )+ ) |
||
| 3415 | -+ | |||
| 1525 | +1579x |
-
+ ret |
||
| 3416 | +1526 |
- #' @rdname formatters_methods+ } |
||
| 3417 | +1527 |
- #' @export+ } |
||
| 3418 | +1528 |
- setMethod(+ |
||
| 3419 | +1529 |
- "prov_footer", "TableRow", # Only getter: see main_title for TableRow+ .validate_cfuns <- function(fun) {
|
||
| 3420 | -6x | +1530 | +122x |
- function(obj) character()+ if (is.list(fun)) {
|
| 3421 | -+ | |||
| 1531 | +2x |
- )+ return(unlist(lapply(fun, .validate_cfuns))) |
||
| 3422 | +1532 |
-
+ } |
||
| 3423 | +1533 |
- make_ref_value <- function(value) {
+
|
||
| 3424 | -3232x | +1534 | +120x |
- if (is(value, "RefFootnote")) {
+ frmls <- formals(fun) |
| 3425 | -! | +|||
| 1535 | +120x |
- value <- list(value)+ ls_pos <- match("labelstr", names(frmls))
|
||
| 3426 | -3232x | +1536 | +120x |
- } else if (!is.list(value) || any(!sapply(value, is, "RefFootnote"))) {
+ if (is.na(ls_pos)) {
|
| 3427 | -10x | +|||
| 1537 | +! |
- value <- lapply(value, RefFootnote)+ stop("content functions must explicitly accept a 'labelstr' argument")
|
||
| 3428 | +1538 |
} |
||
| 1539 | ++ | + + | +||
| 3429 | -3232x | +1540 | +120x |
- value+ list(fun) |
| 3430 | +1541 |
} |
||
| 3431 | +1542 | |||
| 3432 | +1543 |
- #' Referential footnote accessors+ #' Analysis function to count levels of a factor with percentage of the column total |
||
| 3433 | +1544 |
#' |
||
| 3434 | +1545 |
- #' Access and set the referential footnotes aspects of a built table.+ #' @param x (`factor`)\cr a vector of data, provided by rtables pagination machinery. |
||
| 3435 | +1546 |
- #'+ #' @param .N_col (`integer(1)`)\cr total count for the column, provided by rtables pagination machinery. |
||
| 3436 | +1547 |
- #' @inheritParams gen_args+ #' |
||
| 3437 | +1548 |
- #'+ #' @return A `RowsVerticalSection` object with counts (and percents) for each level of the factor. |
||
| 3438 | +1549 |
- #' @export+ #' |
||
| 3439 | +1550 |
- #' @rdname ref_fnotes- |
- ||
| 3440 | -50253x | -
- setGeneric("row_footnotes", function(obj) standardGeneric("row_footnotes"))
+ #' @examples |
||
| 3441 | +1551 |
-
+ #' counts_wpcts(DM$SEX, 400) |
||
| 3442 | +1552 |
- #' @export+ #' |
||
| 3443 | +1553 |
- #' @rdname int_methods+ #' @export |
||
| 3444 | +1554 |
- setMethod(+ counts_wpcts <- function(x, .N_col) {
|
||
| 3445 | -+ | |||
| 1555 | +2x |
- "row_footnotes", "TableRow",+ if (!is.factor(x)) {
|
||
| 3446 | -48266x | +1556 | +1x |
- function(obj) obj@row_footnotes+ stop( |
| 3447 | -+ | |||
| 1557 | +1x |
- )+ "using the 'counts_wpcts' analysis function requires factor data ", |
||
| 3448 | -+ | |||
| 1558 | +1x |
-
+ "to guarantee equal numbers of rows across all collumns, got class ", |
||
| 3449 | -+ | |||
| 1559 | +1x |
- #' @export+ class(x), "." |
||
| 3450 | +1560 |
- #' @rdname int_methods+ ) |
||
| 3451 | +1561 |
- setMethod(+ } |
||
| 3452 | -+ | |||
| 1562 | +1x |
- "row_footnotes", "RowsVerticalSection",+ ret <- table(x) |
||
| 3453 | -1567x | +1563 | +1x |
- function(obj) attr(obj, "row_footnotes", exact = TRUE) %||% list()+ in_rows(.list = lapply(ret, function(y) rcell(y * c(1, 1 / .N_col), format = "xx (xx.x%)"))) |
| 3454 | +1564 |
- )+ } |
||
| 3455 | +1565 | |||
| 3456 | +1566 |
- #' @export+ #' Add a content row of summary counts |
||
| 3457 | +1567 |
- #' @rdname ref_fnotes- |
- ||
| 3458 | -65x | -
- setGeneric("row_footnotes<-", function(obj, value) standardGeneric("row_footnotes<-"))
+ #' |
||
| 3459 | +1568 |
-
+ #' @inheritParams lyt_args |
||
| 3460 | +1569 |
- #' @export+ #' |
||
| 3461 | +1570 |
- #' @rdname int_methods+ #' @inherit split_cols_by return |
||
| 3462 | +1571 |
- setMethod(+ #' |
||
| 3463 | +1572 |
- "row_footnotes<-", "TableRow",+ #' @details |
||
| 3464 | +1573 |
- function(obj, value) {
- |
- ||
| 3465 | -65x | -
- obj@row_footnotes <- make_ref_value(value)- |
- ||
| 3466 | -65x | -
- obj+ #' If `format` expects 1 value (i.e. it is specified as a format string and `xx` appears for two values |
||
| 3467 | +1574 |
- }+ #' (i.e. `xx` appears twice in the format string) or is specified as a function, then both raw and percent of |
||
| 3468 | +1575 |
- )+ #' column total counts are calculated. If `format` is a format string where `xx` appears only one time, only |
||
| 3469 | +1576 |
-
+ #' raw counts are used. |
||
| 3470 | +1577 |
- #' @export+ #' |
||
| 3471 | +1578 |
- #' @rdname int_methods+ #' `cfun` must accept `x` or `df` as its first argument. For the `df` argument `cfun` will receive the subset |
||
| 3472 | +1579 |
- setMethod(+ #' `data.frame` corresponding with the row- and column-splitting for the cell being calculated. Must accept |
||
| 3473 | +1580 |
- "row_footnotes", "VTableTree",+ #' `labelstr` as the second parameter, which accepts the `label` of the level of the parent split currently |
||
| 3474 | +1581 |
- function(obj) {
- |
- ||
| 3475 | -420x | -
- rws <- collect_leaves(obj, TRUE, TRUE)- |
- ||
| 3476 | -420x | -
- cells <- lapply(rws, row_footnotes)- |
- ||
| 3477 | -420x | -
- cells+ #' being summarized. Can additionally take any optional argument supported by analysis functions. (see [analyze()]). |
||
| 3478 | +1582 |
- }+ #' |
||
| 3479 | +1583 |
- )+ #' In addition, if complex custom functions are needed, we suggest checking the available [additional_fun_params] |
||
| 3480 | +1584 |
-
+ #' that can be used in `cfun`. |
||
| 3481 | +1585 |
- #' @export+ #' |
||
| 3482 | +1586 |
- #' @rdname ref_fnotes- |
- ||
| 3483 | -197795x | -
- setGeneric("cell_footnotes", function(obj) standardGeneric("cell_footnotes"))
+ #' @examples |
||
| 3484 | +1587 |
-
+ #' DM2 <- subset(DM, COUNTRY %in% c("USA", "CAN", "CHN"))
|
||
| 3485 | +1588 |
- #' @export+ #' |
||
| 3486 | +1589 |
- #' @rdname int_methods+ #' lyt <- basic_table() %>% |
||
| 3487 | +1590 |
- setMethod(+ #' split_cols_by("ARM") %>%
|
||
| 3488 | +1591 |
- "cell_footnotes", "CellValue",+ #' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
|
||
| 3489 | -158336x | +|||
| 1592 | +
- function(obj) attr(obj, "footnotes", exact = TRUE) %||% list()+ #' summarize_row_groups(label_fstr = "%s (n)") %>% |
|||
| 3490 | +1593 |
- )+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
|
||
| 3491 | +1594 |
-
+ #' lyt |
||
| 3492 | +1595 |
- #' @export+ #' |
||
| 3493 | +1596 |
- #' @rdname int_methods+ #' tbl <- build_table(lyt, DM2) |
||
| 3494 | +1597 |
- setMethod(+ #' tbl |
||
| 3495 | +1598 |
- "cell_footnotes", "TableRow",+ #' |
||
| 3496 | +1599 |
- function(obj) {
+ #' row_paths_summary(tbl) # summary count is a content table |
||
| 3497 | -34835x | +|||
| 1600 | +
- ret <- lapply(row_cells(obj), cell_footnotes)+ #' |
|||
| 3498 | -34835x | +|||
| 1601 | +
- if (length(ret) != ncol(obj)) {
+ #' ## use a cfun and extra_args to customize summarization |
|||
| 3499 | -144x | +|||
| 1602 | +
- ret <- rep(ret, row_cspans(obj))+ #' ## behavior |
|||
| 3500 | +1603 |
- }+ #' sfun <- function(x, labelstr, trim) {
|
||
| 3501 | -34835x | +|||
| 1604 | +
- ret+ #' in_rows( |
|||
| 3502 | +1605 |
- }+ #' c(mean(x, trim = trim), trim), |
||
| 3503 | +1606 |
- )+ #' .formats = "xx.x (xx.x%)", |
||
| 3504 | +1607 |
-
+ #' .labels = sprintf( |
||
| 3505 | +1608 |
- #' @export+ #' "%s (Trimmed mean and trim %%)", |
||
| 3506 | +1609 |
- #' @rdname int_methods+ #' labelstr |
||
| 3507 | +1610 |
- setMethod(+ #' ) |
||
| 3508 | +1611 |
- "cell_footnotes", "LabelRow",+ #' ) |
||
| 3509 | +1612 |
- function(obj) {
+ #' } |
||
| 3510 | -4204x | +|||
| 1613 | +
- rep(list(list()), ncol(obj))+ #' |
|||
| 3511 | +1614 |
- }+ #' lyt2 <- basic_table(show_colcounts = TRUE) %>% |
||
| 3512 | +1615 |
- )+ #' split_cols_by("ARM") %>%
|
||
| 3513 | +1616 |
-
+ #' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
|
||
| 3514 | +1617 |
- #' @export+ #' summarize_row_groups("AGE",
|
||
| 3515 | +1618 |
- #' @rdname int_methods+ #' cfun = sfun, |
||
| 3516 | +1619 |
- setMethod(+ #' extra_args = list(trim = .2) |
||
| 3517 | +1620 |
- "cell_footnotes", "VTableTree",+ #' ) %>% |
||
| 3518 | +1621 |
- function(obj) {
+ #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
|
||
| 3519 | -420x | +|||
| 1622 | +
- rws <- collect_leaves(obj, TRUE, TRUE)+ #' append_topleft(c("Country", " Age"))
|
|||
| 3520 | -420x | +|||
| 1623 | +
- cells <- lapply(rws, cell_footnotes)+ #' |
|||
| 3521 | -420x | +|||
| 1624 | +
- do.call(rbind, cells)+ #' tbl2 <- build_table(lyt2, DM2) |
|||
| 3522 | +1625 |
- }+ #' tbl2 |
||
| 3523 | +1626 |
- )+ #' |
||
| 3524 | +1627 |
-
+ #' @author Gabriel Becker |
||
| 3525 | +1628 |
#' @export |
||
| 3526 | +1629 |
- #' @rdname ref_fnotes+ summarize_row_groups <- function(lyt, |
||
| 3527 | -617x | +|||
| 1630 | +
- setGeneric("cell_footnotes<-", function(obj, value) standardGeneric("cell_footnotes<-"))
+ var = "", |
|||
| 3528 | +1631 |
-
+ label_fstr = "%s", |
||
| 3529 | +1632 |
- #' @export+ format = "xx (xx.x%)", |
||
| 3530 | +1633 |
- #' @rdname int_methods+ na_str = "-", |
||
| 3531 | +1634 |
- setMethod(+ cfun = NULL, |
||
| 3532 | +1635 |
- "cell_footnotes<-", "CellValue",+ indent_mod = 0L, |
||
| 3533 | +1636 |
- function(obj, value) {
+ extra_args = list()) {
|
||
| 3534 | -557x | +1637 | +116x |
- attr(obj, "footnotes") <- make_ref_value(value)+ if (is.null(cfun)) {
|
| 3535 | -557x | +1638 | +103x |
- obj+ if (is.character(format) && length(gregexpr("xx(\\.x*){0,1}", format)[[1]]) == 1) {
|
| 3536 | -+ | |||
| 1639 | +1x |
- }+ cfun <- .count_raw_constr(var, format, label_fstr) |
||
| 3537 | +1640 |
- )+ } else {
+ |
+ ||
| 1641 | +102x | +
+ cfun <- .count_wpcts_constr(var, format, label_fstr) |
||
| 3538 | +1642 |
-
+ } |
||
| 3539 | +1643 |
- .cfn_set_helper <- function(obj, value) {
+ } |
||
| 3540 | -60x | +1644 | +116x |
- if (length(value) != ncol(obj)) {
+ cfun <- .validate_cfuns(cfun) |
| 3541 | -! | +|||
| 1645 | +116x |
- stop("Did not get the right number of footnote ref values for cell_footnotes<- on a full row.")
+ .add_row_summary(lyt, |
||
| 3542 | -+ | |||
| 1646 | +116x |
- }+ cfun = cfun, |
||
| 3543 | -+ | |||
| 1647 | +116x |
-
+ cformat = format, |
||
| 3544 | -60x | +1648 | +116x |
- row_cells(obj) <- mapply(+ cna_str = na_str, |
| 3545 | -60x | +1649 | +116x |
- function(cell, fns) {
+ indent_mod = indent_mod, |
| 3546 | -191x | +1650 | +116x |
- if (is.list(fns)) {
+ cvar = var, |
| 3547 | -185x | +1651 | +116x |
- cell_footnotes(cell) <- lapply(fns, RefFootnote)+ extra_args = extra_args |
| 3548 | +1652 |
- } else {
- |
- ||
| 3549 | -6x | -
- cell_footnotes(cell) <- list(RefFootnote(fns))+ ) |
||
| 3550 | +1653 |
- }+ } |
||
| 3551 | -191x | +|||
| 1654 | +
- cell+ |
|||
| 3552 | +1655 |
- },+ #' Add the column population counts to the header |
||
| 3553 | -60x | +|||
| 1656 | +
- cell = row_cells(obj),+ #' |
|||
| 3554 | -60x | +|||
| 1657 | +
- fns = value, SIMPLIFY = FALSE+ #' Add the data derived column counts. |
|||
| 3555 | +1658 |
- )+ #' |
||
| 3556 | -60x | +|||
| 1659 | +
- obj+ #' @details It is often the case that the the column counts derived from the |
|||
| 3557 | +1660 |
- }+ #' input data to [build_table()] is not representative of the population counts. |
||
| 3558 | +1661 |
-
+ #' For example, if events are counted in the table and the header should |
||
| 3559 | +1662 |
- #' @export+ #' display the number of subjects and not the total number of events. |
||
| 3560 | +1663 |
- #' @rdname int_methods+ #' |
||
| 3561 | +1664 |
- setMethod("cell_footnotes<-", "DataRow",
+ #' @inheritParams lyt_args |
||
| 3562 | +1665 |
- definition = .cfn_set_helper+ #' |
||
| 3563 | +1666 |
- )+ #' @inherit split_cols_by return |
||
| 3564 | +1667 |
-
+ #' |
||
| 3565 | +1668 |
- #' @export+ #' @examples |
||
| 3566 | +1669 |
- #' @rdname int_methods+ #' lyt <- basic_table() %>% |
||
| 3567 | +1670 |
- setMethod("cell_footnotes<-", "ContentRow",
+ #' split_cols_by("ARM") %>%
|
||
| 3568 | +1671 |
- definition = .cfn_set_helper+ #' add_colcounts() %>% |
||
| 3569 | +1672 |
- )+ #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
|
||
| 3570 | +1673 |
-
+ #' analyze("AGE", afun = function(x) list(min = min(x), max = max(x)))
|
||
| 3571 | +1674 |
- # Deprecated methods ----+ #' lyt |
||
| 3572 | +1675 |
-
+ #' |
||
| 3573 | +1676 |
- #' @export+ #' tbl <- build_table(lyt, DM) |
||
| 3574 | +1677 |
- #' @rdname ref_fnotes+ #' tbl |
||
| 3575 | -! | +|||
| 1678 | +
- setGeneric("col_fnotes_here", function(obj) standardGeneric("col_fnotes_here"))
+ #' |
|||
| 3576 | +1679 |
-
+ #' @author Gabriel Becker |
||
| 3577 | +1680 |
#' @export |
||
| 3578 | +1681 |
- #' @rdname ref_fnotes+ add_colcounts <- function(lyt, format = "(N=xx)") {
|
||
| 3579 | -+ | |||
| 1682 | +5x |
- setMethod("col_fnotes_here", "ANY", function(obj) {
+ if (is.null(lyt)) {
|
||
| 3580 | +1683 | ! |
- lifecycle::deprecate_warn(+ lyt <- PreDataTableLayouts() |
|
| 3581 | -! | +|||
| 1684 | +
- when = "0.6.6",+ } |
|||
| 3582 | -! | +|||
| 1685 | +5x |
- what = "col_fnotes_here()",+ disp_ccounts(lyt) <- TRUE |
||
| 3583 | -! | +|||
| 1686 | +5x |
- with = "col_footnotes()"+ colcount_format(lyt) <- format |
||
| 3584 | -+ | |||
| 1687 | +5x |
- )+ lyt |
||
| 3585 | -! | +|||
| 1688 | +
- col_footnotes(obj)+ } |
|||
| 3586 | +1689 |
- })+ |
||
| 3587 | +1690 |
-
+ ## Currently existing tables can ONLY be added as new entries at the top level, never at any level of nesting. |
||
| 3588 | +1691 |
- #' @export+ #' Add an already calculated table to the layout |
||
| 3589 | +1692 |
- #' @rdname ref_fnotes+ #' |
||
| 3590 | -! | +|||
| 1693 | +
- setGeneric("col_fnotes_here<-", function(obj, value) standardGeneric("col_fnotes_here<-"))
+ #' @inheritParams lyt_args |
|||
| 3591 | +1694 |
-
+ #' @inheritParams gen_args |
||
| 3592 | +1695 |
- #' @export+ #' |
||
| 3593 | +1696 |
- #' @rdname int_methods+ #' @inherit split_cols_by return |
||
| 3594 | +1697 |
- setMethod("col_fnotes_here<-", "ANY", function(obj, value) {
+ #' |
||
| 3595 | -! | +|||
| 1698 | +
- lifecycle::deprecate_warn(+ #' @examples |
|||
| 3596 | -! | +|||
| 1699 | +
- when = "0.6.6",+ #' lyt1 <- basic_table() %>% |
|||
| 3597 | -! | +|||
| 1700 | +
- what = I("col_fnotes_here()<-"),
+ #' split_cols_by("ARM") %>%
|
|||
| 3598 | -! | +|||
| 1701 | +
- with = I("col_footnotes()<-")
+ #' analyze("AGE", afun = mean, format = "xx.xx")
|
|||
| 3599 | +1702 |
- )+ #' |
||
| 3600 | -! | +|||
| 1703 | +
- col_footnotes(obj) <- value+ #' tbl1 <- build_table(lyt1, DM) |
|||
| 3601 | +1704 |
- })+ #' tbl1 |
||
| 3602 | +1705 |
-
+ #' |
||
| 3603 | +1706 |
- #' @export+ #' lyt2 <- basic_table() %>% |
||
| 3604 | +1707 |
- #' @rdname ref_fnotes+ #' split_cols_by("ARM") %>%
|
||
| 3605 | -16323x | +|||
| 1708 | +
- setGeneric("col_footnotes", function(obj) standardGeneric("col_footnotes"))
+ #' analyze("AGE", afun = sd, format = "xx.xx") %>%
|
|||
| 3606 | +1709 |
-
+ #' add_existing_table(tbl1) |
||
| 3607 | +1710 |
- #' @export+ #' |
||
| 3608 | +1711 |
- #' @rdname int_methods+ #' tbl2 <- build_table(lyt2, DM) |
||
| 3609 | -1407x | +|||
| 1712 | +
- setMethod("col_footnotes", "LayoutColTree", function(obj) obj@col_footnotes)
+ #' tbl2 |
|||
| 3610 | +1713 |
-
+ #' |
||
| 3611 | +1714 |
- #' @export+ #' table_structure(tbl2) |
||
| 3612 | +1715 |
- #' @rdname int_methods+ #' row_paths_summary(tbl2) |
||
| 3613 | -14497x | +|||
| 1716 | +
- setMethod("col_footnotes", "LayoutColLeaf", function(obj) obj@col_footnotes)
+ #' |
|||
| 3614 | +1717 |
-
+ #' @author Gabriel Becker |
||
| 3615 | +1718 |
#' @export |
||
| 3616 | +1719 |
- #' @rdname ref_fnotes+ add_existing_table <- function(lyt, tt, indent_mod = 0) {
|
||
| 3617 | -1999x | +1720 | +1x |
- setGeneric("col_footnotes<-", function(obj, value) standardGeneric("col_footnotes<-"))
+ indent_mod(tt) <- indent_mod |
| 3618 | -+ | |||
| 1721 | +1x |
-
+ lyt <- split_rows( |
||
| 3619 | -+ | |||
| 1722 | +1x |
- #' @export+ lyt, |
||
| 3620 | -+ | |||
| 1723 | +1x |
- #' @rdname int_methods+ tt, |
||
| 3621 | -+ | |||
| 1724 | +1x |
- setMethod("col_footnotes<-", "LayoutColTree", function(obj, value) {
+ next_rpos(lyt, nested = FALSE) |
||
| 3622 | -747x | +|||
| 1725 | +
- obj@col_footnotes <- make_ref_value(value)+ ) |
|||
| 3623 | -747x | +1726 | +1x |
- obj+ lyt |
| 3624 | +1727 |
- })+ } |
||
| 3625 | +1728 | |||
| 3626 | +1729 |
- #' @export+ ## takes_coln = function(f) {
|
||
| 3627 | +1730 |
- #' @rdname int_methods+ ## stopifnot(is(f, "function")) |
||
| 3628 | +1731 |
- setMethod("col_footnotes<-", "LayoutColLeaf", function(obj, value) {
+ ## forms = names(formals(f)) |
||
| 3629 | -1252x | +|||
| 1732 | +
- obj@col_footnotes <- make_ref_value(value)+ ## res = ".N_col" %in% forms |
|||
| 3630 | -1252x | +|||
| 1733 | +
- obj+ ## res |
|||
| 3631 | +1734 |
- })+ ## } |
||
| 3632 | +1735 | |||
| 3633 | +1736 |
- #' @export+ ## takes_totn = function(f) {
|
||
| 3634 | +1737 |
- #' @rdname int_methods+ ## stopifnot(is(f, "function")) |
||
| 3635 | +1738 |
- setMethod(+ ## forms = names(formals(f)) |
||
| 3636 | +1739 |
- "col_footnotes", "VTableTree",+ ## res = ".N_total" %in% forms |
||
| 3637 | +1740 |
- function(obj) {
+ ## res |
||
| 3638 | -419x | +|||
| 1741 | +
- ctree <- coltree(obj)+ ## } |
|||
| 3639 | -419x | +|||
| 1742 | +
- cols <- tree_children(ctree)- |
- |||
| 3640 | -419x | -
- while (all(sapply(cols, is, "LayoutColTree"))) {
- |
- ||
| 3641 | -137x | -
- cols <- lapply(cols, tree_children)- |
- ||
| 3642 | -137x | -
- cols <- unlist(cols, recursive = FALSE)+ |
||
| 3643 | +1743 |
- }- |
- ||
| 3644 | -419x | -
- all_col_fnotes <- lapply(cols, col_footnotes)+ ## use data to transform dynamic cuts to static cuts |
||
| 3645 | -419x | +|||
| 1744 | +
- if (is.null(unlist(all_col_fnotes))) {
+ #' @rdname int_methods |
|||
| 3646 | -414x | +1745 | +2798x |
- return(NULL)+ setGeneric("fix_dyncuts", function(spl, df) standardGeneric("fix_dyncuts"))
|
| 3647 | +1746 |
- }+ |
||
| 3648 | +1747 |
-
+ #' @rdname int_methods |
||
| 3649 | -5x | +1748 | +1040x |
- return(all_col_fnotes)+ setMethod("fix_dyncuts", "Split", function(spl, df) spl)
|
| 3650 | +1749 |
- }+ |
||
| 3651 | +1750 |
- )+ #' @rdname int_methods |
||
| 3652 | +1751 |
-
+ setMethod( |
||
| 3653 | +1752 |
- #' @export+ "fix_dyncuts", "VarDynCutSplit", |
||
| 3654 | +1753 |
- #' @rdname ref_fnotes+ function(spl, df) {
|
||
| 3655 | -594x | +1754 | +5x |
- setGeneric("ref_index", function(obj) standardGeneric("ref_index"))
+ var <- spl_payload(spl)+ |
+
| 1755 | +5x | +
+ varvec <- df[[var]] |
||
| 3656 | +1756 | |||
| 3657 | -+ | |||
| 1757 | +5x |
- #' @export+ cfun <- spl_cutfun(spl) |
||
| 3658 | -+ | |||
| 1758 | +5x |
- #' @rdname int_methods+ cuts <- cfun(varvec) |
||
| 3659 | -+ | |||
| 1759 | +5x |
- setMethod(+ cutlabels <- spl_cutlabelfun(spl)(cuts) |
||
| 3660 | -+ | |||
| 1760 | +5x |
- "ref_index", "RefFootnote",+ if (length(cutlabels) != length(cuts) - 1 && !is.null(names(cuts))) {
|
||
| 3661 | -594x | +1761 | +1x |
- function(obj) obj@index+ cutlabels <- names(cuts)[-1] |
| 3662 | +1762 |
- )+ } |
||
| 3663 | +1763 | |||
| 3664 | -+ | |||
| 1764 | +5x |
- #' @export+ ret <- make_static_cut_split( |
||
| 3665 | -+ | |||
| 1765 | +5x |
- #' @rdname ref_fnotes+ var = var, split_label = obj_label(spl), |
||
| 3666 | -71x | +1766 | +5x |
- setGeneric("ref_index<-", function(obj, value) standardGeneric("ref_index<-"))
+ cuts = cuts, cutlabels = cutlabels, |
| 3667 | -+ | |||
| 1767 | +5x |
-
+ cumulative = spl_is_cmlcuts(spl) |
||
| 3668 | +1768 |
- #' @export+ ) |
||
| 3669 | +1769 |
- #' @rdname int_methods+ ## ret = VarStaticCutSplit(var = var, split_label = obj_label(spl), |
||
| 3670 | +1770 |
- setMethod(+ ## cuts = cuts, cutlabels = cutlabels) |
||
| 3671 | +1771 |
- "ref_index<-", "RefFootnote",+ ## ## classes are tthe same structurally CumulativeCutSplit |
||
| 3672 | +1772 |
- function(obj, value) {
- |
- ||
| 3673 | -71x | -
- obj@index <- value- |
- ||
| 3674 | -71x | -
- obj+ ## ## is just a sentinal so it can hit different make_subset_expr |
||
| 3675 | +1773 |
- }+ ## ## method |
||
| 3676 | +1774 |
- )+ ## if(spl_is_cmlcuts(spl)) |
||
| 3677 | +1775 |
-
+ ## ret = as(ret, "CumulativeCutSplit") |
||
| 3678 | -+ | |||
| 1776 | +5x |
- #' @export+ ret |
||
| 3679 | +1777 |
- #' @rdname ref_fnotes- |
- ||
| 3680 | -523x | -
- setGeneric("ref_symbol", function(obj) standardGeneric("ref_symbol"))
+ } |
||
| 3681 | +1778 |
-
+ ) |
||
| 3682 | +1779 |
- #' @export+ |
||
| 3683 | +1780 |
#' @rdname int_methods |
||
| 3684 | +1781 |
setMethod( |
||
| 3685 | +1782 |
- "ref_symbol", "RefFootnote",+ "fix_dyncuts", "VTableTree", |
||
| 3686 | -523x | +1783 | +1x |
- function(obj) obj@symbol+ function(spl, df) spl |
| 3687 | +1784 |
) |
||
| 3688 | +1785 | |||
| 3689 | +1786 |
- #' @export+ .fd_helper <- function(spl, df) {
|
||
| 3690 | -+ | |||
| 1787 | +1408x |
- #' @rdname ref_fnotes+ lst <- lapply(spl, fix_dyncuts, df = df) |
||
| 3691 | -! | +|||
| 1788 | +1408x |
- setGeneric("ref_symbol<-", function(obj, value) standardGeneric("ref_symbol<-"))
+ spl@.Data <- lst+ |
+ ||
| 1789 | +1408x | +
+ spl |
||
| 3692 | +1790 |
-
+ } |
||
| 3693 | +1791 |
- #' @export+ |
||
| 3694 | +1792 |
#' @rdname int_methods |
||
| 3695 | +1793 |
setMethod( |
||
| 3696 | +1794 |
- "ref_symbol<-", "RefFootnote",+ "fix_dyncuts", "PreDataRowLayout", |
||
| 3697 | +1795 |
- function(obj, value) {
+ function(spl, df) {
|
||
| 3698 | -! | +|||
| 1796 | +
- obj@symbol <- value+ # rt = root_spl(spl) |
|||
| 3699 | -! | +|||
| 1797 | +344x |
- obj+ ret <- .fd_helper(spl, df) |
||
| 3700 | +1798 | ++ |
+ # root_spl(ret) = rt+ |
+ |
| 1799 | +344x | +
+ ret+ |
+ ||
| 1800 |
} |
|||
| 3701 | +1801 |
) |
||
| 3702 | +1802 | |||
| 3703 | +1803 |
- #' @export+ #' @rdname int_methods |
||
| 3704 | +1804 |
- #' @rdname ref_fnotes+ setMethod( |
||
| 3705 | -515x | +|||
| 1805 | +
- setGeneric("ref_msg", function(obj) standardGeneric("ref_msg"))
+ "fix_dyncuts", "PreDataColLayout", |
|||
| 3706 | +1806 |
-
+ function(spl, df) {
|
||
| 3707 | +1807 |
- #' @export+ # rt = root_spl(spl)+ |
+ ||
| 1808 | +344x | +
+ ret <- .fd_helper(spl, df) |
||
| 3708 | +1809 |
- #' @rdname int_methods+ # root_spl(ret) = rt |
||
| 3709 | +1810 |
- setMethod(+ # disp_ccounts(ret) = disp_ccounts(spl) |
||
| 3710 | +1811 |
- "ref_msg", "RefFootnote",+ # colcount_format(ret) = colcount_format(spl) |
||
| 3711 | -515x | +1812 | +344x |
- function(obj) obj@value+ ret |
| 3712 | +1813 |
- )+ } |
||
| 3713 | +1814 | - - | -||
| 3714 | -20x | -
- setGeneric(".fnote_set_inner<-", function(ttrp, colpath, value) standardGeneric(".fnote_set_inner<-"))
+ ) |
||
| 3715 | +1815 | |||
| 3716 | +1816 |
- setMethod(+ #' @rdname int_methods |
||
| 3717 | +1817 |
- ".fnote_set_inner<-", c("TableRow", "NULL"),
+ setMethod( |
||
| 3718 | +1818 |
- function(ttrp, colpath, value) {
+ "fix_dyncuts", "SplitVector", |
||
| 3719 | -7x | +|||
| 1819 | +
- row_footnotes(ttrp) <- value+ function(spl, df) {
|
|||
| 3720 | -7x | +1820 | +720x |
- ttrp+ .fd_helper(spl, df) |
| 3721 | +1821 |
} |
||
| 3722 | +1822 |
) |
||
| 3723 | +1823 | |||
| 3724 | +1824 |
- setMethod(+ #' @rdname int_methods |
||
| 3725 | +1825 |
- ".fnote_set_inner<-", c("TableRow", "character"),
+ setMethod( |
||
| 3726 | +1826 |
- function(ttrp, colpath, value) {
- |
- ||
| 3727 | -6x | -
- ind <- .path_to_pos(path = colpath, tt = ttrp, cols = TRUE)+ "fix_dyncuts", "PreDataTableLayouts", |
||
| 3728 | -6x | +|||
| 1827 | +
- cfns <- cell_footnotes(ttrp)+ function(spl, df) {
|
|||
| 3729 | -6x | +1828 | +344x |
- cfns[[ind]] <- value+ rlayout(spl) <- fix_dyncuts(rlayout(spl), df) |
| 3730 | -6x | +1829 | +344x |
- cell_footnotes(ttrp) <- cfns+ clayout(spl) <- fix_dyncuts(clayout(spl), df) |
| 3731 | -6x | +1830 | +344x |
- ttrp+ spl |
| 3732 | +1831 |
} |
||
| 3733 | +1832 |
) |
||
| 3734 | +1833 | |||
| 3735 | +1834 |
- setMethod(+ ## Manual column construction in a simple (seeming to the user) way. |
||
| 3736 | +1835 |
- ".fnote_set_inner<-", c("InstantiatedColumnInfo", "character"),
+ #' Manual column declaration |
||
| 3737 | +1836 |
- function(ttrp, colpath, value) {
+ #' |
||
| 3738 | -1x | +|||
| 1837 | +
- ctree <- col_fnotes_at_path(coltree(ttrp), colpath, fnotes = value)+ #' @param ... one or more vectors of levels to appear in the column space. If more than one set of levels is given, |
|||
| 3739 | -1x | +|||
| 1838 | +
- coltree(ttrp) <- ctree+ #' the values of the second are nested within each value of the first, and so on. |
|||
| 3740 | -1x | +|||
| 1839 | +
- ttrp+ #' @param .lst (`list`)\cr a list of sets of levels, by default populated via `list(...)`. |
|||
| 3741 | +1840 |
- }+ #' @param ccount_format (`FormatSpec`)\cr the format to use when counts are displayed. |
||
| 3742 | +1841 |
- )+ #' |
||
| 3743 | +1842 |
-
+ #' @return An `InstantiatedColumnInfo` object, suitable for declaring the column structure for a manually constructed |
||
| 3744 | +1843 |
- setMethod(+ #' table. |
||
| 3745 | +1844 |
- ".fnote_set_inner<-", c("VTableTree", "ANY"),
+ #' |
||
| 3746 | +1845 |
- function(ttrp, colpath, value) {
+ #' @examples |
||
| 3747 | -6x | +|||
| 1846 | +
- if (labelrow_visible(ttrp) && !is.null(value)) {
+ #' # simple one level column space |
|||
| 3748 | -2x | +|||
| 1847 | +
- lblrw <- tt_labelrow(ttrp)+ #' rows <- lapply(1:5, function(i) {
|
|||
| 3749 | -2x | +|||
| 1848 | +
- row_footnotes(lblrw) <- value+ #' DataRow(rep(i, times = 3)) |
|||
| 3750 | -2x | +|||
| 1849 | +
- tt_labelrow(ttrp) <- lblrw+ #' }) |
|||
| 3751 | -4x | +|||
| 1850 | +
- } else if (NROW(content_table(ttrp)) == 1L) {
+ #' tbl <- TableTree(kids = rows, cinfo = manual_cols(split = c("a", "b", "c")))
|
|||
| 3752 | -4x | +|||
| 1851 | +
- ctbl <- content_table(ttrp)+ #' tbl |
|||
| 3753 | -4x | +|||
| 1852 | +
- pth <- make_row_df(ctbl)$path[[1]]+ #' |
|||
| 3754 | -4x | +|||
| 1853 | +
- fnotes_at_path(ctbl, pth, colpath) <- value+ #' # manually declared nesting |
|||
| 3755 | -4x | +|||
| 1854 | +
- content_table(ttrp) <- ctbl+ #' tbl2 <- TableTree( |
|||
| 3756 | +1855 |
- } else {
+ #' kids = list(DataRow(as.list(1:4))), |
||
| 3757 | +1856 |
- stop("an error occurred. this shouldn't happen. please contact the maintainer") # nocov
+ #' cinfo = manual_cols( |
||
| 3758 | +1857 |
- }+ #' Arm = c("Arm A", "Arm B"),
|
||
| 3759 | -6x | +|||
| 1858 | +
- ttrp+ #' Gender = c("M", "F")
|
|||
| 3760 | +1859 |
- }+ #' ) |
||
| 3761 | +1860 |
- )+ #' ) |
||
| 3762 | +1861 |
-
+ #' tbl2 |
||
| 3763 | +1862 |
- #' @param rowpath (`character` or `NULL`)\cr path within row structure. `NULL` indicates the footnote should+ #' |
||
| 3764 | +1863 |
- #' go on the column rather than cell.+ #' @author Gabriel Becker |
||
| 3765 | +1864 |
- #' @param colpath (`character` or `NULL`)\cr path within column structure. `NULL` indicates footnote should go+ #' @export |
||
| 3766 | +1865 |
- #' on the row rather than cell.+ manual_cols <- function(..., .lst = list(...), ccount_format = NULL) {
|
||
| 3767 | -+ | |||
| 1866 | +41x |
- #' @param reset_idx (`flag`)\cr whether the numbering for referential footnotes should be immediately+ if (is.null(names(.lst))) {
|
||
| 3768 | -+ | |||
| 1867 | +41x |
- #' recalculated. Defaults to `TRUE`.+ names(.lst) <- paste("colsplit", seq_along(.lst))
|
||
| 3769 | +1868 |
- #'+ } |
||
| 3770 | +1869 |
- #' @examples+ |
||
| 3771 | -+ | |||
| 1870 | +41x |
- #' # How to add referencial footnotes after having created a table+ splvec <- SplitVector(lst = mapply(ManualSplit, |
||
| 3772 | -+ | |||
| 1871 | +41x |
- #' lyt <- basic_table() %>%+ levels = .lst, |
||
| 3773 | -+ | |||
| 1872 | +41x |
- #' split_rows_by("SEX", page_by = TRUE) %>%
+ label = names(.lst) |
||
| 3774 | +1873 |
- #' analyze("AGE")
+ )) |
||
| 3775 | -+ | |||
| 1874 | +41x |
- #'+ ctree <- splitvec_to_coltree(data.frame(), splvec = splvec, pos = TreePos(), global_cc_format = ccount_format) |
||
| 3776 | +1875 |
- #' tbl <- build_table(lyt, DM)+ + |
+ ||
| 1876 | +41x | +
+ ret <- InstantiatedColumnInfo(treelyt = ctree)+ |
+ ||
| 1877 | +41x | +
+ rm_all_colcounts(ret) |
||
| 3777 | +1878 |
- #' tbl <- trim_rows(tbl)+ } |
||
| 3778 | +1879 |
- #' # Check the row and col structure to add precise references+ |
||
| 3779 | +1880 |
- #' # row_paths(tbl)+ |
||
| 3780 | +1881 |
- #' # col_paths(t)+ #' Set all column counts at all levels of nesting to NA |
||
| 3781 | +1882 |
- #' # row_paths_summary(tbl)+ #' |
||
| 3782 | +1883 |
- #' # col_paths_summary(tbl)+ #' @inheritParams gen_args |
||
| 3783 | +1884 |
#' |
||
| 3784 | +1885 |
- #' # Add the citation numbers on the table and relative references in the footnotes+ #' @return `obj` with all column counts reset to missing |
||
| 3785 | +1886 |
- #' fnotes_at_path(tbl, rowpath = c("SEX", "F", "AGE", "Mean")) <- "Famous paper 1"
+ #' |
||
| 3786 | +1887 |
- #' fnotes_at_path(tbl, rowpath = c("SEX", "UNDIFFERENTIATED")) <- "Unfamous paper 2"
+ #' @export |
||
| 3787 | +1888 |
- #' # tbl+ #' @examples |
||
| 3788 | +1889 |
- #'+ #' lyt <- basic_table() %>% |
||
| 3789 | +1890 |
- #' @seealso [row_paths()], [col_paths()], [row_paths_summary()], [col_paths_summary()]+ #' split_cols_by("ARM") %>%
|
||
| 3790 | +1891 |
- #'+ #' split_cols_by("SEX") %>%
|
||
| 3791 | +1892 |
- #' @export+ #' analyze("AGE")
|
||
| 3792 | +1893 |
- #' @rdname ref_fnotes+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 3793 | +1894 |
- setGeneric("fnotes_at_path<-", function(obj,
+ #' |
||
| 3794 | +1895 |
- rowpath = NULL,+ #' # before |
||
| 3795 | +1896 |
- colpath = NULL,+ #' col_counts(tbl) |
||
| 3796 | +1897 |
- reset_idx = TRUE,+ #' tbl <- rm_all_colcounts(tbl) |
||
| 3797 | +1898 |
- value) {
+ #' col_counts(tbl) |
||
| 3798 | -20x | +1899 | +229x |
- standardGeneric("fnotes_at_path<-")
+ setGeneric("rm_all_colcounts", function(obj) standardGeneric("rm_all_colcounts"))
|
| 3799 | +1900 |
- })+ |
||
| 3800 | +1901 |
-
+ #' @rdname rm_all_colcounts |
||
| 3801 | +1902 |
- ## non-null rowpath, null or non-null colpath+ #' @export |
||
| 3802 | +1903 |
- #' @inheritParams fnotes_at_path<-+ setMethod( |
||
| 3803 | +1904 |
- #'+ "rm_all_colcounts", "VTableTree", |
||
| 3804 | +1905 |
- #' @export+ function(obj) {
|
||
| 3805 | -+ | |||
| 1906 | +! |
- #' @rdname int_methods+ cinfo <- col_info(obj) |
||
| 3806 | -+ | |||
| 1907 | +! |
- setMethod(+ cinfo <- rm_all_colcounts(cinfo) |
||
| 3807 | -+ | |||
| 1908 | +! |
- "fnotes_at_path<-", c("VTableTree", "character"),
+ col_info(obj) <- cinfo+ |
+ ||
| 1909 | +! | +
+ obj |
||
| 3808 | +1910 |
- function(obj,+ } |
||
| 3809 | +1911 |
- rowpath = NULL,+ ) |
||
| 3810 | +1912 |
- colpath = NULL,+ |
||
| 3811 | +1913 |
- reset_idx = TRUE,+ #' @rdname rm_all_colcounts |
||
| 3812 | +1914 |
- value) {
+ #' @export |
||
| 3813 | -19x | +|||
| 1915 | +
- rw <- tt_at_path(obj, rowpath)+ setMethod( |
|||
| 3814 | -19x | +|||
| 1916 | +
- .fnote_set_inner(rw, colpath) <- value+ "rm_all_colcounts", "InstantiatedColumnInfo", |
|||
| 3815 | -19x | +|||
| 1917 | +
- tt_at_path(obj, rowpath) <- rw+ function(obj) {
|
|||
| 3816 | -19x | +1918 | +41x |
- if (reset_idx) {
+ ctree <- coltree(obj) |
| 3817 | -19x | +1919 | +41x |
- obj <- update_ref_indexing(obj)+ ctree <- rm_all_colcounts(ctree) |
| 3818 | -+ | |||
| 1920 | +41x |
- }+ coltree(obj) <- ctree |
||
| 3819 | -19x | +1921 | +41x |
obj |
| 3820 | +1922 |
} |
||
| 3821 | +1923 |
) |
||
| 3822 | +1924 | |||
| 3823 | +1925 |
- #' @export+ #' @rdname rm_all_colcounts |
||
| 3824 | +1926 |
- #' @rdname int_methods+ #' @export |
||
| 3825 | +1927 |
setMethod( |
||
| 3826 | +1928 |
- "fnotes_at_path<-", c("VTableTree", "NULL"),
+ "rm_all_colcounts", "LayoutColTree", |
||
| 3827 | +1929 |
- function(obj, rowpath = NULL, colpath = NULL, reset_idx = TRUE, value) {
+ function(obj) {
|
||
| 3828 | -1x | +1930 | +52x |
- cinfo <- col_info(obj)+ obj@column_count <- NA_integer_ |
| 3829 | -1x | +1931 | +52x |
- .fnote_set_inner(cinfo, colpath) <- value+ tree_children(obj) <- lapply(tree_children(obj), rm_all_colcounts) |
| 3830 | -1x | +1932 | +52x |
- col_info(obj) <- cinfo+ obj |
| 3831 | -1x | +|||
| 1933 | +
- if (reset_idx) {
+ } |
|||
| 3832 | -1x | +|||
| 1934 | +
- obj <- update_ref_indexing(obj)+ ) |
|||
| 3833 | +1935 |
- }+ |
||
| 3834 | -1x | +|||
| 1936 | +
- obj+ #' @rdname rm_all_colcounts |
|||
| 3835 | +1937 |
- }+ #' @export |
||
| 3836 | +1938 |
- )+ setMethod( |
||
| 3837 | +1939 | - - | -||
| 3838 | -2889x | -
- setGeneric("has_force_pag", function(obj) standardGeneric("has_force_pag"))
+ "rm_all_colcounts", "LayoutColLeaf", |
||
| 3839 | +1940 |
-
+ function(obj) {
|
||
| 3840 | -349x | -
- setMethod("has_force_pag", "TableTree", function(obj) !is.na(ptitle_prefix(obj)))
- |
- ||
| 3841 | -+ | 1941 | +136x |
-
+ obj@column_count <- NA_integer_ |
| 3842 | -1574x | +1942 | +136x |
- setMethod("has_force_pag", "Split", function(obj) !is.na(ptitle_prefix(obj)))
+ obj |
| 3843 | +1943 | - - | -||
| 3844 | -914x | -
- setMethod("has_force_pag", "VTableNodeInfo", function(obj) FALSE)
+ } |
||
| 3845 | +1944 | - - | -||
| 3846 | -2382x | -
- setGeneric("ptitle_prefix", function(obj) standardGeneric("ptitle_prefix"))
+ ) |
||
| 3847 | +1945 | |||
| 3848 | -357x | +|||
| 1946 | +
- setMethod("ptitle_prefix", "TableTree", function(obj) obj@page_title_prefix)
+ #' Returns a function that coerces the return values of a function to a list |
|||
| 3849 | +1947 |
-
+ #' |
||
| 3850 | -1973x | +|||
| 1948 | +
- setMethod("ptitle_prefix", "Split", function(obj) obj@page_title_prefix)
+ #' @param f (`function`)\cr the function to wrap. |
|||
| 3851 | +1949 |
-
+ #' |
||
| 3852 | -! | +|||
| 1950 | +
- setMethod("ptitle_prefix", "ANY", function(obj) NULL)
+ #' @details |
|||
| 3853 | +1951 |
-
+ #' `list_wrap_x` generates a wrapper which takes `x` as its first argument, while `list_wrap_df` generates an |
||
| 3854 | -344x | +|||
| 1952 | +
- setMethod("page_titles", "VTableTree", function(obj) obj@page_titles)
+ #' otherwise identical wrapper function whose first argument is named `df`. |
|||
| 3855 | +1953 |
-
+ #' |
||
| 3856 | +1954 |
- setMethod("page_titles<-", "VTableTree", function(obj, value) {
+ #' We provide both because when using the functions as tabulation in [analyze()], functions which take `df` as |
||
| 3857 | -19x | +|||
| 1955 | +
- obj@page_titles <- value+ #' their first argument are passed the full subset data frame, while those which accept anything else notably |
|||
| 3858 | -19x | +|||
| 1956 | +
- obj+ #' including `x` are passed only the relevant subset of the variable being analyzed. |
|||
| 3859 | +1957 |
- })+ #' |
||
| 3860 | +1958 |
-
+ #' @return A function that returns a list of `CellValue` objects. |
||
| 3861 | +1959 |
- ## Horizontal separator --------------------------------------------------------+ #' |
||
| 3862 | +1960 |
-
+ #' @examples |
||
| 3863 | +1961 |
- #' Access or recursively set header-body separator for tables+ #' summary(iris$Sepal.Length) |
||
| 3864 | +1962 |
#' |
||
| 3865 | +1963 |
- #' @inheritParams gen_args+ #' f <- list_wrap_x(summary) |
||
| 3866 | +1964 |
- #' @param value (`string`)\cr string to use as new header/body separator.+ #' f(x = iris$Sepal.Length) |
||
| 3867 | +1965 |
#' |
||
| 3868 | +1966 |
- #' @return+ #' f2 <- list_wrap_df(summary) |
||
| 3869 | +1967 |
- #' * `horizontal_sep` returns the string acting as the header separator.+ #' f2(df = iris$Sepal.Length) |
||
| 3870 | +1968 |
- #' * `horizontal_sep<-` returns `obj`, with the new header separator applied recursively to it and all its+ #' |
||
| 3871 | +1969 |
- #' subtables.+ #' @author Gabriel Becker |
||
| 3872 | +1970 |
- #'+ #' @rdname list_wrap |
||
| 3873 | +1971 |
#' @export |
||
| 3874 | -345x | -
- setGeneric("horizontal_sep", function(obj) standardGeneric("horizontal_sep"))
- |
- ||
| 3875 | +1972 |
-
+ list_wrap_x <- function(f) {
|
||
| 3876 | -+ | |||
| 1973 | +16x |
- #' @rdname horizontal_sep+ function(x, ...) {
|
||
| 3877 | -+ | |||
| 1974 | +70x |
- #' @export+ vs <- as.list(f(x, ...)) |
||
| 3878 | -+ | |||
| 1975 | +70x |
- setMethod(+ ret <- mapply( |
||
| 3879 | -+ | |||
| 1976 | +70x |
- "horizontal_sep", "VTableTree",+ function(v, nm) {
|
||
| 3880 | -345x | +1977 | +250x |
- function(obj) obj@horizontal_sep+ rcell(v, label = nm) |
| 3881 | +1978 |
- )+ }, |
||
| 3882 | -+ | |||
| 1979 | +70x |
-
+ v = vs, |
||
| 3883 | -+ | |||
| 1980 | +70x |
- #' @rdname horizontal_sep+ nm = names(vs) |
||
| 3884 | +1981 |
- #' @export+ ) |
||
| 3885 | -23453x | +1982 | +70x |
- setGeneric("horizontal_sep<-", function(obj, value) standardGeneric("horizontal_sep<-"))
+ ret |
| 3886 | +1983 |
-
+ } |
||
| 3887 | +1984 |
- #' @rdname horizontal_sep+ } |
||
| 3888 | +1985 |
- #' @export+ |
||
| 3889 | +1986 |
- setMethod(+ #' @rdname list_wrap |
||
| 3890 | +1987 |
- "horizontal_sep<-", "VTableTree",+ #' @export |
||
| 3891 | +1988 |
- function(obj, value) {
+ list_wrap_df <- function(f) {
|
||
| 3892 | -13124x | +1989 | +1x |
- cont <- content_table(obj)+ function(df, ...) {
|
| 3893 | -13124x | +1990 | +1x |
- if (NROW(cont) > 0) {
+ vs <- as.list(f(df, ...)) |
| 3894 | -1890x | +1991 | +1x |
- horizontal_sep(cont) <- value+ ret <- mapply( |
| 3895 | -1890x | +1992 | +1x |
- content_table(obj) <- cont+ function(v, nm) {
|
| 3896 | -+ | |||
| 1993 | +6x |
- }+ rcell(v, label = nm) |
||
| 3897 | +1994 | - - | -||
| 3898 | -13124x | -
- kids <- lapply(tree_children(obj),+ }, |
||
| 3899 | -13124x | +1995 | +1x |
- `horizontal_sep<-`,+ v = vs, |
| 3900 | -13124x | +1996 | +1x |
- value = value+ nm = names(vs) |
| 3901 | +1997 |
) |
||
| 3902 | -- | - - | -||
| 3903 | -13124x | -
- tree_children(obj) <- kids- |
- ||
| 3904 | -13124x | -
- obj@horizontal_sep <- value- |
- ||
| 3905 | -13124x | +1998 | +1x |
- obj+ ret |
| 3906 | +1999 |
} |
||
| 3907 | +2000 |
- )+ } |
||
| 3908 | +2001 | |||
| 3909 | +2002 |
- #' @rdname horizontal_sep+ #' Layout with 1 column and zero rows |
||
| 3910 | +2003 |
- #' @export+ #' |
||
| 3911 | +2004 |
- setMethod(+ #' Every layout must start with a basic table. |
||
| 3912 | +2005 |
- "horizontal_sep<-", "TableRow",+ #' |
||
| 3913 | -10329x | +|||
| 2006 | +
- function(obj, value) obj+ #' @inheritParams constr_args |
|||
| 3914 | +2007 |
- )+ #' @param show_colcounts (`logical(1)`)\cr Indicates whether the lowest level of |
||
| 3915 | +2008 |
-
+ #' applied to data. `NA`, the default, indicates that the `show_colcounts` |
||
| 3916 | +2009 |
- ## Section dividers ------------------------------------------------------------+ #' argument(s) passed to the relevant calls to `split_cols_by*` |
||
| 3917 | +2010 |
-
+ #' functions. Non-missing values will override the behavior specified in |
||
| 3918 | +2011 |
- # Used for splits+ #' column splitting layout instructions which create the lowest level, or |
||
| 3919 | -1599x | +|||
| 2012 | +
- setGeneric("spl_section_div", function(obj) standardGeneric("spl_section_div"))
+ #' leaf, columns. |
|||
| 3920 | +2013 |
-
+ #' @param colcount_format (`string`)\cr format for use when displaying the column counts. Must be 1d, or 2d |
||
| 3921 | +2014 |
- setMethod(+ #' where one component is a percent. This will also apply to any displayed higher |
||
| 3922 | +2015 |
- "spl_section_div", "Split",+ #' level column counts where an explicit format was not specified. Defaults to `"(N=xx)"`. See Details below. |
||
| 3923 | -1599x | +|||
| 2016 | +
- function(obj) obj@child_section_div+ #' @param top_level_section_div (`character(1)`)\cr if assigned a single character, the first (top level) split |
|||
| 3924 | +2017 |
- )+ #' or division of the table will be highlighted by a line made of that character. See [section_div] for more |
||
| 3925 | +2018 |
-
+ #' information. |
||
| 3926 | -! | +|||
| 2019 | +
- setGeneric("spl_section_div<-", function(obj, value) standardGeneric("spl_section_div<-"))
+ #' |
|||
| 3927 | +2020 |
-
+ #' @details |
||
| 3928 | +2021 |
- setMethod(+ #' `colcount_format` is ignored if `show_colcounts` is `FALSE` (the default). When `show_colcounts` is `TRUE`, |
||
| 3929 | +2022 |
- "spl_section_div<-", "Split",+ #' and `colcount_format` is 2-dimensional with a percent component, the value component for the percent is always |
||
| 3930 | +2023 |
- function(obj, value) {
+ #' populated with `1` (i.e. 100%). 1d formats are used to render the counts exactly as they normally would be, |
||
| 3931 | -! | +|||
| 2024 | +
- obj@child_section_div <- value+ #' while 2d formats which don't include a percent, and all 3d formats result in an error. Formats in the form of |
|||
| 3932 | -! | +|||
| 2025 | +
- obj+ #' functions are not supported for `colcount` format. See [formatters::list_valid_format_labels()] for the list |
|||
| 3933 | +2026 |
- }+ #' of valid format labels to select from. |
||
| 3934 | +2027 |
- )+ #' |
||
| 3935 | +2028 |
-
+ #' @inherit split_cols_by return |
||
| 3936 | +2029 |
- # Used for table object parts+ #' |
||
| 3937 | -24429x | +|||
| 2030 | +
- setGeneric("trailing_section_div", function(obj) standardGeneric("trailing_section_div"))
+ #' @note |
|||
| 3938 | -9415x | +|||
| 2031 | +
- setMethod("trailing_section_div", "VTableTree", function(obj) obj@trailing_section_div)
+ #' - Because percent components in `colcount_format` are *always* populated with the value 1, we can get arguably |
|||
| 3939 | -4578x | +|||
| 2032 | +
- setMethod("trailing_section_div", "LabelRow", function(obj) obj@trailing_section_div)
+ #' strange results, such as that individual arm columns and a combined "all patients" column all list "100%" as |
|||
| 3940 | -10436x | +|||
| 2033 | +
- setMethod("trailing_section_div", "TableRow", function(obj) obj@trailing_section_div)
+ #' their percentage, even though the individual arm columns represent strict subsets of the "all patients" column. |
|||
| 3941 | +2034 |
-
+ #' |
||
| 3942 | -1459x | +|||
| 2035 | +
- setGeneric("trailing_section_div<-", function(obj, value) standardGeneric("trailing_section_div<-"))
+ #' - Note that subtitles ([formatters::subtitles()]) and footers ([formatters::main_footer()] and |
|||
| 3943 | +2036 |
- setMethod("trailing_section_div<-", "VTableTree", function(obj, value) {
+ #' [formatters::prov_footer()]) that span more than one line can be supplied as a character vector to maintain |
||
| 3944 | -1360x | +|||
| 2037 | +
- obj@trailing_section_div <- value+ #' indentation on multiple lines. |
|||
| 3945 | -1360x | +|||
| 2038 | +
- obj+ #' |
|||
| 3946 | +2039 |
- })+ #' @examples |
||
| 3947 | +2040 |
- setMethod("trailing_section_div<-", "LabelRow", function(obj, value) {
+ #' lyt <- basic_table() %>% |
||
| 3948 | -40x | +|||
| 2041 | +
- obj@trailing_section_div <- value+ #' analyze("AGE", afun = mean)
|
|||
| 3949 | -40x | +|||
| 2042 | +
- obj+ #' |
|||
| 3950 | +2043 |
- })+ #' tbl <- build_table(lyt, DM) |
||
| 3951 | +2044 |
- setMethod("trailing_section_div<-", "TableRow", function(obj, value) {
+ #' tbl |
||
| 3952 | -59x | +|||
| 2045 | +
- obj@trailing_section_div <- value+ #' |
|||
| 3953 | -59x | +|||
| 2046 | +
- obj+ #' lyt2 <- basic_table( |
|||
| 3954 | +2047 |
- })+ #' title = "Title of table", |
||
| 3955 | +2048 |
-
+ #' subtitles = c("a number", "of subtitles"),
|
||
| 3956 | +2049 |
- #' Section dividers accessor and setter+ #' main_footer = "test footer", |
||
| 3957 | +2050 |
- #'+ #' prov_footer = paste( |
||
| 3958 | +2051 |
- #' `section_div` can be used to set or get the section divider for a table object+ #' "test.R program, executed at", |
||
| 3959 | +2052 |
- #' produced by [build_table()]. When assigned in post-processing (`section_div<-`)+ #' Sys.time() |
||
| 3960 | +2053 |
- #' the table can have a section divider after every row, each assigned independently.+ #' ) |
||
| 3961 | +2054 |
- #' If assigning during layout creation, only [split_rows_by()] (and its related row-wise+ #' ) %>% |
||
| 3962 | +2055 |
- #' splits) and [analyze()] have a `section_div` parameter that will produce separators+ #' split_cols_by("ARM") %>%
|
||
| 3963 | +2056 |
- #' between split sections and data subgroups, respectively.+ #' analyze("AGE", mean)
|
||
| 3964 | +2057 |
#' |
||
| 3965 | +2058 |
- #' @param obj (`VTableTree`)\cr table object. This can be of any class that inherits from `VTableTree`+ #' tbl2 <- build_table(lyt2, DM) |
||
| 3966 | +2059 |
- #' or `TableRow`/`LabelRow`.+ #' tbl2 |
||
| 3967 | +2060 |
- #' @param only_sep_sections (`flag`)\cr defaults to `FALSE` for `section_div<-`. Allows+ #' |
||
| 3968 | +2061 |
- #' you to set the section divider only for sections that are splits or analyses if the number of+ #' lyt3 <- basic_table( |
||
| 3969 | +2062 |
- #' values is less than the number of rows in the table. If `TRUE`, the section divider will+ #' show_colcounts = TRUE, |
||
| 3970 | +2063 |
- #' be set for all rows of the table.+ #' colcount_format = "xx. (xx.%)" |
||
| 3971 | +2064 |
- #' @param value (`character`)\cr vector of single characters to use as section dividers. Each character+ #' ) %>% |
||
| 3972 | +2065 |
- #' is repeated such that all section dividers span the width of the table. Each character that is+ #' split_cols_by("ARM")
|
||
| 3973 | +2066 |
- #' not `NA_character_` will produce a trailing separator for each row of the table. `value` length+ #' |
||
| 3974 | +2067 |
- #' should reflect the number of rows, or be between 1 and the number of splits/levels.+ #' @export |
||
| 3975 | +2068 |
- #' See the Details section below for more information.+ basic_table <- function(title = "", |
||
| 3976 | +2069 |
- #'+ subtitles = character(), |
||
| 3977 | +2070 |
- #' @return The section divider string. Each line that does not have a trailing separator+ main_footer = character(), |
||
| 3978 | +2071 |
- #' will have `NA_character_` as section divider.+ prov_footer = character(), |
||
| 3979 | +2072 |
- #'+ show_colcounts = NA, # FALSE, |
||
| 3980 | +2073 |
- #' @seealso [basic_table()] parameter `header_section_div` and `top_level_section_div` for global+ colcount_format = "(N=xx)", |
||
| 3981 | +2074 |
- #' section dividers.+ header_section_div = NA_character_, |
||
| 3982 | +2075 |
- #'+ top_level_section_div = NA_character_, |
||
| 3983 | +2076 |
- #' @details+ inset = 0L) {
+ |
+ ||
| 2077 | +329x | +
+ inset <- as.integer(inset)+ |
+ ||
| 2078 | +329x | +
+ if (is.na(inset) || inset < 0L) {
+ |
+ ||
| 2079 | +2x | +
+ stop("Got invalid table_inset value, must be an integer > 0")
|
||
| 3984 | +2080 |
- #' Assigned value to section divider must be a character vector. If any value is `NA_character_`+ }+ |
+ ||
| 2081 | +327x | +
+ .check_header_section_div(header_section_div)+ |
+ ||
| 2082 | +327x | +
+ checkmate::assert_character(top_level_section_div, len = 1, n.chars = 1) |
||
| 3985 | +2083 |
- #' the section divider will be absent for that row or section. When you want to only affect sections+ + |
+ ||
| 2084 | +327x | +
+ ret <- PreDataTableLayouts(+ |
+ ||
| 2085 | +327x | +
+ title = title,+ |
+ ||
| 2086 | +327x | +
+ subtitles = subtitles,+ |
+ ||
| 2087 | +327x | +
+ main_footer = main_footer,+ |
+ ||
| 2088 | +327x | +
+ prov_footer = prov_footer,+ |
+ ||
| 2089 | +327x | +
+ header_section_div = header_section_div,+ |
+ ||
| 2090 | +327x | +
+ top_level_section_div = top_level_section_div,+ |
+ ||
| 2091 | +327x | +
+ table_inset = as.integer(inset) |
||
| 3986 | +2092 |
- #' or splits, please use `only_sep_sections` or provide a shorter vector than the number of rows.+ ) |
||
| 3987 | +2093 |
- #' Ideally, the length of the vector should be less than the number of splits with, eventually, the+ |
||
| 3988 | +2094 |
- #' leaf-level, i.e. `DataRow` where analyze results are. Note that if only one value is inserted,+ ## unconditional now, NA case is handled in cinfo construction+ |
+ ||
| 2095 | +327x | +
+ disp_ccounts(ret) <- show_colcounts+ |
+ ||
| 2096 | +327x | +
+ colcount_format(ret) <- colcount_format |
||
| 3989 | +2097 |
- #' only the first split will be affected.+ ## if (isTRUE(show_colcounts)) {
|
||
| 3990 | +2098 |
- #' If `only_sep_sections = TRUE`, which is the default for `section_div()` produced from the table+ ## ret <- add_colcounts(ret, format = colcount_format) |
||
| 3991 | +2099 |
- #' construction, the section divider will be set for all the splits and eventually analyses, but+ ## }+ |
+ ||
| 2100 | +327x | +
+ ret |
||
| 3992 | +2101 |
- #' not for the header or each row of the table. This can be set with `header_section_div` in+ } |
||
| 3993 | +2102 |
- #' [basic_table()] or, eventually, with `hsep` in [build_table()]. If `FALSE`, the section+ |
||
| 3994 | +2103 |
- #' divider will be set for all the rows of the table.+ #' Append a description to the 'top-left' materials for the layout |
||
| 3995 | +2104 |
#' |
||
| 3996 | +2105 |
- #' @examples+ #' This function *adds* `newlines` to the current set of "top-left materials". |
||
| 3997 | +2106 |
- #' # Data+ #' |
||
| 3998 | +2107 |
- #' df <- data.frame(+ #' @details |
||
| 3999 | +2108 |
- #' cat = c(+ #' Adds `newlines` to the set of strings representing the 'top-left' materials declared in the layout (the content |
||
| 4000 | +2109 |
- #' "really long thing its so ", "long"+ #' displayed to the left of the column labels when the resulting tables are printed). |
||
| 4001 | +2110 |
- #' ),+ #' |
||
| 4002 | +2111 |
- #' value = c(6, 3, 10, 1)+ #' Top-left material strings are stored and then displayed *exactly as is*, no structure or indenting is applied to |
||
| 4003 | +2112 |
- #' )+ #' them either when they are added or when they are displayed. |
||
| 4004 | +2113 |
- #' fast_afun <- function(x) list("m" = rcell(mean(x), format = "xx."), "m/2" = max(x) / 2)
+ #' |
||
| 4005 | +2114 |
- #'+ #' @inheritParams lyt_args |
||
| 4006 | +2115 |
- #' tbl <- basic_table() %>%+ #' @param newlines (`character`)\cr the new line(s) to be added to the materials. |
||
| 4007 | +2116 |
- #' split_rows_by("cat", section_div = "~") %>%
+ #' |
||
| 4008 | +2117 |
- #' analyze("value", afun = fast_afun, section_div = " ") %>%
+ #' @note |
||
| 4009 | +2118 |
- #' build_table(df)+ #' Currently, where in the construction of the layout this is called makes no difference, as it is independent of |
||
| 4010 | +2119 |
- #'+ #' the actual splitting keywords. This may change in the future. |
||
| 4011 | +2120 |
- #' # Getter+ #' |
||
| 4012 | +2121 |
- #' section_div(tbl)+ #' This function is experimental, its name and the details of its behavior are subject to change in future versions. |
||
| 4013 | +2122 |
#' |
||
| 4014 | +2123 |
- #' # Setter+ #' @inherit split_cols_by return |
||
| 4015 | +2124 |
- #' section_div(tbl) <- letters[seq_len(nrow(tbl))]+ #' |
||
| 4016 | +2125 |
- #' tbl+ #' @seealso [top_left()] |
||
| 4017 | +2126 |
#' |
||
| 4018 | +2127 |
- #' # last letter can appear if there is another table+ #' @examplesIf require(dplyr) |
||
| 4019 | +2128 |
- #' rbind(tbl, tbl)+ #' library(dplyr) |
||
| 4020 | +2129 |
#' |
||
| 4021 | +2130 |
- #' # header_section_div+ #' DM2 <- DM %>% mutate(RACE = factor(RACE), SEX = factor(SEX)) |
||
| 4022 | +2131 |
- #' header_section_div(tbl) <- "+"+ #' |
||
| 4023 | +2132 |
- #' tbl+ #' lyt <- basic_table() %>% |
||
| 4024 | +2133 |
- #'+ #' split_cols_by("ARM") %>%
|
||
| 4025 | +2134 |
- #' @docType methods+ #' split_cols_by("SEX") %>%
|
||
| 4026 | +2135 |
- #' @rdname section_div+ #' split_rows_by("RACE") %>%
|
||
| 4027 | +2136 |
- #' @export+ #' append_topleft("Ethnicity") %>%
|
||
| 4028 | -362x | +|||
| 2137 | +
- setGeneric("section_div", function(obj) standardGeneric("section_div"))
+ #' analyze("AGE") %>%
|
|||
| 4029 | +2138 |
-
+ #' append_topleft(" Age")
|
||
| 4030 | +2139 |
- #' @rdname section_div+ #' |
||
| 4031 | +2140 |
- #' @aliases section_div,VTableTree-method+ #' tbl <- build_table(lyt, DM2) |
||
| 4032 | +2141 |
- setMethod("section_div", "VTableTree", function(obj) {
+ #' tbl |
||
| 4033 | -150x | -
- content_row_tbl <- content_table(obj)- |
- ||
| 4034 | -150x | -
- is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0 # otherwise NA or NULL- |
- ||
| 4035 | -150x | +|||
| 2142 | +
- if (labelrow_visible(obj) || is_content_table) {
+ #' |
|||
| 4036 | -67x | +|||
| 2143 | +
- section_div <- trailing_section_div(obj)+ #' @export |
|||
| 4037 | -67x | +|||
| 2144 | +
- labelrow_div <- trailing_section_div(tt_labelrow(obj))+ append_topleft <- function(lyt, newlines) {
|
|||
| 4038 | -67x | -
- rest_of_tree <- section_div(tree_children(obj))- |
- ||
| 4039 | -+ | 2145 | +51x |
- # Case it is the section itself and not the labels to have a trailing sep+ stopifnot( |
| 4040 | -67x | +2146 | +51x |
- if (!is.na(section_div)) {
+ is(lyt, "PreDataTableLayouts"), |
| 4041 | -45x | +2147 | +51x |
- rest_of_tree[length(rest_of_tree)] <- section_div+ is(newlines, "character") |
| 4042 | +2148 |
- }+ ) |
||
| 4043 | -67x | -
- unname(c(labelrow_div, rest_of_tree))- |
- ||
| 4044 | -+ | 2149 | +51x |
- } else {
+ lyt@top_left <- c(lyt@top_left, newlines) |
| 4045 | -83x | +2150 | +51x |
- unname(section_div(tree_children(obj)))+ lyt |
| 4046 | +2151 |
- }+ } |
| 4047 | +1 |
- })+ #' Create an `rtable` row |
||
| 4048 | +2 |
-
+ #' |
||
| 4049 | +3 |
- #' @rdname section_div+ #' @inheritParams compat_args |
||
| 4050 | +4 |
- #' @aliases section_div,list-method+ #' @param ... cell values. |
||
| 4051 | +5 |
- setMethod("section_div", "list", function(obj) {
- |
- ||
| 4052 | -150x | -
- unlist(lapply(obj, section_div))+ #' |
||
| 4053 | +6 |
- })+ #' @return A row object of the context-appropriate type (label or data). |
||
| 4054 | +7 |
-
+ #' |
||
| 4055 | +8 |
- #' @rdname section_div+ #' @examples |
||
| 4056 | +9 |
- #' @aliases section_div,TableRow-method+ #' rrow("ABC", c(1, 2), c(3, 2), format = "xx (xx.%)")
|
||
| 4057 | +10 |
- setMethod("section_div", "TableRow", function(obj) {
- |
- ||
| 4058 | -62x | -
- trailing_section_div(obj)+ #' rrow("")
|
||
| 4059 | +11 |
- })+ #' |
||
| 4060 | +12 |
-
+ #' @family compatibility |
||
| 4061 | +13 |
- # section_div setter from table object+ #' @export |
||
| 4062 | +14 |
- #' @rdname section_div+ rrow <- function(row.name = "", ..., format = NULL, indent = 0, inset = 0L) {
|
||
| 4063 | -+ | |||
| 15 | +258x |
- #' @export+ vals <- list(...) |
||
| 4064 | -+ | |||
| 16 | +258x |
- setGeneric("section_div<-", function(obj, only_sep_sections = FALSE, value) {
+ if (is.null(row.name)) {
|
||
| 4065 | -217x | +17 | +40x |
- standardGeneric("section_div<-")
+ row.name <- "" |
| 4066 | -+ | |||
| 18 | +218x |
- })+ } else if (!is(row.name, "character")) {
|
||
| 4067 | -+ | |||
| 19 | +! |
-
+ stop("row.name must be NULL or a character string")
|
||
| 4068 | +20 |
- #' @rdname section_div+ } |
||
| 4069 | -+ | |||
| 21 | +258x |
- #' @aliases section_div<-,VTableTree-method+ if (length(vals) == 0L) {
|
||
| 4070 | -+ | |||
| 22 | +22x |
- setMethod("section_div<-", "VTableTree", function(obj, only_sep_sections = FALSE, value) {
+ LabelRow( |
||
| 4071 | -90x | +23 | +22x |
- char_v <- as.character(value)+ lev = as.integer(indent), |
| 4072 | -90x | +24 | +22x |
- tree_depths <- unname(vapply(collect_leaves(obj), tt_level, numeric(1)))+ label = row.name, |
| 4073 | -90x | +25 | +22x |
- max_tree_depth <- max(tree_depths)+ name = row.name, |
| 4074 | -90x | +26 | +22x |
- stopifnot(is.logical(only_sep_sections))+ vis = TRUE, |
| 4075 | -90x | +27 | +22x |
- .check_char_vector_for_section_div(char_v, max_tree_depth, nrow(obj))+ table_inset = 0L |
| 4076 | +28 |
-
+ ) |
||
| 4077 | +29 |
- # Automatic establishment of intent+ } else {
|
||
| 4078 | -90x | +30 | +236x |
- if (length(char_v) < nrow(obj)) {
+ csps <- as.integer(sapply(vals, function(x) {
|
| 4079 | -3x | +31 | +1391x |
- only_sep_sections <- TRUE+ attr(x, "colspan", exact = TRUE) %||% 1L |
| 4080 | +32 |
- }+ })) |
||
| 4081 | +33 |
-
+ ## we have to leave the formats on the cells and NOT the row unless we were |
||
| 4082 | +34 |
- # Case where only separators or splits need to change externally+ ## already told to do so, because row formats get clobbered when cbinding |
||
| 4083 | -90x | +|||
| 35 | +
- if (only_sep_sections && length(char_v) < nrow(obj)) {
+ ## but cell formats do not. |
|||
| 4084 | +36 |
- # Case where char_v is longer than the max depth+ ## formats = sapply(vals, obj_format) |
||
| 4085 | -3x | +|||
| 37 | +
- char_v <- char_v[seq_len(min(max_tree_depth, length(char_v)))]+ ## if(is.character(formats) && length(unique(formats)) == 1L && is.null(format)) |
|||
| 4086 | +38 |
- # Filling up with NAs the rest of the tree depth section div chr vector+ ## format = unique(formats) |
||
| 4087 | -3x | +39 | +236x |
- missing_char_v_len <- max_tree_depth - length(char_v)+ DataRow( |
| 4088 | -3x | -
- char_v <- c(char_v, rep(NA_character_, missing_char_v_len))- |
- ||
| 4089 | -+ | 40 | +236x |
- }+ vals = vals, lev = as.integer(indent), label = row.name, |
| 4090 | -+ | |||
| 41 | +236x |
-
+ name = row.name, ## XXX TODO |
||
| 4091 | -+ | |||
| 42 | +236x |
- # Retrieving if it is a contentRow (no need for labelrow to be visible in this case)+ cspan = csps, |
||
| 4092 | -90x | +43 | +236x |
- content_row_tbl <- content_table(obj)+ format = format, |
| 4093 | -90x | +44 | +236x |
- is_content_table <- isS4(content_row_tbl) && nrow(content_row_tbl) > 0+ table_inset = as.integer(inset) |
| 4094 | +45 |
-
+ ) |
||
| 4095 | +46 |
- # Main table structure change- |
- ||
| 4096 | -90x | -
- if (labelrow_visible(obj) || is_content_table) {
+ } |
||
| 4097 | -40x | +|||
| 47 | +
- if (only_sep_sections) {
+ } |
|||
| 4098 | +48 |
- # Only tables are modified+ |
||
| 4099 | -34x | +|||
| 49 | +
- trailing_section_div(tt_labelrow(obj)) <- NA_character_+ #' Create an `rtable` row from a vector or list of values |
|||
| 4100 | -34x | +|||
| 50 | +
- trailing_section_div(obj) <- char_v[1]+ #' |
|||
| 4101 | -34x | +|||
| 51 | +
- section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1]+ #' @inheritParams compat_args |
|||
| 4102 | +52 |
- } else {
+ #' @param ... values in vector/list form. |
||
| 4103 | +53 |
- # All leaves are modified+ #' |
||
| 4104 | -6x | +|||
| 54 | +
- trailing_section_div(tt_labelrow(obj)) <- char_v[1]+ #' @inherit rrow return |
|||
| 4105 | -6x | +|||
| 55 | +
- trailing_section_div(obj) <- NA_character_+ #' |
|||
| 4106 | -6x | +|||
| 56 | +
- section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v[-1]+ #' @examples |
|||
| 4107 | +57 |
- }+ #' rrowl("a", c(1, 2, 3), format = "xx")
|
||
| 4108 | +58 |
- } else {
+ #' rrowl("a", c(1, 2, 3), c(4, 5, 6), format = "xx")
|
||
| 4109 | -50x | +|||
| 59 | +
- section_div(tree_children(obj), only_sep_sections = only_sep_sections) <- char_v+ #' |
|||
| 4110 | +60 |
- }+ #' |
||
| 4111 | -90x | +|||
| 61 | +
- obj+ #' rrowl("N", table(iris$Species))
|
|||
| 4112 | +62 |
- })+ #' rrowl("N", table(iris$Species), format = "xx")
|
||
| 4113 | +63 |
-
+ #' |
||
| 4114 | +64 |
- #' @rdname section_div+ #' x <- tapply(iris$Sepal.Length, iris$Species, mean, simplify = FALSE) |
||
| 4115 | +65 |
- #' @aliases section_div<-,list-method+ #' |
||
| 4116 | +66 |
- setMethod("section_div<-", "list", function(obj, only_sep_sections = FALSE, value) {
+ #' rrow(row.name = "row 1", x) |
||
| 4117 | -90x | +|||
| 67 | +
- char_v <- as.character(value)+ #' rrow("ABC", 2, 3)
|
|||
| 4118 | -90x | +|||
| 68 | +
- for (i in seq_along(obj)) {
+ #' |
|||
| 4119 | -121x | +|||
| 69 | +
- stopifnot(is(obj[[i]], "VTableTree") || is(obj[[i]], "TableRow") || is(obj[[i]], "LabelRow"))+ #' rrowl(row.name = "row 1", c(1, 2), c(3, 4)) |
|||
| 4120 | -121x | +|||
| 70 | +
- list_element_size <- nrow(obj[[i]])+ #' rrow(row.name = "row 2", c(1, 2), c(3, 4)) |
|||
| 4121 | -121x | +|||
| 71 | +
- if (only_sep_sections) {
+ #' |
|||
| 4122 | -97x | +|||
| 72 | +
- char_v_i <- char_v[seq_len(min(list_element_size, length(char_v)))]+ #' @family compatibility |
|||
| 4123 | -97x | +|||
| 73 | +
- char_v_i <- c(char_v_i, rep(NA_character_, list_element_size - length(char_v_i)))+ #' @export |
|||
| 4124 | +74 |
- } else {
+ rrowl <- function(row.name, ..., format = NULL, indent = 0, inset = 0L) {
|
||
| 4125 | -24x | +75 | +38x |
- init <- (i - 1) * list_element_size + 1+ dots <- list(...) |
| 4126 | -24x | +76 | +38x |
- chunk_of_char_v_to_take <- seq(init, init + list_element_size - 1)+ args_list <- c(list( |
| 4127 | -24x | -
- char_v_i <- char_v[chunk_of_char_v_to_take]- |
- ||
| 4128 | -+ | 77 | +38x |
- }+ row.name = row.name, format = format, |
| 4129 | -121x | +78 | +38x |
- section_div(obj[[i]], only_sep_sections = only_sep_sections) <- char_v_i+ indent = indent, inset = inset |
| 4130 | -+ | |||
| 79 | +38x |
- }+ ), val = unlist(lapply(dots, as.list), recursive = FALSE)) |
||
| 4131 | -90x | +80 | +38x |
- obj+ do.call(rrow, args_list) |
| 4132 | +81 |
- })+ } |
||
| 4133 | +82 | |||
| 4134 | +83 |
- #' @rdname section_div+ ## rcell moved to tt_afun_utils.R |
||
| 4135 | +84 |
- #' @aliases section_div<-,TableRow-method+ |
||
| 4136 | +85 |
- setMethod("section_div<-", "TableRow", function(obj, only_sep_sections = FALSE, value) {
+ ## inefficient trash |
||
| 4137 | -37x | +|||
| 86 | +
- trailing_section_div(obj) <- value+ paste_em_n <- function(lst, n, sep = ".") {
|
|||
| 4138 | -37x | +87 | +9x |
- obj+ ret <- lst[[1]] |
| 4139 | -+ | |||
| 88 | +9x |
- })+ if (n > 1) {
|
||
| 4140 | -+ | |||
| 89 | +4x |
-
+ for (i in 2:n) {
|
||
| 4141 | -+ | |||
| 90 | +4x |
- #' @rdname section_div+ ret <- paste(ret, lst[[i]], sep = sep) |
||
| 4142 | +91 |
- #' @aliases section_div<-,LabelRow-method+ } |
||
| 4143 | +92 |
- setMethod("section_div<-", "LabelRow", function(obj, only_sep_sections = FALSE, value) {
- |
- ||
| 4144 | -! | -
- trailing_section_div(obj) <- value+ } |
||
| 4145 | -! | +|||
| 93 | +9x |
- obj+ ret |
||
| 4146 | +94 |
- })+ } |
||
| 4147 | +95 | |||
| 4148 | -- |
- # Helper check function- |
- ||
| 4149 | +96 |
- .check_char_vector_for_section_div <- function(char_v, min_splits, max) {
+ hrows_to_colinfo <- function(rows) {
|
||
| 4150 | -90x | +97 | +34x |
- lcv <- length(char_v)+ nr <- length(rows) |
| 4151 | -90x | -
- if (lcv < 1 || lcv > max) {
- |
- ||
| 4152 | -! | +98 | +34x |
- stop("section_div must be a vector of length between 1 and numer of table rows.")
+ stopifnot(nr > 0) |
| 4153 | -+ | |||
| 99 | +34x |
- }+ cspans <- lapply(rows, row_cspans) |
||
| 4154 | -90x | +100 | +34x |
- if (lcv > min_splits && lcv < max) {
+ vals <- lapply(rows, function(x) unlist(row_values(x))) |
| 4155 | -! | +|||
| 101 | +34x |
- warning(+ unqvals <- lapply(vals, unique) |
||
| 4156 | -! | +|||
| 102 | +34x |
- "section_div will be truncated to the number of splits (", min_splits, ")",
+ formats <- lapply(rows, obj_format) |
||
| 4157 | -! | +|||
| 103 | +34x |
- " because it is shorter than the number of rows (", max, ")."
+ counts <- NULL |
||
| 4158 | -+ | |||
| 104 | +34x |
- )+ if (formats[nr] == "(N=xx)" || all(sapply(row_cells(rows[[nr]]), obj_format) == "(N=xx)")) { ## count row
|
||
| 4159 | -+ | |||
| 105 | +1x |
- }+ counts <- vals[[nr]] |
||
| 4160 | -90x | +106 | +1x |
- nchar_check_v <- nchar(char_v)+ vals <- vals[-nr] |
| 4161 | -90x | +107 | +1x |
- if (any(nchar_check_v > 1, na.rm = TRUE)) {
+ cspans <- cspans[-nr] |
| 4162 | -! | +|||
| 108 | +1x |
- stop("section_div must be a vector of single characters or NAs")
+ nr <- nr - 1 |
||
| 4163 | +109 |
} |
||
| 4164 | -- |
- }- |
- ||
| 4165 | +110 |
-
+ ## easiest case, one header row no counts. we're done |
||
| 4166 | +111 |
- #' @rdname section_div+ ## XXX could one row but cspan ever make sense???? |
||
| 4167 | +112 |
- #' @export+ ## I don't think so? |
||
| 4168 | -596x | +113 | +34x |
- setGeneric("header_section_div", function(obj) standardGeneric("header_section_div"))
+ if (nr == 1) { ## && all(cspans == 1L)) {
|
| 4169 | -+ | |||
| 114 | +29x |
-
+ ret <- manual_cols(unlist(vals[[1]])) |
||
| 4170 | -+ | |||
| 115 | +29x |
- #' @rdname section_div+ if (!is.null(counts)) {
|
||
| 4171 | -+ | |||
| 116 | +1x |
- #' @aliases header_section_div,PreDataTableLayouts-method+ col_counts(ret) <- counts |
||
| 4172 | -+ | |||
| 117 | +1x |
- setMethod(+ disp_ccounts(ret) <- TRUE |
||
| 4173 | +118 |
- "header_section_div", "PreDataTableLayouts",+ } |
||
| 4174 | -296x | +119 | +29x |
- function(obj) obj@header_section_div+ return(ret) |
| 4175 | +120 |
- )+ } |
||
| 4176 | +121 |
-
+ ## second easiest case full repeated nestin |
||
| 4177 | -+ | |||
| 122 | +5x |
- #' @rdname section_div+ repvals <- mapply(function(v, csp) rep(v, times = csp),+ |
+ ||
| 123 | +5x | +
+ v = vals, csp = cspans, SIMPLIFY = FALSE |
||
| 4178 | +124 |
- #' @aliases header_section_div,PreDataTableLayouts-method+ ) |
||
| 4179 | +125 |
- setMethod(+ |
||
| 4180 | +126 |
- "header_section_div", "VTableTree",+ ## nr > 1 here |
||
| 4181 | -300x | +127 | +5x |
- function(obj) obj@header_section_div+ fullnest <- TRUE |
| 4182 | -+ | |||
| 128 | +5x |
- )+ for (i in 2:nr) {
|
||
| 4183 | -+ | |||
| 129 | +5x |
-
+ psted <- paste_em_n(repvals, i - 1) |
||
| 4184 | -+ | |||
| 130 | +5x |
- #' @rdname section_div+ spl <- split(repvals[[i]], psted) |
||
| 4185 | -+ | |||
| 131 | +5x |
- #' @export+ if (!all(sapply(spl, function(x) identical(x, spl[[1]])))) {
|
||
| 4186 | -253x | +132 | +4x |
- setGeneric("header_section_div<-", function(obj, value) standardGeneric("header_section_div<-"))
+ fullnest <- FALSE |
| 4187 | -+ | |||
| 133 | +4x |
-
+ break |
||
| 4188 | +134 |
- #' @rdname section_div+ } |
||
| 4189 | +135 |
- #' @aliases header_section_div<-,PreDataTableLayouts-method+ } |
||
| 4190 | +136 |
- setMethod(+ |
||
| 4191 | +137 |
- "header_section_div<-", "PreDataTableLayouts",+ ## if its full nesting we're done, so put |
||
| 4192 | +138 |
- function(obj, value) {
+ ## the counts on as necessary and return. |
||
| 4193 | -1x | +139 | +5x |
- .check_header_section_div(value)+ if (fullnest) {
|
| 4194 | +140 | 1x |
- obj@header_section_div <- value+ ret <- manual_cols(.lst = unqvals) |
|
| 4195 | +141 | 1x |
- obj+ if (!is.null(counts)) {
+ |
+ |
| 142 | +! | +
+ col_counts(ret) <- counts+ |
+ ||
| 143 | +! | +
+ disp_ccounts(ret) <- TRUE |
||
| 4196 | +144 |
- }+ }+ |
+ ||
| 145 | +1x | +
+ return(ret) |
||
| 4197 | +146 |
- )+ } |
||
| 4198 | +147 | |||
| 4199 | +148 |
- #' @rdname section_div+ ## booo. the fully complex case where the multiple rows |
||
| 4200 | +149 |
- #' @aliases header_section_div<-,PreDataTableLayouts-method+ ## really don't represent nesting at all, each top level |
||
| 4201 | +150 |
- setMethod(+ ## can have different sub labels |
||
| 4202 | +151 |
- "header_section_div<-", "VTableTree",+ |
||
| 4203 | +152 |
- function(obj, value) {
- |
- ||
| 4204 | -252x | -
- .check_header_section_div(value)- |
- ||
| 4205 | -252x | -
- obj@header_section_div <- value- |
- ||
| 4206 | -252x | -
- obj- |
- ||
| 4207 | -- |
- }+ ## we will build it up as if it were full nesting and then prune |
||
| 4208 | +153 |
- )+ ## based on the columns we actually want. |
||
| 4209 | +154 | |||
| 4210 | -- |
- .check_header_section_div <- function(chr) {
- |
- ||
| 4211 | -573x | +155 | +4x |
- if (!is.na(chr) && (!is.character(chr) || length(chr) > 1 || nchar(chr) > 1 || nchar(chr) == 0)) {
+ fullcolinfo <- manual_cols(.lst = unqvals) |
| 4212 | -! | +|||
| 156 | +4x |
- stop("header_section_div must be a single character or NA_character_ if not used")
+ fullbusiness <- names(collect_leaves(coltree(fullcolinfo))) |
||
| 4213 | -+ | |||
| 157 | +4x |
- }+ wanted <- paste_em_n(repvals, nr) |
||
| 4214 | -573x | +158 | +4x |
- invisible(TRUE)+ wantcols <- match(wanted, fullbusiness) |
| 4215 | -+ | |||
| 159 | +4x |
- }+ stopifnot(all(!is.na(wantcols))) |
||
| 4216 | +160 | |||
| 4217 | -- |
- #' @rdname section_div- |
- ||
| 4218 | -- |
- #' @export- |
- ||
| 4219 | -300x | +161 | +4x |
- setGeneric("top_level_section_div", function(obj) standardGeneric("top_level_section_div"))
+ subset_cols(fullcolinfo, wantcols) |
| 4220 | +162 |
-
+ } |
||
| 4221 | +163 |
- #' @rdname section_div+ |
||
| 4222 | +164 |
- #' @aliases top_level_section_div,PreDataTableLayouts-method+ #' Create a header |
||
| 4223 | +165 |
- setMethod(+ #' |
||
| 4224 | +166 |
- "top_level_section_div", "PreDataTableLayouts",- |
- ||
| 4225 | -300x | -
- function(obj) obj@top_level_section_div+ #' @inheritParams compat_args |
||
| 4226 | +167 |
- )+ #' @param ... row specifications, either as character vectors or the output from [rrow()], [DataRow()], |
||
| 4227 | +168 |
-
+ #' [LabelRow()], etc. |
||
| 4228 | +169 |
- #' @rdname section_div+ #' |
||
| 4229 | +170 |
- #' @export- |
- ||
| 4230 | -1x | -
- setGeneric("top_level_section_div<-", function(obj, value) standardGeneric("top_level_section_div<-"))
+ #' @return A `InstantiatedColumnInfo` object. |
||
| 4231 | +171 |
-
+ #' |
||
| 4232 | +172 |
- #' @rdname section_div+ #' @examples |
||
| 4233 | +173 |
- #' @aliases top_level_section_div<-,PreDataTableLayouts-method+ #' h1 <- rheader(c("A", "B", "C"))
|
||
| 4234 | +174 |
- setMethod(+ #' h1 |
||
| 4235 | +175 |
- "top_level_section_div<-", "PreDataTableLayouts",+ #' |
||
| 4236 | +176 |
- function(obj, value) {
- |
- ||
| 4237 | -1x | -
- checkmate::assert_character(value, len = 1, n.chars = 1)- |
- ||
| 4238 | -1x | -
- obj@top_level_section_div <- value- |
- ||
| 4239 | -1x | -
- obj+ #' h2 <- rheader( |
||
| 4240 | +177 |
- }+ #' rrow(NULL, rcell("group 1", colspan = 2), rcell("group 2", colspan = 2)),
|
||
| 4241 | +178 |
- )+ #' rrow(NULL, "A", "B", "A", "B") |
||
| 4242 | +179 |
-
+ #' ) |
||
| 4243 | +180 |
- ## table_inset ----------------------------------------------------------+ #' h2 |
||
| 4244 | +181 |
-
+ #' |
||
| 4245 | +182 |
- #' @rdname formatters_methods+ #' @family compatibility |
||
| 4246 | +183 |
#' @export |
||
| 4247 | -- |
- setMethod(- |
- ||
| 4248 | +184 |
- "table_inset", "VTableNodeInfo", ## VTableTree",+ rheader <- function(..., format = "xx", .lst = NULL) {
|
||
| 4249 | -305x | +185 | +3x |
- function(obj) obj@table_inset+ if (!is.null(.lst)) {
|
| 4250 | -+ | |||
| 186 | +! |
- )+ args <- .lst |
||
| 4251 | +187 |
-
+ } else {
|
||
| 4252 | -+ | |||
| 188 | +3x |
- #' @rdname formatters_methods+ args <- list(...) |
||
| 4253 | +189 |
- #' @export+ } |
||
| 4254 | -+ | |||
| 190 | +3x |
- setMethod(+ rrows <- if (length(args) == 1 && !is(args[[1]], "TableRow")) {
|
||
| 4255 | -+ | |||
| 191 | +! |
- "table_inset", "PreDataTableLayouts",+ list(rrowl(row.name = NULL, val = args[[1]], format = format)) |
||
| 4256 | -295x | +192 | +3x |
- function(obj) obj@table_inset+ } else if (are(args, "TableRow")) {
|
| 4257 | -+ | |||
| 193 | +3x |
- )+ args |
||
| 4258 | +194 |
-
+ } |
||
| 4259 | +195 |
- ## #' @rdname formatters_methods+ |
||
| 4260 | -+ | |||
| 196 | +3x |
- ## #' @export+ hrows_to_colinfo(rrows) |
||
| 4261 | +197 |
- ## setMethod("table_inset", "InstantiatedColumnInfo",
+ } |
||
| 4262 | +198 |
- ## function(obj) obj@table_inset)+ |
||
| 4263 | +199 |
-
+ .char_to_hrows <- function(hdr) {
|
||
| 4264 | -+ | |||
| 200 | +31x |
- #' @rdname formatters_methods+ nlfnd <- grep("\n", hdr, fixed = TRUE)
|
||
| 4265 | -+ | |||
| 201 | +31x |
- #' @export+ if (length(nlfnd) == 0) {
|
||
| 4266 | -+ | |||
| 202 | +27x |
- setMethod(+ return(list(rrowl(NULL, hdr))) |
||
| 4267 | +203 |
- "table_inset<-", "VTableNodeInfo", ## "VTableTree",+ } |
||
| 4268 | +204 |
- function(obj, value) {
+
|
||
| 4269 | -15720x | +205 | +4x |
- if (!is.integer(value)) {
+ stopifnot(length(nlfnd) == length(hdr)) |
| 4270 | -5x | -
- value <- as.integer(value)- |
- ||
| 4271 | -+ | 206 | +4x |
- }+ raw <- strsplit(hdr, "\n", fixed = TRUE) |
| 4272 | -15720x | -
- if (is.na(value) || value < 0) {
- |
- ||
| 4273 | -! | +207 | +4x |
- stop("Got invalid table_inset value, must be an integer > 0")
+ lens <- unique(sapply(raw, length)) |
| 4274 | -+ | |||
| 208 | +4x |
- }+ stopifnot(length(lens) == 1L) |
||
| 4275 | -15720x | +209 | +4x |
- cont <- content_table(obj)+ lapply( |
| 4276 | -15720x | +210 | +4x |
- if (NROW(cont) > 0) {
+ seq(1, lens), |
| 4277 | -1435x | +211 | +4x |
- table_inset(cont) <- value+ function(i) {
|
| 4278 | -1435x | +212 | +8x |
- content_table(obj) <- cont+ rrowl(NULL, vapply(raw, `[`, NA_character_, i = i)) |
| 4279 | +213 |
} |
||
| 4280 | +214 | - - | -||
| 4281 | -15720x | -
- if (length(tree_children(obj)) > 0) {
- |
- ||
| 4282 | -4732x | -
- kids <- lapply(tree_children(obj),- |
- ||
| 4283 | -4732x | -
- `table_inset<-`,- |
- ||
| 4284 | -4732x | -
- value = value+ ) |
||
| 4285 | +215 |
- )- |
- ||
| 4286 | -4732x | -
- tree_children(obj) <- kids+ } |
||
| 4287 | +216 |
- }+ |
||
| 4288 | -15720x | +|||
| 217 | +
- obj@table_inset <- value+ #' Create a table |
|||
| 4289 | -15720x | +|||
| 218 | +
- obj+ #' |
|||
| 4290 | +219 |
- }+ #' @inheritParams compat_args |
||
| 4291 | +220 |
- )+ #' @inheritParams gen_args |
||
| 4292 | +221 |
-
+ #' @param header (`TableRow`, `character`, or `InstantiatedColumnInfo`)\cr information defining the header |
||
| 4293 | +222 |
- #' @rdname formatters_methods+ #' (column structure) of the table. This can be as row objects (legacy), character vectors, or an |
||
| 4294 | +223 |
- #' @export+ #' `InstantiatedColumnInfo` object. |
||
| 4295 | +224 |
- setMethod(+ #' @param ... rows to place in the table. |
||
| 4296 | +225 |
- "table_inset<-", "PreDataTableLayouts",+ #' |
||
| 4297 | +226 |
- function(obj, value) {
+ #' @return A formal table object of the appropriate type (`ElementaryTable` or `TableTree`). |
||
| 4298 | -! | +|||
| 227 | +
- if (!is.integer(value)) {
+ #' |
|||
| 4299 | -! | +|||
| 228 | +
- value <- as.integer(value)+ #' @examples |
|||
| 4300 | +229 |
- }+ #' rtable( |
||
| 4301 | -! | +|||
| 230 | +
- if (is.na(value) || value < 0) {
+ #' header = LETTERS[1:3], |
|||
| 4302 | -! | +|||
| 231 | +
- stop("Got invalid table_inset value, must be an integer > 0")
+ #' rrow("one to three", 1, 2, 3),
|
|||
| 4303 | +232 |
- }+ #' rrow("more stuff", rcell(pi, format = "xx.xx"), "test", "and more")
|
||
| 4304 | +233 |
-
+ #' ) |
||
| 4305 | -! | +|||
| 234 | +
- obj@table_inset <- value+ #' |
|||
| 4306 | -! | +|||
| 235 | +
- obj+ #' # Table with multirow header |
|||
| 4307 | +236 |
- }+ #' |
||
| 4308 | +237 |
- )+ #' sel <- iris$Species == "setosa" |
||
| 4309 | +238 |
-
+ #' mtbl <- rtable( |
||
| 4310 | +239 |
- #' @rdname formatters_methods+ #' header = rheader( |
||
| 4311 | +240 |
- #' @export+ #' rrow( |
||
| 4312 | +241 |
- setMethod(+ #' row.name = NULL, rcell("Sepal.Length", colspan = 2),
|
||
| 4313 | +242 |
- "table_inset<-", "InstantiatedColumnInfo",+ #' rcell("Petal.Length", colspan = 2)
|
||
| 4314 | +243 |
- function(obj, value) {
+ #' ), |
||
| 4315 | -! | +|||
| 244 | +
- if (!is.integer(value)) {
+ #' rrow(NULL, "mean", "median", "mean", "median") |
|||
| 4316 | -! | +|||
| 245 | +
- value <- as.integer(value)+ #' ), |
|||
| 4317 | +246 |
- }+ #' rrow( |
||
| 4318 | -! | +|||
| 247 | +
- if (is.na(value) || value < 0) {
+ #' row.name = "All Species", |
|||
| 4319 | -! | +|||
| 248 | +
- stop("Got invalid table_inset value, must be an integer > 0")
+ #' mean(iris$Sepal.Length), median(iris$Sepal.Length), |
|||
| 4320 | +249 |
- }+ #' mean(iris$Petal.Length), median(iris$Petal.Length), |
||
| 4321 | -! | +|||
| 250 | +
- obj@table_inset <- value+ #' format = "xx.xx" |
|||
| 4322 | -! | +|||
| 251 | +
- obj+ #' ), |
|||
| 4323 | +252 |
- }+ #' rrow( |
||
| 4324 | +253 |
- )+ #' row.name = "Setosa", |
| 1 | +254 |
- #' Create an `rtable` row+ #' mean(iris$Sepal.Length[sel]), median(iris$Sepal.Length[sel]), |
||
| 2 | +255 |
- #'+ #' mean(iris$Petal.Length[sel]), median(iris$Petal.Length[sel]) |
||
| 3 | +256 |
- #' @inheritParams compat_args+ #' ) |
||
| 4 | +257 |
- #' @param ... cell values.+ #' ) |
||
| 5 | +258 |
#' |
||
| 6 | +259 |
- #' @return A row object of the context-appropriate type (label or data).+ #' mtbl |
||
| 7 | +260 |
#' |
||
| 8 | +261 |
- #' @examples+ #' names(mtbl) # always first row of header |
||
| 9 | +262 |
- #' rrow("ABC", c(1, 2), c(3, 2), format = "xx (xx.%)")
+ #' |
||
| 10 | +263 |
- #' rrow("")
+ #' # Single row header |
||
| 11 | +264 |
#' |
||
| 12 | +265 |
- #' @family compatibility+ #' tbl <- rtable( |
||
| 13 | +266 |
- #' @export+ #' header = c("Treatement\nN=100", "Comparison\nN=300"),
|
||
| 14 | +267 |
- 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")
+ #' format = "xx (xx.xx%)", |
||
| 20 | +268 |
- }- |
- ||
| 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+ #' rrow("A", c(104, .2), c(100, .4)),
|
||
| 28 | +269 |
- )+ #' rrow("B", c(23, .4), c(43, .5)),
|
||
| 29 | +270 |
- } else {
- |
- ||
| 30 | -236x | -
- csps <- as.integer(sapply(vals, function(x) {
- |
- ||
| 31 | -1391x | -
- attr(x, "colspan", exact = TRUE) %||% 1L+ #' rrow(""),
|
||
| 32 | +271 |
- }))+ #' rrow("this is a very long section header"),
|
||
| 33 | +272 |
- ## we have to leave the formats on the cells and NOT the row unless we were+ #' rrow("estimate", rcell(55.23, "xx.xx", colspan = 2)),
|
||
| 34 | +273 |
- ## already told to do so, because row formats get clobbered when cbinding+ #' rrow("95% CI", indent = 1, rcell(c(44.8, 67.4), format = "(xx.x, xx.x)", colspan = 2))
|
||
| 35 | +274 |
- ## but cell formats do not.+ #' ) |
||
| 36 | +275 |
- ## formats = sapply(vals, obj_format)+ #' tbl |
||
| 37 | +276 |
- ## if(is.character(formats) && length(unique(formats)) == 1L && is.null(format))+ #' |
||
| 38 | +277 |
- ## format = unique(formats)- |
- ||
| 39 | -236x | -
- DataRow(- |
- ||
| 40 | -236x | -
- vals = vals, lev = as.integer(indent), label = row.name,+ #' row.names(tbl) |
||
| 41 | -236x | +|||
| 278 | +
- name = row.name, ## XXX TODO+ #' names(tbl) |
|||
| 42 | -236x | +|||
| 279 | +
- cspan = csps,+ #' |
|||
| 43 | -236x | +|||
| 280 | +
- format = format,+ #' # Subsetting |
|||
| 44 | -236x | +|||
| 281 | +
- table_inset = as.integer(inset)+ #' |
|||
| 45 | +282 |
- )+ #' tbl[1, ] |
||
| 46 | +283 |
- }+ #' tbl[, 1] |
||
| 47 | +284 |
- }+ #' |
||
| 48 | +285 |
-
+ #' tbl[1, 2] |
||
| 49 | +286 |
- #' Create an `rtable` row from a vector or list of values+ #' tbl[2, 1] |
||
| 50 | +287 |
#' |
||
| 51 | +288 |
- #' @inheritParams compat_args+ #' tbl[3, 2] |
||
| 52 | +289 |
- #' @param ... values in vector/list form.+ #' tbl[5, 1] |
||
| 53 | +290 |
- #'+ #' tbl[5, 2] |
||
| 54 | +291 |
- #' @inherit rrow return+ #' |
||
| 55 | +292 |
- #'+ #' # Data Structure methods |
||
| 56 | +293 |
- #' @examples+ #' |
||
| 57 | +294 |
- #' rrowl("a", c(1, 2, 3), format = "xx")
+ #' dim(tbl) |
||
| 58 | +295 |
- #' rrowl("a", c(1, 2, 3), c(4, 5, 6), format = "xx")
+ #' nrow(tbl) |
||
| 59 | +296 |
- #'+ #' ncol(tbl) |
||
| 60 | +297 |
- #'+ #' names(tbl) |
||
| 61 | +298 |
- #' rrowl("N", table(iris$Species))
+ #' |
||
| 62 | +299 |
- #' rrowl("N", table(iris$Species), format = "xx")
+ #' # Colspans |
||
| 63 | +300 |
#' |
||
| 64 | +301 |
- #' x <- tapply(iris$Sepal.Length, iris$Species, mean, simplify = FALSE)+ #' tbl2 <- rtable( |
||
| 65 | +302 |
- #'+ #' c("A", "B", "C", "D", "E"),
|
||
| 66 | +303 |
- #' rrow(row.name = "row 1", x)+ #' format = "xx", |
||
| 67 | +304 |
- #' rrow("ABC", 2, 3)
+ #' rrow("r1", 1, 2, 3, 4, 5),
|
||
| 68 | +305 |
- #'+ #' rrow("r2", rcell("sp2", colspan = 2), "sp1", rcell("sp2-2", colspan = 2))
|
||
| 69 | +306 |
- #' rrowl(row.name = "row 1", c(1, 2), c(3, 4))+ #' ) |
||
| 70 | +307 |
- #' rrow(row.name = "row 2", c(1, 2), c(3, 4))+ #' tbl2 |
||
| 71 | +308 |
#' |
||
| 72 | +309 |
#' @family compatibility |
||
| 73 | +310 |
#' @export |
||
| 74 | +311 |
- rrowl <- function(row.name, ..., format = NULL, indent = 0, inset = 0L) {
+ rtable <- function(header, ..., format = NULL, hsep = default_hsep(), |
||
| 75 | -38x | +|||
| 312 | +
- dots <- list(...)+ inset = 0L) {
|
|||
| 76 | -38x | +313 | +34x |
- args_list <- c(list(+ if (is.character(header)) {
|
| 77 | -38x | +314 | +31x |
- row.name = row.name, format = format,+ header <- .char_to_hrows(header) |
| 78 | -38x | +|||
| 315 | +
- indent = indent, inset = inset+ } # list(rrowl(NULL, header)) |
|||
| 79 | -38x | +316 | +34x |
- ), val = unlist(lapply(dots, as.list), recursive = FALSE))+ if (is.list(header)) {
|
| 80 | -38x | +317 | +31x |
- do.call(rrow, args_list)+ if (are(header, "TableRow")) {
|
| 81 | -+ | |||
| 318 | +31x |
- }+ colinfo <- hrows_to_colinfo(header) |
||
| 82 | -+ | |||
| 319 | +! |
-
+ } else if (are(header, "list")) {
|
||
| 83 | -+ | |||
| 320 | +! |
- ## rcell moved to tt_afun_utils.R+ colinfo <- do.call(rheader, header) |
||
| 84 | +321 |
-
+ } |
||
| 85 | -+ | |||
| 322 | +3x |
- ## inefficient trash+ } else if (is(header, "InstantiatedColumnInfo")) {
|
||
| 86 | -+ | |||
| 323 | +3x |
- paste_em_n <- function(lst, n, sep = ".") {
+ colinfo <- header |
||
| 87 | -9x | +|||
| 324 | +! |
- ret <- lst[[1]]+ } else if (is(header, "TableRow")) {
|
||
| 88 | -9x | +|||
| 325 | +! |
- if (n > 1) {
+ colinfo <- hrows_to_colinfo(list(header)) |
||
| 89 | -4x | +|||
| 326 | +
- for (i in 2:n) {
+ } else {
|
|||
| 90 | -4x | +|||
| 327 | +! |
- ret <- paste(ret, lst[[i]], sep = sep)+ stop("problems")
|
||
| 91 | +328 |
- }+ } |
||
| 92 | +329 |
- }+ |
||
| 93 | -9x | +330 | +34x |
- ret+ body <- list(...) |
| 94 | +331 |
- }+ ## XXX this shouldn't be needed. hacky |
||
| 95 | -+ | |||
| 332 | +34x |
-
+ if (length(body) == 1 && is.list(body[[1]])) {
+ |
+ ||
| 333 | +! | +
+ body <- body[[1]] |
||
| 96 | +334 |
- hrows_to_colinfo <- function(rows) {
+ } |
||
| 97 | +335 | 34x |
- nr <- length(rows)+ if (are(body, "ElementaryTable") && |
|
| 98 | +336 | 34x |
- stopifnot(nr > 0)+ all(sapply(body, function(tb) {
|
|
| 99 | -34x | +|||
| 337 | +! |
- cspans <- lapply(rows, row_cspans)+ nrow(tb) == 1 && obj_name(tb) == "" |
||
| 100 | -34x | +|||
| 338 | +
- vals <- lapply(rows, function(x) unlist(row_values(x)))+ }))) {
|
|||
| 101 | -34x | +339 | +1x |
- unqvals <- lapply(vals, unique)+ body <- lapply(body, function(tb) tree_children(tb)[[1]]) |
| 102 | -34x | +|||
| 340 | +
- formats <- lapply(rows, obj_format)+ }+ |
+ |||
| 341 | ++ | + | ||
| 103 | +342 | 34x |
- counts <- NULL+ TableTree( |
|
| 104 | +343 | 34x |
- if (formats[nr] == "(N=xx)" || all(sapply(row_cells(rows[[nr]]), obj_format) == "(N=xx)")) { ## count row
+ kids = body, format = format, cinfo = colinfo, |
|
| 105 | -1x | +344 | +34x |
- counts <- vals[[nr]]+ labelrow = LabelRow(lev = 0L, label = "", vis = FALSE), |
| 106 | -1x | +345 | +34x |
- vals <- vals[-nr]+ hsep = hsep, inset = inset |
| 107 | -1x | +|||
| 346 | +
- cspans <- cspans[-nr]+ ) |
|||
| 108 | -1x | +|||
| 347 | +
- nr <- nr - 1+ } |
|||
| 109 | +348 |
- }+ |
||
| 110 | +349 |
- ## easiest case, one header row no counts. we're done+ #' @rdname rtable |
||
| 111 | +350 |
- ## XXX could one row but cspan ever make sense????+ #' @export |
||
| 112 | +351 |
- ## I don't think so?+ rtablel <- function(header, ..., format = NULL, hsep = default_hsep(), inset = 0L) {
|
||
| 113 | -34x | +352 | +1x |
- if (nr == 1) { ## && all(cspans == 1L)) {
+ dots <- list(...) |
| 114 | -29x | +353 | +1x |
- ret <- manual_cols(unlist(vals[[1]]))+ args_list <- c(list(header = header, format = format, hsep = hsep, inset = inset), unlist(lapply( |
| 115 | -29x | +354 | +1x |
- if (!is.null(counts)) {
+ dots, |
| 116 | +355 | 1x |
- col_counts(ret) <- counts+ as.list |
|
| 117 | +356 | 1x |
- disp_ccounts(ret) <- TRUE+ ), recursive = FALSE))+ |
+ |
| 357 | +1x | +
+ do.call(rtable, args_list) |
||
| 118 | +358 |
- }+ } |
||
| 119 | -29x | +|||
| 359 | +
- return(ret)+ |
|||
| 120 | +360 |
- }+ # All object annotations are identical (and exist) |
||
| 121 | +361 |
- ## second easiest case full repeated nestin+ all_annots_identical <- function(all_annots) {
|
||
| 122 | -5x | +362 | +60x |
- repvals <- mapply(function(v, csp) rep(v, times = csp),+ if (!is.list(all_annots)) {
|
| 123 | -5x | +363 | +15x |
- v = vals, csp = cspans, SIMPLIFY = FALSE+ all_annots[1] != "" && length(unique(all_annots)) == 1 |
| 124 | +364 |
- )+ } else {
+ |
+ ||
| 365 | +45x | +
+ length(all_annots[[1]]) > 0 && Reduce(identical, all_annots) |
||
| 125 | +366 |
-
+ } |
||
| 126 | +367 |
- ## nr > 1 here+ } |
||
| 127 | -5x | +|||
| 368 | +
- fullnest <- TRUE+ |
|||
| 128 | -5x | +|||
| 369 | +
- for (i in 2:nr) {
+ # Only first object has annotations |
|||
| 129 | -5x | +|||
| 370 | +
- psted <- paste_em_n(repvals, i - 1)+ only_first_annot <- function(all_annots) {
|
|||
| 130 | -5x | +371 | +56x |
- spl <- split(repvals[[i]], psted)+ if (!is.list(all_annots)) {
|
| 131 | -5x | +372 | +14x |
- if (!all(sapply(spl, function(x) identical(x, spl[[1]])))) {
+ all_annots[1] != "" && all(all_annots[-1] == "") |
| 132 | -4x | +|||
| 373 | +
- fullnest <- FALSE+ } else {
|
|||
| 133 | -4x | +374 | +42x |
- break+ length(all_annots[[1]]) > 0 && all(sapply(all_annots, length)[-1] == 0) |
| 134 | +375 |
- }+ } |
||
| 135 | +376 |
- }+ } |
||
| 136 | +377 | |||
| 137 | +378 |
- ## if its full nesting we're done, so put+ #' @param gap `r lifecycle::badge("deprecated")` ignored.
|
||
| 138 | +379 |
- ## the counts on as necessary and return.+ #' @param check_headers `r lifecycle::badge("deprecated")` ignored.
|
||
| 139 | -5x | +|||
| 380 | +
- if (fullnest) {
+ #' |
|||
| 140 | -1x | +|||
| 381 | +
- ret <- manual_cols(.lst = unqvals)+ #' @return A formal table object. |
|||
| 141 | -1x | +|||
| 382 | +
- if (!is.null(counts)) {
+ #' |
|||
| 142 | -! | +|||
| 383 | +
- col_counts(ret) <- counts+ #' @rdname rbind |
|||
| 143 | -! | +|||
| 384 | +
- disp_ccounts(ret) <- TRUE+ #' @aliases rbind |
|||
| 144 | +385 |
- }+ #' @export |
||
| 145 | -1x | +|||
| 386 | +
- return(ret)+ rbindl_rtables <- function(x, gap = lifecycle::deprecated(), check_headers = lifecycle::deprecated()) {
|
|||
| 146 | +387 |
- }+ ## nocov start |
||
| 147 | +388 |
-
+ if (lifecycle::is_present(gap)) {
|
||
| 148 | +389 |
- ## booo. the fully complex case where the multiple rows+ lifecycle::deprecate_warn( |
||
| 149 | +390 |
- ## really don't represent nesting at all, each top level+ when = "0.3.2", |
||
| 150 | +391 |
- ## can have different sub labels+ what = "rbindl_rtables(gap)" |
||
| 151 | +392 |
-
+ ) |
||
| 152 | +393 |
- ## we will build it up as if it were full nesting and then prune+ } |
||
| 153 | +394 |
- ## based on the columns we actually want.+ if (lifecycle::is_present(check_headers)) {
|
||
| 154 | +395 |
-
+ lifecycle::deprecate_warn( |
||
| 155 | -4x | +|||
| 396 | +
- fullcolinfo <- manual_cols(.lst = unqvals)+ when = "0.3.2", |
|||
| 156 | -4x | +|||
| 397 | +
- fullbusiness <- names(collect_leaves(coltree(fullcolinfo)))+ what = "rbindl_rtables(check_headers)" |
|||
| 157 | -4x | +|||
| 398 | +
- wanted <- paste_em_n(repvals, nr)+ ) |
|||
| 158 | -4x | +|||
| 399 | +
- wantcols <- match(wanted, fullbusiness)+ } |
|||
| 159 | -4x | +|||
| 400 | +
- stopifnot(all(!is.na(wantcols)))+ ## nocov end |
|||
| 160 | +401 | |||
| 161 | -4x | +402 | +16x |
- subset_cols(fullcolinfo, wantcols)+ firstcols <- col_info(x[[1]]) |
| 162 | -+ | |||
| 403 | +16x |
- }+ i <- 1 |
||
| 163 | -+ | |||
| 404 | +16x |
-
+ while (no_colinfo(firstcols) && i <= length(x)) {
|
||
| 164 | -+ | |||
| 405 | +2x |
- #' Create a header+ firstcols <- col_info(x[[i]]) |
||
| 165 | -+ | |||
| 406 | +2x |
- #'+ i <- i + 1 |
||
| 166 | +407 |
- #' @inheritParams compat_args+ } |
||
| 167 | +408 |
- #' @param ... row specifications, either as character vectors or the output from [rrow()], [DataRow()],+ |
||
| 168 | -+ | |||
| 409 | +16x |
- #' [LabelRow()], etc.+ lapply(x, function(xi) chk_compat_cinfos(x[[1]], xi)) ## col_info(xi))) |
||
| 169 | +410 |
- #'+ |
||
| 170 | -+ | |||
| 411 | +15x |
- #' @return A `InstantiatedColumnInfo` object.+ rbind_annot <- list( |
||
| 171 | -+ | |||
| 412 | +15x |
- #'+ main_title = "", |
||
| 172 | -+ | |||
| 413 | +15x |
- #' @examples+ subtitles = character(), |
||
| 173 | -+ | |||
| 414 | +15x |
- #' h1 <- rheader(c("A", "B", "C"))
+ main_footer = character(), |
||
| 174 | -+ | |||
| 415 | +15x |
- #' h1+ prov_footer = character() |
||
| 175 | +416 |
- #'+ ) |
||
| 176 | +417 |
- #' h2 <- rheader(+ |
||
| 177 | +418 |
- #' rrow(NULL, rcell("group 1", colspan = 2), rcell("group 2", colspan = 2)),
+ # Titles/footer info are (independently) retained from first object if |
||
| 178 | +419 |
- #' rrow(NULL, "A", "B", "A", "B")+ # identical or missing in all other objects |
||
| 179 | -+ | |||
| 420 | +15x |
- #' )+ all_titles <- sapply(x, main_title) |
||
| 180 | -+ | |||
| 421 | +15x |
- #' h2+ if (all_annots_identical(all_titles) || only_first_annot(all_titles)) {
|
||
| 181 | -+ | |||
| 422 | +2x |
- #'+ rbind_annot[["main_title"]] <- all_titles[[1]] |
||
| 182 | +423 |
- #' @family compatibility+ } |
||
| 183 | +424 |
- #' @export+ |
||
| 184 | -+ | |||
| 425 | +15x |
- rheader <- function(..., format = "xx", .lst = NULL) {
+ all_sts <- lapply(x, subtitles) |
||
| 185 | -3x | +426 | +15x |
- if (!is.null(.lst)) {
+ if (all_annots_identical(all_sts) || only_first_annot(all_sts)) {
|
| 186 | -! | +|||
| 427 | +2x |
- args <- .lst+ rbind_annot[["subtitles"]] <- all_sts[[1]] |
||
| 187 | +428 |
- } else {
+ }+ |
+ ||
| 429 | ++ | + | ||
| 188 | -3x | +430 | +15x |
- args <- list(...)+ all_ftrs <- lapply(x, main_footer)+ |
+
| 431 | +15x | +
+ if (all_annots_identical(all_ftrs) || only_first_annot(all_ftrs)) {
+ |
+ ||
| 432 | +2x | +
+ rbind_annot[["main_footer"]] <- all_ftrs[[1]] |
||
| 189 | +433 |
} |
||
| 190 | -3x | +|||
| 434 | +
- rrows <- if (length(args) == 1 && !is(args[[1]], "TableRow")) {
+
|
|||
| 191 | -! | +|||
| 435 | +15x |
- list(rrowl(row.name = NULL, val = args[[1]], format = format))+ all_pfs <- lapply(x, prov_footer) |
||
| 192 | -3x | +436 | +15x |
- } else if (are(args, "TableRow")) {
+ if (all_annots_identical(all_pfs) || only_first_annot(all_pfs)) {
|
| 193 | -3x | +437 | +2x |
- args+ rbind_annot[["prov_footer"]] <- all_pfs[[1]] |
| 194 | +438 |
} |
||
| 195 | +439 | |||
| 196 | -3x | +|||
| 440 | +
- hrows_to_colinfo(rrows)+ ## if we got only ElementaryTable and |
|||
| 197 | +441 |
- }+ ## TableRow objects, construct a new |
||
| 198 | +442 |
-
+ ## elementary table with all the rows |
||
| 199 | +443 |
- .char_to_hrows <- function(hdr) {
+ ## instead of adding nesting. |
||
| 200 | -31x | +|||
| 444 | +
- nlfnd <- grep("\n", hdr, fixed = TRUE)
+
|
|||
| 201 | -31x | +|||
| 445 | +
- if (length(nlfnd) == 0) {
+ ## we used to check for xi not being a lable row, why?? XXX |
|||
| 202 | -27x | +446 | +15x |
- return(list(rrowl(NULL, hdr)))+ if (all(sapply(x, function(xi) {
|
| 203 | -+ | |||
| 447 | +30x |
- }+ (is(xi, "ElementaryTable") && !labelrow_visible(xi)) || |
||
| 204 | -+ | |||
| 448 | +30x |
-
+ is(xi, "TableRow") |
||
| 205 | -4x | +449 | +15x |
- stopifnot(length(nlfnd) == length(hdr))+ }))) { ## && !is(xi, "LabelRow")}))) {
|
| 206 | -4x | +450 | +8x |
- raw <- strsplit(hdr, "\n", fixed = TRUE)+ x <- unlist(lapply(x, function(xi) {
|
| 207 | -4x | +451 | +16x |
- lens <- unique(sapply(raw, length))+ if (is(xi, "TableRow")) {
|
| 208 | +452 | 4x |
- stopifnot(length(lens) == 1L)+ xi |
|
| 209 | -4x | +|||
| 453 | +
- lapply(+ } else {
|
|||
| 210 | -4x | +454 | +12x |
- seq(1, lens),+ lst <- tree_children(xi) |
| 211 | -4x | +455 | +12x |
- function(i) {
+ lapply(lst, indent, |
| 212 | -8x | +456 | +12x |
- rrowl(NULL, vapply(raw, `[`, NA_character_, i = i))+ by = indent_mod(xi) |
| 213 | +457 |
- }+ ) |
||
| 214 | +458 |
- )+ } |
||
| 215 | +459 |
- }+ })) |
||
| 216 | +460 |
-
+ } |
||
| 217 | +461 |
- #' Create a table+ |
||
| 218 | -+ | |||
| 462 | +15x |
- #'+ TableTree( |
||
| 219 | -+ | |||
| 463 | +15x |
- #' @inheritParams compat_args+ kids = x, |
||
| 220 | -+ | |||
| 464 | +15x |
- #' @inheritParams gen_args+ cinfo = firstcols, |
||
| 221 | -+ | |||
| 465 | +15x |
- #' @param header (`TableRow`, `character`, or `InstantiatedColumnInfo`)\cr information defining the header+ name = "rbind_root", |
||
| 222 | -+ | |||
| 466 | +15x |
- #' (column structure) of the table. This can be as row objects (legacy), character vectors, or an+ label = "", |
||
| 223 | -+ | |||
| 467 | +15x |
- #' `InstantiatedColumnInfo` object.+ title = rbind_annot[["main_title"]], |
||
| 224 | -+ | |||
| 468 | +15x |
- #' @param ... rows to place in the table.+ subtitles = rbind_annot[["subtitles"]], |
||
| 225 | -+ | |||
| 469 | +15x |
- #'+ main_footer = rbind_annot[["main_footer"]],+ |
+ ||
| 470 | +15x | +
+ prov_footer = rbind_annot[["prov_footer"]] |
||
| 226 | +471 |
- #' @return A formal table object of the appropriate type (`ElementaryTable` or `TableTree`).+ ) |
||
| 227 | +472 |
- #'+ } |
||
| 228 | +473 |
- #' @examples+ |
||
| 229 | +474 |
- #' rtable(+ #' Row-bind `TableTree` and related objects |
||
| 230 | +475 |
- #' header = LETTERS[1:3],+ #' |
||
| 231 | +476 |
- #' rrow("one to three", 1, 2, 3),
+ #' @param deparse.level (`numeric(1)`)\cr currently ignored. |
||
| 232 | +477 |
- #' rrow("more stuff", rcell(pi, format = "xx.xx"), "test", "and more")
+ #' @param ... (`ANY`)\cr elements to be stacked. |
||
| 233 | +478 |
- #' )+ #' |
||
| 234 | +479 |
- #'+ #' @note |
||
| 235 | +480 |
- #' # Table with multirow header+ #' When objects are row-bound, titles and footer information is retained from the first object (if any exists) if all |
||
| 236 | +481 |
- #'+ #' other objects have no titles/footers or have identical titles/footers. Otherwise, all titles/footers are removed |
||
| 237 | +482 |
- #' sel <- iris$Species == "setosa"+ #' and must be set for the bound table via the [formatters::main_title()], [formatters::subtitles()], |
||
| 238 | +483 |
- #' mtbl <- rtable(+ #' [formatters::main_footer()], and [formatters::prov_footer()] functions. |
||
| 239 | +484 |
- #' header = rheader(+ #' |
||
| 240 | +485 |
- #' rrow(+ #' @examples |
||
| 241 | +486 |
- #' row.name = NULL, rcell("Sepal.Length", colspan = 2),
+ #' mtbl <- rtable( |
||
| 242 | +487 |
- #' rcell("Petal.Length", colspan = 2)
+ #' header = rheader( |
||
| 243 | +488 |
- #' ),+ #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
|
||
| 244 | +489 |
#' rrow(NULL, "mean", "median", "mean", "median") |
||
| 245 | +490 |
#' ), |
||
| 246 | +491 |
#' rrow( |
||
| 247 | +492 |
#' row.name = "All Species", |
||
| 248 | +493 |
#' mean(iris$Sepal.Length), median(iris$Sepal.Length), |
||
| 249 | +494 |
#' mean(iris$Petal.Length), median(iris$Petal.Length), |
||
| 250 | +495 |
#' format = "xx.xx" |
||
| 251 | +496 |
- #' ),+ #' ) |
||
| 252 | +497 |
- #' rrow(+ #' ) |
||
| 253 | +498 |
- #' row.name = "Setosa",+ #' |
||
| 254 | +499 |
- #' mean(iris$Sepal.Length[sel]), median(iris$Sepal.Length[sel]),+ #' mtbl2 <- with(subset(iris, Species == "setosa"), rtable( |
||
| 255 | +500 |
- #' mean(iris$Petal.Length[sel]), median(iris$Petal.Length[sel])+ #' header = rheader( |
||
| 256 | +501 |
- #' )+ #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
|
||
| 257 | +502 |
- #' )+ #' rrow(NULL, "mean", "median", "mean", "median") |
||
| 258 | +503 |
- #'+ #' ), |
||
| 259 | +504 |
- #' mtbl+ #' rrow( |
||
| 260 | +505 |
- #'+ #' row.name = "Setosa", |
||
| 261 | +506 |
- #' names(mtbl) # always first row of header+ #' mean(Sepal.Length), median(Sepal.Length), |
||
| 262 | +507 |
- #'+ #' mean(Petal.Length), median(Petal.Length), |
||
| 263 | +508 |
- #' # Single row header+ #' format = "xx.xx" |
||
| 264 | +509 |
- #'+ #' ) |
||
| 265 | +510 |
- #' tbl <- rtable(+ #' )) |
||
| 266 | +511 |
- #' header = c("Treatement\nN=100", "Comparison\nN=300"),
+ #' |
||
| 267 | +512 |
- #' format = "xx (xx.xx%)",+ #' rbind(mtbl, mtbl2) |
||
| 268 | +513 |
- #' rrow("A", c(104, .2), c(100, .4)),
+ #' rbind(mtbl, rrow(), mtbl2) |
||
| 269 | +514 |
- #' rrow("B", c(23, .4), c(43, .5)),
+ #' rbind(mtbl, rrow("aaa"), indent(mtbl2))
|
||
| 270 | +515 |
- #' rrow(""),
+ #' |
||
| 271 | +516 |
- #' rrow("this is a very long section header"),
+ #' @exportMethod rbind |
||
| 272 | +517 |
- #' rrow("estimate", rcell(55.23, "xx.xx", colspan = 2)),
+ #' @rdname rbind |
||
| 273 | +518 |
- #' rrow("95% CI", indent = 1, rcell(c(44.8, 67.4), format = "(xx.x, xx.x)", colspan = 2))
+ setMethod( |
||
| 274 | +519 |
- #' )+ "rbind", "VTableNodeInfo", |
||
| 275 | +520 |
- #' tbl+ function(..., deparse.level = 1) {
|
||
| 276 | -+ | |||
| 521 | +! |
- #'+ rbindl_rtables(list(...)) |
||
| 277 | +522 |
- #' row.names(tbl)+ } |
||
| 278 | +523 |
- #' names(tbl)+ ) |
||
| 279 | +524 |
- #'+ |
||
| 280 | +525 |
- #' # Subsetting+ #' @param y (`ANY`)\cr second element to be row-bound via `rbind2`. |
||
| 281 | +526 |
#' |
||
| 282 | +527 |
- #' tbl[1, ]+ #' @exportMethod rbind2 |
||
| 283 | +528 |
- #' tbl[, 1]+ #' @rdname int_methods |
||
| 284 | +529 |
- #'+ setMethod( |
||
| 285 | +530 |
- #' tbl[1, 2]+ "rbind2", c("VTableNodeInfo", "missing"),
|
||
| 286 | +531 |
- #' tbl[2, 1]+ function(x, y) {
|
||
| 287 | -+ | |||
| 532 | +2x |
- #'+ TableTree(kids = list(x), cinfo = col_info(x), name = "rbind_root", label = "") |
||
| 288 | +533 |
- #' tbl[3, 2]+ } |
||
| 289 | +534 |
- #' tbl[5, 1]+ ) |
||
| 290 | +535 |
- #' tbl[5, 2]+ |
||
| 291 | +536 |
- #'+ #' @param x (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object. |
||
| 292 | +537 |
- #' # Data Structure methods+ #' @param y (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object. |
||
| 293 | +538 |
#' |
||
| 294 | +539 |
- #' dim(tbl)+ #' @exportMethod rbind2 |
||
| 295 | +540 |
- #' nrow(tbl)+ #' @rdname rbind |
||
| 296 | +541 |
- #' ncol(tbl)+ setMethod( |
||
| 297 | +542 |
- #' names(tbl)+ "rbind2", "VTableNodeInfo", |
||
| 298 | +543 |
- #'+ function(x, y) {
|
||
| 299 | -+ | |||
| 544 | +12x |
- #' # Colspans+ rbindl_rtables(list(x, y)) |
||
| 300 | +545 |
- #'+ } |
||
| 301 | +546 |
- #' tbl2 <- rtable(+ ) |
||
| 302 | +547 |
- #' c("A", "B", "C", "D", "E"),
+
|
||
| 303 | +548 |
- #' format = "xx",+ EmptyTreePos <- TreePos() |
||
| 304 | +549 |
- #' rrow("r1", 1, 2, 3, 4, 5),
+
|
||
| 305 | +550 |
- #' rrow("r2", rcell("sp2", colspan = 2), "sp1", rcell("sp2-2", colspan = 2))
+ ## this is painful to do right but we were doing it wrong |
||
| 306 | +551 |
- #' )+ ## before and it now matters because count display information |
||
| 307 | +552 |
- #' tbl2+ ## is in the tree which means all points in the structure |
||
| 308 | +553 |
- #'+ ## must be pathable, which they aren't if siblings have |
||
| 309 | +554 |
- #' @family compatibility+ ## identical names |
||
| 310 | +555 |
- #' @export+ fix_col_nm_recursive <- function(ct, newname, rename_obj = TRUE, oldnm) {
|
||
| 311 | -+ | |||
| 556 | +120x |
- rtable <- function(header, ..., format = NULL, hsep = default_hsep(),+ if (rename_obj) {
|
||
| 312 | -+ | |||
| 557 | +19x |
- inset = 0L) {
+ obj_name(ct) <- newname |
||
| 313 | -34x | +|||
| 558 | +
- if (is.character(header)) {
+ } |
|||
| 314 | -31x | +559 | +120x |
- header <- .char_to_hrows(header)+ if (is(ct, "LayoutColTree")) {
|
| 315 | -+ | |||
| 560 | +45x |
- } # list(rrowl(NULL, header))+ kids <- tree_children(ct) |
||
| 316 | -34x | +561 | +45x |
- if (is.list(header)) {
+ kidnms <- names(kids) |
| 317 | -31x | +562 | +45x |
- if (are(header, "TableRow")) {
+ newkids <- lapply(kids, fix_col_nm_recursive, |
| 318 | -31x | +563 | +45x |
- colinfo <- hrows_to_colinfo(header)+ newname = newname, |
| 319 | -! | +|||
| 564 | +45x |
- } else if (are(header, "list")) {
+ rename_obj = FALSE, |
||
| 320 | -! | +|||
| 565 | +45x |
- colinfo <- do.call(rheader, header)+ oldnm = oldnm |
||
| 321 | +566 |
- }+ ) |
||
| 322 | -3x | +567 | +45x |
- } else if (is(header, "InstantiatedColumnInfo")) {
+ names(newkids) <- kidnms |
| 323 | -3x | +568 | +45x |
- colinfo <- header+ tree_children(ct) <- newkids |
| 324 | -! | +|||
| 569 | +
- } else if (is(header, "TableRow")) {
+ } |
|||
| 325 | -! | +|||
| 570 | +120x |
- colinfo <- hrows_to_colinfo(list(header))+ mypos <- tree_pos(ct) |
||
| 326 | -+ | |||
| 571 | +120x |
- } else {
+ if (!identical(mypos, EmptyTreePos)) {
|
||
| 327 | -! | +|||
| 572 | +97x |
- stop("problems")
+ spls <- pos_splits(mypos) |
||
| 328 | -+ | |||
| 573 | +97x |
- }+ firstspl <- spls[[1]] |
||
| 329 | -+ | |||
| 574 | +97x |
-
+ if (obj_name(firstspl) == oldnm) {
|
||
| 330 | -34x | +|||
| 575 | +! |
- body <- list(...)+ obj_name(firstspl) <- newname |
||
| 331 | -+ | |||
| 576 | +! |
- ## XXX this shouldn't be needed. hacky+ spls[[1]] <- firstspl |
||
| 332 | -34x | +|||
| 577 | +! |
- if (length(body) == 1 && is.list(body[[1]])) {
+ pos_splits(mypos) <- spls |
||
| 333 | +578 | ! |
- body <- body[[1]]+ tree_pos(ct) <- mypos |
|
| 334 | +579 | ++ |
+ }+ |
+ |
| 580 |
} |
|||
| 335 | -34x | +581 | +120x |
- if (are(body, "ElementaryTable") &&+ if (!rename_obj) {
|
| 336 | -34x | +582 | +101x |
- all(sapply(body, function(tb) {
+ spls <- pos_splits(mypos) |
| 337 | -! | +|||
| 583 | +101x |
- nrow(tb) == 1 && obj_name(tb) == ""+ splvals <- pos_splvals(mypos) |
||
| 338 | -+ | |||
| 584 | +101x |
- }))) {
+ pos_splits(mypos) <- c( |
||
| 339 | -1x | +585 | +101x |
- body <- lapply(body, function(tb) tree_children(tb)[[1]])+ list(AllSplit(split_name = newname)), |
| 340 | -+ | |||
| 586 | +101x |
- }+ spls |
||
| 341 | +587 |
-
+ ) |
||
| 342 | -34x | +588 | +101x |
- TableTree(+ pos_splvals(mypos) <- c( |
| 343 | -34x | +589 | +101x |
- kids = body, format = format, cinfo = colinfo,+ list(SplitValue(NA_character_, |
| 344 | -34x | +590 | +101x |
- labelrow = LabelRow(lev = 0L, label = "", vis = FALSE),+ sub_expr = quote(TRUE)+ |
+
| 591 | ++ |
+ )), |
||
| 345 | -34x | +592 | +101x |
- hsep = hsep, inset = inset+ splvals |
| 346 | +593 |
- )+ ) |
||
| 347 | -+ | |||
| 594 | +101x |
- }+ tree_pos(ct) <- mypos |
||
| 348 | +595 |
-
+ }+ |
+ ||
| 596 | +120x | +
+ ct |
||
| 349 | +597 |
- #' @rdname rtable+ } |
||
| 350 | +598 |
- #' @export+ |
||
| 351 | +599 |
- rtablel <- function(header, ..., format = NULL, hsep = default_hsep(), inset = 0L) {
+ fix_nms <- function(ct) {
|
||
| 352 | -1x | +600 | +129x |
- dots <- list(...)+ if (is(ct, "LayoutColLeaf")) {
|
| 353 | -1x | +601 | +75x |
- args_list <- c(list(header = header, format = format, hsep = hsep, inset = inset), unlist(lapply(+ return(ct)+ |
+
| 602 | ++ |
+ } |
||
| 354 | -1x | +603 | +54x |
- dots,+ kids <- lapply(tree_children(ct), fix_nms) |
| 355 | -1x | +604 | +54x |
- as.list+ names(kids) <- vapply(kids, obj_name, "") |
| 356 | -1x | +605 | +54x |
- ), recursive = FALSE))+ tree_children(ct) <- kids |
| 357 | -1x | +606 | +54x |
- do.call(rtable, args_list)+ ct |
| 358 | +607 |
} |
||
| 359 | +608 | |||
| 360 | +609 |
- # All object annotations are identical (and exist)+ make_cbind_names <- function(num, tokens) {
|
||
| 361 | -+ | |||
| 610 | +9x |
- all_annots_identical <- function(all_annots) {
+ cbind_tokens <- grep("^(new_)*cbind_tbl", tokens, value = TRUE)
|
||
| 362 | -60x | +611 | +9x |
- if (!is.list(all_annots)) {
+ ret <- paste0("cbind_tbl_", seq_len(num))
|
| 363 | -15x | +612 | +9x |
- all_annots[1] != "" && length(unique(all_annots)) == 1+ if (length(cbind_tokens) == 0) {
+ |
+
| 613 | +9x | +
+ return(ret) |
||
| 364 | +614 |
- } else {
+ } |
||
| 365 | -45x | +|||
| 615 | +! |
- length(all_annots[[1]]) > 0 && Reduce(identical, all_annots)+ oldprefixes <- gsub("cbind_tbl.*", "", cbind_tokens)
|
||
| 366 | -+ | |||
| 616 | +! |
- }+ oldprefix <- oldprefixes[which.max(nchar(oldprefixes))] |
||
| 367 | -+ | |||
| 617 | +! |
- }+ paste0("new_", oldprefix, ret)
|
||
| 368 | +618 |
-
+ } |
||
| 369 | +619 |
- # Only first object has annotations+ |
||
| 370 | +620 |
- only_first_annot <- function(all_annots) {
+ combine_cinfo <- function(..., new_total = NULL, sync_count_vis) {
|
||
| 371 | -56x | +621 | +10x |
- if (!is.list(all_annots)) {
+ tabs <- list(...) |
| 372 | -14x | +622 | +10x |
- all_annots[1] != "" && all(all_annots[-1] == "")+ chk_cbindable_many(tabs) |
| 373 | -+ | |||
| 623 | +9x |
- } else {
+ cinfs <- lapply(tabs, col_info) |
||
| 374 | -42x | +624 | +9x |
- length(all_annots[[1]]) > 0 && all(sapply(all_annots, length)[-1] == 0)+ stopifnot(are(cinfs, "InstantiatedColumnInfo")) |
| 375 | +625 |
- }+ |
||
| 376 | -+ | |||
| 626 | +9x |
- }+ ctrees <- lapply(cinfs, coltree) |
||
| 377 | -+ | |||
| 627 | +9x |
-
+ oldnms <- nms <- vapply(ctrees, obj_name, "") |
||
| 378 | -+ | |||
| 628 | +9x |
- #' @param gap `r lifecycle::badge("deprecated")` ignored.
+ path_els <- unique(unlist(lapply(ctrees, col_paths), recursive = TRUE)) |
||
| 379 | -+ | |||
| 629 | +9x |
- #' @param check_headers `r lifecycle::badge("deprecated")` ignored.
+ nms <- make_cbind_names(num = length(oldnms), tokens = path_els) |
||
| 380 | +630 |
- #'+ |
||
| 381 | -+ | |||
| 631 | +9x |
- #' @return A formal table object.+ ctrees <- mapply(function(ct, nm, oldnm) {
|
||
| 382 | -+ | |||
| 632 | +19x |
- #'+ ct <- fix_col_nm_recursive(ct, nm, rename_obj = TRUE, oldnm = "") # oldnm) |
||
| 383 | -+ | |||
| 633 | +19x |
- #' @rdname rbind+ ct |
||
| 384 | -+ | |||
| 634 | +9x |
- #' @aliases rbind+ }, ct = ctrees, nm = nms, oldnm = oldnms, SIMPLIFY = FALSE) |
||
| 385 | -+ | |||
| 635 | +9x |
- #' @export+ names(ctrees) <- nms |
||
| 386 | +636 |
- rbindl_rtables <- function(x, gap = lifecycle::deprecated(), check_headers = lifecycle::deprecated()) {
+
|
||
| 387 | -+ | |||
| 637 | +9x |
- ## nocov start+ newctree <- LayoutColTree(kids = ctrees, colcount = NA_integer_, name = "cbind_root") |
||
| 388 | -+ | |||
| 638 | +9x |
- if (lifecycle::is_present(gap)) {
+ newctree <- fix_nms(newctree) |
||
| 389 | -+ | |||
| 639 | +9x |
- lifecycle::deprecate_warn(+ newcounts <- unlist(lapply(cinfs, col_counts)) |
||
| 390 | -+ | |||
| 640 | +9x |
- when = "0.3.2",+ if (is.null(new_total)) {
|
||
| 391 | -+ | |||
| 641 | +9x |
- what = "rbindl_rtables(gap)"+ new_total <- sum(newcounts) |
||
| 392 | +642 |
- )+ } |
||
| 393 | -+ | |||
| 643 | +9x |
- }+ newexprs <- unlist(lapply(cinfs, col_exprs), recursive = FALSE) |
||
| 394 | -+ | |||
| 644 | +9x |
- if (lifecycle::is_present(check_headers)) {
+ newexargs <- unlist(lapply(cinfs, col_extra_args), recursive = FALSE) %||% vector("list", length(newcounts))
|
||
| 395 | -+ | |||
| 645 | +9x |
- lifecycle::deprecate_warn(+ if (!sync_count_vis) {
|
||
| 396 | -+ | |||
| 646 | +1x |
- when = "0.3.2",+ newdisp <- NA |
||
| 397 | +647 |
- what = "rbindl_rtables(check_headers)"+ } else {
|
||
| 398 | -+ | |||
| 648 | +8x |
- )+ newdisp <- any(vapply(cinfs, disp_ccounts, NA)) |
||
| 399 | +649 |
} |
||
| 400 | -+ | |||
| 650 | +9x |
- ## nocov end+ alltls <- lapply(cinfs, top_left) |
||
| 401 | -+ | |||
| 651 | +9x |
-
+ newtl <- character() |
||
| 402 | -16x | +652 | +9x |
- firstcols <- col_info(x[[1]])+ if (!are(tabs, "TableRow")) {
|
| 403 | -16x | +653 | +9x |
- i <- 1+ alltls <- alltls[vapply(alltls, function(x) length(x) > 0, NA)] ## these are already enforced to all be the same |
| 404 | -16x | +654 | +9x |
- while (no_colinfo(firstcols) && i <= length(x)) {
+ if (length(alltls) > 0) {
|
| 405 | -2x | +|||
| 655 | +! |
- firstcols <- col_info(x[[i]])+ newtl <- alltls[[1]] |
||
| 406 | -2x | +|||
| 656 | +
- i <- i + 1+ } |
|||
| 407 | +657 |
} |
||
| 408 | -+ | |||
| 658 | +9x |
-
+ InstantiatedColumnInfo( |
||
| 409 | -16x | +659 | +9x |
- lapply(x, function(xi) chk_compat_cinfos(x[[1]], xi)) ## col_info(xi)))+ treelyt = newctree, |
| 410 | -+ | |||
| 660 | +9x |
-
+ csubs = newexprs, |
||
| 411 | -15x | +661 | +9x |
- rbind_annot <- list(+ extras = newexargs, |
| 412 | -15x | +662 | +9x |
- main_title = "",+ cnts = newcounts, |
| 413 | -15x | +663 | +9x |
- subtitles = character(),+ dispcounts = newdisp, |
| 414 | -15x | +664 | +9x |
- main_footer = character(),+ countformat = colcount_format(cinfs[[1]]), |
| 415 | -15x | +665 | +9x |
- prov_footer = character()+ total_cnt = new_total,+ |
+
| 666 | +9x | +
+ topleft = newtl |
||
| 416 | +667 |
) |
||
| 417 | +668 |
-
+ } |
||
| 418 | +669 |
- # Titles/footer info are (independently) retained from first object if+ |
||
| 419 | +670 |
- # identical or missing in all other objects+ nz_len_els <- function(lst) {
|
||
| 420 | -15x | +671 | +100x |
- all_titles <- sapply(x, main_title)+ if (is(lst, "list")) {
|
| 421 | -15x | +672 | +13x |
- if (all_annots_identical(all_titles) || only_first_annot(all_titles)) {
+ lst[vapply(lst, function(x) length(x) > 0, NA)] |
| 422 | -2x | +673 | +87x |
- rbind_annot[["main_title"]] <- all_titles[[1]]+ } else if (is(lst, "character")) {
|
| 423 | -+ | |||
| 674 | +74x |
- }+ lst[nzchar(lst)] |
||
| 424 | +675 | - - | -||
| 425 | -15x | -
- all_sts <- lapply(x, subtitles)- |
- ||
| 426 | -15x | -
- if (all_annots_identical(all_sts) || only_first_annot(all_sts)) {
+ } else {
|
||
| 427 | -2x | +676 | +13x |
- rbind_annot[["subtitles"]] <- all_sts[[1]]+ lst |
| 428 | +677 |
} |
||
| 429 | +678 |
-
+ } |
||
| 430 | -15x | +|||
| 679 | +
- all_ftrs <- lapply(x, main_footer)+ |
|||
| 431 | -15x | +|||
| 680 | +
- if (all_annots_identical(all_ftrs) || only_first_annot(all_ftrs)) {
+ has_one_unq <- function(x) {
|
|||
| 432 | -2x | +681 | +100x |
- rbind_annot[["main_footer"]] <- all_ftrs[[1]]+ length(unique(nz_len_els(x))) <= 1 |
| 433 | +682 |
- }+ } |
||
| 434 | +683 | |||
| 435 | -15x | +|||
| 684 | +
- all_pfs <- lapply(x, prov_footer)+ classvec <- function(lst, enforce_one = TRUE) {
|
|||
| 436 | -15x | +685 | +26x |
- if (all_annots_identical(all_pfs) || only_first_annot(all_pfs)) {
+ if (enforce_one) {
|
| 437 | -2x | +686 | +26x |
- rbind_annot[["prov_footer"]] <- all_pfs[[1]]+ vapply(lst, class, "") |
| 438 | +687 |
- }+ } else {
|
||
| 439 | -+ | |||
| 688 | +! |
-
+ lapply(lst, class) |
||
| 440 | +689 |
- ## if we got only ElementaryTable and+ } |
||
| 441 | +690 |
- ## TableRow objects, construct a new+ } |
||
| 442 | +691 |
- ## elementary table with all the rows+ |
||
| 443 | +692 |
- ## instead of adding nesting.+ chk_cbindable_many <- function(lst) {
|
||
| 444 | +693 |
-
+ ## we actually want is/inherits there but no easy way |
||
| 445 | +694 |
- ## we used to check for xi not being a lable row, why?? XXX- |
- ||
| 446 | -15x | -
- if (all(sapply(x, function(xi) {
+ ## to figure out what the lowest base class is |
||
| 447 | -30x | +|||
| 695 | +
- (is(xi, "ElementaryTable") && !labelrow_visible(xi)) ||+ ## that I can think of right now, so we do the |
|||
| 448 | -30x | +|||
| 696 | +
- is(xi, "TableRow")+ ## broken wrong thing instead :( |
|||
| 449 | +697 | 15x |
- }))) { ## && !is(xi, "LabelRow")}))) {
- |
- |
| 450 | -8x | -
- x <- unlist(lapply(x, function(xi) {
+ if (are(lst, "TableRow")) {
|
||
| 451 | -16x | +698 | +2x |
- if (is(xi, "TableRow")) {
+ if (!has_one_unq(classvec(lst))) {
|
| 452 | -4x | +699 | +1x |
- xi+ stop("Cannot cbind different types of TableRow objects together")
|
| 453 | +700 |
- } else {
- |
- ||
| 454 | -12x | -
- lst <- tree_children(xi)- |
- ||
| 455 | -12x | -
- lapply(lst, indent,+ } |
||
| 456 | -12x | +701 | +1x |
- by = indent_mod(xi)+ return(TRUE) |
| 457 | +702 |
- )+ } |
||
| 458 | +703 |
- }+ ## if(!are(lst, "VTableTree") |
||
| 459 | +704 |
- }))+ ## stop("Not all elements to be bound are TableTrees or TableRows")
|
||
| 460 | +705 |
- }+ |
||
| 461 | -+ | |||
| 706 | +13x |
-
+ nrs <- vapply(lst, NROW, 1L) |
||
| 462 | -15x | +707 | +13x |
- TableTree(+ if (!has_one_unq(nrs)) {
|
| 463 | -15x | +|||
| 708 | +! |
- kids = x,+ stop("Not all elements to be bound have matching numbers of rows")
|
||
| 464 | -15x | +|||
| 709 | +
- cinfo = firstcols,+ } |
|||
| 465 | -15x | +|||
| 710 | +
- name = "rbind_root",+ |
|||
| 466 | -15x | +711 | +13x |
- label = "",+ tls <- lapply(lst, top_left) |
| 467 | -15x | +712 | +13x |
- title = rbind_annot[["main_title"]],+ if (!has_one_unq(tls[vapply(tls, function(x) length(x) > 0, NA)])) {
|
| 468 | -15x | +713 | +2x |
- subtitles = rbind_annot[["subtitles"]],+ stop( |
| 469 | -15x | +714 | +2x |
- main_footer = rbind_annot[["main_footer"]],+ "Elements to be bound have differing top-left content: ", |
| 470 | -15x | +715 | +2x |
- prov_footer = rbind_annot[["prov_footer"]]+ paste(which(!duplicated(tls)), collapse = " ") |
| 471 | +716 |
- )+ ) |
||
| 472 | +717 |
- }+ } |
||
| 473 | +718 | |||
| 474 | -+ | |||
| 719 | +11x |
- #' Row-bind `TableTree` and related objects+ if (all(vapply(lst, function(x) nrow(x) == 0, NA))) {
|
||
| 475 | -+ | |||
| 720 | +1x |
- #'+ return(TRUE) |
||
| 476 | +721 |
- #' @param deparse.level (`numeric(1)`)\cr currently ignored.+ } |
||
| 477 | +722 |
- #' @param ... (`ANY`)\cr elements to be stacked.+ |
||
| 478 | -+ | |||
| 723 | +10x |
- #'+ rns <- matrix(vapply(lst, row.names, rep("", nrs[[1]])),
|
||
| 479 | -+ | |||
| 724 | +10x |
- #' @note+ nrow = nrs[[1]] |
||
| 480 | +725 |
- #' When objects are row-bound, titles and footer information is retained from the first object (if any exists) if all+ ) |
||
| 481 | -+ | |||
| 726 | +10x |
- #' other objects have no titles/footers or have identical titles/footers. Otherwise, all titles/footers are removed+ rnsok <- apply(rns, 1, has_one_unq) |
||
| 482 | -+ | |||
| 727 | +10x |
- #' and must be set for the bound table via the [formatters::main_title()], [formatters::subtitles()],+ if (!all(rnsok)) {
|
||
| 483 | -+ | |||
| 728 | +! |
- #' [formatters::main_footer()], and [formatters::prov_footer()] functions.+ stop( |
||
| 484 | -+ | |||
| 729 | +! |
- #'+ "Mismatching, non-empty row names detected in rows ", |
||
| 485 | -+ | |||
| 730 | +! |
- #' @examples+ paste(which(!rnsok), collapse = " ") |
||
| 486 | +731 |
- #' mtbl <- rtable(+ ) |
||
| 487 | +732 |
- #' header = rheader(+ } |
||
| 488 | +733 |
- #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
+
|
||
| 489 | -+ | |||
| 734 | +10x |
- #' rrow(NULL, "mean", "median", "mean", "median")+ rws <- lapply(lst, collect_leaves, add.labrows = TRUE) |
||
| 490 | -+ | |||
| 735 | +10x |
- #' ),+ rwclsmat <- matrix(unlist(lapply(rws, classvec)), |
||
| 491 | -+ | |||
| 736 | +10x |
- #' rrow(+ ncol = length(lst) |
||
| 492 | +737 |
- #' row.name = "All Species",+ ) |
||
| 493 | +738 |
- #' mean(iris$Sepal.Length), median(iris$Sepal.Length),+ |
||
| 494 | -+ | |||
| 739 | +10x |
- #' mean(iris$Petal.Length), median(iris$Petal.Length),+ rwsok <- apply(rwclsmat, 1, has_one_unq) |
||
| 495 | -+ | |||
| 740 | +10x |
- #' format = "xx.xx"+ if (!all(rwsok)) {
|
||
| 496 | -+ | |||
| 741 | +! |
- #' )+ stop( |
||
| 497 | -+ | |||
| 742 | +! |
- #' )+ "Mismatching row classes found for rows: ", |
||
| 498 | -+ | |||
| 743 | +! |
- #'+ paste(which(!rwsok), collapse = " ") |
||
| 499 | +744 |
- #' mtbl2 <- with(subset(iris, Species == "setosa"), rtable(+ ) |
||
| 500 | +745 |
- #' header = rheader(+ } |
||
| 501 | -+ | |||
| 746 | +10x |
- #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
+ TRUE |
||
| 502 | +747 |
- #' rrow(NULL, "mean", "median", "mean", "median")+ } |
||
| 503 | +748 |
- #' ),+ |
||
| 504 | +749 |
- #' rrow(+ #' Column-bind two `TableTree` objects |
||
| 505 | +750 |
- #' row.name = "Setosa",+ #' |
||
| 506 | +751 |
- #' mean(Sepal.Length), median(Sepal.Length),+ #' @param x (`TableTree` or `TableRow`)\cr a table or row object. |
||
| 507 | +752 |
- #' mean(Petal.Length), median(Petal.Length),+ #' @param ... one or more further objects of the same class as `x`. |
||
| 508 | +753 |
- #' format = "xx.xx"+ #' @param sync_count_vis (`logical(1)`)\cr should column count |
||
| 509 | +754 |
- #' )+ #' visibility be synced across the new and existing columns. |
||
| 510 | +755 |
- #' ))+ #' Currently defaults to `TRUE` for backwards compatibility but |
||
| 511 | +756 |
- #'+ #' this may change in future releases. |
||
| 512 | +757 |
- #' rbind(mtbl, mtbl2)+ #' |
||
| 513 | +758 |
- #' rbind(mtbl, rrow(), mtbl2)+ #' @inherit rbindl_rtables return |
||
| 514 | +759 |
- #' rbind(mtbl, rrow("aaa"), indent(mtbl2))
+ #' |
||
| 515 | +760 |
- #'+ #' @examples |
||
| 516 | +761 |
- #' @exportMethod rbind+ #' x <- rtable(c("A", "B"), rrow("row 1", 1, 2), rrow("row 2", 3, 4))
|
||
| 517 | +762 |
- #' @rdname rbind+ #' y <- rtable("C", rrow("row 1", 5), rrow("row 2", 6))
|
||
| 518 | +763 |
- setMethod(+ #' z <- rtable("D", rrow("row 1", 9), rrow("row 2", 10))
|
||
| 519 | +764 |
- "rbind", "VTableNodeInfo",+ #' |
||
| 520 | +765 |
- function(..., deparse.level = 1) {
- |
- ||
| 521 | -! | -
- rbindl_rtables(list(...))+ #' t1 <- cbind_rtables(x, y) |
||
| 522 | +766 |
- }+ #' t1 |
||
| 523 | +767 |
- )+ #' |
||
| 524 | +768 |
-
+ #' t2 <- cbind_rtables(x, y, z) |
||
| 525 | +769 |
- #' @param y (`ANY`)\cr second element to be row-bound via `rbind2`.+ #' t2 |
||
| 526 | +770 |
#' |
||
| 527 | +771 |
- #' @exportMethod rbind2+ #' col_paths_summary(t1) |
||
| 528 | +772 |
- #' @rdname int_methods+ #' col_paths_summary(t2) |
||
| 529 | +773 |
- setMethod(+ #' |
||
| 530 | +774 |
- "rbind2", c("VTableNodeInfo", "missing"),
+ #' @export |
||
| 531 | +775 |
- function(x, y) {
+ cbind_rtables <- function(x, ..., sync_count_vis = TRUE) {
|
||
| 532 | -2x | +776 | +10x |
- TableTree(kids = list(x), cinfo = col_info(x), name = "rbind_root", label = "")+ lst <- list(...) |
| 533 | -+ | |||
| 777 | +10x |
- }+ newcinfo <- combine_cinfo(x, ..., sync_count_vis = sync_count_vis)+ |
+ ||
| 778 | +9x | +
+ recurse_cbindl(x, cinfo = newcinfo, .list = lst) |
||
| 534 | +779 |
- )+ } |
||
| 535 | +780 | |||
| 536 | -+ | |||
| 781 | +89x |
- #' @param x (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object.+ setGeneric("recurse_cbindl", function(x, cinfo, .list = NULL) standardGeneric("recurse_cbindl"))
|
||
| 537 | +782 |
- #' @param y (`VTableNodeInfo`)\cr `TableTree`, `ElementaryTable`, or `TableRow` object.+ |
||
| 538 | +783 |
- #'+ setMethod( |
||
| 539 | +784 |
- #' @exportMethod rbind2+ "recurse_cbindl", c( |
||
| 540 | +785 |
- #' @rdname rbind+ x = "VTableNodeInfo", |
||
| 541 | +786 |
- setMethod(+ cinfo = "NULL" |
||
| 542 | +787 |
- "rbind2", "VTableNodeInfo",+ ), |
||
| 543 | +788 |
- function(x, y) {
+ function(x, cinfo, .list = NULL) {
|
||
| 544 | -12x | +|||
| 789 | +! |
- rbindl_rtables(list(x, y))+ recurse_cbindl(x, cinfo = combine_cinfo(.list), .list = .list) |
||
| 545 | +790 |
} |
||
| 546 | +791 |
) |
||
| 547 | +792 | |||
| 548 | +793 |
- EmptyTreePos <- TreePos()+ setMethod( |
||
| 549 | +794 |
-
+ "recurse_cbindl", c( |
||
| 550 | +795 |
- ## this is painful to do right but we were doing it wrong+ x = "TableTree", |
||
| 551 | +796 |
- ## before and it now matters because count display information+ cinfo = "InstantiatedColumnInfo" |
||
| 552 | +797 |
- ## is in the tree which means all points in the structure+ ), |
||
| 553 | +798 |
- ## must be pathable, which they aren't if siblings have+ function(x, cinfo, .list = NULL) {
|
||
| 554 | -+ | |||
| 799 | +18x |
- ## identical names+ stopifnot(are(.list, "VTableTree")) |
||
| 555 | +800 |
- fix_col_nm_recursive <- function(ct, newname, rename_obj = TRUE, oldnm) {
+ ## chk_cbindable(x, y) |
||
| 556 | -120x | +801 | +18x |
- if (rename_obj) {
+ xcont <- content_table(x) |
| 557 | -19x | -
- obj_name(ct) <- newname- |
- ||
| 558 | -+ | 802 | +18x |
- }+ lstconts <- lapply(.list, content_table) |
| 559 | -120x | +803 | +18x |
- if (is(ct, "LayoutColTree")) {
+ lcontnrows <- vapply(lstconts, NROW, 1L) |
| 560 | -45x | +804 | +18x |
- kids <- tree_children(ct)+ unqnrcont <- unique(c(NROW(xcont), lcontnrows)) |
| 561 | -45x | +805 | +18x |
- kidnms <- names(kids)+ if (length(unqnrcont) > 1) {
|
| 562 | -45x | +|||
| 806 | +! |
- newkids <- lapply(kids, fix_col_nm_recursive,+ stop( |
||
| 563 | -45x | +|||
| 807 | +! |
- newname = newname,+ "Got differing numbers of content rows [", |
||
| 564 | -45x | +|||
| 808 | +! |
- rename_obj = FALSE,+ paste(unqnrcont, collapse = ", "), |
||
| 565 | -45x | +|||
| 809 | +! |
- oldnm = oldnm+ "]. Unable to cbind these rtables" |
||
| 566 | +810 |
- )- |
- ||
| 567 | -45x | -
- names(newkids) <- kidnms- |
- ||
| 568 | -45x | -
- tree_children(ct) <- newkids+ ) |
||
| 569 | +811 |
- }- |
- ||
| 570 | -120x | -
- mypos <- tree_pos(ct)+ } |
||
| 571 | -120x | +|||
| 812 | +
- if (!identical(mypos, EmptyTreePos)) {
+
|
|||
| 572 | -97x | +813 | +18x |
- spls <- pos_splits(mypos)+ if (unqnrcont == 0) {
|
| 573 | -97x | +814 | +18x |
- firstspl <- spls[[1]]+ cont <- ElementaryTable(cinfo = cinfo) |
| 574 | -97x | +|||
| 815 | +
- if (obj_name(firstspl) == oldnm) {
+ } else {
|
|||
| 575 | +816 | ! |
- obj_name(firstspl) <- newname+ cont <- recurse_cbindl(xcont, |
|
| 576 | +817 | ! |
- spls[[1]] <- firstspl+ .list = lstconts, |
|
| 577 | +818 | ! |
- pos_splits(mypos) <- spls+ cinfo = cinfo |
|
| 578 | -! | +|||
| 819 | +
- tree_pos(ct) <- mypos+ ) |
|||
| 579 | +820 |
} |
||
| 580 | +821 |
- }+ |
||
| 581 | -120x | +822 | +18x |
- if (!rename_obj) {
+ kids <- lapply( |
| 582 | -101x | +823 | +18x |
- spls <- pos_splits(mypos)+ seq_along(tree_children(x)), |
| 583 | -101x | +824 | +18x |
- splvals <- pos_splvals(mypos)+ function(i) {
|
| 584 | -101x | +825 | +27x |
- pos_splits(mypos) <- c(+ recurse_cbindl( |
| 585 | -101x | +826 | +27x |
- list(AllSplit(split_name = newname)),+ x = tree_children(x)[[i]], |
| 586 | -101x | +827 | +27x |
- spls+ cinfo = cinfo,+ |
+
| 828 | +27x | +
+ .list = lapply(.list, function(tt) tree_children(tt)[[i]]) |
||
| 587 | +829 |
- )+ ) |
||
| 588 | -101x | +|||
| 830 | +
- pos_splvals(mypos) <- c(+ } |
|||
| 589 | -101x | +|||
| 831 | +
- list(SplitValue(NA_character_,+ ) |
|||
| 590 | -101x | +832 | +18x |
- sub_expr = quote(TRUE)+ names(kids) <- names(tree_children(x)) |
| 591 | -+ | |||
| 833 | +18x |
- )),+ TableTree( |
||
| 592 | -101x | +834 | +18x |
- splvals+ kids = kids, labelrow = recurse_cbindl(tt_labelrow(x), |
| 593 | -+ | |||
| 835 | +18x |
- )+ cinfo = cinfo, |
||
| 594 | -101x | +836 | +18x |
- tree_pos(ct) <- mypos+ .list = lapply(.list, tt_labelrow) |
| 595 | +837 |
- }+ ), |
||
| 596 | -120x | +838 | +18x |
- ct+ cont = cont, |
| 597 | -+ | |||
| 839 | +18x |
- }+ name = obj_name(x), |
||
| 598 | -+ | |||
| 840 | +18x |
-
+ lev = tt_level(x), |
||
| 599 | -+ | |||
| 841 | +18x |
- fix_nms <- function(ct) {
+ cinfo = cinfo, |
||
| 600 | -129x | +842 | +18x |
- if (is(ct, "LayoutColLeaf")) {
+ format = obj_format(x) |
| 601 | -75x | +|||
| 843 | +
- return(ct)+ ) |
|||
| 602 | +844 |
} |
||
| 603 | -54x | +|||
| 845 | +
- kids <- lapply(tree_children(ct), fix_nms)+ ) |
|||
| 604 | -54x | +|||
| 846 | +
- names(kids) <- vapply(kids, obj_name, "")+ |
|||
| 605 | -54x | +|||
| 847 | +
- tree_children(ct) <- kids+ setMethod( |
|||
| 606 | -54x | +|||
| 848 | +
- ct+ "recurse_cbindl", c( |
|||
| 607 | +849 |
- }+ x = "ElementaryTable", |
||
| 608 | +850 |
-
+ cinfo = "InstantiatedColumnInfo" |
||
| 609 | +851 |
- make_cbind_names <- function(num, tokens) {
+ ), |
||
| 610 | -9x | +|||
| 852 | +
- cbind_tokens <- grep("^(new_)*cbind_tbl", tokens, value = TRUE)
+ function(x, cinfo, .list) {
|
|||
| 611 | -9x | +853 | +18x |
- ret <- paste0("cbind_tbl_", seq_len(num))
- |
-
| 612 | -9x | -
- if (length(cbind_tokens) == 0) {
- |
- ||
| 613 | -9x | -
- return(ret)+ stopifnot(are(.list, class(x))) |
||
| 614 | +854 |
- }+ ## chk_cbindable(x,y) |
||
| 615 | -! | +|||
| 855 | +18x |
- oldprefixes <- gsub("cbind_tbl.*", "", cbind_tokens)
+ if (nrow(x) == 0 && all(vapply(.list, nrow, 1L) == 0)) {
|
||
| 616 | -! | +|||
| 856 | +1x |
- oldprefix <- oldprefixes[which.max(nchar(oldprefixes))]+ col_info(x) <- cinfo |
||
| 617 | -! | +|||
| 857 | +1x |
- paste0("new_", oldprefix, ret)
+ return(x) ## this needs testing... I was right, it did #136 |
||
| 618 | +858 |
- }+ } |
||
| 619 | -+ | |||
| 859 | +17x |
-
+ kids <- lapply( |
||
| 620 | -+ | |||
| 860 | +17x |
- combine_cinfo <- function(..., new_total = NULL, sync_count_vis) {
+ seq_along(tree_children(x)), |
||
| 621 | -10x | +861 | +17x |
- tabs <- list(...)+ function(i) {
|
| 622 | -10x | +862 | +18x |
- chk_cbindable_many(tabs)+ recurse_cbindl( |
| 623 | -9x | +863 | +18x |
- cinfs <- lapply(tabs, col_info)+ x = tree_children(x)[[i]], |
| 624 | -9x | +864 | +18x |
- stopifnot(are(cinfs, "InstantiatedColumnInfo"))+ cinfo = cinfo, |
| 625 | -+ | |||
| 865 | +18x |
-
+ .list = lapply(.list, function(tt) tree_children(tt)[[i]]) |
||
| 626 | -9x | +|||
| 866 | +
- ctrees <- lapply(cinfs, coltree)+ ) |
|||
| 627 | -9x | +|||
| 867 | +
- oldnms <- nms <- vapply(ctrees, obj_name, "")+ } |
|||
| 628 | -9x | +|||
| 868 | +
- path_els <- unique(unlist(lapply(ctrees, col_paths), recursive = TRUE))+ ) |
|||
| 629 | -9x | +869 | +17x |
- nms <- make_cbind_names(num = length(oldnms), tokens = path_els)+ names(kids) <- names(tree_children(x)) |
| 630 | +870 | |||
| 631 | -9x | +871 | +17x |
- ctrees <- mapply(function(ct, nm, oldnm) {
+ ElementaryTable( |
| 632 | -19x | +872 | +17x |
- ct <- fix_col_nm_recursive(ct, nm, rename_obj = TRUE, oldnm = "") # oldnm)+ kids = kids, |
| 633 | -19x | +873 | +17x |
- ct+ labelrow = recurse_cbindl(tt_labelrow(x), |
| 634 | -9x | +874 | +17x |
- }, ct = ctrees, nm = nms, oldnm = oldnms, SIMPLIFY = FALSE)+ .list = lapply(.list, tt_labelrow), |
| 635 | -9x | +875 | +17x |
- names(ctrees) <- nms+ cinfo |
| 636 | +876 |
-
+ ), |
||
| 637 | -9x | +877 | +17x |
- newctree <- LayoutColTree(kids = ctrees, colcount = NA_integer_, name = "cbind_root")+ name = obj_name(x), |
| 638 | -9x | +878 | +17x |
- newctree <- fix_nms(newctree)+ lev = tt_level(x), |
| 639 | -9x | +879 | +17x |
- newcounts <- unlist(lapply(cinfs, col_counts))+ cinfo = cinfo, |
| 640 | -9x | +880 | +17x |
- if (is.null(new_total)) {
+ format = obj_format(x), |
| 641 | -9x | +881 | +17x |
- new_total <- sum(newcounts)+ var = obj_avar(x) |
| 642 | +882 |
- }- |
- ||
| 643 | -9x | -
- newexprs <- unlist(lapply(cinfs, col_exprs), recursive = FALSE)+ ) |
||
| 644 | -9x | +|||
| 883 | +
- newexargs <- unlist(lapply(cinfs, col_extra_args), recursive = FALSE) %||% vector("list", length(newcounts))
+ } |
|||
| 645 | -9x | +|||
| 884 | +
- if (!sync_count_vis) {
+ ) |
|||
| 646 | -1x | +|||
| 885 | +
- newdisp <- NA+ |
|||
| 647 | +886 |
- } else {
+ .combine_rows <- function(x, cinfo = NULL, .list) {
|
||
| 648 | -8x | +887 | +18x |
- newdisp <- any(vapply(cinfs, disp_ccounts, NA))+ stopifnot(are(.list, class(x))) |
| 649 | +888 |
- }- |
- ||
| 650 | -9x | -
- alltls <- lapply(cinfs, top_left)+ |
||
| 651 | -9x | +889 | +18x |
- newtl <- character()+ avars <- c(obj_avar(x), unlist(lapply(.list, obj_avar), recursive = FALSE)) |
| 652 | -9x | +890 | +18x |
- if (!are(tabs, "TableRow")) {
+ avars <- avars[!is.na(avars)] |
| 653 | -9x | +|||
| 891 | +
- alltls <- alltls[vapply(alltls, function(x) length(x) > 0, NA)] ## these are already enforced to all be the same+ |
|||
| 654 | -9x | +892 | +18x |
- if (length(alltls) > 0) {
+ if (length(unique(avars)) > 1) {
|
| 655 | +893 | ! |
- newtl <- alltls[[1]]+ stop("Got rows that don't analyze the same variable")
|
|
| 656 | +894 |
- }+ } |
||
| 657 | +895 |
- }- |
- ||
| 658 | -9x | -
- InstantiatedColumnInfo(+ |
||
| 659 | -9x | +896 | +18x |
- treelyt = newctree,+ xlst <- c(list(x), .list) |
| 660 | -9x | +|||
| 897 | +
- csubs = newexprs,+ |
|||
| 661 | -9x | +898 | +18x |
- extras = newexargs,+ ncols <- vapply(xlst, ncol, 1L) |
| 662 | -9x | +899 | +18x |
- cnts = newcounts,+ totcols <- sum(ncols) |
| 663 | -9x | +900 | +18x |
- dispcounts = newdisp,+ cumncols <- cumsum(ncols) |
| 664 | -9x | +901 | +18x |
- countformat = colcount_format(cinfs[[1]]),+ strtncols <- c(0L, head(cumncols, -1)) + 1L |
| 665 | -9x | +902 | +18x |
- total_cnt = new_total,+ vals <- vector("list", totcols)
|
| 666 | -9x | +903 | +18x |
- topleft = newtl+ cspans <- integer(totcols) |
| 667 | +904 |
- )+ ## vals[1:ncol(x)] <- row_values(x) |
||
| 668 | +905 |
- }+ ## cpans[1:ncol(x)] <- row_cspans(x) |
||
| 669 | +906 | |||
| 670 | -- |
- nz_len_els <- function(lst) {
- |
- ||
| 671 | -100x | -
- if (is(lst, "list")) {
- |
- ||
| 672 | -13x | +907 | +18x |
- lst[vapply(lst, function(x) length(x) > 0, NA)]+ for (i in seq_along(xlst)) {
|
| 673 | -87x | +908 | +37x |
- } else if (is(lst, "character")) {
+ strt <- strtncols[i] |
| 674 | -74x | +909 | +37x |
- lst[nzchar(lst)]+ end <- cumncols[i] |
| 675 | +910 |
- } else {
+ ## full vars are here for debugging purposes |
||
| 676 | -13x | +911 | +37x |
- lst+ fullvy <- vy <- row_cells(xlst[[i]]) # nolint |
| 677 | -+ | |||
| 912 | +37x |
- }+ fullcspy <- cspy <- row_cspans(xlst[[i]]) # nolint |
||
| 678 | +913 |
- }+ |
||
| 679 | +914 |
-
+ if ( |
||
| 680 | -+ | |||
| 915 | +37x |
- has_one_unq <- function(x) {
+ i > 1 && |
||
| 681 | -100x | +916 | +37x |
- length(unique(nz_len_els(x))) <= 1+ identical(rawvalues(vy[[1]]), rawvalues(lastval)) && |
| 682 | +917 |
- }+ ## cspy[1] == lastspn && |
||
| 683 | -+ | |||
| 918 | +37x |
-
+ lastspn > 1 |
||
| 684 | +919 |
- classvec <- function(lst, enforce_one = TRUE) {
+ ) {
|
||
| 685 | -26x | +|||
| 920 | +! |
- if (enforce_one) {
+ vy <- vy[-1] |
||
| 686 | -26x | +|||
| 921 | +! |
- vapply(lst, class, "")+ cspans[strt - 1L] <- lastspn + cspy[1] |
||
| 687 | -+ | |||
| 922 | +! |
- } else {
+ cspy <- cspy[-1] |
||
| 688 | +923 | ! |
- lapply(lst, class)+ strt <- strt + 1L |
|
| 689 | +924 |
- }+ } |
||
| 690 | -+ | |||
| 925 | +37x |
- }+ if (length(vy) > 0) {
|
||
| 691 | -+ | |||
| 926 | +37x |
-
+ vals[strt:end] <- vy |
||
| 692 | -+ | |||
| 927 | +37x |
- chk_cbindable_many <- function(lst) {
+ cspans[strt:end] <- cspy |
||
| 693 | -+ | |||
| 928 | +37x |
- ## we actually want is/inherits there but no easy way+ lastval <- vy[[length(vy)]] |
||
| 694 | -+ | |||
| 929 | +37x |
- ## to figure out what the lowest base class is+ lastspn <- cspy[[length(cspy)]] |
||
| 695 | +930 |
- ## that I can think of right now, so we do the+ } else {
|
||
| 696 | +931 |
- ## broken wrong thing instead :(- |
- ||
| 697 | -15x | -
- if (are(lst, "TableRow")) {
- |
- ||
| 698 | -2x | -
- if (!has_one_unq(classvec(lst))) {
+ ## lastval stays the same |
||
| 699 | -1x | +|||
| 932 | +! |
- stop("Cannot cbind different types of TableRow objects together")
+ lastspn <- cspans[strtncols[i] - 1] ## already updated |
||
| 700 | +933 |
} |
||
| 701 | -1x | -
- return(TRUE)- |
- ||
| 702 | +934 |
} |
||
| 703 | +935 |
- ## if(!are(lst, "VTableTree")+ |
||
| 704 | +936 |
- ## stop("Not all elements to be bound are TableTrees or TableRows")
+ ## Could be DataRow or ContentRow |
||
| 705 | +937 |
-
+ ## This is ok because LabelRow is special cased |
||
| 706 | -13x | +938 | +18x |
- nrs <- vapply(lst, NROW, 1L)+ constr_fun <- get(class(x), mode = "function") |
| 707 | -13x | -
- if (!has_one_unq(nrs)) {
- |
- ||
| 708 | -! | +939 | +18x |
- stop("Not all elements to be bound have matching numbers of rows")
+ constr_fun( |
| 709 | -+ | |||
| 940 | +18x |
- }+ vals = vals, |
||
| 710 | -+ | |||
| 941 | +18x |
-
+ cspan = cspans, |
||
| 711 | -13x | +942 | +18x |
- tls <- lapply(lst, top_left)+ cinfo = cinfo, |
| 712 | -13x | +943 | +18x |
- if (!has_one_unq(tls[vapply(tls, function(x) length(x) > 0, NA)])) {
+ var = obj_avar(x), |
| 713 | -2x | +944 | +18x |
- stop(+ format = obj_format(x), |
| 714 | -2x | +945 | +18x |
- "Elements to be bound have differing top-left content: ",+ name = obj_name(x), |
| 715 | -2x | +946 | +18x |
- paste(which(!duplicated(tls)), collapse = " ")+ label = obj_label(x) |
| 716 | +947 |
- )+ ) |
||
| 717 | +948 |
- }+ } |
||
| 718 | +949 | |||
| 719 | -11x | -
- if (all(vapply(lst, function(x) nrow(x) == 0, NA))) {
- |
- ||
| 720 | -1x | -
- return(TRUE)- |
- ||
| 721 | +950 |
- }+ setMethod( |
||
| 722 | +951 | - - | -||
| 723 | -10x | -
- rns <- matrix(vapply(lst, row.names, rep("", nrs[[1]])),
- |
- ||
| 724 | -10x | -
- nrow = nrs[[1]]+ "recurse_cbindl", c( |
||
| 725 | +952 |
- )- |
- ||
| 726 | -10x | -
- rnsok <- apply(rns, 1, has_one_unq)- |
- ||
| 727 | -10x | -
- if (!all(rnsok)) {
- |
- ||
| 728 | -! | -
- stop(- |
- ||
| 729 | -! | -
- "Mismatching, non-empty row names detected in rows ",- |
- ||
| 730 | -! | -
- paste(which(!rnsok), collapse = " ")+ "TableRow", |
||
| 731 | +953 |
- )+ "InstantiatedColumnInfo" |
||
| 732 | +954 |
- }+ ), |
||
| 733 | +955 | - - | -||
| 734 | -10x | -
- rws <- lapply(lst, collect_leaves, add.labrows = TRUE)+ function(x, cinfo = NULL, .list) {
|
||
| 735 | -10x | +956 | +18x |
- rwclsmat <- matrix(unlist(lapply(rws, classvec)),+ .combine_rows(x, cinfo, .list) |
| 736 | -10x | +|||
| 957 | +
- ncol = length(lst)+ } |
|||
| 737 | +958 |
- )+ ) |
||
| 738 | +959 | |||
| 739 | -10x | +|||
| 960 | +
- rwsok <- apply(rwclsmat, 1, has_one_unq)+ setMethod( |
|||
| 740 | -10x | +|||
| 961 | +
- if (!all(rwsok)) {
+ "recurse_cbindl", c( |
|||
| 741 | -! | +|||
| 962 | +
- stop(+ x = "LabelRow", |
|||
| 742 | -! | +|||
| 963 | +
- "Mismatching row classes found for rows: ",+ cinfo = "InstantiatedColumnInfo" |
|||
| 743 | -! | +|||
| 964 | +
- paste(which(!rwsok), collapse = " ")+ ), |
|||
| 744 | +965 |
- )+ function(x, cinfo = NULL, .list) {
|
||
| 745 | -+ | |||
| 966 | +35x |
- }+ col_info(x) <- cinfo |
||
| 746 | -10x | +967 | +35x |
- TRUE+ x |
| 747 | +968 |
- }+ } |
||
| 748 | +969 |
-
+ ) |
||
| 749 | +970 |
- #' Column-bind two `TableTree` objects+ |
||
| 750 | +971 |
- #'+ ## we don't care about the following discrepencies: |
||
| 751 | +972 |
- #' @param x (`TableTree` or `TableRow`)\cr a table or row object.+ ## - ci2 having NA counts when ci1 doesn't |
||
| 752 | +973 |
- #' @param ... one or more further objects of the same class as `x`.+ ## - mismatching display_ccounts values |
||
| 753 | +974 |
- #' @param sync_count_vis (`logical(1)`)\cr should column count+ ## - mismatching colcount formats |
||
| 754 | +975 |
- #' visibility be synced across the new and existing columns.+ ## |
||
| 755 | +976 |
- #' Currently defaults to `TRUE` for backwards compatibility but+ |
||
| 756 | +977 |
- #' this may change in future releases.+ # chk_compat_cinfos <- function(ci1, ci2) {
|
||
| 757 | +978 |
- #'+ chk_compat_cinfos <- function(tt1, tt2) {
|
||
| 758 | -+ | |||
| 979 | +41x |
- #' @inherit rbindl_rtables return+ nc1 <- ncol(tt1) |
||
| 759 | -+ | |||
| 980 | +41x |
- #'+ nc2 <- ncol(tt2) |
||
| 760 | -+ | |||
| 981 | +41x |
- #' @examples+ if (nc1 != nc2 && nc1 > 0 && nc2 > 0) {
|
||
| 761 | -+ | |||
| 982 | +1x |
- #' x <- rtable(c("A", "B"), rrow("row 1", 1, 2), rrow("row 2", 3, 4))
+ stop("Column structures contain different non-zero numbers of columns: ", nc1, ", ", nc2)
|
||
| 762 | +983 |
- #' y <- rtable("C", rrow("row 1", 5), rrow("row 2", 6))
+ } |
||
| 763 | -+ | |||
| 984 | +40x |
- #' z <- rtable("D", rrow("row 1", 9), rrow("row 2", 10))
+ if (no_colinfo(tt1) || no_colinfo(tt2)) {
|
||
| 764 | -+ | |||
| 985 | +10x |
- #'+ return(TRUE) |
||
| 765 | +986 |
- #' t1 <- cbind_rtables(x, y)+ } |
||
| 766 | -+ | |||
| 987 | +30x |
- #' t1+ ci1 <- col_info(tt1) |
||
| 767 | -+ | |||
| 988 | +30x |
- #'+ ci2 <- col_info(tt2) |
||
| 768 | +989 |
- #' t2 <- cbind_rtables(x, y, z)+ ## this will enforce same length and |
||
| 769 | +990 |
- #' t2+ ## same names, in addition to same |
||
| 770 | +991 |
- #'+ ## expressions so we dont need |
||
| 771 | +992 |
- #' col_paths_summary(t1)+ ## to check those separateley |
||
| 772 | -+ | |||
| 993 | +30x |
- #' col_paths_summary(t2)+ if (!identical(col_exprs(ci1), col_exprs(ci2))) {
|
||
| 773 | -+ | |||
| 994 | +! |
- #'+ stop("Column structures not compatible: subset expression lists not identical")
|
||
| 774 | +995 |
- #' @export+ } |
||
| 775 | +996 |
- cbind_rtables <- function(x, ..., sync_count_vis = TRUE) {
+
|
||
| 776 | -10x | +997 | +30x |
- lst <- list(...)+ if (any(!is.na(col_counts(ci2))) && |
| 777 | -10x | +998 | +30x |
- newcinfo <- combine_cinfo(x, ..., sync_count_vis = sync_count_vis)+ !identical( |
| 778 | -9x | +999 | +30x |
- recurse_cbindl(x, cinfo = newcinfo, .list = lst)+ col_counts(ci1), |
| 779 | -+ | |||
| 1000 | +30x |
- }+ col_counts(ci2) |
||
| 780 | +1001 |
-
+ )) {
|
||
| 781 | -89x | +|||
| 1002 | +! |
- setGeneric("recurse_cbindl", function(x, cinfo, .list = NULL) standardGeneric("recurse_cbindl"))
+ stop("Column structures not compatible: 2nd column structure has non-matching, non-null column counts")
|
||
| 782 | +1003 |
-
+ } |
||
| 783 | +1004 |
- setMethod(+ |
||
| 784 | -+ | |||
| 1005 | +30x |
- "recurse_cbindl", c(+ if (any(sapply( |
||
| 785 | -- |
- x = "VTableNodeInfo",- |
- ||
| 786 | -+ | |||
| 1006 | +30x |
- cinfo = "NULL"+ col_extra_args(ci2), |
||
| 787 | -+ | |||
| 1007 | +30x |
- ),+ function(x) length(x) > 0 |
||
| 788 | +1008 |
- function(x, cinfo, .list = NULL) {
- |
- ||
| 789 | -! | -
- recurse_cbindl(x, cinfo = combine_cinfo(.list), .list = .list)+ )) && |
||
| 790 | -+ | |||
| 1009 | +30x |
- }+ !identical( |
||
| 791 | -+ | |||
| 1010 | +30x |
- )+ col_extra_args(ci1), |
||
| 792 | -+ | |||
| 1011 | +30x |
-
+ col_extra_args(ci2) |
||
| 793 | +1012 |
- setMethod(+ )) {
|
||
| 794 | -+ | |||
| 1013 | +! |
- "recurse_cbindl", c(+ stop( |
||
| 795 | -+ | |||
| 1014 | +! |
- x = "TableTree",+ "Column structures not compatible: 2nd column structure has ", |
||
| 796 | -+ | |||
| 1015 | +! |
- cinfo = "InstantiatedColumnInfo"+ "non-matching, non-null extra args" |
||
| 797 | +1016 |
- ),+ ) |
||
| 798 | +1017 |
- function(x, cinfo, .list = NULL) {
- |
- ||
| 799 | -18x | -
- stopifnot(are(.list, "VTableTree"))+ } |
||
| 800 | +1018 |
- ## chk_cbindable(x, y)+ |
||
| 801 | -18x | +1019 | +30x |
- xcont <- content_table(x)+ if (any(nzchar(top_left(ci1))) && any(nzchar(top_left(ci2))) && !identical(top_left(ci1), top_left(ci2))) {
|
| 802 | -18x | +1020 | +1x |
- lstconts <- lapply(.list, content_table)+ stop( |
| 803 | -18x | +1021 | +1x |
- lcontnrows <- vapply(lstconts, NROW, 1L)+ "Top-left materials not compatible: Got non-empty, non-matching ", |
| 804 | -18x | +1022 | +1x |
- unqnrcont <- unique(c(NROW(xcont), lcontnrows))+ "top-left materials. Clear them using top_left(x)<-character() ", |
| 805 | -18x | -
- if (length(unqnrcont) > 1) {
- |
- ||
| 806 | -! | +1023 | +1x |
- stop(+ "before binding to force compatibility." |
| 807 | -! | +|||
| 1024 | +
- "Got differing numbers of content rows [",+ ) |
|||
| 808 | -! | +|||
| 1025 | +
- paste(unqnrcont, collapse = ", "),+ } |
|||
| 809 | -! | +|||
| 1026 | +29x |
- "]. Unable to cbind these rtables"+ TRUE |
||
| 810 | +1027 |
- )+ } |
||
| 811 | +1028 |
- }+ |
||
| 812 | +1029 | |||
| 813 | -18x | +|||
| 1030 | +
- if (unqnrcont == 0) {
+ #' Insert `rrow`s at (before) a specific location |
|||
| 814 | -18x | +|||
| 1031 | +
- cont <- ElementaryTable(cinfo = cinfo)+ #' |
|||
| 815 | +1032 |
- } else {
+ #' `r lifecycle::badge("deprecated")`
|
||
| 816 | -! | +|||
| 1033 | +
- cont <- recurse_cbindl(xcont,+ #' |
|||
| 817 | -! | +|||
| 1034 | +
- .list = lstconts,+ #' This function is deprecated and will be removed in a future release of `rtables`. Please use |
|||
| 818 | -! | +|||
| 1035 | +
- cinfo = cinfo+ #' [insert_row_at_path()] or [label_at_path()] instead. |
|||
| 819 | +1036 |
- )+ #' |
||
| 820 | +1037 |
- }+ #' @param tbl (`VTableTree`)\cr a `rtable` object. |
||
| 821 | +1038 |
-
+ #' @param rrow (`TableRow`)\cr an `rrow` to append to `tbl`. |
||
| 822 | -18x | +|||
| 1039 | +
- kids <- lapply(+ #' @param at (`integer(1)`)\cr position into which to put the `rrow`, defaults to beginning (i.e. row 1). |
|||
| 823 | -18x | +|||
| 1040 | +
- seq_along(tree_children(x)),+ #' @param ascontent (`flag`)\cr currently ignored. |
|||
| 824 | -18x | +|||
| 1041 | +
- function(i) {
+ #' |
|||
| 825 | -27x | +|||
| 1042 | +
- recurse_cbindl(+ #' @return A `TableTree` of the same specific class as `tbl`. |
|||
| 826 | -27x | +|||
| 1043 | +
- x = tree_children(x)[[i]],+ #' |
|||
| 827 | -27x | +|||
| 1044 | +
- cinfo = cinfo,+ #' @note |
|||
| 828 | -27x | +|||
| 1045 | +
- .list = lapply(.list, function(tt) tree_children(tt)[[i]])+ #' Label rows (i.e. a row with no data values, only a `row.name`) can only be inserted at positions which do |
|||
| 829 | +1046 |
- )+ #' not already contain a label row when there is a non-trivial nested row structure in `tbl`. |
||
| 830 | +1047 |
- }+ #' |
||
| 831 | +1048 |
- )+ #' @examples |
||
| 832 | -18x | +|||
| 1049 | +
- names(kids) <- names(tree_children(x))+ #' o <- options(warn = 0) |
|||
| 833 | -18x | +|||
| 1050 | +
- TableTree(+ #' lyt <- basic_table() %>% |
|||
| 834 | -18x | +|||
| 1051 | +
- kids = kids, labelrow = recurse_cbindl(tt_labelrow(x),+ #' split_cols_by("Species") %>%
|
|||
| 835 | -18x | +|||
| 1052 | +
- cinfo = cinfo,+ #' analyze("Sepal.Length")
|
|||
| 836 | -18x | +|||
| 1053 | +
- .list = lapply(.list, tt_labelrow)+ #' |
|||
| 837 | +1054 |
- ),+ #' tbl <- build_table(lyt, iris) |
||
| 838 | -18x | +|||
| 1055 | +
- cont = cont,+ #' |
|||
| 839 | -18x | +|||
| 1056 | +
- name = obj_name(x),+ #' insert_rrow(tbl, rrow("Hello World"))
|
|||
| 840 | -18x | +|||
| 1057 | +
- lev = tt_level(x),+ #' insert_rrow(tbl, rrow("Hello World"), at = 2)
|
|||
| 841 | -18x | +|||
| 1058 | +
- cinfo = cinfo,+ #' |
|||
| 842 | -18x | +|||
| 1059 | +
- format = obj_format(x)+ #' lyt2 <- basic_table() %>% |
|||
| 843 | +1060 |
- )+ #' split_cols_by("Species") %>%
|
||
| 844 | +1061 |
- }+ #' split_rows_by("Species") %>%
|
||
| 845 | +1062 |
- )+ #' analyze("Sepal.Length")
|
||
| 846 | +1063 |
-
+ #' |
||
| 847 | +1064 |
- setMethod(+ #' tbl2 <- build_table(lyt2, iris) |
||
| 848 | +1065 |
- "recurse_cbindl", c(+ #' |
||
| 849 | +1066 |
- x = "ElementaryTable",+ #' insert_rrow(tbl2, rrow("Hello World"))
|
||
| 850 | +1067 |
- cinfo = "InstantiatedColumnInfo"+ #' insert_rrow(tbl2, rrow("Hello World"), at = 2)
|
||
| 851 | +1068 |
- ),+ #' insert_rrow(tbl2, rrow("Hello World"), at = 4)
|
||
| 852 | +1069 |
- function(x, cinfo, .list) {
+ #' |
||
| 853 | -18x | +|||
| 1070 | +
- stopifnot(are(.list, class(x)))+ #' insert_rrow(tbl2, rrow("new row", 5, 6, 7))
|
|||
| 854 | +1071 |
- ## chk_cbindable(x,y)+ #' |
||
| 855 | -18x | +|||
| 1072 | +
- if (nrow(x) == 0 && all(vapply(.list, nrow, 1L) == 0)) {
+ #' insert_rrow(tbl2, rrow("new row", 5, 6, 7), at = 3)
|
|||
| 856 | -1x | +|||
| 1073 | +
- col_info(x) <- cinfo+ #' |
|||
| 857 | -1x | +|||
| 1074 | +
- return(x) ## this needs testing... I was right, it did #136+ #' options(o) |
|||
| 858 | +1075 |
- }+ #' |
||
| 859 | -17x | +|||
| 1076 | +
- kids <- lapply(+ #' @export |
|||
| 860 | -17x | +|||
| 1077 | +
- seq_along(tree_children(x)),+ insert_rrow <- function(tbl, rrow, at = 1, |
|||
| 861 | -17x | +|||
| 1078 | +
- function(i) {
+ ascontent = FALSE) {
|
|||
| 862 | -18x | +1079 | +9x |
- recurse_cbindl(+ lifecycle::deprecate_warn( |
| 863 | -18x | +1080 | +9x |
- x = tree_children(x)[[i]],+ when = "0.4.0", |
| 864 | -18x | +1081 | +9x |
- cinfo = cinfo,+ what = "insert_rrow()", |
| 865 | -18x | -
- .list = lapply(.list, function(tt) tree_children(tt)[[i]])- |
- ||
| 866 | -+ | 1082 | +9x |
- )+ with = I("insert_row_at_path() or label_at_path()")
|
| 867 | +1083 |
- }+ ) |
||
| 868 | -+ | |||
| 1084 | +9x |
- )+ stopifnot( |
||
| 869 | -17x | +1085 | +9x |
- names(kids) <- names(tree_children(x))+ is(tbl, "VTableTree"), |
| 870 | -+ | |||
| 1086 | +9x |
-
+ is(rrow, "TableRow"), |
||
| 871 | -17x | +1087 | +9x |
- ElementaryTable(+ at >= 1 && at <= nrow(tbl) + 1 |
| 872 | -17x | +|||
| 1088 | +
- kids = kids,+ ) |
|||
| 873 | -17x | +1089 | +9x |
- labelrow = recurse_cbindl(tt_labelrow(x),+ chk_compat_cinfos(tbl, rrow) |
| 874 | -17x | +1090 | +8x |
- .list = lapply(.list, tt_labelrow),+ if (no_colinfo(rrow)) {
|
| 875 | -17x | +1091 | +8x |
- cinfo+ col_info(rrow) <- col_info(tbl) |
| 876 | +1092 |
- ),+ } |
||
| 877 | -17x | +|||
| 1093 | +
- name = obj_name(x),+ |
|||
| 878 | -17x | +1094 | +8x |
- lev = tt_level(x),+ if (at == 1) {
|
| 879 | -17x | +1095 | +4x |
- cinfo = cinfo,+ return(rbindl_rtables(list(rrow, tbl))) |
| 880 | -17x | +1096 | +4x |
- format = obj_format(x),+ } else if (at == nrow(tbl) + 1) {
|
| 881 | -17x | +1097 | +1x |
- var = obj_avar(x)+ return(rbind2(tbl, rrow)) |
| 882 | +1098 |
- )+ } |
||
| 883 | +1099 |
- }+ |
||
| 884 | -+ | |||
| 1100 | +3x |
- )+ ret <- recurse_insert(tbl, rrow, |
||
| 885 | -+ | |||
| 1101 | +3x |
-
+ at = at, |
||
| 886 | -+ | |||
| 1102 | +3x |
- .combine_rows <- function(x, cinfo = NULL, .list) {
+ pos = 0, |
||
| 887 | -18x | +1103 | +3x |
- stopifnot(are(.list, class(x)))+ ascontent = ascontent |
| 888 | +1104 |
-
+ ) |
||
| 889 | -18x | +1105 | +3x |
- avars <- c(obj_avar(x), unlist(lapply(.list, obj_avar), recursive = FALSE))+ ret |
| 890 | -18x | +|||
| 1106 | +
- avars <- avars[!is.na(avars)]+ } |
|||
| 891 | +1107 | |||
| 892 | -18x | -
- if (length(unique(avars)) > 1) {
- |
- ||
| 893 | -! | -
- stop("Got rows that don't analyze the same variable")
- |
- ||
| 894 | +1108 |
- }+ .insert_helper <- function(tt, row, at, pos, |
||
| 895 | +1109 |
-
+ ascontent = FALSE) {
|
||
| 896 | -18x | +1110 | +9x |
- xlst <- c(list(x), .list)+ islab <- is(row, "LabelRow") |
| 897 | -+ | |||
| 1111 | +9x |
-
+ kids <- tree_children(tt) |
||
| 898 | -18x | +1112 | +9x |
- ncols <- vapply(xlst, ncol, 1L)+ numkids <- length(kids) |
| 899 | -18x | +1113 | +9x |
- totcols <- sum(ncols)+ kidnrs <- sapply(kids, nrow) |
| 900 | -18x | +1114 | +9x |
- cumncols <- cumsum(ncols)+ cumpos <- pos + cumsum(kidnrs) |
| 901 | -18x | +1115 | +9x |
- strtncols <- c(0L, head(cumncols, -1)) + 1L+ contnr <- if (is(tt, "TableTree")) {
|
| 902 | -18x | +1116 | +6x |
- vals <- vector("list", totcols)
+ nrow(content_table(tt))+ |
+
| 1117 | ++ |
+ } else {
|
||
| 903 | -18x | +1118 | +3x |
- cspans <- integer(totcols)+ 0 |
| 904 | +1119 |
- ## vals[1:ncol(x)] <- row_values(x)+ } |
||
| 905 | -+ | |||
| 1120 | +9x |
- ## cpans[1:ncol(x)] <- row_cspans(x)+ contnr <- contnr + as.numeric(labelrow_visible(tt)) |
||
| 906 | +1121 | |||
| 907 | -18x | +1122 | +9x |
- for (i in seq_along(xlst)) {
+ totnr <- nrow(tt) |
| 908 | -37x | +1123 | +9x |
- strt <- strtncols[i]+ endpos <- pos + totnr |
| 909 | -37x | -
- end <- cumncols[i]- |
- ||
| 910 | -+ | 1124 | +9x |
- ## full vars are here for debugging purposes+ atend <- !islab && endpos == at - 1 |
| 911 | -37x | +1125 | +9x |
- fullvy <- vy <- row_cells(xlst[[i]]) # nolint+ if (at == pos + 1 && islab) {
|
| 912 | -37x | +1126 | +2x |
- fullcspy <- cspy <- row_cspans(xlst[[i]]) # nolint+ if (labelrow_visible(tt)) {
|
| 913 | -+ | |||
| 1127 | +! |
-
+ stop("Inserting a label row at a position that already has a label row is not currently supported")
|
||
| 914 | +1128 |
- if (+ } |
||
| 915 | -37x | +1129 | +2x |
- i > 1 &&+ tt_labelrow(tt) <- row |
| 916 | -37x | +1130 | +2x |
- identical(rawvalues(vy[[1]]), rawvalues(lastval)) &&+ return(tt) |
| 917 | +1131 |
- ## cspy[1] == lastspn &&+ } |
||
| 918 | -37x | +|||
| 1132 | +
- lastspn > 1+ |
|||
| 919 | -+ | |||
| 1133 | +7x |
- ) {
+ if (numkids == 0) {
|
||
| 920 | +1134 | ! |
- vy <- vy[-1]+ kids <- list(row) |
|
| 921 | -! | +|||
| 1135 | +7x |
- cspans[strt - 1L] <- lastspn + cspy[1]+ } else if (atend) {
|
||
| 922 | -! | +|||
| 1136 | +2x |
- cspy <- cspy[-1]+ if (are(kids, "TableRow")) {
|
||
| 923 | -! | +|||
| 1137 | +1x |
- strt <- strt + 1L+ kids <- c(kids, list(row)) |
||
| 924 | +1138 |
- }+ } else {
|
||
| 925 | -37x | +1139 | +1x |
- if (length(vy) > 0) {
+ kids[[numkids]] <- recurse_insert( |
| 926 | -37x | +1140 | +1x |
- vals[strt:end] <- vy+ kids[[numkids]], |
| 927 | -37x | +1141 | +1x |
- cspans[strt:end] <- cspy+ row = row, |
| 928 | -37x | +1142 | +1x |
- lastval <- vy[[length(vy)]]+ at = at, |
| 929 | -37x | +1143 | +1x |
- lastspn <- cspy[[length(cspy)]]+ pos = pos + contnr + sum(kidnrs[-numkids]), |
| 930 | -+ | |||
| 1144 | +1x |
- } else {
+ ascontent = ascontent |
||
| 931 | +1145 |
- ## lastval stays the same- |
- ||
| 932 | -! | -
- lastspn <- cspans[strtncols[i] - 1] ## already updated+ ) |
||
| 933 | +1146 |
} |
||
| 934 | +1147 |
- }+ } else { # have >0 kids
+ |
+ ||
| 1148 | +5x | +
+ kidnrs <- sapply(kids, nrow)+ |
+ ||
| 1149 | +5x | +
+ cumpos <- pos + cumsum(kidnrs) |
||
| 935 | +1150 | |||
| 936 | +1151 |
- ## Could be DataRow or ContentRow+ ## data rows go in the end of the |
||
| 937 | +1152 |
- ## This is ok because LabelRow is special cased+ ## preceding subtable (if applicable) |
||
| 938 | -18x | +|||
| 1153 | +
- constr_fun <- get(class(x), mode = "function")+ ## label rows go in the beginning of |
|||
| 939 | -18x | +|||
| 1154 | +
- constr_fun(+ ## one at at |
|||
| 940 | -18x | +1155 | +5x |
- vals = vals,+ ind <- min( |
| 941 | -18x | +1156 | +5x |
- cspan = cspans,+ which((cumpos + !islab) >= at), |
| 942 | -18x | +1157 | +5x |
- cinfo = cinfo,+ numkids |
| 943 | -18x | +|||
| 1158 | +
- var = obj_avar(x),+ ) |
|||
| 944 | -18x | +1159 | +5x |
- format = obj_format(x),+ thekid <- kids[[ind]] |
| 945 | -18x | +|||
| 1160 | +
- name = obj_name(x),+ |
|||
| 946 | -18x | +1161 | +5x |
- label = obj_label(x)+ if (is(thekid, "TableRow")) {
|
| 947 | -+ | |||
| 1162 | +! |
- )+ tt_level(row) <- tt_level(thekid) |
||
| 948 | -+ | |||
| 1163 | +! |
- }+ if (ind == 1) {
|
||
| 949 | -+ | |||
| 1164 | +! |
-
+ bef <- integer() |
||
| 950 | -+ | |||
| 1165 | +! |
- setMethod(+ aft <- 1:numkids |
||
| 951 | -+ | |||
| 1166 | +! |
- "recurse_cbindl", c(+ } else if (ind == numkids) {
|
||
| 952 | -+ | |||
| 1167 | +! |
- "TableRow",+ bef <- 1:(ind - 1) |
||
| 953 | -+ | |||
| 1168 | +! |
- "InstantiatedColumnInfo"+ aft <- ind |
||
| 954 | +1169 |
- ),+ } else {
|
||
| 955 | -+ | |||
| 1170 | +! |
- function(x, cinfo = NULL, .list) {
+ bef <- 1:ind |
||
| 956 | -18x | +|||
| 1171 | +! |
- .combine_rows(x, cinfo, .list)+ aft <- (ind + 1):numkids |
||
| 957 | +1172 |
- }+ } |
||
| 958 | -+ | |||
| 1173 | +! |
- )+ kids <- c( |
||
| 959 | -+ | |||
| 1174 | +! |
-
+ kids[bef], list(row), |
||
| 960 | -+ | |||
| 1175 | +! |
- setMethod(+ kids[aft] |
||
| 961 | +1176 |
- "recurse_cbindl", c(+ ) |
||
| 962 | +1177 |
- x = "LabelRow",+ } else { # kid is not a table row
+ |
+ ||
| 1178 | +5x | +
+ newpos <- if (ind == 1) {
+ |
+ ||
| 1179 | +4x | +
+ pos + contnr |
||
| 963 | +1180 |
- cinfo = "InstantiatedColumnInfo"+ } else {
+ |
+ ||
| 1181 | +1x | +
+ cumpos[ind - 1] |
||
| 964 | +1182 |
- ),+ } |
||
| 965 | +1183 |
- function(x, cinfo = NULL, .list) {
+
|
||
| 966 | -35x | +1184 | +5x |
- col_info(x) <- cinfo+ kids[[ind]] <- recurse_insert(thekid, |
| 967 | -35x | +1185 | +5x |
- x+ row, |
| 968 | -+ | |||
| 1186 | +5x |
- }+ at, |
||
| 969 | -+ | |||
| 1187 | +5x |
- )+ pos = newpos,+ |
+ ||
| 1188 | +5x | +
+ ascontent = ascontent |
||
| 970 | +1189 |
-
+ ) |
||
| 971 | +1190 |
- ## we don't care about the following discrepencies:+ } # end kid is not table row |
||
| 972 | +1191 |
- ## - ci2 having NA counts when ci1 doesn't+ }+ |
+ ||
| 1192 | +7x | +
+ tree_children(tt) <- kids+ |
+ ||
| 1193 | +7x | +
+ tt |
||
| 973 | +1194 |
- ## - mismatching display_ccounts values+ } |
||
| 974 | +1195 |
- ## - mismatching colcount formats+ + |
+ ||
| 1196 | +9x | +
+ setGeneric("recurse_insert", function(tt, row, at, pos, ascontent = FALSE) standardGeneric("recurse_insert"))
|
||
| 975 | +1197 |
- ##+ |
||
| 976 | +1198 |
-
+ setMethod( |
||
| 977 | +1199 |
- # chk_compat_cinfos <- function(ci1, ci2) {
+ "recurse_insert", "TableTree", |
||
| 978 | +1200 |
- chk_compat_cinfos <- function(tt1, tt2) {
+ function(tt, row, at, pos, ascontent = FALSE) {
|
||
| 979 | -41x | +1201 | +6x |
- nc1 <- ncol(tt1)+ ctab <- content_table(tt) |
| 980 | -41x | +1202 | +6x |
- nc2 <- ncol(tt2)+ contnr <- nrow(ctab) |
| 981 | -41x | +1203 | +6x |
- if (nc1 != nc2 && nc1 > 0 && nc2 > 0) {
+ contpos <- pos + contnr |
| 982 | -1x | +1204 | +6x |
- stop("Column structures contain different non-zero numbers of columns: ", nc1, ", ", nc2)
+ islab <- is(row, "LabelRow") |
| 983 | +1205 |
- }+ ## this will NOT insert it as |
||
| 984 | -40x | +1206 | +6x |
- if (no_colinfo(tt1) || no_colinfo(tt2)) {
+ if ((contnr > 0 || islab) && contpos > at) {
|
| 985 | -10x | +|||
| 1207 | +! |
- return(TRUE)+ content_table(tt) <- recurse_insert(ctab, row, at, pos, TRUE)+ |
+ ||
| 1208 | +! | +
+ return(tt) |
||
| 986 | +1209 |
- }+ }+ |
+ ||
| 1210 | ++ | + | ||
| 987 | -30x | +1211 | +6x |
- ci1 <- col_info(tt1)+ .insert_helper(tt, row, |
| 988 | -30x | +1212 | +6x |
- ci2 <- col_info(tt2)+ at = at, pos = pos + contnr, |
| 989 | -+ | |||
| 1213 | +6x |
- ## this will enforce same length and+ ascontent = ascontent |
||
| 990 | +1214 |
- ## same names, in addition to same+ ) |
||
| 991 | +1215 |
- ## expressions so we dont need+ } |
||
| 992 | +1216 |
- ## to check those separateley+ ) |
||
| 993 | -30x | +|||
| 1217 | +
- if (!identical(col_exprs(ci1), col_exprs(ci2))) {
+
|
|||
| 994 | -! | +|||
| 1218 | +
- stop("Column structures not compatible: subset expression lists not identical")
+ setMethod( |
|||
| 995 | +1219 |
- }+ "recurse_insert", "ElementaryTable", |
||
| 996 | +1220 |
-
+ function(tt, row, at, pos, ascontent = FALSE) {
|
||
| 997 | -30x | +1221 | +3x |
- if (any(!is.na(col_counts(ci2))) &&+ .insert_helper(tt, row, |
| 998 | -30x | +1222 | +3x |
- !identical(+ at = at, pos = pos, |
| 999 | -30x | +1223 | +3x |
- col_counts(ci1),+ ascontent = FALSE |
| 1000 | -30x | +|||
| 1224 | +
- col_counts(ci2)+ ) |
|||
| 1001 | +1225 |
- )) {
+ } |
||
| 1002 | -! | +|||
| 1226 | +
- stop("Column structures not compatible: 2nd column structure has non-matching, non-null column counts")
+ ) |
| 1003 | +1 |
- }+ #' Find degenerate (sub)structures within a table |
||
| 1004 | +2 |
-
+ #' |
||
| 1005 | -30x | +|||
| 3 | +
- if (any(sapply(+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 1006 | -30x | +|||
| 4 | +
- col_extra_args(ci2),+ #' |
|||
| 1007 | -30x | +|||
| 5 | +
- function(x) length(x) > 0+ #' This function returns a list with the row-paths to all structural subtables which contain no data rows (even if |
|||
| 1008 | +6 |
- )) &&+ #' they have associated content rows). |
||
| 1009 | -30x | +|||
| 7 | +
- !identical(+ #' |
|||
| 1010 | -30x | +|||
| 8 | +
- col_extra_args(ci1),+ #' @param tt (`TableTree`)\cr a `TableTree` object. |
|||
| 1011 | -30x | +|||
| 9 | +
- col_extra_args(ci2)+ #' |
|||
| 1012 | +10 |
- )) {
+ #' @return A list of character vectors representing the row paths, if any, to degenerate substructures within the table. |
||
| 1013 | -! | +|||
| 11 | +
- stop(+ #' |
|||
| 1014 | -! | +|||
| 12 | +
- "Column structures not compatible: 2nd column structure has ",+ #' @examples |
|||
| 1015 | -! | +|||
| 13 | +
- "non-matching, non-null extra args"+ #' find_degen_struct(rtable("hi"))
|
|||
| 1016 | +14 |
- )+ #' |
||
| 1017 | +15 |
- }+ #' @family table structure validation functions |
||
| 1018 | +16 |
-
+ #' @export |
||
| 1019 | -30x | +|||
| 17 | +
- if (any(nzchar(top_left(ci1))) && any(nzchar(top_left(ci2))) && !identical(top_left(ci1), top_left(ci2))) {
+ find_degen_struct <- function(tt) {
|
|||
| 1020 | -1x | +18 | +7x |
- stop(+ degen <- list() |
| 1021 | -1x | +|||
| 19 | +
- "Top-left materials not compatible: Got non-empty, non-matching ",+ |
|||
| 1022 | -1x | +20 | +7x |
- "top-left materials. Clear them using top_left(x)<-character() ",+ recurse_check <- function(tti, path) {
|
| 1023 | -1x | +21 | +103x |
- "before binding to force compatibility."+ if (is(tti, "VTableTree")) {
|
| 1024 | -+ | |||
| 22 | +103x |
- )+ kids <- tree_children(tti) |
||
| 1025 | -+ | |||
| 23 | +103x |
- }+ if (length(kids) == 0) {
|
||
| 1026 | -29x | +24 | +69x |
- TRUE+ degen <<- c(degen, list(path)) |
| 1027 | +25 |
- }+ } else {
|
||
| 1028 | -+ | |||
| 26 | +34x |
-
+ for (i in seq_along(kids)) {
|
||
| 1029 | -+ | |||
| 27 | +96x |
-
+ recurse_check(kids[[i]], path = c(path, names(kids)[i])) |
||
| 1030 | +28 |
- #' Insert `rrow`s at (before) a specific location+ } |
||
| 1031 | +29 |
- #'+ } |
||
| 1032 | +30 |
- #' `r lifecycle::badge("deprecated")`
+ } |
||
| 1033 | +31 |
- #'+ } |
||
| 1034 | -+ | |||
| 32 | +7x |
- #' This function is deprecated and will be removed in a future release of `rtables`. Please use+ recurse_check(tt, obj_name(tt) %||% "root") |
||
| 1035 | -+ | |||
| 33 | +7x |
- #' [insert_row_at_path()] or [label_at_path()] instead.+ degen |
||
| 1036 | +34 |
- #'+ } |
||
| 1037 | +35 |
- #' @param tbl (`VTableTree`)\cr a `rtable` object.+ |
||
| 1038 | +36 |
- #' @param rrow (`TableRow`)\cr an `rrow` to append to `tbl`.+ #' Validate and assert valid table structure |
||
| 1039 | +37 |
- #' @param at (`integer(1)`)\cr position into which to put the `rrow`, defaults to beginning (i.e. row 1).+ #' |
||
| 1040 | +38 |
- #' @param ascontent (`flag`)\cr currently ignored.+ #' @description `r lifecycle::badge("experimental")`
|
||
| 1041 | +39 |
#' |
||
| 1042 | +40 |
- #' @return A `TableTree` of the same specific class as `tbl`.+ #' A `TableTree` (`rtables`-built table) is considered degenerate if: |
||
| 1043 | +41 |
- #'+ #' \enumerate{
|
||
| 1044 | +42 |
- #' @note+ #' \item{It contains no subtables or data rows (content rows do not count).}
|
||
| 1045 | +43 |
- #' Label rows (i.e. a row with no data values, only a `row.name`) can only be inserted at positions which do+ #' \item{It contains a subtable which is degenerate by the criterion above.}
|
||
| 1046 | +44 |
- #' not already contain a label row when there is a non-trivial nested row structure in `tbl`.+ #' } |
||
| 1047 | +45 |
#' |
||
| 1048 | +46 |
- #' @examples+ #' `validate_table_struct` assesses whether `tt` has a valid (non-degenerate) structure. |
||
| 1049 | +47 |
- #' o <- options(warn = 0)+ #' |
||
| 1050 | +48 |
- #' lyt <- basic_table() %>%+ #' `assert_valid_table` asserts a table must have a valid structure, and throws an informative error (the default) or |
||
| 1051 | +49 |
- #' split_cols_by("Species") %>%
+ #' warning (if `warn_only` is `TRUE`) if the table is degenerate (has invalid structure or contains one or more |
||
| 1052 | +50 |
- #' analyze("Sepal.Length")
+ #' invalid substructures. |
||
| 1053 | +51 |
#' |
||
| 1054 | +52 |
- #' tbl <- build_table(lyt, iris)+ #' @param tt (`TableTree`)\cr a `TableTree` object. |
||
| 1055 | +53 |
#' |
||
| 1056 | +54 |
- #' insert_rrow(tbl, rrow("Hello World"))
+ #' @return |
||
| 1057 | +55 |
- #' insert_rrow(tbl, rrow("Hello World"), at = 2)
+ #' * `validate_table_struct` returns a logical value indicating valid structure. |
||
| 1058 | +56 |
- #'+ #' * `assert_valid_table` is called for its side-effect of throwing an error or warning for degenerate tables. |
||
| 1059 | +57 |
- #' lyt2 <- basic_table() %>%+ #' |
||
| 1060 | +58 |
- #' split_cols_by("Species") %>%
+ #' @note This function is experimental and the exact text of the warning/error is subject to change in future releases. |
||
| 1061 | +59 |
- #' split_rows_by("Species") %>%
+ #' |
||
| 1062 | +60 |
- #' analyze("Sepal.Length")
+ #' @examples |
||
| 1063 | +61 |
- #'+ #' validate_table_struct(rtable("hahaha"))
|
||
| 1064 | +62 |
- #' tbl2 <- build_table(lyt2, iris)+ #' \dontrun{
|
||
| 1065 | +63 |
- #'+ #' assert_valid_table(rtable("oops"))
|
||
| 1066 | +64 |
- #' insert_rrow(tbl2, rrow("Hello World"))
+ #' } |
||
| 1067 | +65 |
- #' insert_rrow(tbl2, rrow("Hello World"), at = 2)
+ #' |
||
| 1068 | +66 |
- #' insert_rrow(tbl2, rrow("Hello World"), at = 4)
+ #' @family table structure validation functions |
||
| 1069 | +67 |
- #'+ #' @export |
||
| 1070 | +68 |
- #' insert_rrow(tbl2, rrow("new row", 5, 6, 7))
+ validate_table_struct <- function(tt) {
|
||
| 1071 | -+ | |||
| 69 | +1x |
- #'+ degen_pths <- find_degen_struct(tt) |
||
| 1072 | -+ | |||
| 70 | +1x |
- #' insert_rrow(tbl2, rrow("new row", 5, 6, 7), at = 3)
+ length(degen_pths) == 0 |
||
| 1073 | +71 |
- #'+ } |
||
| 1074 | +72 |
- #' options(o)+ |
||
| 1075 | +73 |
- #'+ ## XXX this doesn't handle content paths correctly |
||
| 1076 | +74 |
- #' @export+ .path_to_disp <- function(pth) {
|
||
| 1077 | -+ | |||
| 75 | +4x |
- insert_rrow <- function(tbl, rrow, at = 1,+ if (length(pth) == 1) {
+ |
+ ||
| 76 | +1x | +
+ return(pth) |
||
| 1078 | +77 |
- ascontent = FALSE) {
+ } |
||
| 1079 | -9x | +78 | +3x |
- lifecycle::deprecate_warn(+ has_cont <- any(pth == "@content") |
| 1080 | -9x | +79 | +3x |
- when = "0.4.0",+ if (has_cont) {
|
| 1081 | -9x | +|||
| 80 | +! |
- what = "insert_rrow()",+ contpos <- which(pth == "@content") |
||
| 1082 | -9x | +|||
| 81 | +! |
- with = I("insert_row_at_path() or label_at_path()")
+ cont_disp <- paste(tail(pth, length(pth) - contpos + 1),+ |
+ ||
| 82 | +! | +
+ collapse = "->" |
||
| 1083 | +83 |
- )+ ) |
||
| 1084 | -9x | +|||
| 84 | +! |
- stopifnot(+ pth <- head(pth, contpos) |
||
| 1085 | -9x | +|||
| 85 | +
- is(tbl, "VTableTree"),+ } else {
|
|||
| 1086 | -9x | +86 | +3x |
- is(rrow, "TableRow"),+ cont_disp <- character() |
| 1087 | -9x | +|||
| 87 | +
- at >= 1 && at <= nrow(tbl) + 1+ } |
|||
| 1088 | +88 |
- )+ |
||
| 1089 | -9x | +89 | +3x |
- chk_compat_cinfos(tbl, rrow)+ topaste <- character(0) |
| 1090 | -8x | +90 | +3x |
- if (no_colinfo(rrow)) {
+ fullpth <- pth |
| 1091 | -8x | +91 | +3x |
- col_info(rrow) <- col_info(tbl)+ while (length(pth) > 0) {
|
| 1092 | -+ | |||
| 92 | +6x |
- }+ if (length(pth) <= 1) {
|
||
| 1093 | -+ | |||
| 93 | +! |
-
+ topaste <- c(topaste, pth) |
||
| 1094 | -8x | +|||
| 94 | +! |
- if (at == 1) {
+ pth <- character() |
||
| 1095 | -4x | +|||
| 95 | +
- return(rbindl_rtables(list(rrow, tbl)))+ } else {
|
|||
| 1096 | -4x | +96 | +6x |
- } else if (at == nrow(tbl) + 1) {
+ topaste <- c(topaste, sprintf("%s[%s]", pth[1], pth[2]))
|
| 1097 | -1x | +97 | +6x |
- return(rbind2(tbl, rrow))+ pth <- tail(pth, -2) |
| 1098 | +98 |
- }+ } |
||
| 1099 | +99 |
-
+ } |
||
| 1100 | +100 | 3x |
- ret <- recurse_insert(tbl, rrow,+ topaste <- c(topaste, cont_disp) |
|
| 1101 | +101 | 3x |
- at = at,+ paste(topaste, collapse = "->") |
|
| 1102 | -3x | +|||
| 102 | +
- pos = 0,+ } |
|||
| 1103 | -3x | +|||
| 103 | +
- ascontent = ascontent+ |
|||
| 1104 | +104 |
- )+ no_analyze_guess <- paste0( |
||
| 1105 | -3x | +|||
| 105 | +
- ret+ "Was this table created using ", |
|||
| 1106 | +106 |
- }+ "summarize_row_groups but no calls ", |
||
| 1107 | +107 |
-
+ "to analyze?\n" |
||
| 1108 | +108 |
- .insert_helper <- function(tt, row, at, pos,+ ) |
||
| 1109 | +109 |
- ascontent = FALSE) {
+
|
||
| 1110 | -9x | +|||
| 110 | +
- islab <- is(row, "LabelRow")+ use_sanitize_msg <- paste(" Use sanitize_table_struct() to fix these issues")
|
|||
| 1111 | -9x | +|||
| 111 | +
- kids <- tree_children(tt)+ |
|||
| 1112 | -9x | +|||
| 112 | +
- numkids <- length(kids)+ make_degen_message <- function(degen_pths, tt) {
|
|||
| 1113 | -9x | +113 | +2x |
- kidnrs <- sapply(kids, nrow)+ msg <- sprintf( |
| 1114 | -9x | +114 | +2x |
- cumpos <- pos + cumsum(kidnrs)+ paste0( |
| 1115 | -9x | +115 | +2x |
- contnr <- if (is(tt, "TableTree")) {
+ "Invalid table - found %d (sub)structures which contain no data rows.", |
| 1116 | -6x | +116 | +2x |
- nrow(content_table(tt))+ "\n\tThe first occured at path: %s" |
| 1117 | +117 |
- } else {
+ ), |
||
| 1118 | -3x | +118 | +2x |
- 0+ length(degen_pths), .path_to_disp(degen_pths[[1]]) |
| 1119 | +119 |
- }+ ) |
||
| 1120 | -9x | +120 | +2x |
- contnr <- contnr + as.numeric(labelrow_visible(tt))+ if (length(degen_pths) == 1 && length(degen_pths[[1]]) == 1) {
|
| 1121 | -+ | |||
| 121 | +1x |
-
+ msg <- paste(msg, " Likely Cause: Empty data or first row split on variable with only NA values", |
||
| 1122 | -9x | +122 | +1x |
- totnr <- nrow(tt)+ sep = "\n" |
| 1123 | -9x | +|||
| 123 | +
- endpos <- pos + totnr+ ) |
|||
| 1124 | -9x | +124 | +1x |
- atend <- !islab && endpos == at - 1+ } else if (all(make_row_df(tt)$node_class %in% c("LabelRow", "ContentRow"))) {
|
| 1125 | -9x | +125 | +1x |
- if (at == pos + 1 && islab) {
+ msg <- paste(msg, " Cause: Layout did not contain any analyze() calls (only summarize_row_groups())", |
| 1126 | -2x | +126 | +1x |
- if (labelrow_visible(tt)) {
+ sep = "\n" |
| 1127 | -! | +|||
| 127 | +
- stop("Inserting a label row at a position that already has a label row is not currently supported")
+ ) |
|||
| 1128 | +128 |
- }+ } |
||
| 1129 | +129 | 2x |
- tt_labelrow(tt) <- row+ msg <- paste(msg, use_sanitize_msg, sep = "\n") |
|
| 1130 | +130 | 2x |
- return(tt)+ msg |
|
| 1131 | +131 |
- }+ } |
||
| 1132 | +132 | |||
| 1133 | -7x | -
- if (numkids == 0) {
- |
- ||
| 1134 | -! | -
- kids <- list(row)- |
- ||
| 1135 | -7x | -
- } else if (atend) {
- |
- ||
| 1136 | -2x | -
- if (are(kids, "TableRow")) {
- |
- ||
| 1137 | -1x | -
- kids <- c(kids, list(row))- |
- ||
| 1138 | +133 |
- } else {
- |
- ||
| 1139 | -1x | -
- kids[[numkids]] <- recurse_insert(- |
- ||
| 1140 | -1x | -
- kids[[numkids]],- |
- ||
| 1141 | -1x | -
- row = row,- |
- ||
| 1142 | -1x | -
- at = at,- |
- ||
| 1143 | -1x | -
- pos = pos + contnr + sum(kidnrs[-numkids]),+ #' @param warn_only (`flag`)\cr whether a warning should be thrown instead of an error. Defaults to `FALSE`. |
||
| 1144 | -1x | +|||
| 134 | +
- ascontent = ascontent+ #' |
|||
| 1145 | +135 |
- )+ #' @rdname validate_table_struct |
||
| 1146 | +136 |
- }+ #' @export |
||
| 1147 | +137 |
- } else { # have >0 kids
+ assert_valid_table <- function(tt, warn_only = FALSE) {
|
||
| 1148 | -5x | +138 | +2x |
- kidnrs <- sapply(kids, nrow)+ degen_pths <- find_degen_struct(tt) |
| 1149 | -5x | -
- cumpos <- pos + cumsum(kidnrs)- |
- ||
| 1150 | -+ | 139 | +2x |
-
+ if (length(degen_pths) == 0) {
|
| 1151 | -+ | |||
| 140 | +! |
- ## data rows go in the end of the+ return(TRUE) |
||
| 1152 | +141 |
- ## preceding subtable (if applicable)+ } |
||
| 1153 | +142 |
- ## label rows go in the beginning of+ |
||
| 1154 | +143 |
- ## one at at- |
- ||
| 1155 | -5x | -
- ind <- min(- |
- ||
| 1156 | -5x | -
- which((cumpos + !islab) >= at),+ ## we failed, now we build an informative error/warning message |
||
| 1157 | -5x | +144 | +2x |
- numkids+ msg <- make_degen_message(degen_pths, tt) |
| 1158 | +145 |
- )+ |
||
| 1159 | -5x | -
- thekid <- kids[[ind]]- |
- ||
| 1160 | -+ | 146 | +2x |
-
+ if (!warn_only) {
|
| 1161 | -5x | +147 | +2x |
- if (is(thekid, "TableRow")) {
+ stop(msg) |
| 1162 | -! | +|||
| 148 | +
- tt_level(row) <- tt_level(thekid)+ } |
|||
| 1163 | +149 | ! |
- if (ind == 1) {
+ warning(msg) |
|
| 1164 | +150 | ! |
- bef <- integer()+ return(FALSE) |
|
| 1165 | -! | +|||
| 151 | +
- aft <- 1:numkids+ } |
|||
| 1166 | -! | +|||
| 152 | +
- } else if (ind == numkids) {
+
|
|||
| 1167 | -! | +|||
| 153 | +
- bef <- 1:(ind - 1)+ #' Sanitize degenerate table structures |
|||
| 1168 | -! | +|||
| 154 | +
- aft <- ind+ #' |
|||
| 1169 | +155 |
- } else {
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 1170 | -! | +|||
| 156 | +
- bef <- 1:ind+ #' |
|||
| 1171 | -! | +|||
| 157 | +
- aft <- (ind + 1):numkids+ #' Experimental function to correct structure of degenerate tables by adding messaging rows to empty sub-structures. |
|||
| 1172 | +158 |
- }+ #' |
||
| 1173 | -! | +|||
| 159 | +
- kids <- c(+ #' @param tt (`TableTree`)\cr a `TableTree` object. |
|||
| 1174 | -! | +|||
| 160 | +
- kids[bef], list(row),+ #' @param empty_msg (`string`)\cr the string which should be spanned across the inserted empty rows. |
|||
| 1175 | -! | +|||
| 161 | +
- kids[aft]+ #' |
|||
| 1176 | +162 |
- )+ #' @details |
||
| 1177 | +163 |
- } else { # kid is not a table row
+ #' This function locates degenerate portions of the table (including the table overall in the case of a table with no |
||
| 1178 | -5x | +|||
| 164 | +
- newpos <- if (ind == 1) {
+ #' data rows) and inserts a row which spans all columns with the message `empty_msg` at each one, generating a table |
|||
| 1179 | -4x | +|||
| 165 | +
- pos + contnr+ #' guaranteed to be non-degenerate. |
|||
| 1180 | +166 |
- } else {
+ #' |
||
| 1181 | -1x | +|||
| 167 | +
- cumpos[ind - 1]+ #' @return If `tt` is already valid, it is returned unmodified. If `tt` is degenerate, a modified, non-degenerate |
|||
| 1182 | +168 |
- }+ #' version of the table is returned. |
||
| 1183 | +169 |
-
+ #' |
||
| 1184 | -5x | +|||
| 170 | +
- kids[[ind]] <- recurse_insert(thekid,+ #' @examples |
|||
| 1185 | -5x | +|||
| 171 | +
- row,+ #' sanitize_table_struct(rtable("cool beans"))
|
|||
| 1186 | -5x | +|||
| 172 | +
- at,+ #' |
|||
| 1187 | -5x | +|||
| 173 | +
- pos = newpos,+ #' lyt <- basic_table() %>% |
|||
| 1188 | -5x | +|||
| 174 | +
- ascontent = ascontent+ #' split_cols_by("ARM") %>%
|
|||
| 1189 | +175 |
- )+ #' split_rows_by("SEX") %>%
|
||
| 1190 | +176 |
- } # end kid is not table row+ #' summarize_row_groups() |
||
| 1191 | +177 |
- }+ #' |
||
| 1192 | -7x | +|||
| 178 | +
- tree_children(tt) <- kids+ #' ## Degenerate because it doesn't have any analyze calls -> no data rows |
|||
| 1193 | -7x | +|||
| 179 | +
- tt+ #' badtab <- build_table(lyt, DM) |
|||
| 1194 | +180 |
- }+ #' sanitize_table_struct(badtab) |
||
| 1195 | +181 |
-
+ #' |
||
| 1196 | -9x | +|||
| 182 | +
- setGeneric("recurse_insert", function(tt, row, at, pos, ascontent = FALSE) standardGeneric("recurse_insert"))
+ #' @family table structure validation functions |
|||
| 1197 | +183 |
-
+ #' @export |
||
| 1198 | +184 |
- setMethod(+ sanitize_table_struct <- function(tt, empty_msg = "-- This Section Contains No Data --") {
|
||
| 1199 | -+ | |||
| 185 | +4x |
- "recurse_insert", "TableTree",+ rdf <- make_row_df(tt) |
||
| 1200 | +186 |
- function(tt, row, at, pos, ascontent = FALSE) {
+
|
||
| 1201 | -6x | +187 | +4x |
- ctab <- content_table(tt)+ emptyrow <- DataRow( |
| 1202 | -6x | +188 | +4x |
- contnr <- nrow(ctab)+ vals = list(empty_msg), |
| 1203 | -6x | +189 | +4x |
- contpos <- pos + contnr+ name = "empty_section", |
| 1204 | -6x | +190 | +4x |
- islab <- is(row, "LabelRow")+ label = "", |
| 1205 | -+ | |||
| 191 | +4x |
- ## this will NOT insert it as+ cspan = ncol(tt), |
||
| 1206 | -6x | +192 | +4x |
- if ((contnr > 0 || islab) && contpos > at) {
+ cinfo = col_info(tt), |
| 1207 | -! | +|||
| 193 | +4x |
- content_table(tt) <- recurse_insert(ctab, row, at, pos, TRUE)+ format = "xx", |
||
| 1208 | -! | +|||
| 194 | +4x |
- return(tt)+ table_inset = table_inset(tt) |
||
| 1209 | +195 |
- }+ )+ |
+ ||
| 196 | +4x | +
+ degen_pths <- find_degen_struct(tt) |
||
| 1210 | +197 | |||
| 1211 | -6x | +198 | +4x |
- .insert_helper(tt, row,+ if (identical(degen_pths, list("root"))) {
|
| 1212 | -6x | +199 | +2x |
- at = at, pos = pos + contnr,+ tree_children(tt) <- list(empty_row = emptyrow) |
| 1213 | -6x | -
- ascontent = ascontent- |
- ||
| 1214 | -+ | 200 | +2x |
- )+ return(tt) |
| 1215 | +201 |
} |
||
| 1216 | -- |
- )- |
- ||
| 1217 | +202 | |||
| 1218 | -- |
- setMethod(- |
- ||
| 1219 | -+ | |||
| 203 | +2x |
- "recurse_insert", "ElementaryTable",+ for (pth in degen_pths) {
|
||
| 1220 | +204 |
- function(tt, row, at, pos, ascontent = FALSE) {
+ ## FIXME this shouldn't be necessary. why is it? |
||
| 1221 | -3x | +205 | +33x |
- .insert_helper(tt, row,+ tti <- tt_at_path(tt, path = pth) |
| 1222 | -3x | +206 | +33x |
- at = at, pos = pos,+ tree_children(tti) <- list(empty_section = emptyrow) |
| 1223 | -3x | +207 | +33x |
- ascontent = FALSE+ tt_at_path(tt, path = pth) <- tti |
| 1224 | +208 |
- )+ } |
||
| 1225 | -+ | |||
| 209 | +2x |
- }+ tt |
||
| 1226 | +210 |
- )+ } |
| 1 |
- ## Split types -----------------------------------------------------------------+ # Split functions -------------------------------------------------------------- |
||
| 2 |
- ## variable: split on distinct values of a variable+ #' Split functions |
||
| 3 |
- ## all: include all observations (root 'split')+ #' |
||
| 4 |
- ## rawcut: cut on static values of a variable+ #' @description |
||
| 5 |
- ## quantilecut: cut on quantiles of observed values for a variable+ #' This is a collection of useful, default split function that can help you in dividing the data, hence the |
||
| 6 |
- ## missing: split obs based on missingness of a variable/observation. This could be used for compare to ref_group??+ #' table rows or columns, into different parts or groups (splits). You can also create your own split function if you |
||
| 7 |
- ## multicolumn: each child analyzes a different column+ #' need to create a custom division as specific as you need. Please consider reading [custom_split_funs] if |
||
| 8 |
- ## arbitrary: children are not related to each other in any systematic fashion.+ #' this is the case. Beyond this list of functions, you can also use [add_overall_level()] and [add_combo_levels()] |
||
| 9 |
-
+ #' for adding or modifying levels and [trim_levels_to_map()] to provide possible level combinations to filter the split |
||
| 10 |
- ## null is ok here.+ #' with. |
||
| 11 |
- check_ok_label <- function(lbl, multi_ok = FALSE) {
+ #' |
||
| 12 | -47904x | +
- if (length(lbl) == 0) {
+ #' @inheritParams sf_args |
|
| 13 | -10883x | +
- return(TRUE)+ #' @inheritParams gen_args |
|
| 14 |
- }+ #' @param vals (`ANY`)\cr for internal use only. |
||
| 15 |
-
+ #' @param labels (`character`)\cr labels to use for the remaining levels instead of the existing ones. |
||
| 16 | -37021x | +
- if (length(lbl) > 1) {
+ #' |
|
| 17 | -1754x | +
- if (multi_ok) {
+ #' @returns A function that can be used to split the data accordingly. The actual function signature |
|
| 18 | -1754x | +
- return(all(vapply(lbl, check_ok_label, TRUE)))+ #' is similar to the one you can define when creating a fully custom one. For more details see [custom_split_funs]. |
|
| 19 |
- }+ #' |
||
| 20 | -! | +
- stop("got a label of length > 1")
+ #' @note |
|
| 21 |
- }+ #' The following parameters are also documented here but they are only the default |
||
| 22 |
-
+ #' signature of a split function: `df` (data to be split), `spl` (split object), and `vals = NULL`, |
||
| 23 | -35267x | +
- if (grepl("([{}])", lbl)) {
+ #' `labels = NULL`, `trim = FALSE` (last three only for internal use). See [custom_split_funs] for more details |
|
| 24 | -1x | +
- stop("Labels cannot contain { or } due to their use for indicating referential footnotes")
+ #' and [make_split_fun()] for a more advanced API. |
|
| 25 |
- }+ #' |
||
| 26 | -35266x | +
- invisible(TRUE)+ #' @seealso [custom_split_funs], [add_overall_level()], [add_combo_levels()], and [trim_levels_to_map()]. |
|
| 27 |
- }+ #' |
||
| 28 |
-
+ #' @name split_funcs |
||
| 29 |
- valid_lbl_pos <- c("default", "visible", "hidden", "topleft")
+ NULL |
||
| 30 |
- .labelkids_helper <- function(charval) {
+
|
||
| 31 | -2388x | +
- ret <- switch(charval,+ # helper fncs |
|
| 32 | -2388x | +
- "default" = NA,+ .get_unique_levels <- function(vec) {
|
|
| 33 | -2388x | +82x |
- "visible" = TRUE,+ out <- if (is.factor(vec)) {
|
| 34 | -2388x | +81x |
- "hidden" = FALSE,+ levels(vec) |
| 35 | -2388x | +
- "topleft" = FALSE,+ } else {
|
|
| 36 | -2388x | +1x |
- stop(+ unique(vec) |
| 37 | -2388x | +
- "unrecognized charval in .labelkids_helper. ",+ } |
|
| 38 | -2388x | +
- "this shouldn't ever happen"+ |
|
| 39 | -+ | 82x |
- )+ out |
| 40 |
- )+ } |
||
| 41 | -2388x | +
- ret+ |
|
| 42 |
- }+ .print_setdiff_error <- function(provided, existing) {
|
||
| 43 | -+ | 3x |
-
+ paste(setdiff(provided, existing), collapse = ", ") |
| 44 |
- setOldClass("expression")
+ } |
||
| 45 |
- setClassUnion("SubsetDef", c("expression", "logical", "integer", "numeric"))
+
|
||
| 46 |
-
+ #' @describeIn split_funcs keeps only specified levels (`only`) in the split variable. If any of the specified |
||
| 47 |
- setClassUnion("integerOrNULL", c("NULL", "integer"))
+ #' levels is not present, an error is returned. `reorder = TRUE` (the default) orders the split levels |
||
| 48 |
- setClassUnion("characterOrNULL", c("NULL", "character"))
+ #' according to the order of `only`. |
||
| 49 |
-
+ #' |
||
| 50 |
- ## should XXX [splits, s_values, sval_labels, subset(?)] be a data.frame?+ #' @param only (`character`)\cr levels to retain (all others will be dropped). If none of the levels is present |
||
| 51 |
- setClass("TreePos", representation(
+ #' an empty table is returned. |
||
| 52 |
- splits = "list",+ #' @param reorder (`flag`)\cr whether the order of `only` should be used as the order of the children of the |
||
| 53 |
- s_values = "list",+ #' split. Defaults to `TRUE`. |
||
| 54 |
- sval_labels = "character",+ #' |
||
| 55 |
- subset = "SubsetDef"+ #' @examples |
||
| 56 |
- ),+ #' # keep_split_levels keeps specified levels (reorder = TRUE by default) |
||
| 57 |
- validity = function(object) {
+ #' lyt <- basic_table() %>% |
||
| 58 |
- nspl <- length(object@splits)+ #' split_rows_by("COUNTRY",
|
||
| 59 |
- length(object@s_values) == nspl && length(object@sval_labels) == nspl+ #' split_fun = keep_split_levels(c("USA", "CAN", "BRA"))
|
||
| 60 |
- }+ #' ) %>% |
||
| 61 |
- )+ #' analyze("AGE")
|
||
| 62 |
-
+ #' |
||
| 63 |
- setClassUnion("functionOrNULL", c("NULL", "function"))
+ #' tbl <- build_table(lyt, DM) |
||
| 64 |
- setClassUnion("listOrNULL", c("NULL", "list"))
+ #' tbl |
||
| 65 |
- ## TODO (?) make "list" more specific, e.g FormatList, or FunctionList?+ #' |
||
| 66 |
- setClassUnion("FormatSpec", c("NULL", "character", "function", "list"))
+ #' @export |
||
| 67 |
- setClassUnion("ExprOrNULL", c("NULL", "expression"))
+ keep_split_levels <- function(only, reorder = TRUE) {
|
||
| 68 | -+ | 46x |
-
+ function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
|
| 69 | -+ | 74x |
- setClass("ValueWrapper", representation(
+ var <- spl_payload(spl) |
| 70 | -+ | 74x |
- value = "ANY",+ varvec <- df[[var]] |
| 71 |
- label = "characterOrNULL",+ |
||
| 72 |
- subset_expression = "ExprOrNULL"+ # Unique values from the split variable |
||
| 73 | -+ | 74x |
- ),+ unique_vals <- .get_unique_levels(varvec) |
| 74 |
- contains = "VIRTUAL"+ |
||
| 75 |
- )+ # Error in case not all levels are present |
||
| 76 | -+ | 74x |
- ## heavier-weight than I'd like but I think we need+ if (!all(only %in% unique_vals)) {
|
| 77 | -+ | 2x |
- ## this to carry around thee subsets for+ stop( |
| 78 | -+ | 2x |
- ## comparison-based splits+ "Attempted to keep factor level(s) in split that are not present in data: \n", |
| 79 | -+ | 2x |
-
+ .print_setdiff_error(only, unique_vals) |
| 80 |
- setClass("SplitValue",
+ ) |
||
| 81 |
- contains = "ValueWrapper",+ } |
||
| 82 |
- representation(extra = "list")+ |
||
| 83 | -+ | 72x |
- )+ df2 <- df[varvec %in% only, ] |
| 84 | -+ | 72x |
-
+ if (reorder) {
|
| 85 | -+ | 71x |
- SplitValue <- function(val, extr = list(), label = val, sub_expr = NULL) {
+ df2[[var]] <- factor(df2[[var]], levels = only) |
| 86 | -4808x | +
- if (is(val, "SplitValue")) {
+ } else {
|
|
| 87 | -2019x | +
- if (length(splv_extra(val)) > 0) {
+ # Find original order of only |
|
| 88 | -29x | +1x |
- extr <- c(splv_extra(val), extr)+ only <- unique_vals[sort(match(only, unique_vals))] |
| 90 | -2019x | +
- splv_extra(val) <- extr+ |
|
| 91 | -2019x | +72x |
- return(val)+ spl_child_order(spl) <- only |
| 92 | -+ | 72x |
- }+ .apply_split_inner(spl, df2, |
| 93 | -2789x | +72x |
- if (!is(extr, "list")) {
+ vals = only, |
| 94 | -! | +72x |
- extr <- list(extr)+ labels = labels, |
| 95 | -+ | 72x |
- }+ trim = trim |
| 96 | -2789x | +
- if (!is(label, "character")) {
+ ) |
|
| 97 | -! | +
- label <- as.character(label)+ } |
|
| 98 |
- }+ } |
||
| 100 | -2789x | +
- if (!is.null(sub_expr) && !is.expression(sub_expr)) {
+ #' @describeIn split_funcs Removes specified levels (`excl`) from the split variable. Nothing done if not in data. |
|
| 101 | -105x | +
- sub_expr <- as.expression(sub_expr)+ #' |
|
| 102 |
- } ## sometimes they will be "call" objects, etc+ #' @param excl (`character`)\cr levels to be excluded (they will not be reflected in the resulting table structure |
||
| 103 | -2789x | +
- check_ok_label(label)+ #' regardless of presence in the data). |
|
| 104 | -2789x | +
- new("SplitValue",
+ #' |
|
| 105 | -2789x | +
- value = val,+ #' @examples |
|
| 106 | -2789x | +
- extra = extr,+ #' # remove_split_levels removes specified split levels |
|
| 107 | -2789x | +
- label = label,+ #' lyt <- basic_table() %>% |
|
| 108 | -2789x | +
- subset_expression = sub_expr+ #' split_rows_by("COUNTRY",
|
|
| 109 |
- )+ #' split_fun = remove_split_levels(c( |
||
| 110 |
- }+ #' "USA", "CAN", |
||
| 111 |
-
+ #' "CHE", "BRA" |
||
| 112 |
- setClass("LevelComboSplitValue",
+ #' )) |
||
| 113 |
- contains = "SplitValue",+ #' ) %>% |
||
| 114 |
- representation(combolevels = "character")+ #' analyze("AGE")
|
||
| 115 |
- )+ #' |
||
| 116 |
-
+ #' tbl <- build_table(lyt, DM) |
||
| 117 |
- ## wrapped in user-facing `add_combo_facet`+ #' tbl |
||
| 118 |
- LevelComboSplitValue <- function(val, extr, combolevels, label = val, sub_expr = NULL) {
+ #' |
||
| 119 | -28x | +
- check_ok_label(label)+ #' @export |
|
| 120 | -28x | +
- new("LevelComboSplitValue",
+ remove_split_levels <- function(excl) {
|
|
| 121 | 28x |
- value = val,+ stopifnot(is.character(excl)) |
|
| 122 | 28x |
- extra = extr,+ function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
|
|
| 123 | -28x | +55x |
- combolevels = combolevels,+ var <- spl_payload(spl) |
| 124 | -28x | +55x |
- label = label,+ df2 <- df[!(df[[var]] %in% excl), ] |
| 125 | -28x | +55x |
- subset_expression = sub_expr+ if (is.factor(df2[[var]])) {
|
| 126 | -+ | 2x |
- )+ levels <- levels(df2[[var]]) |
| 127 | -+ | 2x |
- }+ levels <- levels[!(levels %in% excl)] |
| 128 | -+ | 2x |
-
+ df2[[var]] <- factor(df2[[var]], levels = levels) |
| 129 |
- setClass("Split",
+ } |
||
| 130 | -+ | 55x |
- contains = "VIRTUAL",+ .apply_split_inner(spl, df2, |
| 131 | -+ | 55x |
- representation(+ vals = vals, |
| 132 | -+ | 55x |
- payload = "ANY",+ labels = labels, |
| 133 | -+ | 55x |
- name = "character",+ trim = trim |
| 134 |
- split_label = "character",+ ) |
||
| 135 |
- split_format = "FormatSpec",+ } |
||
| 136 |
- split_na_str = "character",+ } |
||
| 137 |
- split_label_position = "character",+ |
||
| 138 |
- ## NB this is the function which is applied to+ #' @describeIn split_funcs Drops levels that have no representation in the data. |
||
| 139 |
- ## get the content rows for the CHILDREN of this+ #' |
||
| 140 |
- ## split!!!+ #' @examples |
||
| 141 |
- content_fun = "listOrNULL", ## functionOrNULL",+ #' # drop_split_levels drops levels that are not present in the data |
||
| 142 |
- content_format = "FormatSpec",+ #' lyt <- basic_table() %>% |
||
| 143 |
- content_na_str = "character",+ #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
|
||
| 144 |
- content_var = "character",+ #' analyze("AGE")
|
||
| 145 |
- label_children = "logical",+ #' |
||
| 146 |
- extra_args = "list",+ #' tbl <- build_table(lyt, DM) |
||
| 147 |
- indent_modifier = "integer",+ #' tbl |
||
| 148 |
- content_indent_modifier = "integer",+ #' |
||
| 149 |
- content_extra_args = "list",+ #' @export |
||
| 150 |
- page_title_prefix = "character",+ drop_split_levels <- function(df, |
||
| 151 |
- child_section_div = "character",+ spl, |
||
| 152 |
- child_show_colcounts = "logical",+ vals = NULL, |
||
| 153 |
- child_colcount_format = "FormatSpec"+ labels = NULL, |
||
| 154 |
- )+ trim = FALSE) {
|
||
| 155 | -+ | 168x |
- )+ var <- spl_payload(spl) |
| 156 | -+ | 168x |
-
+ df2 <- df |
| 157 | -+ | 168x |
- setClass("CustomizableSplit",
+ df2[[var]] <- factor(df[[var]]) |
| 158 | -+ | 168x |
- contains = "Split",+ lblvar <- spl_label_var(spl) |
| 159 | -+ | 168x |
- representation(split_fun = "functionOrNULL")+ if (!is.null(lblvar)) {
|
| 160 | -+ | 168x |
- )+ df2[[lblvar]] <- factor(df[[lblvar]]) |
| 161 |
-
+ } |
||
| 162 |
- #' @author Gabriel Becker+ |
||
| 163 | -+ | 168x |
- #' @exportClass VarLevelSplit+ .apply_split_inner(spl, df2, |
| 164 | -+ | 168x |
- #' @rdname VarLevelSplit+ vals = vals, |
| 165 | -+ | 168x |
- setClass("VarLevelSplit",
+ labels = labels, |
| 166 | -+ | 168x |
- contains = "CustomizableSplit",+ trim = trim |
| 167 |
- representation(+ ) |
||
| 168 |
- value_label_var = "character",+ } |
||
| 169 |
- value_order = "ANY"+ |
||
| 170 |
- )+ #' @describeIn split_funcs Removes specified levels `excl` and drops all levels that are |
||
| 171 |
- )+ #' not in the data. |
||
| 172 |
- #' Split on levels within a variable+ #' |
||
| 173 |
- #'+ #' @examples |
||
| 174 |
- #' @inheritParams lyt_args+ #' # Removing "M" and "U" directly, then "UNDIFFERENTIATED" because not in data |
||
| 175 |
- #' @inheritParams constr_args+ #' lyt <- basic_table() %>% |
||
| 176 |
- #'+ #' split_rows_by("SEX", split_fun = drop_and_remove_levels(c("M", "U"))) %>%
|
||
| 177 |
- #' @return a `VarLevelSplit` object.+ #' analyze("AGE")
|
||
| 179 |
- #' @export+ #' tbl <- build_table(lyt, DM) |
||
| 180 |
- VarLevelSplit <- function(var,+ #' tbl |
||
| 181 |
- split_label,+ #' |
||
| 182 |
- labels_var = NULL,+ #' @export |
||
| 183 |
- cfun = NULL,+ drop_and_remove_levels <- function(excl) {
|
||
| 184 | -+ | 4x |
- cformat = NULL,+ stopifnot(is.character(excl)) |
| 185 | -+ | 4x |
- cna_str = NA_character_,+ function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
|
| 186 | -+ | 13x |
- split_fun = NULL,+ var <- spl_payload(spl) |
| 187 | -+ | 13x |
- split_format = NULL,+ df2 <- df[!(df[[var]] %in% excl), ] |
| 188 | -+ | 13x |
- split_na_str = NA_character_,+ df2[[var]] <- factor(df2[[var]]) |
| 189 | -+ | 13x |
- valorder = NULL,+ .apply_split_inner( |
| 190 | -+ | 13x |
- split_name = var,+ spl, |
| 191 | -+ | 13x |
- child_labels = c("default", "visible", "hidden"),
+ df2, |
| 192 | -+ | 13x |
- extra_args = list(),+ vals = vals, |
| 193 | -+ | 13x |
- indent_mod = 0L,+ labels = labels, |
| 194 | -+ | 13x |
- label_pos = c("topleft", "hidden", "visible"),
+ trim = trim |
| 195 |
- cindent_mod = 0L,+ ) |
||
| 196 |
- cvar = "",+ } |
||
| 197 |
- cextra_args = list(),+ } |
||
| 198 |
- page_prefix = NA_character_,+ |
||
| 199 |
- section_div = NA_character_,+ #' @describeIn split_funcs Reorders split levels following `neworder`, which needs to be of |
||
| 200 |
- show_colcounts = FALSE,+ #' same size as the levels in data. |
||
| 201 |
- colcount_format = NULL) {
+ #' |
||
| 202 | -519x | +
- child_labels <- match.arg(child_labels)+ #' @param neworder (`character`)\cr new order of factor levels. All need to be present in the data. |
|
| 203 | -519x | +
- if (is.null(labels_var)) {
+ #' To add empty levels, rely on pre-processing or create your [custom_split_funs]. |
|
| 204 | -1x | +
- labels_var <- var+ #' @param newlabels (`character`)\cr labels for (new order of) factor levels. If named, the levels are matched. |
|
| 205 |
- }+ #' Otherwise, the order of `neworder` is used. |
||
| 206 | -519x | +
- check_ok_label(split_label)+ #' @param drlevels (`flag`)\cr whether levels that are not in `neworder` should be dropped. |
|
| 207 | -519x | +
- new("VarLevelSplit",
+ #' Default is `TRUE`. Note: `drlevels = TRUE` does not drop levels that are not originally in the data. |
|
| 208 | -519x | +
- payload = var,+ #' Rely on pre-processing or use a combination of split functions with [make_split_fun()] to also drop |
|
| 209 | -519x | +
- split_label = split_label,+ #' unused levels. |
|
| 210 | -519x | +
- name = split_name,+ #' |
|
| 211 | -519x | +
- value_label_var = labels_var,+ #' @examples |
|
| 212 | -519x | +
- content_fun = cfun,+ #' # Reordering levels in split variable |
|
| 213 | -519x | +
- content_format = cformat,+ #' lyt <- basic_table() %>% |
|
| 214 | -519x | +
- content_na_str = cna_str,+ #' split_rows_by( |
|
| 215 | -519x | +
- split_fun = split_fun,+ #' "SEX", |
|
| 216 | -519x | +
- split_format = split_format,+ #' split_fun = reorder_split_levels( |
|
| 217 | -519x | +
- split_na_str = split_na_str,+ #' neworder = c("U", "F"),
|
|
| 218 | -519x | +
- value_order = NULL,+ #' newlabels = c(U = "Uu", `F` = "Female") |
|
| 219 | -519x | +
- label_children = .labelkids_helper(child_labels),+ #' ) |
|
| 220 | -519x | +
- extra_args = extra_args,+ #' ) %>% |
|
| 221 | -519x | +
- indent_modifier = as.integer(indent_mod),+ #' analyze("AGE")
|
|
| 222 | -519x | +
- content_indent_modifier = as.integer(cindent_mod),+ #' |
|
| 223 | -519x | +
- content_var = cvar,+ #' tbl <- build_table(lyt, DM) |
|
| 224 | -519x | +
- split_label_position = label_pos,+ #' tbl |
|
| 225 | -519x | +
- content_extra_args = cextra_args,+ #' |
|
| 226 | -519x | +
- page_title_prefix = page_prefix,+ #' # Reordering levels in split variable but keeping all the levels |
|
| 227 | -519x | +
- child_section_div = section_div,+ #' lyt <- basic_table() %>% |
|
| 228 | -519x | +
- child_show_colcounts = show_colcounts,+ #' split_rows_by( |
|
| 229 | -519x | +
- child_colcount_format = colcount_format+ #' "SEX", |
|
| 230 |
- )+ #' split_fun = reorder_split_levels( |
||
| 231 |
- }+ #' neworder = c("U", "F"),
|
||
| 232 |
-
+ #' newlabels = c("Uu", "Female"),
|
||
| 233 |
- setClass("AllSplit", contains = "Split")
+ #' drlevels = FALSE |
||
| 234 |
-
+ #' ) |
||
| 235 |
- AllSplit <- function(split_label = "",+ #' ) %>% |
||
| 236 |
- cfun = NULL,+ #' analyze("AGE")
|
||
| 237 |
- cformat = NULL,+ #' |
||
| 238 |
- cna_str = NA_character_,+ #' tbl <- build_table(lyt, DM) |
||
| 239 |
- split_format = NULL,+ #' tbl |
||
| 240 |
- split_na_str = NA_character_,+ #' |
||
| 241 |
- split_name = NULL,+ #' @export |
||
| 242 |
- extra_args = list(),+ reorder_split_levels <- function(neworder, |
||
| 243 |
- indent_mod = 0L,+ newlabels = neworder, |
||
| 244 |
- cindent_mod = 0L,+ drlevels = TRUE) {
|
||
| 245 | -+ | 8x |
- cvar = "",+ function(df, spl, trim, ...) {
|
| 246 | -+ | 8x |
- cextra_args = list(),+ df2 <- df |
| 247 | -+ | 8x |
- show_colcounts = FALSE,+ valvec <- df2[[spl_payload(spl)]] |
| 248 |
- colcount_format = NULL,+ |
||
| 249 | -+ | 8x |
- ...) {
+ uni_vals <- .get_unique_levels(valvec) |
| 250 | -213x | +
- if (is.null(split_name)) {
+
|
|
| 251 | -112x | +
- if (nzchar(split_label)) {
+ # No sense adding things that are not present -> creating unexpected NAs |
|
| 252 | -7x | +8x |
- split_name <- split_label+ if (!all(neworder %in% uni_vals)) {
|
| 253 | -+ | 1x |
- } else {
+ stop( |
| 254 | -105x | +1x |
- split_name <- "all obs"+ "Attempted to reorder factor levels in split that are not present in data:\n", |
| 255 | -+ | 1x |
- }+ .print_setdiff_error(neworder, uni_vals) |
| 256 |
- }+ ) |
||
| 257 | -213x | +
- check_ok_label(split_label)+ } |
|
| 258 | -213x | +
- new("AllSplit",
+
|
|
| 259 | -213x | +
- split_label = split_label,+ # Keeping all levels also from before if not dropped |
|
| 260 | -213x | +7x |
- content_fun = cfun,+ diff_with_uni_vals <- setdiff(uni_vals, neworder) |
| 261 | -213x | +7x |
- content_format = cformat,+ if (!drlevels && length(diff_with_uni_vals) > 0) {
|
| 262 | -213x | +3x |
- content_na_str = cna_str,+ if (length(newlabels) > length(neworder)) {
|
| 263 | -213x | +1x |
- split_format = split_format,+ stop( |
| 264 | -213x | +1x |
- split_na_str = split_na_str,+ "When keeping levels not in neworder (drlevels = FALSE), newlabels can ", |
| 265 | -213x | +1x |
- name = split_name,+ "affect only selected neworder, and not other levels.\n", |
| 266 | -213x | +1x |
- label_children = FALSE,+ "Add labels for current neworder: ", paste0(neworder, collapse = ", ") |
| 267 | -213x | +
- extra_args = extra_args,+ ) |
|
| 268 | -213x | +
- indent_modifier = as.integer(indent_mod),+ } |
|
| 269 | -213x | +2x |
- content_indent_modifier = as.integer(cindent_mod),+ neworder <- c(neworder, diff_with_uni_vals) |
| 270 | -213x | +2x |
- content_var = cvar,+ if (is.null(names(newlabels))) {
|
| 271 | -213x | +! |
- split_label_position = "hidden",+ newlabels <- c(newlabels, diff_with_uni_vals) |
| 272 | -213x | +
- content_extra_args = cextra_args,+ } else {
|
|
| 273 | -213x | +2x |
- page_title_prefix = NA_character_,+ newlabels <- c(newlabels, setNames(diff_with_uni_vals, diff_with_uni_vals)) |
| 274 | -213x | +
- child_section_div = NA_character_,+ } |
|
| 275 | -213x | +
- child_show_colcounts = show_colcounts,+ } |
|
| 276 | -213x | +
- child_colcount_format = colcount_format+ |
|
| 277 | -+ | 6x |
- )+ valvec <- factor(valvec, levels = neworder) |
| 278 |
- }+ |
||
| 279 |
-
+ # Labels |
||
| 280 | -+ | 6x |
- setClass("RootSplit", contains = "AllSplit")
+ if (!is.null(names(newlabels))) {
|
| 281 | -+ | 5x |
-
+ if (any(!names(newlabels) %in% neworder)) {
|
| 282 | -+ | 2x |
- RootSplit <- function(split_label = "", cfun = NULL, cformat = NULL, cna_str = NA_character_, cvar = "",+ stop( |
| 283 | -+ | 2x |
- split_format = NULL, split_na_str = NA_character_, cextra_args = list(), ...) {
+ "Got labels' names for levels that are not present:\n", |
| 284 | -654x | +2x |
- check_ok_label(split_label)+ setdiff(names(newlabels), neworder) |
| 285 | -654x | +
- new("RootSplit",
+ ) |
|
| 286 | -654x | +
- split_label = split_label,+ } |
|
| 287 | -654x | +
- content_fun = cfun,+ # To be safe: sorting by neworder |
|
| 288 | -654x | +3x |
- content_format = cformat,+ newlabels <- newlabels[sapply(names(newlabels), function(x) which(x == neworder))] |
| 289 | -654x | +1x |
- content_na_str = cna_str,+ } else if (length(neworder) != length(newlabels)) {
|
| 290 | -654x | +1x |
- split_format = split_format,+ stop( |
| 291 | -654x | +1x |
- split_na_str = split_na_str,+ "Got unnamed newlabels with different length than neworder. ", |
| 292 | -654x | +1x |
- name = "root",+ "Please provide names or make sure they are of the same length.\n", |
| 293 | -654x | +1x |
- label_children = FALSE,+ "Current neworder: ", paste0(neworder, collapse = ", ") |
| 294 | -654x | +
- indent_modifier = 0L,+ ) |
|
| 295 | -654x | +
- content_indent_modifier = 0L,+ } |
|
| 296 | -654x | +
- content_var = cvar,+ |
|
| 297 | -654x | +
- split_label_position = "hidden",+ # Final values |
|
| 298 | -654x | +3x |
- content_extra_args = cextra_args,+ spl_child_order(spl) <- neworder |
| 299 | -654x | +3x |
- child_section_div = NA_character_,+ df2[[spl_payload(spl)]] <- valvec |
| 300 | -654x | +3x |
- child_show_colcounts = FALSE,+ .apply_split_inner(spl, df2, |
| 301 | -654x | +3x |
- child_colcount_format = "(N=xx)"+ vals = neworder, |
| 302 | -+ | 3x |
- )+ labels = newlabels, |
| 303 | -+ | 3x |
- }+ trim = trim |
| 304 |
-
+ ) |
||
| 305 |
- setClass("ManualSplit",
+ } |
||
| 306 |
- contains = "AllSplit",+ } |
||
| 307 |
- representation(levels = "character")+ |
||
| 308 |
- )+ #' @describeIn split_funcs Takes the split groups and removes levels of `innervar` if not present in |
||
| 309 |
-
+ #' those split groups. If you want to specify a filter of possible combinations, please |
||
| 310 |
- #' Manually defined split+ #' consider using [trim_levels_to_map()]. |
||
| 312 |
- #' @inheritParams lyt_args+ #' @param innervar (`string`)\cr variable whose factor levels should be trimmed (e.g. empty levels dropped) |
||
| 313 |
- #' @inheritParams constr_args+ #' *separately within each grouping defined at this point in the structure*. |
||
| 314 |
- #' @inheritParams gen_args+ #' @param drop_outlevs (`flag`)\cr whether empty levels in the variable being split on (i.e. the "outer" |
||
| 315 |
- #' @param levels (`character`)\cr levels of the split (i.e. the children of the manual split).+ #' variable, not `innervar`) should be dropped. Defaults to `TRUE`. |
||
| 317 |
- #' @return A `ManualSplit` object.+ #' @examples |
||
| 318 |
- #'+ #' # trim_levels_in_group() trims levels within each group defined by the split variable |
||
| 319 |
- #' @author Gabriel Becker+ #' dat <- data.frame( |
||
| 320 |
- #' @export+ #' col1 = factor(c("A", "B", "C"), levels = c("A", "B", "C", "N")),
|
||
| 321 |
- ManualSplit <- function(levels, label, name = "manual",+ #' col2 = factor(c("a", "b", "c"), levels = c("a", "b", "c", "x"))
|
||
| 322 |
- extra_args = list(),+ #' ) # N is removed if drop_outlevs = TRUE, x is removed always |
||
| 323 |
- indent_mod = 0L,+ #' |
||
| 324 |
- cindent_mod = 0L,+ #' tbl <- basic_table() %>% |
||
| 325 |
- cvar = "",+ #' split_rows_by("col1", split_fun = trim_levels_in_group("col2")) %>%
|
||
| 326 |
- cextra_args = list(),+ #' analyze("col2") %>%
|
||
| 327 |
- label_pos = "visible",+ #' build_table(dat) |
||
| 328 |
- page_prefix = NA_character_,+ #' tbl |
||
| 329 |
- section_div = NA_character_) {
+ #' |
||
| 330 | -48x | +
- label_pos <- match.arg(label_pos, label_pos_values)+ #' @export |
|
| 331 | -48x | +
- check_ok_label(label, multi_ok = TRUE)+ trim_levels_in_group <- function(innervar, drop_outlevs = TRUE) {
|
|
| 332 | -48x | +6x |
- new("ManualSplit",
+ myfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
|
| 333 | -48x | +6x |
- split_label = label,+ if (!drop_outlevs) {
|
| 334 | -48x | +! |
- levels = levels,+ ret <- .apply_split_inner(spl, df, |
| 335 | -48x | +! |
- name = name,+ vals = vals, |
| 336 | -48x | +! |
- label_children = FALSE,+ labels = labels, trim = trim |
| 337 | -48x | +
- extra_args = extra_args,+ ) |
|
| 338 | -48x | +
- indent_modifier = 0L,+ } else {
|
|
| 339 | -48x | +6x |
- content_indent_modifier = as.integer(cindent_mod),+ ret <- drop_split_levels( |
| 340 | -48x | +6x |
- content_var = cvar,+ df = df, spl = spl, vals = vals, |
| 341 | -48x | +6x |
- split_format = NULL,+ labels = labels, trim = trim |
| 342 | -48x | +
- split_na_str = NA_character_,+ ) |
|
| 343 | -48x | +
- split_label_position = label_pos,+ } |
|
| 344 | -48x | +
- page_title_prefix = page_prefix,+ |
|
| 345 | -48x | +6x |
- child_section_div = section_div,+ ret$datasplit <- lapply(ret$datasplit, function(x) {
|
| 346 | -48x | +14x |
- child_show_colcounts = FALSE,+ coldat <- x[[innervar]] |
| 347 | -48x | +14x |
- child_colcount_format = "(N=xx)"+ if (is(coldat, "character")) {
|
| 348 | -+ | ! |
- )+ if (!is.null(vals)) {
|
| 349 | -+ | ! |
- }+ lvs <- vals |
| 350 |
-
+ } else {
|
||
| 351 | -+ | ! |
- ## splits across which variables are being analynzed+ lvs <- unique(coldat) |
| 352 |
- setClass("MultiVarSplit",
+ } |
||
| 353 | -+ | ! |
- contains = "CustomizableSplit", ## "Split",+ coldat <- factor(coldat, levels = lvs) ## otherwise |
| 354 |
- representation(+ } else {
|
||
| 355 | -+ | 14x |
- var_labels = "character",+ coldat <- droplevels(coldat) |
| 356 |
- var_names = "character"+ } |
||
| 357 | -+ | 14x |
- ),+ x[[innervar]] <- coldat |
| 358 | -+ | 14x |
- validity = function(object) {
+ x |
| 359 |
- length(object@payload) >= 1 &&+ }) |
||
| 360 | -+ | 6x |
- all(!is.na(object@payload)) &&+ ret$labels <- as.character(ret$labels) # TODO |
| 361 | -+ | 6x |
- (length(object@var_labels) == 0 || length(object@payload) == length(object@var_labels))+ ret |
| 363 | -+ | 6x |
- )+ myfun |
| 364 |
-
+ } |
||
| 365 |
- .make_suffix_vec <- function(n) {
+
|
||
| 366 | -3x | +
- c(+ # add_combo_levels ------------------------------------------------------------- |
|
| 367 |
- "",+ # Dedicated docs are attached to default split functions |
||
| 368 | -3x | +
- sprintf(+ .add_combo_part_info <- function(part, |
|
| 369 | -3x | +
- "._[[%d]]_.",+ df, |
|
| 370 | -3x | +
- seq_len(n - 1) + 1L+ valuename, |
|
| 371 |
- )+ levels, |
||
| 372 |
- )+ label, |
||
| 373 |
- }+ extras, |
||
| 374 |
-
+ first = TRUE) {
|
||
| 375 | -+ | 24x |
- .make_multivar_names <- function(vars) {
+ value <- LevelComboSplitValue(valuename, extras, |
| 376 | -29x | +24x |
- dups <- duplicated(vars)+ combolevels = levels, |
| 377 | -29x | +24x |
- if (!any(dups)) {
+ label = label |
| 378 | -26x | +
- return(vars)+ ) |
|
| 379 | -+ | 24x |
- }+ newdat <- setNames(list(df), valuename) |
| 380 | -3x | +24x |
- dupvars <- unique(vars[dups])+ newval <- setNames(list(value), valuename) |
| 381 | -3x | +24x |
- ret <- vars+ newextra <- setNames(list(extras), valuename) |
| 382 | -3x | +24x |
- for (v in dupvars) {
+ if (first) {
|
| 383 | -3x | +6x |
- pos <- which(ret == v)+ part$datasplit <- c(newdat, part$datasplit) |
| 384 | -3x | +6x |
- ret[pos] <- paste0(+ part$values <- c(newval, part$values) |
| 385 | -3x | +6x |
- ret[pos],+ part$labels <- c(setNames(label, valuename), part$labels) |
| 386 | -3x | +6x |
- .make_suffix_vec(length(pos))+ part$extras <- c(newextra, part$extras) |
| 387 |
- )+ } else {
|
||
| 388 | -+ | 18x |
- }+ part$datasplit <- c(part$datasplit, newdat) |
| 389 | -3x | +18x |
- ret+ part$values <- c(part$values, newval) |
| 390 | -+ | 18x |
- }+ part$labels <- c(part$labels, setNames(label, valuename)) |
| 391 | -+ | 18x |
-
+ part$extras <- c(part$extras, newextra) |
| 392 |
- #' Split between two or more different variables+ } |
||
| 393 |
- #'+ ## not needed even in custom split function case. |
||
| 394 |
- #' @inheritParams lyt_args+ ## part = .fixupvals(part) |
||
| 395 | -+ | 24x |
- #' @inheritParams constr_args+ part |
| 396 |
- #'+ } |
||
| 397 |
- #' @return A `MultiVarSplit` object.+ |
||
| 398 |
- #'+ #' Add overall or combination levels to split groups |
||
| 399 |
- #' @author Gabriel Becker+ #' |
||
| 400 |
- #' @export+ #' @description |
||
| 401 |
- MultiVarSplit <- function(vars,+ #' `add_overall_level` is a split function that adds a global level to the current levels in the split. Similarly, |
||
| 402 |
- split_label = "",+ #' `add_combo_df` uses a user-provided `data.frame` to define the combine the levels to be added. If you need a |
||
| 403 |
- varlabels = NULL,+ #' single overall column, after all splits, please check [add_overall_col()]. Consider also defining |
||
| 404 |
- varnames = NULL,+ #' your custom split function if you need more flexibility (see [custom_split_funs]). |
||
| 405 |
- cfun = NULL,+ #' |
||
| 406 |
- cformat = NULL,+ #' @inheritParams lyt_args |
||
| 407 |
- cna_str = NA_character_,+ #' @inheritParams sf_args |
||
| 408 |
- split_format = NULL,+ #' @param valname (`string`)\cr value to be assigned to the implicit all-observations split level. Defaults to |
||
| 409 |
- split_na_str = NA_character_,+ #' `"Overall"`. |
||
| 410 |
- split_name = "multivars",+ #' @param first (`flag`)\cr whether the implicit level should appear first (`TRUE`) or last (`FALSE`). Defaults |
||
| 411 |
- child_labels = c("default", "visible", "hidden"),
+ #' to `TRUE`. |
||
| 412 |
- extra_args = list(),+ #' |
||
| 413 |
- indent_mod = 0L,+ #' @return A splitting function (`splfun`) that adds or changes the levels of a split. |
||
| 414 |
- cindent_mod = 0L,+ #' |
||
| 415 |
- cvar = "",+ #' @seealso [custom_split_funs] and [split_funcs]. |
||
| 416 |
- cextra_args = list(),+ #' |
||
| 417 |
- label_pos = "visible",+ #' @examples |
||
| 418 |
- split_fun = NULL,+ #' lyt <- basic_table() %>% |
||
| 419 |
- page_prefix = NA_character_,+ #' split_cols_by("ARM", split_fun = add_overall_level("All Patients",
|
||
| 420 |
- section_div = NA_character_,+ #' first = FALSE |
||
| 421 |
- show_colcounts = FALSE,+ #' )) %>% |
||
| 422 |
- colcount_format = NULL) {
+ #' analyze("AGE")
|
||
| 423 | -29x | +
- check_ok_label(split_label)+ #' |
|
| 424 |
- ## no topleft allowed+ #' tbl <- build_table(lyt, DM) |
||
| 425 | -29x | +
- label_pos <- match.arg(label_pos, label_pos_values[-3])+ #' tbl |
|
| 426 | -29x | +
- child_labels <- match.arg(child_labels)+ #' |
|
| 427 | -29x | +
- if (length(vars) == 1 && grepl(":", vars)) {
+ #' lyt2 <- basic_table() %>% |
|
| 428 | -! | +
- vars <- strsplit(vars, ":")[[1]]+ #' split_cols_by("ARM") %>%
|
|
| 429 |
- }+ #' split_rows_by("RACE",
|
||
| 430 | -29x | +
- if (length(varlabels) == 0) { ## covers NULL and character()
+ #' split_fun = add_overall_level("All Ethnicities")
|
|
| 431 | -1x | +
- varlabels <- vars+ #' ) %>% |
|
| 432 |
- }+ #' summarize_row_groups(label_fstr = "%s (n)") %>% |
||
| 433 | -29x | +
- vnames <- varnames %||% .make_multivar_names(vars)+ #' analyze("AGE")
|
|
| 434 | -29x | +
- stopifnot(length(vnames) == length(vars))+ #' lyt2 |
|
| 435 | -29x | +
- new("MultiVarSplit",
+ #' |
|
| 436 | -29x | +
- payload = vars,+ #' tbl2 <- build_table(lyt2, DM) |
|
| 437 | -29x | +
- split_label = split_label,+ #' tbl2 |
|
| 438 | -29x | +
- var_labels = varlabels,+ #' |
|
| 439 | -29x | +
- var_names = vnames,+ #' @export |
|
| 440 | -29x | +
- content_fun = cfun,+ add_overall_level <- function(valname = "Overall", |
|
| 441 | -29x | +
- content_format = cformat,+ label = valname, |
|
| 442 | -29x | +
- content_na_str = cna_str,+ extra_args = list(), |
|
| 443 | -29x | +
- split_format = split_format,+ first = TRUE, |
|
| 444 | -29x | +
- split_na_str = split_na_str,+ trim = FALSE) {
|
|
| 445 | -29x | +6x |
- label_children = .labelkids_helper(child_labels),+ combodf <- data.frame( |
| 446 | -29x | +6x |
- name = split_name,+ valname = valname, |
| 447 | -29x | +6x |
- extra_args = extra_args,+ label = label, |
| 448 | -29x | +6x |
- indent_modifier = as.integer(indent_mod),+ levelcombo = I(list(select_all_levels)), |
| 449 | -29x | +6x |
- content_indent_modifier = as.integer(cindent_mod),+ exargs = I(list(extra_args)), |
| 450 | -29x | +6x |
- content_var = cvar,+ stringsAsFactors = FALSE |
| 451 | -29x | +
- split_label_position = label_pos,+ ) |
|
| 452 | -29x | +6x |
- content_extra_args = cextra_args,+ add_combo_levels(combodf, |
| 453 | -29x | +6x |
- split_fun = split_fun,+ trim = trim, first = first |
| 454 | -29x | +
- page_title_prefix = page_prefix,+ ) |
|
| 455 | -29x | +
- child_section_div = section_div,+ } |
|
| 456 | -29x | +
- child_show_colcounts = show_colcounts,+ |
|
| 457 | -29x | +
- child_colcount_format = colcount_format+ setClass("AllLevelsSentinel", contains = "character")
|
|
| 458 |
- )+ |
||
| 459 |
- }+ # nocov start |
||
| 460 |
-
+ #' @rdname add_overall_level |
||
| 461 |
- #' Splits for cutting by values of a numeric variable+ #' @export |
||
| 462 |
- #'+ select_all_levels <- new("AllLevelsSentinel")
|
||
| 463 |
- #' @inheritParams lyt_args+ # nocov end |
||
| 464 |
- #' @inheritParams constr_args+ |
||
| 465 |
- #'+ #' @param combosdf (`data.frame` or `tbl_df`)\cr a data frame with columns `valname`, `label`, `levelcombo`, and |
||
| 466 |
- #' @exportClass VarStaticCutSplit+ #' `exargs`. `levelcombo` and `exargs` should be list columns. Passing the `select_all_levels` object as a value in |
||
| 467 |
- #' @rdname cutsplits+ #' `comblevels` column indicates that an overall/all-observations level should be created. |
||
| 468 |
- setClass("VarStaticCutSplit",
+ #' @param keep_levels (`character` or `NULL`)\cr if non-`NULL`, the levels to retain across both combination and |
||
| 469 |
- contains = "Split",+ #' individual levels. |
||
| 470 |
- representation(+ #' |
||
| 471 |
- cuts = "numeric",+ #' @inherit add_overall_level return |
||
| 472 |
- cut_labels = "character"+ #' |
||
| 473 |
- )+ #' @note |
||
| 474 |
- )+ #' Analysis or summary functions for which the order matters should never be used within the tabulation framework. |
||
| 475 |
-
+ #' |
||
| 476 |
- .is_cut_lab_lst <- function(cuts) {
+ #' @examplesIf require(tibble) |
||
| 477 | -12x | +
- is.list(cuts) && is.numeric(cuts[[1]]) &&+ #' |
|
| 478 | -12x | +
- is.character(cuts[[2]]) &&+ #' library(tibble) |
|
| 479 | -12x | +
- length(cuts[[1]]) == length(cuts[[2]])+ #' combodf <- tribble( |
|
| 480 |
- }+ #' ~valname, ~label, ~levelcombo, ~exargs, |
||
| 481 |
-
+ #' "A_B", "Arms A+B", c("A: Drug X", "B: Placebo"), list(),
|
||
| 482 |
- #' Create static cut or static cumulative cut split+ #' "A_C", "Arms A+C", c("A: Drug X", "C: Combination"), list()
|
||
| 483 |
- #'+ #' ) |
||
| 484 |
- #' @inheritParams lyt_args+ #' |
||
| 485 |
- #' @inheritParams constr_args+ #' lyt <- basic_table(show_colcounts = TRUE) %>% |
||
| 486 |
- #'+ #' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
|
||
| 487 |
- #' @return A `VarStaticCutSplit`, `CumulativeCutSplit` object for `make_static_cut_split`, or a `VarDynCutSplit`+ #' analyze("AGE")
|
||
| 488 |
- #' object for [VarDynCutSplit()].+ #' |
||
| 489 |
- #'+ #' tbl <- build_table(lyt, DM) |
||
| 490 |
- #' @rdname cutsplits+ #' tbl |
||
| 491 |
- make_static_cut_split <- function(var,+ #' |
||
| 492 |
- split_label,+ #' lyt1 <- basic_table(show_colcounts = TRUE) %>% |
||
| 493 |
- cuts,+ #' split_cols_by("ARM",
|
||
| 494 |
- cutlabels = NULL,+ #' split_fun = add_combo_levels(combodf, |
||
| 495 |
- cfun = NULL,+ #' keep_levels = c( |
||
| 496 |
- cformat = NULL,+ #' "A_B", |
||
| 497 |
- cna_str = NA_character_,+ #' "A_C" |
||
| 498 |
- split_format = NULL,+ #' ) |
||
| 499 |
- split_na_str = NA_character_,+ #' ) |
||
| 500 |
- split_name = var,+ #' ) %>% |
||
| 501 |
- child_labels = c("default", "visible", "hidden"),
+ #' analyze("AGE")
|
||
| 502 |
- extra_args = list(),+ #' |
||
| 503 |
- indent_mod = 0L,+ #' tbl1 <- build_table(lyt1, DM) |
||
| 504 |
- cindent_mod = 0L,+ #' tbl1 |
||
| 505 |
- cvar = "",+ #' |
||
| 506 |
- cextra_args = list(),+ #' smallerDM <- droplevels(subset(DM, SEX %in% c("M", "F") &
|
||
| 507 |
- label_pos = "visible",+ #' grepl("^(A|B)", ARM)))
|
||
| 508 |
- cumulative = FALSE,+ #' lyt2 <- basic_table(show_colcounts = TRUE) %>% |
||
| 509 |
- page_prefix = NA_character_,+ #' split_cols_by("ARM", split_fun = add_combo_levels(combodf[1, ])) %>%
|
||
| 510 |
- section_div = NA_character_,+ #' split_cols_by("SEX",
|
||
| 511 |
- show_colcounts = FALSE,+ #' split_fun = add_overall_level("SEX_ALL", "All Genders")
|
||
| 512 |
- colcount_format = NULL) {
+ #' ) %>% |
||
| 513 | -12x | +
- cls <- if (cumulative) "CumulativeCutSplit" else "VarStaticCutSplit"+ #' analyze("AGE")
|
|
| 514 | -12x | +
- check_ok_label(split_label)+ #' |
|
| 515 |
-
+ #' lyt3 <- basic_table(show_colcounts = TRUE) %>% |
||
| 516 | -12x | +
- label_pos <- match.arg(label_pos, label_pos_values)+ #' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
|
|
| 517 | -12x | +
- child_labels <- match.arg(child_labels)+ #' split_rows_by("SEX",
|
|
| 518 | -12x | +
- if (.is_cut_lab_lst(cuts)) {
+ #' split_fun = add_overall_level("SEX_ALL", "All Genders")
|
|
| 519 | -! | +
- cutlabels <- cuts[[2]]+ #' ) %>% |
|
| 520 | -! | +
- cuts <- cuts[[1]]+ #' summarize_row_groups() %>% |
|
| 521 |
- }+ #' analyze("AGE")
|
||
| 522 | -12x | +
- if (is.unsorted(cuts, strictly = TRUE)) {
+ #' |
|
| 523 | -! | +
- stop("invalid cuts vector. not sorted unique values.")
+ #' tbl3 <- build_table(lyt3, smallerDM) |
|
| 524 |
- }+ #' tbl3 |
||
| 525 |
-
+ #' |
||
| 526 | -12x | +
- if (is.null(cutlabels) && !is.null(names(cuts))) {
+ #' @rdname add_overall_level |
|
| 527 | -1x | +
- cutlabels <- names(cuts)[-1]+ #' @export |
|
| 528 |
- } ## XXX is this always right?+ add_combo_levels <- function(combosdf, |
||
| 529 |
-
+ trim = FALSE, |
||
| 530 | -12x | +
- new(cls,+ first = FALSE, |
|
| 531 | -12x | +
- payload = var,+ keep_levels = NULL) {
|
|
| 532 | -12x | +14x |
- split_label = split_label,+ myfun <- function(df, spl, vals = NULL, labels = NULL, ...) {
|
| 533 | -12x | +19x |
- cuts = cuts,+ if (is(spl, "MultiVarSplit")) {
|
| 534 | -12x | +1x |
- cut_labels = cutlabels,+ stop("Combining levels of a MultiVarSplit does not make sense.",
|
| 535 | -12x | +1x |
- content_fun = cfun,+ call. = FALSE |
| 536 | -12x | +
- content_format = cformat,+ ) |
|
| 537 | -12x | +14x |
- content_na_str = cna_str,+ } # nocov |
| 538 | -12x | +18x |
- split_format = split_format,+ ret <- .apply_split_inner(spl, df, |
| 539 | -12x | +18x |
- split_na_str = split_na_str,+ vals = vals, |
| 540 | -12x | +18x |
- name = split_name,+ labels = labels, trim = trim |
| 541 | -12x | +
- label_children = .labelkids_helper(child_labels),+ ) |
|
| 542 | -12x | +18x |
- extra_args = extra_args,+ for (i in seq_len(nrow(combosdf))) {
|
| 543 | -12x | +24x |
- indent_modifier = as.integer(indent_mod),+ lcombo <- combosdf[i, "levelcombo", drop = TRUE][[1]] |
| 544 | -12x | +24x |
- content_indent_modifier = as.integer(cindent_mod),+ spld <- spl_payload(spl) |
| 545 | -12x | +24x |
- content_var = cvar,+ if (is(lcombo, "AllLevelsSentinel")) {
|
| 546 | -12x | +6x |
- split_label_position = label_pos,+ subdf <- df |
| 547 | -12x | +18x |
- content_extra_args = cextra_args,+ } else if (is(spl, "VarLevelSplit")) {
|
| 548 | -12x | +18x |
- page_title_prefix = page_prefix,+ subdf <- df[df[[spld]] %in% lcombo, ] |
| 549 | -12x | +14x |
- child_section_div = section_div,+ } else { ## this covers non-var splits, e.g. Cut-based splits
|
| 550 | -12x | +! |
- child_show_colcounts = show_colcounts,+ stopifnot(all(lcombo %in% c(ret$labels, ret$vals))) |
| 551 | -12x | +! |
- child_colcount_format = colcount_format+ subdf <- do.call( |
| 552 | -+ | ! |
- )+ rbind, |
| 553 | -+ | ! |
- }+ ret$datasplit[names(ret$datasplit) %in% lcombo | ret$vals %in% lcombo] |
| 554 |
-
+ ) |
||
| 555 |
- #' @exportClass CumulativeCutSplit+ } |
||
| 556 | -+ | 24x |
- #' @rdname cutsplits+ ret <- .add_combo_part_info( |
| 557 | -+ | 24x |
- setClass("CumulativeCutSplit", contains = "VarStaticCutSplit")
+ ret, subdf, |
| 558 | -+ | 24x |
-
+ combosdf[i, "valname", drop = TRUE], |
| 559 | -+ | 24x |
- ## make_static_cut_split with cumulative=TRUE is the constructor+ lcombo, |
| 560 | -+ | 24x |
- ## for CumulativeCutSplit+ combosdf[i, "label", drop = TRUE], |
| 561 | -+ | 24x |
-
+ combosdf[i, "exargs", drop = TRUE][[1]], |
| 562 | -+ | 24x |
- ## do we want this to be a CustomizableSplit instead of+ first |
| 563 |
- ## taking cut_fun?+ ) |
||
| 564 |
- ## cut_funct must take avector and no other arguments+ } |
||
| 565 | -+ | 18x |
- ## and return a named vector of cut points+ if (!is.null(keep_levels)) {
|
| 566 | -+ | 3x |
- #' @exportClass VarDynCutSplit+ keep_inds <- value_names(ret$values) %in% keep_levels |
| 567 | -+ | 3x |
- #' @rdname cutsplits+ ret <- lapply(ret, function(x) x[keep_inds]) |
| 568 |
- setClass("VarDynCutSplit",
+ } |
||
| 569 |
- contains = "Split",+ |
||
| 570 | -+ | 18x |
- representation(+ ret |
| 571 |
- cut_fun = "function",+ } |
||
| 572 | -+ | 14x |
- cut_label_fun = "function",+ myfun |
| 573 |
- cumulative_cuts = "logical"+ } |
||
| 574 |
- )+ |
||
| 575 |
- )+ #' Trim levels to map |
||
| 576 |
-
+ #' |
||
| 577 |
- #' @export+ #' This split function constructor creates a split function which trims levels of a variable to reflect restrictions |
||
| 578 |
- #' @rdname cutsplits+ #' on the possible combinations of two or more variables which the data is split by (along the same axis) within a |
||
| 579 |
- VarDynCutSplit <- function(var,+ #' layout. |
||
| 580 |
- split_label,+ #' |
||
| 581 |
- cutfun,+ #' @param map data.frame. A data.frame defining allowed combinations of |
||
| 582 |
- cutlabelfun = function(x) NULL,+ #' variables. Any combination at the level of this split not present in the |
||
| 583 |
- cfun = NULL,+ #' map will be removed from the data, both for the variable being split and |
||
| 584 |
- cformat = NULL,+ #' those present in the data but not associated with this split or any parents |
||
| 585 |
- cna_str = NA_character_,+ #' of it. |
||
| 586 |
- split_format = NULL,+ #' |
||
| 587 |
- split_na_str = NA_character_,+ #' @details |
||
| 588 |
- split_name = var,+ #' When splitting occurs, the map is subset to the values of all previously performed splits. The levels of the |
||
| 589 |
- child_labels = c("default", "visible", "hidden"),
+ #' variable being split are then pruned to only those still present within this subset of the map representing the |
||
| 590 |
- extra_args = list(),+ #' current hierarchical splitting context. |
||
| 591 |
- cumulative = FALSE,+ #' |
||
| 592 |
- indent_mod = 0L,+ #' Splitting is then performed via the [keep_split_levels()] split function. |
||
| 593 |
- cindent_mod = 0L,+ #' |
||
| 594 |
- cvar = "",+ #' Each resulting element of the partition is then further trimmed by pruning values of any remaining variables |
||
| 595 |
- cextra_args = list(),+ #' specified in the map to those values allowed under the combination of the previous and current split. |
||
| 596 |
- label_pos = "visible",+ #' |
||
| 597 |
- page_prefix = NA_character_,+ #' @return A function that can be used as a split function. |
||
| 598 |
- section_div = NA_character_,+ #' |
||
| 599 |
- show_colcounts = FALSE,+ #' @seealso [trim_levels_in_group()]. |
||
| 600 |
- colcount_format = NULL) {
+ #' |
||
| 601 | -6x | +
- check_ok_label(split_label)+ #' @examples |
|
| 602 | -6x | +
- label_pos <- match.arg(label_pos, label_pos_values)+ #' map <- data.frame( |
|
| 603 | -6x | +
- child_labels <- match.arg(child_labels)+ #' LBCAT = c("CHEMISTRY", "CHEMISTRY", "CHEMISTRY", "IMMUNOLOGY"),
|
|
| 604 | -6x | +
- new("VarDynCutSplit",
+ #' PARAMCD = c("ALT", "CRP", "CRP", "IGA"),
|
|
| 605 | -6x | +
- payload = var,+ #' ANRIND = c("LOW", "LOW", "HIGH", "HIGH"),
|
|
| 606 | -6x | +
- split_label = split_label,+ #' stringsAsFactors = FALSE |
|
| 607 | -6x | +
- cut_fun = cutfun,+ #' ) |
|
| 608 | -6x | +
- cumulative_cuts = cumulative,+ #' |
|
| 609 | -6x | +
- cut_label_fun = cutlabelfun,+ #' lyt <- basic_table() %>% |
|
| 610 | -6x | +
- content_fun = cfun,+ #' split_rows_by("LBCAT") %>%
|
|
| 611 | -6x | +
- content_format = cformat,+ #' split_rows_by("PARAMCD", split_fun = trim_levels_to_map(map = map)) %>%
|
|
| 612 | -6x | +
- content_na_str = cna_str,+ #' analyze("ANRIND")
|
|
| 613 | -6x | +
- split_format = split_format,+ #' tbl <- build_table(lyt, ex_adlb) |
|
| 614 | -6x | +
- split_na_str = split_na_str,+ #' |
|
| 615 | -6x | +
- name = split_name,+ #' @export |
|
| 616 | -6x | +
- label_children = .labelkids_helper(child_labels),+ trim_levels_to_map <- function(map = NULL) {
|
|
| 617 | -6x | +7x |
- extra_args = extra_args,+ if (is.null(map) || any(sapply(map, class) != "character")) {
|
| 618 | -6x | +! |
- indent_modifier = as.integer(indent_mod),+ stop( |
| 619 | -6x | +! |
- content_indent_modifier = as.integer(cindent_mod),+ "No map dataframe was provided or not all of the columns are of ", |
| 620 | -6x | +! |
- content_var = cvar,+ "type character." |
| 621 | -6x | +
- split_label_position = label_pos,+ ) |
|
| 622 | -6x | +
- content_extra_args = cextra_args,+ } |
|
| 623 | -6x | +
- page_title_prefix = page_prefix,+ |
|
| 624 | -6x | +7x |
- child_section_div = section_div,+ myfun <- function(df, |
| 625 | -6x | +7x |
- child_show_colcounts = show_colcounts,+ spl, |
| 626 | -6x | +7x |
- child_colcount_format = colcount_format+ vals = NULL, |
| 627 | -+ | 7x |
- )+ labels = NULL, |
| 628 | -+ | 7x |
- }+ trim = FALSE, |
| 629 | -+ | 7x |
-
+ .spl_context) {
|
| 630 | -+ | 12x |
- ## NB analyze splits can't have content-related things+ allvars <- colnames(map) |
| 631 | -+ | 12x |
- setClass("VAnalyzeSplit",
+ splvar <- spl_payload(spl) |
| 632 |
- contains = "Split",+ |
||
| 633 | -+ | 12x |
- representation(+ allvmatches <- match(.spl_context$split, allvars) |
| 634 | -+ | 12x |
- default_rowlabel = "character",+ outvars <- allvars[na.omit(allvmatches)] |
| 635 |
- include_NAs = "logical",+ ## invars are variables present in data, but not in |
||
| 636 |
- var_label_position = "character"+ ## previous or current splits |
||
| 637 | -+ | 12x |
- )+ invars <- intersect( |
| 638 | -+ | 12x |
- )+ setdiff(allvars, c(outvars, splvar)), |
| 639 | -+ | 12x |
-
+ names(df) |
| 640 |
- setClass("AnalyzeVarSplit",
+ ) |
||
| 641 |
- contains = "VAnalyzeSplit",+ ## allvarord <- c(na.omit(allvmatches), ## appear in prior splits |
||
| 642 |
- representation(analysis_fun = "function")+ ## which(allvars == splvar), ## this split |
||
| 643 |
- )+ ## allvars[-1*na.omit(allvmatches)]) ## "outvars" |
||
| 645 |
- setClass("AnalyzeColVarSplit",
+ ## allvars <- allvars[allvarord] |
||
| 646 |
- contains = "VAnalyzeSplit",+ ## outvars <- allvars[-(which(allvars == splvar):length(allvars))] |
||
| 647 | -+ | 12x |
- representation(analysis_fun = "list")+ if (length(outvars) > 0) {
|
| 648 | -+ | 10x |
- )+ indfilters <- vapply(outvars, function(ivar) {
|
| 649 | -+ | 12x |
-
+ obsval <- .spl_context$value[match(ivar, .spl_context$split)] |
| 650 | -+ | 12x |
- #' Define a subset tabulation/analysis+ sprintf("%s == '%s'", ivar, obsval)
|
| 651 |
- #'+ }, "") |
||
| 652 |
- #' @inheritParams lyt_args+ |
||
| 653 | -+ | 10x |
- #' @inheritParams constr_args+ allfilters <- paste(indfilters, collapse = " & ") |
| 654 | -+ | 10x |
- #' @param defrowlab (`character`)\cr default row labels, if not specified by the return value of `afun`.+ map <- map[eval(parse(text = allfilters), envir = map), ] |
| 655 |
- #'+ } |
||
| 656 | -+ | 12x |
- #' @return An `AnalyzeVarSplit` object.+ map_splvarpos <- which(names(map) == splvar) |
| 657 | -+ | 12x |
- #'+ nondup <- !duplicated(map[[splvar]]) |
| 658 | -+ | 12x |
- #' @author Gabriel Becker+ ksl_fun <- keep_split_levels( |
| 659 | -+ | 12x |
- #' @export+ only = map[[splvar]][nondup], |
| 660 | -+ | 12x |
- #' @rdname avarspl+ reorder = TRUE |
| 661 |
- AnalyzeVarSplit <- function(var,+ ) |
||
| 662 | -+ | 12x |
- split_label = var,+ ret <- ksl_fun(df, spl, vals, labels, trim = trim) |
| 663 |
- afun,+ |
||
| 664 | -+ | 12x |
- defrowlab = "",+ if (length(ret$datasplit) == 0) {
|
| 665 | -+ | 1x |
- cfun = NULL,+ msg <- paste(sprintf("%s[%s]", .spl_context$split, .spl_context$value),
|
| 666 | -+ | 1x |
- cformat = NULL,+ collapse = "->" |
| 667 |
- split_format = NULL,+ ) |
||
| 668 | -+ | 1x |
- split_na_str = NA_character_,+ stop( |
| 669 | -+ | 1x |
- inclNAs = FALSE,+ "map does not allow any values present in data for split ", |
| 670 | -+ | 1x |
- split_name = var,+ "variable ", splvar, |
| 671 | -+ | 1x |
- extra_args = list(),+ " under the following parent splits:\n\t", msg |
| 672 |
- indent_mod = 0L,+ ) |
||
| 673 |
- label_pos = "default",+ } |
||
| 674 |
- cvar = "",+ |
||
| 675 |
- section_div = NA_character_) {
+ ## keep non-split (inner) variables levels |
||
| 676 | -333x | +11x |
- check_ok_label(split_label)+ ret$datasplit <- lapply(ret$values, function(splvar_lev) {
|
| 677 | -333x | +19x |
- label_pos <- match.arg(label_pos, c("default", label_pos_values))
+ df3 <- ret$datasplit[[splvar_lev]] |
| 678 | -333x | +19x |
- if (!any(nzchar(defrowlab))) {
+ curmap <- map[map[[map_splvarpos]] == splvar_lev, ] |
| 679 | -1x | +
- defrowlab <- as.character(substitute(afun))+ ## loop through inner variables |
|
| 680 | -1x | +19x |
- if (length(defrowlab) > 1 || startsWith(defrowlab, "function(")) {
+ for (iv in invars) { ## setdiff(colnames(map), splvar)) {
|
| 681 | -! | +19x |
- defrowlab <- ""+ iv_lev <- df3[[iv]] |
| 682 | -+ | 19x |
- }+ levkeep <- as.character(unique(curmap[[iv]])) |
| 683 | -+ | 19x |
- }+ if (is.factor(iv_lev) && !all(levkeep %in% levels(iv_lev))) {
|
| 684 | -333x | +! |
- new("AnalyzeVarSplit",
+ stop( |
| 685 | -333x | +! |
- payload = var,+ "Attempted to keep invalid factor level(s) in split ", |
| 686 | -333x | +! |
- split_label = split_label,+ setdiff(levkeep, levels(iv_lev)) |
| 687 | -333x | +
- content_fun = cfun,+ ) |
|
| 688 | -333x | +
- analysis_fun = afun,+ } |
|
| 689 | -333x | +
- content_format = cformat,+ |
|
| 690 | -333x | +19x |
- split_format = split_format,+ df3 <- df3[iv_lev %in% levkeep, , drop = FALSE] |
| 691 | -333x | +
- split_na_str = split_na_str,+ |
|
| 692 | -333x | +19x |
- default_rowlabel = defrowlab,+ if (is.factor(iv_lev)) {
|
| 693 | -333x | +19x |
- include_NAs = inclNAs,+ df3[[iv]] <- factor(as.character(df3[[iv]]), |
| 694 | -333x | +19x |
- name = split_name,+ levels = levkeep |
| 695 | -333x | +
- label_children = FALSE,+ ) |
|
| 696 | -333x | +
- extra_args = extra_args,+ } |
|
| 697 | -333x | +
- indent_modifier = as.integer(indent_mod),+ } |
|
| 698 | -333x | +
- content_indent_modifier = 0L,+ |
|
| 699 | -333x | +19x |
- var_label_position = label_pos,+ df3 |
| 700 | -333x | +
- content_var = cvar,+ }) |
|
| 701 | -333x | +11x |
- page_title_prefix = NA_character_,+ names(ret$datasplit) <- ret$values |
| 702 | -333x | +11x |
- child_section_div = section_div,+ ret |
| 703 | -333x | +
- child_show_colcounts = FALSE,+ } |
|
| 704 | -333x | +
- child_colcount_format = NA_character_+ |
|
| 705 | -333x | +7x |
- ) ## no content_extra_args+ myfun |
| 707 | +1 |
-
+ ## Split types ----------------------------------------------------------------- |
||
| 708 | +2 |
- #' Define a subset tabulation/analysis+ ## variable: split on distinct values of a variable |
||
| 709 | +3 |
- #'+ ## all: include all observations (root 'split') |
||
| 710 | +4 |
- #' @inheritParams lyt_args+ ## rawcut: cut on static values of a variable |
||
| 711 | +5 |
- #' @inheritParams constr_args+ ## quantilecut: cut on quantiles of observed values for a variable |
||
| 712 | +6 |
- #'+ ## missing: split obs based on missingness of a variable/observation. This could be used for compare to ref_group?? |
||
| 713 | +7 |
- #' @author Gabriel Becker+ ## multicolumn: each child analyzes a different column |
||
| 714 | +8 |
- #' @export+ ## arbitrary: children are not related to each other in any systematic fashion. |
||
| 715 | +9 |
- #' @rdname avarspl+ |
||
| 716 | +10 |
- AnalyzeColVarSplit <- function(afun,+ ## null is ok here. |
||
| 717 | +11 |
- defrowlab = "",+ check_ok_label <- function(lbl, multi_ok = FALSE) {
|
||
| 718 | -+ | |||
| 12 | +50452x |
- cfun = NULL,+ if (length(lbl) == 0) {
+ |
+ ||
| 13 | +11636x | +
+ return(TRUE) |
||
| 719 | +14 |
- cformat = NULL,+ } |
||
| 720 | +15 |
- split_format = NULL,+ + |
+ ||
| 16 | +38816x | +
+ if (length(lbl) > 1) {
+ |
+ ||
| 17 | +1933x | +
+ if (multi_ok) {
+ |
+ ||
| 18 | +1933x | +
+ return(all(vapply(lbl, check_ok_label, TRUE))) |
||
| 721 | +19 |
- split_na_str = NA_character_,+ }+ |
+ ||
| 20 | +! | +
+ stop("got a label of length > 1")
|
||
| 722 | +21 |
- inclNAs = FALSE,+ } |
||
| 723 | +22 |
- split_name = "",+ + |
+ ||
| 23 | +36883x | +
+ if (grepl("([{}])", lbl)) {
+ |
+ ||
| 24 | +1x | +
+ stop("Labels cannot contain { or } due to their use for indicating referential footnotes")
|
||
| 724 | +25 |
- extra_args = list(),+ }+ |
+ ||
| 26 | +36882x | +
+ invisible(TRUE) |
||
| 725 | +27 |
- indent_mod = 0L,+ } |
||
| 726 | +28 |
- label_pos = "default",+ |
||
| 727 | +29 |
- cvar = "",+ valid_lbl_pos <- c("default", "visible", "hidden", "topleft")
|
||
| 728 | +30 |
- section_div = NA_character_) {
+ .labelkids_helper <- function(charval) {
|
||
| 729 | -23x | +31 | +2470x |
- label_pos <- match.arg(label_pos, c("default", label_pos_values))
+ ret <- switch(charval, |
| 730 | -23x | +32 | +2470x |
- new("AnalyzeColVarSplit",
+ "default" = NA, |
| 731 | -23x | +33 | +2470x |
- payload = NA_character_,+ "visible" = TRUE, |
| 732 | -23x | +34 | +2470x |
- split_label = "",+ "hidden" = FALSE, |
| 733 | -23x | +35 | +2470x |
- content_fun = cfun,+ "topleft" = FALSE, |
| 734 | -23x | +36 | +2470x |
- analysis_fun = afun,+ stop( |
| 735 | -23x | +37 | +2470x |
- content_format = cformat,+ "unrecognized charval in .labelkids_helper. ", |
| 736 | -23x | +38 | +2470x |
- split_format = split_format,+ "this shouldn't ever happen" |
| 737 | -23x | +|||
| 39 | +
- split_na_str = split_na_str,+ ) |
|||
| 738 | -23x | +|||
| 40 | +
- default_rowlabel = defrowlab,+ ) |
|||
| 739 | -23x | +41 | +2470x |
- include_NAs = inclNAs,+ ret |
| 740 | -23x | +|||
| 42 | +
- name = split_name,+ } |
|||
| 741 | -23x | +|||
| 43 | +
- label_children = FALSE,+ |
|||
| 742 | -23x | +|||
| 44 | +
- extra_args = extra_args,+ setOldClass("expression")
|
|||
| 743 | -23x | +|||
| 45 | +
- indent_modifier = as.integer(indent_mod),+ setClassUnion("SubsetDef", c("expression", "logical", "integer", "numeric"))
|
|||
| 744 | -23x | +|||
| 46 | +
- content_indent_modifier = 0L,+ |
|||
| 745 | -23x | +|||
| 47 | +
- var_label_position = label_pos,+ setClassUnion("integerOrNULL", c("NULL", "integer"))
|
|||
| 746 | -23x | +|||
| 48 | +
- content_var = cvar,+ setClassUnion("characterOrNULL", c("NULL", "character"))
|
|||
| 747 | -23x | +|||
| 49 | +
- page_title_prefix = NA_character_,+ |
|||
| 748 | -23x | +|||
| 50 | +
- child_section_div = section_div,+ ## should XXX [splits, s_values, sval_labels, subset(?)] be a data.frame? |
|||
| 749 | -23x | +|||
| 51 | +
- child_show_colcounts = FALSE,+ setClass("TreePos", representation(
|
|||
| 750 | -23x | +|||
| 52 | +
- child_colcount_format = NA_character_+ splits = "list", |
|||
| 751 | -23x | +|||
| 53 | +
- ) ## no content_extra_args+ s_values = "list", |
|||
| 752 | +54 |
- }+ sval_labels = "character", |
||
| 753 | +55 |
-
+ subset = "SubsetDef" |
||
| 754 | +56 |
- setClass("CompoundSplit",
+ ), |
||
| 755 | +57 |
- contains = "Split",+ validity = function(object) {
|
||
| 756 | +58 |
- validity = function(object) are(object@payload, "Split")+ nspl <- length(object@splits) |
||
| 757 | +59 | ++ |
+ length(object@s_values) == nspl && length(object@sval_labels) == nspl+ |
+ |
| 60 | ++ |
+ }+ |
+ ||
| 61 |
) |
|||
| 758 | +62 | |||
| 759 | +63 |
- setClass("AnalyzeMultiVars", contains = "CompoundSplit")
+ setClassUnion("functionOrNULL", c("NULL", "function"))
|
||
| 760 | +64 |
-
+ setClassUnion("listOrNULL", c("NULL", "list"))
|
||
| 761 | +65 |
- .repoutlst <- function(x, nv) {
+ ## TODO (?) make "list" more specific, e.g FormatList, or FunctionList? |
||
| 762 | -1830x | +|||
| 66 | +
- if (!is.function(x) && length(x) == nv) {
+ setClassUnion("FormatSpec", c("NULL", "character", "function", "list"))
|
|||
| 763 | -879x | +|||
| 67 | +
- return(x)+ setClassUnion("ExprOrNULL", c("NULL", "expression"))
|
|||
| 764 | +68 |
- }+ |
||
| 765 | -951x | +|||
| 69 | +
- if (!is(x, "list")) {
+ setClass("ValueWrapper", representation(
|
|||
| 766 | -951x | +|||
| 70 | +
- x <- list(x)+ value = "ANY", |
|||
| 767 | +71 |
- }+ label = "characterOrNULL", |
||
| 768 | -951x | +|||
| 72 | +
- rep(x, length.out = nv)+ subset_expression = "ExprOrNULL" |
|||
| 769 | +73 |
- }+ ), |
||
| 770 | +74 |
-
+ contains = "VIRTUAL" |
||
| 771 | +75 |
- .uncompound <- function(csplit) {
+ ) |
||
| 772 | -61x | +|||
| 76 | +
- if (is(csplit, "list")) {
+ ## heavier-weight than I'd like but I think we need |
|||
| 773 | -3x | +|||
| 77 | +
- return(unlist(lapply(csplit, .uncompound)))+ ## this to carry around thee subsets for |
|||
| 774 | +78 |
- }+ ## comparison-based splits |
||
| 775 | +79 | |||
| 776 | -58x | +|||
| 80 | +
- if (!is(csplit, "CompoundSplit")) {
+ setClass("SplitValue",
|
|||
| 777 | -57x | +|||
| 81 | +
- return(csplit)+ contains = "ValueWrapper", |
|||
| 778 | +82 |
- }+ representation(extra = "list") |
||
| 779 | +83 | ++ |
+ )+ |
+ |
| 84 | ||||
| 780 | -1x | +|||
| 85 | +
- pld <- spl_payload(csplit)+ SplitValue <- function(val, extr = list(), label = val, sub_expr = NULL) {
|
|||
| 781 | -1x | +86 | +4946x |
- done <- all(!vapply(pld, is, TRUE, class2 = "CompoundSplit"))+ if (is(val, "SplitValue")) {
|
| 782 | -1x | +87 | +2086x |
- if (done) {
+ if (length(splv_extra(val)) > 0) {
|
| 783 | -1x | +88 | +29x |
- pld+ extr <- c(splv_extra(val), extr) |
| 784 | +89 |
- } else {
+ } |
||
| 785 | -! | +|||
| 90 | +2086x |
- unlist(lapply(pld, .uncompound))+ splv_extra(val) <- extr+ |
+ ||
| 91 | +2086x | +
+ return(val) |
||
| 786 | +92 |
} |
||
| 787 | -+ | |||
| 93 | +2860x |
- }+ if (!is(extr, "list")) {
|
||
| 788 | -+ | |||
| 94 | +! |
-
+ extr <- list(extr) |
||
| 789 | +95 |
- strip_compound_name <- function(obj) {
+ } |
||
| 790 | -11x | +96 | +2860x |
- nm <- obj_name(obj)+ if (!is(label, "character")) {
|
| 791 | -11x | +|||
| 97 | +! |
- gsub("^ma_", "", nm)
+ label <- as.character(label) |
||
| 792 | +98 |
- }+ } |
||
| 793 | +99 | |||
| 100 | +2860x | +
+ if (!is.null(sub_expr) && !is.expression(sub_expr)) {
+ |
+ ||
| 101 | +105x | +
+ sub_expr <- as.expression(sub_expr)+ |
+ ||
| 794 | +102 |
- make_ma_name <- function(spl, pld = spl_payload(spl)) {
+ } ## sometimes they will be "call" objects, etc |
||
| 795 | -3x | +103 | +2860x |
- paste(+ check_ok_label(label) |
| 796 | -3x | +104 | +2860x |
- c(+ new("SplitValue",
|
| 797 | -3x | +105 | +2860x |
- "ma",+ value = val, |
| 798 | -3x | +106 | +2860x |
- vapply(pld, strip_compound_name, "")+ extra = extr, |
| 799 | -+ | |||
| 107 | +2860x |
- ),+ label = label, |
||
| 800 | -3x | +108 | +2860x |
- collapse = "_"+ subset_expression = sub_expr |
| 801 | +109 |
) |
||
| 802 | +110 |
} |
||
| 803 | +111 | |||
| 804 | +112 |
- #' @param .payload (`list`)\cr used internally, not intended to be set by end users.+ setClass("LevelComboSplitValue",
|
||
| 805 | +113 |
- #'+ contains = "SplitValue", |
||
| 806 | +114 |
- #' @return An `AnalyzeMultiVars` split object.+ representation(combolevels = "character") |
||
| 807 | +115 |
- #'+ ) |
||
| 808 | +116 |
- #' @export+ |
||
| 809 | +117 |
- #' @rdname avarspl+ ## wrapped in user-facing `add_combo_facet` |
||
| 810 | +118 |
- AnalyzeMultiVars <- function(var,+ LevelComboSplitValue <- function(val, extr, combolevels, label = val, sub_expr = NULL) {
|
||
| 811 | -+ | |||
| 119 | +28x |
- split_label = "",+ check_ok_label(label)+ |
+ ||
| 120 | +28x | +
+ new("LevelComboSplitValue",
+ |
+ ||
| 121 | +28x | +
+ value = val,+ |
+ ||
| 122 | +28x | +
+ extra = extr,+ |
+ ||
| 123 | +28x | +
+ combolevels = combolevels,+ |
+ ||
| 124 | +28x | +
+ label = label,+ |
+ ||
| 125 | +28x | +
+ subset_expression = sub_expr |
||
| 812 | +126 |
- afun,+ ) |
||
| 813 | +127 |
- defrowlab = "",+ } |
||
| 814 | +128 |
- cfun = NULL,+ |
||
| 815 | +129 |
- cformat = NULL,+ setClass("Split",
|
||
| 816 | +130 |
- split_format = NULL,+ contains = "VIRTUAL", |
||
| 817 | +131 |
- split_na_str = NA_character_,+ representation( |
||
| 818 | +132 |
- inclNAs = FALSE,+ payload = "ANY", |
||
| 819 | +133 |
- .payload = NULL,+ name = "character", |
||
| 820 | +134 |
- split_name = NULL,+ split_label = "character", |
||
| 821 | +135 |
- extra_args = list(),+ split_format = "FormatSpec", |
||
| 822 | +136 |
- indent_mod = 0L,+ split_na_str = "character", |
||
| 823 | +137 |
- child_labels = c("default", "topleft", "visible", "hidden"),
+ split_label_position = "character", |
||
| 824 | +138 |
- child_names = var,+ ## NB this is the function which is applied to |
||
| 825 | +139 |
- cvar = "",+ ## get the content rows for the CHILDREN of this |
||
| 826 | +140 |
- section_div = NA_character_) {
+ ## split!!! |
||
| 827 | +141 |
- ## NB we used to resolve to strict TRUE/FALSE for label visibillity+ content_fun = "listOrNULL", ## functionOrNULL", |
||
| 828 | +142 |
- ## in this function but that was too greedy for repeated+ content_format = "FormatSpec", |
||
| 829 | +143 |
- ## analyze calls, so that now occurs in the tabulation machinery+ content_na_str = "character", |
||
| 830 | +144 |
- ## when the table is actually being built.+ content_var = "character", |
||
| 831 | +145 |
- ## show_kidlabs = .labelkids_helper(match.arg(child_labels))+ label_children = "logical", |
||
| 832 | -329x | +|||
| 146 | +
- child_labels <- match.arg(child_labels)+ extra_args = "list", |
|||
| 833 | -329x | -
- show_kidlabs <- child_labels- |
- ||
| 834 | -329x | +|||
| 147 | +
- if (is.null(.payload)) {
+ indent_modifier = "integer", |
|||
| 835 | -305x | +|||
| 148 | +
- nv <- length(var)+ content_indent_modifier = "integer", |
|||
| 836 | -305x | +|||
| 149 | +
- defrowlab <- .repoutlst(defrowlab, nv)+ content_extra_args = "list", |
|||
| 837 | -305x | +|||
| 150 | +
- afun <- .repoutlst(afun, nv)+ page_title_prefix = "character", |
|||
| 838 | -305x | +|||
| 151 | +
- split_label <- .repoutlst(split_label, nv)+ child_section_div = "character", |
|||
| 839 | -305x | +|||
| 152 | +
- check_ok_label(split_label, multi_ok = TRUE)+ child_show_colcounts = "logical", |
|||
| 840 | -305x | +|||
| 153 | +
- cfun <- .repoutlst(cfun, nv)+ child_colcount_format = "FormatSpec" |
|||
| 841 | -305x | +|||
| 154 | +
- cformat <- .repoutlst(cformat, nv)+ ) |
|||
| 842 | +155 |
- ## split_format = .repoutlst(split_format, nv)+ ) |
||
| 843 | -305x | +|||
| 156 | +
- inclNAs <- .repoutlst(inclNAs, nv)+ |
|||
| 844 | -305x | +|||
| 157 | +
- section_div_if_multivar <- if (length(var) > 1) NA_character_ else section_div+ setClass("CustomizableSplit",
|
|||
| 845 | -305x | +|||
| 158 | +
- pld <- mapply(AnalyzeVarSplit,+ contains = "Split", |
|||
| 846 | -305x | +|||
| 159 | +
- var = var,+ representation(split_fun = "functionOrNULL") |
|||
| 847 | -305x | +|||
| 160 | +
- split_name = child_names,+ ) |
|||
| 848 | -305x | +|||
| 161 | +
- split_label = split_label,+ |
|||
| 849 | -305x | +|||
| 162 | +
- afun = afun,+ #' @author Gabriel Becker |
|||
| 850 | -305x | +|||
| 163 | +
- defrowlab = defrowlab,+ #' @exportClass VarLevelSplit |
|||
| 851 | -305x | +|||
| 164 | +
- cfun = cfun,+ #' @rdname VarLevelSplit |
|||
| 852 | -305x | +|||
| 165 | +
- cformat = cformat,+ setClass("VarLevelSplit",
|
|||
| 853 | +166 |
- ## split_format = split_format,+ contains = "CustomizableSplit", |
||
| 854 | -305x | +|||
| 167 | +
- inclNAs = inclNAs,+ representation( |
|||
| 855 | -305x | +|||
| 168 | +
- MoreArgs = list(+ value_label_var = "character", |
|||
| 856 | -305x | +|||
| 169 | +
- extra_args = extra_args,+ value_order = "ANY" |
|||
| 857 | -305x | +|||
| 170 | +
- indent_mod = indent_mod,+ ) |
|||
| 858 | -305x | +|||
| 171 | +
- label_pos = show_kidlabs,+ ) |
|||
| 859 | -305x | +|||
| 172 | +
- split_format = split_format,+ #' Split on levels within a variable |
|||
| 860 | -305x | +|||
| 173 | +
- split_na_str = split_na_str,+ #' |
|||
| 861 | -305x | +|||
| 174 | +
- section_div = section_div_if_multivar+ #' @inheritParams lyt_args |
|||
| 862 | -305x | +|||
| 175 | +
- ), ## rvis),+ #' @inheritParams constr_args |
|||
| 863 | -305x | +|||
| 176 | +
- SIMPLIFY = FALSE+ #' |
|||
| 864 | +177 |
- )+ #' @return a `VarLevelSplit` object. |
||
| 865 | +178 |
- } else {
+ #' |
||
| 866 | +179 |
- ## we're combining existing splits here+ #' @export |
||
| 867 | -24x | +|||
| 180 | +
- pld <- unlist(lapply(.payload, .uncompound))+ VarLevelSplit <- function(var, |
|||
| 868 | +181 |
-
+ split_label, |
||
| 869 | +182 |
- ## only override the childen being combined if the constructor+ labels_var = NULL, |
||
| 870 | +183 |
- ## was passed a non-default value for child_labels+ cfun = NULL, |
||
| 871 | +184 |
- ## and the child was at NA before+ cformat = NULL, |
||
| 872 | -24x | +|||
| 185 | +
- pld <- lapply(+ cna_str = NA_character_, |
|||
| 873 | -24x | +|||
| 186 | +
- pld,+ split_fun = NULL, |
|||
| 874 | -24x | +|||
| 187 | +
- function(x) {
+ split_format = NULL, |
|||
| 875 | -48x | +|||
| 188 | +
- rvis <- label_position(x) ## labelrow_visible(x)+ split_na_str = NA_character_, |
|||
| 876 | -48x | +|||
| 189 | +
- if (!identical(show_kidlabs, "default")) { ## is.na(show_kidlabs)) {
+ valorder = NULL, |
|||
| 877 | -! | +|||
| 190 | +
- if (identical(rvis, "default")) { ## ois.na(rvis))
+ split_name = var, |
|||
| 878 | -! | +|||
| 191 | +
- rvis <- show_kidlabs+ child_labels = c("default", "visible", "hidden"),
|
|||
| 879 | +192 |
- }+ extra_args = list(), |
||
| 880 | +193 |
- }+ indent_mod = 0L, |
||
| 881 | -48x | +|||
| 194 | +
- label_position(x) <- rvis+ label_pos = c("topleft", "hidden", "visible"),
|
|||
| 882 | -48x | +|||
| 195 | +
- x+ cindent_mod = 0L, |
|||
| 883 | +196 |
- }+ cvar = "", |
||
| 884 | +197 |
- )+ cextra_args = list(), |
||
| 885 | +198 |
- }+ page_prefix = NA_character_, |
||
| 886 | -329x | +|||
| 199 | +
- if (length(pld) == 1) {
+ section_div = NA_character_, |
|||
| 887 | -282x | +|||
| 200 | +
- ret <- pld[[1]]+ show_colcounts = FALSE, |
|||
| 888 | +201 |
- } else {
+ colcount_format = NULL) {
|
||
| 889 | -47x | +202 | +536x |
- if (is.null(split_name)) {
+ child_labels <- match.arg(child_labels) |
| 890 | -47x | +203 | +536x |
- split_name <- paste(c("ma", vapply(pld, obj_name, "")),
+ if (is.null(labels_var)) {
|
| 891 | -47x | +204 | +1x |
- collapse = "_"+ labels_var <- var |
| 892 | +205 |
- )+ } |
||
| 893 | -+ | |||
| 206 | +536x |
- }+ check_ok_label(split_label) |
||
| 894 | -47x | +207 | +536x |
- ret <- new("AnalyzeMultiVars",
+ new("VarLevelSplit",
|
| 895 | -47x | +208 | +536x |
- payload = pld,+ payload = var, |
| 896 | -47x | +209 | +536x |
- split_label = "",+ split_label = split_label, |
| 897 | -47x | +210 | +536x |
- split_format = NULL,+ name = split_name, |
| 898 | -47x | +211 | +536x |
- split_na_str = split_na_str,+ value_label_var = labels_var, |
| 899 | -47x | +212 | +536x |
- content_fun = NULL,+ content_fun = cfun, |
| 900 | -47x | +213 | +536x |
- content_format = NULL,+ content_format = cformat, |
| 901 | -+ | |||
| 214 | +536x |
- ## I beleive this is superfluous now+ content_na_str = cna_str, |
||
| 902 | -+ | |||
| 215 | +536x |
- ## the payloads carry aroudn the real instructions+ split_fun = split_fun, |
||
| 903 | -+ | |||
| 216 | +536x |
- ## XXX+ split_format = split_format, |
||
| 904 | -47x | +217 | +536x |
- label_children = .labelkids_helper(show_kidlabs),+ split_na_str = split_na_str, |
| 905 | -47x | +218 | +536x |
- split_label_position = "hidden", ## XXX is this right?+ value_order = NULL, |
| 906 | -47x | +219 | +536x |
- name = split_name,+ label_children = .labelkids_helper(child_labels), |
| 907 | -47x | +220 | +536x |
- extra_args = extra_args,+ extra_args = extra_args, |
| 908 | -+ | |||
| 221 | +536x |
- ## modifier applied on splits in payload+ indent_modifier = as.integer(indent_mod), |
||
| 909 | -47x | +222 | +536x |
- indent_modifier = 0L,+ content_indent_modifier = as.integer(cindent_mod), |
| 910 | -47x | +223 | +536x |
- content_indent_modifier = 0L,+ content_var = cvar, |
| 911 | -47x | +224 | +536x |
- content_var = cvar,+ split_label_position = label_pos, |
| 912 | -47x | +225 | +536x |
- page_title_prefix = NA_character_,+ content_extra_args = cextra_args, |
| 913 | -47x | +226 | +536x |
- child_section_div = section_div+ page_title_prefix = page_prefix, |
| 914 | -+ | |||
| 227 | +536x |
- )+ child_section_div = section_div, |
||
| 915 | -+ | |||
| 228 | +536x |
- }+ child_show_colcounts = show_colcounts, |
||
| 916 | -329x | +229 | +536x |
- ret+ child_colcount_format = colcount_format |
| 917 | +230 |
- }+ ) |
||
| 918 | +231 |
-
+ } |
||
| 919 | +232 |
- setClass("VarLevWBaselineSplit",
+
|
||
| 920 | +233 |
- contains = "VarLevelSplit",+ setClass("AllSplit", contains = "Split")
|
||
| 921 | +234 |
- representation(+ |
||
| 922 | +235 |
- var = "character",+ AllSplit <- function(split_label = "", |
||
| 923 | +236 |
- ref_group_value = "character"+ cfun = NULL, |
||
| 924 | +237 |
- )+ cformat = NULL, |
||
| 925 | +238 |
- )+ cna_str = NA_character_, |
||
| 926 | +239 |
-
+ split_format = NULL, |
||
| 927 | +240 |
- #' @rdname VarLevelSplit+ split_na_str = NA_character_, |
||
| 928 | +241 |
- #' @export+ split_name = NULL, |
||
| 929 | +242 |
- VarLevWBaselineSplit <- function(var,+ extra_args = list(), |
||
| 930 | +243 |
- ref_group,+ indent_mod = 0L, |
||
| 931 | +244 |
- labels_var = var,+ cindent_mod = 0L, |
||
| 932 | +245 |
- split_label,+ cvar = "", |
||
| 933 | +246 |
- split_fun = NULL,+ cextra_args = list(), |
||
| 934 | +247 |
- label_fstr = "%s - %s",+ show_colcounts = FALSE, |
||
| 935 | +248 |
- ## not needed I Think...+ colcount_format = NULL, |
||
| 936 | +249 |
- cfun = NULL,+ ...) {
|
||
| 937 | -+ | |||
| 250 | +213x |
- cformat = NULL,+ if (is.null(split_name)) {
|
||
| 938 | -+ | |||
| 251 | +112x |
- cna_str = NA_character_,+ if (nzchar(split_label)) {
|
||
| 939 | -+ | |||
| 252 | +7x |
- cvar = "",+ split_name <- split_label |
||
| 940 | +253 |
- split_format = NULL,+ } else {
|
||
| 941 | -+ | |||
| 254 | +105x |
- split_na_str = NA_character_,+ split_name <- "all obs" |
||
| 942 | +255 |
- valorder = NULL,+ } |
||
| 943 | +256 |
- split_name = var,+ } |
||
| 944 | -+ | |||
| 257 | +213x |
- extra_args = list(),+ check_ok_label(split_label) |
||
| 945 | -+ | |||
| 258 | +213x |
- show_colcounts = FALSE,+ new("AllSplit",
|
||
| 946 | -+ | |||
| 259 | +213x |
- colcount_format = NULL) {
+ split_label = split_label, |
||
| 947 | -10x | +260 | +213x |
- check_ok_label(split_label)+ content_fun = cfun, |
| 948 | -10x | +261 | +213x |
- new("VarLevWBaselineSplit",
+ content_format = cformat, |
| 949 | -10x | +262 | +213x |
- payload = var,+ content_na_str = cna_str, |
| 950 | -10x | +263 | +213x |
- ref_group_value = ref_group,+ split_format = split_format, |
| 951 | -+ | |||
| 264 | +213x |
- ## This will occur at the row level not on the column split, for now+ split_na_str = split_na_str, |
||
| 952 | -+ | |||
| 265 | +213x |
- ## TODO revisit this to confirm its right+ name = split_name, |
||
| 953 | -+ | |||
| 266 | +213x |
- ## comparison_func = comparison,+ label_children = FALSE, |
||
| 954 | -+ | |||
| 267 | +213x |
- # label_format = label_fstr,+ extra_args = extra_args, |
||
| 955 | -10x | +268 | +213x |
- value_label_var = labels_var,+ indent_modifier = as.integer(indent_mod), |
| 956 | -10x | +269 | +213x |
- split_label = split_label,+ content_indent_modifier = as.integer(cindent_mod), |
| 957 | -10x | +270 | +213x |
- content_fun = cfun,+ content_var = cvar, |
| 958 | -10x | +271 | +213x |
- content_format = cformat,+ split_label_position = "hidden", |
| 959 | -10x | +272 | +213x |
- content_na_str = cna_str,+ content_extra_args = cextra_args, |
| 960 | -10x | +273 | +213x |
- split_format = split_format,+ page_title_prefix = NA_character_, |
| 961 | -10x | +274 | +213x |
- split_na_str = split_na_str,+ child_section_div = NA_character_, |
| 962 | -10x | +275 | +213x |
- split_fun = split_fun,+ child_show_colcounts = show_colcounts, |
| 963 | -10x | +276 | +213x |
- name = split_name,+ child_colcount_format = colcount_format |
| 964 | -10x | +|||
| 277 | +
- label_children = FALSE,+ ) |
|||
| 965 | -10x | +|||
| 278 | +
- extra_args = extra_args,+ } |
|||
| 966 | +279 |
- ## this is always a column split+ |
||
| 967 | -10x | +|||
| 280 | +
- indent_modifier = 0L,+ setClass("RootSplit", contains = "AllSplit")
|
|||
| 968 | -10x | +|||
| 281 | +
- content_indent_modifier = 0L,+ |
|||
| 969 | -10x | +|||
| 282 | +
- content_var = cvar,+ RootSplit <- function(split_label = "", cfun = NULL, cformat = NULL, cna_str = NA_character_, cvar = "", |
|||
| 970 | +283 |
- ## so long as this is columnspace only+ split_format = NULL, split_na_str = NA_character_, cextra_args = list(), ...) {
|
||
| 971 | -10x | +284 | +668x |
- page_title_prefix = NA_character_,+ check_ok_label(split_label) |
| 972 | -10x | +285 | +668x |
- child_section_div = NA_character_,+ new("RootSplit",
|
| 973 | -10x | +286 | +668x |
- child_show_colcounts = show_colcounts,+ split_label = split_label, |
| 974 | -10x | +287 | +668x |
- child_colcount_format = colcount_format+ content_fun = cfun, |
| 975 | -+ | |||
| 288 | +668x |
- )+ content_format = cformat, |
||
| 976 | -+ | |||
| 289 | +668x |
- }+ content_na_str = cna_str, |
||
| 977 | -+ | |||
| 290 | +668x |
-
+ split_format = split_format, |
||
| 978 | -+ | |||
| 291 | +668x |
- .chkname <- function(nm) {
+ split_na_str = split_na_str, |
||
| 979 | -18858x | +292 | +668x |
- if (is.null(nm)) {
+ name = "root", |
| 980 | -! | +|||
| 293 | +668x |
- nm <- ""+ label_children = FALSE, |
||
| 981 | -+ | |||
| 294 | +668x |
- }+ indent_modifier = 0L, |
||
| 982 | -18858x | +295 | +668x |
- if (length(nm) != 1) {
+ content_indent_modifier = 0L, |
| 983 | -! | +|||
| 296 | +668x |
- stop("name is not of length one")
+ content_var = cvar, |
||
| 984 | -18858x | +297 | +668x |
- } else if (is.na(nm)) {
+ split_label_position = "hidden", |
| 985 | -! | +|||
| 298 | +668x |
- warning("Got missing value for name, converting to characters '<NA>'")
+ content_extra_args = cextra_args, |
||
| 986 | -! | +|||
| 299 | +668x |
- nm <- "<NA>"+ child_section_div = NA_character_, |
||
| 987 | -+ | |||
| 300 | +668x |
- }+ child_show_colcounts = FALSE, |
||
| 988 | -18858x | +301 | +668x |
- nm+ child_colcount_format = "(N=xx)" |
| 989 | +302 | ++ |
+ )+ |
+ |
| 303 |
} |
|||
| 990 | +304 | |||
| 991 | +305 |
- ### Tree Position Representation+ setClass("ManualSplit",
|
||
| 992 | +306 |
- ###+ contains = "AllSplit", |
||
| 993 | +307 |
- ### Class(es) that represent position with in a+ representation(levels = "character") |
||
| 994 | +308 |
- ### tree as parallel vectors of Split objects and+ ) |
||
| 995 | +309 |
- ### values chosen at that split, plus labeling info+ |
||
| 996 | +310 |
- TreePos <- function(spls = list(),+ #' Manually defined split |
||
| 997 | +311 |
- svals = list(),+ #' |
||
| 998 | +312 |
- svlabels = character(),+ #' @inheritParams lyt_args |
||
| 999 | +313 |
- sub = NULL) {
+ #' @inheritParams constr_args |
||
| 1000 | -1756x | +|||
| 314 | +
- check_ok_label(svlabels, multi_ok = TRUE)- |
- |||
| 1001 | -1756x | -
- svals <- make_splvalue_vec(vals = svals, subset_exprs = lapply(svals, value_expr))- |
- ||
| 1002 | -1756x | -
- if (is.null(sub)) {
- |
- ||
| 1003 | -377x | -
- if (length(spls) > 0) {
- |
- ||
| 1004 | -! | -
- sub <- make_pos_subset(- |
- ||
| 1005 | -! | -
- spls = spls,- |
- ||
| 1006 | -! | -
- svals = svals+ #' @inheritParams gen_args |
||
| 1007 | +315 |
- )+ #' @param levels (`character`)\cr levels of the split (i.e. the children of the manual split). |
||
| 1008 | +316 |
- } else {
- |
- ||
| 1009 | -377x | -
- sub <- expression(TRUE)+ #' |
||
| 1010 | +317 |
- }+ #' @return A `ManualSplit` object. |
||
| 1011 | +318 |
- }- |
- ||
| 1012 | -1756x | -
- new("TreePos",
- |
- ||
| 1013 | -1756x | -
- splits = spls, s_values = svals,- |
- ||
| 1014 | -1756x | -
- sval_labels = svlabels,- |
- ||
| 1015 | -1756x | -
- subset = sub+ #' |
||
| 1016 | +319 |
- )+ #' @author Gabriel Becker |
||
| 1017 | +320 |
- }+ #' @export |
||
| 1018 | +321 |
-
+ ManualSplit <- function(levels, label, name = "manual", |
||
| 1019 | +322 |
- ## Tree position convenience functions+ extra_args = list(), |
||
| 1020 | +323 |
- ##+ indent_mod = 0L, |
||
| 1021 | +324 |
- make_child_pos <- function(parpos,+ cindent_mod = 0L, |
||
| 1022 | +325 |
- newspl,+ cvar = "", |
||
| 1023 | +326 |
- newval,+ cextra_args = list(), |
||
| 1024 | +327 |
- newlab = newval,+ label_pos = "visible", |
||
| 1025 | +328 |
- newextra = list()) {
- |
- ||
| 1026 | -1379x | -
- if (!is(newval, "SplitValue")) {
- |
- ||
| 1027 | -! | -
- nsplitval <- SplitValue(newval, extr = newextra, label = newlab)+ page_prefix = NA_character_, |
||
| 1028 | +329 |
- } else {
+ section_div = NA_character_) {
|
||
| 1029 | -1379x | +330 | +48x |
- nsplitval <- newval+ label_pos <- match.arg(label_pos, label_pos_values) |
| 1030 | -+ | |||
| 331 | +48x |
- }+ check_ok_label(label, multi_ok = TRUE) |
||
| 1031 | -1379x | +332 | +48x |
- check_ok_label(newlab)+ new("ManualSplit",
|
| 1032 | -1379x | +333 | +48x |
- newpos <- TreePos(+ split_label = label, |
| 1033 | -1379x | +334 | +48x |
- spls = c(pos_splits(parpos), newspl),+ levels = levels, |
| 1034 | -1379x | +335 | +48x |
- svals = c(pos_splvals(parpos), nsplitval),+ name = name, |
| 1035 | -1379x | +336 | +48x |
- svlabels = c(pos_splval_labels(parpos), newlab),+ label_children = FALSE, |
| 1036 | -1379x | +337 | +48x |
- sub = .combine_subset_exprs(+ extra_args = extra_args, |
| 1037 | -1379x | +338 | +48x |
- pos_subset(parpos),+ indent_modifier = 0L, |
| 1038 | -+ | |||
| 339 | +48x |
- ## this will grab the value's custom subset expression if present+ content_indent_modifier = as.integer(cindent_mod), |
||
| 1039 | -1379x | +340 | +48x |
- make_subset_expr(newspl, nsplitval)+ content_var = cvar, |
| 1040 | -+ | |||
| 341 | +48x |
- )+ split_format = NULL, |
||
| 1041 | -+ | |||
| 342 | +48x |
- )+ split_na_str = NA_character_, |
||
| 1042 | -1379x | +343 | +48x |
- newpos+ split_label_position = label_pos, |
| 1043 | -+ | |||
| 344 | +48x |
- }+ page_title_prefix = page_prefix, |
||
| 1044 | -+ | |||
| 345 | +48x |
-
+ child_section_div = section_div, |
||
| 1045 | -+ | |||
| 346 | +48x |
- ## Virtual Classes for Tree Nodes and Layouts =================================+ child_show_colcounts = FALSE, |
||
| 1046 | -+ | |||
| 347 | +48x |
- ##+ child_colcount_format = "(N=xx)" |
||
| 1047 | +348 |
- ## Virtual class hiearchy for the various types of trees in use in the S4+ ) |
||
| 1048 | +349 |
- ## implementation of the TableTree machinery+ } |
||
| 1049 | +350 | |||
| 1050 | +351 |
- ## core basics+ ## splits across which variables are being analynzed |
||
| 1051 | +352 |
- setClass("VNodeInfo",
+ setClass("MultiVarSplit",
|
||
| 1052 | +353 |
- contains = "VIRTUAL",+ contains = "CustomizableSplit", ## "Split", |
||
| 1053 | +354 |
representation( |
||
| 1054 | -- |
- level = "integer",- |
- ||
| 1055 | +355 |
- name = "character" ## ,+ var_labels = "character", |
||
| 1056 | +356 |
- ## label = "character"+ var_names = "character" |
||
| 1057 | +357 |
- )+ ), |
||
| 1058 | +358 |
- )+ validity = function(object) {
|
||
| 1059 | +359 |
-
+ length(object@payload) >= 1 && |
||
| 1060 | +360 |
- setClass("VTree",
+ all(!is.na(object@payload)) && |
||
| 1061 | +361 |
- contains = c("VIRTUAL", "VNodeInfo"),
+ (length(object@var_labels) == 0 || length(object@payload) == length(object@var_labels)) |
||
| 1062 | +362 |
- representation(children = "list")+ } |
||
| 1063 | +363 |
) |
||
| 1064 | -- | - - | -||
| 1065 | -- |
- setClass("VLeaf", contains = c("VIRTUAL", "VNodeInfo"))
- |
- ||
| 1066 | -- | - - | -||
| 1067 | -- |
- ## Layout trees =================================- |
- ||
| 1068 | +364 | |||
| 1069 | +365 |
- # setClass("VLayoutNode", contains= c("VIRTUAL", "VNodeInfo"))
+ .make_suffix_vec <- function(n) {
|
||
| 1070 | -+ | |||
| 366 | +3x |
-
+ c( |
||
| 1071 | +367 |
- setClass("VLayoutLeaf",
+ "", |
||
| 1072 | -+ | |||
| 368 | +3x |
- contains = c("VIRTUAL", "VLeaf"),
+ sprintf( |
||
| 1073 | -+ | |||
| 369 | +3x |
- representation(+ "._[[%d]]_.", |
||
| 1074 | -+ | |||
| 370 | +3x |
- pos_in_tree = "TreePos",+ seq_len(n - 1) + 1L |
||
| 1075 | +371 |
- label = "character"+ ) |
||
| 1076 | +372 |
) |
||
| 1077 | +373 |
- )+ } |
||
| 1078 | +374 | |||
| 1079 | +375 |
- setClass("VLayoutTree",
+ .make_multivar_names <- function(vars) {
|
||
| 1080 | -+ | |||
| 376 | +29x |
- contains = c("VIRTUAL", "VTree"),
+ dups <- duplicated(vars) |
||
| 1081 | -+ | |||
| 377 | +29x |
- representation(+ if (!any(dups)) {
|
||
| 1082 | -+ | |||
| 378 | +26x |
- split = "Split",+ return(vars) |
||
| 1083 | +379 |
- pos_in_tree = "TreePos",+ } |
||
| 1084 | -+ | |||
| 380 | +3x |
- label = "character"+ dupvars <- unique(vars[dups]) |
||
| 1085 | -+ | |||
| 381 | +3x |
- )+ ret <- vars |
||
| 1086 | -+ | |||
| 382 | +3x |
- )+ for (v in dupvars) {
|
||
| 1087 | -+ | |||
| 383 | +3x |
-
+ pos <- which(ret == v) |
||
| 1088 | -+ | |||
| 384 | +3x |
- setClassUnion("VLayoutNode", c("VLayoutLeaf", "VLayoutTree"))
+ ret[pos] <- paste0( |
||
| 1089 | -+ | |||
| 385 | +3x |
-
+ ret[pos], |
||
| 1090 | -+ | |||
| 386 | +3x |
- ## LayoutAxisTree classes =================================+ .make_suffix_vec(length(pos)) |
||
| 1091 | +387 |
-
+ ) |
||
| 1092 | +388 |
- setOldClass("function")
+ } |
||
| 1093 | -+ | |||
| 389 | +3x |
- setOldClass("NULL")
+ ret |
||
| 1094 | +390 |
- setClassUnion("FunctionOrNULL", c("function", "NULL"))
+ } |
||
| 1095 | +391 | |||
| 1096 | +392 |
- setClass("LayoutAxisTree",
+ #' Split between two or more different variables |
||
| 1097 | +393 |
- contains = "VLayoutTree",+ #' |
||
| 1098 | +394 |
- representation(summary_func = "FunctionOrNULL"),+ #' @inheritParams lyt_args |
||
| 1099 | +395 |
- validity = function(object) {
+ #' @inheritParams constr_args |
||
| 1100 | +396 |
- all(sapply(object@children, function(x) is(x, "LayoutAxisTree") || is(x, "LayoutAxisLeaf")))+ #' |
||
| 1101 | +397 |
- }+ #' @return A `MultiVarSplit` object. |
||
| 1102 | +398 |
- )+ #' |
||
| 1103 | +399 |
-
+ #' @author Gabriel Becker |
||
| 1104 | +400 |
- ## this is only used for columns!!!!+ #' @export |
||
| 1105 | +401 |
- setClass("LayoutAxisLeaf",
+ MultiVarSplit <- function(vars, |
||
| 1106 | +402 |
- contains = "VLayoutLeaf", ## "VNodeInfo",+ split_label = "", |
||
| 1107 | +403 |
- representation(+ varlabels = NULL, |
||
| 1108 | +404 |
- func = "function",+ varnames = NULL, |
||
| 1109 | +405 |
- display_columncounts = "logical",+ cfun = NULL, |
||
| 1110 | +406 |
- columncount_format = "FormatSpec", # character",+ cformat = NULL, |
||
| 1111 | +407 |
- col_footnotes = "list",+ cna_str = NA_character_, |
||
| 1112 | +408 |
- column_count = "integer"+ split_format = NULL, |
||
| 1113 | +409 |
- )+ split_na_str = NA_character_, |
||
| 1114 | +410 |
- )+ split_name = "multivars", |
||
| 1115 | +411 |
-
+ child_labels = c("default", "visible", "hidden"),
|
||
| 1116 | +412 |
- setClass("LayoutColTree",
+ extra_args = list(), |
||
| 1117 | +413 |
- contains = "LayoutAxisTree",+ indent_mod = 0L, |
||
| 1118 | +414 |
- representation(+ cindent_mod = 0L, |
||
| 1119 | +415 |
- display_columncounts = "logical",+ cvar = "", |
||
| 1120 | +416 |
- columncount_format = "FormatSpec", # "character",+ cextra_args = list(), |
||
| 1121 | +417 |
- col_footnotes = "list",+ label_pos = "visible", |
||
| 1122 | +418 |
- column_count = "integer"+ split_fun = NULL, |
||
| 1123 | +419 |
- )+ page_prefix = NA_character_, |
||
| 1124 | +420 |
- )+ section_div = NA_character_, |
||
| 1125 | +421 |
-
+ show_colcounts = FALSE, |
||
| 1126 | +422 |
- setClass("LayoutColLeaf", contains = "LayoutAxisLeaf")
+ colcount_format = NULL) {
|
||
| 1127 | -+ | |||
| 423 | +29x |
- LayoutColTree <- function(lev = 0L,+ check_ok_label(split_label) |
||
| 1128 | +424 |
- name = obj_name(spl),+ ## no topleft allowed |
||
| 1129 | -+ | |||
| 425 | +29x |
- label = obj_label(spl),+ label_pos <- match.arg(label_pos, label_pos_values[-3]) |
||
| 1130 | -+ | |||
| 426 | +29x |
- kids = list(),+ child_labels <- match.arg(child_labels) |
||
| 1131 | -+ | |||
| 427 | +29x |
- spl = EmptyAllSplit,+ if (length(vars) == 1 && grepl(":", vars)) {
|
||
| 1132 | -+ | |||
| 428 | +! |
- tpos = TreePos(),+ vars <- strsplit(vars, ":")[[1]] |
||
| 1133 | +429 |
- summary_function = NULL,+ } |
||
| 1134 | -+ | |||
| 430 | +29x |
- disp_ccounts = FALSE,+ if (length(varlabels) == 0) { ## covers NULL and character()
|
||
| 1135 | -+ | |||
| 431 | +1x |
- colcount_format = NULL,+ varlabels <- vars |
||
| 1136 | +432 |
- footnotes = list(),+ } |
||
| 1137 | -+ | |||
| 433 | +29x |
- colcount) { ## ,
+ vnames <- varnames %||% .make_multivar_names(vars) |
||
| 1138 | -+ | |||
| 434 | +29x |
- ## sub = expression(TRUE),+ stopifnot(length(vnames) == length(vars)) |
||
| 1139 | -+ | |||
| 435 | +29x |
- ## svar = NA_character_,+ new("MultiVarSplit",
|
||
| 1140 | -+ | |||
| 436 | +29x |
- ## slab = NA_character_) {
+ payload = vars, |
||
| 1141 | -611x | +437 | +29x |
- if (is.null(spl)) {
+ split_label = split_label, |
| 1142 | -! | +|||
| 438 | +29x |
- stop(+ var_labels = varlabels, |
||
| 1143 | -! | +|||
| 439 | +29x |
- "LayoutColTree constructor got NULL for spl. ", # nocov+ var_names = vnames, |
||
| 1144 | -! | +|||
| 440 | +29x |
- "This should never happen. Please contact the maintainer."+ content_fun = cfun, |
||
| 1145 | -+ | |||
| 441 | +29x |
- )+ content_format = cformat, |
||
| 1146 | -+ | |||
| 442 | +29x |
- } # nocov+ content_na_str = cna_str, |
||
| 1147 | -611x | +443 | +29x |
- footnotes <- make_ref_value(footnotes)+ split_format = split_format, |
| 1148 | -611x | +444 | +29x |
- check_ok_label(label)+ split_na_str = split_na_str, |
| 1149 | -611x | +445 | +29x |
- new("LayoutColTree",
+ label_children = .labelkids_helper(child_labels), |
| 1150 | -611x | +446 | +29x |
- level = lev, children = kids,+ name = split_name, |
| 1151 | -611x | +447 | +29x |
- name = .chkname(name),+ extra_args = extra_args, |
| 1152 | -611x | +448 | +29x |
- summary_func = summary_function,+ indent_modifier = as.integer(indent_mod), |
| 1153 | -611x | +449 | +29x |
- pos_in_tree = tpos,+ content_indent_modifier = as.integer(cindent_mod), |
| 1154 | -611x | +450 | +29x |
- split = spl,+ content_var = cvar, |
| 1155 | -+ | |||
| 451 | +29x |
- ## subset = sub,+ split_label_position = label_pos, |
||
| 1156 | -+ | |||
| 452 | +29x |
- ## splitvar = svar,+ content_extra_args = cextra_args, |
||
| 1157 | -611x | +453 | +29x |
- label = label,+ split_fun = split_fun, |
| 1158 | -611x | +454 | +29x |
- display_columncounts = disp_ccounts,+ page_title_prefix = page_prefix, |
| 1159 | -611x | +455 | +29x |
- columncount_format = colcount_format,+ child_section_div = section_div, |
| 1160 | -611x | +456 | +29x |
- col_footnotes = footnotes,+ child_show_colcounts = show_colcounts, |
| 1161 | -611x | +457 | +29x |
- column_count = colcount+ child_colcount_format = colcount_format |
| 1162 | +458 |
) |
||
| 1163 | +459 |
} |
||
| 1164 | +460 | |||
| 1165 | +461 |
- LayoutColLeaf <- function(lev = 0L,+ #' Splits for cutting by values of a numeric variable |
||
| 1166 | +462 |
- name = label,+ #' |
||
| 1167 | +463 |
- label = "",+ #' @inheritParams lyt_args |
||
| 1168 | +464 |
- tpos = TreePos(),+ #' @inheritParams constr_args |
||
| 1169 | +465 |
- colcount,+ #' |
||
| 1170 | +466 |
- disp_ccounts = FALSE,+ #' @exportClass VarStaticCutSplit |
||
| 1171 | +467 |
- colcount_format = NULL) {
- |
- ||
| 1172 | -1147x | -
- check_ok_label(label)- |
- ||
| 1173 | -1147x | -
- new("LayoutColLeaf",
+ #' @rdname cutsplits |
||
| 1174 | -1147x | +|||
| 468 | +
- level = lev, name = .chkname(name), label = label,+ setClass("VarStaticCutSplit",
|
|||
| 1175 | -1147x | +|||
| 469 | +
- pos_in_tree = tpos,+ contains = "Split", |
|||
| 1176 | -1147x | +|||
| 470 | +
- column_count = colcount,+ representation( |
|||
| 1177 | -1147x | +|||
| 471 | +
- display_columncounts = disp_ccounts,+ cuts = "numeric", |
|||
| 1178 | -1147x | +|||
| 472 | +
- columncount_format = colcount_format+ cut_labels = "character" |
|||
| 1179 | +473 |
) |
||
| 1180 | +474 |
- }+ ) |
||
| 1181 | +475 | |||
| 1182 | +476 |
- ## Instantiated column info class ==============================================+ .is_cut_lab_lst <- function(cuts) {
|
||
| 1183 | -+ | |||
| 477 | +12x |
- ##+ is.list(cuts) && is.numeric(cuts[[1]]) && |
||
| 1184 | -+ | |||
| 478 | +12x |
- ## This is so we don't need multiple arguments+ is.character(cuts[[2]]) && |
||
| 1185 | -+ | |||
| 479 | +12x |
- ## in the recursive functions that track+ length(cuts[[1]]) == length(cuts[[2]]) |
||
| 1186 | +480 |
- ## various aspects of the column layout+ } |
||
| 1187 | +481 |
- ## once its applied to the data.+ |
||
| 1188 | +482 |
-
+ #' Create static cut or static cumulative cut split |
||
| 1189 | +483 |
- #' Instantiated column info+ #' |
||
| 1190 | +484 |
- #'+ #' @inheritParams lyt_args |
||
| 1191 | +485 |
- #' @inheritParams gen_args+ #' @inheritParams constr_args |
||
| 1192 | +486 |
#' |
||
| 1193 | +487 |
- #' @exportClass InstantiatedColumnInfo+ #' @return A `VarStaticCutSplit`, `CumulativeCutSplit` object for `make_static_cut_split`, or a `VarDynCutSplit` |
||
| 1194 | -- |
- #' @rdname cinfo- |
- ||
| 1195 | -- |
- setClass(- |
- ||
| 1196 | -- |
- "InstantiatedColumnInfo",- |
- ||
| 1197 | -- |
- representation(- |
- ||
| 1198 | -- |
- tree_layout = "VLayoutNode", ## LayoutColTree",- |
- ||
| 1199 | -- |
- subset_exprs = "list",- |
- ||
| 1200 | -- |
- cextra_args = "list",- |
- ||
| 1201 | -- |
- counts = "integer",- |
- ||
| 1202 | -- |
- total_count = "integer",- |
- ||
| 1203 | -- |
- display_columncounts = "logical",- |
- ||
| 1204 | -- |
- columncount_format = "FormatSpec",- |
- ||
| 1205 | -- |
- columncount_na_str = "character",- |
- ||
| 1206 | -- |
- top_left = "character"- |
- ||
| 1207 | -- |
- )- |
- ||
| 1208 | -- |
- )- |
- ||
| 1209 | +488 |
-
+ #' object for [VarDynCutSplit()]. |
||
| 1210 | +489 |
- #' @param treelyt (`LayoutColTree`)\cr a `LayoutColTree` object.+ #' |
||
| 1211 | +490 |
- #' @param csubs (`list`)\cr a list of subsetting expressions.+ #' @rdname cutsplits |
||
| 1212 | +491 |
- #' @param extras (`list`)\cr extra arguments associated with the columns.+ make_static_cut_split <- function(var, |
||
| 1213 | +492 |
- #' @param cnts (`integer`)\cr counts.+ split_label, |
||
| 1214 | +493 |
- #' @param total_cnt (`integer(1)`)\cr total observations represented across all columns.+ cuts, |
||
| 1215 | +494 |
- #' @param dispcounts (`flag`)\cr whether the counts should be displayed as header info when the associated+ cutlabels = NULL, |
||
| 1216 | +495 |
- #' table is printed.+ cfun = NULL, |
||
| 1217 | +496 |
- #' @param countformat (`string`)\cr format for the counts if they are displayed.+ cformat = NULL, |
||
| 1218 | +497 |
- #' @param count_na_str (`character`)\cr string to use in place of missing values when formatting counts. Defaults+ cna_str = NA_character_, |
||
| 1219 | +498 |
- #' to `""`.+ split_format = NULL, |
||
| 1220 | +499 |
- #'+ split_na_str = NA_character_, |
||
| 1221 | +500 |
- #' @return An `InstantiateadColumnInfo` object.+ split_name = var, |
||
| 1222 | +501 |
- #'+ child_labels = c("default", "visible", "hidden"),
|
||
| 1223 | +502 |
- #' @export+ extra_args = list(), |
||
| 1224 | +503 |
- #' @rdname cinfo+ indent_mod = 0L, |
||
| 1225 | +504 |
- InstantiatedColumnInfo <- function(treelyt = LayoutColTree(colcount = total_cnt),+ cindent_mod = 0L, |
||
| 1226 | +505 |
- csubs = list(expression(TRUE)),+ cvar = "", |
||
| 1227 | +506 |
- extras = list(list()),+ cextra_args = list(), |
||
| 1228 | +507 |
- cnts = NA_integer_,+ label_pos = "visible", |
||
| 1229 | +508 |
- total_cnt = NA_integer_,+ cumulative = FALSE, |
||
| 1230 | +509 |
- dispcounts = FALSE,+ page_prefix = NA_character_, |
||
| 1231 | +510 |
- countformat = "(N=xx)",+ section_div = NA_character_, |
||
| 1232 | +511 |
- count_na_str = "",+ show_colcounts = FALSE, |
||
| 1233 | +512 |
- topleft = character()) {
- |
- ||
| 1234 | -645x | -
- leaves <- collect_leaves(treelyt)- |
- ||
| 1235 | -645x | -
- nl <- length(leaves)- |
- ||
| 1236 | -645x | -
- extras <- rep(extras, length.out = nl)+ colcount_format = NULL) {
|
||
| 1237 | -645x | +513 | +12x |
- cnts <- rep(cnts, length.out = nl)+ cls <- if (cumulative) "CumulativeCutSplit" else "VarStaticCutSplit" |
| 1238 | -645x | +514 | +12x |
- csubs <- rep(csubs, length.out = nl)+ check_ok_label(split_label) |
| 1239 | +515 | |||
| 1240 | -645x | +516 | +12x |
- nleaves <- length(leaves)+ label_pos <- match.arg(label_pos, label_pos_values) |
| 1241 | -645x | +517 | +12x |
- snas <- sum(is.na(cnts))+ child_labels <- match.arg(child_labels) |
| 1242 | -645x | +518 | +12x |
- if (length(csubs) != nleaves || length(extras) != nleaves || length(cnts) != nleaves) {
+ if (.is_cut_lab_lst(cuts)) {
|
| 1243 | +519 | ! |
- stop(+ cutlabels <- cuts[[2]] |
|
| 1244 | +520 | ! |
- "Mismatching number of columns indicated by: csubs [",+ cuts <- cuts[[1]] |
|
| 1245 | -! | +|||
| 521 | +
- length(csubs), "], ",+ } |
|||
| 1246 | -! | +|||
| 522 | +12x |
- "treelyt [", nl, "], extras [", length(extras),+ if (is.unsorted(cuts, strictly = TRUE)) {
|
||
| 1247 | +523 | ! |
- "] and counts [", cnts, "]."+ stop("invalid cuts vector. not sorted unique values.")
|
|
| 1248 | +524 |
- )+ } |
||
| 1249 | +525 |
- }+ |
||
| 1250 | -645x | +526 | +12x |
- if (snas != 0 && snas != nleaves) {
+ if (is.null(cutlabels) && !is.null(names(cuts))) {
|
| 1251 | -2x | +527 | +1x |
- warning(+ cutlabels <- names(cuts)[-1] |
| 1252 | -2x | +|||
| 528 | +
- "Mixture of missing and non-missing column counts when ",+ } ## XXX is this always right? |
|||
| 1253 | -2x | +|||
| 529 | +
- "creating column info."+ |
|||
| 1254 | -+ | |||
| 530 | +12x |
- )+ new(cls, |
||
| 1255 | -+ | |||
| 531 | +12x |
- }+ payload = var, |
||
| 1256 | -+ | |||
| 532 | +12x |
-
+ split_label = split_label, |
||
| 1257 | -645x | +533 | +12x |
- if (!is.na(dispcounts)) {
+ cuts = cuts, |
| 1258 | -407x | +534 | +12x |
- pths <- col_paths(treelyt)+ cut_labels = cutlabels, |
| 1259 | -407x | +535 | +12x |
- for (path in pths) {
+ content_fun = cfun, |
| 1260 | -917x | +536 | +12x |
- colcount_visible(treelyt, path) <- dispcounts+ content_format = cformat, |
| 1261 | -+ | |||
| 537 | +12x |
- }+ content_na_str = cna_str, |
||
| 1262 | -+ | |||
| 538 | +12x |
- } else { ## na leaves the children as they are and dispcols goes to whether any of them are displayed for the leaves
+ split_format = split_format, |
||
| 1263 | -238x | +539 | +12x |
- dispcounts <- any(vapply(leaves, disp_ccounts, NA))+ split_na_str = split_na_str, |
| 1264 | -+ | |||
| 540 | +12x |
- }+ name = split_name, |
||
| 1265 | -+ | |||
| 541 | +12x |
-
+ label_children = .labelkids_helper(child_labels), |
||
| 1266 | -645x | +542 | +12x |
- new("InstantiatedColumnInfo",
+ extra_args = extra_args, |
| 1267 | -645x | +543 | +12x |
- tree_layout = treelyt,+ indent_modifier = as.integer(indent_mod), |
| 1268 | -645x | +544 | +12x |
- subset_exprs = csubs,+ content_indent_modifier = as.integer(cindent_mod), |
| 1269 | -645x | +545 | +12x |
- cextra_args = extras,+ content_var = cvar, |
| 1270 | -645x | +546 | +12x |
- counts = cnts,+ split_label_position = label_pos, |
| 1271 | -645x | +547 | +12x |
- total_count = total_cnt,+ content_extra_args = cextra_args, |
| 1272 | -645x | +548 | +12x |
- display_columncounts = dispcounts,+ page_title_prefix = page_prefix, |
| 1273 | -645x | +549 | +12x |
- columncount_format = countformat,+ child_section_div = section_div, |
| 1274 | -645x | +550 | +12x |
- columncount_na_str = count_na_str,+ child_show_colcounts = show_colcounts, |
| 1275 | -645x | +551 | +12x |
- top_left = topleft+ child_colcount_format = colcount_format |
| 1276 | +552 |
) |
||
| 1277 | +553 |
} |
||
| 1278 | +554 | |||
| 1279 | +555 |
- ## TableTrees and row classes ==================================================+ #' @exportClass CumulativeCutSplit |
||
| 1280 | +556 |
- ## XXX Rowspans as implemented dont really work+ #' @rdname cutsplits |
||
| 1281 | +557 |
- ## they're aren't attached to the right data structures+ setClass("CumulativeCutSplit", contains = "VarStaticCutSplit")
|
||
| 1282 | +558 |
- ## during conversions.+ |
||
| 1283 | +559 |
-
+ ## make_static_cut_split with cumulative=TRUE is the constructor |
||
| 1284 | +560 |
- ## FIXME: if we ever actually need row spanning+ ## for CumulativeCutSplit |
||
| 1285 | +561 |
- setClass("VTableNodeInfo",
+
|
||
| 1286 | +562 |
- contains = c("VNodeInfo", "VIRTUAL"),
+ ## do we want this to be a CustomizableSplit instead of |
||
| 1287 | +563 |
- representation(+ ## taking cut_fun? |
||
| 1288 | +564 |
- ## col_layout = "VLayoutNode",+ ## cut_funct must take avector and no other arguments |
||
| 1289 | +565 |
- col_info = "InstantiatedColumnInfo",+ ## and return a named vector of cut points |
||
| 1290 | +566 |
- format = "FormatSpec",+ #' @exportClass VarDynCutSplit |
||
| 1291 | +567 |
- na_str = "character",+ #' @rdname cutsplits |
||
| 1292 | +568 |
- indent_modifier = "integer",+ setClass("VarDynCutSplit",
|
||
| 1293 | +569 |
- table_inset = "integer"+ contains = "Split", |
||
| 1294 | +570 |
- )+ representation( |
||
| 1295 | +571 |
- )+ cut_fun = "function", |
||
| 1296 | +572 |
-
+ cut_label_fun = "function", |
||
| 1297 | +573 |
- setClass("TableRow",
+ cumulative_cuts = "logical" |
||
| 1298 | +574 |
- contains = c("VIRTUAL", "VLeaf", "VTableNodeInfo"),
+ ) |
||
| 1299 | +575 |
- representation(+ ) |
||
| 1300 | +576 |
- leaf_value = "ANY",+ |
||
| 1301 | +577 |
- var_analyzed = "character",+ #' @export |
||
| 1302 | +578 |
- ## var_label = "character",+ #' @rdname cutsplits |
||
| 1303 | +579 |
- label = "character",+ VarDynCutSplit <- function(var, |
||
| 1304 | +580 |
- row_footnotes = "list",+ split_label, |
||
| 1305 | +581 |
- trailing_section_div = "character"+ cutfun, |
||
| 1306 | +582 |
- )+ cutlabelfun = function(x) NULL, |
||
| 1307 | +583 |
- )+ cfun = NULL, |
||
| 1308 | +584 |
-
+ cformat = NULL, |
||
| 1309 | +585 |
- ## TableTree Core Non-Virtual Classes ==============+ cna_str = NA_character_, |
||
| 1310 | +586 |
- ##+ split_format = NULL, |
||
| 1311 | +587 |
- #' Row classes and constructors+ split_na_str = NA_character_, |
||
| 1312 | +588 |
- #'+ split_name = var, |
||
| 1313 | +589 |
- #' @inheritParams constr_args+ child_labels = c("default", "visible", "hidden"),
|
||
| 1314 | +590 |
- #' @inheritParams lyt_args+ extra_args = list(), |
||
| 1315 | +591 |
- #' @param vis (`flag`)\cr whether the row should be visible (`LabelRow` only).+ cumulative = FALSE, |
||
| 1316 | +592 |
- #'+ indent_mod = 0L, |
||
| 1317 | +593 |
- #' @return A formal object representing a table row of the constructed type.+ cindent_mod = 0L, |
||
| 1318 | +594 |
- #'+ cvar = "", |
||
| 1319 | +595 |
- #' @author Gabriel Becker+ cextra_args = list(), |
||
| 1320 | +596 |
- #' @export+ label_pos = "visible", |
||
| 1321 | +597 |
- #' @rdname rowclasses+ page_prefix = NA_character_, |
||
| 1322 | +598 |
- LabelRow <- function(lev = 1L,+ section_div = NA_character_, |
||
| 1323 | +599 |
- label = "",+ show_colcounts = FALSE, |
||
| 1324 | +600 |
- name = label,+ colcount_format = NULL) {
|
||
| 1325 | -+ | |||
| 601 | +6x |
- vis = !is.na(label) && nzchar(label),+ check_ok_label(split_label) |
||
| 1326 | -+ | |||
| 602 | +6x |
- cinfo = EmptyColInfo,+ label_pos <- match.arg(label_pos, label_pos_values) |
||
| 1327 | -+ | |||
| 603 | +6x |
- indent_mod = 0L,+ child_labels <- match.arg(child_labels) |
||
| 1328 | -+ | |||
| 604 | +6x |
- table_inset = 0L,+ new("VarDynCutSplit",
|
||
| 1329 | -+ | |||
| 605 | +6x |
- trailing_section_div = NA_character_) {
+ payload = var, |
||
| 1330 | -4711x | +606 | +6x |
- check_ok_label(label)+ split_label = split_label, |
| 1331 | -4711x | +607 | +6x |
- new("LabelRow",
+ cut_fun = cutfun, |
| 1332 | -4711x | +608 | +6x |
- leaf_value = list(),+ cumulative_cuts = cumulative, |
| 1333 | -4711x | +609 | +6x |
- level = lev,+ cut_label_fun = cutlabelfun, |
| 1334 | -4711x | +610 | +6x |
- label = label,+ content_fun = cfun, |
| 1335 | -+ | |||
| 611 | +6x |
- ## XXX this means that a label row and its talbe can have the same name....+ content_format = cformat, |
||
| 1336 | -+ | |||
| 612 | +6x |
- ## XXX that is bad but how bad remains to be seen+ content_na_str = cna_str, |
||
| 1337 | -+ | |||
| 613 | +6x |
- ## XXX+ split_format = split_format, |
||
| 1338 | -4711x | +614 | +6x |
- name = .chkname(name),+ split_na_str = split_na_str, |
| 1339 | -4711x | +615 | +6x |
- col_info = cinfo,+ name = split_name, |
| 1340 | -4711x | +616 | +6x |
- visible = vis,+ label_children = .labelkids_helper(child_labels), |
| 1341 | -4711x | +617 | +6x | +
+ extra_args = extra_args,+ |
+
| 618 | +6x |
indent_modifier = as.integer(indent_mod), |
||
| 1342 | -4711x | +619 | +6x |
- table_inset = as.integer(table_inset),+ content_indent_modifier = as.integer(cindent_mod), |
| 1343 | -4711x | +620 | +6x |
- trailing_section_div = trailing_section_div+ content_var = cvar, |
| 1344 | -+ | |||
| 621 | +6x |
- )+ split_label_position = label_pos, |
||
| 1345 | -+ | |||
| 622 | +6x |
- }+ content_extra_args = cextra_args, |
||
| 1346 | -+ | |||
| 623 | +6x |
-
+ page_title_prefix = page_prefix, |
||
| 1347 | -+ | |||
| 624 | +6x |
- #' Row constructors and classes+ child_section_div = section_div, |
||
| 1348 | -+ | |||
| 625 | +6x |
- #'+ child_show_colcounts = show_colcounts, |
||
| 1349 | -+ | |||
| 626 | +6x |
- #' @rdname rowclasses+ child_colcount_format = colcount_format |
||
| 1350 | +627 |
- #' @exportClass DataRow+ ) |
||
| 1351 | +628 |
- setClass("DataRow",
+ } |
||
| 1352 | +629 |
- contains = "TableRow",+ |
||
| 1353 | +630 |
- representation(colspans = "integer") ## ,+ ## NB analyze splits can't have content-related things |
||
| 1354 | +631 |
- ## pos_in_tree = "TableRowPos"),+ setClass("VAnalyzeSplit",
|
||
| 1355 | +632 |
- ## validity = function(object) {
+ contains = "Split", |
||
| 1356 | +633 |
- ## lcsp = length(object@colspans)+ representation( |
||
| 1357 | +634 |
- ## length(lcsp == 0) || lcsp == length(object@leaf_value)+ default_rowlabel = "character", |
||
| 1358 | +635 |
- ## }+ include_NAs = "logical", |
||
| 1359 | +636 |
- )+ var_label_position = "character" |
||
| 1360 | +637 |
-
+ ) |
||
| 1361 | +638 |
- #' @rdname rowclasses+ ) |
||
| 1362 | +639 |
- #' @exportClass ContentRow+ |
||
| 1363 | +640 |
- setClass("ContentRow",
+ setClass("AnalyzeVarSplit",
|
||
| 1364 | +641 |
- contains = "TableRow",+ contains = "VAnalyzeSplit", |
||
| 1365 | +642 |
- representation(colspans = "integer") ## ,+ representation(analysis_fun = "function") |
||
| 1366 | +643 |
- ## pos_in_tree = "TableRowPos"),+ ) |
||
| 1367 | +644 |
- ## validity = function(object) {
+
|
||
| 1368 | +645 |
- ## lcsp = length(object@colspans)+ setClass("AnalyzeColVarSplit",
|
||
| 1369 | +646 |
- ## length(lcsp == 0) || lcsp == length(object@leaf_value)+ contains = "VAnalyzeSplit", |
||
| 1370 | +647 |
- ## }+ representation(analysis_fun = "list") |
||
| 1371 | +648 |
) |
||
| 1372 | +649 | |||
| 1373 | +650 |
- #' @rdname rowclasses+ #' Define a subset tabulation/analysis |
||
| 1374 | +651 |
- #' @exportClass LabelRow+ #' |
||
| 1375 | +652 |
- setClass("LabelRow",
+ #' @inheritParams lyt_args |
||
| 1376 | +653 |
- contains = "TableRow",+ #' @inheritParams constr_args |
||
| 1377 | +654 |
- representation(visible = "logical")+ #' @param defrowlab (`character`)\cr default row labels, if not specified by the return value of `afun`. |
||
| 1378 | +655 |
- )+ #' |
||
| 1379 | +656 |
-
+ #' @return An `AnalyzeVarSplit` object. |
||
| 1380 | +657 |
- #' @param klass (`character`)\cr internal detail.+ #' |
||
| 1381 | +658 |
- #'+ #' @author Gabriel Becker |
||
| 1382 | +659 |
#' @export |
||
| 1383 | +660 |
- #' @rdname rowclasses+ #' @rdname avarspl |
||
| 1384 | +661 |
- .tablerow <- function(vals = list(),+ AnalyzeVarSplit <- function(var, |
||
| 1385 | +662 |
- name = "",+ split_label = var, |
||
| 1386 | +663 |
- lev = 1L,+ afun, |
||
| 1387 | +664 |
- label = name,+ defrowlab = "", |
||
| 1388 | +665 |
- cspan = rep(1L, length(vals)),+ cfun = NULL, |
||
| 1389 | +666 |
- cinfo = EmptyColInfo,+ cformat = NULL, |
||
| 1390 | +667 |
- var = NA_character_,+ split_format = NULL, |
||
| 1391 | +668 |
- format = NULL,+ split_na_str = NA_character_, |
||
| 1392 | +669 |
- na_str = NA_character_,+ inclNAs = FALSE, |
||
| 1393 | +670 |
- klass,+ split_name = var, |
||
| 1394 | +671 |
- indent_mod = 0L,+ extra_args = list(), |
||
| 1395 | +672 |
- footnotes = list(),+ indent_mod = 0L, |
||
| 1396 | +673 |
- table_inset = 0L,+ label_pos = "default", |
||
| 1397 | +674 |
- trailing_section_div = NA_character_) {
+ cvar = "", |
||
| 1398 | -3256x | +|||
| 675 | +
- if ((missing(name) || is.null(name) || is.na(name) || nchar(name) == 0) && !missing(label)) {
+ section_div = NA_character_) {
|
|||
| 1399 | -257x | +676 | +346x |
- name <- label+ check_ok_label(split_label) |
| 1400 | -+ | |||
| 677 | +346x |
- }+ label_pos <- match.arg(label_pos, c("default", label_pos_values))
|
||
| 1401 | -3256x | +678 | +346x |
- vals <- lapply(vals, rcell)+ if (!any(nzchar(defrowlab))) {
|
| 1402 | -3256x | +679 | +1x |
- rlabels <- unique(unlist(lapply(vals, obj_label)))+ defrowlab <- as.character(substitute(afun)) |
| 1403 | -3256x | +680 | +1x |
- if ((missing(label) || is.null(label) || identical(label, "")) && sum(nzchar(rlabels)) == 1) {
+ if (length(defrowlab) > 1 || startsWith(defrowlab, "function(")) {
|
| 1404 | +681 | ! |
- label <- rlabels[nzchar(rlabels)]+ defrowlab <- "" |
|
| 1405 | +682 |
- }- |
- ||
| 1406 | -3256x | -
- if (missing(cspan) && !is.null(unlist(lapply(vals, cell_cspan)))) {
- |
- ||
| 1407 | -2998x | -
- cspan <- vapply(vals, cell_cspan, 0L)+ } |
||
| 1408 | +683 |
} |
||
| 1409 | -- | - - | -||
| 1410 | -3256x | +684 | +346x |
- check_ok_label(label)+ new("AnalyzeVarSplit",
|
| 1411 | -3256x | +685 | +346x |
- rw <- new(klass,+ payload = var, |
| 1412 | -3256x | +686 | +346x |
- leaf_value = vals,+ split_label = split_label, |
| 1413 | -3256x | +687 | +346x |
- name = .chkname(name),+ content_fun = cfun, |
| 1414 | -3256x | +688 | +346x |
- level = lev,+ analysis_fun = afun, |
| 1415 | -3256x | +689 | +346x |
- label = .chkname(label),+ content_format = cformat, |
| 1416 | -3256x | +690 | +346x |
- colspans = cspan,+ split_format = split_format, |
| 1417 | -3256x | +691 | +346x |
- col_info = cinfo,+ split_na_str = split_na_str, |
| 1418 | -3256x | -
- var_analyzed = var,- |
- ||
| 1419 | -+ | 692 | +346x |
- ## these are set in set_format_recursive below+ default_rowlabel = defrowlab, |
| 1420 | -3256x | +693 | +346x |
- format = NULL,+ include_NAs = inclNAs, |
| 1421 | -3256x | +694 | +346x |
- na_str = NA_character_,+ name = split_name, |
| 1422 | -3256x | +695 | +346x |
- indent_modifier = indent_mod,+ label_children = FALSE, |
| 1423 | -3256x | +696 | +346x |
- row_footnotes = footnotes,+ extra_args = extra_args, |
| 1424 | -3256x | +697 | +346x |
- table_inset = table_inset,+ indent_modifier = as.integer(indent_mod), |
| 1425 | -3256x | -
- trailing_section_div = trailing_section_div- |
- ||
| 1426 | -+ | 698 | +346x |
- )+ content_indent_modifier = 0L, |
| 1427 | -3256x | +699 | +346x |
- rw <- set_format_recursive(rw, format, na_str, FALSE)+ var_label_position = label_pos, |
| 1428 | -3256x | +700 | +346x |
- rw+ content_var = cvar, |
| 1429 | -+ | |||
| 701 | +346x |
- }+ page_title_prefix = NA_character_, |
||
| 1430 | -+ | |||
| 702 | +346x |
-
+ child_section_div = section_div, |
||
| 1431 | -+ | |||
| 703 | +346x |
- #' @param ... additional parameters passed to shared constructor (`.tablerow`).+ child_show_colcounts = FALSE, |
||
| 1432 | -+ | |||
| 704 | +346x |
- #'+ child_colcount_format = NA_character_ |
||
| 1433 | -+ | |||
| 705 | +346x |
- #' @export+ ) ## no content_extra_args |
||
| 1434 | +706 |
- #' @rdname rowclasses- |
- ||
| 1435 | -2732x | -
- DataRow <- function(...) .tablerow(..., klass = "DataRow")+ } |
||
| 1436 | +707 | |||
| 1437 | +708 |
- #' @export+ #' Define a subset tabulation/analysis |
||
| 1438 | +709 |
- #' @rdname rowclasses- |
- ||
| 1439 | -524x | -
- ContentRow <- function(...) .tablerow(..., klass = "ContentRow")+ #' |
||
| 1440 | +710 |
-
+ #' @inheritParams lyt_args |
||
| 1441 | +711 |
- setClass("VTitleFooter",
+ #' @inheritParams constr_args |
||
| 1442 | +712 |
- contains = "VIRTUAL",+ #' |
||
| 1443 | +713 |
- representation(+ #' @author Gabriel Becker |
||
| 1444 | +714 |
- main_title = "character",+ #' @export |
||
| 1445 | +715 |
- subtitles = "character",+ #' @rdname avarspl |
||
| 1446 | +716 |
- main_footer = "character",+ AnalyzeColVarSplit <- function(afun, |
||
| 1447 | +717 |
- provenance_footer = "character"+ defrowlab = "", |
||
| 1448 | +718 |
- )+ cfun = NULL, |
||
| 1449 | +719 |
- )+ cformat = NULL, |
||
| 1450 | +720 |
-
+ split_format = NULL, |
||
| 1451 | +721 |
- setClass("VTableTree",
+ split_na_str = NA_character_, |
||
| 1452 | +722 |
- contains = c("VIRTUAL", "VTableNodeInfo", "VTree", "VTitleFooter"),
+ inclNAs = FALSE, |
||
| 1453 | +723 |
- representation(+ split_name = "", |
||
| 1454 | +724 |
- children = "list",+ extra_args = list(), |
||
| 1455 | +725 |
- rowspans = "data.frame",+ indent_mod = 0L, |
||
| 1456 | +726 |
- labelrow = "LabelRow",+ label_pos = "default", |
||
| 1457 | +727 |
- page_titles = "character",+ cvar = "", |
||
| 1458 | +728 |
- horizontal_sep = "character",+ section_div = NA_character_) {
|
||
| 1459 | -+ | |||
| 729 | +23x |
- header_section_div = "character",+ label_pos <- match.arg(label_pos, c("default", label_pos_values))
|
||
| 1460 | -+ | |||
| 730 | +23x |
- trailing_section_div = "character"+ new("AnalyzeColVarSplit",
|
||
| 1461 | -+ | |||
| 731 | +23x |
- )+ payload = NA_character_, |
||
| 1462 | -+ | |||
| 732 | +23x |
- )+ split_label = "", |
||
| 1463 | -+ | |||
| 733 | +23x |
-
+ content_fun = cfun, |
||
| 1464 | -+ | |||
| 734 | +23x |
- setClassUnion("IntegerOrNull", c("integer", "NULL"))
+ analysis_fun = afun, |
||
| 1465 | -+ | |||
| 735 | +23x |
- ## covered because it's ElementaryTable's validity method but covr misses it+ content_format = cformat, |
||
| 1466 | -+ | |||
| 736 | +23x |
- ## nocov start+ split_format = split_format, |
||
| 1467 | -+ | |||
| 737 | +23x |
- etable_validity <- function(object) {
+ split_na_str = split_na_str, |
||
| 1468 | -+ | |||
| 738 | +23x |
- kids <- tree_children(object)+ default_rowlabel = defrowlab, |
||
| 1469 | -+ | |||
| 739 | +23x |
- all(sapply(+ include_NAs = inclNAs, |
||
| 1470 | -+ | |||
| 740 | +23x |
- kids,+ name = split_name, |
||
| 1471 | -+ | |||
| 741 | +23x |
- function(k) {
+ label_children = FALSE, |
||
| 1472 | -+ | |||
| 742 | +23x |
- (is(k, "DataRow") || is(k, "ContentRow"))+ extra_args = extra_args, |
||
| 1473 | -+ | |||
| 743 | +23x |
- }+ indent_modifier = as.integer(indent_mod), |
||
| 1474 | -+ | |||
| 744 | +23x |
- )) ### &&+ content_indent_modifier = 0L, |
||
| 1475 | -+ | |||
| 745 | +23x |
- }+ var_label_position = label_pos, |
||
| 1476 | -+ | |||
| 746 | +23x |
- ## nocov end+ content_var = cvar, |
||
| 1477 | -+ | |||
| 747 | +23x |
-
+ page_title_prefix = NA_character_, |
||
| 1478 | -+ | |||
| 748 | +23x |
- #' `TableTree` classes+ child_section_div = section_div, |
||
| 1479 | -+ | |||
| 749 | +23x |
- #'+ child_show_colcounts = FALSE, |
||
| 1480 | -+ | |||
| 750 | +23x |
- #' @return A formal object representing a populated table.+ child_colcount_format = NA_character_ |
||
| 1481 | -+ | |||
| 751 | +23x |
- #'+ ) ## no content_extra_args |
||
| 1482 | +752 |
- #' @author Gabriel Becker+ } |
||
| 1483 | +753 |
- #' @exportClass ElementaryTable+ |
||
| 1484 | +754 |
- #' @rdname tabclasses+ setClass("CompoundSplit",
|
||
| 1485 | +755 |
- setClass("ElementaryTable",
+ contains = "Split", |
||
| 1486 | +756 |
- contains = "VTableTree",+ validity = function(object) are(object@payload, "Split") |
||
| 1487 | +757 |
- representation(var_analyzed = "character"),+ ) |
||
| 1488 | +758 |
- validity = etable_validity ## function(object) {
+
|
||
| 1489 | +759 |
- )+ setClass("AnalyzeMultiVars", contains = "CompoundSplit")
|
||
| 1490 | +760 | |||
| 1491 | -- |
- .enforce_valid_kids <- function(lst, colinfo) {
- |
- ||
| 1492 | +761 |
- ## colinfo+ .repoutlst <- function(x, nv) {
|
||
| 1493 | -5877x | +762 | +1878x |
- if (!no_colinfo(colinfo)) {
+ if (!is.function(x) && length(x) == nv) {
|
| 1494 | -5877x | +763 | +893x |
- lst <- lapply(+ return(x) |
| 1495 | -5877x | +|||
| 764 | +
- lst,+ } |
|||
| 1496 | -5877x | +765 | +985x |
- function(x) {
+ if (!is(x, "list")) {
|
| 1497 | -7322x | +766 | +985x |
- if (no_colinfo(x)) {
+ x <- list(x) |
| 1498 | -208x | +|||
| 767 | +
- col_info(x) <- colinfo+ } |
|||
| 1499 | -7114x | -
- } else if (!identical(colinfo, col_info(x), ignore.environment = TRUE)) {
- |
- ||
| 1500 | -+ | 768 | +985x |
- ## split functions from function factories (e.g. add_combo_levels)+ rep(x, length.out = nv) |
| 1501 | +769 |
- ## have different environments so we can't use identical here+ } |
||
| 1502 | +770 |
- ## all.equal requires the **values within the closures** to be the+ |
||
| 1503 | +771 |
- ## same but not the actual enclosing environments.- |
- ||
| 1504 | -! | -
- stop(+ .uncompound <- function(csplit) {
|
||
| 1505 | -! | +|||
| 772 | +63x |
- "attempted to add child with non-matching, non-empty ",+ if (is(csplit, "list")) {
|
||
| 1506 | -! | +|||
| 773 | +3x |
- "column info to an existing table"+ return(unlist(lapply(csplit, .uncompound))) |
||
| 1507 | +774 |
- )+ } |
||
| 1508 | +775 |
- }+ |
||
| 1509 | -7322x | -
- x- |
- ||
| 1510 | -+ | 776 | +60x |
- }+ if (!is(csplit, "CompoundSplit")) {
|
| 1511 | -+ | |||
| 777 | +59x |
- )+ return(csplit) |
||
| 1512 | +778 |
} |
||
| 1513 | +779 | |||
| 1514 | -5877x | +780 | +1x |
- if (are(lst, "ElementaryTable") &&+ pld <- spl_payload(csplit) |
| 1515 | -5877x | +781 | +1x |
- all(sapply(lst, function(tb) {
+ done <- all(!vapply(pld, is, TRUE, class2 = "CompoundSplit")) |
| 1516 | -1014x | -
- nrow(tb) <= 1 && identical(obj_name(tb), "")- |
- ||
| 1517 | -+ | 782 | +1x |
- }))) {
+ if (done) {
|
| 1518 | -1562x | +783 | +1x |
- lst <- unlist(lapply(lst, function(tb) tree_children(tb)[[1]]))+ pld |
| 1519 | +784 |
- }- |
- ||
| 1520 | -5877x | -
- if (length(lst) == 0) {
+ } else {
|
||
| 1521 | -1562x | +|||
| 785 | +! |
- return(list())+ unlist(lapply(pld, .uncompound)) |
||
| 1522 | +786 |
} |
||
| 1523 | +787 |
- ## names- |
- ||
| 1524 | -4315x | -
- realnames <- sapply(lst, obj_name)- |
- ||
| 1525 | -4315x | -
- lstnames <- names(lst)+ } |
||
| 1526 | -4315x | +|||
| 788 | +
- if (is.null(lstnames)) {
+
|
|||
| 1527 | -1850x | +|||
| 789 | +
- names(lst) <- realnames+ strip_compound_name <- function(obj) {
|
|||
| 1528 | -2465x | +790 | +11x |
- } else if (!identical(realnames, lstnames)) {
+ nm <- obj_name(obj) |
| 1529 | -2465x | +791 | +11x |
- names(lst) <- realnames+ gsub("^ma_", "", nm)
|
| 1530 | +792 |
- }+ } |
||
| 1531 | +793 | |||
| 1532 | -4315x | -
- lst- |
- ||
| 1533 | +794 |
- }+ make_ma_name <- function(spl, pld = spl_payload(spl)) {
|
||
| 1534 | -+ | |||
| 795 | +3x |
-
+ paste( |
||
| 1535 | -+ | |||
| 796 | +3x |
- #' Table constructors and classes+ c( |
||
| 1536 | -+ | |||
| 797 | +3x |
- #'+ "ma", |
||
| 1537 | -+ | |||
| 798 | +3x |
- #' @inheritParams constr_args+ vapply(pld, strip_compound_name, "") |
||
| 1538 | +799 |
- #' @inheritParams gen_args+ ), |
||
| 1539 | -+ | |||
| 800 | +3x |
- #' @inheritParams lyt_args+ collapse = "_" |
||
| 1540 | +801 |
- #' @param rspans (`data.frame`)\cr currently stored but otherwise ignored.+ ) |
||
| 1541 | +802 |
- #'+ } |
||
| 1542 | +803 |
- #' @author Gabriel Becker+ |
||
| 1543 | +804 |
- #' @export+ #' @param .payload (`list`)\cr used internally, not intended to be set by end users. |
||
| 1544 | +805 |
- #' @rdname tabclasses+ #' |
||
| 1545 | +806 |
- ElementaryTable <- function(kids = list(),+ #' @return An `AnalyzeMultiVars` split object. |
||
| 1546 | +807 |
- name = "",+ #' |
||
| 1547 | +808 |
- lev = 1L,+ #' @export |
||
| 1548 | +809 |
- label = "",+ #' @rdname avarspl |
||
| 1549 | +810 |
- labelrow = LabelRow(+ AnalyzeMultiVars <- function(var, |
||
| 1550 | +811 |
- lev = lev,+ split_label = "", |
||
| 1551 | +812 |
- label = label,+ afun, |
||
| 1552 | +813 |
- vis = !isTRUE(iscontent) &&+ defrowlab = "", |
||
| 1553 | +814 |
- !is.na(label) &&+ cfun = NULL, |
||
| 1554 | +815 |
- nzchar(label)+ cformat = NULL, |
||
| 1555 | +816 |
- ),+ split_format = NULL, |
||
| 1556 | +817 |
- rspans = data.frame(),+ split_na_str = NA_character_, |
||
| 1557 | +818 |
- cinfo = NULL,+ inclNAs = FALSE, |
||
| 1558 | +819 |
- iscontent = NA,+ .payload = NULL, |
||
| 1559 | +820 |
- var = NA_character_,+ split_name = NULL, |
||
| 1560 | +821 |
- format = NULL,+ extra_args = list(), |
||
| 1561 | +822 |
- na_str = NA_character_,+ indent_mod = 0L, |
||
| 1562 | +823 |
- indent_mod = 0L,+ child_labels = c("default", "topleft", "visible", "hidden"),
|
||
| 1563 | +824 |
- title = "",+ child_names = var, |
||
| 1564 | +825 |
- subtitles = character(),+ cvar = "", |
||
| 1565 | +826 |
- main_footer = character(),+ section_div = NA_character_) {
|
||
| 1566 | +827 |
- prov_footer = character(),+ ## NB we used to resolve to strict TRUE/FALSE for label visibillity |
||
| 1567 | +828 |
- header_section_div = NA_character_,+ ## in this function but that was too greedy for repeated |
||
| 1568 | +829 |
- hsep = default_hsep(),+ ## analyze calls, so that now occurs in the tabulation machinery |
||
| 1569 | +830 |
- trailing_section_div = NA_character_,+ ## when the table is actually being built. |
||
| 1570 | +831 |
- inset = 0L) {
+ ## show_kidlabs = .labelkids_helper(match.arg(child_labels)) |
||
| 1571 | -3051x | +832 | +338x |
- check_ok_label(label)+ child_labels <- match.arg(child_labels) |
| 1572 | -3051x | -
- if (is.null(cinfo)) {
- |
- ||
| 1573 | -! | +833 | +338x |
- if (length(kids) > 0) {
+ show_kidlabs <- child_labels |
| 1574 | -! | +|||
| 834 | +338x |
- cinfo <- col_info(kids[[1]])+ if (is.null(.payload)) {
|
||
| 1575 | -+ | |||
| 835 | +313x |
- } else {
+ nv <- length(var) |
||
| 1576 | -! | +|||
| 836 | +313x |
- cinfo <- EmptyColInfo+ defrowlab <- .repoutlst(defrowlab, nv) |
||
| 1577 | -+ | |||
| 837 | +313x |
- }+ afun <- .repoutlst(afun, nv) |
||
| 1578 | -+ | |||
| 838 | +313x |
- }+ split_label <- .repoutlst(split_label, nv) |
||
| 1579 | -+ | |||
| 839 | +313x |
-
+ check_ok_label(split_label, multi_ok = TRUE) |
||
| 1580 | -3051x | +840 | +313x |
- if (no_colinfo(labelrow)) {
+ cfun <- .repoutlst(cfun, nv) |
| 1581 | -1881x | +841 | +313x |
- col_info(labelrow) <- cinfo+ cformat <- .repoutlst(cformat, nv) |
| 1582 | +842 |
- }+ ## split_format = .repoutlst(split_format, nv) |
||
| 1583 | -3051x | +843 | +313x |
- kids <- .enforce_valid_kids(kids, cinfo)+ inclNAs <- .repoutlst(inclNAs, nv) |
| 1584 | -3051x | +844 | +313x |
- tab <- new("ElementaryTable",
+ section_div_if_multivar <- if (length(var) > 1) NA_character_ else section_div |
| 1585 | -3051x | +845 | +313x |
- children = kids,+ pld <- mapply(AnalyzeVarSplit, |
| 1586 | -3051x | +846 | +313x |
- name = .chkname(name),+ var = var, |
| 1587 | -3051x | +847 | +313x |
- level = lev,+ split_name = child_names, |
| 1588 | -3051x | +848 | +313x |
- labelrow = labelrow,+ split_label = split_label, |
| 1589 | -3051x | +849 | +313x |
- rowspans = rspans,+ afun = afun, |
| 1590 | -3051x | +850 | +313x |
- col_info = cinfo,+ defrowlab = defrowlab, |
| 1591 | -3051x | +851 | +313x |
- var_analyzed = var,+ cfun = cfun, |
| 1592 | -+ | |||
| 852 | +313x |
- ## XXX these are hardcoded, because they both get set during+ cformat = cformat, |
||
| 1593 | +853 |
- ## set_format_recursive anyway+ ## split_format = split_format, |
||
| 1594 | -3051x | +854 | +313x |
- format = NULL,+ inclNAs = inclNAs, |
| 1595 | -3051x | +855 | +313x |
- na_str = NA_character_,+ MoreArgs = list( |
| 1596 | -3051x | +856 | +313x |
- table_inset = 0L,+ extra_args = extra_args, |
| 1597 | -3051x | +857 | +313x |
- indent_modifier = as.integer(indent_mod),+ indent_mod = indent_mod, |
| 1598 | -3051x | +858 | +313x |
- main_title = title,+ label_pos = show_kidlabs, |
| 1599 | -3051x | +859 | +313x |
- subtitles = subtitles,+ split_format = split_format, |
| 1600 | -3051x | +860 | +313x |
- main_footer = main_footer,+ split_na_str = split_na_str, |
| 1601 | -3051x | +861 | +313x |
- provenance_footer = prov_footer,+ section_div = section_div_if_multivar |
| 1602 | -3051x | +862 | +313x |
- horizontal_sep = hsep,+ ), ## rvis), |
| 1603 | -3051x | +863 | +313x |
- header_section_div = header_section_div,+ SIMPLIFY = FALSE |
| 1604 | -3051x | +|||
| 864 | +
- trailing_section_div = trailing_section_div+ ) |
|||
| 1605 | +865 |
- )+ } else {
|
||
| 1606 | -3051x | +|||
| 866 | +
- tab <- set_format_recursive(tab, format, na_str, FALSE)+ ## we're combining existing splits here |
|||
| 1607 | -3051x | +867 | +25x |
- table_inset(tab) <- as.integer(inset)+ pld <- unlist(lapply(.payload, .uncompound)) |
| 1608 | -3051x | +|||
| 868 | +
- tab+ |
|||
| 1609 | +869 |
- }+ ## only override the childen being combined if the constructor |
||
| 1610 | +870 |
-
+ ## was passed a non-default value for child_labels |
||
| 1611 | +871 |
- ttable_validity <- function(object) {
+ ## and the child was at NA before |
||
| 1612 | -! | +|||
| 872 | +25x |
- all(sapply(+ pld <- lapply( |
||
| 1613 | -! | +|||
| 873 | +25x |
- tree_children(object),+ pld,+ |
+ ||
| 874 | +25x | +
+ function(x) {
+ |
+ ||
| 875 | +50x | +
+ rvis <- label_position(x) ## labelrow_visible(x)+ |
+ ||
| 876 | +50x | +
+ if (!identical(show_kidlabs, "default")) { ## is.na(show_kidlabs)) {
|
||
| 1614 | +877 | ! |
- function(x) is(x, "VTableTree") || is(x, "TableRow")+ if (identical(rvis, "default")) { ## ois.na(rvis))
|
|
| 1615 | -+ | |||
| 878 | +! |
- ))+ rvis <- show_kidlabs |
||
| 1616 | +879 |
- }+ } |
||
| 1617 | +880 |
-
+ } |
||
| 1618 | -+ | |||
| 881 | +50x |
- .calc_cinfo <- function(cinfo, cont, kids) {
+ label_position(x) <- rvis |
||
| 1619 | -2826x | +882 | +50x |
- if (!is.null(cinfo)) {
+ x |
| 1620 | -2826x | +|||
| 883 | +
- cinfo+ } |
|||
| 1621 | -! | +|||
| 884 | +
- } else if (!is.null(cont)) {
+ ) |
|||
| 1622 | -! | +|||
| 885 | +
- col_info(cont)+ } |
|||
| 1623 | -! | +|||
| 886 | +338x |
- } else if (length(kids) >= 1) {
+ if (length(pld) == 1) {
|
||
| 1624 | -! | +|||
| 887 | +285x |
- col_info(kids[[1]])+ ret <- pld[[1]] |
||
| 1625 | +888 |
} else {
|
||
| 1626 | -! | +|||
| 889 | +53x |
- EmptyColInfo+ if (is.null(split_name)) {
|
||
| 1627 | -+ | |||
| 890 | +53x |
- }+ split_name <- paste(c("ma", vapply(pld, obj_name, "")),
|
||
| 1628 | -+ | |||
| 891 | +53x |
- }+ collapse = "_" |
||
| 1629 | +892 |
-
+ ) |
||
| 1630 | +893 |
- ## under this model, non-leaf nodes can have a content table where rollup+ } |
||
| 1631 | -+ | |||
| 894 | +53x |
- ## analyses live+ ret <- new("AnalyzeMultiVars",
|
||
| 1632 | -+ | |||
| 895 | +53x |
- #' @exportClass TableTree+ payload = pld, |
||
| 1633 | -+ | |||
| 896 | +53x |
- #' @rdname tabclasses+ split_label = "", |
||
| 1634 | -+ | |||
| 897 | +53x |
- setClass("TableTree",
+ split_format = NULL, |
||
| 1635 | -+ | |||
| 898 | +53x |
- contains = c("VTableTree"),
+ split_na_str = split_na_str, |
||
| 1636 | -+ | |||
| 899 | +53x |
- representation(+ content_fun = NULL, |
||
| 1637 | -+ | |||
| 900 | +53x |
- content = "ElementaryTable",+ content_format = NULL, |
||
| 1638 | +901 |
- page_title_prefix = "character"+ ## I beleive this is superfluous now |
||
| 1639 | +902 |
- ),+ ## the payloads carry aroudn the real instructions |
||
| 1640 | +903 |
- validity = ttable_validity+ ## XXX |
||
| 1641 | -+ | |||
| 904 | +53x |
- )+ label_children = .labelkids_helper(show_kidlabs), |
||
| 1642 | -+ | |||
| 905 | +53x |
-
+ split_label_position = "hidden", ## XXX is this right? |
||
| 1643 | -+ | |||
| 906 | +53x |
- #' @export+ name = split_name, |
||
| 1644 | -+ | |||
| 907 | +53x |
- #' @rdname tabclasses+ extra_args = extra_args, |
||
| 1645 | +908 |
- TableTree <- function(kids = list(),+ ## modifier applied on splits in payload |
||
| 1646 | -+ | |||
| 909 | +53x |
- name = if (!is.na(var)) var else "",+ indent_modifier = 0L, |
||
| 1647 | -+ | |||
| 910 | +53x |
- cont = EmptyElTable,+ content_indent_modifier = 0L, |
||
| 1648 | -+ | |||
| 911 | +53x |
- lev = 1L,+ content_var = cvar, |
||
| 1649 | -+ | |||
| 912 | +53x |
- label = name,+ page_title_prefix = NA_character_, |
||
| 1650 | -+ | |||
| 913 | +53x |
- labelrow = LabelRow(+ child_section_div = section_div |
||
| 1651 | +914 |
- lev = lev,+ ) |
||
| 1652 | +915 |
- label = label,+ } |
||
| 1653 | -+ | |||
| 916 | +338x |
- vis = nrow(cont) == 0 && !is.na(label) &&+ ret |
||
| 1654 | +917 |
- nzchar(label)+ } |
||
| 1655 | +918 |
- ),+ |
||
| 1656 | +919 |
- rspans = data.frame(),+ setClass("VarLevWBaselineSplit",
|
||
| 1657 | +920 |
- iscontent = NA,+ contains = "VarLevelSplit", |
||
| 1658 | +921 |
- var = NA_character_,+ representation( |
||
| 1659 | +922 |
- cinfo = NULL,+ var = "character", |
||
| 1660 | +923 |
- format = NULL,+ ref_group_value = "character" |
||
| 1661 | +924 |
- na_str = NA_character_,+ ) |
||
| 1662 | +925 |
- indent_mod = 0L,+ ) |
||
| 1663 | +926 |
- title = "",+ |
||
| 1664 | +927 |
- subtitles = character(),+ #' @rdname VarLevelSplit |
||
| 1665 | +928 |
- main_footer = character(),+ #' @export |
||
| 1666 | +929 |
- prov_footer = character(),+ VarLevWBaselineSplit <- function(var, |
||
| 1667 | +930 |
- page_title = NA_character_,+ ref_group, |
||
| 1668 | +931 |
- hsep = default_hsep(),+ labels_var = var, |
||
| 1669 | +932 |
- header_section_div = NA_character_,+ split_label, |
||
| 1670 | +933 |
- trailing_section_div = NA_character_,+ split_fun = NULL, |
||
| 1671 | +934 |
- inset = 0L) {
- |
- ||
| 1672 | -2826x | -
- check_ok_label(label)- |
- ||
| 1673 | -2826x | -
- cinfo <- .calc_cinfo(cinfo, cont, kids)+ label_fstr = "%s - %s", |
||
| 1674 | +935 | - - | -||
| 1675 | -2826x | -
- kids <- .enforce_valid_kids(kids, cinfo)+ ## not needed I Think... |
||
| 1676 | -2826x | +|||
| 936 | +
- if (isTRUE(iscontent) && !is.null(cont) && nrow(cont) > 0) {
+ cfun = NULL, |
|||
| 1677 | -! | +|||
| 937 | +
- stop("Got table tree with content table and content position")
+ cformat = NULL, |
|||
| 1678 | +938 |
- }+ cna_str = NA_character_, |
||
| 1679 | -2826x | +|||
| 939 | +
- if (no_colinfo(labelrow)) {
+ cvar = "", |
|||
| 1680 | -1599x | +|||
| 940 | +
- col_info(labelrow) <- cinfo+ split_format = NULL, |
|||
| 1681 | +941 |
- }+ split_na_str = NA_character_, |
||
| 1682 | -2826x | +|||
| 942 | +
- if ((is.null(cont) || nrow(cont) == 0) && all(sapply(kids, is, "DataRow"))) {
+ valorder = NULL, |
|||
| 1683 | -1153x | +|||
| 943 | +
- if (!is.na(page_title)) {
+ split_name = var, |
|||
| 1684 | -! | +|||
| 944 | +
- stop("Got a page title prefix for an Elementary Table")
+ extra_args = list(), |
|||
| 1685 | +945 |
- }+ show_colcounts = FALSE, |
||
| 1686 | +946 |
- ## constructor takes care of recursive format application+ colcount_format = NULL) {
|
||
| 1687 | -1153x | +947 | +10x |
- ElementaryTable(+ check_ok_label(split_label) |
| 1688 | -1153x | +948 | +10x |
- kids = kids,+ new("VarLevWBaselineSplit",
|
| 1689 | -1153x | +949 | +10x |
- name = .chkname(name),+ payload = var, |
| 1690 | -1153x | +950 | +10x |
- lev = lev,+ ref_group_value = ref_group, |
| 1691 | -1153x | +|||
| 951 | +
- labelrow = labelrow,+ ## This will occur at the row level not on the column split, for now |
|||
| 1692 | -1153x | +|||
| 952 | +
- rspans = rspans,+ ## TODO revisit this to confirm its right |
|||
| 1693 | -1153x | +|||
| 953 | +
- cinfo = cinfo,+ ## comparison_func = comparison, |
|||
| 1694 | -1153x | +|||
| 954 | +
- var = var,+ # label_format = label_fstr, |
|||
| 1695 | -1153x | +955 | +10x |
- format = format,+ value_label_var = labels_var, |
| 1696 | -1153x | +956 | +10x |
- na_str = na_str,+ split_label = split_label, |
| 1697 | -1153x | +957 | +10x |
- indent_mod = indent_mod,+ content_fun = cfun, |
| 1698 | -1153x | +958 | +10x |
- title = title,+ content_format = cformat, |
| 1699 | -1153x | +959 | +10x |
- subtitles = subtitles,+ content_na_str = cna_str, |
| 1700 | -1153x | +960 | +10x |
- main_footer = main_footer,+ split_format = split_format, |
| 1701 | -1153x | +961 | +10x |
- prov_footer = prov_footer,+ split_na_str = split_na_str, |
| 1702 | -1153x | +962 | +10x |
- hsep = hsep,+ split_fun = split_fun, |
| 1703 | -1153x | +963 | +10x |
- header_section_div = header_section_div,+ name = split_name, |
| 1704 | -1153x | +964 | +10x |
- trailing_section_div = trailing_section_div,+ label_children = FALSE, |
| 1705 | -1153x | -
- inset = inset- |
- ||
| 1706 | -+ | 965 | +10x |
- )+ extra_args = extra_args, |
| 1707 | +966 |
- } else {
+ ## this is always a column split |
||
| 1708 | -1673x | +967 | +10x |
- tab <- new("TableTree",
+ indent_modifier = 0L, |
| 1709 | -1673x | +968 | +10x |
- content = cont,+ content_indent_modifier = 0L, |
| 1710 | -1673x | +969 | +10x |
- children = kids,+ content_var = cvar, |
| 1711 | -1673x | +|||
| 970 | +
- name = .chkname(name),+ ## so long as this is columnspace only |
|||
| 1712 | -1673x | +971 | +10x |
- level = lev,+ page_title_prefix = NA_character_, |
| 1713 | -1673x | +972 | +10x |
- labelrow = labelrow,+ child_section_div = NA_character_, |
| 1714 | -1673x | +973 | +10x |
- rowspans = rspans,+ child_show_colcounts = show_colcounts, |
| 1715 | -1673x | +974 | +10x |
- col_info = cinfo,+ child_colcount_format = colcount_format |
| 1716 | -1673x | +|||
| 975 | +
- format = NULL,+ ) |
|||
| 1717 | -1673x | +|||
| 976 | +
- na_str = na_str,+ } |
|||
| 1718 | -1673x | +|||
| 977 | +
- table_inset = 0L,+ |
|||
| 1719 | -1673x | +|||
| 978 | +
- indent_modifier = as.integer(indent_mod),+ .chkname <- function(nm) {
|
|||
| 1720 | -1673x | +979 | +19463x |
- main_title = title,+ if (is.null(nm)) {
|
| 1721 | -1673x | +|||
| 980 | +! |
- subtitles = subtitles,+ nm <- "" |
||
| 1722 | -1673x | +|||
| 981 | +
- main_footer = main_footer,+ } |
|||
| 1723 | -1673x | +982 | +19463x |
- provenance_footer = prov_footer,+ if (length(nm) != 1) {
|
| 1724 | -1673x | +|||
| 983 | +! |
- page_title_prefix = page_title,+ stop("name is not of length one")
|
||
| 1725 | -1673x | +984 | +19463x |
- horizontal_sep = "-",+ } else if (is.na(nm)) {
|
| 1726 | -1673x | +|||
| 985 | +! |
- header_section_div = header_section_div,+ warning("Got missing value for name, converting to characters '<NA>'")
|
||
| 1727 | -1673x | +|||
| 986 | +! |
- trailing_section_div = trailing_section_div+ nm <- "<NA>" |
||
| 1728 | -1673x | +|||
| 987 | +
- ) ## this is overridden below to get recursiveness+ } |
|||
| 1729 | -1673x | +988 | +19463x |
- tab <- set_format_recursive(tab, format, na_str, FALSE)+ nm |
| 1730 | +989 |
-
+ } |
||
| 1731 | +990 |
- ## these is recursive+ |
||
| 1732 | +991 |
- ## XXX combine these probably- |
- ||
| 1733 | -1673x | -
- horizontal_sep(tab) <- hsep- |
- ||
| 1734 | -1673x | -
- table_inset(tab) <- as.integer(inset)- |
- ||
| 1735 | -1673x | -
- tab+ ### Tree Position Representation |
||
| 1736 | +992 |
- }+ ### |
||
| 1737 | +993 |
- }+ ### Class(es) that represent position with in a |
||
| 1738 | +994 |
-
+ ### tree as parallel vectors of Split objects and |
||
| 1739 | +995 |
- ### Pre-Data Layout Declaration Classes+ ### values chosen at that split, plus labeling info |
||
| 1740 | +996 |
- ###+ TreePos <- function(spls = list(), |
||
| 1741 | +997 |
- ### Notably these are NOT represented as trees+ svals = list(), |
||
| 1742 | +998 |
- ### because without data we cannot know what the+ svlabels = character(), |
||
| 1743 | +999 |
- ### children should be.+ sub = NULL) {
|
||
| 1744 | -+ | |||
| 1000 | +1806x |
-
+ check_ok_label(svlabels, multi_ok = TRUE) |
||
| 1745 | -+ | |||
| 1001 | +1806x |
- ## Vector (ordered list) of splits.+ svals <- make_splvalue_vec(vals = svals, subset_exprs = lapply(svals, value_expr)) |
||
| 1746 | -+ | |||
| 1002 | +1806x |
- ##+ if (is.null(sub)) {
|
||
| 1747 | -+ | |||
| 1003 | +384x |
- ## This is a vector (ordered list) of splits to be+ if (length(spls) > 0) {
|
||
| 1748 | -+ | |||
| 1004 | +! |
- ## applied recursively to the data when provided.+ sub <- make_pos_subset( |
||
| 1749 | -+ | |||
| 1005 | +! |
- ##+ spls = spls, |
||
| 1750 | -+ | |||
| 1006 | +! |
- ## For convenience, if this is length 1, it can contain+ svals = svals |
||
| 1751 | +1007 |
- ## a pre-existing TableTree/ElementaryTable.+ ) |
||
| 1752 | +1008 |
- ## This is used for add_existing_table in colby_constructors.R+ } else {
|
||
| 1753 | -+ | |||
| 1009 | +384x |
-
+ sub <- expression(TRUE) |
||
| 1754 | +1010 |
- setClass("SplitVector",
+ } |
||
| 1755 | +1011 |
- contains = "list",+ } |
||
| 1756 | -+ | |||
| 1012 | +1806x |
- validity = function(object) {
+ new("TreePos",
|
||
| 1757 | -+ | |||
| 1013 | +1806x |
- if (length(object) >= 1) {
+ splits = spls, s_values = svals, |
||
| 1758 | -+ | |||
| 1014 | +1806x |
- lst <- tail(object, 1)[[1]]+ sval_labels = svlabels, |
||
| 1759 | -+ | |||
| 1015 | +1806x |
- } else {
+ subset = sub |
||
| 1760 | +1016 |
- lst <- NULL+ ) |
||
| 1761 | +1017 |
- }+ } |
||
| 1762 | +1018 |
- all(sapply(head(object, -1), is, "Split")) &&+ |
||
| 1763 | +1019 |
- (is.null(lst) || is(lst, "Split") || is(lst, "VTableNodeInfo"))+ ## Tree position convenience functions |
||
| 1764 | +1020 |
- }+ ## |
||
| 1765 | +1021 |
- )+ make_child_pos <- function(parpos, |
||
| 1766 | +1022 |
-
+ newspl, |
||
| 1767 | +1023 |
- SplitVector <- function(x = NULL,+ newval, |
||
| 1768 | +1024 |
- ...,+ newlab = newval, |
||
| 1769 | +1025 |
- lst = list(...)) {
+ newextra = list()) {
|
||
| 1770 | -2479x | +1026 | +1422x |
- if (!is.null(x)) {
+ if (!is(newval, "SplitValue")) {
|
| 1771 | -448x | +|||
| 1027 | +! |
- lst <- unlist(c(list(x), lst), recursive = FALSE)+ nsplitval <- SplitValue(newval, extr = newextra, label = newlab) |
||
| 1772 | +1028 |
- }+ } else {
|
||
| 1773 | -2479x | +1029 | +1422x |
- new("SplitVector", lst)
+ nsplitval <- newval |
| 1774 | +1030 |
- }+ } |
||
| 1775 | -- | - + | ||
| 1031 | +1422x | +
+ check_ok_label(newlab) |
||
| 1776 | -+ | |||
| 1032 | +1422x |
- avar_noneorlast <- function(vec) {
+ newpos <- TreePos( |
||
| 1777 | -1005x | +1033 | +1422x |
- if (!is(vec, "SplitVector")) {
+ spls = c(pos_splits(parpos), newspl), |
| 1778 | -! | +|||
| 1034 | +1422x |
- return(FALSE)+ svals = c(pos_splvals(parpos), nsplitval), |
||
| 1779 | -+ | |||
| 1035 | +1422x |
- }+ svlabels = c(pos_splval_labels(parpos), newlab), |
||
| 1780 | -1005x | +1036 | +1422x |
- if (length(vec) == 0) {
+ sub = .combine_subset_exprs( |
| 1781 | -656x | +1037 | +1422x |
- return(TRUE)+ pos_subset(parpos), |
| 1782 | +1038 |
- }- |
- ||
| 1783 | -349x | -
- isavar <- which(sapply(vec, is, "AnalyzeVarSplit"))+ ## this will grab the value's custom subset expression if present |
||
| 1784 | -349x | +1039 | +1422x |
- (length(isavar) == 0) || (length(isavar) == 1 && isavar == length(vec))+ make_subset_expr(newspl, nsplitval) |
| 1785 | +1040 |
- }+ ) |
||
| 1786 | +1041 |
-
+ ) |
||
| 1787 | -+ | |||
| 1042 | +1422x |
- setClass("PreDataAxisLayout",
+ newpos |
||
| 1788 | +1043 |
- contains = "list",+ } |
||
| 1789 | +1044 |
- representation(root_split = "ANY"),+ |
||
| 1790 | +1045 |
- validity = function(object) {
+ ## Virtual Classes for Tree Nodes and Layouts ================================= |
||
| 1791 | +1046 |
- allleafs <- unlist(object, recursive = TRUE)+ ## |
||
| 1792 | +1047 |
- all(sapply(object, avar_noneorlast)) &&+ ## Virtual class hiearchy for the various types of trees in use in the S4 |
||
| 1793 | +1048 |
- all(sapply(+ ## implementation of the TableTree machinery |
||
| 1794 | +1049 |
- allleafs,+ |
||
| 1795 | +1050 |
- ## remember existing table trees can be added to layouts+ ## core basics |
||
| 1796 | +1051 |
- ## for now...+ setClass("VNodeInfo",
|
||
| 1797 | +1052 |
- function(x) is(x, "Split") || is(x, "VTableTree")+ contains = "VIRTUAL", |
||
| 1798 | +1053 |
- ))+ representation( |
||
| 1799 | +1054 |
- }+ level = "integer", |
||
| 1800 | +1055 |
- )+ name = "character" ## , |
||
| 1801 | +1056 |
-
+ ## label = "character" |
||
| 1802 | +1057 |
- setClass("PreDataColLayout",
+ ) |
||
| 1803 | +1058 |
- contains = "PreDataAxisLayout",+ ) |
||
| 1804 | +1059 |
- representation(+ |
||
| 1805 | +1060 |
- display_columncounts = "logical",+ setClass("VTree",
|
||
| 1806 | +1061 |
- columncount_format = "FormatSpec" # "character"+ contains = c("VIRTUAL", "VNodeInfo"),
|
||
| 1807 | +1062 |
- )+ representation(children = "list") |
||
| 1808 | +1063 |
) |
||
| 1809 | +1064 | |||
| 1810 | +1065 |
- setClass("PreDataRowLayout", contains = "PreDataAxisLayout")
+ setClass("VLeaf", contains = c("VIRTUAL", "VNodeInfo"))
|
||
| 1811 | +1066 | |||
| 1812 | +1067 |
- PreDataColLayout <- function(x = SplitVector(),+ ## Layout trees ================================= |
||
| 1813 | +1068 |
- rtsp = RootSplit(),+ |
||
| 1814 | +1069 |
- ...,+ # setClass("VLayoutNode", contains= c("VIRTUAL", "VNodeInfo"))
|
||
| 1815 | +1070 |
- lst = list(x, ...),+ |
||
| 1816 | +1071 |
- disp_colcounts = NA,+ setClass("VLayoutLeaf",
|
||
| 1817 | +1072 |
- colcount_format = "(N=xx)") {
+ contains = c("VIRTUAL", "VLeaf"),
|
||
| 1818 | -323x | +|||
| 1073 | +
- ret <- new("PreDataColLayout", lst,
+ representation( |
|||
| 1819 | -323x | +|||
| 1074 | +
- display_columncounts = disp_colcounts,+ pos_in_tree = "TreePos", |
|||
| 1820 | -323x | +|||
| 1075 | +
- columncount_format = colcount_format+ label = "character" |
|||
| 1821 | +1076 |
) |
||
| 1822 | -323x | -
- ret@root_split <- rtsp- |
- ||
| 1823 | -323x | -
- ret- |
- ||
| 1824 | +1077 |
- }+ ) |
||
| 1825 | +1078 | |||
| 1826 | +1079 |
- PreDataRowLayout <- function(x = SplitVector(),+ setClass("VLayoutTree",
|
||
| 1827 | +1080 |
- root = RootSplit(),+ contains = c("VIRTUAL", "VTree"),
|
||
| 1828 | +1081 |
- ...,+ representation( |
||
| 1829 | +1082 |
- lst = list(x, ...)) {
- |
- ||
| 1830 | -659x | -
- new("PreDataRowLayout", lst, root_split = root)
+ split = "Split", |
||
| 1831 | +1083 |
- }+ pos_in_tree = "TreePos", |
||
| 1832 | +1084 |
-
+ label = "character" |
||
| 1833 | +1085 |
- setClass("PreDataTableLayouts",
+ ) |
||
| 1834 | +1086 |
- contains = "VTitleFooter",+ ) |
||
| 1835 | +1087 |
- representation(+ |
||
| 1836 | +1088 |
- row_layout = "PreDataRowLayout",+ setClassUnion("VLayoutNode", c("VLayoutLeaf", "VLayoutTree"))
|
||
| 1837 | +1089 |
- col_layout = "PreDataColLayout",+ |
||
| 1838 | +1090 |
- top_left = "character",+ ## LayoutAxisTree classes ================================= |
||
| 1839 | +1091 |
- header_section_div = "character",+ |
||
| 1840 | +1092 |
- top_level_section_div = "character",+ setOldClass("function")
|
||
| 1841 | +1093 |
- table_inset = "integer"+ setOldClass("NULL")
|
||
| 1842 | +1094 |
- )+ setClassUnion("FunctionOrNULL", c("function", "NULL"))
|
||
| 1843 | +1095 |
- )+ |
||
| 1844 | +1096 |
-
+ setClass("LayoutAxisTree",
|
||
| 1845 | +1097 |
- PreDataTableLayouts <- function(rlayout = PreDataRowLayout(),+ contains = "VLayoutTree", |
||
| 1846 | +1098 |
- clayout = PreDataColLayout(),+ representation(summary_func = "FunctionOrNULL"), |
||
| 1847 | +1099 |
- topleft = character(),+ validity = function(object) {
|
||
| 1848 | +1100 |
- title = "",+ all(sapply(object@children, function(x) is(x, "LayoutAxisTree") || is(x, "LayoutAxisLeaf"))) |
||
| 1849 | +1101 |
- subtitles = character(),+ } |
||
| 1850 | +1102 |
- main_footer = character(),+ ) |
||
| 1851 | +1103 |
- prov_footer = character(),+ |
||
| 1852 | +1104 |
- header_section_div = NA_character_,+ ## this is only used for columns!!!! |
||
| 1853 | +1105 |
- top_level_section_div = NA_character_,+ setClass("LayoutAxisLeaf",
|
||
| 1854 | +1106 |
- table_inset = 0L) {
- |
- ||
| 1855 | -323x | -
- new("PreDataTableLayouts",
- |
- ||
| 1856 | -323x | -
- row_layout = rlayout,- |
- ||
| 1857 | -323x | -
- col_layout = clayout,- |
- ||
| 1858 | -323x | -
- top_left = topleft,- |
- ||
| 1859 | -323x | -
- main_title = title,- |
- ||
| 1860 | -323x | -
- subtitles = subtitles,- |
- ||
| 1861 | -323x | -
- main_footer = main_footer,- |
- ||
| 1862 | -323x | -
- provenance_footer = prov_footer,- |
- ||
| 1863 | -323x | -
- header_section_div = header_section_div,- |
- ||
| 1864 | -323x | -
- top_level_section_div = top_level_section_div,- |
- ||
| 1865 | -323x | -
- table_inset = table_inset+ contains = "VLayoutLeaf", ## "VNodeInfo", |
||
| 1866 | +1107 |
- )+ representation( |
||
| 1867 | +1108 |
- }+ func = "function", |
||
| 1868 | +1109 |
-
+ display_columncounts = "logical", |
||
| 1869 | +1110 |
- ## setClass("CellValue", contains = "ValueWrapper",
+ columncount_format = "FormatSpec", # character", |
||
| 1870 | +1111 |
- ## representation(format = "FormatSpec",+ col_footnotes = "list", |
||
| 1871 | +1112 |
- ## colspan = "integerOrNULL",+ column_count = "integer" |
||
| 1872 | +1113 |
- ## label = "characterOrNULL"),+ ) |
||
| 1873 | +1114 |
- ## prototype = list(label ="", colspan = NULL, format = NULL))+ ) |
||
| 1874 | +1115 | |||
| 1875 | +1116 |
- setOldClass("CellValue")
+ setClass("LayoutColTree",
|
||
| 1876 | +1117 |
-
+ contains = "LayoutAxisTree", |
||
| 1877 | +1118 |
- #' Length of a Cell value+ representation( |
||
| 1878 | +1119 |
- #'+ display_columncounts = "logical", |
||
| 1879 | +1120 |
- #' @param x (`CellValue`)\cr a `CellValue` object.+ columncount_format = "FormatSpec", # "character", |
||
| 1880 | +1121 |
- #'+ col_footnotes = "list", |
||
| 1881 | +1122 |
- #' @return Always returns `1L`.+ column_count = "integer" |
||
| 1882 | +1123 |
- #'+ ) |
||
| 1883 | +1124 |
- #' @exportMethod length+ ) |
||
| 1884 | +1125 |
- setMethod(+ |
||
| 1885 | +1126 |
- "length", "CellValue",- |
- ||
| 1886 | -! | -
- function(x) 1L+ setClass("LayoutColLeaf", contains = "LayoutAxisLeaf")
|
||
| 1887 | +1127 |
- )+ LayoutColTree <- function(lev = 0L, |
||
| 1888 | +1128 |
-
+ name = obj_name(spl), |
||
| 1889 | +1129 |
- setClass("RefFootnote", representation(
+ label = obj_label(spl), |
||
| 1890 | +1130 |
- value = "character",+ kids = list(), |
||
| 1891 | +1131 |
- index = "integer",+ spl = EmptyAllSplit, |
||
| 1892 | +1132 |
- symbol = "character"+ tpos = TreePos(), |
||
| 1893 | +1133 |
- ))+ summary_function = NULL, |
||
| 1894 | +1134 |
-
+ disp_ccounts = FALSE, |
||
| 1895 | +1135 |
- RefFootnote <- function(note, index = NA_integer_, symbol = NA_character_) {
+ colcount_format = NULL, |
||
| 1896 | -56x | +|||
| 1136 | +
- if (is(note, "RefFootnote")) {
+ footnotes = list(), |
|||
| 1897 | -28x | +|||
| 1137 | +
- return(note)+ colcount) { ## ,
|
|||
| 1898 | -28x | +|||
| 1138 | +
- } else if (length(note) == 0) {
+ ## sub = expression(TRUE), |
|||
| 1899 | -! | +|||
| 1139 | +
- return(NULL)+ ## svar = NA_character_, |
|||
| 1900 | +1140 |
- }+ ## slab = NA_character_) {
|
||
| 1901 | -28x | +1141 | +627x |
- if (length(symbol) != 1L) {
+ if (is.null(spl)) {
|
| 1902 | +1142 | ! |
stop( |
|
| 1903 | +1143 | ! |
- "Referential footnote can only have a single string as its index.",+ "LayoutColTree constructor got NULL for spl. ", # nocov |
|
| 1904 | +1144 | ! |
- " Got char vector of length ", length(index)+ "This should never happen. Please contact the maintainer." |
|
| 1905 | +1145 |
) |
||
| 1906 | +1146 |
- }+ } # nocov |
||
| 1907 | -28x | -
- if (!is.na(symbol) && (index == "NA" || grepl("[{}]", index))) {
- |
- ||
| 1908 | -! | -
- stop(- |
- ||
| 1909 | -! | -
- "The string 'NA' and strings containing '{' or '}' cannot be used as ",
- |
- ||
| 1910 | -! | +1147 | +627x |
- "referential footnote index symbols. Got string '", index, "'."+ footnotes <- make_ref_value(footnotes) |
| 1911 | -+ | |||
| 1148 | +627x |
- )+ check_ok_label(label) |
||
| 1912 | -+ | |||
| 1149 | +627x |
- }+ new("LayoutColTree",
|
||
| 1913 | -+ | |||
| 1150 | +627x |
-
+ level = lev, children = kids, |
||
| 1914 | -28x | +1151 | +627x |
- new("RefFootnote", value = note, index = index, symbol = symbol)
+ name = .chkname(name), |
| 1915 | -+ | |||
| 1152 | +627x |
- }+ summary_func = summary_function, |
||
| 1916 | -+ | |||
| 1153 | +627x |
-
+ pos_in_tree = tpos, |
||
| 1917 | -+ | |||
| 1154 | +627x |
- #' Constructor for Cell Value+ split = spl, |
||
| 1918 | +1155 |
- #'+ ## subset = sub, |
||
| 1919 | +1156 |
- #' @inheritParams lyt_args+ ## splitvar = svar, |
||
| 1920 | -+ | |||
| 1157 | +627x |
- #' @inheritParams rcell+ label = label, |
||
| 1921 | -+ | |||
| 1158 | +627x |
- #' @param val (`ANY`)\cr value in the cell exactly as it should be passed to a formatter or returned when extracted.+ display_columncounts = disp_ccounts, |
||
| 1922 | -+ | |||
| 1159 | +627x |
- #'+ columncount_format = colcount_format, |
||
| 1923 | -+ | |||
| 1160 | +627x |
- #' @return An object representing the value within a single cell within a populated table. The underlying structure+ col_footnotes = footnotes, |
||
| 1924 | -+ | |||
| 1161 | +627x |
- #' of this object is an implementation detail and should not be relied upon beyond calling accessors for the class.+ column_count = colcount |
||
| 1925 | +1162 |
- #'+ ) |
||
| 1926 | +1163 |
- #' @export+ } |
||
| 1927 | +1164 | |||
| 1928 | +1165 |
- ## Class definition+ LayoutColLeaf <- function(lev = 0L, |
||
| 1929 | +1166 |
- ## [[1]] list: cell value+ name = label, |
||
| 1930 | +1167 |
- ## format : format for cell+ label = "", |
||
| 1931 | +1168 |
- ## colspan: column span info for cell+ tpos = TreePos(), |
||
| 1932 | +1169 |
- ## label: row label to be used for parent row+ colcount, |
||
| 1933 | +1170 |
- ## indent_mod: indent modifier to be used for parent row+ disp_ccounts = FALSE, |
||
| 1934 | +1171 |
- CellValue <- function(val, format = NULL, colspan = 1L, label = NULL,+ colcount_format = NULL) {
|
||
| 1935 | -+ | |||
| 1172 | +1181x |
- indent_mod = NULL, footnotes = NULL,+ check_ok_label(label) |
||
| 1936 | -+ | |||
| 1173 | +1181x |
- align = NULL, format_na_str = NULL) {
+ new("LayoutColLeaf",
|
||
| 1937 | -12629x | +1174 | +1181x |
- if (is.null(colspan)) {
+ level = lev, name = .chkname(name), label = label, |
| 1938 | -! | +|||
| 1175 | +1181x |
- colspan <- 1L+ pos_in_tree = tpos, |
||
| 1939 | -+ | |||
| 1176 | +1181x |
- }+ column_count = colcount, |
||
| 1940 | -12629x | +1177 | +1181x |
- if (!is.null(colspan) && !is(colspan, "integer")) {
+ display_columncounts = disp_ccounts, |
| 1941 | -10x | +1178 | +1181x |
- colspan <- as.integer(colspan)+ columncount_format = colcount_format |
| 1942 | +1179 |
- }+ ) |
||
| 1943 | +1180 |
- ## if we're not given a label but the value has one associated with+ } |
||
| 1944 | +1181 |
- ## it we use that.+ |
||
| 1945 | +1182 |
- ## NB: we need to be able to override a non-empty label with an empty one+ ## Instantiated column info class ============================================== |
||
| 1946 | +1183 |
- ## so we can't have "" mean "not given a label" here+ ## |
||
| 1947 | -12629x | +|||
| 1184 | +
- if ((is.null(label) || is.na(label)) && !is.null(obj_label(val))) {
+ ## This is so we don't need multiple arguments |
|||
| 1948 | -2x | +|||
| 1185 | +
- label <- obj_label(val)+ ## in the recursive functions that track |
|||
| 1949 | +1186 |
- }+ ## various aspects of the column layout |
||
| 1950 | -12629x | +|||
| 1187 | +
- if (!is.list(footnotes)) {
+ ## once its applied to the data. |
|||
| 1951 | -9x | +|||
| 1188 | +
- footnotes <- lapply(footnotes, RefFootnote)+ |
|||
| 1952 | +1189 |
- }+ #' Instantiated column info |
||
| 1953 | -12629x | +|||
| 1190 | +
- check_ok_label(label)+ #' |
|||
| 1954 | -12629x | +|||
| 1191 | +
- ret <- structure(list(val),+ #' @inheritParams gen_args |
|||
| 1955 | -12629x | +|||
| 1192 | +
- format = format, colspan = colspan,+ #' |
|||
| 1956 | -12629x | +|||
| 1193 | +
- label = label,+ #' @exportClass InstantiatedColumnInfo |
|||
| 1957 | -12629x | +|||
| 1194 | +
- indent_mod = indent_mod, footnotes = footnotes,+ #' @rdname cinfo |
|||
| 1958 | -12629x | +|||
| 1195 | +
- align = align,+ setClass( |
|||
| 1959 | -12629x | +|||
| 1196 | +
- format_na_str = format_na_str,+ "InstantiatedColumnInfo", |
|||
| 1960 | -12629x | +|||
| 1197 | +
- class = "CellValue"+ representation( |
|||
| 1961 | +1198 |
- )+ tree_layout = "VLayoutNode", ## LayoutColTree", |
||
| 1962 | -12629x | +|||
| 1199 | +
- ret+ subset_exprs = "list", |
|||
| 1963 | +1200 |
- }+ cextra_args = "list", |
||
| 1964 | +1201 |
-
+ counts = "integer", |
||
| 1965 | +1202 |
- #' @method print CellValue+ total_count = "integer", |
||
| 1966 | +1203 |
- #'+ display_columncounts = "logical", |
||
| 1967 | +1204 |
- #' @export+ columncount_format = "FormatSpec", |
||
| 1968 | +1205 |
- print.CellValue <- function(x, ...) {
+ columncount_na_str = "character", |
||
| 1969 | -! | +|||
| 1206 | +
- cat(paste("rcell:", format_rcell(x), "\n"))
+ top_left = "character" |
|||
| 1970 | -! | +|||
| 1207 | +
- invisible(x)+ ) |
|||
| 1971 | +1208 |
- }+ ) |
||
| 1972 | +1209 | |||
| 1973 | +1210 |
- ## too slow+ #' @param treelyt (`LayoutColTree`)\cr a `LayoutColTree` object. |
||
| 1974 | +1211 |
- # setClass("RowsVerticalSection", contains = "list",
+ #' @param csubs (`list`)\cr a list of subsetting expressions. |
||
| 1975 | +1212 |
- # representation = list(row_names = "characterOrNULL",+ #' @param extras (`list`)\cr extra arguments associated with the columns. |
||
| 1976 | +1213 |
- # row_labels = "characterOrNULL",+ #' @param cnts (`integer`)\cr counts. |
||
| 1977 | +1214 |
- # row_formats = "ANY",+ #' @param total_cnt (`integer(1)`)\cr total observations represented across all columns. |
||
| 1978 | +1215 |
- # indent_mods = "integerOrNULL"))+ #' @param dispcounts (`flag`)\cr whether the counts should be displayed as header info when the associated |
||
| 1979 | +1216 |
-
+ #' table is printed. |
||
| 1980 | +1217 |
- setOldClass("RowsVerticalSection")
+ #' @param countformat (`string`)\cr format for the counts if they are displayed. |
||
| 1981 | +1218 |
- RowsVerticalSection <- function(values,+ #' @param count_na_str (`character`)\cr string to use in place of missing values when formatting counts. Defaults |
||
| 1982 | +1219 |
- names = names(values),+ #' to `""`. |
||
| 1983 | +1220 |
- labels = NULL,+ #' |
||
| 1984 | +1221 |
- indent_mods = NULL,+ #' @return An `InstantiateadColumnInfo` object. |
||
| 1985 | +1222 |
- formats = NULL,+ #' |
||
| 1986 | +1223 |
- footnotes = NULL,+ #' @export |
||
| 1987 | +1224 |
- format_na_strs = NULL) {
+ #' @rdname cinfo |
||
| 1988 | -5775x | +|||
| 1225 | +
- stopifnot(is(values, "list"))+ InstantiatedColumnInfo <- function(treelyt = LayoutColTree(colcount = total_cnt), |
|||
| 1989 | +1226 |
- ## innernms <- value_names(values)+ csubs = list(expression(TRUE)), |
||
| 1990 | +1227 |
-
+ extras = list(list()), |
||
| 1991 | -5775x | +|||
| 1228 | +
- if (is.null(labels)) {
+ cnts = NA_integer_, |
|||
| 1992 | -2554x | +|||
| 1229 | +
- labels <- names(values)+ total_cnt = NA_integer_, |
|||
| 1993 | +1230 |
- }+ dispcounts = FALSE, |
||
| 1994 | -5775x | +|||
| 1231 | +
- if (is.null(names) && all(nzchar(labels))) {
+ countformat = "(N=xx)", |
|||
| 1995 | -3265x | +|||
| 1232 | +
- names <- labels+ count_na_str = "", |
|||
| 1996 | -2510x | +|||
| 1233 | +
- } else if (is.null(labels) && !is.null(names)) {
+ topleft = character()) {
|
|||
| 1997 | -15x | +1234 | +652x |
- labels <- names+ leaves <- collect_leaves(treelyt) |
| 1998 | -+ | |||
| 1235 | +652x |
- }+ nl <- length(leaves) |
||
| 1999 | -+ | |||
| 1236 | +652x |
-
+ extras <- rep(extras, length.out = nl) |
||
| 2000 | -5775x | +1237 | +652x |
- if (!is.null(indent_mods)) {
+ cnts <- rep(cnts, length.out = nl) |
| 2001 | -68x | +1238 | +652x |
- indent_mods <- as.integer(indent_mods)+ csubs <- rep(csubs, length.out = nl) |
| 2002 | +1239 |
- }+ |
||
| 2003 | -5775x | +1240 | +652x |
- check_ok_label(labels, multi_ok = TRUE)+ nleaves <- length(leaves) |
| 2004 | -5774x | +1241 | +652x |
- structure(values,+ snas <- sum(is.na(cnts)) |
| 2005 | -5774x | +1242 | +652x |
- class = "RowsVerticalSection", row_names = names,+ if (length(csubs) != nleaves || length(extras) != nleaves || length(cnts) != nleaves) {
|
| 2006 | -5774x | +|||
| 1243 | +! |
- row_labels = labels, indent_mods = indent_mods,+ stop( |
||
| 2007 | -5774x | +|||
| 1244 | +! |
- row_formats = formats,+ "Mismatching number of columns indicated by: csubs [", |
||
| 2008 | -5774x | +|||
| 1245 | +! |
- row_na_strs = format_na_strs,+ length(csubs), "], ", |
||
| 2009 | -5774x | +|||
| 1246 | +! |
- row_footnotes = lapply(+ "treelyt [", nl, "], extras [", length(extras), |
||
| 2010 | -5774x | +|||
| 1247 | +! |
- footnotes,+ "] and counts [", cnts, "]." |
||
| 2011 | +1248 |
- ## cause each row needs to accept+ ) |
||
| 2012 | +1249 |
- ## a *list* of row footnotes+ } |
||
| 2013 | -5774x | +1250 | +652x |
- function(fns) lapply(fns, RefFootnote)+ if (snas != 0 && snas != nleaves) {
|
| 2014 | -+ | |||
| 1251 | +2x |
- )+ warning(+ |
+ ||
| 1252 | +2x | +
+ "Mixture of missing and non-missing column counts when ",+ |
+ ||
| 1253 | +2x | +
+ "creating column info." |
||
| 2015 | +1254 |
- )+ ) |
||
| 2016 | +1255 |
- }+ } |
||
| 2017 | +1256 | |||
| 2018 | -+ | |||
| 1257 | +652x |
- #' @method print RowsVerticalSection+ if (!is.na(dispcounts)) {
|
||
| 2019 | -+ | |||
| 1258 | +409x |
- #'+ pths <- col_paths(treelyt) |
||
| 2020 | -+ | |||
| 1259 | +409x |
- #' @export+ for (path in pths) {
+ |
+ ||
| 1260 | +921x | +
+ colcount_visible(treelyt, path) <- dispcounts |
||
| 2021 | +1261 |
- print.RowsVerticalSection <- function(x, ...) {
+ } |
||
| 2022 | -1x | +|||
| 1262 | +
- cat("RowsVerticalSection (in_rows) object print method:\n-------------------",
+ } else { ## na leaves the children as they are and dispcols goes to whether any of them are displayed for the leaves
|
|||
| 2023 | -1x | +1263 | +243x |
- "---------\n",+ dispcounts <- any(vapply(leaves, disp_ccounts, NA)) |
| 2024 | -1x | +|||
| 1264 | +
- sep = ""+ } |
|||
| 2025 | +1265 |
- )+ |
||
| 2026 | -1x | +1266 | +652x |
- print(data.frame(+ new("InstantiatedColumnInfo",
|
| 2027 | -1x | +1267 | +652x |
- row_name = attr(x, "row_names", exact = TRUE),+ tree_layout = treelyt, |
| 2028 | -1x | +1268 | +652x |
- formatted_cell = vapply(x, format_rcell, character(1)),+ subset_exprs = csubs, |
| 2029 | -1x | +1269 | +652x |
- indent_mod = indent_mod(x), ## vapply(x, indent_mod, numeric(1)),+ cextra_args = extras, |
| 2030 | -1x | +1270 | +652x |
- row_label = attr(x, "row_labels", exact = TRUE),+ counts = cnts, |
| 2031 | -1x | +1271 | +652x |
- stringsAsFactors = FALSE,+ total_count = total_cnt, |
| 2032 | -1x | +1272 | +652x |
- row.names = NULL+ display_columncounts = dispcounts, |
| 2033 | -1x | +1273 | +652x |
- ), row.names = TRUE)+ columncount_format = countformat, |
| 2034 | -1x | +1274 | +652x |
- invisible(x)+ columncount_na_str = count_na_str, |
| 2035 | -+ | |||
| 1275 | +652x |
- }+ top_left = topleft |
||
| 2036 | +1276 |
-
+ ) |
||
| 2037 | +1277 |
- #### Empty default objects to avoid repeated calls+ } |
||
| 2038 | +1278 |
- ## EmptyColInfo <- InstantiatedColumnInfo()+ |
||
| 2039 | +1279 |
- ## EmptyElTable <- ElementaryTable()+ ## TableTrees and row classes ================================================== |
||
| 2040 | +1280 |
- ## EmptyRootSplit <- RootSplit()+ ## XXX Rowspans as implemented dont really work |
||
| 2041 | +1281 |
- ## EmptyAllSplit <- AllSplit()+ ## they're aren't attached to the right data structures |
| 1 | +1282 |
- match_extra_args <- function(f,+ ## during conversions. |
||
| 2 | +1283 |
- .N_col,+ |
||
| 3 | +1284 |
- .N_total,+ ## FIXME: if we ever actually need row spanning |
||
| 4 | +1285 |
- .all_col_exprs,+ setClass("VTableNodeInfo",
|
||
| 5 | +1286 |
- .all_col_counts,+ contains = c("VNodeInfo", "VIRTUAL"),
|
||
| 6 | +1287 |
- .var,+ representation( |
||
| 7 | +1288 |
- .ref_group = NULL,+ ## col_layout = "VLayoutNode", |
||
| 8 | +1289 |
- .alt_df_row = NULL,+ col_info = "InstantiatedColumnInfo", |
||
| 9 | +1290 |
- .alt_df = NULL,+ format = "FormatSpec", |
||
| 10 | +1291 |
- .ref_full = NULL,+ na_str = "character", |
||
| 11 | +1292 |
- .in_ref_col = NULL,+ indent_modifier = "integer", |
||
| 12 | +1293 |
- .spl_context = NULL,+ table_inset = "integer" |
||
| 13 | +1294 |
- .N_row,+ ) |
||
| 14 | +1295 |
- .df_row,+ ) |
||
| 15 | +1296 |
- extras) {
+
|
||
| 16 | +1297 |
- # This list is always present- |
- ||
| 17 | -5734x | -
- possargs <- c(+ setClass("TableRow",
|
||
| 18 | -5734x | +|||
| 1298 | +
- list(+ contains = c("VIRTUAL", "VLeaf", "VTableNodeInfo"),
|
|||
| 19 | -5734x | +|||
| 1299 | +
- .N_col = .N_col,+ representation( |
|||
| 20 | -5734x | +|||
| 1300 | +
- .N_total = .N_total,+ leaf_value = "ANY", |
|||
| 21 | -5734x | +|||
| 1301 | +
- .N_row = .N_row,+ var_analyzed = "character", |
|||
| 22 | -5734x | +|||
| 1302 | +
- .df_row = .df_row,+ ## var_label = "character", |
|||
| 23 | -5734x | +|||
| 1303 | +
- .all_col_exprs = .all_col_exprs,+ label = "character", |
|||
| 24 | -5734x | +|||
| 1304 | +
- .all_col_counts = .all_col_counts+ row_footnotes = "list", |
|||
| 25 | +1305 |
- ),+ trailing_section_div = "character" |
||
| 26 | -5734x | +|||
| 1306 | +
- extras+ ) |
|||
| 27 | +1307 |
- )+ ) |
||
| 28 | +1308 | |||
| 29 | +1309 |
- ## specialized arguments that must be named in formals, cannot go+ ## TableTree Core Non-Virtual Classes ============== |
||
| 30 | +1310 |
- ## anonymously into ...+ ## |
||
| 31 | -5734x | +|||
| 1311 | +
- if (!is.null(.var) && nzchar(.var)) {
+ #' Row classes and constructors |
|||
| 32 | -4502x | +|||
| 1312 | +
- possargs <- c(possargs, list(.var = .var))+ #' |
|||
| 33 | +1313 |
- }+ #' @inheritParams constr_args |
||
| 34 | -5734x | +|||
| 1314 | +
- if (!is.null(.ref_group)) {
+ #' @inheritParams lyt_args |
|||
| 35 | -1797x | +|||
| 1315 | +
- possargs <- c(possargs, list(.ref_group = .ref_group))+ #' @param vis (`flag`)\cr whether the row should be visible (`LabelRow` only). |
|||
| 36 | +1316 |
- }+ #' |
||
| 37 | -5734x | +|||
| 1317 | +
- if (!is.null(.alt_df_row)) {
+ #' @return A formal object representing a table row of the constructed type. |
|||
| 38 | -105x | +|||
| 1318 | +
- possargs <- c(possargs, list(.alt_df_row = .alt_df_row))+ #' |
|||
| 39 | +1319 |
- }+ #' @author Gabriel Becker |
||
| 40 | -5734x | +|||
| 1320 | +
- if (!is.null(.alt_df)) {
+ #' @export |
|||
| 41 | -105x | +|||
| 1321 | +
- possargs <- c(possargs, list(.alt_df = .alt_df))+ #' @rdname rowclasses |
|||
| 42 | +1322 |
- }+ LabelRow <- function(lev = 1L, |
||
| 43 | -5734x | +|||
| 1323 | +
- if (!is.null(.ref_full)) {
+ label = "", |
|||
| 44 | -141x | +|||
| 1324 | +
- possargs <- c(possargs, list(.ref_full = .ref_full))+ name = label, |
|||
| 45 | +1325 |
- }+ vis = !is.na(label) && nzchar(label), |
||
| 46 | -5734x | +|||
| 1326 | +
- if (!is.null(.in_ref_col)) {
+ cinfo = EmptyColInfo, |
|||
| 47 | -141x | +|||
| 1327 | +
- possargs <- c(possargs, list(.in_ref_col = .in_ref_col))+ indent_mod = 0L, |
|||
| 48 | +1328 |
- }+ table_inset = 0L, |
||
| 49 | +1329 |
-
+ trailing_section_div = NA_character_) {
|
||
| 50 | -+ | |||
| 1330 | +4841x |
- # Special case: .spl_context+ check_ok_label(label) |
||
| 51 | -5734x | +1331 | +4841x |
- if (!is.null(.spl_context) && !(".spl_context" %in% names(possargs))) {
+ new("LabelRow",
|
| 52 | -5734x | +1332 | +4841x |
- possargs <- c(possargs, list(.spl_context = .spl_context))+ leaf_value = list(), |
| 53 | -+ | |||
| 1333 | +4841x |
- } else {
+ level = lev, |
||
| 54 | -! | +|||
| 1334 | +4841x |
- possargs$.spl_context <- NULL+ label = label, |
||
| 55 | +1335 |
- }+ ## XXX this means that a label row and its talbe can have the same name.... |
||
| 56 | +1336 |
-
+ ## XXX that is bad but how bad remains to be seen |
||
| 57 | +1337 |
- # Extra args handling+ ## XXX |
||
| 58 | -5734x | +1338 | +4841x |
- formargs <- formals(f)+ name = .chkname(name), |
| 59 | -5734x | +1339 | +4841x |
- formnms <- names(formargs)+ col_info = cinfo, |
| 60 | -5734x | +1340 | +4841x |
- exnms <- names(extras)+ visible = vis, |
| 61 | -5734x | +1341 | +4841x |
- if (is.null(formargs)) {
+ indent_modifier = as.integer(indent_mod), |
| 62 | -190x | +1342 | +4841x |
- return(NULL)+ table_inset = as.integer(table_inset), |
| 63 | -5544x | +1343 | +4841x |
- } else if ("..." %in% names(formargs)) {
+ trailing_section_div = trailing_section_div |
| 64 | -4842x | +|||
| 1344 | +
- formnms <- c(formnms, exnms[nzchar(exnms)])+ ) |
|||
| 65 | +1345 |
- }+ } |
||
| 66 | -5544x | +|||
| 1346 | +
- possargs[names(possargs) %in% formnms]+ |
|||
| 67 | +1347 |
- }+ #' Row constructors and classes |
||
| 68 | +1348 |
-
+ #' |
||
| 69 | +1349 |
- #' @noRd+ #' @rdname rowclasses |
||
| 70 | +1350 |
- #' @return A `RowsVerticalSection` object representing the `k x 1` section of the+ #' @exportClass DataRow |
||
| 71 | +1351 |
- #' table being generated, with `k` the number of rows the analysis function+ setClass("DataRow",
|
||
| 72 | +1352 |
- #' generates.+ contains = "TableRow", |
||
| 73 | +1353 |
- gen_onerv <- function(csub, col, count, cextr, cpath,+ representation(colspans = "integer") ## , |
||
| 74 | +1354 |
- dfpart, func, totcount, splextra,+ ## pos_in_tree = "TableRowPos"), |
||
| 75 | +1355 |
- all_col_exprs,+ ## validity = function(object) {
|
||
| 76 | +1356 |
- all_col_counts,+ ## lcsp = length(object@colspans) |
||
| 77 | +1357 |
- takesdf = .takes_df(func),+ ## length(lcsp == 0) || lcsp == length(object@leaf_value) |
||
| 78 | +1358 |
- baselinedf,+ ## } |
||
| 79 | +1359 |
- alt_dfpart,+ ) |
||
| 80 | +1360 |
- inclNAs,+ |
||
| 81 | +1361 |
- col_parent_inds,+ #' @rdname rowclasses |
||
| 82 | +1362 |
- spl_context) {
+ #' @exportClass ContentRow |
||
| 83 | -5734x | +|||
| 1363 | +
- if (NROW(spl_context) > 0) {
+ setClass("ContentRow",
|
|||
| 84 | -5713x | +|||
| 1364 | +
- spl_context$cur_col_id <- paste(cpath[seq(2, length(cpath), 2)], collapse = ".")+ contains = "TableRow", |
|||
| 85 | -5713x | +|||
| 1365 | +
- spl_context$cur_col_subset <- col_parent_inds+ representation(colspans = "integer") ## , |
|||
| 86 | -5713x | +|||
| 1366 | +
- spl_context$cur_col_expr <- list(csub)+ ## pos_in_tree = "TableRowPos"), |
|||
| 87 | -5713x | +|||
| 1367 | +
- spl_context$cur_col_n <- vapply(col_parent_inds, sum, 1L)+ ## validity = function(object) {
|
|||
| 88 | -5713x | +|||
| 1368 | +
- spl_context$cur_col_split <- list(cpath[seq(1, length(cpath), 2)])+ ## lcsp = length(object@colspans) |
|||
| 89 | -5713x | +|||
| 1369 | +
- spl_context$cur_col_split_val <- list(cpath[seq(2, length(cpath), 2)])+ ## length(lcsp == 0) || lcsp == length(object@leaf_value) |
|||
| 90 | +1370 |
- }+ ## } |
||
| 91 | +1371 | ++ |
+ )+ |
+ |
| 1372 | ||||
| 92 | +1373 |
- # Making .alt_df from alt_dfpart (i.e. .alt_df_row)+ #' @rdname rowclasses |
||
| 93 | -5734x | +|||
| 1374 | +
- if (NROW(alt_dfpart) > 0) {
+ #' @exportClass LabelRow |
|||
| 94 | -105x | +|||
| 1375 | +
- alt_dfpart_fil <- alt_dfpart[eval(csub, envir = alt_dfpart), , drop = FALSE]+ setClass("LabelRow",
|
|||
| 95 | -105x | +|||
| 1376 | +
- if (!is.null(col) && col %in% names(alt_dfpart_fil) && !inclNAs) {
+ contains = "TableRow", |
|||
| 96 | -99x | +|||
| 1377 | +
- alt_dfpart_fil <- alt_dfpart_fil[!is.na(alt_dfpart_fil[[col]]), ,+ representation(visible = "logical") |
|||
| 97 | -99x | +|||
| 1378 | +
- drop = FALSE+ ) |
|||
| 98 | +1379 |
- ]+ |
||
| 99 | +1380 |
- }+ #' @param klass (`character`)\cr internal detail. |
||
| 100 | +1381 |
- } else {
+ #' |
||
| 101 | -5629x | +|||
| 1382 | +
- alt_dfpart_fil <- alt_dfpart+ #' @export |
|||
| 102 | +1383 |
- }+ #' @rdname rowclasses |
||
| 103 | +1384 |
-
+ .tablerow <- function(vals = list(), |
||
| 104 | +1385 |
- ## workaround for https://github.com/insightsengineering/rtables/issues/159+ name = "", |
||
| 105 | -5734x | +|||
| 1386 | +
- if (NROW(dfpart) > 0) {
+ lev = 1L, |
|||
| 106 | -4882x | +|||
| 1387 | +
- inds <- eval(csub, envir = dfpart)+ label = name, |
|||
| 107 | -4882x | +|||
| 1388 | +
- dat <- dfpart[inds, , drop = FALSE]+ cspan = rep(1L, length(vals)), |
|||
| 108 | +1389 |
- } else {
+ cinfo = EmptyColInfo, |
||
| 109 | -852x | +|||
| 1390 | +
- dat <- dfpart+ var = NA_character_, |
|||
| 110 | +1391 |
- }+ format = NULL, |
||
| 111 | -5734x | +|||
| 1392 | +
- if (!is.null(col) && !inclNAs) {
+ na_str = NA_character_, |
|||
| 112 | -4476x | +|||
| 1393 | +
- dat <- dat[!is.na(dat[[col]]), , drop = FALSE]+ klass, |
|||
| 113 | +1394 |
- }+ indent_mod = 0L, |
||
| 114 | +1395 |
-
+ footnotes = list(), |
||
| 115 | -5734x | +|||
| 1396 | +
- fullrefcoldat <- cextr$.ref_full+ table_inset = 0L,+ |
+ |||
| 1397 | ++ |
+ trailing_section_div = NA_character_) {
|
||
| 116 | -5734x | +1398 | +3380x |
- if (!is.null(fullrefcoldat)) {
+ if ((missing(name) || is.null(name) || is.na(name) || nchar(name) == 0) && !missing(label)) {
|
| 117 | -141x | +1399 | +257x |
- cextr$.ref_full <- NULL+ name <- label |
| 118 | +1400 |
} |
||
| 119 | -5734x | +1401 | +3380x |
- inrefcol <- cextr$.in_ref_col+ vals <- lapply(vals, rcell) |
| 120 | -5734x | +1402 | +3380x |
- if (!is.null(fullrefcoldat)) {
+ rlabels <- unique(unlist(lapply(vals, obj_label))) |
| 121 | -141x | +1403 | +3380x |
- cextr$.in_ref_col <- NULL+ if ((missing(label) || is.null(label) || identical(label, "")) && sum(nzchar(rlabels)) == 1) {
|
| 122 | -+ | |||
| 1404 | +! |
- }+ label <- rlabels[nzchar(rlabels)] |
||
| 123 | +1405 |
-
+ } |
||
| 124 | -5734x | +1406 | +3380x |
- exargs <- c(cextr, splextra)+ if (missing(cspan) && !is.null(unlist(lapply(vals, cell_cspan)))) {
|
| 125 | -+ | |||
| 1407 | +3122x |
-
+ cspan <- vapply(vals, cell_cspan, 0L) |
||
| 126 | +1408 |
- ## behavior for x/df and ref-data (full and group)+ } |
||
| 127 | +1409 |
- ## match+ |
||
| 128 | -5734x | +1410 | +3380x |
- if (!is.null(col) && !takesdf) {
- |
-
| 129 | -3583x | -
- dat <- dat[[col]]+ check_ok_label(label) |
||
| 130 | -3583x | +1411 | +3380x |
- fullrefcoldat <- fullrefcoldat[[col]]+ rw <- new(klass, |
| 131 | -3583x | -
- baselinedf <- baselinedf[[col]]- |
- ||
| 132 | -+ | 1412 | +3380x |
- }+ leaf_value = vals, |
| 133 | -5734x | -
- args <- list(dat)- |
- ||
| 134 | -+ | 1413 | +3380x |
-
+ name = .chkname(name), |
| 135 | -5734x | -
- names(all_col_counts) <- names(all_col_exprs)- |
- ||
| 136 | -+ | 1414 | +3380x |
-
+ level = lev, |
| 137 | -5734x | +1415 | +3380x |
- exargs <- match_extra_args(func,+ label = .chkname(label), |
| 138 | -5734x | +1416 | +3380x |
- .N_col = count,+ colspans = cspan, |
| 139 | -5734x | +1417 | +3380x |
- .N_total = totcount,+ col_info = cinfo, |
| 140 | -5734x | +1418 | +3380x |
- .all_col_exprs = all_col_exprs,+ var_analyzed = var, |
| 141 | -5734x | +|||
| 1419 | +
- .all_col_counts = all_col_counts,+ ## these are set in set_format_recursive below |
|||
| 142 | -5734x | +1420 | +3380x |
- .var = col,+ format = NULL, |
| 143 | -5734x | +1421 | +3380x |
- .ref_group = baselinedf,+ na_str = NA_character_, |
| 144 | -5734x | +1422 | +3380x |
- .alt_df_row = alt_dfpart,+ indent_modifier = indent_mod, |
| 145 | -5734x | +1423 | +3380x |
- .alt_df = alt_dfpart_fil,+ row_footnotes = footnotes, |
| 146 | -5734x | +1424 | +3380x |
- .ref_full = fullrefcoldat,+ table_inset = table_inset, |
| 147 | -5734x | +1425 | +3380x |
- .in_ref_col = inrefcol,+ trailing_section_div = trailing_section_div |
| 148 | -5734x | +|||
| 1426 | +
- .N_row = NROW(dfpart),+ ) |
|||
| 149 | -5734x | +1427 | +3380x |
- .df_row = dfpart,+ rw <- set_format_recursive(rw, format, na_str, FALSE) |
| 150 | -5734x | +1428 | +3380x |
- .spl_context = spl_context,+ rw |
| 151 | -5734x | +|||
| 1429 | +
- extras = c(+ } |
|||
| 152 | -5734x | +|||
| 1430 | +
- cextr,+ |
|||
| 153 | -5734x | +|||
| 1431 | +
- splextra+ #' @param ... additional parameters passed to shared constructor (`.tablerow`). |
|||
| 154 | +1432 |
- )+ #' |
||
| 155 | +1433 |
- )+ #' @export |
||
| 156 | +1434 |
-
+ #' @rdname rowclasses |
||
| 157 | -5734x | +1435 | +2848x |
- args <- c(args, exargs)+ DataRow <- function(...) .tablerow(..., klass = "DataRow") |
| 158 | +1436 | |||
| 159 | -5734x | -
- val <- do.call(func, args)- |
- ||
| 160 | -5731x | -
- if (!is(val, "RowsVerticalSection")) {
- |
- ||
| 161 | -3732x | -
- if (!is(val, "list")) {
- |
- ||
| 162 | -3254x | -
- val <- list(val)- |
- ||
| 163 | +1437 |
- }- |
- ||
| 164 | -3732x | -
- ret <- in_rows(- |
- ||
| 165 | -3732x | -
- .list = val,+ #' @export |
||
| 166 | -3732x | +|||
| 1438 | +
- .labels = unlist(value_labels(val)),+ #' @rdname rowclasses |
|||
| 167 | -3732x | +1439 | +532x |
- .names = names(val)+ ContentRow <- function(...) .tablerow(..., klass = "ContentRow") |
| 168 | +1440 |
- )+ |
||
| 169 | +1441 |
- } else {
+ setClass("VTitleFooter",
|
||
| 170 | -1999x | +|||
| 1442 | +
- ret <- val+ contains = "VIRTUAL", |
|||
| 171 | +1443 |
- }+ representation( |
||
| 172 | -5731x | +|||
| 1444 | +
- ret+ main_title = "character", |
|||
| 173 | +1445 |
- }+ subtitles = "character", |
||
| 174 | +1446 |
-
+ main_footer = "character", |
||
| 175 | +1447 |
- strip_multivar_suffix <- function(x) {
+ provenance_footer = "character" |
||
| 176 | -228x | +|||
| 1448 | +
- gsub("\\._\\[\\[[0-9]\\]\\]_\\.$", "", x)
+ ) |
|||
| 177 | +1449 |
- }+ ) |
||
| 178 | +1450 | |||
| 179 | +1451 |
- ## Generate all values (one for each column) for one or more rows+ setClass("VTableTree",
|
||
| 180 | +1452 |
- ## by calling func once per column (as defined by cinfo)+ contains = c("VIRTUAL", "VTableNodeInfo", "VTree", "VTitleFooter"),
|
||
| 181 | +1453 |
- #' @noRd+ representation( |
||
| 182 | +1454 |
- #' @return A list of `m` `RowsVerticalSection` objects, one for each (leaf) column in the table.+ children = "list", |
||
| 183 | +1455 |
- gen_rowvalues <- function(dfpart,+ rowspans = "data.frame", |
||
| 184 | +1456 |
- datcol,+ labelrow = "LabelRow", |
||
| 185 | +1457 |
- cinfo,+ page_titles = "character", |
||
| 186 | +1458 |
- func,+ horizontal_sep = "character", |
||
| 187 | +1459 |
- splextra,+ header_section_div = "character", |
||
| 188 | +1460 |
- takesdf = NULL,+ trailing_section_div = "character" |
||
| 189 | +1461 |
- baselines,+ ) |
||
| 190 | +1462 |
- alt_dfpart,+ ) |
||
| 191 | +1463 |
- inclNAs,+ |
||
| 192 | +1464 |
- spl_context = spl_context) {
- |
- ||
| 193 | -1571x | -
- colexprs <- col_exprs(cinfo)- |
- ||
| 194 | -1571x | -
- colcounts <- col_counts(cinfo)- |
- ||
| 195 | -1571x | -
- colextras <- col_extra_args(cinfo, NULL)- |
- ||
| 196 | -1571x | -
- cpaths <- col_paths(cinfo)+ setClassUnion("IntegerOrNull", c("integer", "NULL"))
|
||
| 197 | +1465 |
- ## XXX I don't think this is used anywhere???+ ## covered because it's ElementaryTable's validity method but covr misses it |
||
| 198 | +1466 |
- ## splextra = c(splextra, list(.spl_context = spl_context))- |
- ||
| 199 | -1571x | -
- totcount <- col_total(cinfo)+ ## nocov start |
||
| 200 | +1467 | - - | -||
| 201 | -1571x | -
- colleaves <- collect_leaves(cinfo@tree_layout)+ etable_validity <- function(object) {
|
||
| 202 | +1468 |
-
+ kids <- tree_children(object) |
||
| 203 | -1571x | +|||
| 1469 | +
- gotflist <- is.list(func)+ all(sapply( |
|||
| 204 | +1470 |
-
+ kids, |
||
| 205 | +1471 |
- ## one set of named args to be applied to all columns+ function(k) {
|
||
| 206 | -1571x | +|||
| 1472 | +
- if (!is.null(names(splextra))) {
+ (is(k, "DataRow") || is(k, "ContentRow")) |
|||
| 207 | -25x | +|||
| 1473 | +
- splextra <- list(splextra)+ } |
|||
| 208 | +1474 |
- } else {
+ )) ### && |
||
| 209 | -1546x | +|||
| 1475 | +
- length(splextra) <- ncol(cinfo)+ } |
|||
| 210 | +1476 |
- }+ ## nocov end |
||
| 211 | +1477 | |||
| 212 | -1571x | -
- if (!gotflist) {
- |
- ||
| 213 | -1048x | -
- func <- list(func)- |
- ||
| 214 | -523x | -
- } else if (length(splextra) == 1) {
- |
- ||
| 215 | -114x | -
- splextra <- rep(splextra, length.out = length(func))- |
- ||
| 216 | +1478 |
- }+ #' `TableTree` classes |
||
| 217 | +1479 |
- ## if(length(func)) == 1 && names(spl)+ #' |
||
| 218 | +1480 |
- ## splextra = list(splextra)+ #' @return A formal object representing a populated table. |
||
| 219 | +1481 |
-
+ #' |
||
| 220 | +1482 |
- ## we are in analyze_colvars, so we have to match+ #' @author Gabriel Becker |
||
| 221 | +1483 |
- ## the exargs value by position for each column repeatedly+ #' @exportClass ElementaryTable |
||
| 222 | +1484 |
- ## across the higher level col splits.+ #' @rdname tabclasses |
||
| 223 | -1571x | +|||
| 1485 | +
- if (!is.null(datcol) && is.na(datcol)) {
+ setClass("ElementaryTable",
|
|||
| 224 | -54x | +|||
| 1486 | +
- datcol <- character(length(colleaves))+ contains = "VTableTree", |
|||
| 225 | -54x | +|||
| 1487 | +
- exargs <- vector("list", length(colleaves))
+ representation(var_analyzed = "character"), |
|||
| 226 | -54x | +|||
| 1488 | +
- for (i in seq_along(colleaves)) {
+ validity = etable_validity ## function(object) {
|
|||
| 227 | -228x | +|||
| 1489 | +
- x <- colleaves[[i]]+ ) |
|||
| 228 | +1490 | |||
| 229 | -228x | -
- pos <- tree_pos(x)- |
- ||
| 230 | -228x | -
- spls <- pos_splits(pos)- |
- ||
| 231 | +1491 |
- ## values have the suffix but we are populating datacol+ .enforce_valid_kids <- function(lst, colinfo) {
|
||
| 232 | +1492 |
- ## so it has to match var numbers so strip the suffixes back off- |
- ||
| 233 | -228x | -
- splvals <- strip_multivar_suffix(rawvalues(pos))+ ## colinfo |
||
| 234 | -228x | +1493 | +6054x |
- n <- length(spls)+ if (!no_colinfo(colinfo)) {
|
| 235 | -228x | +1494 | +6054x |
- datcol[i] <- if (is(spls[[n]], "MultiVarSplit")) {
+ lst <- lapply( |
| 236 | -228x | -
- splvals[n]- |
- ||
| 237 | -+ | 1495 | +6054x |
- } else {
+ lst, |
| 238 | -228x | -
- NA_character_- |
- ||
| 239 | -+ | 1496 | +6054x |
- }+ function(x) {
|
| 240 | -228x | -
- argpos <- match(datcol[i], spl_payload(spls[[n]]))- |
- ||
| 241 | -- |
- ## single bracket here because assigning NULL into a list removes- |
- ||
| 242 | -+ | 1497 | +7643x |
- ## the position entirely+ if (no_colinfo(x)) {
|
| 243 | -228x | +1498 | +208x |
- exargs[i] <- if (argpos <= length(splextra)) {
+ col_info(x) <- colinfo |
| 244 | -228x | +1499 | +7435x |
- splextra[argpos]+ } else if (!identical(colinfo, col_info(x), ignore.environment = TRUE)) {
|
| 245 | +1500 |
- } else {
- |
- ||
| 246 | -! | -
- list(NULL)+ ## split functions from function factories (e.g. add_combo_levels) |
||
| 247 | +1501 |
- }+ ## have different environments so we can't use identical here |
||
| 248 | +1502 |
- }+ ## all.equal requires the **values within the closures** to be the |
||
| 249 | +1503 |
- ## })- |
- ||
| 250 | -54x | -
- if (all(is.na(datcol))) {
+ ## same but not the actual enclosing environments. |
||
| 251 | +1504 | ! |
- datcol <- list(NULL)- |
- |
| 252 | -54x | -
- } else if (any(is.na(datcol))) {
+ stop( |
||
| 253 | +1505 | ! |
- stop("mix of var and non-var columns with NA analysis rowvara")
+ "attempted to add child with non-matching, non-empty ", |
|
| 254 | -+ | |||
| 1506 | +! |
- }+ "column info to an existing table" |
||
| 255 | +1507 |
- } else {
- |
- ||
| 256 | -1517x | -
- exargs <- splextra- |
- ||
| 257 | -1517x | -
- if (is.null(datcol)) {
- |
- ||
| 258 | -332x | -
- datcol <- list(NULL)+ ) |
||
| 259 | +1508 |
- }+ } |
||
| 260 | -1517x | +1509 | +7643x |
- datcol <- rep(datcol, length(colexprs))+ x |
| 261 | +1510 |
- ## if(gotflist)+ } |
||
| 262 | +1511 |
- ## length(exargs) <- length(func) ## func is a list- |
- ||
| 263 | -1517x | -
- exargs <- rep(exargs, length.out = length(colexprs))+ ) |
||
| 264 | +1512 |
} |
||
| 265 | -1571x | -
- allfuncs <- rep(func, length.out = length(colexprs))- |
- ||
| 266 | +1513 | |||
| 267 | -1571x | +1514 | +6054x |
- if (is.null(takesdf)) {
+ if (are(lst, "ElementaryTable") && |
| 268 | -1102x | +1515 | +6054x |
- takesdf <- .takes_df(allfuncs)+ all(sapply(lst, function(tb) {
|
| 269 | -+ | |||
| 1516 | +1060x |
- }+ nrow(tb) <= 1 && identical(obj_name(tb), "") |
||
| 270 | +1517 |
-
+ }))) {
|
||
| 271 | -1571x | +1518 | +1596x |
- rawvals <- mapply(gen_onerv,+ lst <- unlist(lapply(lst, function(tb) tree_children(tb)[[1]])) |
| 272 | -1571x | +|||
| 1519 | +
- csub = colexprs,+ } |
|||
| 273 | -1571x | +1520 | +6054x |
- col = datcol,+ if (length(lst) == 0) {
|
| 274 | -1571x | +1521 | +1596x |
- count = colcounts,+ return(list()) |
| 275 | -1571x | +|||
| 1522 | +
- cextr = colextras,+ } |
|||
| 276 | -1571x | +|||
| 1523 | +
- cpath = cpaths,+ ## names |
|||
| 277 | -1571x | +1524 | +4458x |
- baselinedf = baselines,+ realnames <- sapply(lst, obj_name) |
| 278 | -1571x | +1525 | +4458x |
- alt_dfpart = list(alt_dfpart),+ lstnames <- names(lst) |
| 279 | -1571x | +1526 | +4458x |
- func = allfuncs,+ if (is.null(lstnames)) {
|
| 280 | -1571x | +1527 | +1912x |
- takesdf = takesdf,+ names(lst) <- realnames |
| 281 | -1571x | +1528 | +2546x |
- col_parent_inds = spl_context[, names(colexprs),+ } else if (!identical(realnames, lstnames)) {
|
| 282 | -1571x | +1529 | +2546x |
- drop = FALSE+ names(lst) <- realnames |
| 283 | +1530 |
- ],- |
- ||
| 284 | -1571x | -
- all_col_exprs = list(colexprs),- |
- ||
| 285 | -1571x | -
- all_col_counts = list(colcounts),- |
- ||
| 286 | -1571x | -
- splextra = exargs,+ } |
||
| 287 | -1571x | +|||
| 1531 | +
- MoreArgs = list(+ |
|||
| 288 | -1571x | +1532 | +4458x |
- dfpart = dfpart,+ lst |
| 289 | -1571x | +|||
| 1533 | +
- totcount = totcount,+ } |
|||
| 290 | -1571x | +|||
| 1534 | +
- inclNAs = inclNAs,+ |
|||
| 291 | -1571x | +|||
| 1535 | +
- spl_context = spl_context+ #' Table constructors and classes |
|||
| 292 | +1536 |
- ),+ #' |
||
| 293 | -1571x | +|||
| 1537 | +
- SIMPLIFY = FALSE+ #' @inheritParams constr_args |
|||
| 294 | +1538 |
- )+ #' @inheritParams gen_args |
||
| 295 | +1539 |
-
+ #' @inheritParams lyt_args |
||
| 296 | -1568x | +|||
| 1540 | +
- names(rawvals) <- names(colexprs)+ #' @param rspans (`data.frame`)\cr currently stored but otherwise ignored. |
|||
| 297 | -1568x | +|||
| 1541 | +
- rawvals+ #' |
|||
| 298 | +1542 |
- }+ #' @author Gabriel Becker |
||
| 299 | +1543 |
-
+ #' @export |
||
| 300 | +1544 |
- .strip_lst_rvals <- function(lst) {
+ #' @rdname tabclasses |
||
| 301 | -! | +|||
| 1545 | +
- lapply(lst, rawvalues)+ ElementaryTable <- function(kids = list(), |
|||
| 302 | +1546 |
- }+ name = "", |
||
| 303 | +1547 |
-
+ lev = 1L, |
||
| 304 | +1548 |
- #' @noRd+ label = "", |
||
| 305 | +1549 |
- #' @return A list of table rows, even when only one is generated.+ labelrow = LabelRow( |
||
| 306 | +1550 |
- .make_tablerows <- function(dfpart,+ lev = lev, |
||
| 307 | +1551 |
- alt_dfpart,+ label = label, |
||
| 308 | +1552 |
- func,+ vis = !isTRUE(iscontent) && |
||
| 309 | +1553 |
- cinfo,+ !is.na(label) && |
||
| 310 | +1554 |
- datcol = NULL,+ nzchar(label) |
||
| 311 | +1555 |
- lev = 1L,+ ), |
||
| 312 | +1556 |
- rvlab = NA_character_,+ rspans = data.frame(), |
||
| 313 | +1557 |
- format = NULL,+ cinfo = NULL, |
||
| 314 | +1558 |
- defrowlabs = NULL,+ iscontent = NA, |
||
| 315 | +1559 |
- rowconstr = DataRow,+ var = NA_character_, |
||
| 316 | +1560 |
- splextra = list(),+ format = NULL, |
||
| 317 | +1561 |
- takesdf = NULL,+ na_str = NA_character_, |
||
| 318 | +1562 |
- baselines = replicate(+ indent_mod = 0L, |
||
| 319 | +1563 |
- length(col_exprs(cinfo)),+ title = "", |
||
| 320 | +1564 |
- list(dfpart[0, ])+ subtitles = character(), |
||
| 321 | +1565 |
- ),+ main_footer = character(), |
||
| 322 | +1566 |
- inclNAs,+ prov_footer = character(), |
||
| 323 | +1567 |
- spl_context = context_df_row(cinfo = cinfo)) {
+ header_section_div = NA_character_, |
||
| 324 | -1571x | +|||
| 1568 | +
- if (is.null(datcol) && !is.na(rvlab)) {
+ hsep = default_hsep(), |
|||
| 325 | -! | +|||
| 1569 | +
- stop("NULL datcol but non-na rowvar label")
+ trailing_section_div = NA_character_, |
|||
| 326 | +1570 |
- }+ inset = 0L) {
|
||
| 327 | -1571x | +1571 | +3140x |
- if (!is.null(datcol) && !is.na(datcol)) {
+ check_ok_label(label) |
| 328 | -1185x | +1572 | +3140x |
- if (!all(datcol %in% names(dfpart))) {
+ if (is.null(cinfo)) {
|
| 329 | +1573 | ! |
- stop(+ if (length(kids) > 0) {
|
|
| 330 | +1574 | ! |
- "specified analysis variable (", datcol,
+ cinfo <- col_info(kids[[1]])+ |
+ |
| 1575 | ++ |
+ } else {
|
||
| 331 | +1576 | ! |
- ") not present in data"+ cinfo <- EmptyColInfo |
|
| 332 | +1577 |
- )+ } |
||
| 333 | +1578 |
- }+ } |
||
| 334 | +1579 | |||
| 335 | -1185x | +1580 | +3140x |
- rowvar <- datcol+ if (no_colinfo(labelrow)) {
+ |
+
| 1581 | +1923x | +
+ col_info(labelrow) <- cinfo |
||
| 336 | +1582 |
- } else {
+ } |
||
| 337 | -386x | +1583 | +3140x |
- rowvar <- NA_character_+ kids <- .enforce_valid_kids(kids, cinfo)+ |
+
| 1584 | +3140x | +
+ tab <- new("ElementaryTable",
+ |
+ ||
| 1585 | +3140x | +
+ children = kids,+ |
+ ||
| 1586 | +3140x | +
+ name = .chkname(name),+ |
+ ||
| 1587 | +3140x | +
+ level = lev,+ |
+ ||
| 1588 | +3140x | +
+ labelrow = labelrow,+ |
+ ||
| 1589 | +3140x | +
+ rowspans = rspans,+ |
+ ||
| 1590 | +3140x | +
+ col_info = cinfo,+ |
+ ||
| 1591 | +3140x | +
+ var_analyzed = var, |
||
| 338 | +1592 |
- }+ ## XXX these are hardcoded, because they both get set during |
||
| 339 | +1593 |
-
+ ## set_format_recursive anyway |
||
| 340 | -1571x | +1594 | +3140x |
- rawvals <- gen_rowvalues(dfpart,+ format = NULL, |
| 341 | -1571x | +1595 | +3140x |
- alt_dfpart = alt_dfpart,+ na_str = NA_character_, |
| 342 | -1571x | +1596 | +3140x |
- datcol = datcol,+ table_inset = 0L, |
| 343 | -1571x | +1597 | +3140x |
- cinfo = cinfo,+ indent_modifier = as.integer(indent_mod), |
| 344 | -1571x | +1598 | +3140x |
- func = func,+ main_title = title, |
| 345 | -1571x | +1599 | +3140x |
- splextra = splextra,+ subtitles = subtitles, |
| 346 | -1571x | +1600 | +3140x |
- takesdf = takesdf,+ main_footer = main_footer, |
| 347 | -1571x | +1601 | +3140x |
- baselines = baselines,+ provenance_footer = prov_footer, |
| 348 | -1571x | +1602 | +3140x |
- inclNAs = inclNAs,+ horizontal_sep = hsep, |
| 349 | -1571x | +1603 | +3140x |
- spl_context = spl_context+ header_section_div = header_section_div,+ |
+
| 1604 | +3140x | +
+ trailing_section_div = trailing_section_div |
||
| 350 | +1605 |
) |
||
| 1606 | +3140x | +
+ tab <- set_format_recursive(tab, format, na_str, FALSE)+ |
+ ||
| 1607 | +3140x | +
+ table_inset(tab) <- as.integer(inset)+ |
+ ||
| 1608 | +3140x | +
+ tab+ |
+ ||
| 351 | +1609 |
-
+ } |
||
| 352 | +1610 |
- ## if(is.null(rvtypes))+ |
||
| 353 | +1611 |
- ## rvtypes = rep(NA_character_, length(rawvals))+ ttable_validity <- function(object) {
|
||
| 354 | -1568x | +|||
| 1612 | +! |
- lens <- vapply(rawvals, length, NA_integer_)+ all(sapply( |
||
| 355 | -1568x | +|||
| 1613 | +! |
- unqlens <- unique(lens)+ tree_children(object), |
||
| 356 | -+ | |||
| 1614 | +! |
- ## length 0 returns are ok to not match cause they are+ function(x) is(x, "VTableTree") || is(x, "TableRow") |
||
| 357 | +1615 |
- ## just empty space we can fill in as needed.+ )) |
||
| 358 | -1568x | +|||
| 1616 | +
- if (length(unqlens[unqlens > 0]) != 1L) { ## length(unqlens) != 1 &&
+ } |
|||
| 359 | +1617 |
- ## (0 %in% unqlens && length(unqlens) != 2)) {
+
|
||
| 360 | -1x | +|||
| 1618 | +
- stop(+ .calc_cinfo <- function(cinfo, cont, kids) {
|
|||
| 361 | -1x | +1619 | +2914x |
- "Number of rows generated by analysis function do not match ",+ if (!is.null(cinfo)) {
|
| 362 | -1x | +1620 | +2914x |
- "across all columns. ",+ cinfo |
| 363 | -1x | +|||
| 1621 | +! |
- if (!is.na(datcol) && is.character(dfpart[[datcol]])) {
+ } else if (!is.null(cont)) {
|
||
| 364 | +1622 | ! |
- paste(+ col_info(cont) |
|
| 365 | +1623 | ! |
- "\nPerhaps convert analysis variable", datcol,+ } else if (length(kids) >= 1) {
|
|
| 366 | +1624 | ! |
- "to a factor?"+ col_info(kids[[1]]) |
|
| 367 | +1625 |
- )+ } else {
|
||
| 368 | -+ | |||
| 1626 | +! |
- }+ EmptyColInfo |
||
| 369 | +1627 |
- )+ } |
||
| 370 | +1628 |
- }+ } |
||
| 371 | -1567x | +|||
| 1629 | +
- maxind <- match(max(unqlens), lens)+ |
|||
| 372 | +1630 |
-
+ ## under this model, non-leaf nodes can have a content table where rollup |
||
| 373 | +1631 |
- ## look if we got labels, if not apply the+ ## analyses live |
||
| 374 | +1632 |
- ## default row labels+ #' @exportClass TableTree |
||
| 375 | +1633 |
- ## this is guaranteed to be a RowsVerticalSection object.+ #' @rdname tabclasses |
||
| 376 | -1567x | +|||
| 1634 | +
- rv1col <- rawvals[[maxind]]+ setClass("TableTree",
|
|||
| 377 | +1635 |
- ## nocov start+ contains = c("VTableTree"),
|
||
| 378 | +1636 |
- if (!is(rv1col, "RowsVerticalSection")) {
+ representation( |
||
| 379 | +1637 |
- stop(+ content = "ElementaryTable", |
||
| 380 | +1638 |
- "gen_rowvalues appears to have generated something that was not ",+ page_title_prefix = "character" |
||
| 381 | +1639 |
- "a RowsVerticalSection object. Please contact the maintainer."+ ), |
||
| 382 | +1640 |
- )+ validity = ttable_validity |
||
| 383 | +1641 |
- }+ ) |
||
| 384 | +1642 |
- # nocov end+ |
||
| 385 | +1643 |
-
+ #' @export |
||
| 386 | -1567x | +|||
| 1644 | +
- labels <- value_labels(rv1col)+ #' @rdname tabclasses |
|||
| 387 | +1645 |
-
+ TableTree <- function(kids = list(), |
||
| 388 | -1567x | +|||
| 1646 | +
- ncrows <- max(unqlens)+ name = if (!is.na(var)) var else "", |
|||
| 389 | -1567x | +|||
| 1647 | +
- if (ncrows == 0) {
+ cont = EmptyElTable, |
|||
| 390 | -! | +|||
| 1648 | +
- return(list())+ lev = 1L, |
|||
| 391 | +1649 |
- }+ label = name, |
||
| 392 | -1567x | +|||
| 1650 | +
- stopifnot(ncrows > 0)+ labelrow = LabelRow( |
|||
| 393 | +1651 |
-
+ lev = lev, |
||
| 394 | -1567x | +|||
| 1652 | +
- if (is.null(labels)) {
+ label = label, |
|||
| 395 | -207x | +|||
| 1653 | +
- if (length(rawvals[[maxind]]) == length(defrowlabs)) {
+ vis = nrow(cont) == 0 && !is.na(label) && |
|||
| 396 | -199x | +|||
| 1654 | +
- labels <- defrowlabs+ nzchar(label) |
|||
| 397 | +1655 |
- } else {
+ ), |
||
| 398 | -8x | +|||
| 1656 | +
- labels <- rep("", ncrows)
+ rspans = data.frame(), |
|||
| 399 | +1657 |
- }+ iscontent = NA, |
||
| 400 | +1658 |
- }+ var = NA_character_, |
||
| 401 | +1659 |
-
+ cinfo = NULL, |
||
| 402 | -1567x | +|||
| 1660 | +
- rfootnotes <- rep(list(list(), length(rv1col)))+ format = NULL, |
|||
| 403 | -1567x | +|||
| 1661 | +
- nms <- value_names(rv1col)+ na_str = NA_character_, |
|||
| 404 | -1567x | +|||
| 1662 | +
- rfootnotes <- row_footnotes(rv1col)+ indent_mod = 0L, |
|||
| 405 | +1663 |
-
+ title = "", |
||
| 406 | -1567x | +|||
| 1664 | +
- imods <- indent_mod(rv1col) ## rv1col@indent_mods+ subtitles = character(), |
|||
| 407 | -1567x | +|||
| 1665 | +
- unwrapped_vals <- lapply(rawvals, as, Class = "list", strict = TRUE)+ main_footer = character(), |
|||
| 408 | +1666 |
-
+ prov_footer = character(), |
||
| 409 | -1567x | +|||
| 1667 | +
- formatvec <- NULL+ page_title = NA_character_, |
|||
| 410 | -1567x | +|||
| 1668 | +
- if (!is.null(format)) {
+ hsep = default_hsep(), |
|||
| 411 | -200x | +|||
| 1669 | +
- if (is.function(format)) {
+ header_section_div = NA_character_, |
|||
| 412 | -1x | +|||
| 1670 | +
- format <- list(format)+ trailing_section_div = NA_character_, |
|||
| 413 | +1671 |
- }+ inset = 0L) {
|
||
| 414 | -200x | +1672 | +2914x |
- formatvec <- rep(format, length.out = ncrows)+ check_ok_label(label) |
| 415 | -+ | |||
| 1673 | +2914x |
- }+ cinfo <- .calc_cinfo(cinfo, cont, kids) |
||
| 416 | +1674 | |||
| 417 | -1567x | +1675 | +2914x |
- trows <- lapply(1:ncrows, function(i) {
+ kids <- .enforce_valid_kids(kids, cinfo) |
| 418 | -2532x | +1676 | +2914x |
- rowvals <- lapply(unwrapped_vals, function(colvals) {
+ if (isTRUE(iscontent) && !is.null(cont) && nrow(cont) > 0) {
|
| 419 | -9046x | +|||
| 1677 | +! |
- colvals[[i]]+ stop("Got table tree with content table and content position")
|
||
| 420 | +1678 |
- })+ } |
||
| 421 | -2532x | +1679 | +2914x |
- imod <- unique(vapply(rowvals, indent_mod, 0L))+ if (no_colinfo(labelrow)) {
|
| 422 | -2532x | +1680 | +1657x |
- if (length(imod) != 1) {
+ col_info(labelrow) <- cinfo |
| 423 | -! | +|||
| 1681 | +
- stop(+ } |
|||
| 424 | -! | +|||
| 1682 | +2914x |
- "Different cells in the same row appear to have been given ",+ if ((is.null(cont) || nrow(cont) == 0) && all(sapply(kids, is, "DataRow"))) {
+ |
+ ||
| 1683 | +1200x | +
+ if (!is.na(page_title)) {
|
||
| 425 | +1684 | ! |
- "different indent_mod values"+ stop("Got a page title prefix for an Elementary Table")
|
|
| 426 | +1685 |
- )+ } |
||
| 427 | +1686 |
- }+ ## constructor takes care of recursive format application |
||
| 428 | -2532x | +1687 | +1200x |
- rowconstr(+ ElementaryTable( |
| 429 | -2532x | +1688 | +1200x |
- vals = rowvals,+ kids = kids, |
| 430 | -2532x | +1689 | +1200x |
- cinfo = cinfo,+ name = .chkname(name), |
| 431 | -2532x | +1690 | +1200x |
lev = lev, |
| 432 | -2532x | +1691 | +1200x |
- label = labels[i],+ labelrow = labelrow, |
| 433 | -2532x | +1692 | +1200x |
- name = nms[i], ## labels[i], ## XXX this is probably wrong?!+ rspans = rspans, |
| 434 | -2532x | +1693 | +1200x |
- var = rowvar,+ cinfo = cinfo, |
| 435 | -2532x | +1694 | +1200x |
- format = formatvec[[i]],+ var = var, |
| 436 | -2532x | +1695 | +1200x |
- indent_mod = imods[[i]] %||% 0L,+ format = format, |
| 437 | -2532x | +1696 | +1200x |
- footnotes = rfootnotes[[i]] ## one bracket so list+ na_str = na_str, |
| 438 | -+ | |||
| 1697 | +1200x |
- )+ indent_mod = indent_mod, |
||
| 439 | -+ | |||
| 1698 | +1200x |
- })+ title = title, |
||
| 440 | -1567x | +1699 | +1200x |
- trows+ subtitles = subtitles, |
| 441 | -+ | |||
| 1700 | +1200x |
- }+ main_footer = main_footer, |
||
| 442 | -+ | |||
| 1701 | +1200x |
-
+ prov_footer = prov_footer, |
||
| 443 | -+ | |||
| 1702 | +1200x |
- .make_caller <- function(parent_cfun, clabelstr = "") {
+ hsep = hsep, |
||
| 444 | -480x | +1703 | +1200x |
- formalnms <- names(formals(parent_cfun))+ header_section_div = header_section_div, |
| 445 | -+ | |||
| 1704 | +1200x |
- ## note the <- here+ trailing_section_div = trailing_section_div, |
||
| 446 | -480x | +1705 | +1200x |
- if (!is.na(dotspos <- match("...", formalnms))) {
+ inset = inset |
| 447 | -1x | +|||
| 1706 | +
- toremove <- dotspos+ ) |
|||
| 448 | +1707 |
} else {
|
||
| 449 | -479x | +1708 | +1714x |
- toremove <- NULL+ tab <- new("TableTree",
|
| 450 | -+ | |||
| 1709 | +1714x |
- }+ content = cont, |
||
| 451 | -+ | |||
| 1710 | +1714x |
-
+ children = kids, |
||
| 452 | -480x | +1711 | +1714x |
- labelstrpos <- match("labelstr", names(formals(parent_cfun)))
+ name = .chkname(name), |
| 453 | -480x | +1712 | +1714x |
- if (is.na(labelstrpos)) {
+ level = lev, |
| 454 | -! | +|||
| 1713 | +1714x |
- stop(+ labelrow = labelrow, |
||
| 455 | -! | +|||
| 1714 | +1714x |
- "content function does not appear to accept the labelstr",+ rowspans = rspans, |
||
| 456 | -! | +|||
| 1715 | +1714x |
- "arguent"+ col_info = cinfo, |
||
| 457 | -+ | |||
| 1716 | +1714x |
- )+ format = NULL, |
||
| 458 | -+ | |||
| 1717 | +1714x |
- }+ na_str = na_str, |
||
| 459 | -480x | +1718 | +1714x |
- toremove <- c(toremove, labelstrpos)+ table_inset = 0L, |
| 460 | -480x | +1719 | +1714x |
- formalnms <- formalnms[-1 * toremove]+ indent_modifier = as.integer(indent_mod), |
| 461 | -+ | |||
| 1720 | +1714x |
-
+ main_title = title, |
||
| 462 | -480x | +1721 | +1714x |
- caller <- eval(parser_helper(text = paste(+ subtitles = subtitles, |
| 463 | -480x | +1722 | +1714x |
- "function() { parent_cfun(",
+ main_footer = main_footer, |
| 464 | -480x | +1723 | +1714x |
- paste(formalnms, "=",+ provenance_footer = prov_footer, |
| 465 | -480x | +1724 | +1714x |
- formalnms,+ page_title_prefix = page_title, |
| 466 | -480x | +1725 | +1714x |
- collapse = ", "+ horizontal_sep = "-", |
| 467 | -+ | |||
| 1726 | +1714x |
- ),+ header_section_div = header_section_div, |
||
| 468 | -480x | +1727 | +1714x |
- ", labelstr = clabelstr, ...)}"+ trailing_section_div = trailing_section_div+ |
+
| 1728 | +1714x | +
+ ) ## this is overridden below to get recursiveness+ |
+ ||
| 1729 | +1714x | +
+ tab <- set_format_recursive(tab, format, na_str, FALSE) |
||
| 469 | +1730 |
- )))+ |
||
| 470 | -480x | +|||
| 1731 | +
- formals(caller) <- c(+ ## these is recursive |
|||
| 471 | -480x | +|||
| 1732 | +
- formals(parent_cfun)[-labelstrpos],+ ## XXX combine these probably |
|||
| 472 | -480x | +1733 | +1714x |
- alist("..." = )
+ horizontal_sep(tab) <- hsep |
| 473 | -480x | +1734 | +1714x |
- ) # nolint+ table_inset(tab) <- as.integer(inset) |
| 474 | -480x | +1735 | +1714x |
- caller+ tab |
| 475 | +1736 | ++ |
+ }+ |
+ |
| 1737 |
} |
|||
| 476 | +1738 | |||
| 477 | +1739 |
- # Makes content table xxx renaming+ ### Pre-Data Layout Declaration Classes |
||
| 478 | +1740 |
- .make_ctab <- function(df,+ ### |
||
| 479 | +1741 |
- lvl, ## treepos,+ ### Notably these are NOT represented as trees |
||
| 480 | +1742 |
- name,+ ### because without data we cannot know what the |
||
| 481 | +1743 |
- label,+ ### children should be. |
||
| 482 | +1744 |
- cinfo,+ |
||
| 483 | +1745 |
- parent_cfun = NULL,+ ## Vector (ordered list) of splits. |
||
| 484 | +1746 |
- format = NULL,+ ## |
||
| 485 | +1747 |
- na_str = NA_character_,+ ## This is a vector (ordered list) of splits to be |
||
| 486 | +1748 |
- indent_mod = 0L,+ ## applied recursively to the data when provided. |
||
| 487 | +1749 |
- cvar = NULL,+ ## |
||
| 488 | +1750 |
- inclNAs,+ ## For convenience, if this is length 1, it can contain |
||
| 489 | +1751 |
- alt_df,+ ## a pre-existing TableTree/ElementaryTable. |
||
| 490 | +1752 |
- extra_args,+ ## This is used for add_existing_table in colby_constructors.R |
||
| 491 | +1753 |
- spl_context = context_df_row(cinfo = cinfo)) {
+
|
||
| 492 | -1834x | +|||
| 1754 | +
- if (length(cvar) == 0 || is.na(cvar) || identical(nchar(cvar), 0L)) {
+ setClass("SplitVector",
|
|||
| 493 | -1665x | +|||
| 1755 | +
- cvar <- NULL+ contains = "list", |
|||
| 494 | +1756 |
- }+ validity = function(object) {
|
||
| 495 | -1834x | +|||
| 1757 | +
- if (!is.null(parent_cfun)) {
+ if (length(object) >= 1) {
|
|||
| 496 | +1758 |
- ## cfunc <- .make_caller(parent_cfun, label)+ lst <- tail(object, 1)[[1]] |
||
| 497 | -469x | +|||
| 1759 | +
- cfunc <- lapply(parent_cfun, .make_caller, clabelstr = label)+ } else {
|
|||
| 498 | -469x | +|||
| 1760 | +
- contkids <- tryCatch(+ lst <- NULL |
|||
| 499 | -469x | +|||
| 1761 | +
- .make_tablerows(df,+ } |
|||
| 500 | -469x | +|||
| 1762 | +
- lev = lvl,+ all(sapply(head(object, -1), is, "Split")) && |
|||
| 501 | -469x | +|||
| 1763 | +
- func = cfunc,+ (is.null(lst) || is(lst, "Split") || is(lst, "VTableNodeInfo")) |
|||
| 502 | -469x | +|||
| 1764 | +
- cinfo = cinfo,+ } |
|||
| 503 | -469x | +|||
| 1765 | +
- rowconstr = ContentRow,+ ) |
|||
| 504 | -469x | +|||
| 1766 | +
- datcol = cvar,+ |
|||
| 505 | -469x | +|||
| 1767 | +
- takesdf = rep(.takes_df(cfunc),+ SplitVector <- function(x = NULL, |
|||
| 506 | -469x | +|||
| 1768 | +
- length.out = ncol(cinfo)+ ..., |
|||
| 507 | +1769 |
- ),+ lst = list(...)) {
|
||
| 508 | -469x | +1770 | +2538x |
- inclNAs = FALSE,+ if (!is.null(x)) {
|
| 509 | -469x | +1771 | +459x |
- alt_dfpart = alt_df,+ lst <- unlist(c(list(x), lst), recursive = FALSE) |
| 510 | -469x | +|||
| 1772 | +
- splextra = extra_args,+ } |
|||
| 511 | -469x | +1773 | +2538x |
- spl_context = spl_context+ new("SplitVector", lst)
|
| 512 | +1774 |
- ),+ } |
||
| 513 | -469x | +|||
| 1775 | +
- error = function(e) e+ |
|||
| 514 | +1776 |
- )+ avar_noneorlast <- function(vec) {
|
||
| 515 | -469x | +1777 | +1026x |
- if (is(contkids, "error")) {
+ if (!is(vec, "SplitVector")) {
+ |
+
| 1778 | +! | +
+ return(FALSE)+ |
+ ||
| 1779 | ++ |
+ } |
||
| 516 | -1x | +1780 | +1026x |
- stop("Error in content (summary) function: ", contkids$message,
+ if (length(vec) == 0) {
|
| 517 | -1x | +1781 | +670x |
- "\n\toccured at path: ",+ return(TRUE)+ |
+
| 1782 | ++ |
+ } |
||
| 518 | -1x | +1783 | +356x |
- spl_context_to_disp_path(spl_context),+ isavar <- which(sapply(vec, is, "AnalyzeVarSplit")) |
| 519 | -1x | +1784 | +356x |
- call. = FALSE+ (length(isavar) == 0) || (length(isavar) == 1 && isavar == length(vec)) |
| 520 | +1785 |
- )+ } |
||
| 521 | +1786 |
- }+ |
||
| 522 | +1787 |
- } else {
+ setClass("PreDataAxisLayout",
|
||
| 523 | -1365x | +|||
| 1788 | +
- contkids <- list()+ contains = "list", |
|||
| 524 | +1789 |
- }+ representation(root_split = "ANY"), |
||
| 525 | -1833x | +|||
| 1790 | +
- ctab <- ElementaryTable(+ validity = function(object) {
|
|||
| 526 | -1833x | +|||
| 1791 | +
- kids = contkids,+ allleafs <- unlist(object, recursive = TRUE) |
|||
| 527 | -1833x | +|||
| 1792 | +
- name = paste0(name, "@content"),+ all(sapply(object, avar_noneorlast)) && |
|||
| 528 | -1833x | +|||
| 1793 | +
- lev = lvl,+ all(sapply( |
|||
| 529 | -1833x | +|||
| 1794 | +
- labelrow = LabelRow(),+ allleafs, |
|||
| 530 | -1833x | +|||
| 1795 | +
- cinfo = cinfo,+ ## remember existing table trees can be added to layouts |
|||
| 531 | -1833x | +|||
| 1796 | +
- iscontent = TRUE,+ ## for now... |
|||
| 532 | -1833x | +|||
| 1797 | +
- format = format,+ function(x) is(x, "Split") || is(x, "VTableTree") |
|||
| 533 | -1833x | +|||
| 1798 | +
- indent_mod = indent_mod,+ )) |
|||
| 534 | -1833x | +|||
| 1799 | +
- na_str = na_str+ } |
|||
| 535 | +1800 |
- )+ ) |
||
| 536 | -1833x | +|||
| 1801 | +
- ctab+ |
|||
| 537 | +1802 |
- }+ setClass("PreDataColLayout",
|
||
| 538 | +1803 |
-
+ contains = "PreDataAxisLayout", |
||
| 539 | +1804 |
- .make_analyzed_tab <- function(df,+ representation( |
||
| 540 | +1805 |
- alt_df,+ display_columncounts = "logical", |
||
| 541 | +1806 |
- spl,+ columncount_format = "FormatSpec" # "character" |
||
| 542 | +1807 |
- cinfo,+ ) |
||
| 543 | +1808 |
- partlabel = "",+ ) |
||
| 544 | +1809 |
- dolab = TRUE,+ |
||
| 545 | +1810 |
- lvl,+ setClass("PreDataRowLayout", contains = "PreDataAxisLayout")
|
||
| 546 | +1811 |
- baselines,+ |
||
| 547 | +1812 |
- spl_context) {
+ PreDataColLayout <- function(x = SplitVector(), |
||
| 548 | -1103x | +|||
| 1813 | +
- stopifnot(is(spl, "VAnalyzeSplit"))+ rtsp = RootSplit(), |
|||
| 549 | -1103x | +|||
| 1814 | +
- check_validsplit(spl, df)+ ...,+ |
+ |||
| 1815 | ++ |
+ lst = list(x, ...),+ |
+ ||
| 1816 | ++ |
+ disp_colcounts = NA,+ |
+ ||
| 1817 | ++ |
+ colcount_format = "(N=xx)") {
|
||
| 550 | -1102x | +1818 | +330x |
- defrlabel <- spl@default_rowlabel+ ret <- new("PreDataColLayout", lst,
|
| 551 | -1102x | +1819 | +330x |
- if (nchar(defrlabel) == 0 && !missing(partlabel) && nchar(partlabel) > 0) {
+ display_columncounts = disp_colcounts, |
| 552 | -! | +|||
| 1820 | +330x |
- defrlabel <- partlabel+ columncount_format = colcount_format |
||
| 553 | +1821 |
- }+ ) |
||
| 554 | -1102x | +1822 | +330x |
- kids <- tryCatch(+ ret@root_split <- rtsp |
| 555 | -1102x | +1823 | +330x |
- .make_tablerows(df,+ ret |
| 556 | -1102x | +|||
| 1824 | +
- func = analysis_fun(spl),+ } |
|||
| 557 | -1102x | +|||
| 1825 | +
- defrowlabs = defrlabel, # XXX+ |
|||
| 558 | -1102x | +|||
| 1826 | +
- cinfo = cinfo,+ PreDataRowLayout <- function(x = SplitVector(), |
|||
| 559 | -1102x | +|||
| 1827 | +
- datcol = spl_payload(spl),+ root = RootSplit(), |
|||
| 560 | -1102x | +|||
| 1828 | +
- lev = lvl + 1L,+ ..., |
|||
| 561 | -1102x | +|||
| 1829 | +
- format = obj_format(spl),+ lst = list(x, ...)) {
|
|||
| 562 | -1102x | +1830 | +673x |
- splextra = split_exargs(spl),+ new("PreDataRowLayout", lst, root_split = root)
|
| 563 | -1102x | +|||
| 1831 | +
- baselines = baselines,+ } |
|||
| 564 | -1102x | +|||
| 1832 | +
- alt_dfpart = alt_df,+ |
|||
| 565 | -1102x | +|||
| 1833 | +
- inclNAs = avar_inclNAs(spl),+ setClass("PreDataTableLayouts",
|
|||
| 566 | -1102x | +|||
| 1834 | +
- spl_context = spl_context+ contains = "VTitleFooter", |
|||
| 567 | +1835 |
- ),+ representation( |
||
| 568 | -1102x | +|||
| 1836 | +
- error = function(e) e+ row_layout = "PreDataRowLayout", |
|||
| 569 | +1837 |
- )+ col_layout = "PreDataColLayout", |
||
| 570 | +1838 |
-
+ top_left = "character", |
||
| 571 | +1839 |
- # Adding section_div for DataRows (analyze leaves)+ header_section_div = "character", |
||
| 572 | -1102x | +|||
| 1840 | +
- kids <- .set_kids_section_div(kids, spl_section_div(spl), "DataRow")+ top_level_section_div = "character", |
|||
| 573 | +1841 |
-
+ table_inset = "integer" |
||
| 574 | -1102x | +|||
| 1842 | +
- if (is(kids, "error")) {
+ ) |
|||
| 575 | -3x | +|||
| 1843 | +
- stop("Error applying analysis function (var - ",
+ ) |
|||
| 576 | -3x | +|||
| 1844 | +
- spl_payload(spl) %||% "colvars", "): ", kids$message,+ |
|||
| 577 | -3x | +|||
| 1845 | +
- "\n\toccured at (row) path: ",+ PreDataTableLayouts <- function(rlayout = PreDataRowLayout(), |
|||
| 578 | -3x | +|||
| 1846 | +
- spl_context_to_disp_path(spl_context),+ clayout = PreDataColLayout(), |
|||
| 579 | -3x | +|||
| 1847 | +
- call. = FALSE+ topleft = character(), |
|||
| 580 | +1848 |
- )+ title = "", |
||
| 581 | +1849 |
- }+ subtitles = character(), |
||
| 582 | -1099x | +|||
| 1850 | +
- lab <- obj_label(spl)+ main_footer = character(), |
|||
| 583 | -1099x | +|||
| 1851 | +
- ret <- TableTree(+ prov_footer = character(), |
|||
| 584 | -1099x | +|||
| 1852 | +
- kids = kids,+ header_section_div = NA_character_, |
|||
| 585 | -1099x | +|||
| 1853 | +
- name = obj_name(spl),+ top_level_section_div = NA_character_,+ |
+ |||
| 1854 | ++ |
+ table_inset = 0L) {
|
||
| 586 | -1099x | +1855 | +330x |
- label = lab,+ new("PreDataTableLayouts",
|
| 587 | -1099x | +1856 | +330x |
- lev = lvl,+ row_layout = rlayout, |
| 588 | -1099x | +1857 | +330x |
- cinfo = cinfo,+ col_layout = clayout, |
| 589 | -1099x | +1858 | +330x |
- format = obj_format(spl),+ top_left = topleft, |
| 590 | -1099x | +1859 | +330x |
- na_str = obj_na_str(spl),+ main_title = title, |
| 591 | -1099x | +1860 | +330x |
- indent_mod = indent_mod(spl)+ subtitles = subtitles, |
| 592 | -+ | |||
| 1861 | +330x |
- )+ main_footer = main_footer, |
||
| 593 | -+ | |||
| 1862 | +330x |
-
+ provenance_footer = prov_footer, |
||
| 594 | -1099x | +1863 | +330x |
- labelrow_visible(ret) <- dolab+ header_section_div = header_section_div, |
| 595 | -1099x | +1864 | +330x |
- ret+ top_level_section_div = top_level_section_div, |
| 596 | -+ | |||
| 1865 | +330x |
- }+ table_inset = table_inset |
||
| 597 | +1866 |
-
+ ) |
||
| 598 | +1867 |
- #' @param ... all arguments to `recurse_applysplit`, methods may only use some of them.+ } |
||
| 599 | +1868 |
- #' @return A `list` of children to place at this level.+ |
||
| 600 | +1869 |
- #'+ ## setClass("CellValue", contains = "ValueWrapper",
|
||
| 601 | +1870 |
- #' @noRd+ ## representation(format = "FormatSpec", |
||
| 602 | +1871 |
- setGeneric(".make_split_kids", function(spl, have_controws, make_lrow, ...) {
+ ## colspan = "integerOrNULL", |
||
| 603 | -1626x | +|||
| 1872 | +
- standardGeneric(".make_split_kids")
+ ## label = "characterOrNULL"), |
|||
| 604 | +1873 |
- })+ ## prototype = list(label ="", colspan = NULL, format = NULL)) |
||
| 605 | +1874 | |||
| 606 | +1875 |
- ## single AnalyzeSplit+ setOldClass("CellValue")
|
||
| 607 | +1876 |
- setMethod(+ |
||
| 608 | +1877 |
- ".make_split_kids", "VAnalyzeSplit",+ #' Length of a Cell value |
||
| 609 | +1878 |
- function(spl,+ #' |
||
| 610 | +1879 |
- have_controws, ## unused here+ #' @param x (`CellValue`)\cr a `CellValue` object. |
||
| 611 | +1880 |
- make_lrow, ## unused here+ #' |
||
| 612 | +1881 |
- ...,+ #' @return Always returns `1L`. |
||
| 613 | +1882 |
- df,+ #' |
||
| 614 | +1883 |
- alt_df,+ #' @exportMethod length |
||
| 615 | +1884 |
- lvl,+ setMethod( |
||
| 616 | +1885 |
- name,+ "length", "CellValue", |
||
| 617 | -+ | |||
| 1886 | +! |
- cinfo,+ function(x) 1L |
||
| 618 | +1887 |
- baselines,+ ) |
||
| 619 | +1888 |
- spl_context,+ |
||
| 620 | +1889 |
- nsibs = 0) {
+ setClass("RefFootnote", representation(
|
||
| 621 | -1103x | +|||
| 1890 | +
- spvis <- labelrow_visible(spl)+ value = "character", |
|||
| 622 | -1103x | +|||
| 1891 | +
- if (is.na(spvis)) {
+ index = "integer", |
|||
| 623 | -182x | +|||
| 1892 | +
- spvis <- nsibs > 0+ symbol = "character" |
|||
| 624 | +1893 |
- }+ )) |
||
| 625 | +1894 | |||
| 626 | -1103x | +|||
| 1895 | +
- ret <- .make_analyzed_tab(+ RefFootnote <- function(note, index = NA_integer_, symbol = NA_character_) {
|
|||
| 627 | -1103x | +1896 | +56x |
- df = df,+ if (is(note, "RefFootnote")) {
|
| 628 | -1103x | +1897 | +28x |
- alt_df,+ return(note) |
| 629 | -1103x | +1898 | +28x |
- spl = spl,+ } else if (length(note) == 0) {
|
| 630 | -1103x | +|||
| 1899 | +! |
- cinfo = cinfo,+ return(NULL) |
||
| 631 | -1103x | +|||
| 1900 | +
- lvl = lvl + 1L,+ } |
|||
| 632 | -1103x | +1901 | +28x |
- dolab = spvis,+ if (length(symbol) != 1L) {
|
| 633 | -1103x | +|||
| 1902 | +! |
- partlabel = obj_label(spl),+ stop( |
||
| 634 | -1103x | +|||
| 1903 | +! |
- baselines = baselines,+ "Referential footnote can only have a single string as its index.", |
||
| 635 | -1103x | +|||
| 1904 | +! |
- spl_context = spl_context+ " Got char vector of length ", length(index) |
||
| 636 | +1905 |
) |
||
| 637 | -1099x | -
- indent_mod(ret) <- indent_mod(spl)- |
- ||
| 638 | +1906 | - - | -||
| 639 | -1099x | -
- kids <- list(ret)+ } |
||
| 640 | -1099x | +1907 | +28x |
- names(kids) <- obj_name(ret)+ if (!is.na(symbol) && (index == "NA" || grepl("[{}]", index))) {
|
| 641 | -1099x | +|||
| 1908 | +! |
- kids+ stop( |
||
| 642 | -+ | |||
| 1909 | +! |
- }+ "The string 'NA' and strings containing '{' or '}' cannot be used as ",
|
||
| 643 | -+ | |||
| 1910 | +! |
- )+ "referential footnote index symbols. Got string '", index, "'." |
||
| 644 | +1911 |
-
+ ) |
||
| 645 | +1912 |
- # Adding section_divisors to TableRow+ } |
||
| 646 | +1913 |
- .set_kids_section_div <- function(lst, trailing_section_div_char, allowed_class = "VTableTree") {
+
|
||
| 647 | -1599x | +1914 | +28x |
- if (!is.na(trailing_section_div_char)) {
+ new("RefFootnote", value = note, index = index, symbol = symbol)
|
| 648 | -29x | +|||
| 1915 | +
- lst <- lapply(+ } |
|||
| 649 | -29x | +|||
| 1916 | +
- lst,+ |
|||
| 650 | -29x | +|||
| 1917 | +
- function(k) {
+ #' Constructor for Cell Value |
|||
| 651 | -70x | +|||
| 1918 | +
- if (is(k, allowed_class)) {
+ #' |
|||
| 652 | -70x | +|||
| 1919 | +
- trailing_section_div(k) <- trailing_section_div_char+ #' @inheritParams lyt_args |
|||
| 653 | +1920 |
- }+ #' @inheritParams rcell |
||
| 654 | -70x | +|||
| 1921 | +
- k+ #' @param val (`ANY`)\cr value in the cell exactly as it should be passed to a formatter or returned when extracted. |
|||
| 655 | +1922 |
- }+ #' |
||
| 656 | +1923 |
- )+ #' @return An object representing the value within a single cell within a populated table. The underlying structure |
||
| 657 | +1924 |
- }+ #' of this object is an implementation detail and should not be relied upon beyond calling accessors for the class. |
||
| 658 | -1599x | +|||
| 1925 | +
- lst+ #' |
|||
| 659 | +1926 |
- }+ #' @export |
||
| 660 | +1927 | |||
| 661 | +1928 |
- ## 1 or more AnalyzeSplits+ ## Class definition |
||
| 662 | +1929 |
- setMethod(+ ## [[1]] list: cell value |
||
| 663 | +1930 |
- ".make_split_kids", "AnalyzeMultiVars",+ ## format : format for cell |
||
| 664 | +1931 |
- function(spl,+ ## colspan: column span info for cell |
||
| 665 | +1932 |
- have_controws,+ ## label: row label to be used for parent row |
||
| 666 | +1933 |
- make_lrow, ## used here+ ## indent_mod: indent modifier to be used for parent row |
||
| 667 | +1934 |
- spl_context,+ CellValue <- function(val, format = NULL, colspan = 1L, label = NULL, |
||
| 668 | +1935 |
- ...) { ## all passed directly down to VAnalyzeSplit method
- |
- ||
| 669 | -98x | -
- avspls <- spl_payload(spl)+ indent_mod = NULL, footnotes = NULL, |
||
| 670 | +1936 |
-
+ align = NULL, format_na_str = NULL, stat_names = NA_character_) {
|
||
| 671 | -98x | -
- nspl <- length(avspls)- |
- ||
| 672 | -+ | 1937 | +13451x |
-
+ if (is.null(colspan)) {
|
| 673 | -98x | +|||
| 1938 | +! |
- kids <- unlist(lapply(avspls,+ colspan <- 1L |
||
| 674 | -98x | +|||
| 1939 | +
- .make_split_kids,+ } |
|||
| 675 | -98x | +1940 | +13451x |
- nsibs = nspl - 1,+ if (!is.null(colspan) && !is(colspan, "integer")) {
|
| 676 | -98x | +1941 | +10x |
- have_controws = have_controws,+ colspan <- as.integer(colspan) |
| 677 | -98x | +|||
| 1942 | +
- make_lrow = make_lrow,+ } |
|||
| 678 | -98x | +|||
| 1943 | +
- spl_context = spl_context,+ ## if we're not given a label but the value has one associated with |
|||
| 679 | +1944 |
- ...+ ## it we use that. |
||
| 680 | +1945 |
- ))+ ## NB: we need to be able to override a non-empty label with an empty one |
||
| 681 | +1946 |
-
+ ## so we can't have "" mean "not given a label" here |
||
| 682 | -98x | +1947 | +13451x |
- kids <- .set_kids_section_div(kids, spl_section_div(spl), "VTableTree")+ if ((is.null(label) || is.na(label)) && !is.null(obj_label(val))) {
|
| 683 | -+ | |||
| 1948 | +2x |
-
+ label <- obj_label(val) |
||
| 684 | +1949 |
- ## XXX this seems like it should be identical not !identical+ } |
||
| 685 | -+ | |||
| 1950 | +13451x |
- ## TODO FIXME+ if (!is.list(footnotes)) {
|
||
| 686 | -98x | +1951 | +9x |
- if (!identical(make_lrow, FALSE) && !have_controws && length(kids) == 1) {
+ footnotes <- lapply(footnotes, RefFootnote) |
| 687 | +1952 |
- ## we only analyzed one var so+ } |
||
| 688 | -+ | |||
| 1953 | +13451x |
- ## we don't need an extra wrapper table+ check_ok_label(label) |
||
| 689 | -+ | |||
| 1954 | +13451x |
- ## in the structure+ ret <- structure(list(val), |
||
| 690 | -! | +|||
| 1955 | +13451x |
- stopifnot(identical(- |
- ||
| 691 | -! | -
- obj_name(kids[[1]]),+ format = format, colspan = colspan, |
||
| 692 | -! | +|||
| 1956 | +13451x |
- spl_payload(spl)+ label = label, |
||
| 693 | -+ | |||
| 1957 | +13451x |
- ))+ indent_mod = indent_mod, footnotes = footnotes, |
||
| 694 | -! | +|||
| 1958 | +13451x |
- return(kids[[1]])+ align = align, |
||
| 695 | -+ | |||
| 1959 | +13451x |
- }+ format_na_str = format_na_str, |
||
| 696 | -+ | |||
| 1960 | +13451x |
- ## this will be the variables+ stat_names = stat_names, |
||
| 697 | -+ | |||
| 1961 | +13451x |
- ## nms = sapply(spl_payload(spl), spl_payload)+ class = "CellValue" |
||
| 698 | +1962 |
-
+ ) |
||
| 699 | -98x | +1963 | +13451x |
- nms <- vapply(kids, obj_name, "")+ ret |
| 700 | -98x | +|||
| 1964 | +
- labs <- vapply(kids, obj_label, "")+ } |
|||
| 701 | -98x | +|||
| 1965 | +
- if (length(unique(nms)) != length(nms) && length(unique(nms)) != length(nms)) {
+
|
|||
| 702 | -1x | +|||
| 1966 | +
- warning("Non-unique sibling analysis table names. Using Labels ",
+ #' @method print CellValue |
|||
| 703 | -1x | +|||
| 1967 | +
- "instead. Use the table_names argument to analyze to avoid ",+ #' |
|||
| 704 | -1x | +|||
| 1968 | +
- "this when analyzing the same variable multiple times.",+ #' @export |
|||
| 705 | -1x | +|||
| 1969 | +
- "\n\toccured at (row) path: ",+ print.CellValue <- function(x, ...) {
|
|||
| 706 | -1x | +|||
| 1970 | +! |
- spl_context_to_disp_path(spl_context),+ cat(paste("rcell:", format_rcell(x), "\n"))
|
||
| 707 | -1x | +|||
| 1971 | +! |
- call. = FALSE+ invisible(x) |
||
| 708 | +1972 |
- )- |
- ||
| 709 | -1x | -
- kids <- mapply(function(k, nm) {
+ } |
||
| 710 | -2x | +|||
| 1973 | +
- obj_name(k) <- nm+ |
|||
| 711 | -2x | +|||
| 1974 | +
- k+ ## too slow |
|||
| 712 | -1x | +|||
| 1975 | +
- }, k = kids, nm = labs, SIMPLIFY = FALSE)+ # setClass("RowsVerticalSection", contains = "list",
|
|||
| 713 | -1x | +|||
| 1976 | +
- nms <- labs+ # representation = list(row_names = "characterOrNULL", |
|||
| 714 | +1977 |
- }+ # row_labels = "characterOrNULL", |
||
| 715 | +1978 |
-
+ # row_formats = "ANY", |
||
| 716 | -98x | +|||
| 1979 | +
- nms[is.na(nms)] <- ""+ # indent_mods = "integerOrNULL")) |
|||
| 717 | +1980 | |||
| 718 | -98x | +|||
| 1981 | +
- names(kids) <- nms+ setOldClass("RowsVerticalSection")
|
|||
| 719 | -98x | +|||
| 1982 | +
- kids+ RowsVerticalSection <- function(values, |
|||
| 720 | +1983 |
- }+ names = names(values), |
||
| 721 | +1984 |
- )+ labels = NULL, |
||
| 722 | +1985 |
-
+ indent_mods = NULL, |
||
| 723 | +1986 |
- setMethod(+ formats = NULL, |
||
| 724 | +1987 |
- ".make_split_kids", "Split",+ footnotes = NULL, |
||
| 725 | +1988 |
- function(spl,+ format_na_strs = NULL) {
|
||
| 726 | -+ | |||
| 1989 | +6148x |
- have_controws,+ stopifnot(is(values, "list")) |
||
| 727 | +1990 |
- make_lrow,+ ## innernms <- value_names(values) |
||
| 728 | +1991 |
- ...,+ |
||
| 729 | -+ | |||
| 1992 | +6148x |
- splvec, ## passed to recursive_applysplit+ if (is.null(labels)) {
|
||
| 730 | -+ | |||
| 1993 | +2849x |
- df, ## used to apply split+ labels <- names(values) |
||
| 731 | +1994 |
- alt_df, ## used to apply split for alternative df+ } |
||
| 732 | -+ | |||
| 1995 | +6148x |
- lvl, ## used to calculate innerlev+ if (is.null(names) && all(nzchar(labels))) {
|
||
| 733 | -+ | |||
| 1996 | +3341x |
- cinfo, ## used for sanity check+ names <- labels |
||
| 734 | -+ | |||
| 1997 | +2807x |
- baselines, ## used to calc new baselines+ } else if (is.null(labels) && !is.null(names)) {
+ |
+ ||
| 1998 | +15x | +
+ labels <- names |
||
| 735 | +1999 |
- spl_context) {
+ } |
||
| 736 | +2000 |
- ## do the core splitting of data into children for this split+ |
||
| 737 | -425x | +2001 | +6148x |
- rawpart <- do_split(spl, df, spl_context = spl_context)+ if (!is.null(indent_mods)) {
|
| 738 | -414x | +2002 | +68x |
- dataspl <- rawpart[["datasplit"]]+ indent_mods <- as.integer(indent_mods) |
| 739 | +2003 |
- ## these are SplitValue objects+ } |
||
| 740 | -414x | +2004 | +6148x |
- splvals <- rawpart[["values"]]+ check_ok_label(labels, multi_ok = TRUE) |
| 741 | -414x | +2005 | +6147x |
- partlabels <- rawpart[["labels"]]+ structure(values, |
| 742 | -414x | +2006 | +6147x |
- if (is.factor(partlabels)) {
+ class = "RowsVerticalSection", row_names = names, |
| 743 | -! | +|||
| 2007 | +6147x |
- partlabels <- as.character(partlabels)+ row_labels = labels, indent_mods = indent_mods, |
||
| 744 | -+ | |||
| 2008 | +6147x |
- }+ row_formats = formats, |
||
| 745 | -414x | +2009 | +6147x |
- nms <- unlist(value_names(splvals))+ row_na_strs = format_na_strs, |
| 746 | -414x | +2010 | +6147x |
- if (is.factor(nms)) {
+ row_footnotes = lapply( |
| 747 | -! | +|||
| 2011 | +6147x |
- nms <- as.character(nms)+ footnotes, |
||
| 748 | +2012 |
- }+ ## cause each row needs to accept |
||
| 749 | +2013 |
-
+ ## a *list* of row footnotes |
||
| 750 | -+ | |||
| 2014 | +6147x |
- ## Get new baseline values+ function(fns) lapply(fns, RefFootnote) |
||
| 751 | +2015 |
- ##+ ) |
||
| 752 | +2016 |
- ## XXX this is a lot of data churn, if it proves too slow+ ) |
||
| 753 | +2017 |
- ## we can+ } |
||
| 754 | +2018 |
- ## a) check if any of the analyses (i.e. the afuns) need the baseline in this+ |
||
| 755 | +2019 |
- ## splitvec and not do any of this if not, or+ #' @method print RowsVerticalSection |
||
| 756 | +2020 |
- ## b) refactor row splitting to behave like column splitting+ #' |
||
| 757 | +2021 |
- ##+ #' @export |
||
| 758 | +2022 |
- ## (b) seems the better design but is a major reworking of the guts of how+ print.RowsVerticalSection <- function(x, ...) {
|
||
| 759 | -+ | |||
| 2023 | +1x |
- ## rtables tabulation works+ cat("RowsVerticalSection (in_rows) object print method:\n-------------------",
|
||
| 760 | -+ | |||
| 2024 | +1x |
- ## (a) will only help if analyses that use baseline+ "---------\n",+ |
+ ||
| 2025 | +1x | +
+ sep = "" |
||
| 761 | +2026 |
- ## info are mixed with those who don't.+ ) |
||
| 762 | -414x | +2027 | +1x |
- newbl_raw <- lapply(baselines, function(dat) {
+ print(data.frame( |
| 763 | -+ | |||
| 2028 | +1x |
- # If no ref_group is specified+ row_name = attr(x, "row_names", exact = TRUE), |
||
| 764 | -1481x | +2029 | +1x |
- if (is.null(dat)) {
+ formatted_cell = vapply(x, format_rcell, character(1)), |
| 765 | -1461x | +2030 | +1x |
- return(NULL)+ indent_mod = indent_mod(x), ## vapply(x, indent_mod, numeric(1)), |
| 766 | -+ | |||
| 2031 | +1x |
- }+ row_label = attr(x, "row_labels", exact = TRUE), |
||
| 767 | -+ | |||
| 2032 | +1x |
-
+ stringsAsFactors = FALSE, |
||
| 768 | -+ | |||
| 2033 | +1x |
- ## apply the same splitting on the+ row.names = NULL |
||
| 769 | -20x | +2034 | +1x |
- bldataspl <- tryCatch(do_split(spl, dat, spl_context = spl_context)[["datasplit"]],+ ), row.names = TRUE) |
| 770 | -20x | +2035 | +1x |
- error = function(e) e+ invisible(x) |
| 771 | +2036 |
- )+ } |
||
| 772 | +2037 | |||
| 773 | +2038 |
- # Error localization+ #### Empty default objects to avoid repeated calls |
||
| 774 | -20x | +|||
| 2039 | +
- if (is(bldataspl, "error")) {
+ ## EmptyColInfo <- InstantiatedColumnInfo() |
|||
| 775 | -! | +|||
| 2040 | +
- stop("Following error encountered in splitting .ref_group (baselines): ",
+ ## EmptyElTable <- ElementaryTable() |
|||
| 776 | -! | +|||
| 2041 | +
- bldataspl$message,+ ## EmptyRootSplit <- RootSplit() |
|||
| 777 | -! | +|||
| 2042 | +
- call. = FALSE+ ## EmptyAllSplit <- AllSplit() |
| 778 | +1 |
- )+ # Generics and how they are used directly ------------------------------------- |
||
| 779 | +2 |
- }+ |
||
| 780 | +3 |
-
+ ## check_validsplit - Check if the split is valid for the data, error if not |
||
| 781 | +4 |
- ## we only keep the ones corresponding with actual data splits+ |
||
| 782 | -20x | +|||
| 5 | +
- res <- lapply(+ ## .apply_spl_extras - Generate Extras |
|||
| 783 | -20x | +|||
| 6 | +
- names(dataspl),+ |
|||
| 784 | -20x | +|||
| 7 | +
- function(nm) {
+ ## .apply_spl_datapart - generate data partition |
|||
| 785 | -52x | +|||
| 8 | +
- if (nm %in% names(bldataspl)) {
+
|
|||
| 786 | -52x | +|||
| 9 | +
- bldataspl[[nm]]+ ## .apply_spl_rawvals - Generate raw (i.e. non SplitValue object) partition values |
|||
| 787 | +10 |
- } else {
+
|
||
| 788 | -! | +|||
| 11 | +
- dataspl[[1]][0, ]+ setGeneric( |
|||
| 789 | +12 |
- }+ ".applysplit_rawvals",+ |
+ ||
| 13 | +1007x | +
+ function(spl, df) standardGeneric(".applysplit_rawvals")
|
||
| 790 | +14 |
- }+ ) |
||
| 791 | +15 |
- )+ |
||
| 792 | +16 |
-
+ setGeneric( |
||
| 793 | -20x | +|||
| 17 | +
- names(res) <- names(dataspl)+ ".applysplit_datapart", |
|||
| 794 | -20x | +18 | +1082x |
- res+ function(spl, df, vals) standardGeneric(".applysplit_datapart")
|
| 795 | +19 |
- })+ ) |
||
| 796 | +20 | |||
| 797 | -414x | +|||
| 21 | +
- newbaselines <- lapply(names(dataspl), function(nm) {
+ setGeneric( |
|||
| 798 | -1234x | +|||
| 22 | +
- lapply(newbl_raw, function(rawdat) {
+ ".applysplit_extras", |
|||
| 799 | -4384x | +23 | +1082x |
- if (nm %in% names(rawdat)) {
+ function(spl, df, vals) standardGeneric(".applysplit_extras")
|
| 800 | -52x | +|||
| 24 | +
- rawdat[[nm]]+ ) |
|||
| 801 | +25 |
- } else {
+
|
||
| 802 | -4332x | +|||
| 26 | +
- rawdat[[1]][0, ]+ setGeneric( |
|||
| 803 | +27 |
- }+ ".applysplit_partlabels", |
||
| 804 | -+ | |||
| 28 | +1079x |
- })+ function(spl, df, vals, labels) standardGeneric(".applysplit_partlabels")
|
||
| 805 | +29 |
- })+ ) |
||
| 806 | +30 | |||
| 807 | -414x | +|||
| 31 | +
- if (length(newbaselines) != length(dataspl)) {
+ setGeneric( |
|||
| 808 | -! | +|||
| 32 | +
- stop(+ "check_validsplit", |
|||
| 809 | -! | +|||
| 33 | +2259x |
- "Baselines (ref_group) after row split does not have",+ function(spl, df) standardGeneric("check_validsplit")
|
||
| 810 | -! | +|||
| 34 | +
- " the same number of levels of input data split. ",+ ) |
|||
| 811 | -! | +|||
| 35 | +
- "Contact the maintainer."+ |
|||
| 812 | -! | +|||
| 36 | +
- ) # nocov+ setGeneric( |
|||
| 813 | +37 |
- }+ ".applysplit_ref_vals", |
||
| 814 | -414x | +38 | +17x |
- if (!(length(newbaselines) == 0 ||+ function(spl, df, vals) standardGeneric(".applysplit_ref_vals")
|
| 815 | -414x | +|||
| 39 | +
- identical(+ ) |
|||
| 816 | -414x | +|||
| 40 | +
- unique(sapply(newbaselines, length)),+ # Custom split fncs ------------------------------------------------------------ |
|||
| 817 | -414x | +|||
| 41 | +
- length(col_exprs(cinfo))+ #' Custom split functions |
|||
| 818 | +42 |
- ))) {
+ #' |
||
| 819 | -! | +|||
| 43 | +
- stop(+ #' Split functions provide the work-horse for `rtables`'s generalized partitioning. These functions accept a (sub)set |
|||
| 820 | -! | +|||
| 44 | +
- "Baselines (ref_group) do not have the same number of columns",+ #' of incoming data and a split object, and return "splits" of that data. |
|||
| 821 | -! | +|||
| 45 | +
- " in each split. Contact the maintainer."+ #' |
|||
| 822 | -! | +|||
| 46 | +
- ) # nocov+ #' @section Custom Splitting Function Details: |
|||
| 823 | +47 |
- }+ #' |
||
| 824 | +48 |
-
+ #' User-defined custom split functions can perform any type of computation on the incoming data provided that they |
||
| 825 | +49 |
- # If params are not present do not do the calculation+ #' meet the requirements for generating "splits" of the incoming data based on the split object. |
||
| 826 | -414x | +|||
| 50 | +
- acdf_param <- check_afun_cfun_params(+ #' |
|||
| 827 | -414x | +|||
| 51 | +
- SplitVector(spl, splvec),+ #' Split functions are functions that accept: |
|||
| 828 | -414x | +|||
| 52 | +
- c(".alt_df", ".alt_df_row")
+ #' \describe{
|
|||
| 829 | +53 |
- )+ #' \item{df}{a `data.frame` of incoming data to be split.}
|
||
| 830 | +54 |
-
+ #' \item{spl}{a Split object. This is largely an internal detail custom functions will not need to worry about,
|
||
| 831 | +55 |
- # Apply same split for alt_counts_df+ #' but `obj_name(spl)`, for example, will give the name of the split as it will appear in paths in the resulting |
||
| 832 | -414x | +|||
| 56 | +
- if (!is.null(alt_df) && any(acdf_param)) {
+ #' table.} |
|||
| 833 | -17x | +|||
| 57 | +
- alt_dfpart <- tryCatch(+ #' \item{vals}{any pre-calculated values. If given non-`NULL` values, the values returned should match these.
|
|||
| 834 | -17x | +|||
| 58 | +
- do_split(spl, alt_df,+ #' Should be `NULL` in most cases and can usually be ignored.} |
|||
| 835 | -17x | +|||
| 59 | +
- spl_context = spl_context+ #' \item{labels}{any pre-calculated value labels. Same as above for `values`.}
|
|||
| 836 | -17x | +|||
| 60 | +
- )[["datasplit"]],+ #' \item{trim}{if `TRUE`, resulting splits that are empty are removed.}
|
|||
| 837 | -17x | +|||
| 61 | +
- error = function(e) e+ #' \item{(optional) .spl_context}{a `data.frame` describing previously performed splits which collectively
|
|||
| 838 | +62 |
- )+ #' arrived at `df`.} |
||
| 839 | +63 |
-
+ #' } |
||
| 840 | +64 |
- # Removing NA rows - to explore why this happens at all in a split+ #' |
||
| 841 | +65 |
- # This would be a fix but it is done in post-processing instead of pre-proc -> xxx+ #' The function must then output a named `list` with the following elements: |
||
| 842 | +66 |
- # x alt_dfpart <- lapply(alt_dfpart, function(data) {
+ #' |
||
| 843 | +67 |
- # x data[!apply(is.na(data), 1, all), ]+ #' \describe{
|
||
| 844 | +68 |
- # x })+ #' \item{values}{the vector of all values corresponding to the splits of `df`.}
|
||
| 845 | +69 |
-
+ #' \item{datasplit}{a list of `data.frame`s representing the groupings of the actual observations from `df`.}
|
||
| 846 | +70 |
- # Error localization+ #' \item{labels}{a character vector giving a string label for each value listed in the `values` element above.}
|
||
| 847 | -17x | +|||
| 71 | +
- if (is(alt_dfpart, "error")) {
+ #' \item{(optional) extras}{if present, extra arguments are to be passed to summary and analysis functions
|
|||
| 848 | -2x | +|||
| 72 | +
- stop("Following error encountered in splitting alt_counts_df: ",
+ #' whenever they are executed on the corresponding element of `datasplit` or a subset thereof.} |
|||
| 849 | -2x | +|||
| 73 | +
- alt_dfpart$message,+ #' } |
|||
| 850 | -2x | +|||
| 74 | +
- call. = FALSE+ #' |
|||
| 851 | +75 |
- )+ #' One way to generate custom splitting functions is to wrap existing split functions and modify either the incoming |
||
| 852 | +76 |
- }+ #' data before they are called or their outputs. |
||
| 853 | +77 |
- # Error if split does not have the same values in the alt_df (and order)+ #' |
||
| 854 | +78 |
- # The following breaks if there are different levels (do_split returns empty list)+ #' @seealso [make_split_fun()] for the API for creating custom split functions, and [split_funcs] for a variety of |
||
| 855 | +79 |
- # or if there are different number of the same levels. Added handling of NAs+ #' pre-defined split functions. |
||
| 856 | +80 |
- # in the values of the factor when is all only NAs+ #' |
||
| 857 | -15x | +|||
| 81 | +
- is_all_na <- all(is.na(alt_df[[spl_payload(spl)]]))+ #' @examples |
|||
| 858 | +82 |
-
+ #' # Example of a picky split function. The number of values in the column variable |
||
| 859 | -15x | +|||
| 83 | +
- if (!all(names(dataspl) %in% names(alt_dfpart)) || length(alt_dfpart) != length(dataspl) || is_all_na) {
+ #' # var decrees if we are going to print also the column with all observation |
|||
| 860 | -5x | +|||
| 84 | +
- alt_df_spl_vals <- unique(alt_df[[spl_payload(spl)]])+ #' # or not. |
|||
| 861 | -5x | +|||
| 85 | +
- end_part <- ""+ #' |
|||
| 862 | +86 |
-
+ #' picky_splitter <- function(var) {
|
||
| 863 | -5x | +|||
| 87 | +
- if (!all(alt_df_spl_vals %in% levels(alt_df_spl_vals))) {
+ #' # Main layout function |
|||
| 864 | -2x | +|||
| 88 | +
- end_part <- paste0(+ #' function(df, spl, vals, labels, trim) {
|
|||
| 865 | -2x | +|||
| 89 | +
- " and following levels: ",+ #' orig_vals <- vals |
|||
| 866 | -2x | +|||
| 90 | +
- paste_vec(levels(alt_df_spl_vals))+ #' |
|||
| 867 | +91 |
- )+ #' # Check for number of levels if all are selected |
||
| 868 | +92 |
- }+ #' if (is.null(vals)) {
|
||
| 869 | +93 |
-
+ #' vec <- df[[var]] |
||
| 870 | -5x | +|||
| 94 | +
- if (is_all_na) {
+ #' vals <- unique(vec) |
|||
| 871 | -2x | +|||
| 95 | +
- end_part <- ". Found only NAs in alt_counts_df split"+ #' } |
|||
| 872 | +96 |
- }+ #' |
||
| 873 | +97 |
-
+ #' # Do a split with or without All obs |
||
| 874 | -5x | +|||
| 98 | +
- stop(+ #' if (length(vals) == 1) {
|
|||
| 875 | -5x | +|||
| 99 | +
- "alt_counts_df split variable(s) [", spl_payload(spl),+ #' do_base_split(spl = spl, df = df, vals = vals, labels = labels, trim = trim) |
|||
| 876 | -5x | +|||
| 100 | +
- "] (in split ", as.character(class(spl)),+ #' } else {
|
|||
| 877 | -5x | +|||
| 101 | +
- ") does not have the same factor levels of df.\ndf has c(", '"',
+ #' fnc_tmp <- add_overall_level("Overall", label = "All Obs", first = FALSE)
|
|||
| 878 | -5x | +|||
| 102 | +
- paste(names(dataspl), collapse = '", "'), '"', ") levels while alt_counts_df has ",+ #' fnc_tmp(df = df, spl = spl, vals = orig_vals, trim = trim) |
|||
| 879 | -5x | +|||
| 103 | +
- ifelse(length(alt_df_spl_vals) > 0, paste_vec(alt_df_spl_vals), ""),+ #' } |
|||
| 880 | -5x | +|||
| 104 | +
- " unique values", end_part+ #' } |
|||
| 881 | +105 |
- )+ #' } |
||
| 882 | +106 |
- }+ #' |
||
| 883 | +107 |
- } else {
+ #' # Data sub-set |
||
| 884 | -397x | +|||
| 108 | +
- alt_dfpart <- setNames(rep(list(NULL), length(dataspl)), names(dataspl))+ #' d1 <- subset(ex_adsl, ARM == "A: Drug X" | (ARM == "B: Placebo" & SEX == "F")) |
|||
| 885 | +109 |
- }+ #' d1 <- subset(d1, SEX %in% c("M", "F"))
|
||
| 886 | +110 |
-
+ #' d1$SEX <- factor(d1$SEX) |
||
| 887 | +111 |
-
+ #' |
||
| 888 | -407x | +|||
| 112 | +
- innerlev <- lvl + (have_controws || is.na(make_lrow) || make_lrow)+ #' # This table uses the number of values in the SEX column to add the overall col or not |
|||
| 889 | +113 |
- ## do full recursive_applysplit on each part of the split defined by spl+ #' lyt <- basic_table() %>% |
||
| 890 | -407x | +|||
| 114 | +
- inner <- unlist(mapply(+ #' split_cols_by("ARM", split_fun = drop_split_levels) %>%
|
|||
| 891 | -407x | +|||
| 115 | +
- function(dfpart, alt_dfpart, nm, label, baselines, splval) {
+ #' split_cols_by("SEX", split_fun = picky_splitter("SEX")) %>%
|
|||
| 892 | -1192x | +|||
| 116 | +
- rsplval <- context_df_row(+ #' analyze("AGE", show_labels = "visible")
|
|||
| 893 | -1192x | +|||
| 117 | +
- split = obj_name(spl),+ #' tbl <- build_table(lyt, d1) |
|||
| 894 | -1192x | +|||
| 118 | +
- value = value_names(splval),+ #' tbl |
|||
| 895 | -1192x | +|||
| 119 | +
- full_parent_df = list(dfpart),+ #' |
|||
| 896 | -1192x | +|||
| 120 | +
- cinfo = cinfo+ #' @name custom_split_funs |
|||
| 897 | +121 |
- )+ NULL |
||
| 898 | +122 | |||
| 899 | +123 |
- ## if(length(rsplval) > 0)+ ## do various cleaning, and naming, plus |
||
| 900 | +124 |
- ## rsplval <- setNames(rsplval, obj_name(spl))+ ## ensure partinfo$values contains SplitValue objects only |
||
| 901 | -1192x | +|||
| 125 | +
- recursive_applysplit(+ .fixupvals <- function(partinfo) {
|
|||
| 902 | -1192x | +126 | +1109x |
- df = dfpart,+ if (is.factor(partinfo$labels)) {
|
| 903 | -1192x | +|||
| 127 | +! |
- alt_df = alt_dfpart,+ partinfo$labels <- as.character(partinfo$labels) |
||
| 904 | -1192x | +|||
| 128 | +
- name = nm,+ } |
|||
| 905 | -1192x | +|||
| 129 | +
- lvl = innerlev,+ |
|||
| 906 | -1192x | +130 | +1109x |
- splvec = splvec,+ vals <- partinfo$values |
| 907 | -1192x | +131 | +1109x |
- cinfo = cinfo,+ if (is.factor(vals)) {
|
| 908 | -1192x | +|||
| 132 | +! |
- make_lrow = label_kids(spl),+ vals <- levels(vals)[vals] |
||
| 909 | -1192x | +|||
| 133 | +
- parent_cfun = content_fun(spl),+ } |
|||
| 910 | -1192x | +134 | +1109x |
- cformat = content_format(spl),+ extr <- partinfo$extras |
| 911 | -1192x | +135 | +1109x |
- cna_str = content_na_str(spl),+ dpart <- partinfo$datasplit |
| 912 | -1192x | +136 | +1109x |
- partlabel = label,+ labels <- partinfo$labels |
| 913 | -1192x | +137 | +1109x |
- cindent_mod = content_indent_mod(spl),+ if (is.null(labels)) {
|
| 914 | -1192x | +|||
| 138 | +! |
- cvar = content_var(spl),+ if (!is.null(names(vals))) {
|
||
| 915 | -1192x | +|||
| 139 | +! |
- baselines = baselines,+ labels <- names(vals) |
||
| 916 | -1192x | +|||
| 140 | +! |
- cextra_args = content_extra_args(spl),+ } else if (!is.null(names(dpart))) {
|
||
| 917 | -+ | |||
| 141 | +! |
- ## splval should still be retaining its name+ labels <- names(dpart) |
||
| 918 | -1192x | +|||
| 142 | +! |
- spl_context = rbind(spl_context, rsplval)+ } else if (!is.null(names(extr))) {
+ |
+ ||
| 143 | +! | +
+ labels <- names(extr) |
||
| 919 | +144 |
- )+ } |
||
| 920 | +145 |
- },+ } |
||
| 921 | -407x | +|||
| 146 | +
- dfpart = dataspl,+ |
|||
| 922 | -407x | +147 | +1109x |
- alt_dfpart = alt_dfpart,+ subsets <- partinfo$subset_exprs |
| 923 | -407x | +148 | +1109x |
- label = partlabels,+ if (is.null(subsets)) {
|
| 924 | -407x | +149 | +1093x |
- nm = nms,+ subsets <- vector(mode = "list", length = length(vals)) |
| 925 | -407x | +|||
| 150 | +
- baselines = newbaselines,+ ## use labels here cause we already did all that work |
|||
| 926 | -407x | +|||
| 151 | +
- splval = splvals,+ ## to get the names on the labels vector right |
|||
| 927 | -407x | +152 | +1093x |
- SIMPLIFY = FALSE+ names(subsets) <- names(labels) |
| 928 | +153 |
- ))+ } |
||
| 929 | +154 | |||
| 155 | +1109x | +
+ if (is.null(vals) && !is.null(extr)) {
+ |
+ ||
| 156 | +! | +
+ vals <- seq_along(extr)+ |
+ ||
| 930 | +157 |
- # Setting the kids section separator if they inherits VTableTree+ } |
||
| 931 | -399x | +|||
| 158 | +
- inner <- .set_kids_section_div(+ |
|||
| 932 | -399x | +159 | +1109x |
- inner,+ if (length(vals) == 0) {
|
| 933 | -399x | +160 | +13x |
- trailing_section_div_char = spl_section_div(spl),+ stopifnot(length(extr) == 0) |
| 934 | -399x | +161 | +13x |
- allowed_class = "VTableTree"+ return(partinfo) |
| 935 | +162 |
- )+ } |
||
| 936 | +163 |
-
+ ## length(vals) > 0 from here down |
||
| 937 | +164 |
- ## This is where we need to build the structural tables+ |
||
| 938 | -+ | |||
| 165 | +1096x |
- ## even if they are invisible because their labels are not+ if (are(vals, "SplitValue") && !are(vals, "LevelComboSplitValue")) {
+ |
+ ||
| 166 | +22x | +
+ if (!is.null(extr)) {
|
||
| 939 | +167 |
- ## not shown.+ ## in_ref_cols is in here for some reason even though its already in the SplitValue object. |
||
| 940 | -399x | +|||
| 168 | +
- innertab <- TableTree(+ ## https://github.com/insightsengineering/rtables/issues/707#issuecomment-1678810598 |
|||
| 941 | -399x | +|||
| 169 | +
- kids = inner,+ ## the if is a bandaid. |
|||
| 942 | -399x | +|||
| 170 | +
- name = obj_name(spl),+ ## XXX FIXME RIGHT |
|||
| 943 | -399x | +171 | +3x |
- labelrow = LabelRow(+ sq <- seq_along(vals) |
| 944 | -399x | +172 | +3x |
- label = obj_label(spl),+ if (any(vapply(sq, function(i) !all(names(extr[[i]]) %in% names(splv_extra(vals[[i]]))), TRUE))) {
|
| 945 | -399x | +|||
| 173 | +! |
- vis = isTRUE(vis_label(spl))+ warning( |
||
| 946 | -+ | |||
| 174 | +! |
- ),+ "Got a partinfo list with values that are ", |
||
| 947 | -399x | +|||
| 175 | +! |
- cinfo = cinfo,+ "already SplitValue objects and non-null extras ", |
||
| 948 | -399x | +|||
| 176 | +! |
- iscontent = FALSE,+ "element. This shouldn't happen" |
||
| 949 | -399x | +|||
| 177 | +
- indent_mod = indent_mod(spl),+ ) |
|||
| 950 | -399x | +|||
| 178 | +
- page_title = ptitle_prefix(spl)+ } |
|||
| 951 | +179 |
- )+ } |
||
| 952 | +180 |
- ## kids = inner+ } else {
|
||
| 953 | -399x | +181 | +1074x |
- kids <- list(innertab)+ if (is.null(extr)) {
|
| 954 | -399x | +182 | +6x |
- kids+ extr <- rep(list(list()), length(vals)) |
| 955 | +183 |
- }+ } |
||
| 956 | -+ | |||
| 184 | +1074x |
- )+ vals <- make_splvalue_vec(vals, extr, labels = labels, subset_exprs = subsets) |
||
| 957 | +185 |
-
+ } |
||
| 958 | +186 |
- context_df_row <- function(split = character(),+ ## we're done with this so take it off |
||
| 959 | -+ | |||
| 187 | +1096x |
- value = character(),+ partinfo$extras <- NULL |
||
| 960 | +188 |
- full_parent_df = list(),+ + |
+ ||
| 189 | +1096x | +
+ vnames <- value_names(vals)+ |
+ ||
| 190 | +1096x | +
+ names(vals) <- vnames+ |
+ ||
| 191 | +1096x | +
+ partinfo$values <- vals |
||
| 961 | +192 |
- cinfo = NULL) {
+
|
||
| 962 | -2901x | +193 | +1096x |
- ret <- data.frame(+ if (!identical(names(dpart), vnames)) {
|
| 963 | -2901x | +194 | +1096x |
- split = split,+ names(dpart) <- vnames |
| 964 | -2901x | +195 | +1096x |
- value = value,+ partinfo$datasplit <- dpart |
| 965 | -2901x | +|||
| 196 | +
- full_parent_df = I(full_parent_df),+ } |
|||
| 966 | +197 |
- # parent_cold_inds = I(parent_col_inds),+ |
||
| 967 | -2901x | +198 | +1096x |
- stringsAsFactors = FALSE+ partinfo$labels <- labels |
| 968 | +199 |
- )+ |
||
| 969 | -2901x | +200 | +1096x |
- if (nrow(ret) > 0) {
+ stopifnot(length(unique(sapply(partinfo, NROW))) == 1) |
| 970 | -2888x | +201 | +1096x |
- ret$all_cols_n <- nrow(full_parent_df[[1]])+ partinfo |
| 971 | +202 |
- } else {
+ } |
||
| 972 | -13x | +|||
| 203 | +
- ret$all_cols_n <- integer() ## should this be numeric??? This never happens+ |
|||
| 973 | +204 |
- }+ .add_ref_extras <- function(spl, df, partinfo) {
|
||
| 974 | +205 |
-
+ ## this is only the .in_ref_col booleans |
||
| 975 | -2901x | +206 | +17x |
- if (!is.null(cinfo)) {
+ refvals <- .applysplit_ref_vals(spl, df, partinfo$values) |
| 976 | -1518x | +207 | +17x |
- if (nrow(ret) > 0) {
+ ref_ind <- which(unlist(refvals)) |
| 977 | -1509x | +208 | +17x |
- colcols <- as.data.frame(lapply(col_exprs(cinfo), function(e) {
+ stopifnot(length(ref_ind) == 1)+ |
+
| 209 | ++ | + | ||
| 978 | -5354x | +210 | +17x |
- vals <- eval(e, envir = full_parent_df[[1]])+ vnames <- value_names(partinfo$values) |
| 979 | -5354x | +211 | +17x |
- if (identical(vals, TRUE)) {
+ if (is.null(partinfo$extras)) {
|
| 980 | -545x | +212 | +3x |
- vals <- rep(vals, length.out = nrow(full_parent_df[[1]]))+ names(refvals) <- vnames+ |
+
| 213 | +3x | +
+ partinfo$extras <- refvals |
||
| 981 | +214 |
- }+ } else {
|
||
| 982 | -5354x | +215 | +14x |
- I(list(vals))+ newextras <- mapply(+ |
+
| 216 | +14x | +
+ function(old, incol, ref_full) {
+ |
+ ||
| 217 | +37x | +
+ c(old, list(+ |
+ ||
| 218 | +37x | +
+ .in_ref_col = incol,+ |
+ ||
| 219 | +37x | +
+ .ref_full = ref_full |
||
| 983 | +220 |
- }))+ )) |
||
| 984 | +221 |
- } else {
+ }, |
||
| 985 | -9x | +222 | +14x |
- colcols <- as.data.frame(rep(list(logical()), ncol(cinfo)))+ old = partinfo$extras,+ |
+
| 223 | +14x | +
+ incol = unlist(refvals),+ |
+ ||
| 224 | +14x | +
+ MoreArgs = list(ref_full = partinfo$datasplit[[ref_ind]]),+ |
+ ||
| 225 | +14x | +
+ SIMPLIFY = FALSE |
||
| 986 | +226 |
- }+ ) |
||
| 987 | -1518x | +227 | +14x |
- names(colcols) <- names(col_exprs(cinfo))+ names(newextras) <- vnames |
| 988 | -1518x | +228 | +14x |
- ret <- cbind(ret, colcols)+ partinfo$extras <- newextras |
| 989 | +229 |
} |
||
| 990 | -2901x | +230 | +17x |
- ret+ partinfo |
| 991 | +231 |
} |
||
| 992 | +232 | |||
| 993 | +233 |
- recursive_applysplit <- function(df,+ #' Apply basic split (for use in custom split functions) |
||
| 994 | +234 |
- lvl = 0L,+ #' |
||
| 995 | +235 |
- alt_df,+ #' This function is intended for use inside custom split functions. It applies the current split *as if it had no |
||
| 996 | +236 |
- splvec,+ #' custom splitting function* so that those default splits can be further manipulated. |
||
| 997 | +237 |
- name,+ #' |
||
| 998 | +238 |
- # label,+ #' @inheritParams gen_args |
||
| 999 | +239 |
- make_lrow = NA,+ #' @param vals (`ANY`)\cr already calculated/known values of the split. Generally should be left as `NULL`. |
||
| 1000 | +240 |
- partlabel = "",+ #' @param labels (`character`)\cr labels associated with `vals`. Should be `NULL` whenever `vals` is, which should |
||
| 1001 | +241 |
- cinfo,+ #' almost always be the case. |
||
| 1002 | +242 |
- parent_cfun = NULL,+ #' @param trim (`flag`)\cr whether groups corresponding to empty data subsets should be removed. Defaults to |
||
| 1003 | +243 |
- cformat = NULL,+ #' `FALSE`. |
||
| 1004 | +244 |
- cna_str = NA_character_,+ #' |
||
| 1005 | +245 |
- cindent_mod = 0L,+ #' @return The result of the split being applied as if it had no custom split function. See [custom_split_funs]. |
||
| 1006 | +246 |
- cextra_args = list(),+ #' |
||
| 1007 | +247 |
- cvar = NULL,+ #' @examples |
||
| 1008 | +248 |
- baselines = lapply(+ #' uneven_splfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
|
||
| 1009 | +249 |
- col_extra_args(cinfo),+ #' ret <- do_base_split(spl, df, vals, labels, trim) |
||
| 1010 | +250 |
- function(x) x$.ref_full+ #' if (NROW(df) == 0) {
|
||
| 1011 | +251 |
- ),+ #' ret <- lapply(ret, function(x) x[1]) |
||
| 1012 | +252 |
- spl_context = context_df_row(cinfo = cinfo),+ #' } |
||
| 1013 | +253 |
- no_outer_tbl = FALSE,+ #' ret |
||
| 1014 | +254 |
- parent_sect_split = NA_character_) {
+ #' } |
||
| 1015 | +255 |
- ## pre-existing table was added to the layout+ #' |
||
| 1016 | -1518x | +|||
| 256 | +
- if (length(splvec) == 1L && is(splvec[[1]], "VTableNodeInfo")) {
+ #' lyt <- basic_table() %>% |
|||
| 1017 | -1x | +|||
| 257 | +
- return(splvec[[1]])+ #' split_cols_by("ARM") %>%
|
|||
| 1018 | +258 |
- }+ #' split_cols_by_multivar(c("USUBJID", "AESEQ", "BMRKR1"),
|
||
| 1019 | +259 |
-
+ #' varlabels = c("N", "E", "BMR1"),
|
||
| 1020 | +260 |
- ## the content function is the one from the PREVIOUS+ #' split_fun = uneven_splfun |
||
| 1021 | +261 |
- ## split, i.e. the one whose children we are now constructing+ #' ) %>% |
||
| 1022 | +262 |
- ## this is a bit annoying but makes the semantics for+ #' analyze_colvars(list( |
||
| 1023 | +263 |
- ## declaring layouts much more sane.+ #' USUBJID = function(x, ...) length(unique(x)), |
||
| 1024 | -1517x | +|||
| 264 | +
- ctab <- .make_ctab(df,+ #' AESEQ = max, |
|||
| 1025 | -1517x | +|||
| 265 | +
- lvl = lvl,+ #' BMRKR1 = mean |
|||
| 1026 | -1517x | +|||
| 266 | +
- name = name,+ #' )) |
|||
| 1027 | -1517x | +|||
| 267 | +
- label = partlabel,+ #' |
|||
| 1028 | -1517x | +|||
| 268 | +
- cinfo = cinfo,+ #' tbl <- build_table(lyt, subset(ex_adae, as.numeric(ARM) <= 2)) |
|||
| 1029 | -1517x | +|||
| 269 | +
- parent_cfun = parent_cfun,+ #' tbl |
|||
| 1030 | -1517x | +|||
| 270 | +
- format = cformat,+ #' |
|||
| 1031 | -1517x | +|||
| 271 | +
- na_str = cna_str,+ #' @export+ |
+ |||
| 272 | ++ |
+ do_base_split <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
|
||
| 1032 | -1517x | +273 | +13x |
- indent_mod = cindent_mod,+ spl2 <- spl |
| 1033 | -1517x | +274 | +13x |
- cvar = cvar,+ split_fun(spl2) <- NULL |
| 1034 | -1517x | +275 | +13x |
- alt_df = alt_df,+ do_split(spl2, |
| 1035 | -1517x | +276 | +13x |
- extra_args = cextra_args,+ df = df, vals = vals, labels = labels, trim = trim, |
| 1036 | -1517x | +277 | +13x |
- spl_context = spl_context+ spl_context = NULL |
| 1037 | +278 |
) |
||
| 1038 | +279 | - - | -||
| 1039 | -1516x | -
- nonroot <- lvl != 0L+ } |
||
| 1040 | +280 | |||
| 1041 | -1516x | -
- if (is.na(make_lrow)) {
- |
- ||
| 1042 | -1211x | +|||
| 281 | +
- make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE+ ### NB This is called at EACH level of recursive splitting |
|||
| 1043 | +282 |
- }+ do_split <- function(spl, |
||
| 1044 | +283 |
- ## never print an empty row label for root.+ df, |
||
| 1045 | -1516x | +|||
| 284 | +
- if (make_lrow && partlabel == "" && !nonroot) {
+ vals = NULL, |
|||
| 1046 | -6x | +|||
| 285 | +
- make_lrow <- FALSE+ labels = NULL, |
|||
| 1047 | +286 |
- }+ trim = FALSE, |
||
| 1048 | +287 |
-
+ spl_context) {
|
||
| 1049 | -1516x | +|||
| 288 | +
- if (length(splvec) == 0L) {
+ ## this will error if, e.g., df doesn't have columns |
|||
| 1050 | -99x | +|||
| 289 | +
- kids <- list()+ ## required by spl, or generally any time the spl |
|||
| 1051 | -99x | +|||
| 290 | +
- imod <- 0L+ ## can't be applied to df |
|||
| 1052 | -99x | +291 | +1109x |
- spl <- NULL+ check_validsplit(spl, df) |
| 1053 | +292 |
- } else {
- |
- ||
| 1054 | -1417x | -
- spl <- splvec[[1]]+ ## note the <- here!!! |
||
| 1055 | -1417x | +293 | +1108x |
- splvec <- splvec[-1]+ if (!is.null(splfun <- split_fun(spl))) {
|
| 1056 | +294 |
-
+ ## Currently the contract is that split_functions take df, vals, labels and |
||
| 1057 | +295 |
- ## we pass this everything recursive_applysplit received and+ ## return list(values=., datasplit=., labels = .), optionally with |
||
| 1058 | +296 |
- ## it all gets passed around through ... as needed+ ## an additional extras element |
||
| 1059 | -+ | |||
| 297 | +355x |
- ## to the various methods of .make_split_kids+ if (func_takes(splfun, ".spl_context")) {
|
||
| 1060 | -1417x | +298 | +23x |
- kids <- .make_split_kids(+ ret <- tryCatch( |
| 1061 | -1417x | +299 | +23x |
- spl = spl,+ splfun(df, spl, vals, labels, |
| 1062 | -1417x | +300 | +23x |
- df = df,+ trim = trim, |
| 1063 | -1417x | +301 | +23x |
- alt_df = alt_df,+ .spl_context = spl_context |
| 1064 | -1417x | +|||
| 302 | +
- lvl = lvl,+ ), |
|||
| 1065 | -1417x | +303 | +23x |
- splvec = splvec,+ error = function(e) e |
| 1066 | -1417x | +304 | +23x |
- name = name,+ ) ## rawvalues(spl_context )) |
| 1067 | -1417x | +|||
| 305 | +
- make_lrow = make_lrow,+ } else {
|
|||
| 1068 | -1417x | +306 | +332x |
- partlabel = partlabel,+ ret <- tryCatch(splfun(df, spl, vals, labels, trim = trim), |
| 1069 | -1417x | +307 | +332x |
- cinfo = cinfo,+ error = function(e) e |
| 1070 | -1417x | +|||
| 308 | +
- parent_cfun = parent_cfun,+ ) |
|||
| 1071 | -1417x | +|||
| 309 | +
- cformat = cformat,+ } |
|||
| 1072 | -1417x | +310 | +355x |
- cindent_mod = cindent_mod,+ if (is(ret, "error")) {
|
| 1073 | -1417x | +311 | +12x |
- cextra_args = cextra_args, cvar = cvar,+ stop( |
| 1074 | -1417x | +312 | +12x |
- baselines = baselines,+ "Error applying custom split function: ", ret$message, "\n\tsplit: ", |
| 1075 | -1417x | +313 | +12x |
- spl_context = spl_context,+ class(spl), " (", payloadmsg(spl), ")\n",
|
| 1076 | -1417x | +314 | +12x |
- have_controws = nrow(ctab) > 0+ "\toccured at path: ", |
| 1077 | -+ | |||
| 315 | +12x |
- )+ spl_context_to_disp_path(spl_context), "\n" |
||
| 1078 | -1387x | +|||
| 316 | +
- imod <- 0L+ ) |
|||
| 1079 | +317 |
- } ## end length(splvec)+ } |
||
| 1080 | +318 |
-
+ } else {
|
||
| 1081 | -1486x | +319 | +753x |
- if (is.na(make_lrow)) {
+ ret <- .apply_split_inner(df = df, spl = spl, vals = vals, labels = labels, trim = trim) |
| 1082 | -! | +|||
| 320 | +
- make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE+ } |
|||
| 1083 | +321 |
- }+ |
||
| 1084 | +322 |
- ## never print an empty row label for root.+ ## this adds .ref_full and .in_ref_col |
||
| 1085 | -1486x | +323 | +1096x |
- if (make_lrow && partlabel == "" && !nonroot) {
+ if (is(spl, "VarLevWBaselineSplit")) {
|
| 1086 | -! | +|||
| 324 | +17x |
- make_lrow <- FALSE+ ret <- .add_ref_extras(spl, df, ret) |
||
| 1087 | +325 |
} |
||
| 1088 | +326 | |||
| 1089 | +327 |
- ## this is only true when called from build_table and the first split+ ## this: |
||
| 1090 | +328 |
- ## in (one of the) SplitVector is NOT an AnalyzeMultiVars split.+ ## - guarantees that ret$values contains SplitValue objects |
||
| 1091 | +329 |
- ## in that case we would be "double creating" the structural+ ## - removes the extras element since its redundant after the above |
||
| 1092 | +330 |
- ## subtable- |
- ||
| 1093 | -1486x | -
- if (no_outer_tbl) {
- |
- ||
| 1094 | -277x | -
- ret <- kids[[1]]+ ## - Ensures datasplit and values lists are named according to labels |
||
| 1095 | -277x | +|||
| 331 | +
- indent_mod(ret) <- indent_mod(spl)+ ## - ensures labels are character not factor |
|||
| 1096 | -1209x | +332 | +1096x |
- } else if (nrow(ctab) > 0L || length(kids) > 0L) {
+ ret <- .fixupvals(ret) |
| 1097 | +333 |
- ## previously we checked if the child had an identical label+ ## we didn't put this in .fixupvals because that get called withint he split functions |
||
| 1098 | +334 |
- ## but I don't think thats needed anymore.+ ## created by make_split_fun and its not clear this check should be happening then. |
||
| 1099 | -1209x | +335 | +1096x |
- tlabel <- partlabel+ if (has_force_pag(spl) && length(ret$datasplit) == 0) { ## this means it's page_by=TRUE
|
| 1100 | -1209x | +336 | +3x |
- ret <- TableTree(+ stop( |
| 1101 | -1209x | +337 | +3x |
- cont = ctab,+ "Page-by split resulted in zero pages (no observed values of split variable?). \n\tsplit: ", |
| 1102 | -1209x | +338 | +3x |
- kids = kids,+ class(spl), " (", payloadmsg(spl), ")\n",
|
| 1103 | -1209x | +339 | +3x |
- name = name,+ "\toccured at path: ", |
| 1104 | -1209x | +340 | +3x |
- label = tlabel, # partlabel,+ spl_context_to_disp_path(spl_context), "\n" |
| 1105 | -1209x | +|||
| 341 | +
- lev = lvl,+ ) |
|||
| 1106 | -1209x | +|||
| 342 | +
- iscontent = FALSE,+ } |
|||
| 1107 | -1209x | +343 | +1093x |
- labelrow = LabelRow(+ ret |
| 1108 | -1209x | +|||
| 344 | +
- lev = lvl,+ } |
|||
| 1109 | -1209x | +|||
| 345 | +
- label = tlabel,+ + |
+ |||
| 346 | ++ |
+ .apply_split_inner <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
|
||
| 1110 | -1209x | +347 | +1082x |
- cinfo = cinfo,+ if (is.null(vals)) {
|
| 1111 | -1209x | +348 | +1007x |
- vis = make_lrow+ vals <- .applysplit_rawvals(spl, df) |
| 1112 | +349 |
- ),+ } |
||
| 1113 | -1209x | +350 | +1082x |
- cinfo = cinfo,+ extr <- .applysplit_extras(spl, df, vals)+ |
+
| 351 | ++ | + | ||
| 1114 | -1209x | +352 | +1082x |
- indent_mod = imod+ if (is.null(vals)) {
|
| 1115 | -+ | |||
| 353 | +! |
- )+ return(list( |
||
| 1116 | -+ | |||
| 354 | +! |
- } else {
+ values = list(), |
||
| 1117 | +355 | ! |
- ret <- NULL+ datasplit = list(), |
|
| 1118 | -+ | |||
| 356 | +! |
- }+ labels = list(), |
||
| 1119 | -+ | |||
| 357 | +! |
-
+ extras = list() |
||
| 1120 | +358 |
- ## if(!is.null(spl) && !is.na(spl_section_sep(spl)))+ )) |
||
| 1121 | +359 |
- ## ret <- apply_kids_section_sep(ret, spl_section_sep(spl))+ } |
||
| 1122 | +360 |
- ## ## message(sprintf("indent modifier: %d", indentmod))
+
|
||
| 1123 | -+ | |||
| 361 | +1082x |
- ## if(!is.null(ret))+ dpart <- .applysplit_datapart(spl, df, vals) |
||
| 1124 | +362 |
- ## indent_mod(ret) = indentmod+ |
||
| 1125 | -1486x | +363 | +1082x |
- ret+ if (is.null(labels)) {
|
| 1126 | -+ | |||
| 364 | +1079x |
- }+ labels <- .applysplit_partlabels(spl, df, vals, labels) |
||
| 1127 | +365 |
-
+ } else {
|
||
| 1128 | -+ | |||
| 366 | +3x |
- #' Create a table from a layout and data+ stopifnot(names(labels) == names(vals)) |
||
| 1129 | +367 |
- #'+ } |
||
| 1130 | +368 |
- #' Layouts are used to describe a table pre-data. `build_table` is used to create a table+ ## get rid of columns that would not have any |
||
| 1131 | +369 |
- #' using a layout and a dataset.+ ## observations. |
||
| 1132 | +370 |
- #'+ ## |
||
| 1133 | +371 |
- #' @inheritParams gen_args+ ## But only if there were any rows to start with |
||
| 1134 | +372 |
- #' @inheritParams lyt_args+ ## if not we're in a manually constructed table |
||
| 1135 | +373 |
- #' @param col_counts (`numeric` or `NULL`)\cr `r lifecycle::badge("deprecated")` if non-`NULL`, column counts
+ ## column tree |
||
| 1136 | -+ | |||
| 374 | +1082x |
- #' *for leaf-columns only* which override those calculated automatically during tabulation. Must specify+ if (trim) {
|
||
| 1137 | -+ | |||
| 375 | +! |
- #' "counts" for *all* leaf-columns if non-`NULL`. `NA` elements will be replaced with the automatically+ hasdata <- sapply(dpart, function(x) nrow(x) > 0) |
||
| 1138 | -+ | |||
| 376 | +! |
- #' calculated counts. Turns on display of leaf-column counts when non-`NULL`.+ if (nrow(df) > 0 && length(dpart) > sum(hasdata)) { # some empties
|
||
| 1139 | -+ | |||
| 377 | +! |
- #' @param col_total (`integer(1)`)\cr the total observations across all columns. Defaults to `nrow(df)`.+ dpart <- dpart[hasdata] |
||
| 1140 | -+ | |||
| 378 | +! |
- #' @param ... ignored.+ vals <- vals[hasdata] |
||
| 1141 | -+ | |||
| 379 | +! |
- #'+ extr <- extr[hasdata] |
||
| 1142 | -+ | |||
| 380 | +! |
- #' @details+ labels <- labels[hasdata] |
||
| 1143 | +381 |
- #' When `alt_counts_df` is specified, column counts are calculated by applying the exact column subsetting+ } |
||
| 1144 | +382 |
- #' expressions determined when applying column splitting to the main data (`df`) to `alt_counts_df` and+ } |
||
| 1145 | +383 |
- #' counting the observations in each resulting subset.+ |
||
| 1146 | -+ | |||
| 384 | +1082x |
- #'+ if (is.null(spl_child_order(spl)) || is(spl, "AllSplit")) {
|
||
| 1147 | -+ | |||
| 385 | +163x |
- #' In particular, this means that in the case of splitting based on cuts of the data, any dynamic cuts will have+ vord <- seq_along(vals) |
||
| 1148 | +386 |
- #' been calculated based on `df` and simply re-used for the count calculation.+ } else {
|
||
| 1149 | -+ | |||
| 387 | +919x |
- #'+ vord <- match( |
||
| 1150 | -+ | |||
| 388 | +919x |
- #' @note+ spl_child_order(spl), |
||
| 1151 | -+ | |||
| 389 | +919x |
- #' When overriding the column counts or totals care must be taken that, e.g., `length()` or `nrow()` are not called+ vals |
||
| 1152 | +390 |
- #' within tabulation functions, because those will NOT give the overridden counts. Writing/using tabulation+ ) |
||
| 1153 | -+ | |||
| 391 | +919x |
- #' functions which accept `.N_col` and `.N_total` or do not rely on column counts at all (even implicitly) is the+ vord <- vord[!is.na(vord)] |
||
| 1154 | +392 |
- #' only way to ensure overridden counts are fully respected.+ } |
||
| 1155 | +393 |
- #'+ |
||
| 1156 | +394 |
- #' @return A `TableTree` or `ElementaryTable` object representing the table created by performing the tabulations+ ## FIXME: should be an S4 object, not a list |
||
| 1157 | -+ | |||
| 395 | +1082x |
- #' declared in `lyt` to the data `df`.+ ret <- list( |
||
| 1158 | -+ | |||
| 396 | +1082x |
- #'+ values = vals[vord], |
||
| 1159 | -+ | |||
| 397 | +1082x |
- #' @examples+ datasplit = dpart[vord], |
||
| 1160 | -+ | |||
| 398 | +1082x |
- #' lyt <- basic_table() %>%+ labels = labels[vord], |
||
| 1161 | -+ | |||
| 399 | +1082x |
- #' split_cols_by("Species") %>%
+ extras = extr[vord] |
||
| 1162 | +400 |
- #' analyze("Sepal.Length", afun = function(x) {
+ ) |
||
| 1163 | -+ | |||
| 401 | +1082x |
- #' list(+ ret |
||
| 1164 | +402 |
- #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ } |
||
| 1165 | +403 |
- #' "range" = diff(range(x))+ |
||
| 1166 | +404 |
- #' )+ .checkvarsok <- function(spl, df) {
|
||
| 1167 | -+ | |||
| 405 | +2022x |
- #' })+ vars <- spl_payload(spl) |
||
| 1168 | +406 |
- #' lyt+ ## could be multiple vars in the future? |
||
| 1169 | +407 |
- #'+ ## no reason not to make that work here now. |
||
| 1170 | -+ | |||
| 408 | +2022x |
- #' tbl <- build_table(lyt, iris)+ if (!all(vars %in% names(df))) {
|
||
| 1171 | -+ | |||
| 409 | +2x |
- #' tbl+ stop( |
||
| 1172 | -+ | |||
| 410 | +2x |
- #'+ " variable(s) [", |
||
| 1173 | -+ | |||
| 411 | +2x |
- #' # analyze multiple variables+ paste(setdiff(vars, names(df)), |
||
| 1174 | -+ | |||
| 412 | +2x |
- #' lyt2 <- basic_table() %>%+ collapse = ", " |
||
| 1175 | +413 |
- #' split_cols_by("Species") %>%
+ ), |
||
| 1176 | -+ | |||
| 414 | +2x |
- #' analyze(c("Sepal.Length", "Petal.Width"), afun = function(x) {
+ "] not present in data. (",
|
||
| 1177 | -+ | |||
| 415 | +2x |
- #' list(+ class(spl), ")" |
||
| 1178 | +416 |
- #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ ) |
||
| 1179 | +417 |
- #' "range" = diff(range(x))+ } |
||
| 1180 | -+ | |||
| 418 | +2020x |
- #' )+ invisible(NULL) |
||
| 1181 | +419 |
- #' })+ } |
||
| 1182 | +420 |
- #'+ |
||
| 1183 | +421 |
- #' tbl2 <- build_table(lyt2, iris)+ ### Methods to verify a split appears to be valid, applicable |
||
| 1184 | +422 |
- #' tbl2+ ### to the ***current subset*** of the df. |
||
| 1185 | +423 |
- #'+ ### |
||
| 1186 | +424 |
- #' # an example more relevant for clinical trials with column counts+ ### This is called at each level of recursive splitting so |
||
| 1187 | +425 |
- #' lyt3 <- basic_table(show_colcounts = TRUE) %>%+ ### do NOT make it check, e.g., if the ref_group level of |
||
| 1188 | +426 |
- #' split_cols_by("ARM") %>%
+ ### a factor is present in the data, because it may not be. |
||
| 1189 | +427 |
- #' analyze("AGE", afun = function(x) {
+
|
||
| 1190 | +428 |
- #' setNames(as.list(fivenum(x)), c(+ setMethod( |
||
| 1191 | +429 |
- #' "minimum", "lower-hinge", "median",+ "check_validsplit", "VarLevelSplit", |
||
| 1192 | +430 |
- #' "upper-hinge", "maximum"+ function(spl, df) {
+ |
+ ||
| 431 | +870x | +
+ .checkvarsok(spl, df) |
||
| 1193 | +432 |
- #' ))+ } |
||
| 1194 | +433 |
- #' })+ ) |
||
| 1195 | +434 |
- #'+ |
||
| 1196 | +435 |
- #' tbl3 <- build_table(lyt3, DM)+ setMethod( |
||
| 1197 | +436 |
- #' tbl3+ "check_validsplit", "MultiVarSplit", |
||
| 1198 | +437 |
- #'+ function(spl, df) {
+ |
+ ||
| 438 | +56x | +
+ .checkvarsok(spl, df) |
||
| 1199 | +439 |
- #' tbl4 <- build_table(lyt3, subset(DM, AGE > 40))+ } |
||
| 1200 | +440 |
- #' tbl4+ ) |
||
| 1201 | +441 |
- #'+ |
||
| 1202 | +442 |
- #' # with column counts calculated based on different data+ setMethod( |
||
| 1203 | +443 |
- #' miniDM <- DM[sample(1:NROW(DM), 100), ]+ "check_validsplit", "VAnalyzeSplit", |
||
| 1204 | +444 |
- #' tbl5 <- build_table(lyt3, DM, alt_counts_df = miniDM)+ function(spl, df) {
+ |
+ ||
| 445 | +1150x | +
+ if (!is.na(spl_payload(spl))) {
+ |
+ ||
| 446 | +1096x | +
+ .checkvarsok(spl, df) |
||
| 1205 | +447 |
- #' tbl5+ } else {
+ |
+ ||
| 448 | +54x | +
+ TRUE |
||
| 1206 | +449 |
- #'+ } |
||
| 1207 | +450 |
- #' tbl6 <- build_table(lyt3, DM, col_counts = 1:3)+ } |
||
| 1208 | +451 |
- #' tbl6+ ) |
||
| 1209 | +452 |
- #'+ |
||
| 1210 | +453 |
- #' @author Gabriel Becker+ setMethod( |
||
| 1211 | +454 |
- #' @export+ "check_validsplit", "CompoundSplit", |
||
| 1212 | +455 |
- build_table <- function(lyt, df,+ function(spl, df) {
+ |
+ ||
| 456 | +! | +
+ all(sapply(spl_payload(spl), df)) |
||
| 1213 | +457 |
- alt_counts_df = NULL,+ } |
||
| 1214 | +458 |
- col_counts = NULL,+ ) |
||
| 1215 | +459 |
- col_total = if (is.null(alt_counts_df)) nrow(df) else nrow(alt_counts_df),+ |
||
| 1216 | +460 |
- topleft = NULL,+ ## default does nothing, add methods as they become |
||
| 1217 | +461 |
- hsep = default_hsep(),+ ## required |
||
| 1218 | +462 |
- ...) {
+ setMethod( |
||
| 1219 | -337x | -
- if (!is(lyt, "PreDataTableLayouts")) {
- |
- ||
| 1220 | -! | -
- stop(- |
- ||
| 1221 | -! | +|||
| 463 | +
- "lyt must be a PreDataTableLayouts object. Got object of class ",+ "check_validsplit", "Split", |
|||
| 1222 | -! | +|||
| 464 | +131x |
- class(lyt)+ function(spl, df) invisible(NULL) |
||
| 1223 | +465 |
- )+ ) |
||
| 1224 | +466 |
- }+ |
||
| 1225 | +467 |
-
+ setMethod( |
||
| 1226 | +468 |
- ## if no columns are defined (e.g. because lyt is NULL)+ ".applysplit_rawvals", "VarLevelSplit", |
||
| 1227 | +469 |
- ## add a single overall column as the "most basic"+ function(spl, df) {
|
||
| 1228 | -+ | |||
| 470 | +776x |
- ## table column structure that makes sense+ varvec <- df[[spl_payload(spl)]] |
||
| 1229 | -337x | +471 | +776x |
- clyt <- clayout(lyt)+ if (is.factor(varvec)) {
|
| 1230 | -337x | +472 | +579x |
- if (length(clyt) == 1 && length(clyt[[1]]) == 0) {
+ levels(varvec) |
| 1231 | -105x | +|||
| 473 | +
- clyt[[1]] <- add_overall_col(clyt[[1]], "")+ } else {
|
|||
| 1232 | -105x | +474 | +197x |
- clayout(lyt) <- clyt+ unique(varvec) |
| 1233 | +475 |
- }+ } |
||
| 1234 | +476 |
-
+ } |
||
| 1235 | +477 |
- ## do checks and defensive programming now that we have the data+ ) |
||
| 1236 | -337x | +|||
| 478 | +
- lyt <- fix_dyncuts(lyt, df)+ |
|||
| 1237 | -337x | +|||
| 479 | +
- lyt <- set_def_child_ord(lyt, df)+ setMethod( |
|||
| 1238 | -336x | +|||
| 480 | +
- lyt <- fix_analyze_vis(lyt)+ ".applysplit_rawvals", "MultiVarSplit", |
|||
| 1239 | -336x | +|||
| 481 | +
- df <- fix_split_vars(lyt, df, char_ok = is.null(col_counts))+ function(spl, df) {
|
|||
| 1240 | -327x | +|||
| 482 | +
- alt_params <- check_afun_cfun_params(lyt, c(".alt_df", ".alt_df_row"))
+ ## spl_payload(spl) |
|||
| 1241 | -327x | +483 | +48x |
- if (any(alt_params) && is.null(alt_counts_df)) {
+ spl_varnames(spl) |
| 1242 | -2x | +|||
| 484 | +
- stop(+ } |
|||
| 1243 | -2x | +|||
| 485 | +
- "Layout contains afun/cfun functions that have optional parameters ",+ ) |
|||
| 1244 | -2x | +|||
| 486 | +
- ".alt_df and/or .alt_df_row, but no alt_counts_df was provided in ",+ |
|||
| 1245 | -2x | +|||
| 487 | +
- "build_table()."+ setMethod( |
|||
| 1246 | +488 |
- )+ ".applysplit_rawvals", "AllSplit", |
||
| 1247 | -+ | |||
| 489 | +109x |
- }+ function(spl, df) obj_name(spl) |
||
| 1248 | +490 |
-
+ ) # "all obs") |
||
| 1249 | -325x | +|||
| 491 | +
- rtpos <- TreePos()+ |
|||
| 1250 | -325x | +|||
| 492 | +
- cinfo <- create_colinfo(lyt, df, rtpos,+ setMethod( |
|||
| 1251 | -325x | +|||
| 493 | +
- counts = col_counts,+ ".applysplit_rawvals", "ManualSplit", |
|||
| 1252 | -325x | +494 | +52x |
- alt_counts_df = alt_counts_df,+ function(spl, df) spl@levels |
| 1253 | -325x | +|||
| 495 | +
- total = col_total,+ ) |
|||
| 1254 | -325x | +|||
| 496 | +
- topleft+ |
|||
| 1255 | +497 |
- )+ ## setMethod(".applysplit_rawvals", "NULLSplit",
|
||
| 1256 | -317x | +|||
| 498 | +
- if (!is.null(col_counts)) {
+ ## function(spl, df) "") |
|||
| 1257 | -3x | +|||
| 499 | +
- toreplace <- !is.na(col_counts)+ |
|||
| 1258 | -3x | +|||
| 500 | +
- newccs <- col_counts(cinfo) ## old actual counts+ setMethod( |
|||
| 1259 | -3x | +|||
| 501 | +
- newccs[toreplace] <- col_counts[toreplace]+ ".applysplit_rawvals", "VAnalyzeSplit", |
|||
| 1260 | -3x | +|||
| 502 | +! |
- col_counts(cinfo) <- newccs+ function(spl, df) spl_payload(spl) |
||
| 1261 | -3x | +|||
| 503 | +
- leaf_paths <- col_paths(cinfo)+ ) |
|||
| 1262 | -3x | +|||
| 504 | +
- for (pth in leaf_paths) {
+
|
|||
| 1263 | -21x | +|||
| 505 | +
- colcount_visible(cinfo, pth) <- TRUE+ ## formfactor here is gross we're gonna have ot do this |
|||
| 1264 | +506 |
- }+ ## all again in tthe data split part :-/ |
||
| 1265 | +507 |
- }+ setMethod( |
||
| 1266 | -317x | +|||
| 508 | +
- rlyt <- rlayout(lyt)+ ".applysplit_rawvals", "VarStaticCutSplit", |
|||
| 1267 | -317x | +|||
| 509 | +
- rtspl <- root_spl(rlyt)+ function(spl, df) {
|
|||
| 1268 | -317x | +510 | +22x |
- ctab <- .make_ctab(df, 0L,+ spl_cutlabels(spl) |
| 1269 | -317x | +|||
| 511 | +
- alt_df = NULL,+ } |
|||
| 1270 | -317x | +|||
| 512 | +
- name = "root",+ ) |
|||
| 1271 | -317x | +|||
| 513 | +
- label = "",+ |
|||
| 1272 | -317x | +|||
| 514 | +
- cinfo = cinfo, ## cexprs, ctree,+ setMethod( |
|||
| 1273 | -317x | +|||
| 515 | +
- parent_cfun = content_fun(rtspl),+ ".applysplit_datapart", "VarLevelSplit", |
|||
| 1274 | -317x | +|||
| 516 | +
- format = content_format(rtspl),+ function(spl, df, vals) {
|
|||
| 1275 | -317x | +517 | +851x |
- na_str = content_na_str(rtspl),+ if (!(spl_payload(spl) %in% names(df))) {
|
| 1276 | -317x | +|||
| 518 | +! |
- indent_mod = 0L,+ stop( |
||
| 1277 | -317x | +|||
| 519 | +! |
- cvar = content_var(rtspl),+ "Attempted to split on values of column (", spl_payload(spl),
|
||
| 1278 | -317x | +|||
| 520 | +! |
- extra_args = content_extra_args(rtspl)+ ") not present in the data" |
||
| 1279 | +521 |
- )+ ) |
||
| 1280 | +522 | - - | -||
| 1281 | -317x | -
- kids <- lapply(seq_along(rlyt), function(i) {
+ } |
||
| 1282 | -340x | +523 | +851x |
- splvec <- rlyt[[i]]+ ret <- lapply(seq_along(vals), function(i) {
|
| 1283 | -340x | +524 | +2322x |
- if (length(splvec) == 0) {
+ spl_col <- df[[spl_payload(spl)]] |
| 1284 | -14x | +525 | +2322x |
- return(NULL)+ df[!is.na(spl_col) & spl_col == vals[[i]], ] |
| 1285 | +526 |
- }+ }) |
||
| 1286 | -326x | +527 | +851x |
- firstspl <- splvec[[1]]+ names(ret) <- as.character(vals) |
| 1287 | -326x | +528 | +851x |
- nm <- obj_name(firstspl)+ ret |
| 1288 | +529 |
- ## XXX unused, probably shouldn't be?+ } |
||
| 1289 | +530 |
- ## this seems to be covered by grabbing the partlabel+ ) |
||
| 1290 | +531 |
- ## TODO confirm this+ |
||
| 1291 | +532 |
- ## lab <- obj_label(firstspl)+ setMethod( |
||
| 1292 | -326x | +|||
| 533 | +
- recursive_applysplit(+ ".applysplit_datapart", "MultiVarSplit", |
|||
| 1293 | -326x | +|||
| 534 | +
- df = df, lvl = 0L,+ function(spl, df, vals) {
|
|||
| 1294 | -326x | +535 | +48x |
- alt_df = alt_counts_df,+ allvnms <- spl_varnames(spl) |
| 1295 | -326x | +536 | +48x |
- name = nm,+ if (!is.null(vals) && !identical(allvnms, vals)) {
|
| 1296 | -326x | +|||
| 537 | +! |
- splvec = splvec,+ incl <- match(vals, allvnms)+ |
+ ||
| 538 | ++ |
+ } else {
|
||
| 1297 | -326x | +539 | +48x |
- cinfo = cinfo,+ incl <- seq_along(allvnms) |
| 1298 | +540 |
- ## XXX are these ALWAYS right?+ } |
||
| 1299 | -326x | +541 | +48x |
- make_lrow = label_kids(firstspl),+ vars <- spl_payload(spl)[incl] |
| 1300 | -326x | +|||
| 542 | +
- parent_cfun = NULL,+ ## don't remove nas |
|||
| 1301 | -326x | +|||
| 543 | +
- cformat = content_format(firstspl),+ ## ret = lapply(vars, function(cl) {
|
|||
| 1302 | -326x | +|||
| 544 | +
- cna_str = content_na_str(firstspl),+ ## df[!is.na(df[[cl]]),] |
|||
| 1303 | -326x | +|||
| 545 | +
- cvar = content_var(firstspl),+ ## }) |
|||
| 1304 | -326x | +546 | +48x |
- cextra_args = content_extra_args(firstspl),+ ret <- rep(list(df), length(vars)) |
| 1305 | -326x | +547 | +48x |
- spl_context = context_df_row(+ names(ret) <- vals |
| 1306 | -326x | +548 | +48x |
- split = "root", value = "root",+ ret |
| 1307 | -326x | +|||
| 549 | +
- full_parent_df = list(df),+ } |
|||
| 1308 | -326x | +|||
| 550 | +
- cinfo = cinfo+ ) |
|||
| 1309 | +551 |
- ),+ |
||
| 1310 | +552 |
- ## we DO want the 'outer table' if the first+ setMethod( |
||
| 1311 | +553 |
- ## one is a multi-analyze+ ".applysplit_datapart", "AllSplit", |
||
| 1312 | -326x | +554 | +109x |
- no_outer_tbl = !is(firstspl, "AnalyzeMultiVars")+ function(spl, df, vals) list(df) |
| 1313 | +555 |
- )+ ) |
||
| 1314 | +556 |
- })+ |
||
| 1315 | -294x | +|||
| 557 | +
- kids <- kids[!sapply(kids, is.null)]+ ## ## not sure I need this |
|||
| 1316 | -280x | +|||
| 558 | +
- if (length(kids) > 0) names(kids) <- sapply(kids, obj_name)+ setMethod( |
|||
| 1317 | +559 |
-
+ ".applysplit_datapart", "ManualSplit",+ |
+ ||
| 560 | +52x | +
+ function(spl, df, vals) rep(list(df), times = length(vals)) |
||
| 1318 | +561 |
- # top level divisor+ ) |
||
| 1319 | -294x | +|||
| 562 | +
- if (!is.na(top_level_section_div(lyt))) {
+
|
|||
| 1320 | -2x | +|||
| 563 | +
- kids <- lapply(kids, function(first_level_kids) {
+ ## setMethod(".applysplit_datapart", "NULLSplit",
|
|||
| 1321 | -4x | +|||
| 564 | +
- trailing_section_div(first_level_kids) <- top_level_section_div(lyt)+ ## function(spl, df, vals) list(df[FALSE,])) |
|||
| 1322 | -4x | +|||
| 565 | +
- first_level_kids+ |
|||
| 1323 | +566 |
- })+ setMethod( |
||
| 1324 | +567 |
- }+ ".applysplit_datapart", "VarStaticCutSplit", |
||
| 1325 | +568 |
-
+ function(spl, df, vals) {
|
||
| 1326 | -294x | +|||
| 569 | +
- if (nrow(ctab) == 0L && length(kids) == 1L && is(kids[[1]], "VTableTree")) {
+ # lbs = spl_cutlabels(spl) |
|||
| 1327 | -251x | +570 | +14x |
- tab <- kids[[1]]+ var <- spl_payload(spl) |
| 1328 | -251x | +571 | +14x |
- main_title(tab) <- main_title(lyt)+ varvec <- df[[var]] |
| 1329 | -251x | +572 | +14x |
- subtitles(tab) <- subtitles(lyt)+ cts <- spl_cuts(spl) |
| 1330 | -251x | +573 | +14x |
- main_footer(tab) <- main_footer(lyt)+ cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs) |
| 1331 | -251x | +574 | +14x |
- prov_footer(tab) <- prov_footer(lyt)+ split(df, cfct, drop = FALSE) |
| 1332 | -251x | +|||
| 575 | +
- header_section_div(tab) <- header_section_div(lyt)+ } |
|||
| 1333 | +576 |
- } else {
+ ) |
||
| 1334 | -43x | +|||
| 577 | +
- tab <- TableTree(+ |
|||
| 1335 | -43x | +|||
| 578 | +
- cont = ctab,+ setMethod( |
|||
| 1336 | -43x | +|||
| 579 | +
- kids = kids,+ ".applysplit_datapart", "CumulativeCutSplit", |
|||
| 1337 | -43x | +|||
| 580 | +
- lev = 0L,+ function(spl, df, vals) {
|
|||
| 1338 | -43x | +|||
| 581 | +
- name = "root",+ # lbs = spl_cutlabels(spl) |
|||
| 1339 | -43x | +582 | +8x |
- label = "",+ var <- spl_payload(spl) |
| 1340 | -43x | +583 | +8x |
- iscontent = FALSE,+ varvec <- df[[var]] |
| 1341 | -43x | +584 | +8x |
- cinfo = cinfo,+ cts <- spl_cuts(spl) |
| 1342 | -43x | +585 | +8x |
- format = obj_format(rtspl),+ cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs) |
| 1343 | -43x | +586 | +8x |
- na_str = obj_na_str(rtspl),+ ret <- lapply( |
| 1344 | -43x | +587 | +8x |
- title = main_title(lyt),+ seq_len(length(levels(cfct))), |
| 1345 | -43x | +588 | +8x |
- subtitles = subtitles(lyt),+ function(i) df[as.integer(cfct) <= i, ] |
| 1346 | -43x | +|||
| 589 | +
- main_footer = main_footer(lyt),+ ) |
|||
| 1347 | -43x | +590 | +8x |
- prov_footer = prov_footer(lyt),+ names(ret) <- levels(cfct) |
| 1348 | -43x | +591 | +8x |
- header_section_div = header_section_div(lyt)+ ret |
| 1349 | +592 |
- )+ } |
||
| 1350 | +593 |
- }+ ) |
||
| 1351 | +594 | |||
| 1352 | +595 |
- ## This seems to be unneeded, not clear what 'top_left' check it refers to+ ## XXX TODO *CutSplit Methods |
||
| 1353 | +596 |
- ## but both top_left taller than column headers and very long topleft are now+ |
||
| 1354 | +597 |
- ## allowed, so this is just wasted computation.+ setClass("NullSentinel", contains = "NULL")
|
||
| 1355 | +598 |
-
+ nullsentinel <- new("NullSentinel")
+ |
+ ||
| 599 | +! | +
+ noarg <- function() nullsentinel |
||
| 1356 | +600 |
- ## ## this is where the top_left check lives right now. refactor later maybe+ |
||
| 1357 | +601 |
- ## ## but now just call it so the error gets thrown when I want it to+ ## Extras generation methods |
||
| 1358 | +602 |
- ## unused <- matrix_form(tab)+ setMethod( |
||
| 1359 | -294x | +|||
| 603 | +
- tab <- update_ref_indexing(tab)+ ".applysplit_extras", "Split", |
|||
| 1360 | -294x | +|||
| 604 | +
- horizontal_sep(tab) <- hsep+ function(spl, df, vals) {
|
|||
| 1361 | -294x | +605 | +1030x |
- if (table_inset(lyt) > 0) {
+ splex <- split_exargs(spl) |
| 1362 | -1x | +606 | +1030x |
- table_inset(tab) <- table_inset(lyt)+ nvals <- length(vals) |
| 1363 | -+ | |||
| 607 | +1030x |
- }+ lapply(seq_len(nvals), function(vpos) {
|
||
| 1364 | -294x | +608 | +2623x |
- tab+ one_ex <- lapply(splex, function(arg) {
|
| 1365 | -+ | |||
| 609 | +! |
- }+ if (length(arg) >= vpos) {
|
||
| 1366 | -+ | |||
| 610 | +! |
-
+ arg[[vpos]] |
||
| 1367 | +611 |
- # fix_split_vars ----+ } else {
|
||
| 1368 | -+ | |||
| 612 | +! |
- # These checks guarantee that all the split variables are present in the data.+ noarg() |
||
| 1369 | +613 |
- # No generic is needed because it is not dependent on the input layout but+ } |
||
| 1370 | +614 |
- # on the df.+ }) |
||
| 1371 | -+ | |||
| 615 | +2623x |
- fix_one_split_var <- function(spl, df, char_ok = TRUE) {
+ names(one_ex) <- names(splex) |
||
| 1372 | -547x | +616 | +2623x |
- var <- spl_payload(spl)+ one_ex <- one_ex[!sapply(one_ex, is, "NullSentinel")] |
| 1373 | -547x | +617 | +2623x |
- if (!(var %in% names(df))) {
+ one_ex |
| 1374 | -2x | +|||
| 618 | +
- stop("Split variable [", var, "] not found in data being tabulated.")
+ }) |
|||
| 1375 | +619 |
} |
||
| 1376 | -545x | +|||
| 620 | +
- varvec <- df[[var]]+ ) |
|||
| 1377 | -545x | +|||
| 621 | +
- if (!is(varvec, "character") && !is.factor(varvec)) {
+
|
|||
| 1378 | -1x | +|||
| 622 | +
- message(sprintf(+ setMethod( |
|||
| 1379 | -1x | +|||
| 623 | +
- paste(+ ".applysplit_ref_vals", "Split", |
|||
| 1380 | -1x | +|||
| 624 | +! |
- "Split var [%s] was not character or factor.",+ function(spl, df, vals) rep(list(NULL), length(vals)) |
||
| 1381 | -1x | +|||
| 625 | +
- "Converting to factor"+ ) |
|||
| 1382 | +626 |
- ),+ |
||
| 1383 | -1x | +|||
| 627 | +
- var+ setMethod( |
|||
| 1384 | +628 |
- ))+ ".applysplit_ref_vals", "VarLevWBaselineSplit", |
||
| 1385 | -1x | +|||
| 629 | +
- varvec <- factor(varvec)+ function(spl, df, vals) {
|
|||
| 1386 | -1x | +630 | +17x |
- df[[var]] <- varvec+ bl_level <- spl@ref_group_value # XXX XXX |
| 1387 | -544x | +631 | +17x |
- } else if (is(varvec, "character") && !char_ok) {
+ vnames <- value_names(vals) |
| 1388 | -1x | +632 | +17x |
- stop(+ ret <- lapply(vnames, function(vl) {
|
| 1389 | -1x | +633 | +46x |
- "Overriding column counts is not supported when splitting on ",+ list(.in_ref_col = vl == bl_level)+ |
+
| 634 | ++ |
+ }) |
||
| 1390 | -1x | +635 | +17x |
- "character variables.\n Please convert all column split variables to ",+ names(ret) <- vnames |
| 1391 | -1x | +636 | +17x |
- "factors."+ ret |
| 1392 | +637 |
- )+ } |
||
| 1393 | +638 |
- }+ ) |
||
| 1394 | +639 | |||
| 1395 | -544x | +|||
| 640 | +
- if (is.factor(varvec)) {
+ ## XXX TODO FIXME |
|||
| 1396 | -386x | +|||
| 641 | +
- levs <- levels(varvec)+ setMethod( |
|||
| 1397 | +642 |
- } else {
+ ".applysplit_partlabels", "Split", |
||
| 1398 | -158x | +643 | +131x |
- levs <- unique(varvec)+ function(spl, df, vals, labels) as.character(vals) |
| 1399 | +644 |
- }+ ) |
||
| 1400 | -544x | +|||
| 645 | +
- if (!all(nzchar(levs))) {
+
|
|||
| 1401 | -4x | +|||
| 646 | +
- stop(+ setMethod(+ |
+ |||
| 647 | ++ |
+ ".applysplit_partlabels", "VarLevelSplit",+ |
+ ||
| 648 | ++ |
+ function(spl, df, vals, labels) {
|
||
| 1402 | -4x | +649 | +848x |
- "Got empty string level in splitting variable ", var,+ varname <- spl_payload(spl) |
| 1403 | -4x | +650 | +848x |
- " This is not supported.\nIf display as an empty level is ",+ vlabelname <- spl_labelvar(spl) |
| 1404 | -4x | +651 | +848x |
- "desired use a value-labeling variable."+ varvec <- df[[varname]] |
| 1405 | +652 |
- )+ ## we used to check if vals was NULL but |
||
| 1406 | +653 |
- }+ ## this is called after a short-circuit return in .apply_split_inner in that |
||
| 1407 | +654 |
-
+ ## case |
||
| 1408 | +655 |
- ## handle label var+ ## so vals is guaranteed to be non-null here |
||
| 1409 | -540x | +656 | +848x |
- lblvar <- spl_label_var(spl)+ if (is.null(labels)) {
|
| 1410 | -540x | +657 | +848x |
- have_lblvar <- !identical(var, lblvar)+ if (varname == vlabelname) {
|
| 1411 | -540x | +658 | +718x |
- if (have_lblvar) {
+ labels <- vals |
| 1412 | -85x | +|||
| 659 | +
- if (!(lblvar %in% names(df))) {
+ } else {
|
|||
| 1413 | -1x | +660 | +130x |
- stop(+ labfact <- is.factor(df[[vlabelname]]) |
| 1414 | -1x | +661 | +130x |
- "Value label variable [", lblvar,+ lablevs <- if (labfact) levels(df[[vlabelname]]) else NULL |
| 1415 | -1x | +662 | +130x |
- "] not found in data being tabulated."+ labels <- sapply(vals, function(v) {
|
| 1416 | -+ | |||
| 663 | +262x |
- )+ vlabel <- unique(df[varvec == v, vlabelname, drop = TRUE]) |
||
| 1417 | +664 |
- }- |
- ||
| 1418 | -84x | -
- lblvec <- df[[lblvar]]- |
- ||
| 1419 | -84x | -
- tab <- table(varvec, lblvec)+ ## TODO remove this once 1-to-1 value-label map is enforced |
||
| 1420 | +665 | - - | -||
| 1421 | -84x | -
- if (any(rowSums(tab > 0) > 1) || any(colSums(tab > 0) > 1)) {
+ ## elsewhere. |
||
| 1422 | -1x | +666 | +262x |
- stop(sprintf(+ stopifnot(length(vlabel) < 2) |
| 1423 | -1x | +667 | +262x |
- paste(+ if (length(vlabel) == 0) {
|
| 1424 | -1x | +|||
| 668 | +! |
- "There does not appear to be a 1-1",+ vlabel <- "" |
||
| 1425 | -1x | +669 | +262x |
- "correspondence between values in split var",+ } else if (labfact) {
|
| 1426 | -1x | +670 | +6x |
- "[%s] and label var [%s]"+ vlabel <- lablevs[vlabel] |
| 1427 | +671 |
- ),+ } |
||
| 1428 | -1x | +672 | +262x |
- var, lblvar+ vlabel |
| 1429 | +673 |
- ))+ }) |
||
| 1430 | +674 |
- }+ } |
||
| 1431 | +675 |
-
+ } |
||
| 1432 | -83x | -
- if (!is(lblvec, "character") && !is.factor(lblvec)) {
- |
- ||
| 1433 | -! | -
- message(sprintf(- |
- ||
| 1434 | -! | -
- paste(- |
- ||
| 1435 | -! | +676 | +848x |
- "Split label var [%s] was not character or",+ names(labels) <- as.character(vals) |
| 1436 | -! | +|||
| 677 | +848x |
- "factor. Converting to factor"+ labels |
||
| 1437 | +678 |
- ),- |
- ||
| 1438 | -! | -
- var+ } |
||
| 1439 | +679 |
- ))- |
- ||
| 1440 | -! | -
- lblvec <- factor(lblvec)- |
- ||
| 1441 | -! | -
- df[[lblvar]] <- lblvec+ ) |
||
| 1442 | +680 |
- }+ |
||
| 1443 | +681 |
- }+ setMethod( |
||
| 1444 | +682 |
-
+ ".applysplit_partlabels", "MultiVarSplit", |
||
| 1445 | -538x | +683 | +48x |
- df+ function(spl, df, vals, labels) value_labels(spl) |
| 1446 | +684 |
- }+ ) |
||
| 1447 | +685 | |||
| 1448 | +686 |
- fix_split_vars <- function(lyt, df, char_ok) {
+ make_splvalue_vec <- function(vals, extrs = list(list()), labels = vals, |
||
| 1449 | -336x | +|||
| 687 | +
- df <- fix_split_vars_inner(clayout(lyt), df, char_ok = char_ok)+ subset_exprs) {
|
|||
| 1450 | -332x | +688 | +2880x |
- df <- fix_split_vars_inner(rlayout(lyt), df, char_ok = TRUE)+ if (length(vals) == 0) {
|
| 1451 | -327x | +689 | +384x |
- df+ return(vals) |
| 1452 | +690 |
-
+ } |
||
| 1453 | +691 |
- ## clyt <- clayout(lyt)+ |
||
| 1454 | -+ | |||
| 692 | +2496x |
- ## rlyt <- rlayout(lyt)+ if (is(extrs, "AsIs")) {
|
||
| 1455 | -+ | |||
| 693 | +! |
-
+ extrs <- unclass(extrs) |
||
| 1456 | +694 |
- ## allspls <- unlist(list(clyt, rlyt))+ } |
||
| 1457 | +695 |
- ## VarLevelSplit includes sublclass VarLevWBaselineSplit+ ## if(are(vals, "SplitValue")) {
|
||
| 1458 | +696 |
- }+ |
||
| 1459 | +697 |
-
+ ## return(vals) |
||
| 1460 | +698 |
- fix_split_vars_inner <- function(lyt, df, char_ok) {
+ ## } |
||
| 1461 | -668x | +|||
| 699 | +
- stopifnot(is(lyt, "PreDataAxisLayout"))+ |
|||
| 1462 | -668x | +700 | +2496x |
- allspls <- unlist(lyt)+ mapply(SplitValue, |
| 1463 | -668x | +701 | +2496x |
- varspls <- allspls[sapply(allspls, is, "VarLevelSplit")]+ val = vals, extr = extrs, |
| 1464 | -668x | +702 | +2496x |
- unqvarinds <- !duplicated(sapply(varspls, spl_payload))+ label = labels, |
| 1465 | -668x | +703 | +2496x |
- unqvarspls <- varspls[unqvarinds]+ sub_expr = subset_exprs, |
| 1466 | -547x | +704 | +2496x |
- for (spl in unqvarspls) df <- fix_one_split_var(spl, df, char_ok = char_ok)+ SIMPLIFY = FALSE |
| 1467 | +705 |
-
+ ) |
||
| 1468 | -659x | +|||
| 706 | +
- df+ } |
| 1469 | +1 |
- }+ # paths summary ---- |
|||
| 1470 | +2 | ||||
| 1471 | +3 |
- # set_def_child_ord ----+ #' Get a list of table row/column paths |
|||
| 1472 | +4 |
- ## the table is built by recursively splitting the data and doing things to each+ #' |
|||
| 1473 | +5 |
- ## piece. The order (or even values) of unique(df[[col]]) is not guaranteed to+ #' @param x (`VTableTree`)\cr an `rtable` object. |
|||
| 1474 | +6 |
- ## be the same in all the different partitions. This addresses that.+ #' |
|||
| 1475 | +7 |
- setGeneric(+ #' @return A list of paths to each row/column within `x`. |
|||
| 1476 | +8 |
- "set_def_child_ord",+ #' |
|||
| 1477 | -3818x | +||||
| 9 | +
- function(lyt, df) standardGeneric("set_def_child_ord")
+ #' @seealso [cell_values()], [`fnotes_at_path<-`], [row_paths_summary()], [col_paths_summary()] |
||||
| 1478 | +10 |
- )+ #' |
|||
| 1479 | +11 |
-
+ #' @examples |
|||
| 1480 | +12 |
- setMethod(+ #' lyt <- basic_table() %>% |
|||
| 1481 | +13 |
- "set_def_child_ord", "PreDataTableLayouts",+ #' split_cols_by("ARM") %>%
|
|||
| 1482 | +14 |
- function(lyt, df) {
+ #' analyze(c("SEX", "AGE"))
|
|||
| 1483 | -337x | +||||
| 15 | +
- clayout(lyt) <- set_def_child_ord(clayout(lyt), df)+ #' |
||||
| 1484 | -336x | +||||
| 16 | +
- rlayout(lyt) <- set_def_child_ord(rlayout(lyt), df)+ #' tbl <- build_table(lyt, ex_adsl) |
||||
| 1485 | -336x | +||||
| 17 | +
- lyt+ #' tbl |
||||
| 1486 | +18 |
- }+ #' |
|||
| 1487 | +19 |
- )+ #' row_paths(tbl) |
|||
| 1488 | +20 |
-
+ #' col_paths(tbl) |
|||
| 1489 | +21 |
- setMethod(+ #' |
|||
| 1490 | +22 |
- "set_def_child_ord", "PreDataAxisLayout",+ #' cell_values(tbl, c("AGE", "Mean"), c("ARM", "B: Placebo"))
|
|||
| 1491 | +23 |
- function(lyt, df) {
+ #' |
|||
| 1492 | -1000x | +||||
| 24 | +
- lyt@.Data <- lapply(lyt, set_def_child_ord, df = df)+ #' @rdname make_col_row_df |
||||
| 1493 | -999x | +||||
| 25 | +
- lyt+ #' @export |
||||
| 1494 | +26 |
- }+ row_paths <- function(x) {
+ |
+ |||
| 27 | +45x | +
+ stopifnot(is_rtable(x))+ |
+ |||
| 28 | +45x | +
+ make_row_df(x, visible_only = TRUE)$path |
|||
| 1495 | +29 |
- )+ } |
|||
| 1496 | +30 | ||||
| 1497 | +31 |
- setMethod(+ #' @rdname make_col_row_df |
|||
| 1498 | +32 |
- "set_def_child_ord", "SplitVector",+ #' @export |
|||
| 1499 | +33 |
- function(lyt, df) {
+ col_paths <- function(x) {
|
|||
| 1500 | -1040x | +34 | +2405x |
- lyt[] <- lapply(lyt, set_def_child_ord, df = df)+ if (!is(coltree(x), "LayoutColTree")) {
|
|
| 1501 | -1039x | +||||
| 35 | +! |
- lyt+ stop("I don't know how to extract the column paths from an object of class ", class(x))
|
|||
| 1502 | +36 |
} |
|||
| 37 | +2405x | +
+ make_col_df(x, visible_only = TRUE)$path+ |
+ |||
| 1503 | +38 |
- )+ } |
|||
| 1504 | +39 | ||||
| 1505 | +40 |
- ## for most split types, don't do anything+ #' Print row/column paths summary |
|||
| 1506 | +41 |
- ## becuause their ordering already isn't data-based+ #' |
|||
| 1507 | +42 |
- setMethod(+ #' @param x (`VTableTree`)\cr an `rtable` object. |
|||
| 1508 | +43 |
- "set_def_child_ord", "ANY",+ #' |
|||
| 1509 | -610x | +||||
| 44 | +
- function(lyt, df) lyt+ #' @return A data frame summarizing the row- or column-structure of `x`. |
||||
| 1510 | +45 |
- )+ #' |
|||
| 1511 | +46 |
-
+ #' @examplesIf require(dplyr) |
|||
| 1512 | +47 |
- setMethod(+ #' ex_adsl_MF <- ex_adsl %>% dplyr::filter(SEX %in% c("M", "F"))
|
|||
| 1513 | +48 |
- "set_def_child_ord", "VarLevelSplit",+ #' |
|||
| 1514 | +49 |
- function(lyt, df) {
+ #' lyt <- basic_table() %>% |
|||
| 1515 | -814x | +||||
| 50 | +
- if (!is.null(spl_child_order(lyt))) {
+ #' split_cols_by("ARM") %>%
|
||||
| 1516 | -267x | +||||
| 51 | +
- return(lyt)+ #' split_cols_by("SEX", split_fun = drop_split_levels) %>%
|
||||
| 1517 | +52 |
- }+ #' analyze(c("AGE", "BMRKR2"))
|
|||
| 1518 | +53 |
-
+ #' |
|||
| 1519 | -547x | +||||
| 54 | +
- vec <- df[[spl_payload(lyt)]]+ #' tbl <- build_table(lyt, ex_adsl_MF) |
||||
| 1520 | -547x | +||||
| 55 | +
- vals <- if (is.factor(vec)) {
+ #' tbl |
||||
| 1521 | -387x | +||||
| 56 | +
- levels(vec)+ #' |
||||
| 1522 | +57 |
- } else {
+ #' df <- row_paths_summary(tbl) |
|||
| 1523 | -160x | +||||
| 58 | +
- unique(vec)+ #' df |
||||
| 1524 | +59 |
- }+ #' |
|||
| 1525 | -547x | +||||
| 60 | +
- spl_child_order(lyt) <- vals+ #' col_paths_summary(tbl) |
||||
| 1526 | -547x | +||||
| 61 | +
- lyt+ #' |
||||
| 1527 | +62 |
- }+ #' # manually constructed table |
|||
| 1528 | +63 |
- )+ #' tbl2 <- rtable( |
|||
| 1529 | +64 |
-
+ #' rheader( |
|||
| 1530 | +65 |
- setMethod(+ #' rrow( |
|||
| 1531 | +66 |
- "set_def_child_ord", "VarLevWBaselineSplit",+ #' "row 1", rcell("a", colspan = 2),
|
|||
| 1532 | +67 |
- function(lyt, df) {
+ #' rcell("b", colspan = 2)
|
|||
| 1533 | -17x | +||||
| 68 | +
- bline <- spl_ref_group(lyt)+ #' ), |
||||
| 1534 | -17x | +||||
| 69 | +
- if (!is.null(spl_child_order(lyt)) && match(bline, spl_child_order(lyt), nomatch = -1) == 1L) {
+ #' rrow("h2", "a", "b", "c", "d")
|
||||
| 1535 | -6x | +||||
| 70 | +
- return(lyt)+ #' ), |
||||
| 1536 | +71 |
- }+ #' rrow("r1", 1, 2, 1, 2), rrow("r2", 3, 4, 2, 1)
|
|||
| 1537 | +72 |
-
+ #' ) |
|||
| 1538 | -11x | +||||
| 73 | +
- if (!is.null(split_fun(lyt))) {
+ #' col_paths_summary(tbl2) |
||||
| 1539 | +74 |
- ## expensive but sadly necessary, I think+ #' |
|||
| 1540 | -3x | +||||
| 75 | +
- pinfo <- do_split(lyt, df, spl_context = context_df_row())+ #' @export+ |
+ ||||
| 76 | ++ |
+ row_paths_summary <- function(x) {
|
|||
| 1541 | -3x | +77 | +1x |
- vals <- sort(unlist(value_names(pinfo$values)))+ stopifnot(is_rtable(x)) |
|
| 1542 | +78 |
- } else {
+
|
|||
| 1543 | -8x | +79 | +1x |
- vec <- df[[spl_payload(lyt)]]+ if (nrow(x) == 0) {
|
|
| 1544 | -8x | +||||
| 80 | +! |
- vals <- if (is.factor(vec)) {
+ return("rowname node_class path\n---------------------\n")
|
|||
| 1545 | -5x | +||||
| 81 | +
- levels(vec)+ } |
||||
| 1546 | +82 |
- } else {
+
|
|||
| 1547 | -3x | +83 | +1x |
- unique(vec)+ pagdf <- make_row_df(x, visible_only = TRUE) |
|
| 1548 | -+ | ||||
| 84 | +1x |
- }+ row.names(pagdf) <- NULL |
|||
| 1549 | +85 |
- }+ |
|||
| 1550 | -11x | +86 | +1x |
- if (!bline %in% vals) {
+ mat <- rbind( |
|
| 1551 | +87 | 1x |
- stop(paste0(+ c("rowname", "node_class", "path"),
|
||
| 1552 | +88 | 1x |
- 'Reference group "', bline, '"', " was not present in the levels of ", spl_payload(lyt), " in the data."+ t(apply(pagdf, 1, function(xi) {
|
||
| 1553 | -+ | ||||
| 89 | +28x |
- ))+ c( |
|||
| 1554 | -+ | ||||
| 90 | +28x |
- }+ indent_string(xi$label, xi$indent), |
|||
| 1555 | -10x | +91 | +28x |
- spl_child_order(lyt) <- vals+ xi$node_class, |
|
| 1556 | -10x | +92 | +28x |
- lyt+ paste(xi$path, collapse = ", ") |
|
| 1557 | +93 |
- }+ ) |
|||
| 1558 | +94 |
- )+ })) |
|||
| 1559 | +95 |
-
+ ) |
|||
| 1560 | +96 |
- splitvec_to_coltree <- function(df, splvec, pos = NULL,+ |
|||
| 1561 | -+ | ||||
| 97 | +1x |
- lvl = 1L, label = "",+ txt <- mat_as_string(mat) |
|||
| 1562 | -+ | ||||
| 98 | +1x |
- spl_context = context_df_row(cinfo = NULL),+ cat(txt) |
|||
| 1563 | -+ | ||||
| 99 | +1x |
- alt_counts_df = df,+ cat("\n")
|
|||
| 1564 | +100 |
- global_cc_format) {
+
|
|||
| 1565 | -1751x | +101 | +1x |
- stopifnot(+ invisible(pagdf[, c("label", "indent", "node_class", "path")])
|
|
| 1566 | -1751x | +||||
| 102 | +
- lvl <= length(splvec) + 1L,+ } |
||||
| 1567 | -1751x | +||||
| 103 | +
- is(splvec, "SplitVector")+ |
||||
| 1568 | +104 |
- )+ #' @rdname row_paths_summary |
|||
| 1569 | +105 |
-
+ #' @export |
|||
| 1570 | +106 |
-
+ col_paths_summary <- function(x) {
|
|||
| 1571 | -1751x | +107 | +1x |
- if (lvl == length(splvec) + 1L) {
+ stopifnot(is_rtable(x)) |
|
| 1572 | +108 |
- ## XXX this should be a LayoutColree I Think.+ |
|||
| 1573 | -1147x | +109 | +1x |
- nm <- unlist(tail(value_names(pos), 1)) %||% ""+ pagdf <- make_col_df(x, visible_only = FALSE) |
|
| 1574 | -1147x | +110 | +1x |
- spl <- tail(pos_splits(pos), 1)[[1]]+ row.names(pagdf) <- NULL |
|
| 1575 | -1147x | +||||
| 111 | +
- fmt <- colcount_format(spl) %||% global_cc_format+ |
||||
| 1576 | -1147x | +112 | +1x |
- LayoutColLeaf(+ mat <- rbind( |
|
| 1577 | -1147x | +113 | +1x |
- lev = lvl - 1L,+ c("label", "path"),
|
|
| 1578 | -1147x | +114 | +1x |
- label = label,+ t(apply(pagdf, 1, function(xi) {
|
|
| 1579 | -1147x | +115 | +6x |
- tpos = pos,+ c( |
|
| 1580 | -1147x | +116 | +6x |
- name = nm,+ indent_string(xi$label, floor(length(xi$path) / 2 - 1)), |
|
| 1581 | -1147x | +117 | +6x |
- colcount = NROW(alt_counts_df),+ paste(xi$path, collapse = ", ") |
|
| 1582 | -1147x | +||||
| 118 | +
- disp_ccounts = disp_ccounts(spl),+ ) |
||||
| 1583 | -1147x | +||||
| 119 | +
- colcount_format = fmt+ })) |
||||
| 1584 | +120 |
- )+ ) |
|||
| 1585 | +121 |
- } else {
+
|
|||
| 1586 | -604x | +122 | +1x |
- spl <- splvec[[lvl]]+ txt <- mat_as_string(mat) |
|
| 1587 | -604x | +123 | +1x |
- nm <- if (is.null(pos) || length(pos_splits(pos)) == 0) {
+ cat(txt) |
|
| 1588 | -376x | +124 | +1x |
- obj_name(spl)+ cat("\n")
|
|
| 1589 | +125 |
- } else {
- |
- |||
| 1590 | -228x | -
- unlist(tail(- |
- |||
| 1591 | -228x | -
- value_names(pos),+ |
|||
| 1592 | -228x | +126 | +1x |
- 1+ invisible(pagdf[, c("label", "path")])
|
|
| 1593 | +127 |
- ))+ } |
|||
| 1594 | +128 |
- }- |
- |||
| 1595 | -604x | -
- rawpart <- do_split(spl, df,- |
- |||
| 1596 | -604x | -
- trim = FALSE,- |
- |||
| 1597 | -604x | -
- spl_context = spl_context+ |
|||
| 1598 | +129 |
- )- |
- |||
| 1599 | -601x | -
- datparts <- rawpart[["datasplit"]]- |
- |||
| 1600 | -601x | -
- vals <- rawpart[["values"]]+ # Rows ---- |
|||
| 1601 | -601x | +||||
| 130 | +
- labs <- rawpart[["labels"]]+ # . Summarize Rows ---- |
||||
| 1602 | +131 | ||||
| 1603 | -601x | -
- force(alt_counts_df)- |
- |||
| 1604 | -601x | -
- kids <- mapply(- |
- |||
| 1605 | -601x | -
- function(dfpart, value, partlab) {
- |
- |||
| 1606 | +132 |
- ## we could pass subset expression in here but the spec+ # summarize_row_df <- |
|||
| 1607 | +133 |
- ## currently doesn't call for it in column space- |
- |||
| 1608 | -1379x | -
- newprev <- context_df_row(- |
- |||
| 1609 | -1379x | -
- split = obj_name(spl),- |
- |||
| 1610 | -1379x | -
- value = value_names(value),- |
- |||
| 1611 | -1379x | -
- full_parent_df = list(dfpart),- |
- |||
| 1612 | -1379x | -
- cinfo = NULL+ # function(name, |
|||
| 1613 | +134 |
- )+ # label, |
|||
| 1614 | +135 |
- ## subset expressions handled inside make_child_pos,+ # indent, |
|||
| 1615 | +136 |
- ## value is (optionally, for the moment) carrying it around- |
- |||
| 1616 | -1379x | -
- newpos <- make_child_pos(pos, spl, value, partlab)+ # depth, |
|||
| 1617 | -1379x | +||||
| 137 | +
- acdf_subset_expr <- make_subset_expr(spl, value)+ # rowtype, |
||||
| 1618 | -1379x | +||||
| 138 | +
- new_acdf_subset <- try(eval(acdf_subset_expr, alt_counts_df), silent = TRUE)+ # indent_mod, |
||||
| 1619 | -1379x | +||||
| 139 | +
- if (is(new_acdf_subset, "try-error")) {
+ # level) {
|
||||
| 1620 | -4x | +||||
| 140 | +
- stop(sprintf(+ # data.frame( |
||||
| 1621 | -4x | +||||
| 141 | +
- paste(+ # name = name, |
||||
| 1622 | -4x | +||||
| 142 | +
- ifelse(identical(df, alt_counts_df), "df", "alt_counts_df"),+ # label = label, |
||||
| 1623 | -4x | +||||
| 143 | +
- "appears incompatible with column-split",+ # indent = indent, |
||||
| 1624 | -4x | +||||
| 144 | +
- "structure. Offending column subset",+ # depth = level, |
||||
| 1625 | -4x | +||||
| 145 | +
- "expression: %s\nOriginal error",+ # rowtype = rowtype, |
||||
| 1626 | -4x | +||||
| 146 | +
- "message: %s"+ # indent_mod = indent_mod, |
||||
| 1627 | -4x | +||||
| 147 | +
- ), deparse(acdf_subset_expr[[1]]),+ # level = level, |
||||
| 1628 | -4x | +||||
| 148 | +
- conditionMessage(attr(new_acdf_subset, "condition"))+ # stringsAsFactors = FALSE |
||||
| 1629 | +149 |
- ))+ # ) |
|||
| 1630 | +150 |
- }+ # } |
|||
| 1631 | +151 | ||||
| 1632 | -1375x | -
- splitvec_to_coltree(dfpart, splvec, newpos,- |
- |||
| 1633 | -1375x | -
- lvl + 1L, partlab,- |
- |||
| 1634 | -1375x | -
- spl_context = rbind(spl_context, newprev),- |
- |||
| 1635 | -1375x | -
- alt_counts_df = alt_counts_df[new_acdf_subset, , drop = FALSE],- |
- |||
| 1636 | -1375x | -
- global_cc_format = global_cc_format- |
- |||
| 1637 | +152 |
- )+ #' Summarize rows |
|||
| 1638 | +153 |
- },- |
- |||
| 1639 | -601x | -
- dfpart = datparts, value = vals,- |
- |||
| 1640 | -601x | -
- partlab = labs, SIMPLIFY = FALSE+ #' |
|||
| 1641 | +154 |
- )- |
- |||
| 1642 | -595x | -
- disp_cc <- FALSE- |
- |||
| 1643 | -595x | -
- cc_format <- global_cc_format # this doesn't matter probably, but its technically more correct- |
- |||
| 1644 | -595x | -
- if (lvl > 1) {
- |
- |||
| 1645 | -226x | -
- disp_cc <- disp_ccounts(splvec[[lvl - 1]])- |
- |||
| 1646 | -226x | -
- cc_format <- colcount_format(splvec[[lvl - 1]]) %||% global_cc_format+ #' @inheritParams gen_args |
|||
| 1647 | +155 |
- }+ #' @param depth (`numeric(1)`)\cr depth. |
|||
| 1648 | +156 | - - | -|||
| 1649 | -595x | -
- names(kids) <- value_names(vals)- |
- |||
| 1650 | -595x | -
- LayoutColTree(- |
- |||
| 1651 | -595x | -
- lev = lvl, label = label,- |
- |||
| 1652 | -595x | -
- spl = spl,+ #' @param indent (`numeric(1)`)\cr indent. |
|||
| 1653 | -595x | +||||
| 157 | +
- kids = kids, tpos = pos,+ #' |
||||
| 1654 | -595x | +||||
| 158 | +
- name = nm,+ #' @examplesIf require(dplyr) |
||||
| 1655 | -595x | +||||
| 159 | +
- summary_function = content_fun(spl),+ #' library(dplyr) |
||||
| 1656 | -595x | +||||
| 160 | +
- colcount = NROW(alt_counts_df),+ #' |
||||
| 1657 | -595x | +||||
| 161 | +
- disp_ccounts = disp_cc,+ #' iris2 <- iris %>% |
||||
| 1658 | -595x | +||||
| 162 | +
- colcount_format = cc_format+ #' group_by(Species) %>% |
||||
| 1659 | +163 |
- )+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
|||
| 1660 | +164 |
- }+ #' ungroup() |
|||
| 1661 | +165 |
- }+ #' |
|||
| 1662 | +166 |
-
+ #' lyt <- basic_table() %>% |
|||
| 1663 | +167 |
- # fix_analyze_vis ----+ #' split_cols_by("Species") %>%
|
|||
| 1664 | +168 |
- ## now that we know for sure the number of siblings+ #' split_cols_by("group") %>%
|
|||
| 1665 | +169 |
- ## collaplse NAs to TRUE/FALSE for whether+ #' analyze(c("Sepal.Length", "Petal.Width"),
|
|||
| 1666 | +170 |
- ## labelrows should be visible for ElementaryTables+ #' afun = list_wrap_x(summary), |
|||
| 1667 | +171 |
- ## generatead from analyzing a single variable+ #' format = "xx.xx" |
|||
| 1668 | -1031x | +||||
| 172 | +
- setGeneric("fix_analyze_vis", function(lyt) standardGeneric("fix_analyze_vis"))
+ #' ) |
||||
| 1669 | +173 |
-
+ #' |
|||
| 1670 | +174 |
- setMethod(+ #' tbl <- build_table(lyt, iris2) |
|||
| 1671 | +175 |
- "fix_analyze_vis", "PreDataTableLayouts",+ #' |
|||
| 1672 | +176 |
- function(lyt) {
+ #' @rdname int_methods |
|||
| 1673 | -336x | +||||
| 177 | +
- rlayout(lyt) <- fix_analyze_vis(rlayout(lyt))+ setGeneric("summarize_rows_inner", function(obj, depth = 0, indent = 0) {
|
||||
| 1674 | -336x | +||||
| 178 | +! |
- lyt+ standardGeneric("summarize_rows_inner")
|
|||
| 1675 | +179 |
- }+ }) |
|||
| 1676 | +180 |
- )+ |
|||
| 1677 | +181 |
-
+ #' @rdname int_methods |
|||
| 1678 | +182 |
setMethod( |
|||
| 1679 | +183 |
- "fix_analyze_vis", "PreDataRowLayout",+ "summarize_rows_inner", "TableTree", |
|||
| 1680 | +184 |
- function(lyt) {
+ function(obj, depth = 0, indent = 0) {
|
|||
| 1681 | -336x | +||||
| 185 | +! |
- splvecs <- lapply(lyt, fix_analyze_vis)+ indent <- max(0L, indent + indent_mod(obj)) |
|||
| 1682 | -336x | +||||
| 186 | +
- PreDataRowLayout(+ |
||||
| 1683 | -336x | +||||
| 187 | +! |
- root = root_spl(lyt),+ lr <- summarize_rows_inner(tt_labelrow(obj), depth, indent) |
|||
| 1684 | -336x | +||||
| 188 | +! |
- lst = splvecs+ if (!is.null(lr)) {
|
|||
| 1685 | -+ | ||||
| 189 | +! |
- )+ ret <- list(lr) |
|||
| 1686 | +190 |
- }+ } else {
+ |
+ |||
| 191 | +! | +
+ ret <- list() |
|||
| 1687 | +192 |
- )+ } |
|||
| 1688 | +193 | ||||
| 1689 | -+ | ||||
| 194 | +! |
- setMethod(+ indent <- indent + (!is.null(lr)) |
|||
| 1690 | +195 |
- "fix_analyze_vis", "SplitVector",+ |
|||
| 1691 | -+ | ||||
| 196 | +! |
- function(lyt) {
+ ctab <- content_table(obj) |
|||
| 1692 | -359x | +||||
| 197 | +! |
- len <- length(lyt)+ if (NROW(ctab)) {
|
|||
| 1693 | -359x | +||||
| 198 | +! |
- if (len == 0) {
+ ct <- summarize_rows_inner(ctab, |
|||
| 1694 | -14x | +||||
| 199 | +! |
- return(lyt)+ depth = depth, |
|||
| 1695 | -+ | ||||
| 200 | +! |
- }+ indent = indent + indent_mod(ctab) |
|||
| 1696 | -345x | +||||
| 201 | +
- lastspl <- lyt[[len]]+ ) |
||||
| 1697 | -345x | +||||
| 202 | +! |
- if (!(is(lastspl, "VAnalyzeSplit") || is(lastspl, "AnalyzeMultivar"))) {
+ ret <- c(ret, ct) |
|||
| 1698 | -73x | +||||
| 203 | +! |
- return(lyt)+ indent <- indent + (length(ct) > 0) * (1 + indent_mod(ctab)) |
|||
| 1699 | +204 |
} |
|||
| 1700 | +205 | ||||
| 1701 | -272x | +||||
| 206 | +! |
- if (is(lastspl, "VAnalyzeSplit") && is.na(labelrow_visible(lastspl))) {
+ kids <- tree_children(obj) |
|||
| 1702 | -+ | ||||
| 207 | +! |
- ## labelrow_visible(lastspl) = FALSE+ els <- lapply(tree_children(obj), summarize_rows_inner, |
|||
| 1703 | -266x | +||||
| 208 | +! |
- labelrow_visible(lastspl) <- "hidden"+ depth = depth + 1, indent = indent |
|||
| 1704 | -6x | +||||
| 209 | +
- } else if (is(lastspl, "AnalyzeMultiVar")) {
+ ) |
||||
| 1705 | +210 | ! |
- pld <- spl_payload(lastspl)+ if (!are(kids, "TableRow")) {
|
||
| 1706 | +211 | ! |
- newpld <- lapply(pld, function(sp, havesibs) {
+ if (!are(kids, "VTableTree")) {
+ |
+ ||
| 212 | ++ |
+ ## hatchet job of a hack, wrap em just so we can unlist em all at+ |
+ |||
| 213 | ++ |
+ ## the same level |
|||
| 1707 | +214 | ! |
- if (is.na(labelrow_visible(sp))) {
+ rowinds <- vapply(kids, is, NA, class2 = "TableRow") |
||
| 1708 | +215 | ! |
- labelrow_visible(sp) <- havesibs+ els[rowinds] <- lapply(els[rowinds], function(x) list(x)) |
||
| 1709 | +216 |
- }- |
- |||
| 1710 | -! | -
- }, havesibs = len > 1)+ } |
|||
| 1711 | +217 | ! |
- spl_payload(lastspl) <- newpld+ els <- unlist(els, recursive = FALSE) |
||
| 1712 | +218 |
- ## pretty sure this isn't needed...+ } |
|||
| 1713 | +219 | ! |
- if (is.na(label_kids(lastspl))) {
+ ret <- c(ret, els) |
||
| 1714 | +220 | ! |
- label_kids(lastspl) <- len > 1+ ret |
||
| 1715 | +221 |
- }+ ## df <- do.call(rbind, c(list(lr), list(ct), els)) |
|||
| 1716 | +222 |
- }+ |
|||
| 1717 | -272x | +||||
| 223 | +
- lyt[[len]] <- lastspl+ ## row.names(df) <- NULL |
||||
| 1718 | -272x | +||||
| 224 | +
- lyt+ ## df |
||||
| 1719 | +225 |
} |
|||
| 1720 | +226 |
) |
|||
| 1721 | +227 | ||||
| 1722 | +228 |
- # check_afun_cfun_params ----+ # Print Table Structure ---- |
|||
| 1723 | +229 | ||||
| 1724 | +230 |
- # This checks if the input params are used anywhere in cfun/afun+ #' Summarize table |
|||
| 1725 | +231 |
- setGeneric("check_afun_cfun_params", function(lyt, params) {
+ #' |
|||
| 1726 | -3188x | +||||
| 232 | +
- standardGeneric("check_afun_cfun_params")
+ #' @param x (`VTableTree`)\cr a table object. |
||||
| 1727 | +233 |
- })+ #' @param detail (`string`)\cr either `row` or `subtable`. |
|||
| 1728 | +234 |
-
+ #' |
|||
| 1729 | +235 |
- setMethod(+ #' @return No return value. Called for the side-effect of printing a row- or subtable-structure summary of `x`. |
|||
| 1730 | +236 |
- "check_afun_cfun_params", "PreDataTableLayouts",+ #' |
|||
| 1731 | +237 |
- function(lyt, params) {
+ #' @examplesIf require(dplyr) |
|||
| 1732 | +238 |
- # clayout does not have analysis functions+ #' library(dplyr) |
|||
| 1733 | -327x | +||||
| 239 | +
- check_afun_cfun_params(rlayout(lyt), params)+ #' |
||||
| 1734 | +240 |
- }+ #' iris2 <- iris %>% |
|||
| 1735 | +241 |
- )+ #' group_by(Species) %>% |
|||
| 1736 | +242 |
-
+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
|||
| 1737 | +243 |
- setMethod(+ #' ungroup() |
|||
| 1738 | +244 |
- "check_afun_cfun_params", "PreDataRowLayout",+ #' |
|||
| 1739 | +245 |
- function(lyt, params) {
+ #' lyt <- basic_table() %>% |
|||
| 1740 | -327x | +||||
| 246 | +
- ro_spl_parm_l <- check_afun_cfun_params(root_spl(lyt), params)+ #' split_cols_by("Species") %>%
|
||||
| 1741 | -327x | +||||
| 247 | +
- r_spl_parm_l <- lapply(lyt, check_afun_cfun_params, params = params)+ #' split_cols_by("group") %>%
|
||||
| 1742 | -327x | +||||
| 248 | +
- Reduce(`|`, c(list(ro_spl_parm_l), r_spl_parm_l))+ #' analyze(c("Sepal.Length", "Petal.Width"),
|
||||
| 1743 | +249 |
- }+ #' afun = list_wrap_x(summary), |
|||
| 1744 | +250 |
- )+ #' format = "xx.xx" |
|||
| 1745 | +251 |
-
+ #' ) |
|||
| 1746 | +252 |
- # Main function for checking parameters+ #' |
|||
| 1747 | +253 |
- setMethod(+ #' tbl <- build_table(lyt, iris2) |
|||
| 1748 | +254 |
- "check_afun_cfun_params", "SplitVector",+ #' tbl |
|||
| 1749 | +255 |
- function(lyt, params) {
+ #' |
|||
| 1750 | -764x | +||||
| 256 | +
- param_l <- lapply(lyt, check_afun_cfun_params, params = params)+ #' row_paths(tbl) |
||||
| 1751 | -764x | +||||
| 257 | +
- Reduce(`|`, param_l)+ #' |
||||
| 1752 | +258 |
- }+ #' table_structure(tbl) |
|||
| 1753 | +259 |
- )+ #' |
|||
| 1754 | +260 |
-
+ #' table_structure(tbl, detail = "row") |
|||
| 1755 | +261 |
- # Helper function for check_afun_cfun_params+ #' |
|||
| 1756 | +262 |
- .afun_cfun_switch <- function(spl_i) {
+ #' @export |
|||
| 1757 | -1769x | +||||
| 263 | +
- if (is(spl_i, "VAnalyzeSplit")) {
+ table_structure <- function(x, detail = c("subtable", "row")) {
|
||||
| 1758 | -593x | -
- analysis_fun(spl_i)+ | 264 | +2x | +
+ detail <- match.arg(detail) |
| 1759 | +265 |
- } else {
+
|
|||
| 1760 | -1176x | +266 | +2x |
- content_fun(spl_i)+ switch(detail,+ |
+ |
| 267 | +1x | +
+ subtable = treestruct(x),+ |
+ |||
| 268 | +1x | +
+ row = table_structure_inner(x),+ |
+ |||
| 269 | +! | +
+ stop("unsupported level of detail ", detail)
|
|||
| 1761 | +270 |
- }+ ) |
|||
| 1762 | +271 |
} |
|||
| 1763 | +272 | ||||
| 1764 | +273 |
- # Extreme case that happens only when using add_existing_table+ #' @param obj (`VTableTree`)\cr a table object. |
|||
| 1765 | +274 |
- setMethod(+ #' @param depth (`numeric(1)`)\cr depth in tree. |
|||
| 1766 | +275 |
- "check_afun_cfun_params", "VTableTree",+ #' @param indent (`numeric(1)`)\cr indent. |
|||
| 1767 | +276 |
- function(lyt, params) {
+ #' @param print_indent (`numeric(1)`)\cr indent for printing. |
|||
| 1768 | -1x | +||||
| 277 | +
- setNames(logical(length(params)), params) # All FALSE+ #' |
||||
| 1769 | +278 |
- }+ #' @rdname int_methods |
|||
| 1770 | +279 |
- )+ setGeneric( |
|||
| 1771 | +280 |
-
+ "table_structure_inner", |
|||
| 1772 | +281 |
- setMethod(+ function(obj, |
|||
| 1773 | +282 |
- "check_afun_cfun_params", "Split",+ depth = 0, |
|||
| 1774 | +283 |
- function(lyt, params) {
+ indent = 0, |
|||
| 1775 | +284 |
- # Extract function in the split+ print_indent = 0) {
|
|||
| 1776 | -1769x | +285 | +70x |
- fnc <- .afun_cfun_switch(lyt)+ standardGeneric("table_structure_inner")
|
|
| 1777 | +286 |
-
+ } |
|||
| 1778 | +287 |
- # For each parameter, check if it is called+ ) |
|||
| 1779 | -1769x | +||||
| 288 | +
- sapply(params, function(pai) any(unlist(func_takes(fnc, pai))))+ |
||||
| 1780 | +289 |
- }+ scat <- function(..., indent = 0, newline = TRUE) {
|
|||
| 1781 | -+ | ||||
| 290 | +101x |
- )+ txt <- paste(..., collapse = "", sep = "") |
|||
| 1782 | +291 | ||||
| 1783 | -+ | ||||
| 292 | +101x |
- # Helper functions ----+ cat(indent_string(txt, indent)) |
|||
| 1784 | +293 | ||||
| 1785 | -231x | +294 | +101x |
- count <- function(df, ...) NROW(df)+ if (newline) cat("\n")
|
|
| 1786 | +295 | ++ |
+ }+ |
+ ||
| 296 | |||||
| 1787 | +297 |
- guess_format <- function(val) {
+ ## helper functions |
|||
| 1788 | -1054x | +||||
| 298 | +
- if (length(val) == 1) {
+ obj_visible <- function(x) {
|
||||
| 1789 | -1042x | +299 | +50x |
- if (is.integer(val) || !is.numeric(val)) {
+ x@visible |
|
| 1790 | -226x | +||||
| 300 | +
- "xx"+ } |
||||
| 1791 | +301 |
- } else {
+
+ |
+ |||
| 302 | ++ |
+ is_empty_labelrow <- function(x) {
|
|||
| 1792 | -816x | +303 | +4x |
- "xx.xx"+ obj_label(x) == "" && !labelrow_visible(x) |
|
| 1793 | +304 |
- }+ } |
|||
| 1794 | -12x | +||||
| 305 | +
- } else if (length(val) == 2) {
+
|
||||
| 1795 | -12x | +||||
| 306 | +
- "xx.x / xx.x"+ is_empty_ElementaryTable <- function(x) {
|
||||
| 1796 | -! | +||||
| 307 | +10x |
- } else if (length(val) == 3) {
+ length(tree_children(x)) == 0 && is_empty_labelrow(tt_labelrow(x)) |
|||
| 1797 | -! | +||||
| 308 | +
- "xx.x (xx.x - xx.x)"+ } |
||||
| 1798 | +309 |
- } else {
+
|
|||
| 1799 | -! | +||||
| 310 | +
- stop("got value of length > 3")
+ #' @param object (`VTableTree`)\cr a table object. |
||||
| 1800 | +311 |
- }+ #' |
|||
| 1801 | +312 |
- }+ #' @rdname int_methods |
|||
| 1802 | +313 |
-
+ #' @export |
|||
| 1803 | +314 |
- .quick_afun <- function(afun, lbls) {
+ setGeneric("str", function(object, ...) {
|
|||
| 1804 | -14x | +||||
| 315 | +! |
- if (.takes_df(afun)) {
+ standardGeneric("str")
|
|||
| 1805 | -5x | +||||
| 316 | +
- function(df, .spl_context, ...) {
+ }) |
||||
| 1806 | -226x | +||||
| 317 | +
- if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
+
|
||||
| 1807 | -222x | +||||
| 318 | +
- lbls <- tail(.spl_context$value, 1)+ #' @param max.level (`numeric(1)`)\cr passed to `utils::str`. Defaults to 3 for the `VTableTree` method, unlike |
||||
| 1808 | +319 |
- }+ #' the underlying default of `NA`. `NA` is *not* appropriate for `VTableTree` objects. |
|||
| 1809 | -226x | +||||
| 320 | +
- if (".spl_context" %in% names(formals(afun))) {
+ #' |
||||
| 1810 | -! | +||||
| 321 | +
- res <- afun(df = df, .spl_context = .spl_context, ...)+ #' @rdname int_methods |
||||
| 1811 | +322 |
- } else {
+ #' @export |
|||
| 1812 | -226x | +||||
| 323 | +
- res <- afun(df = df, ...)+ setMethod( |
||||
| 1813 | +324 |
- }+ "str", "VTableTree", |
|||
| 1814 | -226x | +||||
| 325 | +
- if (is(res, "RowsVerticalSection")) {
+ function(object, max.level = 3L, ...) {
|
||||
| 1815 | +326 | ! |
- ret <- res+ utils::str(object, max.level = max.level, ...) |
||
| 1816 | -+ | ||||
| 327 | +! |
- } else {
+ warning("str provides a low level, implementation-detail-specific description of the TableTree object structure. ",
|
|||
| 1817 | -226x | +||||
| 328 | +! |
- if (!is.list(res)) {
+ "See table_structure(.) for a summary of table struture intended for end users.", |
|||
| 1818 | -226x | +||||
| 329 | +! |
- ret <- rcell(res, label = lbls, format = guess_format(res))+ call. = FALSE |
|||
| 1819 | +330 |
- } else {
+ ) |
|||
| 1820 | +331 | ! |
- if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
+ invisible(NULL) |
||
| 1821 | -! | +||||
| 332 | +
- names(res) <- lbls+ } |
||||
| 1822 | +333 |
- }+ ) |
|||
| 1823 | -! | +||||
| 334 | +
- ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, ""))+ |
||||
| 1824 | +335 |
- }+ #' @inheritParams table_structure_inner |
|||
| 1825 | +336 |
- }+ #' @rdname int_methods |
|||
| 1826 | -226x | +||||
| 337 | +
- ret+ setMethod( |
||||
| 1827 | +338 |
- }+ "table_structure_inner", "TableTree", |
|||
| 1828 | +339 |
- } else {
+ function(obj, depth = 0, indent = 0, print_indent = 0) {
|
|||
| 1829 | -9x | +340 | +10x |
- function(x, .spl_context, ...) {
+ indent <- indent + indent_mod(obj) |
|
| 1830 | -387x | +||||
| 341 | +
- if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
+
|
||||
| 1831 | -225x | +342 | +10x |
- lbls <- tail(.spl_context$value, 1)+ scat("TableTree: ", "[", obj_name(obj), "] (",
|
|
| 1832 | -+ | ||||
| 343 | +10x |
- }+ obj_label(obj), ")", |
|||
| 1833 | -387x | +344 | +10x |
- if (".spl_context" %in% names(formals(afun))) {
+ indent = print_indent |
|
| 1834 | -! | +||||
| 345 | +
- res <- afun(x = x, .spl_context = .spl_context, ...)+ ) |
||||
| 1835 | +346 |
- } else {
+
|
|||
| 1836 | -387x | +347 | +10x |
- res <- afun(x = x, ...)+ table_structure_inner( |
|
| 1837 | -+ | ||||
| 348 | +10x |
- }+ tt_labelrow(obj), depth, indent, |
|||
| 1838 | -387x | +349 | +10x |
- if (is(res, "RowsVerticalSection")) {
+ print_indent + 1 |
|
| 1839 | -! | +||||
| 350 | +
- ret <- res+ ) |
||||
| 1840 | +351 |
- } else {
+
|
|||
| 1841 | -387x | +352 | +10x |
- if (!is.list(res)) {
+ ctab <- content_table(obj) |
|
| 1842 | -297x | +353 | +10x |
- ret <- rcell(res, label = lbls, format = guess_format(res))+ visible_content <- if (is_empty_ElementaryTable(ctab)) {
|
|
| 1843 | +354 |
- } else {
- |
- |||
| 1844 | -90x | -
- if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
+ # scat("content: -", indent = print_indent + 1)
|
|||
| 1845 | -9x | +355 | +4x |
- names(res) <- lbls+ FALSE |
|
| 1846 | +356 |
- }+ } else {
|
|||
| 1847 | -90x | +357 | +6x |
- ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, ""))+ scat("content:", indent = print_indent + 1)
|
|
| 1848 | -+ | ||||
| 358 | +6x |
- }+ table_structure_inner(ctab, |
|||
| 1849 | -+ | ||||
| 359 | +6x |
- }+ depth = depth, |
|||
| 1850 | -387x | +360 | +6x |
- ret+ indent = indent + indent_mod(ctab), |
|
| 1851 | -+ | ||||
| 361 | +6x |
- }+ print_indent = print_indent + 2 |
|||
| 1852 | +362 |
- }+ ) |
|||
| 1853 | +363 |
- }+ } |
|||
| 1854 | +364 | ||||
| 1855 | -+ | ||||
| 365 | +10x |
- # qtable ----+ if (length(tree_children(obj)) == 0) {
|
|||
| 1856 | -+ | ||||
| 366 | +! |
-
+ scat("children: - ", indent = print_indent + 1)
|
|||
| 1857 | +367 |
- n_cells_res <- function(res) {
+ } else {
|
|||
| 1858 | -8x | +368 | +10x |
- ans <- 1L+ scat("children: ", indent = print_indent + 1)
|
|
| 1859 | -8x | +369 | +10x |
- if (is.list(res)) {
+ lapply(tree_children(obj), table_structure_inner, |
|
| 1860 | -4x | +370 | +10x |
- ans <- length(res)+ depth = depth + 1, |
|
| 1861 | -4x | +371 | +10x |
- } else if (is(res, "RowsVerticalSection")) {
+ indent = indent + visible_content * (1 + indent_mod(ctab)), |
|
| 1862 | -! | +||||
| 372 | +10x |
- ans <- length(res$values)+ print_indent = print_indent + 2 |
|||
| 1863 | +373 |
- } # XXX penetrating the abstraction- |
- |||
| 1864 | -8x | -
- ans+ ) |
|||
| 1865 | +374 |
- }+ } |
|||
| 1866 | +375 | ||||
| 1867 | -+ | ||||
| 376 | +10x |
- #' Generalized frequency table+ invisible(NULL) |
|||
| 1868 | +377 |
- #'+ } |
|||
| 1869 | +378 |
- #' This function provides a convenience interface for generating generalizations of a 2-way frequency table. Row and+ ) |
|||
| 1870 | +379 |
- #' column space can be facetted by variables, and an analysis function can be specified. The function then builds a+ |
|||
| 1871 | +380 |
- #' layout with the specified layout and applies it to the data provided.+ #' @rdname int_methods |
|||
| 1872 | +381 |
- #'+ setMethod( |
|||
| 1873 | +382 |
- #' @inheritParams constr_args+ "table_structure_inner", "ElementaryTable", |
|||
| 1874 | +383 |
- #' @inheritParams basic_table+ function(obj, depth = 0, indent = 0, print_indent = 0) {
|
|||
| 1875 | -+ | ||||
| 384 | +15x |
- #' @param row_vars (`character`)\cr the names of variables to be used in row facetting.+ scat("ElementaryTable: ", "[", obj_name(obj),
|
|||
| 1876 | -+ | ||||
| 385 | +15x |
- #' @param col_vars (`character`)\cr the names of variables to be used in column facetting.+ "] (", obj_label(obj), ")",
|
|||
| 1877 | -+ | ||||
| 386 | +15x |
- #' @param data (`data.frame`)\cr the data to tabulate.+ indent = print_indent |
|||
| 1878 | +387 |
- #' @param avar (`string`)\cr the variable to be analyzed. Defaults to the first variable in `data`.+ ) |
|||
| 1879 | +388 |
- #' @param row_labels (`character` or `NULL`)\cr row label(s) which should be applied to the analysis rows. Length must+ |
|||
| 1880 | -+ | ||||
| 389 | +15x |
- #' match the number of rows generated by `afun`.+ indent <- indent + indent_mod(obj) |
|||
| 1881 | +390 |
- #' @param afun (`function`)\cr the function to generate the analysis row cell values. This can be a proper analysis+ |
|||
| 1882 | -+ | ||||
| 391 | +15x |
- #' function, or a function which returns a vector or list. Vectors are taken as multi-valued single cells, whereas+ table_structure_inner( |
|||
| 1883 | -+ | ||||
| 392 | +15x |
- #' lists are interpreted as multiple cells.+ tt_labelrow(obj), depth, |
|||
| 1884 | -+ | ||||
| 393 | +15x |
- #' @param drop_levels (`flag`)\cr whether unobserved factor levels should be dropped during facetting. Defaults to+ indent, print_indent + 1 |
|||
| 1885 | +394 |
- #' `TRUE`.+ ) |
|||
| 1886 | +395 |
- #' @param summarize_groups (`flag`)\cr whether each level of nesting should include marginal summary rows. Defaults to+ |
|||
| 1887 | -+ | ||||
| 396 | +15x |
- #' `FALSE`.+ if (length(tree_children(obj)) == 0) {
|
|||
| 1888 | -+ | ||||
| 397 | +! |
- #' @param ... additional arguments passed to `afun`.+ scat("children: - ", indent = print_indent + 1)
|
|||
| 1889 | +398 |
- #' @param .default_rlabel (`string`)\cr this is an implementation detail that should not be set by end users.+ } else {
|
|||
| 1890 | -+ | ||||
| 399 | +15x |
- #'+ scat("children: ", indent = print_indent + 1)
|
|||
| 1891 | -+ | ||||
| 400 | +15x |
- #' @details+ lapply(tree_children(obj), table_structure_inner, |
|||
| 1892 | -+ | ||||
| 401 | +15x |
- #' This function creates a table with a single top-level structure in both row and column dimensions involving faceting+ depth = depth + 1, indent = indent, |
|||
| 1893 | -+ | ||||
| 402 | +15x |
- #' by 0 or more variables in each dimension.+ print_indent = print_indent + 2 |
|||
| 1894 | +403 |
- #'+ ) |
|||
| 1895 | +404 |
- #' The display of the table depends on certain details of the tabulation. In the case of an `afun` which returns a+ } |
|||
| 1896 | +405 |
- #' single cell's contents (either a scalar or a vector of 2 or 3 elements), the label rows for the deepest-nested row+ |
|||
| 1897 | -+ | ||||
| 406 | +15x |
- #' facets will be hidden and the labels used there will be used as the analysis row labels. In the case of an `afun`+ invisible(NULL) |
|||
| 1898 | +407 |
- #' which returns a list (corresponding to multiple cells), the names of the list will be used as the analysis row+ } |
|||
| 1899 | +408 |
- #' labels and the deepest-nested facet row labels will be visible.+ ) |
|||
| 1900 | +409 |
- #'+ |
|||
| 1901 | +410 |
- #' The table will be annotated in the top-left area with an informative label displaying the analysis variable+ #' @rdname int_methods |
|||
| 1902 | +411 |
- #' (`avar`), if set, and the function used (captured via substitute) where possible, or 'count' if not. One exception+ setMethod( |
|||
| 1903 | +412 |
- #' where the user may directly modify the top-left area (via `row_labels`) is the case of a table with row facets and+ "table_structure_inner", "TableRow", |
|||
| 1904 | +413 |
- #' an `afun` which returns a single row.+ function(obj, depth = 0, indent = 0, print_indent = 0) {
|
|||
| 1905 | -+ | ||||
| 414 | +20x |
- #'+ scat(class(obj), ": ", "[", obj_name(obj), "] (",
|
|||
| 1906 | -+ | ||||
| 415 | +20x |
- #' @return+ obj_label(obj), ")", |
|||
| 1907 | -+ | ||||
| 416 | +20x |
- #' * `qtable` returns a built `TableTree` object representing the desired table+ indent = print_indent |
|||
| 1908 | +417 |
- #' * `qtable_layout` returns a `PreDataTableLayouts` object declaring the structure of the desired table, suitable for+ ) |
|||
| 1909 | +418 |
- #' passing to [build_table()].+ |
|||
| 1910 | -+ | ||||
| 419 | +20x |
- #'+ indent <- indent + indent_mod(obj) |
|||
| 1911 | +420 |
- #' @examples+ |
|||
| 1912 | -+ | ||||
| 421 | +20x |
- #' qtable(ex_adsl)+ invisible(NULL) |
|||
| 1913 | +422 |
- #' qtable(ex_adsl, row_vars = "ARM")+ } |
|||
| 1914 | +423 |
- #' qtable(ex_adsl, col_vars = "ARM")+ ) |
|||
| 1915 | +424 |
- #' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM")+ |
|||
| 1916 | +425 |
- #' qtable(ex_adsl, row_vars = c("COUNTRY", "SEX"), col_vars = c("ARM", "STRATA1"))
+ #' @rdname int_methods |
|||
| 1917 | +426 |
- #' qtable(ex_adsl,+ setMethod( |
|||
| 1918 | +427 |
- #' row_vars = c("COUNTRY", "SEX"),
+ "table_structure_inner", "LabelRow", |
|||
| 1919 | +428 |
- #' col_vars = c("ARM", "STRATA1"), avar = "AGE", afun = mean
+ function(obj, depth = 0, indent = 0, print_indent = 0) {
|
|||
| 1920 | -+ | ||||
| 429 | +25x |
- #' )+ indent <- indent + indent_mod(obj) |
|||
| 1921 | +430 |
- #' summary_list <- function(x, ...) as.list(summary(x))+ |
|||
| 1922 | -+ | ||||
| 431 | +25x |
- #' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM", avar = "AGE", afun = summary_list)+ txtvis <- if (!obj_visible(obj)) " - <not visible>" else "" |
|||
| 1923 | +432 |
- #' suppressWarnings(qtable(ex_adsl,+ |
|||
| 1924 | -+ | ||||
| 433 | +25x |
- #' row_vars = "SEX",+ scat("labelrow: ", "[", obj_name(obj), "] (", obj_label(obj), ")",
|
|||
| 1925 | -+ | ||||
| 434 | +25x |
- #' col_vars = "ARM", avar = "AGE", afun = range+ txtvis, |
|||
| 1926 | -+ | ||||
| 435 | +25x |
- #' ))+ indent = print_indent |
|||
| 1927 | +436 |
- #'+ ) |
|||
| 1928 | +437 |
- #' @export+ |
|||
| 1929 | -+ | ||||
| 438 | +25x |
- qtable_layout <- function(data,+ obj_visible(obj) |
|||
| 1930 | +439 |
- row_vars = character(),+ } |
|||
| 1931 | +440 |
- col_vars = character(),+ ) |
| 1932 | +1 |
- avar = NULL,+ do_recursive_replace <- function(tab, path, incontent = FALSE, value) { ## rows = NULL,
|
||
| 1933 | +2 |
- row_labels = NULL,+ ## cols = NULL, value) {
|
||
| 1934 | +3 |
- afun = NULL,+ ## don't want this in the recursive function |
||
| 1935 | +4 |
- summarize_groups = FALSE,+ ## so thats why we have the do_ variant+ |
+ ||
| 5 | +168x | +
+ if (is.character(path) && length(path) > 1) {
+ |
+ ||
| 6 | +143x | +
+ path <- as.list(path) |
||
| 1936 | +7 |
- title = "",+ }+ |
+ ||
| 8 | +168x | +
+ if (length(path) > 0 && path[[1]] == obj_name(tab)) {
+ |
+ ||
| 9 | +144x | +
+ path <- path[-1] |
||
| 1937 | +10 |
- subtitles = character(),+ }+ |
+ ||
| 11 | +168x | +
+ recursive_replace(tab, path, value) ## incontent, rows, cols,value) |
||
| 1938 | +12 |
- main_footer = character(),+ } |
||
| 1939 | +13 |
- prov_footer = character(),+ |
||
| 1940 | +14 |
- show_colcounts = TRUE,+ ## different cases we want to support: |
||
| 1941 | +15 |
- drop_levels = TRUE,+ ## 1. Replace entire children for a particular node/position in the tree |
||
| 1942 | +16 |
- ...,+ ## 2. Replace entire rows at a particular (ElementaryTable) position within the |
||
| 1943 | +17 |
- .default_rlabel = NULL) {
+ ## tree |
||
| 1944 | -16x | +|||
| 18 | +
- subafun <- substitute(afun)+ ## 3. Replace specific cell values within a set of row x column positions within |
|||
| 1945 | -16x | +|||
| 19 | +
- if (!is.null(.default_rlabel)) {
+ ## an ElementaryTable at a particular position within the tree |
|||
| 1946 | -16x | +|||
| 20 | +
- dflt_row_lbl <- .default_rlabel+ ## 3. replace entire content table at a node position |
|||
| 1947 | +21 |
- } else if (+ ## 4. replace entire rows within the content table at a particular node position |
||
| 1948 | -! | +|||
| 22 | +
- is.name(subafun) &&+ ## in the tree |
|||
| 1949 | -! | +|||
| 23 | +
- is.function(afun) &&+ ## 5. replace data cell values for specific row/col positions within the content |
|||
| 1950 | +24 |
- ## this is gross. basically testing+ ## table at a particular position within the tree |
||
| 1951 | +25 |
- ## if the symbol we have corresponds+ |
||
| 1952 | +26 |
- ## in some meaningful way to the function+ ## XXX This is wrong, what happens if a split (or more accurately, value) |
||
| 1953 | +27 |
- ## we will be calling.+ ## happens more than once in the overall tree??? |
||
| 1954 | -! | +|||
| 28 | +
- identical(+ recursive_replace <- function(tab, path, value) { ## incontent = FALSE, rows = NULL, cols = NULL, value) {
|
|||
| 1955 | -! | +|||
| 29 | +675x |
- mget(+ if (length(path) == 0) { ## done recursing
|
||
| 1956 | -! | +|||
| 30 | +
- as.character(subafun),+ ## if(is.null(rows) && is.null(cols)) { ## replacing whole subtree a this position
|
|||
| 1957 | -! | +|||
| 31 | +
- mode = "function",+ ## if(incontent) {
|
|||
| 1958 | -! | +|||
| 32 | +
- envir = parent.frame(1),+ ## newkid = tab |
|||
| 1959 | -! | +|||
| 33 | +
- ifnotfound = list(NULL),+ ## content_table(newkid) = value |
|||
| 1960 | -! | +|||
| 34 | +
- inherits = TRUE+ ## } else |
|||
| 1961 | -! | +|||
| 35 | +171x |
- )[[1]],+ newkid <- value |
||
| 1962 | -! | +|||
| 36 | +
- afun+ ## newkid has either thee content table |
|||
| 1963 | +37 |
- )+ ## replaced on the old kid or is the new |
||
| 1964 | +38 |
- ) {
+ ## kid |
||
| 1965 | -! | +|||
| 39 | +
- dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ")+ # } ## else { ## rows or cols (or both) non-null
|
|||
| 1966 | +40 |
- } else {
+ ## if(incontent) {
|
||
| 1967 | -! | +|||
| 41 | +
- dflt_row_lbl <- if (is.null(avar)) "count" else avar+ ## ctab = content_table(tab) |
|||
| 1968 | +42 |
- }+ ## ctab[rows, cols] = value |
||
| 1969 | +43 | ++ |
+ ## content_table(tab) = ctab+ |
+ |
| 44 | ++ |
+ ## newkid = tab+ |
+ ||
| 45 | ||||
| 1970 | -16x | +|||
| 46 | +
- if (is.null(afun)) {
+ ## } else {
|
|||
| 1971 | -5x | +|||
| 47 | +
- afun <- count+ ## allkids = tree_children(tab) |
|||
| 1972 | +48 |
- }+ ## stopifnot(are(allkids, "TableRow")) |
||
| 1973 | +49 |
-
+ ## newkid = tab |
||
| 1974 | -16x | +|||
| 50 | +
- if (is.null(avar)) {
+ ## newkid[rows, cols] = value |
|||
| 1975 | -5x | +|||
| 51 | +
- avar <- names(data)[1]+ ## } |
|||
| 1976 | +52 |
- }+ ## } |
||
| 1977 | -16x | +53 | +171x |
- fakeres <- afun(data[[avar]], ...)+ return(newkid) |
| 1978 | -16x | +54 | +504x |
- multirow <- is.list(fakeres) || is(fakeres, "RowsVerticalSection") || summarize_groups+ } else if (path[[1]] == "@content") {
+ |
+
| 55 | +25x | +
+ ctb <- content_table(tab)+ |
+ ||
| 56 | +25x | +
+ ctb <- recursive_replace(ctb,+ |
+ ||
| 57 | +25x | +
+ path = path[-1], |
||
| 1979 | +58 |
- ## this is before we plug in the default so if not specified by the user+ ## rows = rows, |
||
| 1980 | +59 |
- ## explicitly, row_labels is NULL at this point.+ ## cols = cols, |
||
| 1981 | -16x | +60 | +25x |
- if (!is.null(row_labels) && length(row_labels) != n_cells_res(fakeres)) {
+ value = value |
| 1982 | -2x | +|||
| 61 | +
- stop(+ ) |
|||
| 1983 | -2x | +62 | +25x |
- "Length of row_labels (",
+ content_table(tab) <- ctb |
| 1984 | -2x | +63 | +25x |
- length(row_labels),+ tab |
| 1985 | -2x | +|||
| 64 | +
- ") does not agree with number of rows generated by analysis function (",
+ } else { ## length(path) > 1, more recursing to do
|
|||
| 1986 | -2x | +65 | +479x |
- n_cells_res(fakeres),+ kidel <- path[[1]] |
| 1987 | +66 |
- ")."+ ## broken up for debugabiliity, could be a single complex |
||
| 1988 | +67 |
- )+ ## expression |
||
| 1989 | +68 |
- }+ ## for now only the last step supports selecting |
||
| 1990 | +69 |
-
+ ## multiple kids |
||
| 1991 | -14x | +70 | +479x |
- if (is.null(row_labels)) {
+ stopifnot( |
| 1992 | -10x | +71 | +479x |
- row_labels <- dflt_row_lbl+ length(kidel) == 1, |
| 1993 | -+ | |||
| 72 | +479x |
- }+ is.character(kidel) || is.factor(kidel) |
||
| 1994 | +73 |
-
+ ) |
||
| 1995 | -14x | +74 | +479x |
- lyt <- basic_table(+ knms <- names(tree_children(tab)) |
| 1996 | -14x | +75 | +479x |
- title = title,+ if (!(kidel %in% knms)) {
+ |
+
| 76 | +! | +
+ stop(sprintf("position element %s not in names of next level children", kidel))
|
||
| 1997 | -14x | +77 | +479x |
- subtitles = subtitles,+ } 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] |
||
| 1998 | -14x | +81 | +479x |
- main_footer = main_footer,+ newkid <- recursive_replace( |
| 1999 | -14x | +82 | +479x |
- prov_footer = prov_footer,+ tree_children(tab)[[kidel]], |
| 2000 | -14x | +83 | +479x |
- show_colcounts = show_colcounts+ path[-1], |
| 2001 | +84 |
- )+ ## incontent = incontent, |
||
| 2002 | +85 |
-
+ ## rows = rows,+ |
+ ||
| 86 | ++ |
+ ## cols = cols, |
||
| 2003 | -14x | +87 | +479x |
- for (var in col_vars) lyt <- split_cols_by(lyt, var)+ value |
| 2004 | +88 |
-
+ ) |
||
| 2005 | -14x | +89 | +479x |
- for (var in head(row_vars, -1)) {
+ tree_children(tab)[[kidel]] <- newkid |
| 2006 | -4x | +90 | +479x |
- lyt <- split_rows_by(lyt, var, split_fun = if (drop_levels) drop_split_levels else NULL)+ tab |
| 2007 | -4x | +|||
| 91 | +
- if (summarize_groups) {
+ } |
|||
| 2008 | -2x | +|||
| 92 | +
- lyt <- summarize_row_groups(lyt)+ } |
|||
| 2009 | +93 |
- }+ + |
+ ||
| 94 | +1x | +
+ coltree_split <- function(ctree) ctree@split |
||
| 2010 | +95 |
- }+ |
||
| 2011 | +96 |
-
+ col_fnotes_at_path <- function(ctree, path, fnotes) {
|
||
| 2012 | -14x | +97 | +2x |
- tleft <- if (multirow || length(row_vars) > 0) dflt_row_lbl else character()+ if (length(path) == 0) {
|
| 2013 | -14x | +98 | +1x |
- if (length(row_vars) > 0) {
+ col_footnotes(ctree) <- fnotes |
| 2014 | -10x | +99 | +1x |
- if (!multirow) {
+ return(ctree) |
| 2015 | +100 |
- ## in the single row in splitting case, we use the row label as the topleft+ } |
||
| 2016 | +101 |
- ## and the split values as the row labels for a more compact apeparance+ |
||
| 2017 | -6x | +102 | +1x |
- tleft <- row_labels+ if (identical(path[1], obj_name(coltree_split(ctree)))) {
|
| 2018 | -6x | +103 | +1x |
- row_labels <- NA_character_+ path <- path[-1] |
| 2019 | -6x | +|||
| 104 | +
- lyt <- split_rows_by(+ } else {
|
|||
| 2020 | -6x | +|||
| 105 | +! |
- lyt, tail(row_vars, 1),+ stop(paste("Path appears invalid at step:", path[1]))
|
||
| 2021 | -6x | +|||
| 106 | +
- split_fun = if (drop_levels) drop_split_levels else NULL, child_labels = "hidden"+ } |
|||
| 2022 | +107 |
- )+ |
||
| 2023 | -+ | |||
| 108 | +1x |
- } else {
+ kids <- tree_children(ctree) |
||
| 2024 | -4x | +109 | +1x |
- lyt <- split_rows_by(lyt, tail(row_vars, 1), split_fun = if (drop_levels) drop_split_levels else NULL)+ kidel <- path[[1]] |
| 2025 | -+ | |||
| 110 | +1x |
- }+ knms <- names(kids) |
||
| 2026 | -10x | +111 | +1x |
- if (summarize_groups) {
+ stopifnot(kidel %in% knms) |
| 2027 | -2x | +112 | +1x |
- lyt <- summarize_row_groups(lyt)+ newkid <- col_fnotes_at_path(kids[[kidel]], |
| 2028 | -+ | |||
| 113 | +1x |
- }+ path[-1],+ |
+ ||
| 114 | +1x | +
+ fnotes = fnotes |
||
| 2029 | +115 |
- }+ ) |
||
| 2030 | -14x | +116 | +1x |
- inner_afun <- .quick_afun(afun, row_labels)+ kids[[kidel]] <- newkid |
| 2031 | -14x | +117 | +1x |
- lyt <- analyze(lyt, avar, afun = inner_afun, extra_args = list(...))+ tree_children(ctree) <- kids |
| 2032 | -14x | +118 | +1x |
- lyt <- append_topleft(lyt, tleft)+ ctree |
| 2033 | +119 |
} |
||
| 2034 | +120 | |||
| 2035 | +121 |
- #' @rdname qtable_layout+ #' Insert row at path |
||
| 2036 | +122 |
- #' @export+ #' |
||
| 2037 | +123 |
- qtable <- function(data,+ #' Insert a row into an existing table directly before or directly after an existing data (i.e., non-content and |
||
| 2038 | +124 |
- row_vars = character(),+ #' non-label) row, specified by its path. |
||
| 2039 | +125 |
- col_vars = character(),+ #' |
||
| 2040 | +126 |
- avar = NULL,+ #' @inheritParams gen_args |
||
| 2041 | +127 |
- row_labels = NULL,+ #' @param after (`flag`)\cr whether `value` should be added as a row directly before (`FALSE`, the default) or after |
||
| 2042 | +128 |
- afun = NULL,+ #' (`TRUE`) the row specified by `path`. |
||
| 2043 | +129 |
- summarize_groups = FALSE,+ #' |
||
| 2044 | +130 |
- title = "",+ #' @seealso [DataRow()], [rrow()] |
||
| 2045 | +131 |
- subtitles = character(),+ #' |
||
| 2046 | +132 |
- main_footer = character(),+ #' @examples |
||
| 2047 | +133 |
- prov_footer = character(),+ #' lyt <- basic_table() %>% |
||
| 2048 | +134 |
- show_colcounts = TRUE,+ #' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
|
||
| 2049 | +135 |
- drop_levels = TRUE,+ #' analyze("AGE")
|
||
| 2050 | +136 |
- ...) {
+ #' |
||
| 2051 | +137 |
- ## this involves substitution so it needs to appear in both functions. Gross but true.+ #' tbl <- build_table(lyt, DM) |
||
| 2052 | -16x | +|||
| 138 | +
- subafun <- substitute(afun)+ #' |
|||
| 2053 | +139 |
- if (+ #' tbl2 <- insert_row_at_path( |
||
| 2054 | -16x | +|||
| 140 | +
- is.name(subafun) && is.function(afun) &&+ #' tbl, c("COUNTRY", "CHN", "AGE", "Mean"),
|
|||
| 2055 | +141 |
- ## this is gross. basically testing+ #' rrow("new row", 555)
|
||
| 2056 | +142 |
- ## if the symbol we have corresponds+ #' ) |
||
| 2057 | +143 |
- ## in some meaningful way to the function+ #' tbl2 |
||
| 2058 | +144 |
- ## we will be calling.+ #' |
||
| 2059 | -16x | +|||
| 145 | +
- identical(+ #' tbl3 <- insert_row_at_path(tbl2, c("COUNTRY", "CHN", "AGE", "Mean"),
|
|||
| 2060 | -16x | +|||
| 146 | +
- mget(+ #' rrow("new row redux", 888),
|
|||
| 2061 | -16x | +|||
| 147 | +
- as.character(subafun),+ #' after = TRUE |
|||
| 2062 | -16x | +|||
| 148 | +
- mode = "function", envir = parent.frame(1), ifnotfound = list(NULL), inherits = TRUE+ #' ) |
|||
| 2063 | -16x | +|||
| 149 | +
- )[[1]],+ #' tbl3 |
|||
| 2064 | -16x | +|||
| 150 | +
- afun+ #' |
|||
| 2065 | +151 |
- )+ #' @export |
||
| 2066 | +152 |
- ) {
+ setGeneric("insert_row_at_path",
|
||
| 2067 | -11x | +|||
| 153 | +
- dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ")+ signature = c("tt", "value"),
|
|||
| 2068 | +154 |
- } else {
+ function(tt, path, value, after = FALSE) {
|
||
| 2069 | -5x | +155 | +6x |
- dflt_row_lbl <- if (is.null(avar)) "count" else avar+ standardGeneric("insert_row_at_path")
|
| 2070 | +156 |
} |
||
| 2071 | +157 | ++ |
+ )+ |
+ |
| 158 | ||||
| 2072 | -16x | +|||
| 159 | +
- lyt <- qtable_layout(+ #' @rdname insert_row_at_path |
|||
| 2073 | -16x | +|||
| 160 | +
- data = data,+ setMethod( |
|||
| 2074 | -16x | +|||
| 161 | +
- row_vars = row_vars,+ "insert_row_at_path", c("VTableTree", "DataRow"),
|
|||
| 2075 | -16x | +|||
| 162 | +
- col_vars = col_vars,+ function(tt, path, value, after = FALSE) {
|
|||
| 2076 | -16x | +163 | +6x |
- avar = avar,+ if (no_colinfo(value)) {
|
| 2077 | -16x | +164 | +6x |
- row_labels = row_labels,+ col_info(value) <- col_info(tt) |
| 2078 | -16x | +|||
| 165 | +
- afun = afun,+ } else {
|
|||
| 2079 | -16x | +|||
| 166 | +! |
- summarize_groups = summarize_groups,+ chk_compat_cinfos(tt, value)+ |
+ ||
| 167 | ++ |
+ }+ |
+ ||
| 168 | ++ |
+ ## retained for debugging |
||
| 2080 | -16x | +169 | +6x |
- title = title,+ origpath <- path # nolint |
| 2081 | -16x | +170 | +6x |
- subtitles = subtitles,+ idx_row <- tt_at_path(tt, path) |
| 2082 | -16x | +171 | +6x |
- main_footer = main_footer,+ if (!is(idx_row, "DataRow")) {
|
| 2083 | -16x | +172 | +4x |
- prov_footer = prov_footer,+ stop( |
| 2084 | -16x | +173 | +4x |
- show_colcounts = show_colcounts,+ "path must resolve fully to a non-content data row. Insertion of ", |
| 2085 | -16x | +174 | +4x |
- drop_levels = drop_levels,+ "rows elsewhere in the tree is not currently supported." |
| 2086 | +175 |
- ...,+ ) |
||
| 2087 | -16x | +|||
| 176 | +
- .default_rlabel = dflt_row_lbl+ } |
|||
| 2088 | +177 |
- )+ |
||
| 2089 | -14x | +178 | +2x |
- build_table(lyt, data)+ posnm <- tail(path, 1) |
| 2090 | +179 |
- }- |
-
| 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 | +180 | +2x |
- sep = ""+ path <- head(path, -1) |
| 6 | +181 |
- )+ |
||
| 7 | -19x | +182 | +2x |
- if (!is(obj, "ElementaryTable") && nrow(obj@content) > 0) {
+ subtt <- tt_at_path(tt, path) |
| 8 | -6x | +183 | +2x |
- crows <- nrow(content_table(obj))+ kids <- tree_children(subtt) |
| 9 | -6x | +184 | +2x |
- ccols <- if (crows == 0) 0 else nc+ ind <- which(names(kids) == posnm) |
| 10 | -6x | +185 | +2x |
- cat(sprintf(+ if (length(ind) != 1L) {
|
| 11 | -6x | +|||
| 186 | +
- " [cont: %d x %d]",+ ## nocov start |
|||
| 12 | -6x | +|||
| 187 | +
- crows, ccols+ stop( |
|||
| 13 | +188 |
- ))+ "table children do not appear to be named correctly at this ", |
||
| 14 | +189 |
- }+ "path. This should not happen, please contact the maintainer of ", |
||
| 15 | -19x | +|||
| 190 | +
- if (is(obj, "VTableTree") && length(tree_children(obj))) {
+ "rtables." |
|||
| 16 | -19x | +|||
| 191 | +
- kids <- tree_children(obj)+ ) |
|||
| 17 | -19x | +|||
| 192 | +
- if (are(kids, "TableRow")) {
+ ## nocov end |
|||
| 18 | -9x | +|||
| 193 | +
- cat(sprintf(+ } |
|||
| 19 | -9x | +194 | +2x |
- " (%d x %d)\n",+ if (after) {
|
| 20 | -9x | +195 | +1x |
- length(kids), nc+ ind <- ind + 1 |
| 21 | +196 |
- ))+ } |
||
| 22 | +197 |
- } else {
+
|
||
| 23 | -10x | +198 | +2x |
- cat("\n")
+ sq <- seq_along(kids) |
| 24 | -10x | +199 | +2x |
- lapply(kids, treestruct, ind = ind + 1)+ tree_children(subtt) <- c( |
| 25 | -+ | |||
| 200 | +2x |
- }+ kids[sq < ind], |
||
| 26 | -+ | |||
| 201 | +2x |
- }+ setNames(list(value), obj_name(value)), |
||
| 27 | -19x | +202 | +2x |
- invisible(NULL)+ kids[sq >= ind] |
| 28 | +203 |
- }+ ) |
||
| 29 | -+ | |||
| 204 | +2x |
-
+ tt_at_path(tt, path) <- subtt |
||
| 30 | -+ | |||
| 205 | +2x |
- setGeneric(+ tt |
||
| 31 | +206 |
- "ploads_to_str",- |
- ||
| 32 | -103x | -
- function(x, collapse = ":") standardGeneric("ploads_to_str")
+ } |
||
| 33 | +207 |
) |
||
| 34 | +208 |
-
+ #' @rdname insert_row_at_path |
||
| 35 | +209 |
setMethod( |
||
| 36 | +210 |
- "ploads_to_str", "Split",+ "insert_row_at_path", c("VTableTree", "ANY"),
|
||
| 37 | +211 |
- function(x, collapse = ":") {
+ function(tt, path, value) {
|
||
| 38 | -52x | +|||
| 212 | +! |
- paste(sapply(spl_payload(x), ploads_to_str),+ stop( |
||
| 39 | -52x | +|||
| 213 | +! |
- collapse = collapse+ "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." |
||
| 40 | +216 |
) |
||
| 41 | +217 |
} |
||
| 42 | +218 |
) |
||
| 43 | +219 | |||
| 44 | +220 |
- setMethod(+ #' Label at path |
||
| 45 | +221 |
- "ploads_to_str", "CompoundSplit",+ #' |
||
| 46 | +222 |
- function(x, collapse = ":") {
- |
- ||
| 47 | -6x | -
- paste(sapply(spl_payload(x), ploads_to_str),- |
- ||
| 48 | -6x | -
- collapse = collapse+ #' Accesses or sets the label at a path. |
||
| 49 | +223 |
- )+ #' |
||
| 50 | +224 |
- }+ #' @inheritParams gen_args |
||
| 51 | +225 |
- )+ #' |
||
| 52 | +226 |
-
+ #' @details |
||
| 53 | +227 |
- setMethod(+ #' If `path` resolves to a single row, the label for that row is retrieved or set. If, instead, `path` resolves to a |
||
| 54 | +228 |
- "ploads_to_str", "list",+ #' subtable, the text for the row-label associated with that path is retrieved or set. In the subtable case, if the |
||
| 55 | +229 |
- function(x, collapse = ":") {
- |
- ||
| 56 | -! | -
- stop("Please contact the maintainer")
+ #' label text is set to a non-`NA` value, the `labelrow` will be set to visible, even if it was not before. Similarly, |
||
| 57 | +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 |
||
| 58 | +231 |
- )+ #' appear at all when the table is printed. |
||
| 59 | +232 |
-
+ #' |
||
| 60 | +233 |
- setMethod(+ #' @note When changing the row labels for content rows, it is important to path all the way to the *row*. Paths |
||
| 61 | +234 |
- "ploads_to_str", "SplitVector",+ #' ending in `"@content"` will not exhibit the behavior you want, and are thus an error. See [row_paths()] for help |
||
| 62 | +235 |
- function(x, collapse = ":") {
- |
- ||
| 63 | -8x | -
- sapply(x, ploads_to_str)+ #' determining the full paths to content rows. |
||
| 64 | +236 |
- }+ #' |
||
| 65 | +237 |
- )+ #' @examples |
||
| 66 | +238 |
-
+ #' lyt <- basic_table() %>% |
||
| 67 | +239 |
- setMethod(+ #' split_rows_by("COUNTRY", split_fun = keep_split_levels(c("CHN", "USA"))) %>%
|
||
| 68 | +240 |
- "ploads_to_str", "ANY",+ #' analyze("AGE")
|
||
| 69 | +241 |
- function(x, collapse = ":") {
+ #' |
||
| 70 | -37x | +|||
| 242 | +
- paste(x)+ #' tbl <- build_table(lyt, DM) |
|||
| 71 | +243 |
- }+ #' |
||
| 72 | +244 |
- )+ #' label_at_path(tbl, c("COUNTRY", "CHN"))
|
||
| 73 | +245 |
-
+ #' |
||
| 74 | -47x | +|||
| 246 | +
- setGeneric("payloadmsg", function(spl) standardGeneric("payloadmsg"))
+ #' label_at_path(tbl, c("COUNTRY", "USA")) <- "United States"
|
|||
| 75 | +247 |
-
+ #' tbl |
||
| 76 | +248 |
- setMethod(+ #' |
||
| 77 | +249 |
- "payloadmsg", "VarLevelSplit",+ #' @export |
||
| 78 | +250 |
- function(spl) {
+ label_at_path <- function(tt, path) {
|
||
| 79 | -45x | +251 | +29x |
- spl_payload(spl)+ obj_label(tt_at_path(tt, path)) |
| 80 | +252 |
- }+ } |
||
| 81 | +253 |
- )+ |
||
| 82 | +254 |
-
+ #' @export |
||
| 83 | +255 |
- setMethod(+ #' @rdname label_at_path |
||
| 84 | +256 |
- "payloadmsg", "MultiVarSplit",+ `label_at_path<-` <- function(tt, path, value) {
|
||
| 85 | -2x | +257 | +32x |
- function(spl) "var"+ if (!is(tt, "VTableTree")) {
|
| 86 | -+ | |||
| 258 | +! |
- )+ stop("tt must be a TableTree or ElementaryTable object")
|
||
| 87 | +259 |
-
+ } |
||
| 88 | -+ | |||
| 260 | +32x |
- setMethod(+ if (is.null(value) || is.na(value)) {
|
||
| 89 | -+ | |||
| 261 | +1x |
- "payloadmsg", "VarLevWBaselineSplit",+ value <- NA_character_ |
||
| 90 | +262 |
- function(spl) {
- |
- ||
| 91 | -! | -
- paste0(+ } |
||
| 92 | -! | +|||
| 263 | +32x |
- spl_payload(spl), "[bsl ",+ subt <- tt_at_path(tt, path) |
||
| 93 | -! | +|||
| 264 | +32x |
- spl@ref_group_value, # XXX XXX+ obj_label(subt) <- value |
||
| 94 | -+ | |||
| 265 | +32x |
- "]"+ tt_at_path(tt, path) <- subt |
||
| 95 | -+ | |||
| 266 | +32x |
- )+ tt |
||
| 96 | +267 |
- }+ } |
||
| 97 | +268 |
- )+ |
||
| 98 | +269 |
-
+ #' Access or set table elements at specified path |
||
| 99 | +270 |
- setMethod(+ #' |
||
| 100 | +271 |
- "payloadmsg", "ManualSplit",- |
- ||
| 101 | -! | -
- function(spl) "mnl"+ #' @inheritParams gen_args |
||
| 102 | +272 |
- )+ #' @param ... unused. |
||
| 103 | +273 |
-
+ #' |
||
| 104 | +274 |
- setMethod(+ #' @export |
||
| 105 | +275 |
- "payloadmsg", "AllSplit",+ #' @rdname ttap |
||
| 106 | -! | +|||
| 276 | +348x |
- function(spl) "all"+ setGeneric("tt_at_path", function(tt, path, ...) standardGeneric("tt_at_path"))
|
||
| 107 | +277 |
- )+ |
||
| 108 | +278 |
-
+ #' @inheritParams tt_at_path |
||
| 109 | +279 |
- setMethod(+ #' |
||
| 110 | +280 |
- "payloadmsg", "ANY",+ #' @export |
||
| 111 | +281 |
- function(spl) {
- |
- ||
| 112 | -! | -
- warning("don't know how to make payload print message for Split of class", class(spl))
- |
- ||
| 113 | -! | -
- "XXX"+ #' @rdname int_methods |
||
| 114 | +282 |
- }+ setMethod( |
||
| 115 | +283 |
- )+ "tt_at_path", "VTableTree", |
||
| 116 | +284 |
-
+ function(tt, path, ...) {
|
||
| 117 | -+ | |||
| 285 | +348x |
- spldesc <- function(spl, value = "") {
+ stopifnot( |
||
| 118 | -32x | +286 | +348x |
- value <- rawvalues(value)+ is(path, "character"), |
| 119 | -32x | +287 | +348x |
- payloadmsg <- payloadmsg(spl)+ length(path) > 0, |
| 120 | -32x | +288 | +348x |
- format <- "%s (%s)"+ !anyNA(path) |
| 121 | -32x | +|||
| 289 | +
- sprintf(+ ) |
|||
| 122 | -32x | +|||
| 290 | +
- format,+ |
|||
| 123 | -32x | +291 | +348x |
- value,+ if (path[1] == "root" && obj_name(tt) != "root") {
|
| 124 | -32x | +292 | +3x |
- payloadmsg+ path <- path[-1] |
| 125 | +293 |
- )+ } |
||
| 126 | +294 |
- }+ ## handle pathing that hits the root split by name |
||
| 127 | -+ | |||
| 295 | +348x |
-
+ if (obj_name(tt) == path[1]) {
|
||
| 128 | -+ | |||
| 296 | +318x |
- layoutmsg <- function(obj) {
+ path <- path[-1] |
||
| 129 | +297 |
- ## if(!is(obj, "VLayoutNode"))+ } |
||
| 130 | -+ | |||
| 298 | +348x |
- ## stop("how did a non layoutnode object get in docatlayout??")
+ cur <- tt |
||
| 131 | -+ | |||
| 299 | +348x |
-
+ curpath <- path |
||
| 132 | -28x | +300 | +348x |
- pos <- tree_pos(obj)+ while (length(curpath > 0)) {
|
| 133 | -28x | +301 | +1163x |
- spllst <- pos_splits(pos)+ kids <- tree_children(cur) |
| 134 | -28x | +302 | +1163x |
- spvallst <- pos_splvals(pos)+ curname <- curpath[1] |
| 135 | -28x | +303 | +1163x |
- if (is(obj, "LayoutAxisTree")) {
+ if (curname == "@content") {
|
| 136 | -12x | +304 | +65x |
- kids <- tree_children(obj)+ cur <- content_table(cur) |
| 137 | -12x | +305 | +1098x |
- return(unlist(lapply(kids, layoutmsg)))+ } else if (curname %in% names(kids)) {
|
| 138 | -+ | |||
| 306 | +1097x |
- }+ cur <- kids[[curname]] |
||
| 139 | +307 |
-
+ } else {
|
||
| 140 | -16x | +308 | +1x |
- msg <- paste(+ stop("Path appears invalid for this tree at step ", curname)
|
| 141 | -16x | +|||
| 309 | +
- collapse = " -> ",+ } |
|||
| 142 | -16x | +310 | +1162x |
- mapply(spldesc,+ curpath <- curpath[-1] |
| 143 | -16x | +|||
| 311 | +
- spl = spllst,+ } |
|||
| 144 | -16x | +312 | +347x |
- value = spvallst+ cur |
| 145 | +313 |
- )+ } |
||
| 146 | +314 |
- )- |
- ||
| 147 | -16x | -
- msg+ ) |
||
| 148 | +315 |
- }+ |
||
| 149 | +316 |
-
+ #' @note Setting `NULL` at a defined path removes the corresponding sub-table. |
||
| 150 | +317 |
- setMethod(+ #' |
||
| 151 | +318 |
- "show", "LayoutAxisTree",+ #' @examples |
||
| 152 | +319 |
- function(object) {
+ #' # Accessing sub table. |
||
| 153 | -2x | +|||
| 320 | +
- msg <- layoutmsg(object)+ #' lyt <- basic_table() %>% |
|||
| 154 | -2x | +|||
| 321 | +
- cat(msg, "\n")+ #' split_cols_by("ARM") %>%
|
|||
| 155 | -2x | +|||
| 322 | +
- invisible(object)+ #' split_rows_by("SEX") %>%
|
|||
| 156 | +323 |
- }+ #' split_rows_by("BMRKR2") %>%
|
||
| 157 | +324 |
- )+ #' analyze("AGE")
|
||
| 158 | +325 |
-
+ #' |
||
| 159 | +326 |
-
+ #' tbl <- build_table(lyt, ex_adsl) %>% prune_table() |
||
| 160 | +327 |
- #' Display column tree structure+ #' sub_tbl <- tt_at_path(tbl, path = c("SEX", "F", "BMRKR2"))
|
||
| 161 | +328 |
#' |
||
| 162 | +329 |
- #' Displays the tree structure of the columns of a+ #' # Removing sub table. |
||
| 163 | +330 |
- #' table or column structure object.+ #' tbl2 <- tbl |
||
| 164 | +331 |
- #'+ #' tt_at_path(tbl2, path = c("SEX", "F")) <- NULL
|
||
| 165 | +332 |
- #' @inheritParams gen_args+ #' tbl2 |
||
| 166 | +333 |
#' |
||
| 167 | +334 |
- #' @return Nothing, called for its side effect of displaying+ #' # Setting sub table. |
||
| 168 | +335 |
- #' a summary to the terminal.+ #' lyt3 <- basic_table() %>% |
||
| 169 | +336 |
- #'+ #' split_cols_by("ARM") %>%
|
||
| 170 | +337 |
- #' @examples+ #' split_rows_by("SEX") %>%
|
||
| 171 | +338 |
- #' lyt <- basic_table() %>%+ #' analyze("BMRKR2")
|
||
| 172 | +339 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 173 | +340 |
- #' split_cols_by("STRATA1") %>%
+ #' tbl3 <- build_table(lyt3, ex_adsl) %>% prune_table() |
||
| 174 | +341 |
- #' split_cols_by("SEX", nested = FALSE) %>%
+ #' |
||
| 175 | +342 |
- #' analyze("AGE")
+ #' tt_at_path(tbl3, path = c("SEX", "F", "BMRKR2")) <- sub_tbl
|
||
| 176 | +343 |
- #'+ #' tbl3 |
||
| 177 | +344 |
- #' tbl <- build_table(lyt, ex_adsl)+ #' |
||
| 178 | +345 |
- #' coltree_structure(tbl)+ #' @export |
||
| 179 | +346 |
- #' @export+ #' @rdname ttap |
||
| 180 | +347 |
- coltree_structure <- function(obj) {
+ setGeneric( |
||
| 181 | -1x | +|||
| 348 | +
- ctree <- coltree(obj)+ "tt_at_path<-", |
|||
| 182 | -1x | +349 | +168x |
- cat(layoutmsg2(ctree))+ function(tt, path, ..., value) standardGeneric("tt_at_path<-")
|
| 183 | +350 |
- }+ ) |
||
| 184 | +351 | |||
| 185 | +352 |
- lastposmsg <- function(pos) {
+ #' @export |
||
| 186 | -6x | +|||
| 353 | +
- spls <- pos_splits(pos)+ #' @keywords internal |
|||
| 187 | -6x | +|||
| 354 | +
- splvals <- value_names(pos_splvals(pos))+ #' @rdname int_methods |
|||
| 188 | -6x | +|||
| 355 | +
- indiv_msgs <- unlist(mapply(function(spl, valnm) paste(obj_name(spl), valnm, sep = ": "),+ setMethod( |
|||
| 189 | -6x | +|||
| 356 | +
- spl = spls,+ "tt_at_path<-", c(tt = "VTableTree", value = "VTableTree"), |
|||
| 190 | -6x | +|||
| 357 | +
- valnm = splvals,+ function(tt, path, ..., value) {
|
|||
| 191 | -6x | +358 | +78x |
- SIMPLIFY = FALSE+ do_recursive_replace(tt, path = path, value = value) |
| 192 | +359 |
- ))- |
- ||
| 193 | -6x | -
- paste(indiv_msgs, collapse = " -> ")+ } |
||
| 194 | +360 |
- }+ ) |
||
| 195 | +361 | |||
| 196 | +362 |
- layoutmsg2 <- function(obj, level = 1) {
+ ## this one removes the child at path from the parents list of children, |
||
| 197 | -7x | +|||
| 363 | +
- nm <- obj_name(obj)+ ## because that is how lists behave. |
|||
| 198 | -7x | +|||
| 364 | +
- pos <- tree_pos(obj)+ #' @export |
|||
| 199 | -7x | +|||
| 365 | +
- nopos <- identical(pos, EmptyTreePos)+ #' @keywords internal |
|||
| 200 | +366 |
-
+ #' @rdname int_methods |
||
| 201 | -7x | +|||
| 367 | +
- msg <- paste0(strrep(" ", times = 2 * (level - 1)), "[", nm, "] (", if (nopos) "no pos" else lastposmsg(pos), ")\n")
+ setMethod( |
|||
| 202 | -7x | +|||
| 368 | +
- if (is(obj, "LayoutAxisTree")) {
+ "tt_at_path<-", c(tt = "VTableTree", value = "NULL"), |
|||
| 203 | -3x | +|||
| 369 | +
- kids <- tree_children(obj)+ function(tt, path, ..., value) {
|
|||
| 204 | -3x | +370 | +2x |
- msg <- c(msg, unlist(lapply(kids, layoutmsg2, level = level + 1)))+ do_recursive_replace(tt, path = path, value = value) |
| 205 | +371 |
} |
||
| 206 | -7x | +|||
| 372 | +
- msg+ ) |
|||
| 207 | +373 |
- }+ |
||
| 208 | +374 |
-
+ #' @export |
||
| 209 | -46x | +|||
| 375 | +
- setGeneric("spltype_abbrev", function(obj) standardGeneric("spltype_abbrev"))
+ #' @keywords internal |
|||
| 210 | +376 |
-
+ #' @rdname int_methods |
||
| 211 | +377 |
setMethod( |
||
| 212 | +378 |
- "spltype_abbrev", "VarLevelSplit",+ "tt_at_path<-", c(tt = "VTableTree", value = "TableRow"),+ |
+ ||
| 379 | ++ |
+ function(tt, path, ..., value) {
|
||
| 213 | -4x | +380 | +88x |
- function(obj) "lvls"+ stopifnot(is(tt_at_path(tt = tt, path = path), "TableRow"))+ |
+
| 381 | +88x | +
+ do_recursive_replace(tt, path = path, value = value) |
||
| 214 | +382 |
- )+ |
||
| 215 | +383 |
-
+ ## ##i <- .path_to_pos(path = path, seq_len(nrow(tt)), tt, NROW) |
||
| 216 | +384 |
- setMethod(+ ## i <- .path_to_pos(path = path, tt = tt) |
||
| 217 | +385 |
- "spltype_abbrev", "VarLevWBaselineSplit",+ |
||
| 218 | -5x | +|||
| 386 | +
- function(obj) paste("ref_group", obj@ref_group_value)
+ ## replace_rows(tt, i = i, value = list(value)) |
|||
| 219 | +387 | ++ |
+ }+ |
+ |
| 388 |
) |
|||
| 220 | +389 | |||
| 221 | +390 |
- setMethod(+ #' Retrieve and assign elements of a `TableTree` |
||
| 222 | +391 |
- "spltype_abbrev", "MultiVarSplit",+ #' |
||
| 223 | -! | +|||
| 392 | +
- function(obj) "vars"+ #' @param x (`TableTree`)\cr a `TableTree` object. |
|||
| 224 | +393 |
- )+ #' @param i (`numeric(1)`)\cr index. |
||
| 225 | +394 |
-
+ #' @param j (`numeric(1)`)\cr index. |
||
| 226 | +395 |
- setMethod(+ #' @param drop (`flag`)\cr whether the value in the cell should be returned if one cell is selected by the |
||
| 227 | +396 |
- "spltype_abbrev", "VarStaticCutSplit",+ #' combination of `i` and `j`. It is not possible to return a vector of values. To do so please consider using |
||
| 228 | -10x | +|||
| 397 | +
- function(obj) "scut"+ #' [cell_values()]. Defaults to `FALSE`. |
|||
| 229 | +398 |
- )+ #' @param ... additional arguments. Includes: |
||
| 230 | +399 |
-
+ #' \describe{
|
||
| 231 | +400 |
- setMethod(+ #' \item{`keep_topleft`}{(`flag`) (`[` only) whether the top-left material for the table should be retained after
|
||
| 232 | +401 |
- "spltype_abbrev", "VarDynCutSplit",+ #' subsetting. Defaults to `TRUE` if all rows are included (i.e. subsetting was by column), and drops it |
||
| 233 | -5x | +|||
| 402 | +
- function(obj) "dcut"+ #' otherwise.} |
|||
| 234 | +403 |
- )+ #' \item{`keep_titles`}{(`flag`) whether title information should be retained. Defaults to `FALSE`.}
|
||
| 235 | +404 |
- setMethod(+ #' \item{`keep_footers`}{(`flag`) whether non-referential footer information should be retained. Defaults to
|
||
| 236 | +405 |
- "spltype_abbrev", "AllSplit",+ #' `keep_titles`.} |
||
| 237 | -15x | +|||
| 406 | +
- function(obj) "all obs"+ #' \item{`reindex_refs`}{(`flag`) whether referential footnotes should be re-indexed as if the resulting subset is
|
|||
| 238 | +407 |
- )+ #' the entire table. Defaults to `TRUE`.} |
||
| 239 | +408 |
- ## setMethod("spltype_abbrev", "NULLSplit",
+ #' } |
||
| 240 | +409 |
- ## function(obj) "no obs")+ #' @param value (`list`, `TableRow`, or `TableTree`)\cr replacement value. |
||
| 241 | +410 |
-
+ #' |
||
| 242 | +411 |
- setMethod(+ #' @details |
||
| 243 | +412 |
- "spltype_abbrev", "AnalyzeVarSplit",+ #' By default, subsetting drops the information about title, subtitle, main footer, provenance footer, and `topleft`. |
||
| 244 | -1x | +|||
| 413 | +
- function(obj) "** analysis **"+ #' If only a column is selected and all rows are kept, the `topleft` information remains as default. Any referential |
|||
| 245 | +414 |
- )+ #' footnote is kept whenever the subset table contains the referenced element. |
||
| 246 | +415 |
-
+ #' |
||
| 247 | +416 |
- setMethod(+ #' @return A `TableTree` (or `ElementaryTable`) object, unless a single cell was selected with `drop = TRUE`, in which |
||
| 248 | +417 |
- "spltype_abbrev", "CompoundSplit",+ #' case the (possibly multi-valued) fully stripped raw value of the selected cell. |
||
| 249 | -! | +|||
| 418 | +
- function(obj) paste("compound", paste(sapply(spl_payload(obj), spltype_abbrev), collapse = " "))
+ #' |
|||
| 250 | +419 |
- )+ #' @note |
||
| 251 | +420 |
-
+ #' Subsetting always preserve the original order, even if provided indexes do not preserve it. If sorting is needed, |
||
| 252 | +421 |
- setMethod(+ #' please consider using `sort_at_path()`. Also note that `character` indices are treated as paths, not vectors of |
||
| 253 | +422 |
- "spltype_abbrev", "AnalyzeMultiVars",+ #' names in both `[` and `[<-`. |
||
| 254 | -6x | +|||
| 423 | +
- function(obj) "** multivar analysis **"+ #' |
|||
| 255 | +424 |
- )+ #' @seealso |
||
| 256 | +425 |
- setMethod(+ #' * [sort_at_path()] to understand sorting. |
||
| 257 | +426 |
- "spltype_abbrev", "AnalyzeColVarSplit",+ #' * [summarize_row_groups()] to understand path structure. |
||
| 258 | -! | +|||
| 427 | +
- function(obj) "** col-var analysis **"+ #' |
|||
| 259 | +428 |
- )+ #' @examples |
||
| 260 | +429 |
-
+ #' lyt <- basic_table( |
||
| 261 | +430 |
- docat_splitvec <- function(object, indent = 0) {
+ #' title = "Title", |
||
| 262 | -8x | +|||
| 431 | +
- if (indent > 0) {
+ #' subtitles = c("Sub", "titles"),
|
|||
| 263 | -! | +|||
| 432 | +
- cat(rep(" ", times = indent), sep = "")
+ #' prov_footer = "prov footer", |
|||
| 264 | +433 |
- }+ #' main_footer = "main footer" |
||
| 265 | -8x | +|||
| 434 | +
- if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) {
+ #' ) %>% |
|||
| 266 | -! | +|||
| 435 | +
- tab <- object[[1]]+ #' split_cols_by("ARM") %>%
|
|||
| 267 | -! | +|||
| 436 | +
- msg <- sprintf(+ #' split_rows_by("SEX") %>%
|
|||
| 268 | -! | +|||
| 437 | +
- "A Pre-Existing Table [%d x %d]",+ #' analyze(c("AGE"))
|
|||
| 269 | -! | +|||
| 438 | +
- nrow(tab), ncol(tab)+ #' |
|||
| 270 | +439 |
- )+ #' tbl <- build_table(lyt, DM) |
||
| 271 | +440 |
- } else {
+ #' top_left(tbl) <- "Info" |
||
| 272 | -8x | +|||
| 441 | +
- plds <- ploads_to_str(object) ## lapply(object, spl_payload))+ #' tbl |
|||
| 273 | +442 |
-
+ #' |
||
| 274 | -8x | +|||
| 443 | +
- tabbrev <- sapply(object, spltype_abbrev)+ #' # As default header, footer, and topleft information is lost |
|||
| 275 | -8x | +|||
| 444 | +
- msg <- paste(+ #' tbl[1, ] |
|||
| 276 | -8x | +|||
| 445 | +
- collapse = " -> ",+ #' tbl[1:2, 2] |
|||
| 277 | -8x | +|||
| 446 | +
- paste0(plds, " (", tabbrev, ")")
+ #' |
|||
| 278 | +447 |
- )+ #' # Also boolean filters can work |
||
| 279 | +448 |
- }+ #' tbl[, c(FALSE, TRUE, FALSE)] |
||
| 280 | -8x | +|||
| 449 | +
- cat(msg, "\n")+ #' |
|||
| 281 | +450 |
- }+ #' # If drop = TRUE, the content values are directly retrieved |
||
| 282 | +451 |
-
+ #' tbl[2, 1] |
||
| 283 | +452 |
- setMethod(+ #' tbl[2, 1, drop = TRUE] |
||
| 284 | +453 |
- "show", "SplitVector",+ #' |
||
| 285 | +454 |
- function(object) {
+ #' # Drop works also if vectors are selected, but not matrices |
||
| 286 | -1x | +|||
| 455 | +
- cat("A SplitVector Pre-defining a Tree Structure\n\n")
+ #' tbl[, 1, drop = TRUE] |
|||
| 287 | -1x | +|||
| 456 | +
- docat_splitvec(object)+ #' tbl[2, , drop = TRUE] |
|||
| 288 | -1x | +|||
| 457 | +
- cat("\n")
+ #' tbl[1, 1, drop = TRUE] # NULL because it is a label row |
|||
| 289 | -1x | +|||
| 458 | +
- invisible(object)+ #' tbl[2, 1:2, drop = TRUE] # vectors can be returned only with cell_values() |
|||
| 290 | +459 |
- }+ #' tbl[1:2, 1:2, drop = TRUE] # no dropping because it is a matrix |
||
| 291 | +460 |
- )+ #' |
||
| 292 | +461 |
-
+ #' # If all rows are selected, topleft is kept by default |
||
| 293 | +462 |
- docat_predataxis <- function(object, indent = 0) {
+ #' tbl[, 2] |
||
| 294 | -6x | +|||
| 463 | +
- lapply(object, docat_splitvec)+ #' tbl[, 1] |
|||
| 295 | +464 |
- }+ #' |
||
| 296 | +465 |
-
+ #' # It is possible to deselect values |
||
| 297 | +466 |
- setMethod(+ #' tbl[-2, ] |
||
| 298 | +467 |
- "show", "PreDataColLayout",+ #' tbl[, -1] |
||
| 299 | +468 |
- function(object) {
+ #' |
||
| 300 | -1x | +|||
| 469 | +
- cat("A Pre-data Column Layout Object\n\n")
+ #' # Values can be reassigned |
|||
| 301 | -1x | +|||
| 470 | +
- docat_predataxis(object)+ #' tbl[2, 1] <- rcell(999) |
|||
| 302 | -1x | +|||
| 471 | +
- invisible(object)+ #' tbl[2, ] <- list(rrow("FFF", 888, 666, 777))
|
|||
| 303 | +472 |
- }+ #' tbl[6, ] <- list(-111, -222, -333) |
||
| 304 | +473 |
- )+ #' tbl |
||
| 305 | +474 |
-
+ #' |
||
| 306 | +475 |
- setMethod(+ #' # We can keep some information from the original table if we need |
||
| 307 | +476 |
- "show", "PreDataRowLayout",+ #' tbl[1, 2, keep_titles = TRUE] |
||
| 308 | +477 |
- function(object) {
+ #' tbl[1, 2, keep_footers = TRUE, keep_titles = FALSE] |
||
| 309 | -1x | +|||
| 478 | +
- cat("A Pre-data Row Layout Object\n\n")
+ #' tbl[1, 2, keep_footers = FALSE, keep_titles = TRUE] |
|||
| 310 | -1x | +|||
| 479 | +
- docat_predataxis(object)+ #' tbl[1, 2, keep_footers = TRUE] |
|||
| 311 | -1x | +|||
| 480 | +
- invisible(object)+ #' tbl[1, 2, keep_topleft = TRUE] |
|||
| 312 | +481 |
- }+ #' |
||
| 313 | +482 |
- )+ #' # Keeps the referential footnotes when subset contains them |
||
| 314 | +483 |
-
+ #' fnotes_at_path(tbl, rowpath = c("SEX", "M", "AGE", "Mean")) <- "important"
|
||
| 315 | +484 |
- setMethod(+ #' tbl[4, 1] |
||
| 316 | +485 |
- "show", "PreDataTableLayouts",+ #' tbl[2, 1] # None present |
||
| 317 | +486 |
- function(object) {
+ #' |
||
| 318 | -2x | +|||
| 487 | +
- cat("A Pre-data Table Layout\n")
+ #' # We can reindex referential footnotes, so that the new table does not depend |
|||
| 319 | -2x | +|||
| 488 | +
- cat("\nColumn-Split Structure:\n")
+ #' # on the original one |
|||
| 320 | -2x | +|||
| 489 | +
- docat_predataxis(object@col_layout)+ #' fnotes_at_path(tbl, rowpath = c("SEX", "U", "AGE", "Mean")) <- "important"
|
|||
| 321 | -2x | +|||
| 490 | +
- cat("\nRow-Split Structure:\n")
+ #' tbl[, 1] # both present |
|||
| 322 | -2x | +|||
| 491 | +
- docat_predataxis(object@row_layout)+ #' tbl[5:6, 1] # {1} because it has been indexed again
|
|||
| 323 | -2x | +|||
| 492 | +
- cat("\n")
+ #' tbl[5:6, 1, reindex_refs = FALSE] # {2} -> not reindexed
|
|||
| 324 | -2x | +|||
| 493 | +
- invisible(object)+ #' |
|||
| 325 | +494 |
- }+ #' # Note that order can not be changed with subsetting |
||
| 326 | +495 |
- )+ #' tbl[c(4, 3, 1), c(3, 1)] # It preserves order and wanted selection |
||
| 327 | +496 |
-
+ #' |
||
| 328 | +497 |
- setMethod(+ #' @name brackets |
||
| 329 | +498 |
- "show", "InstantiatedColumnInfo",+ NULL |
||
| 330 | +499 |
- function(object) {
+
|
||
| 331 | -2x | +|||
| 500 | +
- layoutmsg <- layoutmsg(coltree(object))+ #' @exportMethod [<- |
|||
| 332 | -2x | +|||
| 501 | +
- cat("An InstantiatedColumnInfo object",
+ #' @rdname brackets |
|||
| 333 | -2x | +|||
| 502 | +
- "Columns:",+ setMethod( |
|||
| 334 | -2x | +|||
| 503 | +
- layoutmsg,+ "[<-", c("VTableTree", value = "list"),
|
|||
| 335 | -2x | +|||
| 504 | +
- if (disp_ccounts(object)) {
+ function(x, i, j, ..., value) {
|
|||
| 336 | -2x | +505 | +3x |
- paste(+ nr <- nrow(x) |
| 337 | -2x | +506 | +3x |
- "ColumnCounts:\n",+ if (missing(i)) {
|
| 338 | -2x | +|||
| 507 | +! |
- paste(col_counts(object),+ i <- seq_len(NROW(x)) |
||
| 339 | -2x | +508 | +3x |
- collapse = ", "+ } else if (is(i, "character")) {
|
| 340 | -+ | |||
| 509 | +! |
- )+ i <- .path_to_pos(i, x) |
||
| 341 | +510 |
- )+ } else {
+ |
+ ||
| 511 | +3x | +
+ i <- .j_to_posj(i, nr) |
||
| 342 | +512 |
- },+ } |
||
| 343 | +513 |
- "",+ |
||
| 344 | -2x | +514 | +3x |
- sep = "\n"+ if (missing(j)) {
|
| 345 | -+ | |||
| 515 | +1x |
- )+ j <- seq_along(col_exprs(col_info(x))) |
||
| 346 | +516 | 2x |
- invisible(object)+ } else if (is(j, "character")) {
+ |
+ |
| 517 | +! | +
+ j <- .path_to_pos(j, x, cols = TRUE) |
||
| 347 | +518 |
- }+ } else {
+ |
+ ||
| 519 | +2x | +
+ j <- .j_to_posj(j, ncol(x)) |
||
| 348 | +520 |
- )+ } |
||
| 349 | +521 | |||
| 522 | +3x | +
+ if (length(i) > 1 && length(j) < ncol(x)) {
+ |
+ ||
| 523 | +! | +
+ stop("cannot modify multiple rows in not all columns.")
+ |
+ ||
| 350 | +524 |
- #' @rdname int_methods+ } |
||
| 351 | +525 |
- setMethod("print", "VTableTree", function(x, ...) {
+
|
||
| 352 | -5x | +526 | +3x |
- msg <- toString(x, ...)+ if (are(value, "TableRow")) {
|
| 353 | -4x | +527 | +1x |
- cat(msg)+ value <- rep(value, length.out = length(i))+ |
+
| 528 | ++ |
+ } else {
|
||
| 354 | -4x | +529 | +2x |
- invisible(x)+ value <- rep(value, length.out = length(i) * length(j)) |
| 355 | +530 |
- })+ } |
||
| 356 | +531 | |||
| 357 | -+ | |||
| 532 | +3x |
- #' @rdname int_methods+ counter <- 0 |
||
| 358 | +533 |
- setMethod("show", "VTableTree", function(object) {
+ ## this has access to value, i, and j by scoping |
||
| 359 | -! | +|||
| 534 | +3x |
- cat(toString(object))+ replace_rowsbynum <- function(x, i, valifnone = NULL) {
+ |
+ ||
| 535 | +16x | +
+ maxi <- max(i)+ |
+ ||
| 536 | +16x | +
+ if (counter >= maxi) {
|
||
| 360 | +537 | ! |
- invisible(object)+ return(valifnone) |
|
| 361 | +538 |
- })+ } |
||
| 362 | +539 | |||
| 363 | -+ | |||
| 540 | +16x |
- setMethod("show", "TableRow", function(object) {
+ if (labelrow_visible(x)) {
|
||
| 364 | -1x | +541 | +3x |
- cat(sprintf(+ counter <<- counter + 1 |
| 365 | -1x | +542 | +3x |
- "[%s indent_mod %d]: %s %s\n",+ if (counter %in% i) {
|
| 366 | +543 | 1x |
- class(object),+ nxtval <- value[[1]] |
|
| 367 | +544 | 1x |
- indent_mod(object),- |
- |
| 368 | -1x | -
- obj_label(object),- |
- ||
| 369 | -1x | -
- paste(as.vector(get_formatted_cells(object)),+ if (is(nxtval, "LabelRow")) {
|
||
| 370 | +545 | 1x |
- collapse = " "+ tt_labelrow(x) <- nxtval |
|
| 371 | +546 |
- )+ } else {
|
||
| 372 | -+ | |||
| 547 | +! |
- ))+ stop( |
||
| 373 | -1x | +|||
| 548 | +! |
- invisible(object)+ "can't replace label with value of class", |
||
| 374 | -+ | |||
| 549 | +! |
- })+ class(nxtval) |
| 1 | +550 |
- #' Variable associated with a split+ ) |
||
| 2 | +551 |
- #'+ } |
||
| 3 | +552 |
- #' This function is intended for use when writing custom splitting logic. In cases where the split is associated with+ ## we're done with this one move to |
||
| 4 | +553 |
- #' a single variable, the name of that variable will be returned. At time of writing this includes splits generated+ ## the next |
||
| 5 | -+ | |||
| 554 | +1x |
- #' via the [split_rows_by()], [split_cols_by()], [split_rows_by_cuts()], [split_cols_by_cuts()],+ value <<- value[-1] |
||
| 6 | +555 |
- #' [split_rows_by_cutfun()], and [split_cols_by_cutfun()] layout directives.+ } |
||
| 7 | +556 |
- #'+ } |
||
| 8 | -+ | |||
| 557 | +16x |
- #' @param spl (`VarLevelSplit`)\cr the split object.+ if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
|
||
| 9 | -+ | |||
| 558 | +3x |
- #'+ ctab <- content_table(x) |
||
| 10 | +559 |
- #' @return For splits with a single variable associated with them, returns the split. Otherwise, an error is raised.+ |
||
| 11 | -+ | |||
| 560 | +3x |
- #'+ content_table(x) <- replace_rowsbynum(ctab, i) |
||
| 12 | +561 |
- #' @export+ } |
||
| 13 | -+ | |||
| 562 | +16x |
- #' @seealso \code{\link{make_split_fun}}
+ if (counter >= maxi) { # already done
|
||
| 14 | +563 | 2x |
- setGeneric("spl_variable", function(spl) standardGeneric("spl_variable"))
- |
- |
| 15 | -- | - - | -||
| 16 | -- |
- #' @rdname spl_variable+ return(x) |
||
| 17 | +564 |
- #' @export+ } |
||
| 18 | -1x | +565 | +14x |
- setMethod("spl_variable", "VarLevelSplit", function(spl) spl_payload(spl))
+ kids <- tree_children(x) |
| 19 | +566 | |||
| 20 | -+ | |||
| 567 | +14x |
- #' @rdname spl_variable+ if (length(kids) > 0) {
|
||
| 21 | -+ | |||
| 568 | +14x |
- #' @export+ for (pos in seq_along(kids)) {
|
||
| 22 | -! | +|||
| 569 | +17x |
- setMethod("spl_variable", "VarDynCutSplit", function(spl) spl_payload(spl))
+ curkid <- kids[[pos]] |
||
| 23 | -+ | |||
| 570 | +17x |
-
+ if (is(curkid, "TableRow")) {
|
||
| 24 | -+ | |||
| 571 | +7x |
- #' @rdname spl_variable+ counter <<- counter + 1 |
||
| 25 | -+ | |||
| 572 | +7x |
- #' @export+ if (counter %in% i) {
|
||
| 26 | -! | +|||
| 573 | +3x |
- setMethod("spl_variable", "VarStaticCutSplit", function(spl) spl_payload(spl))
+ nxtval <- value[[1]] |
||
| 27 | -+ | |||
| 574 | +3x |
-
+ if (is(nxtval, class(curkid))) {
|
||
| 28 | -+ | |||
| 575 | +1x |
- #' @rdname spl_variable+ if (no_colinfo(nxtval) && length(row_values(nxtval)) == ncol(x)) {
|
||
| 29 | -+ | |||
| 576 | +1x |
- #' @export+ col_info(nxtval) <- col_info(x) |
||
| 30 | +577 |
- setMethod(+ } |
||
| 31 | -+ | |||
| 578 | +1x |
- "spl_variable", "Split",+ stopifnot(identical(col_info(x), col_info(nxtval))) |
||
| 32 | +579 | 1x |
- function(spl) stop("Split class ", class(spl), " not associated with a single variable.")
+ curkid <- nxtval |
|
| 33 | -+ | |||
| 580 | +1x |
- )+ value <- value[-1] |
||
| 34 | +581 |
-
+ } else {
|
||
| 35 | -+ | |||
| 582 | +2x |
- in_col_split <- function(spl_ctx) {
+ rvs <- row_values(curkid) |
||
| 36 | -! | +|||
| 583 | +2x |
- identical(+ rvs[j] <- value[seq_along(j)] |
||
| 37 | -! | +|||
| 584 | +2x |
- names(spl_ctx),+ row_values(curkid) <- rvs |
||
| 38 | -! | +|||
| 585 | +2x |
- names(context_df_row(cinfo = NULL))+ value <- value[-(seq_along(j))] |
||
| 39 | +586 |
- )+ } |
||
| 40 | -+ | |||
| 587 | +3x |
- }+ kids[[pos]] <- curkid |
||
| 41 | +588 |
-
+ } |
||
| 42 | +589 |
- assert_splres_element <- function(pinfo, nm, len = NULL, component = NULL) {
- |
- ||
| 43 | -45x | -
- msg_2_append <- ""+ } else {
|
||
| 44 | -45x | +590 | +10x |
- if (!is.null(component)) {
+ kids[[pos]] <- replace_rowsbynum(curkid, i) |
| 45 | -33x | +|||
| 591 | +
- msg_2_append <- paste0(+ } |
|||
| 46 | -33x | +592 | +17x |
- "Invalid split function constructed by upstream call to ",+ if (counter >= maxi) {
|
| 47 | -33x | +593 | +7x |
- "make_split_fun. Problem source: ",+ break |
| 48 | -33x | +|||
| 594 | +
- component, " argument."+ } |
|||
| 49 | +595 |
- )+ } |
||
| 50 | +596 |
- }+ } |
||
| 51 | -45x | +597 | +14x |
- if (!(nm %in% names(pinfo))) {
+ tree_children(x) <- kids |
| 52 | -! | +|||
| 598 | +14x |
- stop(+ x |
||
| 53 | -! | +|||
| 599 | +
- "Split result does not have required element: ", nm, ".",+ } |
|||
| 54 | -! | +|||
| 600 | +3x |
- msg_2_append+ replace_rowsbynum(x, i, ...) |
||
| 55 | +601 |
- )+ } |
||
| 56 | +602 |
- }- |
- ||
| 57 | -45x | -
- if (!is.null(len) && length(pinfo[[nm]]) != len) {
+ ) |
||
| 58 | -! | +|||
| 603 | +
- stop(+ |
|||
| 59 | -! | +|||
| 604 | +
- "Split result element ", nm, " does not have required length ", len, ".",+ #' @inheritParams brackets |
|||
| 60 | -! | +|||
| 605 | +
- msg_2_append+ #' |
|||
| 61 | +606 |
- )+ #' @exportMethod [<- |
||
| 62 | +607 |
- }+ #' @rdname int_methods |
||
| 63 | -45x | +|||
| 608 | +
- TRUE+ #' @keywords internal |
|||
| 64 | +609 |
- }+ setMethod( |
||
| 65 | +610 |
-
+ "[<-", c("VTableTree", value = "CellValue"),
|
||
| 66 | +611 |
- validate_split_result <- function(pinfo, component = NULL) {
+ function(x, i, j, ..., value) {
|
||
| 67 | -15x | +612 | +1x |
- assert_splres_element(pinfo, "datasplit", component = component)+ x[i = i, j = j, ...] <- list(value) |
| 68 | -15x | +613 | +1x |
- len <- length(pinfo$datasplit)+ x |
| 69 | -15x | +|||
| 614 | +
- assert_splres_element(pinfo, "values", len, component = component)+ } |
|||
| 70 | -15x | +|||
| 615 | +
- assert_splres_element(pinfo, "labels", len, component = component)+ ) |
|||
| 71 | -15x | +|||
| 616 | +
- TRUE+ |
|||
| 72 | +617 |
- }+ ## this is going to be hard :( :( :( |
||
| 73 | +618 | |||
| 74 | +619 |
- #' Construct split result object+ ### selecting/removing columns |
||
| 75 | +620 |
- #'+ |
||
| 76 | +621 |
- #' These functions can be used to create or add to a split result in functions which implement core splitting or+ ## we have two options here: path like we do with rows and positional |
||
| 77 | +622 |
- #' post-processing within a custom split function.+ ## in leaf space. |
||
| 78 | +623 |
- #'+ |
||
| 79 | +624 |
- #' @param values (`character` or `list(SplitValue)`)\cr the values associated with each facet.+ setGeneric( |
||
| 80 | +625 |
- #' @param datasplit (`list(data.frame)`)\cr the facet data for each facet generated in the split.+ "subset_cols", |
||
| 81 | +626 |
- #' @param labels (`character`)\cr the labels associated with each facet.+ function(tt, |
||
| 82 | +627 |
- #' @param extras (`list` or `NULL`)\cr extra values associated with each of the facets which will be passed to+ j, |
||
| 83 | +628 |
- #' analysis functions applied within the facet.+ newcinfo = NULL, |
||
| 84 | +629 |
- #' @param subset_exprs (`list`)\cr A list of subsetting expressions (e.g.,+ keep_topleft = TRUE, |
||
| 85 | +630 |
- #' created with `quote()`) to be used during column subsetting.+ keep_titles = TRUE, |
||
| 86 | +631 |
- #'+ keep_footers = keep_titles, |
||
| 87 | +632 |
- #' @return A named list representing the facets generated by the split with elements `values`, `datasplit`, and+ ...) {
|
||
| 88 | -+ | |||
| 633 | +9970x |
- #' `labels`, which are the same length and correspond to each other element-wise.+ standardGeneric("subset_cols")
|
||
| 89 | +634 |
- #'+ } |
||
| 90 | +635 |
- #' @details+ ) |
||
| 91 | +636 |
- #' These functions performs various housekeeping tasks to ensure that the split result list is as the rtables+ |
||
| 92 | +637 |
- #' internals expect it, most of which are not relevant to end users.+ setMethod( |
||
| 93 | +638 |
- #'+ "subset_cols", c("TableTree", "numeric"),
|
||
| 94 | +639 |
- #' @examples+ function(tt, j, newcinfo = NULL, |
||
| 95 | +640 |
- #' splres <- make_split_result(+ keep_topleft, keep_titles, keep_footers, ...) {
|
||
| 96 | -+ | |||
| 641 | +867x |
- #' values = c("hi", "lo"),
+ j <- .j_to_posj(j, ncol(tt)) |
||
| 97 | -+ | |||
| 642 | +867x |
- #' datasplit = list(hi = mtcars, lo = mtcars[1:10, ]),+ if (is.null(newcinfo)) {
|
||
| 98 | -+ | |||
| 643 | +161x |
- #' labels = c("more data", "less data"),
+ cinfo <- col_info(tt) |
||
| 99 | -+ | |||
| 644 | +161x |
- #' subset_exprs = list(expression(TRUE), expression(seq_along(wt) <= 10))+ newcinfo <- subset_cols(cinfo, j, |
||
| 100 | -+ | |||
| 645 | +161x |
- #' )+ keep_topleft = keep_topleft, ... |
||
| 101 | +646 |
- #'+ ) |
||
| 102 | +647 |
- #' splres2 <- add_to_split_result(splres,+ } |
||
| 103 | +648 |
- #' values = "med",+ ## topleft taken care of in creation of newcinfo |
||
| 104 | -+ | |||
| 649 | +867x |
- #' datasplit = list(med = mtcars[1:20, ]),+ kids <- tree_children(tt) |
||
| 105 | -+ | |||
| 650 | +867x |
- #' labels = "kinda some data",+ newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...) |
||
| 106 | -+ | |||
| 651 | +867x |
- #' subset_exprs = quote(seq_along(wt) <= 20)+ cont <- content_table(tt) |
||
| 107 | -+ | |||
| 652 | +867x |
- #' )+ newcont <- subset_cols(cont, j, newcinfo = newcinfo, ...) |
||
| 108 | -+ | |||
| 653 | +867x |
- #'+ tt2 <- tt |
||
| 109 | -+ | |||
| 654 | +867x |
- #' @family make_custom_split+ col_info(tt2) <- newcinfo |
||
| 110 | -+ | |||
| 655 | +867x |
- #' @rdname make_split_result+ content_table(tt2) <- newcont |
||
| 111 | -+ | |||
| 656 | +867x |
- #' @export+ tree_children(tt2) <- newkids |
||
| 112 | -+ | |||
| 657 | +867x |
- #' @family make_custom_split+ tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...) |
||
| 113 | +658 |
- make_split_result <- function(values, datasplit, labels, extras = NULL, subset_exprs = vector("list", length(values))) {
+
|
||
| 114 | -9x | -
- if (length(values) == 1 && is(datasplit, "data.frame")) {
- |
- ||
| 115 | -! | +659 | +867x |
- datasplit <- list(datasplit)+ tt2 <- .h_copy_titles_footers_topleft( |
| 116 | -+ | |||
| 660 | +867x |
- }+ tt2, tt, |
||
| 117 | -9x | +661 | +867x |
- ret <- list(values = values, datasplit = datasplit, labels = labels, subset_exprs = subset_exprs)+ keep_titles, |
| 118 | -9x | +662 | +867x |
- if (!is.null(extras)) {
+ keep_footers, |
| 119 | -! | +|||
| 663 | +867x |
- ret$extras <- extras+ keep_topleft |
||
| 120 | +664 |
- }+ ) |
||
| 121 | -9x | +665 | +867x |
- .fixupvals(ret)+ tt2 |
| 122 | +666 |
- }+ } |
||
| 123 | +667 |
-
+ ) |
||
| 124 | +668 |
- #' @param splres (`list`)\cr a list representing the result of splitting.+ |
||
| 125 | +669 |
- #'+ setMethod( |
||
| 126 | +670 |
- #' @rdname make_split_result+ "subset_cols", c("ElementaryTable", "numeric"),
|
||
| 127 | +671 |
- #' @export+ function(tt, j, newcinfo = NULL, |
||
| 128 | +672 |
- add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL, subset_exprs = NULL) {
+ keep_topleft, keep_titles, keep_footers, ...) {
|
||
| 129 | -4x | +673 | +1829x |
- validate_split_result(splres)+ j <- .j_to_posj(j, ncol(tt)) |
| 130 | -4x | +674 | +1829x |
- newstuff <- make_split_result(values, datasplit, labels, extras, subset_exprs = list(subset_exprs))+ if (is.null(newcinfo)) {
|
| 131 | -4x | +675 | +97x |
- ret <- lapply(+ cinfo <- col_info(tt) |
| 132 | -4x | +676 | +97x |
- names(splres),+ newcinfo <- subset_cols(cinfo, j, |
| 133 | -4x | -
- function(nm) c(splres[[nm]], newstuff[[nm]])- |
- ||
| 134 | -+ | 677 | +97x |
- )+ keep_topleft = keep_topleft, |
| 135 | -4x | +678 | +97x |
- names(ret) <- names(splres)+ keep_titles = keep_titles, |
| 136 | -4x | +679 | +97x |
- .fixupvals(ret)+ keep_footers = keep_footers, ... |
| 137 | +680 |
- }+ ) |
||
| 138 | +681 |
-
+ } |
||
| 139 | +682 |
-
+ ## topleft handled in creation of newcinfo |
||
| 140 | -13x | +683 | +1829x |
- .can_take_spl_context <- function(f) any(c(".spl_context", "...") %in% names(formals(f)))
+ kids <- tree_children(tt) |
| 141 | -+ | |||
| 684 | +1829x |
-
+ newkids <- lapply(kids, subset_cols, j = j, newcinfo = newcinfo, ...) |
||
| 142 | -+ | |||
| 685 | +1829x |
- #' Create a custom splitting function+ tt2 <- tt |
||
| 143 | -+ | |||
| 686 | +1829x |
- #'+ col_info(tt2) <- newcinfo |
||
| 144 | -+ | |||
| 687 | +1829x |
- #' @param pre (`list`)\cr zero or more functions which operate on the incoming data and return a new data frame that+ tree_children(tt2) <- newkids |
||
| 145 | -+ | |||
| 688 | +1829x |
- #' should split via `core_split`. They will be called on the data in the order they appear in the list.+ tt_labelrow(tt2) <- subset_cols(tt_labelrow(tt2), j, newcinfo, ...) |
||
| 146 | -+ | |||
| 689 | +1829x |
- #' @param core_split (`function` or `NULL`)\cr if non-`NULL`, a function which accepts the same arguments that+ tt2 <- .h_copy_titles_footers_topleft( |
||
| 147 | -+ | |||
| 690 | +1829x |
- #' `do_base_split` does, and returns the same type of named list. Custom functions which override this behavior+ tt2, tt, |
||
| 148 | -+ | |||
| 691 | +1829x |
- #' cannot be used in column splits.+ keep_titles, |
||
| 149 | -+ | |||
| 692 | +1829x |
- #' @param post (`list`)\cr zero or more functions which should be called on the list output by splitting.+ keep_footers, |
||
| 150 | -+ | |||
| 693 | +1829x |
- #'+ keep_topleft |
||
| 151 | +694 |
- #' @details+ ) |
||
| 152 | -+ | |||
| 695 | +1829x |
- #' Custom split functions can be thought of as (up to) 3 different types of manipulations of the splitting process:+ tt2 |
||
| 153 | +696 |
- #'+ } |
||
| 154 | +697 |
- #' 1. Pre-processing of the incoming data to be split.+ ) |
||
| 155 | +698 |
- #' 2. (Row-splitting only) Customization of the core mapping of incoming data to facets.+ |
||
| 156 | +699 |
- #' 3. Post-processing operations on the set of facets (groups) generated by the split.+ ## small utility to transform any negative |
||
| 157 | +700 |
- #'+ ## indices into positive ones, given j |
||
| 158 | +701 |
- #' This function provides an interface to create custom split functions by implementing and specifying sets of+ ## and total length |
||
| 159 | +702 |
- #' operations in each of those classes of customization independently.+ |
||
| 160 | +703 |
- #'+ .j_to_posj <- function(j, n) {
|
||
| 161 | +704 |
- #' Pre-processing functions (1), must accept: `df`, `spl`, `vals`, and `labels`, and can optionally accept+ ## This will work for logicals, numerics, integers |
||
| 162 | -+ | |||
| 705 | +15040x |
- #' `.spl_context`. They then manipulate `df` (the incoming data for the split) and return a modified data frame.+ j <- seq_len(n)[j] |
||
| 163 | -+ | |||
| 706 | +15040x |
- #' This modified data frame *must* contain all columns present in the incoming data frame, but can add columns if+ j |
||
| 164 | +707 |
- #' necessary (though we note that these new columns cannot be used in the layout as split or analysis variables,+ } |
||
| 165 | +708 |
- #' because they will not be present when validity checking is done).+ |
||
| 166 | +709 |
- #'+ path_collapse_sep <- "`" |
||
| 167 | +710 |
- #' The preprocessing component is useful for things such as manipulating factor levels, e.g., to trim unobserved ones+ escape_name_padding <- function(x) {
|
||
| 168 | -+ | |||
| 711 | +141x |
- #' or to reorder levels based on observed counts, etc.+ ret <- gsub("._[[", "\\._\\[\\[", x, fixed = TRUE)
|
||
| 169 | -+ | |||
| 712 | +141x |
- #'+ ret <- gsub("]]_.", "\\]\\]_\\.", ret, fixed = TRUE)
|
||
| 170 | -+ | |||
| 713 | +141x |
- #' Core splitting functions override the fundamental+ ret |
||
| 171 | +714 |
- #' splitting procedure, and are only necessary in rare cases. These+ } |
||
| 172 | +715 |
- #' must accept `spl`, `df`, `vals`, `labels`, and can optionally+ path_to_regex <- function(path) {
|
||
| 173 | -+ | |||
| 716 | +51x |
- #' accept `.spl_context`. They should return a split result object+ paste(vapply(path, function(x) {
|
||
| 174 | -+ | |||
| 717 | +142x |
- #' constructed via `make_split_result()`.+ if (identical(x, "*")) {
|
||
| 175 | -+ | |||
| 718 | +1x |
- #'+ paste0("[^", path_collapse_sep, "]+")
|
||
| 176 | +719 |
- #' In particular, if the custom split function will be used in+ } else {
|
||
| 177 | -+ | |||
| 720 | +141x |
- #' column space, subsetting expressions (e.g., as returned by+ escape_name_padding(x) |
||
| 178 | +721 |
- #' `quote()` or `bquote` must be provided, while they are+ } |
||
| 179 | -+ | |||
| 722 | +51x |
- #' optional (and largely ignored, currently) in row space.+ }, ""), collapse = path_collapse_sep) |
||
| 180 | +723 |
- #'+ } |
||
| 181 | +724 |
- #'+ |
||
| 182 | +725 |
- #' Post-processing functions (3) must accept the result of the core split as their first argument (which can be+ .path_to_pos <- function(path, tt, distinct_ok = TRUE, cols = FALSE) {
|
||
| 183 | -+ | |||
| 726 | +51x |
- #' anything), in addition to `spl`, and `fulldf`, and can optionally accept `.spl_context`. They must each return a+ path <- path[!grepl("^(|root)$", path)]
|
||
| 184 | -+ | |||
| 727 | +51x |
- #' modified version of the same structure specified above for core splitting.+ if (cols) {
|
||
| 185 | -+ | |||
| 728 | +51x |
- #'+ rowdf <- make_col_df(tt) |
||
| 186 | +729 |
- #' In both the pre- and post-processing cases, multiple functions can be specified. When this happens, they are applied+ } else {
|
||
| 187 | -+ | |||
| 730 | +! |
- #' sequentially, in the order they appear in the list passed to the relevant argument (`pre` and `post`, respectively).+ rowdf <- make_row_df(tt) |
||
| 188 | +731 |
- #'+ } |
||
| 189 | -+ | |||
| 732 | +51x |
- #' @return A custom function that can be used as a split function.+ if (length(path) == 0 || identical(path, "*") || identical(path, "root")) {
|
||
| 190 | -+ | |||
| 733 | +! |
- #'+ return(seq(1, nrow(rowdf))) |
||
| 191 | +734 |
- #' @seealso [custom_split_funs] for a more detailed discussion on what custom split functions do.+ } |
||
| 192 | +735 |
- #'+ |
||
| 193 | -+ | |||
| 736 | +51x |
- #' @examples+ paths <- rowdf$path |
||
| 194 | -+ | |||
| 737 | +51x |
- #' mysplitfun <- make_split_fun(+ pathregex <- path_to_regex(path) |
||
| 195 | -+ | |||
| 738 | +51x |
- #' pre = list(drop_facet_levels),+ pathstrs <- vapply(paths, paste, "", collapse = path_collapse_sep) |
||
| 196 | -+ | |||
| 739 | +51x |
- #' post = list(add_overall_facet("ALL", "All Arms"))
+ allmatchs <- grep(pathregex, pathstrs) |
||
| 197 | -+ | |||
| 740 | +51x |
- #' )+ if (length(allmatchs) == 0) {
|
||
| 198 | -+ | |||
| 741 | +! |
- #'+ stop( |
||
| 199 | -+ | |||
| 742 | +! |
- #' basic_table(show_colcounts = TRUE) %>%+ if (cols) "column path [" else "row path [", |
||
| 200 | -+ | |||
| 743 | +! |
- #' split_cols_by("ARM", split_fun = mysplitfun) %>%
+ paste(path, collapse = "->"), |
||
| 201 | -+ | |||
| 744 | +! |
- #' analyze("AGE") %>%
+ "] does not appear valid for this table" |
||
| 202 | +745 |
- #' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
+ ) |
||
| 203 | +746 |
- #'+ } |
||
| 204 | +747 |
- #' ## post (and pre) arguments can take multiple functions, here+ |
||
| 205 | -+ | |||
| 748 | +51x |
- #' ## we add an overall facet and the reorder the facets+ idxdiffs <- diff(allmatchs) |
||
| 206 | -+ | |||
| 749 | +51x |
- #' reorder_facets <- function(splret, spl, fulldf, ...) {
+ if (!distinct_ok && length(idxdiffs) > 0 && any(idxdiffs > 1)) {
|
||
| 207 | -+ | |||
| 750 | +! |
- #' ord <- order(names(splret$values))+ firstnon <- min(which(idxdiffs > 1)) |
||
| 208 | +751 |
- #' make_split_result(+ ## its firstnon here because we would want firstnon-1 but |
||
| 209 | +752 |
- #' splret$values[ord],+ ## the diffs are actually shifted 1 so they cancel out |
||
| 210 | -+ | |||
| 753 | +! |
- #' splret$datasplit[ord],+ allmatchs <- allmatchs[seq(1, firstnon)] |
||
| 211 | +754 |
- #' splret$labels[ord]+ } |
||
| 212 | -+ | |||
| 755 | +51x |
- #' )+ allmatchs |
||
| 213 | +756 |
- #' }+ } |
||
| 214 | +757 |
- #'+ |
||
| 215 | +758 |
- #' mysplitfun2 <- make_split_fun(+ ## fix column spans that would be invalid |
||
| 216 | +759 |
- #' pre = list(drop_facet_levels),+ ## after some columns are no longer there |
||
| 217 | +760 |
- #' post = list(+ .fix_rowcspans <- function(rw, j) {
|
||
| 218 | -+ | |||
| 761 | +3974x |
- #' add_overall_facet("ALL", "All Arms"),
+ cspans <- row_cspans(rw) |
||
| 219 | -+ | |||
| 762 | +3974x |
- #' reorder_facets+ nc <- sum(cspans) |
||
| 220 | -+ | |||
| 763 | +3974x |
- #' )+ j <- .j_to_posj(j, nc) |
||
| 221 | +764 |
- #' )+ ## this is overly complicated |
||
| 222 | +765 |
- #' basic_table(show_colcounts = TRUE) %>%+ ## we need the starting indices |
||
| 223 | +766 |
- #' split_cols_by("ARM", split_fun = mysplitfun2) %>%
+ ## but the first span might not be 1, so |
||
| 224 | +767 |
- #' analyze("AGE") %>%
+ ## we pad with 1 and then take off the last |
||
| 225 | -+ | |||
| 768 | +3974x |
- #' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
+ start <- cumsum(c(1, head(cspans, -1))) |
||
| 226 | -+ | |||
| 769 | +3974x |
- #'+ ends <- c(tail(start, -1) - 1, nc) |
||
| 227 | -+ | |||
| 770 | +3974x |
- #' very_stupid_core <- function(spl, df, vals, labels, .spl_context) {
+ res <- mapply(function(st, en) {
|
||
| 228 | -+ | |||
| 771 | +22905x |
- #' make_split_result(c("stupid", "silly"),
+ sum(j >= st & j <= en) |
||
| 229 | -+ | |||
| 772 | +3974x |
- #' datasplit = list(df[1:10, ], df[11:30, ]),+ }, st = start, en = ends) |
||
| 230 | -+ | |||
| 773 | +3974x |
- #' labels = c("first 10", "second 20")
+ res <- res[res > 0] |
||
| 231 | -+ | |||
| 774 | +3974x |
- #' )+ stopifnot(sum(res) == length(j)) |
||
| 232 | -+ | |||
| 775 | +3974x |
- #' }+ res |
||
| 233 | +776 |
- #'+ } |
||
| 234 | +777 |
- #' dumb_30_facet <- add_combo_facet("dumb",
+
|
||
| 235 | +778 |
- #' label = "thirty patients",+ select_cells_j <- function(cells, j) {
|
||
| 236 | -+ | |||
| 779 | +3974x |
- #' levels = c("stupid", "silly")
+ if (length(j) != length(unique(j))) {
|
||
| 237 | -+ | |||
| 780 | +! |
- #' )+ stop("duplicate column selections is not currently supported")
|
||
| 238 | +781 |
- #' nonsense_splfun <- make_split_fun(+ } |
||
| 239 | -+ | |||
| 782 | +3974x |
- #' core_split = very_stupid_core,+ spans <- vapply( |
||
| 240 | -+ | |||
| 783 | +3974x |
- #' post = list(dumb_30_facet)+ cells, function(x) cell_cspan(x), |
||
| 241 | -+ | |||
| 784 | +3974x |
- #' )+ integer(1) |
||
| 242 | +785 |
- #'+ )+ |
+ ||
| 786 | +3974x | +
+ inds <- rep(seq_along(cells), times = spans)+ |
+ ||
| 787 | +3974x | +
+ selinds <- inds[j]+ |
+ ||
| 788 | +3974x | +
+ retcells <- cells[selinds[!duplicated(selinds)]]+ |
+ ||
| 789 | +3974x | +
+ newspans <- vapply(+ |
+ ||
| 790 | +3974x | +
+ split(selinds, selinds),+ |
+ ||
| 791 | +3974x | +
+ length,+ |
+ ||
| 792 | +3974x | +
+ integer(1) |
||
| 243 | +793 |
- #' ## recall core split overriding is not supported in column space+ ) |
||
| 244 | +794 |
- #' ## currently, but we can see it in action in row space+ + |
+ ||
| 795 | +3974x | +
+ mapply(function(cl, sp) {
+ |
+ ||
| 796 | +6891x | +
+ cell_cspan(cl) <- sp+ |
+ ||
| 797 | +6891x | +
+ cl+ |
+ ||
| 798 | +3974x | +
+ }, cl = retcells, sp = newspans, SIMPLIFY = FALSE) |
||
| 245 | +799 |
- #'+ } |
||
| 246 | +800 |
- #' lyt_silly <- basic_table() %>%+ |
||
| 247 | +801 |
- #' split_rows_by("ARM", split_fun = nonsense_splfun) %>%
+ setMethod( |
||
| 248 | +802 |
- #' summarize_row_groups() %>%+ "subset_cols", c("ANY", "character"),
|
||
| 249 | +803 |
- #' analyze("AGE")
+ 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, ...) |
||
| 250 | +806 |
- #' silly_table <- build_table(lyt_silly, DM)+ } |
||
| 251 | +807 |
- #' silly_table+ ) |
||
| 252 | +808 |
- #'+ |
||
| 253 | +809 |
- #' @family make_custom_split+ setMethod( |
||
| 254 | +810 |
- #' @export+ "subset_cols", c("TableRow", "numeric"),
|
||
| 255 | +811 |
- make_split_fun <- function(pre = list(), core_split = NULL, post = list()) {
+ function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
|
||
| 256 | -7x | +812 | +3974x |
- function(df,+ j <- .j_to_posj(j, ncol(tt)) |
| 257 | -7x | +813 | +3974x |
- spl,+ if (is.null(newcinfo)) {
|
| 258 | -7x | +814 | +16x |
- vals = NULL,+ cinfo <- col_info(tt) |
| 259 | -7x | +815 | +16x |
- labels = NULL,+ newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...) |
| 260 | -7x | +|||
| 816 | +
- trim = FALSE,+ } |
|||
| 261 | -7x | +817 | +3974x |
- .spl_context) {
+ tt2 <- tt |
| 262 | -11x | +818 | +3974x |
- orig_columns <- names(df)+ row_cells(tt2) <- select_cells_j(row_cells(tt2), j) |
| 263 | -11x | +|||
| 819 | +
- for (pre_fn in pre) {
+
|
|||
| 264 | -5x | +820 | +3974x |
- if (.can_take_spl_context(pre_fn)) {
+ if (length(row_cspans(tt2)) > 0) {
|
| 265 | -5x | +821 | +3974x |
- df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels, .spl_context = .spl_context)+ row_cspans(tt2) <- .fix_rowcspans(tt2, j) |
| 266 | +822 |
- } else {
- |
- ||
| 267 | -! | -
- df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels)+ } |
||
| 268 | -+ | |||
| 823 | +3974x |
- }+ col_info(tt2) <- newcinfo |
||
| 269 | -3x | +824 | +3974x |
- if (!is(df, "data.frame")) {
+ tt2 |
| 270 | -! | +|||
| 825 | +
- stop(+ } |
|||
| 271 | -! | +|||
| 826 | +
- "Error in custom split function, pre-split step did not return a data.frame. ",+ ) |
|||
| 272 | -! | +|||
| 827 | +
- "See upstream call to make_split_fun for original source of error."+ |
|||
| 273 | +828 |
- )+ setMethod( |
||
| 274 | +829 |
- }+ "subset_cols", c("LabelRow", "numeric"),
|
||
| 275 | +830 |
- }+ function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
|
||
| 276 | -+ | |||
| 831 | +2702x |
-
+ j <- .j_to_posj(j, ncol(tt)) |
||
| 277 | -9x | +832 | +2702x |
- if (!all(orig_columns %in% names(df))) {
+ if (is.null(newcinfo)) {
|
| 278 | +833 | ! |
- stop(+ cinfo <- col_info(tt) |
|
| 279 | +834 | ! |
- "Preprocessing functions(s) in custom split function removed a column from the incoming data.",+ newcinfo <- subset_cols(cinfo, j, keep_topleft = keep_topleft, ...) |
|
| 280 | -! | +|||
| 835 | +
- " This is not supported. See upstread make_split_fun call (pre argument) for original source of error."+ }+ |
+ |||
| 836 | +2702x | +
+ col_info(tt) <- newcinfo+ |
+ ||
| 837 | +2702x | +
+ tt |
||
| 281 | +838 |
- )+ } |
||
| 282 | +839 |
- }+ ) |
||
| 283 | +840 | |||
| 284 | -9x | +|||
| 841 | +
- if (is.null(core_split)) {
+ setMethod( |
|||
| 285 | -7x | +|||
| 842 | +
- ret <- do_base_split(spl = spl, df = df, vals = vals, labels = labels)+ "subset_cols", c("InstantiatedColumnInfo", "numeric"),
|
|||
| 286 | +843 |
- } else {
+ function(tt, j, newcinfo = NULL, keep_topleft = TRUE, ...) {
|
||
| 287 | -2x | +844 | +278x |
- ret <- core_split(spl = spl, df = df, vals = vals, labels = labels, .spl_context)+ if (!is.null(newcinfo)) {
|
| 288 | -2x | +|||
| 845 | +! |
- validate_split_result(ret, component = "core_split")+ return(newcinfo) |
||
| 289 | +846 |
} |
||
| 290 | -+ | |||
| 847 | +278x |
-
+ j <- .j_to_posj(j, length(col_exprs(tt))) |
||
| 291 | -9x | +848 | +278x |
- for (post_fn in post) {
+ newctree <- subset_cols(coltree(tt), j, NULL) |
| 292 | -8x | +849 | +278x |
- if (.can_take_spl_context(post_fn)) {
+ newcextra <- col_extra_args(tt)[j] |
| 293 | -8x | +850 | +278x |
- ret <- post_fn(ret, spl = spl, .spl_context = .spl_context, fulldf = df)+ newcsubs <- col_exprs(tt)[j] |
| 294 | -+ | |||
| 851 | +278x |
- } else {
+ newcounts <- col_counts(tt)[j] |
||
| 295 | -! | +|||
| 852 | +278x |
- ret <- post_fn(ret, spl = spl, fulldf = df)+ tl <- if (keep_topleft) top_left(tt) else character() |
||
| 296 | -+ | |||
| 853 | +278x |
- }+ InstantiatedColumnInfo( |
||
| 297 | -+ | |||
| 854 | +278x |
- }+ treelyt = newctree, |
||
| 298 | -9x | +855 | +278x |
- validate_split_result(ret, "post")+ csubs = newcsubs, |
| 299 | -9x | +856 | +278x |
- ret+ extras = newcextra, |
| 300 | -+ | |||
| 857 | +278x |
- }+ cnts = newcounts, |
||
| 301 | -+ | |||
| 858 | +278x |
- }+ dispcounts = disp_ccounts(tt), |
||
| 302 | -+ | |||
| 859 | +278x |
-
+ countformat = colcount_format(tt), |
||
| 303 | -+ | |||
| 860 | +278x |
- #' Add a combination facet in post-processing+ topleft = tl |
||
| 304 | +861 |
- #'+ ) |
||
| 305 | +862 |
- #' Add a combination facet during the post-processing stage in a custom split fun.+ } |
||
| 306 | +863 |
- #'+ ) |
||
| 307 | +864 |
- #' @param name (`string`)\cr name for the resulting facet (for use in pathing, etc.).+ |
||
| 308 | +865 |
- #' @param label (`string`)\cr label for the resulting facet.+ setMethod( |
||
| 309 | +866 |
- #' @param levels (`character`)\cr vector of levels to combine within the resulting facet.+ "subset_cols", c("LayoutColTree", "numeric"),
|
||
| 310 | +867 |
- #' @param extra (`list`)\cr extra arguments to be passed to analysis functions applied within the resulting facet.+ function(tt, j, newcinfo = NULL, ...) {
|
||
| 311 | -+ | |||
| 868 | +278x |
- #'+ lst <- collect_leaves(tt) |
||
| 312 | -+ | |||
| 869 | +278x |
- #' @details+ j <- .j_to_posj(j, length(lst)) |
||
| 313 | +870 |
- #' For `add_combo_facet`, the data associated with the resulting facet will be the data associated with the facets for+ |
||
| 314 | +871 |
- #' each level in `levels`, row-bound together. In particular, this means that if those levels are overlapping, data+ ## j has only non-negative values from |
||
| 315 | +872 |
- #' that appears in both will be duplicated.+ ## this point on |
||
| 316 | -+ | |||
| 873 | +278x |
- #'+ counter <- 0 |
||
| 317 | -+ | |||
| 874 | +278x |
- #' @return A function which can be used within the `post` argument in [make_split_fun()].+ prune_children <- function(x, j) {
|
||
| 318 | -+ | |||
| 875 | +674x |
- #'+ kids <- tree_children(x) |
||
| 319 | -+ | |||
| 876 | +674x |
- #' @seealso [make_split_fun()]+ newkids <- kids |
||
| 320 | -+ | |||
| 877 | +674x |
- #'+ for (i in seq_along(newkids)) {
|
||
| 321 | -+ | |||
| 878 | +1813x |
- #' @examples+ if (is(newkids[[i]], "LayoutColLeaf")) {
+ |
+ ||
| 879 | +1417x | +
+ counter <<- counter + 1+ |
+ ||
| 880 | +1417x | +
+ if (!(counter %in% j)) {
+ |
+ ||
| 881 | +1013x | +
+ newkids[[i]] <- list()+ |
+ ||
| 882 | +278x | +
+ } ## NULL removes the position entirely |
||
| 322 | +883 |
- #' mysplfun <- make_split_fun(post = list(+ } else {
+ |
+ ||
| 884 | +396x | +
+ newkids[[i]] <- prune_children(newkids[[i]], j) |
||
| 323 | +885 |
- #' add_combo_facet("A_B",
+ } |
||
| 324 | +886 |
- #' label = "Arms A+B",+ } |
||
| 325 | +887 |
- #' levels = c("A: Drug X", "B: Placebo")
+
+ |
+ ||
| 888 | +674x | +
+ newkids <- newkids[sapply(newkids, function(thing) length(thing) > 0)]+ |
+ ||
| 889 | +674x | +
+ if (length(newkids) > 0) {
+ |
+ ||
| 890 | +474x | +
+ tree_children(x) <- newkids+ |
+ ||
| 891 | +474x | +
+ x |
||
| 326 | +892 |
- #' ),+ } else {
+ |
+ ||
| 893 | +200x | +
+ list() |
||
| 327 | +894 |
- #' add_overall_facet("ALL", label = "All Arms")
+ } |
||
| 328 | +895 |
- #' ))+ }+ |
+ ||
| 896 | +278x | +
+ prune_children(tt, j) |
||
| 329 | +897 |
- #'+ } |
||
| 330 | +898 |
- #' lyt <- basic_table(show_colcounts = TRUE) %>%+ ) |
||
| 331 | +899 |
- #' split_cols_by("ARM", split_fun = mysplfun) %>%
+
|
||
| 332 | +900 |
- #' analyze("AGE")
+ ## label rows ARE included in the count |
||
| 333 | +901 |
- #'+ subset_by_rownum <- function(tt, |
||
| 334 | +902 |
- #' tbl <- build_table(lyt, DM)+ i, |
||
| 335 | +903 |
- #'+ keep_topleft = FALSE, |
||
| 336 | +904 |
- #' @family make_custom_split+ keep_titles = TRUE, |
||
| 337 | +905 |
- #' @export+ keep_footers = keep_titles, |
||
| 338 | +906 |
- add_combo_facet <- function(name, label = name, levels, extra = list()) {
+ ...) {
|
||
| 339 | -3x | +907 | +184x |
- function(ret, spl, .spl_context, fulldf) {
+ stopifnot(is(tt, "VTableNodeInfo")) |
| 340 | -4x | +908 | +184x |
- if (is(levels, "AllLevelsSentinel")) {
+ counter <- 0 |
| 341 | -1x | +909 | +184x |
- subexpr <- expression(TRUE)+ nr <- nrow(tt) |
| 342 | -1x | +910 | +184x |
- datpart <- list(fulldf)+ i <- .j_to_posj(i, nr) |
| 343 | -+ | |||
| 911 | +184x |
- } else {
+ if (length(i) == 0) {
|
||
| 344 | +912 | 3x |
- subexpr <- .combine_value_exprs(ret$values[levels])+ ret <- TableTree(cinfo = col_info(tt)) |
|
| 345 | +913 | 3x |
- datpart <- list(do.call(rbind, ret$datasplit[levels]))+ if (isTRUE(keep_topleft)) {
+ |
+ |
| 914 | +1x | +
+ top_left(ret) <- top_left(tt) |
||
| 346 | +915 |
} |
||
| 916 | +3x | +
+ return(ret)+ |
+ ||
| 347 | +917 |
-
+ } |
||
| 348 | +918 | |||
| 349 | -4x | +919 | +181x |
- val <- LevelComboSplitValue(+ prune_rowsbynum <- function(x, i, valifnone = NULL) {
|
| 350 | -4x | +920 | +1321x |
- val = name, extr = extra, combolevels = levels, label = label,+ maxi <- max(i) |
| 351 | -4x | +921 | +1321x |
- sub_expr = subexpr+ if (counter > maxi) {
+ |
+
| 922 | +137x | +
+ return(valifnone) |
||
| 352 | +923 |
- )+ }+ |
+ ||
| 924 | ++ | + | ||
| 353 | -4x | +925 | +1184x |
- add_to_split_result(ret,+ if (labelrow_visible(x)) {
|
| 354 | -4x | +926 | +489x |
- values = list(val), labels = label,+ counter <<- counter + 1 |
| 355 | -4x | +927 | +489x |
- datasplit = datpart+ if (!(counter %in% i)) {
|
| 356 | +928 |
- )+ ## XXX this should do whatever |
||
| 357 | +929 |
- }+ ## is required to 'remove' the Label Row |
||
| 358 | +930 |
- }+ ## (currently implicit based on |
||
| 359 | +931 |
-
+ ## the value of the label but |
||
| 360 | +932 |
- .combine_value_exprs <- function(val_lst, spl) {
+ ## that shold really probably change) |
||
| 361 | -3x | +933 | +177x |
- exprs <- lapply(val_lst, value_expr)+ labelrow_visible(x) <- FALSE |
| 362 | -3x | +|||
| 934 | +
- nulls <- vapply(exprs, is.null, TRUE)+ } |
|||
| 363 | -3x | +|||
| 935 | +
- if (all(nulls)) {
+ } |
|||
| 364 | -1x | +936 | +1184x |
- return(NULL) # default behavior all the way down the line, no need to do anything.+ if (is(x, "TableTree") && nrow(content_table(x)) > 0) {
|
| 365 | -2x | +937 | +90x |
- } else if (any(nulls)) {
+ ctab <- content_table(x) |
| 366 | -! | +|||
| 938 | +
- exprs[nulls] <- lapply(val_lst[nulls], function(vali) make_subset_expr(spl, vali))+ |
|||
| 367 | -+ | |||
| 939 | +90x |
- }+ content_table(x) <- prune_rowsbynum(ctab, i, |
||
| 368 | -2x | +940 | +90x |
- Reduce(.or_combine_exprs, exprs)+ valifnone = ElementaryTable( |
| 369 | -+ | |||
| 941 | +90x |
- }+ cinfo = col_info(ctab), |
||
| 370 | -+ | |||
| 942 | +90x |
-
+ iscontent = TRUE |
||
| 371 | +943 |
- ## no NULLS coming in here, everything has been populated+ ) |
||
| 372 | +944 |
- ## by either custom subsetting expressions or the result of make_subset_expr(spl, val)+ ) |
||
| 373 | +945 |
- .or_combine_exprs <- function(ex1, ex2) {
+ } |
||
| 374 | -2x | +946 | +1184x |
- if (identical(ex1, expression(FALSE))) {
+ kids <- tree_children(x) |
| 375 | -! | +|||
| 947 | +1184x |
- return(ex2)+ if (counter > maxi) { # already done
|
||
| 376 | -2x | +948 | +49x |
- } else if (identical(ex2, expression(FALSE))) {
+ kids <- list() |
| 377 | -! | +|||
| 949 | +1135x |
- return(ex1)+ } else if (length(kids) > 0) {
|
||
| 378 | -2x | +950 | +1133x |
- } else if (identical(ex1, expression(TRUE)) || identical(ex2, expression(TRUE))) {
+ for (pos in seq_along(kids)) {
|
| 379 | -! | +|||
| 951 | +4102x |
- return(TRUE)+ if (is(kids[[pos]], "TableRow")) {
|
||
| 380 | -+ | |||
| 952 | +3052x |
- }+ counter <<- counter + 1 |
||
| 381 | -2x | +953 | +3052x |
- as.expression(bquote((.(a)) | .(b), list(a = ex1[[1]], b = ex2[[1]])))+ if (!(counter %in% i)) {
|
| 382 | -+ | |||
| 954 | +2144x |
- }+ kids[[pos]] <- list() |
||
| 383 | +955 |
-
+ } |
||
| 384 | +956 |
- #' @rdname add_combo_facet+ } else {
+ |
+ ||
| 957 | +1050x | +
+ kids[[pos]] <- prune_rowsbynum(kids[[pos]], i, list()) |
||
| 385 | +958 |
- #' @export+ } |
||
| 386 | +959 |
- add_overall_facet <- function(name, label, extra = list()) {
+ } |
||
| 387 | -1x | +960 | +1133x |
- add_combo_facet(+ kids <- kids[sapply(kids, function(x) NROW(x) > 0)]+ |
+
| 961 | ++ |
+ } |
||
| 388 | -1x | +962 | +1184x |
- name = name, label = label, levels = select_all_levels,+ if (length(kids) == 0 && NROW(content_table(x)) == 0 && !labelrow_visible(x)) {
|
| 389 | -1x | +963 | +359x |
- extra = extra+ return(valifnone) |
| 390 | +964 |
- )+ } else {
|
||
| 391 | -+ | |||
| 965 | +825x |
- }+ tree_children(x) <- kids+ |
+ ||
| 966 | +825x | +
+ x |
||
| 392 | +967 |
-
+ } |
||
| 393 | +968 |
- #' Trim levels of another variable from each facet (post-processing split step)+ ## ## if(length(kids) == 0) {
|
||
| 394 | +969 |
- #'+ ## ## if(!is(x, "TableTree")) |
||
| 395 | +970 |
- #' @param innervar (`character`)\cr the variable(s) to trim (remove unobserved levels) independently within each facet.+ ## ## return(valifnone) |
||
| 396 | +971 |
- #'+ ## ## } |
||
| 397 | +972 |
- #' @return A function suitable for use in the `pre` (list) argument of `make_split_fun`.+ ## if(is(x, "VTableTree") && nrow(x) > 0) {
|
||
| 398 | +973 |
- #'+ ## x |
||
| 399 | +974 |
- #' @seealso [make_split_fun()]+ ## } else {
|
||
| 400 | +975 |
- #'+ ## valifnone |
||
| 401 | +976 |
- #' @family make_custom_split+ ## } |
||
| 402 | +977 |
- #' @export+ }+ |
+ ||
| 978 | +181x | +
+ ret <- prune_rowsbynum(tt, i) |
||
| 403 | +979 |
- trim_levels_in_facets <- function(innervar) {
+
|
||
| 404 | -1x | +980 | +181x |
- function(ret, ...) {
+ ret <- .h_copy_titles_footers_topleft( |
| 405 | -1x | +981 | +181x |
- for (var in innervar) {
+ ret, tt, |
| 406 | -1x | +982 | +181x |
- ret$datasplit <- lapply(ret$datasplit, function(df) {
+ keep_titles, |
| 407 | -2x | +983 | +181x |
- df[[var]] <- factor(df[[var]])+ keep_footers, |
| 408 | -2x | +984 | +181x |
- df+ keep_topleft |
| 409 | +985 |
- })+ ) |
||
| 410 | +986 |
- }+ |
||
| 411 | -1x | +987 | +181x |
- ret+ ret |
| 412 | +988 |
- }+ } |
||
| 413 | +989 |
- }+ |
||
| 414 | +990 |
-
+ #' @exportMethod [ |
||
| 415 | +991 |
- #' Pre-processing function for use in `make_split_fun`+ #' @rdname brackets |
||
| 416 | +992 |
- #'+ setMethod( |
||
| 417 | +993 |
- #' This function is intended for use as a pre-processing component in `make_split_fun`, and should not be called+ "[", c("VTableTree", "logical", "logical"),
|
||
| 418 | +994 |
- #' directly by end users.+ function(x, i, j, ..., drop = FALSE) {
|
||
| 419 | -+ | |||
| 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] |
||
| 420 | +998 |
- #' @param df (`data.frame`)\cr the incoming data corresponding with the parent facet.+ } |
||
| 421 | +999 |
- #' @param spl (`VarLevelSplit`)\cr the split.+ ) |
||
| 422 | +1000 |
- #' @param ... additional parameters passed internally.+ |
||
| 423 | +1001 |
- #'+ #' @exportMethod [ |
||
| 424 | +1002 |
- #' @seealso [make_split_fun()]+ #' @rdname int_methods |
||
| 425 | +1003 |
- #'+ #' @keywords internal |
||
| 426 | +1004 |
- #' @family make_custom_split+ setMethod( |
||
| 427 | +1005 |
- #' @export+ "[", c("VTableTree", "logical", "ANY"),
|
||
| 428 | +1006 |
- drop_facet_levels <- function(df, spl, ...) {
+ function(x, i, j, ..., drop = FALSE) {
|
||
| 429 | -2x | +|||
| 1007 | +! |
- if (!is(spl, "VarLevelSplit") || is.na(spl_payload(spl))) {
+ i <- .j_to_posj(i, nrow(x)) |
||
| 430 | +1008 | ! |
- stop("Unable to determine faceting variable in drop_facet_levels application.")
+ x[i, j, ..., drop = drop] |
|
| 431 | +1009 |
} |
||
| 432 | -2x | +|||
| 1010 | +
- var <- spl_payload(spl)+ ) |
|||
| 433 | -2x | +|||
| 1011 | +
- df[[var]] <- factor(df[[var]])+ |
|||
| 434 | -2x | +|||
| 1012 | +
- df+ #' @exportMethod [ |
|||
| 435 | +1013 |
- }+ #' @rdname int_methods |
| 1 | +1014 |
- #' Cell value constructors+ #' @keywords internal |
||
| 2 | +1015 |
- #'+ setMethod( |
||
| 3 | +1016 |
- #' Construct a cell value and associate formatting, labeling, indenting, and column spanning information with it.+ "[", c("VTableTree", "logical", "missing"),
|
||
| 4 | +1017 |
- #'+ function(x, i, j, ..., drop = FALSE) {
|
||
| 5 | -+ | |||
| 1018 | +4x |
- #' @inheritParams compat_args+ j <- seq_len(ncol(x)) |
||
| 6 | -+ | |||
| 1019 | +4x |
- #' @inheritParams lyt_args+ i <- .j_to_posj(i, nrow(x)) |
||
| 7 | -+ | |||
| 1020 | +4x |
- #' @param x (`ANY`)\cr cell value.+ x[i, j, ..., drop = drop] |
||
| 8 | +1021 |
- #' @param format (`string` or `function`)\cr the format label (string) or `formatters` function to apply to `x`.+ } |
||
| 9 | +1022 |
- #' See [formatters::list_valid_format_labels()] for currently supported format labels.+ ) |
||
| 10 | +1023 |
- #' @param label (`string` or `NULL`)\cr label. If non-`NULL`, it will be looked at when determining row labels.+ |
||
| 11 | +1024 |
- #' @param colspan (`integer(1)`)\cr column span value.+ #' @exportMethod [ |
||
| 12 | +1025 |
- #' @param footnotes (`list` or `NULL`)\cr referential footnote messages for the cell.+ #' @rdname int_methods |
||
| 13 | +1026 |
- #'+ #' @keywords internal |
||
| 14 | +1027 |
- #' @inherit CellValue return+ setMethod( |
||
| 15 | +1028 |
- #'+ "[", c("VTableTree", "ANY", "logical"),
|
||
| 16 | +1029 |
- #' @note Currently column spanning is only supported for defining header structure.+ function(x, i, j, ..., drop = FALSE) {
|
||
| 17 | -+ | |||
| 1030 | +1x |
- #'+ j <- .j_to_posj(j, ncol(x)) |
||
| 18 | -+ | |||
| 1031 | +1x |
- #' @rdname rcell+ x[i, j, ..., drop = drop] |
||
| 19 | +1032 |
- #' @export+ } |
||
| 20 | +1033 |
- rcell <- function(x,+ ) |
||
| 21 | +1034 |
- format = NULL,+ |
||
| 22 | +1035 |
- colspan = 1L,+ #' @exportMethod [ |
||
| 23 | +1036 |
- label = NULL,+ #' @rdname int_methods |
||
| 24 | +1037 |
- indent_mod = NULL,+ #' @keywords internal |
||
| 25 | +1038 |
- footnotes = NULL,+ setMethod( |
||
| 26 | +1039 |
- align = NULL,+ "[", c("VTableTree", "ANY", "missing"),
|
||
| 27 | +1040 |
- format_na_str = NULL) {
+ function(x, i, j, ..., drop = FALSE) {
|
||
| 28 | -31806x | +1041 | +146x |
- if (!is.null(align)) {
+ j <- seq_len(ncol(x)) |
| 29 | -56x | +1042 | +146x |
- check_aligns(align)+ x[i = i, j = j, ..., drop = drop] |
| 30 | +1043 |
} |
||
| 31 | -31806x | -
- if (is(x, "CellValue")) {
- |
- ||
| 32 | -19186x | -
- if (!is.null(label)) {
- |
- ||
| 33 | -1x | +|||
| 1044 | +
- obj_label(x) <- label+ ) |
|||
| 34 | +1045 |
- }+ |
||
| 35 | -19186x | +|||
| 1046 | +
- if (colspan != 1L) {
+ #' @exportMethod [ |
|||
| 36 | -1x | +|||
| 1047 | +
- cell_cspan(x) <- colspan+ #' @rdname int_methods |
|||
| 37 | +1048 |
- }+ #' @keywords internal |
||
| 38 | -19186x | +|||
| 1049 | +
- if (!is.null(indent_mod)) {
+ setMethod( |
|||
| 39 | -1x | +|||
| 1050 | +
- indent_mod(x) <- indent_mod+ "[", c("VTableTree", "missing", "ANY"),
|
|||
| 40 | +1051 |
- }+ function(x, i, j, ..., drop = FALSE) {
|
||
| 41 | -19186x | +1052 | +4x |
- if (!is.null(format)) {
+ i <- seq_len(nrow(x)) |
| 42 | -1x | +1053 | +4x |
- obj_format(x) <- format+ x[i = i, j = j, ..., drop = drop] |
| 43 | +1054 |
- }+ } |
||
| 44 | -19186x | +|||
| 1055 | +
- if (!is.null(footnotes)) {
+ ) |
|||
| 45 | -366x | +|||
| 1056 | +
- cell_footnotes(x) <- lapply(footnotes, RefFootnote)+ |
|||
| 46 | +1057 |
- }+ #' @exportMethod [ |
||
| 47 | -19186x | +|||
| 1058 | +
- if (!is.null(format_na_str)) {
+ #' @rdname int_methods |
|||
| 48 | -! | +|||
| 1059 | +
- obj_na_str(x) <- format_na_str+ #' @keywords internal |
|||
| 49 | +1060 |
- }+ setMethod( |
||
| 50 | -19186x | +|||
| 1061 | +
- ret <- x+ "[", c("VTableTree", "ANY", "character"),
|
|||
| 51 | +1062 |
- } else {
+ function(x, i, j, ..., drop = FALSE) {
|
||
| 52 | -12620x | +|||
| 1063 | +
- if (is.null(label)) {
+ ## j <- .colpath_to_j(j, coltree(x)) |
|||
| 53 | -9738x | -
- label <- obj_label(x)- |
- ||
| 54 | -- |
- }- |
- ||
| 55 | -12620x | +1064 | +3x |
- if (is.null(format)) {
+ j <- .path_to_pos(path = j, tt = x, cols = TRUE) |
| 56 | -6782x | +1065 | +3x |
- format <- obj_format(x)+ x[i = i, j = j, ..., drop = drop] |
| 57 | +1066 |
- }- |
- ||
| 58 | -12620x | -
- if (is.null(indent_mod)) {
- |
- ||
| 59 | -12620x | -
- indent_mod <- indent_mod(x)+ } |
||
| 60 | +1067 |
- }+ ) |
||
| 61 | -12620x | +|||
| 1068 | +
- footnotes <- lapply(footnotes, RefFootnote)+ |
|||
| 62 | -12620x | +|||
| 1069 | +
- ret <- CellValue(+ #' @exportMethod [ |
|||
| 63 | -12620x | +|||
| 1070 | +
- val = x,+ #' @rdname int_methods |
|||
| 64 | -12620x | +|||
| 1071 | +
- format = format,+ #' @keywords internal |
|||
| 65 | -12620x | +|||
| 1072 | +
- colspan = colspan,+ setMethod( |
|||
| 66 | -12620x | +|||
| 1073 | +
- label = label,+ "[", c("VTableTree", "character", "ANY"),
|
|||
| 67 | -12620x | +|||
| 1074 | +
- indent_mod = indent_mod,+ function(x, i, j, ..., drop = FALSE) {
|
|||
| 68 | -12620x | +|||
| 1075 | +
- footnotes = footnotes,+ ## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW) |
|||
| 69 | -12620x | +|||
| 1076 | +! |
- format_na_str = format_na_str+ i <- .path_to_pos(i, x) |
||
| 70 | -12620x | +|||
| 1077 | +! |
- ) # RefFootnote(footnote))+ x[i = i, j = j, ..., drop = drop] |
||
| 71 | +1078 |
} |
||
| 72 | -31806x | -
- if (!is.null(align)) {
- |
- ||
| 73 | -56x | +|||
| 1079 | +
- cell_align(ret) <- align+ ) |
|||
| 74 | +1080 |
- }+ |
||
| 75 | -31806x | +|||
| 1081 | +
- ret+ ## to avoid dispatch ambiguity. Not necessary, possibly not a good idea at all |
|||
| 76 | +1082 |
- }+ #' @exportMethod [ |
||
| 77 | +1083 |
-
+ #' @rdname int_methods |
||
| 78 | +1084 |
- #' @param is_ref (`flag`)\cr whether function is being used in the reference column (i.e. `.in_ref_col` should be+ #' @keywords internal |
||
| 79 | +1085 |
- #' passed to this argument).+ setMethod( |
||
| 80 | +1086 |
- #' @param refval (`ANY`)\cr value to use when in the reference column. Defaults to `NULL`.+ "[", c("VTableTree", "character", "character"),
|
||
| 81 | +1087 |
- #'+ function(x, i, j, ..., drop = FALSE) {
|
||
| 82 | +1088 |
- #' @details+ ## i <- .path_to_pos(i, seq_len(nrow(x)), x, NROW) |
||
| 83 | -+ | |||
| 1089 | +! |
- #' `non_ref_rcell` provides the common *blank for cells in the reference column, this value otherwise*, and should+ i <- .path_to_pos(i, x) |
||
| 84 | +1090 |
- #' be passed the value of `.in_ref_col` when it is used.+ ## j <- .colpath_to_j(j, coltree(x)) |
||
| 85 | -+ | |||
| 1091 | +! |
- #'+ j <- .path_to_pos(path = j, tt = x, cols = TRUE) |
||
| 86 | -+ | |||
| 1092 | +! |
- #' @rdname rcell+ x[i = i, j = j, ..., drop = drop] |
||
| 87 | +1093 |
- #' @export+ } |
||
| 88 | +1094 |
- non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L,+ ) |
||
| 89 | +1095 |
- label = NULL, indent_mod = NULL,+ |
||
| 90 | +1096 |
- refval = NULL,+ #' @exportMethod [ |
||
| 91 | +1097 |
- align = "center",+ #' @rdname int_methods |
||
| 92 | +1098 |
- format_na_str = NULL) {
+ #' @keywords internal |
||
| 93 | -2x | +|||
| 1099 | +
- val <- if (is_ref) refval else x+ setMethod( |
|||
| 94 | -2x | +|||
| 1100 | +
- rcell(val,+ "[", c("VTableTree", "missing", "numeric"),
|
|||
| 95 | -2x | +|||
| 1101 | +
- format = format, colspan = colspan, label = label,+ function(x, i, j, ..., drop = FALSE) {
|
|||
| 96 | -2x | +1102 | +238x |
- indent_mod = indent_mod, align = align,+ i <- seq_len(nrow(x)) |
| 97 | -2x | +1103 | +238x |
- format_na_str = format_na_str+ x[i, j, ..., drop = drop] |
| 98 | +1104 |
- )+ } |
||
| 99 | +1105 |
- }+ ) |
||
| 100 | +1106 | |||
| 101 | +1107 |
- #' Create multiple rows in analysis or summary functions+ #' @exportMethod [ |
||
| 102 | +1108 |
- #'+ #' @rdname int_methods |
||
| 103 | +1109 |
- #' Define the cells that get placed into multiple rows in `afun`.+ #' @keywords internal |
||
| 104 | +1110 |
- #'+ setMethod( |
||
| 105 | +1111 |
- #' @param ... single row defining expressions.+ "[", c("VTableTree", "numeric", "numeric"),
|
||
| 106 | +1112 |
- #' @param .list (`list`)\cr list cell content (usually `rcells`). The `.list` is concatenated to `...`.+ function(x, i, j, ..., drop = FALSE) {
|
||
| 107 | +1113 |
- #' @param .names (`character` or `NULL`)\cr names of the returned list/structure.+ ## have to do it this way because we can't add an argument since we don't |
||
| 108 | +1114 |
- #' @param .labels (`character` or `NULL`)\cr labels for the defined rows.+ ## own the generic declaration |
||
| 109 | -+ | |||
| 1115 | +471x |
- #' @param .formats (`character` or `NULL`)\cr formats for the values.+ keep_topleft <- list(...)[["keep_topleft"]] %||% NA |
||
| 110 | -+ | |||
| 1116 | +471x |
- #' @param .indent_mods (`integer` or `NULL`)\cr indent modifications for the defined rows.+ keep_titles <- list(...)[["keep_titles"]] %||% FALSE |
||
| 111 | -+ | |||
| 1117 | +471x |
- #' @param .cell_footnotes (`list`)\cr referential footnote messages to be associated by name with *cells*.+ keep_footers <- list(...)[["keep_footers"]] %||% keep_titles |
||
| 112 | -+ | |||
| 1118 | +471x |
- #' @param .row_footnotes (`list`)\cr referential footnotes messages to be associated by name with *rows*.+ reindex_refs <- list(...)[["reindex_refs"]] %||% TRUE |
||
| 113 | +1119 |
- #' @param .aligns (`character` or `NULL`)\cr alignments for the cells. Standard for `NULL` is `"center"`.+ |
||
| 114 | -+ | |||
| 1120 | +471x |
- #' See [formatters::list_valid_aligns()] for currently supported alignments.+ nr <- nrow(x) |
||
| 115 | -+ | |||
| 1121 | +471x |
- #' @param .format_na_strs (`character` or `NULL`)\cr NA strings for the cells.+ nc <- ncol(x) |
||
| 116 | -+ | |||
| 1122 | +471x |
- #'+ i <- .j_to_posj(i, nr) |
||
| 117 | -+ | |||
| 1123 | +471x |
- #' @note In post-processing, referential footnotes can also be added using row and column+ j <- .j_to_posj(j, nc) |
||
| 118 | +1124 |
- #' paths with [`fnotes_at_path<-`].+ |
||
| 119 | +1125 |
- #'+ ## if(!missing(i) && length(i) < nr) {
|
||
| 120 | -+ | |||
| 1126 | +471x |
- #' @return A `RowsVerticalSection` object (or `NULL`). The details of this object should be considered an+ if (length(i) < nr) { ## already populated by .j_to_posj
|
||
| 121 | -+ | |||
| 1127 | +184x |
- #' internal implementation detail.+ keep_topleft <- isTRUE(keep_topleft) |
||
| 122 | -+ | |||
| 1128 | +184x |
- #'+ x <- subset_by_rownum(x, i, |
||
| 123 | -+ | |||
| 1129 | +184x |
- #' @seealso [analyze()]+ keep_topleft = keep_topleft, |
||
| 124 | -+ | |||
| 1130 | +184x |
- #'+ keep_titles = keep_titles, |
||
| 125 | -+ | |||
| 1131 | +184x |
- #' @examples+ keep_footers = keep_footers |
||
| 126 | +1132 |
- #' in_rows(1, 2, 3, .names = c("a", "b", "c"))
+ ) |
||
| 127 | -+ | |||
| 1133 | +287x |
- #' in_rows(1, 2, 3, .labels = c("a", "b", "c"))
+ } else if (is.na(keep_topleft)) {
|
||
| 128 | -+ | |||
| 1134 | +49x |
- #' in_rows(1, 2, 3, .names = c("a", "b", "c"), .labels = c("AAA", "BBB", "CCC"))
+ keep_topleft <- TRUE |
||
| 129 | +1135 |
- #'+ } |
||
| 130 | +1136 |
- #' in_rows(.list = list(a = 1, b = 2, c = 3))+ |
||
| 131 | +1137 |
- #' in_rows(1, 2, .list = list(3), .names = c("a", "b", "c"))
+ ## if(!missing(j) && length(j) < nc) |
||
| 132 | -+ | |||
| 1138 | +471x |
- #'+ if (length(j) < nc) {
|
||
| 133 | -+ | |||
| 1139 | +232x |
- #' lyt <- basic_table() %>%+ x <- subset_cols(x, j, |
||
| 134 | -+ | |||
| 1140 | +232x |
- #' split_cols_by("ARM") %>%
+ keep_topleft = keep_topleft, |
||
| 135 | -+ | |||
| 1141 | +232x |
- #' analyze("AGE", afun = function(x) {
+ keep_titles = keep_titles, |
||
| 136 | -+ | |||
| 1142 | +232x |
- #' in_rows(+ keep_footers = keep_footers |
||
| 137 | +1143 |
- #' "Mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ ) |
||
| 138 | +1144 |
- #' "Range" = rcell(range(x), format = "xx.xx - xx.xx")+ } |
||
| 139 | +1145 |
- #' )+ |
||
| 140 | +1146 |
- #' })+ # Dropping everything |
||
| 141 | -+ | |||
| 1147 | +471x |
- #'+ if (drop) {
|
||
| 142 | -+ | |||
| 1148 | +35x |
- #' tbl <- build_table(lyt, ex_adsl)+ if (length(j) == 1L && length(i) == 1L) {
|
||
| 143 | -+ | |||
| 1149 | +30x |
- #' tbl+ rw <- collect_leaves(x, TRUE, TRUE)[[1]] |
||
| 144 | -+ | |||
| 1150 | +30x |
- #'+ if (is(rw, "LabelRow")) {
|
||
| 145 | -+ | |||
| 1151 | +2x |
- #' @export+ warning( |
||
| 146 | -+ | |||
| 1152 | +2x |
- in_rows <- function(..., .list = NULL, .names = NULL,+ "The value selected with drop = TRUE belongs ", |
||
| 147 | -+ | |||
| 1153 | +2x |
- .labels = NULL,+ "to a label row. NULL will be returned" |
||
| 148 | +1154 |
- .formats = NULL,+ ) |
||
| 149 | -+ | |||
| 1155 | +2x |
- .indent_mods = NULL,+ x <- NULL |
||
| 150 | +1156 |
- .cell_footnotes = list(NULL),+ } else {
|
||
| 151 | -+ | |||
| 1157 | +28x |
- .row_footnotes = list(NULL),+ x <- row_values(rw)[[1]] |
||
| 152 | +1158 |
- .aligns = NULL,+ } |
||
| 153 | +1159 |
- .format_na_strs = NULL) {
+ } else {
|
||
| 154 | -5775x | +1160 | +5x |
- if (is.function(.formats)) {
+ warning( |
| 155 | -! | +|||
| 1161 | +5x |
- .formats <- list(.formats)+ "Trying to drop more than one subsetted value. ", |
||
| 156 | -+ | |||
| 1162 | +5x |
- }+ "We support this only with accessor function `cell_values()`. ",+ |
+ ||
| 1163 | +5x | +
+ "No drop will be done at this time." |
||
| 157 | +1164 |
-
+ ) |
||
| 158 | -5775x | +1165 | +5x |
- l <- c(list(...), .list)+ drop <- FALSE |
| 159 | +1166 |
-
+ }+ |
+ ||
| 1167 | ++ |
+ } |
||
| 160 | -5775x | +1168 | +471x |
- if (missing(.names) && missing(.labels)) {
+ if (!drop) {
|
| 161 | -1766x | +1169 | +441x |
- if (length(l) > 0 && is.null(names(l))) {
+ if (!keep_topleft) {
|
| 162 | -! | +|||
| 1170 | +61x |
- stop("need a named list")
+ top_left(x) <- character() |
||
| 163 | +1171 |
- } else {
+ } |
||
| 164 | -1766x | +1172 | +441x |
- .names <- names(l)+ if (reindex_refs) {
+ |
+
| 1173 | +105x | +
+ x <- update_ref_indexing(x) |
||
| 165 | +1174 | ++ |
+ }+ |
+ |
| 1175 |
} |
|||
| 166 | -1766x | +1176 | +471x |
- stopifnot(!anyNA(.names))+ x |
| 167 | +1177 |
} |
||
| 168 | +1178 |
-
+ ) |
||
| 169 | -5775x | +|||
| 1179 | +
- if (length(l) == 0) {
+
|
|||
| 170 | +1180 |
- if (+ #' @importFrom utils compareVersion |
||
| 171 | -! | +|||
| 1181 | +
- length(.labels) > 0 ||+ |
|||
| 172 | -! | +|||
| 1182 | +
- length(.formats) > 0 ||+ setGeneric("tail", tail)
|
|||
| 173 | -! | +|||
| 1183 | +
- length(.names) > 0 ||+ |
|||
| 174 | -! | +|||
| 1184 | +
- length(.indent_mods) > 0 ||+ setMethod( |
|||
| 175 | -! | +|||
| 1185 | +
- length(.format_na_strs) > 0+ "tail", "VTableTree", |
|||
| 176 | +1186 |
- ) {
+ function(x, n = 6L, ...) {
|
||
| 177 | -! | +|||
| 1187 | +
- stop(+ if (compareVersion("4.0.0", as.character(getRversion())) <= 0) {
|
|||
| 178 | -! | +|||
| 1188 | +
- "in_rows got 0 rows but length >0 of at least one of ",+ tail.matrix(x, n, keepnums = FALSE) |
|||
| 179 | -! | +|||
| 1189 | +
- ".labels, .formats, .names, .indent_mods, .format_na_strs. ",+ } else {
|
|||
| 180 | -! | +|||
| 1190 | +
- "Does your analysis/summary function handle the 0 row ",+ tail.matrix(x, n, addrownums = FALSE) |
|||
| 181 | -! | +|||
| 1191 | +
- "df/length 0 x case?"+ } |
|||
| 182 | +1192 |
- )+ } |
||
| 183 | +1193 |
- }+ ) |
||
| 184 | -! | +|||
| 1194 | +
- l2 <- list()+ |
|||
| 185 | +1195 |
- } else {
+ setGeneric("head", head)
|
||
| 186 | -5775x | +|||
| 1196 | +
- if (is.null(.formats)) {
+
|
|||
| 187 | -5315x | +|||
| 1197 | +
- .formats <- list(NULL)+ setMethod( |
|||
| 188 | +1198 |
- }+ "head", "VTableTree", |
||
| 189 | -5775x | +|||
| 1199 | +
- stopifnot(is.list(.cell_footnotes))+ function(x, n = 6L, ...) {
|
|||
| 190 | -5775x | +|||
| 1200 | +
- if (length(.cell_footnotes) != length(l)) {
+ head.matrix(x, n) |
|||
| 191 | -1187x | +|||
| 1201 | +
- .cell_footnotes <- c(+ } |
|||
| 192 | -1187x | +|||
| 1202 | +
- .cell_footnotes,+ ) |
|||
| 193 | -1187x | +|||
| 1203 | +
- setNames(+ |
|||
| 194 | -1187x | +|||
| 1204 | +
- rep(list(character()),+ #' Retrieve cell values by row and column path |
|||
| 195 | -1187x | +|||
| 1205 | +
- length.out = length(setdiff(+ #' |
|||
| 196 | -1187x | +|||
| 1206 | +
- names(l),+ #' @inheritParams gen_args |
|||
| 197 | -1187x | +|||
| 1207 | +
- names(.cell_footnotes)+ #' @param rowpath (`character`)\cr path in row-split space to the desired row(s). Can include `"@content"`. |
|||
| 198 | +1208 |
- ))+ #' @param colpath (`character`)\cr path in column-split space to the desired column(s). Can include `"*"`. |
||
| 199 | +1209 |
- ),+ #' @param omit_labrows (`flag`)\cr whether label rows underneath `rowpath` should be omitted (`TRUE`, the default), |
||
| 200 | -1187x | +|||
| 1210 | +
- setdiff(+ #' or return empty lists of cell "values" (`FALSE`). |
|||
| 201 | -1187x | +|||
| 1211 | +
- names(l),+ #' |
|||
| 202 | -1187x | +|||
| 1212 | +
- names(.cell_footnotes)+ #' @return |
|||
| 203 | +1213 |
- )+ #' * `cell_values` returns a `list` (regardless of the type of value the cells hold). If `rowpath` defines a path to |
||
| 204 | +1214 |
- )+ #' a single row, `cell_values` returns the list of cell values for that row, otherwise a list of such lists, one for |
||
| 205 | +1215 |
- )+ #' each row captured underneath `rowpath`. This occurs after subsetting to `colpath` has occurred. |
||
| 206 | -1187x | +|||
| 1216 | +
- .cell_footnotes <- .cell_footnotes[names(l)]+ #' * `value_at` returns the "unwrapped" value of a single cell, or an error, if the combination of `rowpath` and |
|||
| 207 | +1217 |
- }+ #' `colpath` do not define the location of a single cell in `tt`. |
||
| 208 | -5775x | +|||
| 1218 | +
- if (is.null(.aligns)) {
+ #' |
|||
| 209 | -5772x | +|||
| 1219 | +
- .aligns <- list(NULL)+ #' @note `cell_values` will return a single cell's value wrapped in a list. Use `value_at` to receive the "bare" cell |
|||
| 210 | +1220 |
- }+ #' value. |
||
| 211 | -5775x | +|||
| 1221 | +
- l2 <- mapply(rcell,+ #' |
|||
| 212 | -5775x | +|||
| 1222 | +
- x = l, format = .formats,+ #' @examples |
|||
| 213 | -5775x | +|||
| 1223 | +
- footnotes = .cell_footnotes %||% list(NULL),+ #' lyt <- basic_table() %>% |
|||
| 214 | -5775x | +|||
| 1224 | +
- align = .aligns,+ #' split_cols_by("ARM") %>%
|
|||
| 215 | -5775x | +|||
| 1225 | +
- format_na_str = .format_na_strs %||% list(NULL),+ #' split_cols_by("SEX") %>%
|
|||
| 216 | -5775x | +|||
| 1226 | +
- SIMPLIFY = FALSE+ #' split_rows_by("RACE") %>%
|
|||
| 217 | +1227 |
- )+ #' summarize_row_groups() %>% |
||
| 218 | +1228 |
- }+ #' split_rows_by("STRATA1") %>%
|
||
| 219 | -5775x | +|||
| 1229 | +
- if (is.null(.labels)) {
+ #' analyze("AGE")
|
|||
| 220 | -2623x | +|||
| 1230 | +
- objlabs <- vapply(l2, function(x) obj_label(x) %||% "", "")+ #' |
|||
| 221 | -2623x | +|||
| 1231 | +
- if (any(nzchar(objlabs))) {
+ #' @examplesIf require(dplyr) |
|||
| 222 | -69x | +|||
| 1232 | +
- .labels <- objlabs+ #' library(dplyr) ## for mutate |
|||
| 223 | +1233 |
- }+ #' tbl <- build_table(lyt, DM %>% |
||
| 224 | +1234 |
- }+ #' mutate(SEX = droplevels(SEX), RACE = droplevels(RACE))) |
||
| 225 | +1235 |
-
+ #' |
||
| 226 | -5775x | +|||
| 1236 | +
- if (is.null(.names) && !is.null(names(l))) {
+ #' row_paths_summary(tbl) |
|||
| 227 | -97x | +|||
| 1237 | +
- .names <- names(l)+ #' col_paths_summary(tbl) |
|||
| 228 | +1238 |
- }+ #' |
||
| 229 | -5775x | +|||
| 1239 | +
- stopifnot(is.list(.row_footnotes))+ #' cell_values( |
|||
| 230 | -5775x | +|||
| 1240 | +
- if (length(.row_footnotes) != length(l2)) {
+ #' tbl, c("RACE", "ASIAN", "STRATA1", "B"),
|
|||
| 231 | -1187x | +|||
| 1241 | +
- tmp <- .row_footnotes+ #' c("ARM", "A: Drug X", "SEX", "F")
|
|||
| 232 | -1187x | +|||
| 1242 | +
- .row_footnotes <- vector("list", length(l2))
+ #' ) |
|||
| 233 | -1187x | +|||
| 1243 | +
- pos <- match(names(tmp), .names)+ #' |
|||
| 234 | -1187x | +|||
| 1244 | +
- nonna <- which(!is.na(pos))+ #' # it's also possible to access multiple values by being less specific |
|||
| 235 | -1187x | +|||
| 1245 | +
- .row_footnotes[pos] <- tmp[nonna]+ #' cell_values( |
|||
| 236 | +1246 |
- # length(.row_footnotes) <- length(l2)+ #' tbl, c("RACE", "ASIAN", "STRATA1"),
|
||
| 237 | +1247 |
- }+ #' c("ARM", "A: Drug X", "SEX", "F")
|
||
| 238 | -5775x | +|||
| 1248 | +
- ret <- RowsVerticalSection(l2,+ #' ) |
|||
| 239 | -5775x | +|||
| 1249 | +
- names = .names,+ #' cell_values(tbl, c("RACE", "ASIAN"), c("ARM", "A: Drug X", "SEX", "M"))
|
|||
| 240 | -5775x | +|||
| 1250 | +
- labels = .labels,+ #' |
|||
| 241 | -5775x | +|||
| 1251 | +
- indent_mods = .indent_mods,+ #' ## any arm, male columns from the ASIAN content (i.e. summary) row |
|||
| 242 | -5775x | +|||
| 1252 | +
- formats = .formats,+ #' cell_values( |
|||
| 243 | -5775x | +|||
| 1253 | +
- footnotes = .row_footnotes,+ #' tbl, c("RACE", "ASIAN", "@content"),
|
|||
| 244 | -5775x | +|||
| 1254 | +
- format_na_strs = .format_na_strs+ #' c("ARM", "B: Placebo", "SEX", "M")
|
|||
| 245 | +1255 |
- )+ #' ) |
||
| 246 | +1256 |
- ## if(!is.null(.names))+ #' cell_values( |
||
| 247 | +1257 |
- ## names(l2) <- .names+ #' tbl, c("RACE", "ASIAN", "@content"),
|
||
| 248 | +1258 |
- ## else+ #' c("ARM", "*", "SEX", "M")
|
||
| 249 | +1259 |
- ## names(l2) <- names(l)+ #' ) |
||
| 250 | -! | +|||
| 1260 | +
- if (length(ret) == 0) NULL else ret+ #' |
|||
| 251 | +1261 |
-
+ #' ## all columns |
||
| 252 | +1262 |
- ## if (length(l) == 0) NULL else l+ #' cell_values(tbl, c("RACE", "ASIAN", "STRATA1", "B"))
|
||
| 253 | +1263 |
- }+ #' |
||
| 254 | +1264 |
-
+ #' ## all columns for the Combination arm |
||
| 255 | +1265 |
- .validate_nms <- function(vals, .stats, arg) {
+ #' cell_values( |
||
| 256 | -268x | +|||
| 1266 | +
- if (!is.null(arg)) {
+ #' tbl, c("RACE", "ASIAN", "STRATA1", "B"),
|
|||
| 257 | -112x | +|||
| 1267 | +
- if (is.null(names(arg))) {
+ #' c("ARM", "C: Combination")
|
|||
| 258 | -! | +|||
| 1268 | +
- stopifnot(length(arg) == length(.stats))+ #' ) |
|||
| 259 | -! | +|||
| 1269 | +
- names(arg) <- names(vals)+ #' |
|||
| 260 | +1270 |
- } else {
+ #' cvlist <- cell_values( |
||
| 261 | -112x | +|||
| 1271 | +
- lblpos <- match(names(arg), names(vals))+ #' tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"),
|
|||
| 262 | -112x | +|||
| 1272 | +
- stopifnot(!anyNA(lblpos))+ #' c("ARM", "B: Placebo", "SEX", "M")
|
|||
| 263 | +1273 |
- }+ #' ) |
||
| 264 | +1274 |
- }+ #' cvnolist <- value_at( |
||
| 265 | -268x | +|||
| 1275 | +
- arg+ #' tbl, c("RACE", "ASIAN", "STRATA1", "B", "AGE", "Mean"),
|
|||
| 266 | +1276 |
- }+ #' c("ARM", "B: Placebo", "SEX", "M")
|
||
| 267 | +1277 |
-
+ #' ) |
||
| 268 | +1278 |
- #' Create a custom analysis function wrapping an existing function+ #' stopifnot(identical(cvlist[[1]], cvnolist)) |
||
| 269 | +1279 |
#' |
||
| 270 | +1280 |
- #' @param fun (`function`)\cr the function to be wrapped in a new customized analysis function.+ #' @rdname cell_values |
||
| 271 | +1281 |
- #' `fun` should return a named `list`.+ #' @export |
||
| 272 | +1282 |
- #' @param .stats (`character`)\cr names of elements to keep from `fun`'s full output.+ setGeneric("cell_values", function(tt, rowpath = NULL, colpath = NULL, omit_labrows = TRUE) {
|
||
| 273 | -+ | |||
| 1283 | +170x |
- #' @param .formats (`ANY`)\cr vector or list of formats to override any defaults applied by `fun`.+ standardGeneric("cell_values")
|
||
| 274 | +1284 |
- #' @param .labels (`character`)\cr vector of labels to override defaults returned by `fun`.+ }) |
||
| 275 | +1285 |
- #' @param .indent_mods (`integer`)\cr named vector of indent modifiers for the generated rows.+ |
||
| 276 | +1286 |
- #' @param .ungroup_stats (`character`)\cr vector of names, which must match elements of `.stats`.+ #' @rdname int_methods |
||
| 277 | +1287 |
- #' @param ... additional arguments to `fun` which effectively become new defaults. These can still be+ #' @keywords internal |
||
| 278 | +1288 |
- #' overridden by `extra_args` within a split.+ #' @exportMethod cell_values |
||
| 279 | +1289 |
- #' @param .null_ref_cells (`flag`)\cr whether cells for the reference column should be `NULL`-ed by the+ setMethod( |
||
| 280 | +1290 |
- #' returned analysis function. Defaults to `TRUE` if `fun` accepts `.in_ref_col` as a formal argument. Note+ "cell_values", "VTableTree", |
||
| 281 | +1291 |
- #' this argument occurs after `...` so it must be *fully* specified by name when set.+ function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
|
||
| 282 | -+ | |||
| 1292 | +167x |
- #' @param .format_na_strs (`ANY`)\cr vector/list of `NA` strings to override any defaults applied by `fun`.+ .inner_cell_value(tt, |
||
| 283 | -+ | |||
| 1293 | +167x |
- #'+ rowpath = rowpath, colpath = colpath, |
||
| 284 | -+ | |||
| 1294 | +167x |
- #' @return A function suitable for use in [analyze()] with element selection, reformatting, and relabeling+ omit_labrows = omit_labrows, value_at = FALSE |
||
| 285 | +1295 |
- #' performed automatically.+ ) |
||
| 286 | +1296 |
- #'+ } |
||
| 287 | +1297 |
- #' @note+ ) |
||
| 288 | +1298 |
- #' Setting `.ungroup_stats` to non-`NULL` changes the *structure* of the value(s) returned by `fun`, rather than+ |
||
| 289 | +1299 |
- #' just labeling (`.labels`), formatting (`.formats`), and selecting amongst (`.stats`) them. This means that+ #' @rdname int_methods |
||
| 290 | +1300 |
- #' subsequent `make_afun` calls to customize the output further both can and must operate on the new structure,+ #' @keywords internal |
||
| 291 | +1301 |
- #' *not* the original structure returned by `fun`. See the final pair of examples below.+ #' @exportMethod cell_values |
||
| 292 | +1302 |
- #'+ setMethod( |
||
| 293 | +1303 |
- #' @seealso [analyze()]+ "cell_values", "TableRow", |
||
| 294 | +1304 |
- #'+ function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
|
||
| 295 | -+ | |||
| 1305 | +2x |
- #' @examples+ if (!is.null(rowpath)) {
|
||
| 296 | -+ | |||
| 1306 | +1x |
- #' s_summary <- function(x) {
+ stop("cell_values on TableRow objects must have NULL rowpath")
|
||
| 297 | +1307 |
- #' stopifnot(is.numeric(x))+ } |
||
| 298 | -+ | |||
| 1308 | +1x |
- #'+ .inner_cell_value(tt, |
||
| 299 | -+ | |||
| 1309 | +1x |
- #' list(+ rowpath = rowpath, colpath = colpath, |
||
| 300 | -+ | |||
| 1310 | +1x |
- #' n = sum(!is.na(x)),+ omit_labrows = omit_labrows, value_at = FALSE |
||
| 301 | +1311 |
- #' mean_sd = c(mean = mean(x), sd = sd(x)),+ ) |
||
| 302 | +1312 |
- #' min_max = range(x)+ } |
||
| 303 | +1313 |
- #' )+ ) |
||
| 304 | +1314 |
- #' }+ |
||
| 305 | +1315 |
- #'+ #' @rdname int_methods |
||
| 306 | +1316 |
- #' s_summary(iris$Sepal.Length)+ #' @keywords internal |
||
| 307 | +1317 |
- #'+ #' @exportMethod cell_values |
||
| 308 | +1318 |
- #' a_summary <- make_afun(+ setMethod( |
||
| 309 | +1319 |
- #' fun = s_summary,+ "cell_values", "LabelRow", |
||
| 310 | +1320 |
- #' .formats = c(n = "xx", mean_sd = "xx.xx (xx.xx)", min_max = "xx.xx - xx.xx"),+ function(tt, rowpath, colpath = NULL, omit_labrows = TRUE) {
|
||
| 311 | -+ | |||
| 1321 | +1x |
- #' .labels = c(n = "n", mean_sd = "Mean (sd)", min_max = "min - max")+ stop("calling cell_values on LabelRow is not meaningful")
|
||
| 312 | +1322 |
- #' )+ } |
||
| 313 | +1323 |
- #'+ ) |
||
| 314 | +1324 |
- #' a_summary(x = iris$Sepal.Length)+ |
||
| 315 | +1325 |
- #'+ #' @rdname cell_values |
||
| 316 | +1326 |
- #' a_summary2 <- make_afun(a_summary, .stats = c("n", "mean_sd"))
+ #' @export |
||
| 317 | +1327 |
- #'+ setGeneric("value_at", function(tt, rowpath = NULL, colpath = NULL) {
|
||
| 318 | -+ | |||
| 1328 | +8x |
- #' a_summary2(x = iris$Sepal.Length)+ standardGeneric("value_at")
|
||
| 319 | +1329 |
- #'+ }) |
||
| 320 | +1330 |
- #' a_summary3 <- make_afun(a_summary, .formats = c(mean_sd = "(xx.xxx, xx.xxx)"))+ |
||
| 321 | +1331 |
- #'+ #' @rdname cell_values |
||
| 322 | +1332 |
- #' s_foo <- function(df, .N_col, a = 1, b = 2) {
+ #' @exportMethod value_at |
||
| 323 | +1333 |
- #' list(+ setMethod( |
||
| 324 | +1334 |
- #' nrow_df = nrow(df),+ "value_at", "VTableTree", |
||
| 325 | +1335 |
- #' .N_col = .N_col,+ function(tt, rowpath, colpath = NULL) {
|
||
| 326 | -+ | |||
| 1336 | +7x |
- #' a = a,+ .inner_cell_value(tt, |
||
| 327 | -+ | |||
| 1337 | +7x |
- #' b = b+ rowpath = rowpath, colpath = colpath, |
||
| 328 | -+ | |||
| 1338 | +7x |
- #' )+ omit_labrows = FALSE, value_at = TRUE |
||
| 329 | +1339 |
- #' }+ ) |
||
| 330 | +1340 |
- #'+ } |
||
| 331 | +1341 |
- #' s_foo(iris, 40)+ ) |
||
| 332 | +1342 |
- #'+ |
||
| 333 | +1343 |
- #' a_foo <- make_afun(s_foo,+ #' @rdname int_methods |
||
| 334 | +1344 |
- #' b = 4,+ #' @keywords internal |
||
| 335 | +1345 |
- #' .formats = c(nrow_df = "xx.xx", ".N_col" = "xx.", a = "xx", b = "xx.x"),+ #' @exportMethod value_at |
||
| 336 | +1346 |
- #' .labels = c(+ setMethod( |
||
| 337 | +1347 |
- #' nrow_df = "Nrow df",+ "value_at", "TableRow", |
||
| 338 | +1348 |
- #' ".N_col" = "n in cols", a = "a value", b = "b value"+ function(tt, rowpath, colpath = NULL) {
|
||
| 339 | -+ | |||
| 1349 | +1x |
- #' ),+ .inner_cell_value(tt, |
||
| 340 | -+ | |||
| 1350 | +1x |
- #' .indent_mods = c(nrow_df = 2L, a = 1L)+ rowpath = rowpath, colpath = colpath, |
||
| 341 | -+ | |||
| 1351 | +1x |
- #' )+ omit_labrows = FALSE, value_at = TRUE |
||
| 342 | +1352 |
- #'+ ) |
||
| 343 | +1353 |
- #' a_foo(iris, .N_col = 40)+ } |
||
| 344 | +1354 |
- #' a_foo2 <- make_afun(a_foo, .labels = c(nrow_df = "Number of Rows"))+ ) |
||
| 345 | +1355 |
- #' a_foo2(iris, .N_col = 40)+ |
||
| 346 | +1356 |
- #'+ #' @rdname int_methods |
||
| 347 | +1357 |
- #' # grouping and further customization+ #' @keywords internal |
||
| 348 | +1358 |
- #' s_grp <- function(df, .N_col, a = 1, b = 2) {
+ #' @exportMethod value_at |
||
| 349 | +1359 |
- #' list(+ setMethod( |
||
| 350 | +1360 |
- #' nrow_df = nrow(df),+ "value_at", "LabelRow", |
||
| 351 | +1361 |
- #' .N_col = .N_col,+ function(tt, rowpath, colpath = NULL) {
|
||
| 352 | -+ | |||
| 1362 | +! |
- #' letters = list(+ stop("calling value_at for LabelRow objects is not meaningful")
|
||
| 353 | +1363 |
- #' a = a,+ } |
||
| 354 | +1364 |
- #' b = b+ ) |
||
| 355 | +1365 |
- #' )+ |
||
| 356 | +1366 |
- #' )+ .inner_cell_value <- function(tt, |
||
| 357 | +1367 |
- #' }+ rowpath, |
||
| 358 | +1368 |
- #' a_grp <- make_afun(s_grp,+ colpath = NULL, |
||
| 359 | +1369 |
- #' b = 3,+ omit_labrows = TRUE, |
||
| 360 | +1370 |
- #' .labels = c(+ value_at = FALSE) {
|
||
| 361 | -+ | |||
| 1371 | +176x |
- #' nrow_df = "row count",+ if (is.null(rowpath)) {
|
||
| 362 | -+ | |||
| 1372 | +97x |
- #' .N_col = "count in column"+ subtree <- tt |
||
| 363 | +1373 |
- #' ),+ } else {
|
||
| 364 | -+ | |||
| 1374 | +79x |
- #' .formats = c(nrow_df = "xx.", .N_col = "xx."),+ subtree <- tt_at_path(tt, rowpath) |
||
| 365 | +1375 |
- #' .indent_mods = c(letters = 1L),+ } |
||
| 366 | -+ | |||
| 1376 | +175x |
- #' .ungroup_stats = "letters"+ if (!is.null(colpath)) {
|
||
| 367 | -+ | |||
| 1377 | +28x |
- #' )+ subtree <- subset_cols(subtree, colpath) |
||
| 368 | +1378 |
- #' a_grp(iris, 40)+ } |
||
| 369 | +1379 |
- #' a_aftergrp <- make_afun(a_grp,+ |
||
| 370 | -+ | |||
| 1380 | +175x |
- #' .stats = c("nrow_df", "b"),
+ rows <- collect_leaves(subtree, TRUE, !omit_labrows) |
||
| 371 | -+ | |||
| 1381 | +175x |
- #' .formats = c(b = "xx.")+ if (value_at && (ncol(subtree) != 1 || length(rows) != 1)) {
|
||
| 372 | -+ | |||
| 1382 | +3x |
- #' )+ stop("Combination of rowpath and colpath does not select individual cell.\n",
|
||
| 373 | -+ | |||
| 1383 | +3x |
- #' a_aftergrp(iris, 40)+ " To retrieve more than one cell value at a time use cell_values().", |
||
| 374 | -+ | |||
| 1384 | +3x |
- #'+ call. = FALSE |
||
| 375 | +1385 |
- #' s_ref <- function(x, .in_ref_col, .ref_group) {
+ ) |
||
| 376 | +1386 |
- #' list(+ } |
||
| 377 | -+ | |||
| 1387 | +172x |
- #' mean_diff = mean(x) - mean(.ref_group)+ if (length(rows) == 1) {
|
||
| 378 | -+ | |||
| 1388 | +93x |
- #' )+ ret <- row_values(rows[[1]]) |
||
| 379 | -+ | |||
| 1389 | +93x |
- #' }+ if (value_at && ncol(subtree) == 1) {
|
||
| 380 | -+ | |||
| 1390 | +5x |
- #'+ ret <- ret[[1]] |
||
| 381 | +1391 |
- #' a_ref <- make_afun(s_ref,+ } |
||
| 382 | -+ | |||
| 1392 | +93x |
- #' .labels = c(mean_diff = "Mean Difference from Ref")+ ret |
||
| 383 | +1393 |
- #' )+ } else {
|
||
| 384 | -+ | |||
| 1394 | +79x |
- #' a_ref(iris$Sepal.Length, .in_ref_col = TRUE, 1:10)+ lapply(rows, row_values) |
||
| 385 | +1395 |
- #' a_ref(iris$Sepal.Length, .in_ref_col = FALSE, 1:10)+ } |
||
| 386 | +1396 |
- #'+ } |
||
| 387 | +1397 |
- #' @export+ |
||
| 388 | +1398 |
- make_afun <- function(fun,+ ## empty_table is created in onLoad because it depends on other things there. |
||
| 389 | +1399 |
- .stats = NULL,+ |
||
| 390 | +1400 |
- .formats = NULL,+ # Helper function to copy or not header, footer, and topleft information |
||
| 391 | +1401 |
- .labels = NULL,+ .h_copy_titles_footers_topleft <- function(new, |
||
| 392 | +1402 |
- .indent_mods = NULL,+ old, |
||
| 393 | +1403 |
- .ungroup_stats = NULL,+ keep_titles, |
||
| 394 | +1404 |
- .format_na_strs = NULL,+ keep_footers, |
||
| 395 | +1405 |
- ...,+ keep_topleft, |
||
| 396 | +1406 |
- .null_ref_cells = ".in_ref_col" %in% names(formals(fun))) {
+ reindex_refs = FALSE, |
||
| 397 | +1407 |
- ## there is a LOT more computing-on-the-language hackery in here that I+ empt_tbl = empty_table) {
|
||
| 398 | +1408 |
- ## would prefer, but currently this is the way I see to do everything we+ ## Please note that the standard adopted come from an empty table |
||
| 399 | +1409 |
- ## want to do.+ |
||
| 400 | +1410 |
-
+ # titles |
||
| 401 | -+ | |||
| 1411 | +2886x |
- ## too clever by three-quarters (because half wasn't enough)+ if (isTRUE(keep_titles)) {
+ |
+ ||
| 1412 | +2712x | +
+ main_title(new) <- main_title(old)+ |
+ ||
| 1413 | +2712x | +
+ subtitles(new) <- subtitles(old) |
||
| 402 | +1414 |
- ## gross scope hackery+ } else {
|
||
| 403 | -23x | +1415 | +174x |
- fun_args <- force(list(...))+ main_title(new) <- main_title(empt_tbl) |
| 404 | -23x | +1416 | +174x |
- fun_fnames <- names(formals(fun))+ subtitles(new) <- subtitles(empt_tbl) |
| 405 | +1417 |
-
+ } |
||
| 406 | +1418 |
- ## force EVERYTHING otherwise calling this within loops is the stuff of+ |
||
| 407 | +1419 |
- ## nightmares+ # fnotes |
||
| 408 | -23x | +1420 | +2886x |
- force(.stats)+ if (isTRUE(keep_footers)) {
|
| 409 | -23x | +1421 | +2718x |
- force(.formats)+ main_footer(new) <- main_footer(old) |
| 410 | -23x | +1422 | +2718x |
- force(.format_na_strs)+ prov_footer(new) <- prov_footer(old) |
| 411 | -23x | +|||
| 1423 | +
- force(.labels)+ } else {
|
|||
| 412 | -23x | +1424 | +168x |
- force(.indent_mods)+ main_footer(new) <- main_footer(empt_tbl) |
| 413 | -23x | +1425 | +168x |
- force(.ungroup_stats)+ prov_footer(new) <- prov_footer(empt_tbl)+ |
+
| 1426 | ++ |
+ }+ |
+ ||
| 1427 | ++ | + + | +||
| 1428 | ++ |
+ # topleft |
||
| 414 | -23x | +1429 | +2886x |
- force(.null_ref_cells) ## this one probably isn't needed?+ if (isTRUE(keep_topleft)) {
+ |
+
| 1430 | +2738x | +
+ top_left(new) <- top_left(old) |
||
| 415 | +1431 | ++ |
+ } else {
+ |
+ |
| 1432 | +148x | +
+ top_left(new) <- top_left(empt_tbl)+ |
+ ||
| 1433 | ++ |
+ }+ |
+ ||
| 1434 | ||||
| 1435 | ++ |
+ # reindex references+ |
+ ||
| 416 | -23x | +1436 | +2886x |
- ret <- function(x, ...) { ## remember formals get clobbered here
+ if (reindex_refs) {
+ |
+
| 1437 | +! | +
+ new <- update_ref_indexing(new) |
||
| 417 | +1438 | ++ |
+ }+ |
+ |
| 1439 | ||||
| 1440 | +2886x | +
+ new+ |
+ ||
| 418 | +1441 |
- ## this helper will grab the value and wrap it in a named list if+ } |
||
| 419 | +1442 |
- ## we need the variable and return list() otherwise.+ |
||
| 420 | +1443 |
- ## We define it in here so that the scoping hackery works correctly+ #' Head and tail methods+ |
+ ||
| 1444 | ++ |
+ #'+ |
+ ||
| 1445 | ++ |
+ #' @inheritParams utils::head+ |
+ ||
| 1446 | ++ |
+ #' @param keep_topleft (`flag`)\cr if `TRUE` (the default), top_left material for the table will be carried over to the+ |
+ ||
| 1447 | ++ |
+ #' subset.+ |
+ ||
| 1448 | ++ |
+ #' @param keep_titles (`flag`)\cr if `TRUE` (the default), all title material for the table will be carried over to the+ |
+ ||
| 1449 | ++ |
+ #' subset.+ |
+ ||
| 1450 | ++ |
+ #' @param keep_footers (`flag`)\cr if `TRUE`, all footer material for the table will be carried over to the subset. It+ |
+ ||
| 1451 | ++ |
+ #' defaults to `keep_titles`.+ |
+ ||
| 1452 | ++ |
+ #' @param reindex_refs (`flag`)\cr defaults to `FALSE`. If `TRUE`, referential footnotes will be reindexed for the+ |
+ ||
| 1453 | ++ |
+ #' subset.+ |
+ ||
| 1454 | ++ |
+ #'+ |
+ ||
| 1455 | ++ |
+ #' @docType methods+ |
+ ||
| 1456 | ++ |
+ #' @export+ |
+ ||
| 1457 | ++ |
+ #' @rdname head_tail+ |
+ ||
| 1458 | ++ |
+ setGeneric("head")
+ |
+ ||
| 1459 | ++ | + + | +||
| 1460 | ++ |
+ #' @docType methods+ |
+ ||
| 1461 | ++ |
+ #' @export+ |
+ ||
| 1462 | ++ |
+ #' @rdname head_tail+ |
+ ||
| 1463 | ++ |
+ setMethod(+ |
+ ||
| 1464 | ++ |
+ "head", "VTableTree",+ |
+ ||
| 1465 | ++ |
+ function(x, n = 6, ..., keep_topleft = TRUE,+ |
+ ||
| 1466 | ++ |
+ keep_titles = TRUE,+ |
+ ||
| 1467 | ++ |
+ keep_footers = keep_titles,+ |
+ ||
| 1468 | ++ |
+ ## FALSE because this is a glance+ |
+ ||
| 1469 | ++ |
+ ## more often than a subset op+ |
+ ||
| 1470 | ++ |
+ reindex_refs = FALSE) {
+ |
+ ||
| 1471 | ++ |
+ ## default |
||
| 421 | -66x | +1472 | +5x |
- .if_in_formals <- function(nm, ifnot = list(), named_lwrap = TRUE) {
+ res <- callNextMethod() |
| 422 | -660x | +1473 | +5x |
- val <- if (nm %in% fun_fnames) get(nm) else ifnot+ res <- .h_copy_titles_footers_topleft( |
| 423 | -660x | +1474 | +5x |
- if (named_lwrap && !identical(val, ifnot)) {
+ old = x, new = res, |
| 424 | -78x | +1475 | +5x |
- setNames(list(val), nm)+ keep_topleft = keep_topleft,+ |
+
| 1476 | +5x | +
+ keep_titles = keep_titles,+ |
+ ||
| 1477 | +5x | +
+ keep_footers = keep_footers,+ |
+ ||
| 1478 | +5x | +
+ reindex_refs = reindex_refs |
||
| 425 | +1479 |
- } else {
+ ) |
||
| 426 | -582x | +1480 | +5x |
- val+ res |
| 427 | +1481 |
- }+ } |
||
| 428 | +1482 |
- }+ ) |
||
| 429 | +1483 | |||
| 430 | -66x | +|||
| 1484 | +
- custargs <- fun_args+ #' @docType methods |
|||
| 431 | +1485 | ++ |
+ #' @export+ |
+ |
| 1486 | ++ |
+ #' @rdname head_tail+ |
+ ||
| 1487 | ++ |
+ setGeneric("tail")
+ |
+ ||
| 1488 | ||||
| 432 | +1489 |
- ## special handling cause I need it at the bottom as well+ #' @docType methods |
||
| 433 | -66x | +|||
| 1490 | +
- in_rc_argl <- .if_in_formals(".in_ref_col")
+ #' @export |
|||
| 434 | -66x | +|||
| 1491 | +
- .in_ref_col <- if (length(in_rc_argl) > 0) in_rc_argl[[1]] else FALSE+ #' @rdname head_tail |
|||
| 435 | +1492 |
-
+ setMethod( |
||
| 436 | -66x | +|||
| 1493 | +
- sfunargs <- c(+ "tail", "VTableTree", |
|||
| 437 | +1494 |
- ## these are either named lists containing the arg, or list()+ function(x, n = 6, ..., keep_topleft = TRUE, |
||
| 438 | +1495 |
- ## depending on whether fun accept the argument or not+ keep_titles = TRUE, |
||
| 439 | -66x | +|||
| 1496 | +
- .if_in_formals("x"),
+ keep_footers = keep_titles, |
|||
| 440 | -66x | +|||
| 1497 | +
- .if_in_formals("df"),
+ ## FALSE because this is a glance |
|||
| 441 | -66x | +|||
| 1498 | +
- .if_in_formals(".N_col"),
+ ## more often than a subset op+ |
+ |||
| 1499 | ++ |
+ reindex_refs = FALSE) {
|
||
| 442 | -66x | +1500 | +4x |
- .if_in_formals(".N_total"),
+ res <- callNextMethod() |
| 443 | -66x | +1501 | +4x |
- .if_in_formals(".N_row"),
+ res <- .h_copy_titles_footers_topleft( |
| 444 | -66x | +1502 | +4x |
- .if_in_formals(".ref_group"),
+ old = x, new = res, |
| 445 | -66x | +1503 | +4x |
- in_rc_argl,+ keep_topleft = keep_topleft, |
| 446 | -66x | +1504 | +4x |
- .if_in_formals(".df_row"),
+ keep_titles = keep_titles, |
| 447 | -66x | +1505 | +4x |
- .if_in_formals(".var"),
+ keep_footers = keep_footers, |
| 448 | -66x | +1506 | +4x |
- .if_in_formals(".ref_full")
+ reindex_refs = reindex_refs |
| 449 | +1507 |
) |
||
| 1508 | +4x | +
+ res+ |
+ ||
| 450 | +1509 |
-
+ } |
||
| 451 | -66x | +|||
| 1510 | +
- allvars <- setdiff(fun_fnames, c("...", names(sfunargs)))
+ ) |
| 452 | +1 |
- ## values int he actual call to this function override customization+ #' Score functions for sorting `TableTrees` |
||
| 453 | +2 |
- ## done by the constructor. evalparse is to avoid a "... in wrong context" NOTE+ #'+ |
+ ||
| 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) {
|
||
| 454 | -66x | +10 | +6x |
- if ("..." %in% fun_fnames) {
+ ctab <- content_table(tt) |
| 455 | -5x | +11 | +6x |
- exargs <- eval(parser_helper(text = "list(...)"))+ if (NROW(ctab) == 0) {
|
| 456 | -5x | +12 | +2x |
- custargs[names(exargs)] <- exargs+ stop( |
| 457 | -5x | +13 | +2x |
- allvars <- unique(c(allvars, names(custargs)))+ "cont_n_allcols score function used at subtable [",+ |
+
| 14 | +2x | +
+ obj_name(tt), "] that has no content table." |
||
| 458 | +15 |
- }+ ) |
||
| 459 | +16 |
-
+ } |
||
| 460 | -66x | +17 | +4x |
- for (var in allvars) {
+ sum(sapply(+ |
+
| 18 | +4x | +
+ row_values(tree_children(ctab)[[1]]),+ |
+ ||
| 19 | +4x | +
+ function(cv) cv[1] |
||
| 461 | +20 |
- ## not missing, i.e. specified in the direct call, takes precedence+ ))+ |
+ ||
| 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/latest-tag/articles/sorting_pruning.html)+ |
+ ||
| 27 | ++ |
+ #' vignette.+ |
+ ||
| 28 | ++ |
+ #'+ |
+ ||
| 29 | ++ |
+ #' @export+ |
+ ||
| 30 | ++ |
+ #' @rdname score_funs+ |
+ ||
| 31 | ++ |
+ cont_n_onecol <- function(j) {
|
||
| 462 | -22x | +32 | +2x |
- if (var %in% fun_fnames && eval(parser_helper(text = paste0("!missing(", var, ")")))) {
+ function(tt) {
|
| 463 | -5x | +33 | +6x |
- sfunargs[[var]] <- get(var)+ ctab <- content_table(tt) |
| 464 | -17x | +34 | +6x |
- } else if (var %in% names(custargs)) { ## not specified in the call, but specified in the constructor
+ if (NROW(ctab) == 0) {
|
| 465 | -4x | +35 | +2x |
- sfunargs[[var]] <- custargs[[var]]+ stop(+ |
+
| 36 | +2x | +
+ "cont_n_allcols score function used at subtable [",+ |
+ ||
| 37 | +2x | +
+ obj_name(tt), "] that has no content table." |
||
| 466 | +38 |
- }+ ) |
||
| 467 | +39 |
- ## else left out so we hit the original default we inherited from fun+ }+ |
+ ||
| 40 | +4x | +
+ row_values(tree_children(ctab)[[1]])[[j]][1] |
||
| 468 | +41 |
- }+ } |
||
| 469 | +42 | ++ |
+ }+ |
+ |
| 43 | ||||
| 470 | -66x | +|||
| 44 | +
- rawvals <- do.call(fun, sfunargs)+ #' Sorting a table at a specific path |
|||
| 471 | +45 |
-
+ #' |
||
| 472 | +46 |
- ## note single brackets here so its a list+ #' Main sorting function to order the sub-structure of a `TableTree` at a particular path in the table tree. |
||
| 473 | +47 |
- ## no matter what. thats important!+ #' |
||
| 474 | -66x | +|||
| 48 | +
- final_vals <- if (is.null(.stats)) rawvals else rawvals[.stats]+ #' @inheritParams gen_args |
|||
| 475 | +49 |
-
+ #' @param scorefun (`function`)\cr scoring function. Should accept the type of children directly under the position |
||
| 476 | -66x | +|||
| 50 | +
- if (!is.list(rawvals)) {
+ #' at `path` (either `VTableTree`, `VTableRow`, or `VTableNodeInfo`, which covers both) and return a numeric value |
|||
| 477 | -! | +|||
| 51 | +
- stop("make_afun expects a function fun that always returns a list")
+ #' to be sorted. |
|||
| 478 | +52 |
- }+ #' @param decreasing (`flag`)\cr whether the scores generated by `scorefun` should be sorted in decreasing order. If |
||
| 479 | -66x | +|||
| 53 | +
- if (!is.null(.stats)) {
+ #' unset (the default of `NA`), it is set to `TRUE` if the generated scores are numeric and `FALSE` if they are |
|||
| 480 | -10x | +|||
| 54 | +
- stopifnot(all(.stats %in% names(rawvals)))+ #' characters. |
|||
| 481 | +55 |
- } else {
+ #' @param na.pos (`string`)\cr what should be done with children (sub-trees/rows) with `NA` scores. Defaults to |
||
| 482 | -56x | +|||
| 56 | +
- .stats <- names(rawvals)+ #' `"omit"`, which removes them. Other allowed values are `"last"` and `"first"`, which indicate where `NA` scores |
|||
| 483 | +57 |
- }+ #' should be placed in the order. |
||
| 484 | -66x | +|||
| 58 | +
- if (!is.null(.ungroup_stats) && !all(.ungroup_stats %in% .stats)) {
+ #' @param .prev_path (`character`)\cr internal detail, do not set manually. |
|||
| 485 | -! | +|||
| 59 | +
- stop(+ #' |
|||
| 486 | -! | +|||
| 60 | +
- "Stats specified for ungrouping not included in non-null .stats list: ",+ #' @return A `TableTree` with the same structure as `tt` with the exception that the requested sorting has been done |
|||
| 487 | -! | +|||
| 61 | +
- setdiff(.ungroup_stats, .stats)+ #' at `path`. |
|||
| 488 | +62 |
- )+ #' |
||
| 489 | +63 |
- }+ #' @details |
||
| 490 | +64 |
-
+ #' `sort_at_path`, given a path, locates the (sub)table(s) described by the path (see below for handling of the `"*"` |
||
| 491 | -66x | +|||
| 65 | +
- .labels <- .validate_nms(final_vals, .stats, .labels)+ #' wildcard). For each such subtable, it then calls `scorefun` on each direct child of the table, using the resulting |
|||
| 492 | -66x | +|||
| 66 | +
- .formats <- .validate_nms(final_vals, .stats, .formats)+ #' scores to determine their sorted order. `tt` is then modified to reflect each of these one or more sorting |
|||
| 493 | -66x | +|||
| 67 | +
- .indent_mods <- .validate_nms(final_vals, .stats, .indent_mods)+ #' operations. |
|||
| 494 | -66x | +|||
| 68 | +
- .format_na_strs <- .validate_nms(final_vals, .stats, .format_na_strs)+ #' |
|||
| 495 | +69 |
-
+ #' In `path`, a leading `"root"` element will be ignored, regardless of whether this matches the object name (and thus |
||
| 496 | -66x | +|||
| 70 | +
- final_labels <- value_labels(final_vals)+ #' actual root path name) of `tt`. Including `"root"` in paths where it does not match the name of `tt` may mask deeper |
|||
| 497 | -66x | +|||
| 71 | +
- final_labels[names(.labels)] <- .labels+ #' misunderstandings of how valid paths within a `TableTree` object correspond to the layout used to originally declare |
|||
| 498 | +72 |
-
+ #' it, which we encourage users to avoid. |
||
| 499 | -66x | +|||
| 73 | +
- final_formats <- lapply(final_vals, obj_format)+ #' |
|||
| 500 | -66x | +|||
| 74 | +
- final_formats[names(.formats)] <- .formats+ #' `path` can include the "wildcard" `"*"` as a step, which translates roughly to *any* node/branching element and means |
|||
| 501 | +75 |
-
+ #' that each child at that step will be *separately* sorted based on `scorefun` and the remaining `path` entries. This |
||
| 502 | -66x | +|||
| 76 | +
- final_format_na_strs <- lapply(final_vals, obj_na_str)+ #' can occur multiple times in a path. |
|||
| 503 | -66x | +|||
| 77 | +
- final_format_na_strs[names(.format_na_strs)] <- .format_na_strs+ #' |
|||
| 504 | +78 |
-
+ #' A list of valid (non-wildcard) paths can be seen in the `path` column of the `data.frame` created by |
||
| 505 | -66x | +|||
| 79 | +
- if (is(final_vals, "RowsVerticalSection")) {
+ #' [formatters::make_row_df()] with the `visible_only` argument set to `FALSE`. It can also be inferred from the |
|||
| 506 | -20x | +|||
| 80 | +
- final_imods <- indent_mod(final_vals)+ #' summary given by [table_structure()]. |
|||
| 507 | +81 |
- } else {
+ #' |
||
| 508 | -46x | +|||
| 82 | +
- final_imods <- vapply(final_vals, indent_mod, 1L)+ #' Note that sorting needs a deeper understanding of table structure in `rtables`. Please consider reading the related |
|||
| 509 | +83 |
- }+ #' vignette |
||
| 510 | -66x | +|||
| 84 | +
- final_imods[names(.indent_mods)] <- .indent_mods+ #' ([Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html)) |
|||
| 511 | +85 |
-
+ #' and explore table structure with useful functions like [table_structure()] and [row_paths_summary()]. It is also |
||
| 512 | -66x | +|||
| 86 | +
- if (!is.null(.ungroup_stats)) {
+ #' very important to understand the difference between "content" rows and "data" rows. The first one analyzes and |
|||
| 513 | -2x | +|||
| 87 | +
- for (nm in .ungroup_stats) {
+ #' describes the split variable generally and is generated with [summarize_row_groups()], while the second one is |
|||
| 514 | -3x | +|||
| 88 | +
- tmp <- final_vals[[nm]]+ #' commonly produced by calling one of the various [analyze()] instances.+ |
+ |||
| 89 | ++ |
+ #'+ |
+ ||
| 90 | ++ |
+ #' Built-in score functions are [cont_n_allcols()] and [cont_n_onecol()]. They are both working with content rows+ |
+ ||
| 91 | ++ |
+ #' (coming from [summarize_row_groups()]) while a custom score function needs to be used on `DataRow`s. Here, some+ |
+ ||
| 92 | ++ |
+ #' useful descriptor and accessor functions (coming from related vignette):+ |
+ ||
| 93 | ++ |
+ #' - [cell_values()] - Retrieves a named list of a `TableRow` or `TableTree` object's values.+ |
+ ||
| 94 | ++ |
+ #' - [formatters::obj_name()] - Retrieves the name of an object. Note this can differ from the label that is+ |
+ ||
| 95 | ++ |
+ #' displayed (if any is) when printing.+ |
+ ||
| 96 | ++ |
+ #' - [formatters::obj_label()] - Retrieves the display label of an object. Note this can differ from the name that+ |
+ ||
| 97 | ++ |
+ #' appears in the path.+ |
+ ||
| 98 | ++ |
+ #' - [content_table()] - Retrieves a `TableTree` object's content table (which contains its summary rows).+ |
+ ||
| 99 | ++ |
+ #' - [tree_children()] - Retrieves a `TableTree` object's direct children (either subtables, rows or possibly a mix+ |
+ ||
| 100 | ++ |
+ #' thereof, though that should not happen in practice).+ |
+ ||
| 101 | ++ |
+ #'+ |
+ ||
| 102 | ++ |
+ #' @seealso+ |
+ ||
| 103 | ++ |
+ #' * Score functions [cont_n_allcols()] and [cont_n_onecol()].+ |
+ ||
| 104 | ++ |
+ #' * [formatters::make_row_df()] and [table_structure()] for pathing information.+ |
+ ||
| 105 | ++ |
+ #' * [tt_at_path()] to select a table's (sub)structure at a given path.+ |
+ ||
| 106 | ++ |
+ #'+ |
+ ||
| 107 | ++ |
+ #' @examples+ |
+ ||
| 108 | ++ |
+ #' # Creating a table to sort+ |
+ ||
| 109 | ++ |
+ #'+ |
+ ||
| 110 | ++ |
+ #' # Function that gives two statistics per table-tree "leaf"+ |
+ ||
| 111 | ++ |
+ #' more_analysis_fnc <- function(x) {
+ |
+ ||
| 112 | ++ |
+ #' in_rows(+ |
+ ||
| 113 | ++ |
+ #' "median" = median(x),+ |
+ ||
| 114 | ++ |
+ #' "mean" = mean(x),+ |
+ ||
| 115 | ++ |
+ #' .formats = "xx.x"+ |
+ ||
| 116 | ++ |
+ #' )+ |
+ ||
| 117 | ++ |
+ #' }+ |
+ ||
| 118 | ++ |
+ #'+ |
+ ||
| 119 | ++ |
+ #' # Main layout of the table+ |
+ ||
| 120 | ++ |
+ #' raw_lyt <- basic_table() %>%+ |
+ ||
| 121 | ++ |
+ #' split_cols_by("ARM") %>%
+ |
+ ||
| 122 | ++ |
+ #' split_rows_by(+ |
+ ||
| 123 | ++ |
+ #' "RACE",+ |
+ ||
| 124 | ++ |
+ #' split_fun = drop_and_remove_levels("WHITE") # dropping WHITE levels
+ |
+ ||
| 125 | ++ |
+ #' ) %>%+ |
+ ||
| 126 | ++ |
+ #' summarize_row_groups() %>%+ |
+ ||
| 127 | ++ |
+ #' split_rows_by("STRATA1") %>%
+ |
+ ||
| 128 | ++ |
+ #' summarize_row_groups() %>%+ |
+ ||
| 129 | ++ |
+ #' analyze("AGE", afun = more_analysis_fnc)
+ |
+ ||
| 130 | ++ |
+ #'+ |
+ ||
| 131 | ++ |
+ #' # Creating the table and pruning empty and NAs+ |
+ ||
| 132 | ++ |
+ #' tbl <- build_table(raw_lyt, DM) %>%+ |
+ ||
| 133 | ++ |
+ #' prune_table()+ |
+ ||
| 134 | ++ |
+ #'+ |
+ ||
| 135 | ++ |
+ #' # Peek at the table structure to understand how it is built+ |
+ ||
| 136 | ++ |
+ #' table_structure(tbl)+ |
+ ||
| 137 | ++ |
+ #'+ |
+ ||
| 138 | ++ |
+ #' # Sorting only ASIAN sub-table, or, in other words, sorting STRATA elements for+ |
+ ||
| 139 | ++ |
+ #' # the ASIAN group/row-split. This uses content_table() accessor function as it+ |
+ ||
| 140 | ++ |
+ #' # is a "ContentRow". In this case, we also base our sorting only on the second column.+ |
+ ||
| 141 | ++ |
+ #' sort_at_path(tbl, c("ASIAN", "STRATA1"), cont_n_onecol(2))
+ |
+ ||
| 142 | ++ |
+ #'+ |
+ ||
| 143 | ++ |
+ #' # Custom scoring function that is working on "DataRow"s+ |
+ ||
| 144 | ++ |
+ #' scorefun <- function(tt) {
+ |
+ ||
| 145 | ++ |
+ #' # Here we could use browser()+ |
+ ||
| 146 | ++ |
+ #' sum(unlist(row_values(tt))) # Different accessor function+ |
+ ||
| 147 | ++ |
+ #' }+ |
+ ||
| 148 | ++ |
+ #' # Sorting mean and median for all the AGE leaves!+ |
+ ||
| 149 | ++ |
+ #' sort_at_path(tbl, c("RACE", "*", "STRATA1", "*", "AGE"), scorefun)
+ |
+ ||
| 150 | ++ |
+ #'+ |
+ ||
| 151 | ++ |
+ #' @export+ |
+ ||
| 152 | ++ |
+ sort_at_path <- function(tt,+ |
+ ||
| 153 | ++ |
+ path,+ |
+ ||
| 154 | ++ |
+ scorefun,+ |
+ ||
| 155 | ++ |
+ decreasing = NA,+ |
+ ||
| 156 | ++ |
+ na.pos = c("omit", "last", "first"),
+ |
+ ||
| 157 | ++ |
+ .prev_path = character()) {
|
||
| 515 | -3x | +158 | +35x |
- if (is(tmp, "CellValue")) {
+ if (NROW(tt) == 0) {
|
| 516 | +159 | 1x |
- tmp <- tmp[[1]]+ return(tt) |
|
| 517 | -23x | +|||
| 160 | +
- } ## unwrap it+ } |
|||
| 518 | -3x | +|||
| 161 | +
- final_vals <- insert_replace(final_vals, nm, tmp)+ + |
+ |||
| 162 | ++ |
+ ## XXX hacky fix this!!!+ |
+ ||
| 163 | ++ |
+ ## tt_at_path removes root even if actual root table isn't named root, we need to match that behavior |
||
| 519 | -3x | +164 | +34x |
- stopifnot(all(nzchar(names(final_vals))))+ if (path[1] == "root") {
|
| 520 | +165 |
-
+ ## always remove first root element but only add it to+ |
+ ||
| 166 | ++ |
+ ## .prev_path (used for error reporting) if it actually matched the name |
||
| 521 | -3x | +167 | +1x |
- final_labels <- insert_replace(+ if (obj_name(tt) == "root") {
|
| 522 | -3x | +168 | +1x |
- final_labels,+ .prev_path <- c(.prev_path, path[1])+ |
+
| 169 | ++ |
+ } |
||
| 523 | -3x | +170 | +1x |
- nm,+ path <- path[-1]+ |
+
| 171 | ++ |
+ } |
||
| 524 | -3x | +172 | +34x |
- setNames(+ if (identical(obj_name(tt), path[1])) {
|
| 525 | -3x | +173 | +1x |
- value_labels(tmp),+ .prev_path <- c(.prev_path, path[1]) |
| 526 | -3x | +174 | +1x |
- names(tmp)+ path <- path[-1] |
| 527 | +175 |
- )+ } |
||
| 528 | +176 |
- )+ |
||
| 529 | -3x | +177 | +34x |
- final_formats <- insert_replace(+ curpath <- path |
| 530 | -3x | +178 | +34x |
- final_formats,+ subtree <- tt |
| 531 | -3x | +179 | +34x |
- nm,+ backpath <- c() |
| 532 | -3x | +180 | +34x |
- setNames(+ count <- 0 |
| 533 | -3x | +181 | +34x |
- rep(final_formats[nm],+ while (length(curpath) > 0) {
|
| 534 | -3x | +182 | +40x |
- length.out = length(tmp)+ curname <- curpath[1]+ |
+
| 183 | +40x | +
+ oldkids <- tree_children(subtree) |
||
| 535 | +184 |
- ),+ ## we sort each child separately based on the score function+ |
+ ||
| 185 | ++ |
+ ## and the remaining path |
||
| 536 | -3x | +186 | +40x |
- names(tmp)+ if (curname == "*") {
|
| 537 | -+ | |||
| 187 | +7x |
- )+ oldnames <- vapply(oldkids, obj_name, "") |
||
| 538 | -+ | |||
| 188 | +7x |
- )+ newkids <- lapply( |
||
| 539 | -3x | +189 | +7x | +
+ seq_along(oldkids),+ |
+
| 190 | +7x | +
+ function(i) {
+ |
+ ||
| 191 | +27x |
- final_format_na_strs <- insert_replace(+ sort_at_path(oldkids[[i]], |
||
| 540 | -3x | +192 | +27x |
- final_format_na_strs,+ path = curpath[-1], |
| 541 | -3x | +193 | +27x |
- nm,+ scorefun = scorefun, |
| 542 | -3x | +194 | +27x |
- setNames(+ decreasing = decreasing, |
| 543 | -3x | +195 | +27x |
- rep(final_format_na_strs[nm],+ na.pos = na.pos, |
| 544 | -3x | +|||
| 196 | +
- length.out = length(tmp)+ ## its ok to modify the "path" here because its only ever used for |
|||
| 545 | +197 |
- ),+ ## informative error reporting. |
||
| 546 | -3x | +198 | +27x |
- names(tmp)+ .prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")"))
|
| 547 | +199 |
) |
||
| 548 | +200 |
- )+ } |
||
| 549 | -3x | +|||
| 201 | +
- final_imods <- insert_replace(+ ) |
|||
| 550 | -3x | +202 | +4x |
- final_imods,+ names(newkids) <- oldnames |
| 551 | -3x | +203 | +4x |
- nm,+ newtab <- subtree |
| 552 | -3x | +204 | +4x |
- setNames(+ tree_children(newtab) <- newkids |
| 553 | -3x | +205 | +4x |
- rep(final_imods[nm],+ if (length(backpath) > 0) {
|
| 554 | +206 | 3x |
- length.out = length(tmp)+ ret <- recursive_replace(tt, backpath, value = newtab) |
|
| 555 | +207 |
- ),+ } else {
|
||
| 556 | -3x | +208 | +1x |
- names(tmp)+ ret <- newtab |
| 557 | +209 |
- )+ } |
||
| 558 | -+ | |||
| 210 | +4x |
- )+ return(ret) |
||
| 559 | -+ | |||
| 211 | +33x |
- }+ } else if (!(curname %in% names(oldkids))) {
|
||
| 560 | -+ | |||
| 212 | +1x |
- }+ stop( |
||
| 561 | -66x | +213 | +1x |
- rcells <- mapply(+ "Unable to find child(ren) '", |
| 562 | -66x | +214 | +1x |
- function(x, f, l, na_str) {
+ curname, "'\n\t occurred at path: ", |
| 563 | -197x | +215 | +1x |
- if (is(x, "CellValue")) {
+ paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "), |
| 564 | -65x | +216 | +1x |
- obj_label(x) <- l+ "\n Use 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n", |
| 565 | -65x | +217 | +1x |
- obj_format(x) <- f+ "'table_structure(obj)' to explore valid paths." |
| 566 | -65x | +|||
| 218 | +
- obj_na_str(x) <- na_str+ ) |
|||
| 567 | +219 |
- # indent_mod(x) <- im+ } |
||
| 568 | -65x | +220 | +32x |
- x+ subtree <- tree_children(subtree)[[curname]] |
| 569 | -132x | +221 | +32x |
- } else if (.null_ref_cells) {
+ backpath <- c(backpath, curpath[1]) |
| 570 | -! | +|||
| 222 | +32x |
- non_ref_rcell(x,+ curpath <- curpath[-1] |
||
| 571 | -! | +|||
| 223 | +32x |
- is_ref = .in_ref_col,+ count <- count + 1 |
||
| 572 | -! | +|||
| 224 | +
- format = f, label = l,+ } |
|||
| 573 | -! | +|||
| 225 | +26x |
- format_na_str = na_str+ real_backpath <- path[seq_len(count)] |
||
| 574 | -! | +|||
| 226 | +
- ) # , indent_mod = im)+ + |
+ |||
| 227 | +26x | +
+ na.pos <- match.arg(na.pos) |
||
| 575 | +228 |
- } else {
+ ## subtree <- tt_at_path(tt, path) |
||
| 576 | -132x | +229 | +26x |
- rcell(x, format = f, label = l, format_na_str = na_str) # , indent_mod = im)+ kids <- tree_children(subtree) |
| 577 | +230 |
- }+ ## relax this to allow character "scores" |
||
| 578 | +231 |
- },+ ## scores <- vapply(kids, scorefun, NA_real_) |
||
| 579 | -66x | +232 | +26x |
- f = final_formats, x = final_vals,+ scores <- lapply(kids, function(x) tryCatch(scorefun(x), error = function(e) e)) |
| 580 | -66x | +233 | +26x |
- l = final_labels,+ errs <- which(vapply(scores, is, class2 = "error", TRUE)) |
| 581 | -66x | -
- na_str = final_format_na_strs,- |
- ||
| 582 | -+ | 234 | +26x |
- # im = final_imods,+ if (length(errs) > 0) {
|
| 583 | -66x | -
- SIMPLIFY = FALSE- |
- ||
| 584 | -+ | 235 | +2x |
- )+ stop("Encountered at least ", length(errs), " error(s) when applying score function.\n",
|
| 585 | -66x | +236 | +2x |
- in_rows(.list = rcells, .indent_mods = final_imods) ## , .labels = .labels)+ "First error: ", scores[[errs[1]]]$message, |
| 586 | -+ | |||
| 237 | +2x |
- }+ "\n\toccurred at path: ", |
||
| 587 | -23x | +238 | +2x |
- formals(ret) <- formals(fun)+ paste(c(.prev_path, real_backpath, names(kids)[errs[1]]), collapse = " -> "), |
| 588 | -23x | +239 | +2x |
- ret+ call. = FALSE |
| 589 | +240 |
- }+ ) |
||
| 590 | +241 |
-
+ } else {
|
||
| 591 | -+ | |||
| 242 | +24x |
- insert_replace <- function(x, nm, newvals = x[[nm]]) {
+ scores <- unlist(scores) |
||
| 592 | -15x | +|||
| 243 | +
- i <- match(nm, names(x))+ } |
|||
| 593 | -15x | +244 | +24x |
- if (is.na(i)) {
+ if (!is.null(dim(scores)) || length(scores) != length(kids)) {
|
| 594 | +245 | ! |
- stop("name not found")
+ stop( |
|
| 595 | -+ | |||
| 246 | +! |
- }+ "Score function does not appear to have return exactly one ", |
||
| 596 | -15x | +|||
| 247 | +! |
- bef <- if (i > 1) 1:(i - 1) else numeric()+ "scalar value per child" |
||
| 597 | -15x | +|||
| 248 | +
- aft <- if (i < length(x)) (i + 1):length(x) else numeric()+ ) |
|||
| 598 | -15x | +|||
| 249 | +
- ret <- c(x[bef], newvals, x[aft])+ } |
|||
| 599 | -15x | +250 | +24x |
- names(ret) <- c(names(x)[bef], names(newvals), names(x)[aft])+ if (is.na(decreasing)) {
|
| 600 | -15x | +251 | +8x |
- ret+ decreasing <- if (is.character(scores)) FALSE else TRUE |
| 601 | +252 |
- }+ } |
||
| 602 | -+ | |||
| 253 | +24x |
-
+ ord <- order(scores, na.last = (na.pos != "first"), decreasing = decreasing) |
||
| 603 | -+ | |||
| 254 | +24x |
- parser_helper <- function(text, envir = parent.frame(2)) {
+ newkids <- kids[ord] |
||
| 604 | -505x | +255 | +24x |
- parse(text = text, keep.source = FALSE)+ if (anyNA(scores) && na.pos == "omit") { # we did na last here
+ |
+
| 256 | +! | +
+ newkids <- head(newkids, -1 * sum(is.na(scores))) |
||
| 605 | +257 |
- }+ } |
||
| 606 | +258 | |||
| 607 | -+ | |||
| 259 | +24x |
- length_w_name <- function(x, .parent_splval) {
+ newtree <- subtree |
||
| 608 | -! | +|||
| 260 | +24x |
- in_rows(length(x),+ tree_children(newtree) <- newkids |
||
| 609 | -! | +|||
| 261 | +24x |
- .names = value_labels(.parent_splval)+ tt_at_path(tt, path) <- newtree |
||
| 610 | -+ | |||
| 262 | +24x |
- )+ tt |
||
| 611 | +263 |
}@@ -95135,448 +95414,448 @@ rtables coverage - 90.21% |
| 1 |
- ## Rules for pagination+ # as_result_df ------------------------------------------------------------ |
||
| 2 |
- ##+ #' Generate a result data frame |
||
| 3 |
- ## 1. user defined number of lines per page+ #' |
||
| 4 |
- ## 2. all lines have the same height+ #' Collection of utilities to extract `data.frame` objects from `TableTree` objects. |
||
| 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)+ #' @inheritParams gen_args |
||
| 7 |
- ## 5. Never (?) break on a "label"/content row+ #' @param spec (`function`)\cr function that generates the result data frame from a table (`TableTree`). |
||
| 8 |
- ## 6. Never (?) break on the second (i.e. after the first) data row at a particular leaf Elementary table.+ #' It defaults to `NULL`, for standard processing. |
||
| 9 |
- ##+ #' @param expand_colnames (`flag`)\cr when `TRUE`, the result data frame will have expanded column |
||
| 10 |
- ## Current behavior: paginate_ttree takes a TableTree object and+ #' names above the usual output. This is useful when the result data frame is used for further processing. |
||
| 11 |
- ## returns a list of rtable (S3) objects for printing.+ #' @param data_format (`string`)\cr the format of the data in the result data frame. It can be one value |
||
| 12 |
-
+ #' between `"full_precision"` (default), `"strings"`, and `"numeric"`. The last two values show the numeric |
||
| 13 |
- #' @inheritParams formatters::nlines+ #' data with the visible precision. |
||
| 14 |
- #'+ #' @param make_ard (`flag`)\cr when `TRUE`, the result data frame will have only one statistic per row. |
||
| 15 |
- #' @rdname formatters_methods+ #' @param keep_label_rows (`flag`)\cr when `TRUE`, the result data frame will have all labels |
||
| 16 |
- #' @aliases nlines,TableRow-method+ #' as they appear in the final table. |
||
| 17 |
- #' @exportMethod nlines+ #' @param simplify (`flag`)\cr when `TRUE`, the result data frame will have only visible labels and |
||
| 18 |
- setMethod(+ #' result columns. Consider showing also label rows with `keep_label_rows = TRUE`. This output can be |
||
| 19 |
- "nlines", "TableRow",+ #' used again to create a `TableTree` object with [df_to_tt()]. |
||
| 20 |
- function(x, colwidths, max_width, fontspec, col_gap = 3) {
+ #' @param ... additional arguments passed to spec-specific result data frame function (`spec`). |
||
| 21 | -10374x | +
- fns <- sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) ++ #' |
|
| 22 | -10374x | +
- sum(unlist(lapply(cell_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))+ #' @return |
|
| 23 | -10374x | +
- fcells <- as.vector(get_formatted_cells(x))+ #' * `as_result_df` returns a result `data.frame`. |
|
| 24 | -10374x | +
- spans <- row_cspans(x)+ #' |
|
| 25 | -10374x | +
- have_cw <- !is.null(colwidths)+ #' @seealso [df_to_tt()] when using `simplify = TRUE` and [formatters::make_row_df()] to have a |
|
| 26 |
- ## handle spanning so that the projected word-wrapping from nlines is correct+ #' comprehensive view of the hierarchical structure of the rows. |
||
| 27 | -10374x | +
- if (any(spans > 1)) {
+ #' |
|
| 28 | -10x | +
- new_fcells <- character(length(spans))+ #' @examples |
|
| 29 | -10x | +
- new_colwidths <- numeric(length(spans))+ #' lyt <- basic_table() %>% |
|
| 30 | -10x | +
- cur_fcells <- fcells+ #' split_cols_by("ARM") %>%
|
|
| 31 | -10x | +
- cur_colwidths <- colwidths[-1] ## not the row labels they can't span+ #' split_rows_by("STRATA1") %>%
|
|
| 32 | -10x | +
- for (i in seq_along(spans)) {
+ #' analyze(c("AGE", "BMRKR2"))
|
|
| 33 | -24x | +
- spi <- spans[i]+ #' |
|
| 34 | -24x | +
- new_fcells[i] <- cur_fcells[1] ## 1 cause we're trimming it every loop+ #' tbl <- build_table(lyt, ex_adsl) |
|
| 35 | -24x | +
- new_colwidths[i] <- sum(head(cur_colwidths, spi)) + col_gap * (spi - 1)+ #' as_result_df(tbl, simplify = TRUE) |
|
| 36 | -24x | +
- cur_fcells <- tail(cur_fcells, -1 * spi)+ #' |
|
| 37 | -24x | +
- cur_colwidths <- tail(cur_colwidths, -1 * spi)+ #' @name data.frame_export |
|
| 38 |
- }+ #' @export |
||
| 39 | -10x | +
- if (have_cw) {
+ as_result_df <- function(tt, spec = NULL, |
|
| 40 | -4x | +
- colwidths <- c(colwidths[1], new_colwidths)+ data_format = c("full_precision", "strings", "numeric"),
|
|
| 41 |
- }+ make_ard = FALSE, |
||
| 42 | -10x | +
- fcells <- new_fcells+ expand_colnames = FALSE, |
|
| 43 |
- }+ keep_label_rows = FALSE, |
||
| 44 |
-
+ simplify = FALSE, |
||
| 45 |
- ## rowext <- max(vapply(strsplit(c(obj_label(x), fcells), "\n", fixed = TRUE),+ ...) {
|
||
| 46 | -+ | 31x |
- ## length,+ data_format <- data_format[[1]] |
| 47 | -+ | 31x |
- ## 1L))+ checkmate::assert_class(tt, "VTableTree") |
| 48 | -10374x | +31x |
- rowext <- max(+ checkmate::assert_function(spec, null.ok = TRUE) |
| 49 | -10374x | +31x |
- unlist(+ checkmate::assert_choice(data_format[[1]], choices = eval(formals(as_result_df)[["data_format"]])) |
| 50 | -10374x | +31x |
- mapply(+ checkmate::assert_flag(make_ard) |
| 51 | -10374x | +31x |
- function(s, w) {
+ checkmate::assert_flag(expand_colnames) |
| 52 | -56101x | +31x |
- nlines(strsplit(s, "\n", fixed = TRUE), max_width = w, fontspec = fontspec)+ checkmate::assert_flag(keep_label_rows) |
| 53 | -+ | 31x |
- },+ checkmate::assert_flag(simplify) |
| 54 | -10374x | +
- s = c(obj_label(x), fcells),+ |
|
| 55 | -10374x | +31x |
- w = (colwidths %||% max_width) %||% vector("list", length(c(obj_label(x), fcells))),
+ if (nrow(tt) == 0) {
|
| 56 | -10374x | +2x |
- SIMPLIFY = FALSE+ return(sanitize_table_struct(tt)) |
| 57 |
- )+ } |
||
| 58 |
- )+ |
||
| 59 | -+ | 29x |
- )+ if (make_ard) {
|
| 60 | -+ | 7x |
-
+ simplify <- FALSE |
| 61 | -10374x | +7x |
- rowext + fns+ expand_colnames <- TRUE |
| 62 | -+ | 7x |
- }+ keep_label_rows <- FALSE |
| 63 |
- )+ } |
||
| 65 | -+ | 29x |
- #' @export+ if (is.null(spec)) {
|
| 66 |
- #' @rdname formatters_methods+ # raw values |
||
| 67 | -+ | 29x |
- setMethod(+ rawvals <- cell_values(tt) |
| 68 | -+ | 29x |
- "nlines", "LabelRow",+ cellvals <- .make_df_from_raw_data(rawvals, nr = nrow(tt), nc = ncol(tt)) |
| 69 |
- function(x, colwidths, max_width, fontspec = fontspec, col_gap = NULL) {
+
|
||
| 70 | -3229x | +29x |
- if (labelrow_visible(x)) {
+ if (data_format %in% c("strings", "numeric")) {
|
| 71 | -3229x | +
- nlines(strsplit(obj_label(x), "\n", fixed = TRUE)[[1]], max_width = colwidths[1], fontspec = fontspec) ++ # we keep previous calculations to check the format of the data |
|
| 72 | -3229x | +9x |
- sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec)))+ mf_tt <- matrix_form(tt) |
| 73 | -+ | 9x |
- } else {
+ mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1] |
| 74 | -! | +9x |
- 0L+ mf_result_chars <- .remove_empty_elements(mf_result_chars) |
| 75 | -+ | 9x |
- }+ mf_result_numeric <- as.data.frame( |
| 76 | -+ | 9x |
- }+ .make_numeric_char_mf(mf_result_chars) |
| 77 |
- )+ ) |
||
| 78 | -+ | 9x |
-
+ mf_result_chars <- as.data.frame(mf_result_chars) |
| 79 | -+ | 9x |
- #' @export+ if (!setequal(dim(mf_result_numeric), dim(cellvals)) || !setequal(dim(mf_result_chars), dim(cellvals))) {
|
| 80 | -+ | ! |
- #' @rdname formatters_methods+ stop( |
| 81 | -+ | ! |
- setMethod(+ "The extracted numeric data.frame does not have the same dimension of the", |
| 82 | -+ | ! |
- "nlines", "RefFootnote",+ " cell values extracted with cell_values(). This is a bug. Please report it." |
| 83 | -+ | ! |
- function(x, colwidths, max_width, fontspec, col_gap = NULL) {
+ ) # nocov |
| 84 | -298x | +
- nlines(format_fnote_note(x), colwidths = colwidths, max_width = max_width, fontspec = fontspec)+ } |
|
| 85 | -+ | 9x |
- }+ if (data_format == "strings") {
|
| 86 | -+ | 5x |
- )+ colnames(mf_result_chars) <- colnames(cellvals) |
| 87 | -+ | 5x |
-
+ cellvals <- mf_result_chars |
| 88 |
- #' @export+ } else {
|
||
| 89 | -+ | 4x |
- #' @rdname formatters_methods+ colnames(mf_result_numeric) <- colnames(cellvals) |
| 90 | -+ | 4x |
- setMethod(+ cellvals <- mf_result_numeric |
| 91 |
- "nlines", "InstantiatedColumnInfo",+ } |
||
| 92 |
- function(x, colwidths, max_width, fontspec, col_gap = 3) {
+ } |
||
| 93 | -6x | +
- h_rows <- .do_tbl_h_piece2(x)+ |
|
| 94 | -6x | +29x |
- tl <- top_left(x) %||% rep("", length(h_rows))
+ rdf <- make_row_df(tt) |
| 95 | -6x | +
- main_nls <- vapply(+ |
|
| 96 | -6x | +29x |
- seq_along(h_rows),+ df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")]
|
| 97 | -6x | +
- function(i) {
+ # Removing initial root elements from path (out of the loop -> right maxlen) |
|
| 98 | -10x | +29x |
- max(+ df$path <- lapply(df$path, .remove_root_elems_from_path, |
| 99 | -10x | +29x |
- nlines(h_rows[[i]],+ which_root_name = c("root", "rbind_root"),
|
| 100 | -10x | +29x |
- colwidths = colwidths,+ all = TRUE |
| 101 | -10x | +
- fontspec = fontspec,+ ) |
|
| 102 | -10x | +29x |
- col_gap = col_gap+ maxlen <- max(lengths(df$path)) |
| 103 |
- ),+ |
||
| 104 | -10x | +
- nlines(tl[i],+ # Loop for metadata (path and details from make_row_df) |
|
| 105 | -10x | +29x |
- colwidths = colwidths[1],+ metadf <- do.call( |
| 106 | -10x | +29x |
- fontspec = fontspec+ rbind.data.frame, |
| 107 | -+ | 29x |
- )+ lapply( |
| 108 | -+ | 29x |
- )+ seq_len(NROW(df)), |
| 109 | -+ | 29x |
- },+ function(ii) {
|
| 110 | -6x | +623x |
- 1L+ handle_rdf_row(df[ii, ], maxlen = maxlen) |
| 111 |
- )+ } |
||
| 112 |
-
+ ) |
||
| 113 |
- ## lfs <- collect_leaves(coltree(x))+ ) |
||
| 114 |
- ## depths <- sapply(lfs, function(l) length(pos_splits(l)))+ |
||
| 115 |
-
+ # Should we keep label rows with NAs instead of values? |
||
| 116 | -6x | +29x |
- coldf <- make_col_df(x, colwidths = colwidths)+ if (keep_label_rows) {
|
| 117 | 6x |
- have_fnotes <- length(unlist(coldf$col_fnotes)) > 0+ cellvals_mat_struct <- as.data.frame( |
|
| 118 | -+ | 6x |
- ## ret <- max(depths, length(top_left(x))) ++ matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals)) |
| 119 |
- ## divider_height(x)+ ) |
||
| 120 | 6x |
- ret <- sum(main_nls, divider_height(x))+ colnames(cellvals_mat_struct) <- colnames(cellvals) |
|
| 121 | 6x |
- if (have_fnotes) {
+ cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals |
|
| 122 | -! | +6x |
- ret <- sum(+ ret <- cbind(metadf, cellvals_mat_struct) |
| 123 | -! | +
- ret,+ } else {
|
|
| 124 | -! | +23x |
- vapply(unlist(coldf$col_fnotes),+ ret <- cbind( |
| 125 | -! | +23x |
- nlines,+ metadf[metadf$node_class != "LabelRow", ], |
| 126 | -! | +23x |
- 1,+ cellvals |
| 127 | -! | +
- max_width = max_width,+ ) |
|
| 128 | -! | +
- fontspec = fontspec+ } |
|
| 129 |
- ),+ |
||
| 130 | -! | +
- 2 * divider_height(x)+ # Fix for content rows analysis variable label |
|
| 131 | -+ | 29x |
- )+ if (any(ret$node_class == "ContentRow")) {
|
| 132 | -+ | 8x |
- }+ where_to <- which(ret$node_class == "ContentRow") |
| 133 | -6x | +8x |
- ret+ for (crow_i in where_to) {
|
| 134 |
- }+ # For each Content row, extract the row split that is used as analysis variable |
||
| 135 | -+ | 44x |
- )+ tmp_tbl <- ret[crow_i, , drop = FALSE] |
| 136 | -+ | 44x |
-
+ na_labels <- lapply(tmp_tbl, is.na) %>% unlist(use.names = FALSE) |
| 137 | -+ | 44x |
- col_dfrow <- function(col,+ group_to_take <- colnames(tmp_tbl[, !na_labels]) |
| 138 | -+ | 44x |
- nm = obj_name(col),+ group_to_take <- group_to_take[grep("^group[0-9]+$", group_to_take)]
|
| 139 |
- lab = obj_label(col),+ |
||
| 140 |
- cnum,+ # Final assignment of each Content row to its correct analysis label |
||
| 141 | -+ | 44x |
- pth = NULL,+ ret$avar_name[crow_i] <- ret[[group_to_take[length(group_to_take)]]][crow_i] |
| 142 |
- sibpos = NA_integer_,+ } |
||
| 143 |
- nsibs = NA_integer_,+ } |
||
| 144 |
- leaf_indices = cnum,+ |
||
| 145 |
- span = length(leaf_indices),+ # If we want to expand colnames |
||
| 146 | -+ | 29x |
- col_fnotes = list(),+ if (expand_colnames) {
|
| 147 | -+ | 13x |
- col_count = facet_colcount(col, NULL),+ col_name_structure <- .get_formatted_colnames(clayout(tt)) |
| 148 | -+ | 13x |
- ccount_visible = disp_ccounts(col),+ number_of_non_data_cols <- which(colnames(ret) == "node_class") |
| 149 | -+ | 13x |
- ccount_format = colcount_format(col),+ if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) {
|
| 150 | -+ | ! |
- ccount_na_str,+ stop( |
| 151 | -+ | ! |
- global_cc_format) {
+ "When expanding colnames structure, we were not able to find the same", |
| 152 | -12691x | +! |
- if (is.null(pth)) {
+ " number of columns as in the result data frame. This is a bug. Please report it." |
| 153 | -12047x | +! |
- pth <- pos_to_path(tree_pos(col))+ ) # nocov |
| 154 |
- }+ } |
||
| 155 | -12691x | +
- data.frame(+ |
|
| 156 | -12691x | +13x |
- stringsAsFactors = FALSE,+ buffer_rows_for_colnames <- matrix( |
| 157 | -12691x | +13x |
- name = nm,+ rep("<only_for_column_names>", number_of_non_data_cols * NROW(col_name_structure)),
|
| 158 | -12691x | +13x |
- label = lab,+ nrow = NROW(col_name_structure) |
| 159 | -12691x | +
- abs_pos = cnum,+ ) |
|
| 160 | -12691x | +
- path = I(list(pth)),+ |
|
| 161 | -12691x | +13x |
- pos_in_siblings = sibpos,+ header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure)) |
| 162 | -12691x | +13x |
- n_siblings = nsibs,+ colnames(header_colnames_matrix) <- colnames(ret) |
| 163 | -12691x | +
- leaf_indices = I(list(leaf_indices)),+ |
|
| 164 | -12691x | +13x |
- total_span = span,+ count_row <- NULL |
| 165 | -12691x | +13x |
- col_fnotes = I(list(col_fnotes)),+ if (disp_ccounts(tt)) {
|
| 166 | -12691x | +5x |
- n_col_fnotes = length(col_fnotes),+ ccounts <- col_counts(tt) |
| 167 | -12691x | +5x |
- col_count = col_count,+ if (data_format == "strings") {
|
| 168 | -12691x | +2x |
- ccount_visible = ccount_visible,+ ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ] |
| 169 | -12691x | +2x |
- ccount_format = ccount_format %||% global_cc_format,+ ccounts <- .remove_empty_elements(ccounts) |
| 170 | -12691x | +
- ccount_na_str = ccount_na_str+ } |
|
| 171 | -+ | 5x |
- )+ count_row <- c(rep("<only_for_column_counts>", number_of_non_data_cols), ccounts)
|
| 172 | -+ | 5x |
- }+ header_colnames_matrix <- rbind(header_colnames_matrix, count_row) |
| 173 |
-
+ } |
||
| 174 | -+ | 13x |
- pos_to_path <- function(pos) {
+ ret <- rbind(header_colnames_matrix, ret) |
| 175 | -46481x | +
- spls <- pos_splits(pos)+ } |
|
| 176 | -46481x | +
- vals <- pos_splvals(pos)+ |
|
| 177 |
-
+ # ARD part for one stat per row |
||
| 178 | -46481x | +29x |
- path <- character()+ if (make_ard) {
|
| 179 | -46481x | +7x |
- for (i in seq_along(spls)) {
+ cinfo_df <- col_info(tt) |
| 180 | -58625x | +7x |
- nm <- obj_name(spls[[i]])+ ci_coltree <- coltree(cinfo_df) |
| 181 | -58625x | +7x |
- val_i <- value_names(vals[[i]])+ column_split_names <- .get_column_split_name(ci_coltree) # used only in make_ard |
| 182 | -58625x | +
- path <- c(+ |
|
| 183 | -58625x | +
- path,+ # Unnecessary columns |
|
| 184 | -58625x | +7x |
- obj_name(spls[[i]]),+ ret_tmp <- ret[, !colnames(ret) %in% c("row_num", "is_group_summary", "node_class")]
|
| 185 | -+ | 7x |
- ## rawvalues(vals[[i]]))+ n_row_groups <- sapply(colnames(ret), function(x) {
|
| 186 | -58625x | +90x |
- if (!is.na(val_i)) val_i+ if (grepl("^group", x)) {
|
| 187 |
- )+ # Extract the number after "group" using regex |
||
| 188 | -+ | 14x |
- }+ return(as.numeric(sub("group(\\d+).*", "\\1", x)))
|
| 189 | -46481x | +
- path+ } else {
|
|
| 190 | -+ | 76x |
- }+ return(0) # Return 0 if no "group" is found |
| 191 |
-
+ } |
||
| 192 |
- # make_row_df ---------------------------------------------------------------+ }) %>% |
||
| 193 | -+ | 7x |
-
+ max() |
| 194 |
- #' @inherit formatters::make_row_df+ |
||
| 195 |
- #'+ # Indexes of real columns (visible in the output, but no row names) |
||
| 196 | -+ | 7x |
- # #' @note The technically present root tree node is excluded from the summary returned by both `make_row_df` and+ only_col_indexes <- seq(which(colnames(ret_tmp) == "label_name") + 1, ncol(ret_tmp)) |
| 197 |
- # #' `make_col_df`, as it is simply the row/column structure of `tt` and thus not useful for pathing or pagination.+ |
||
| 198 |
- # #'+ # Core row names |
||
| 199 | -+ | 7x |
- # #' @return a data.frame of row/column-structure information used by the pagination machinery.+ col_label_rows <- grepl("<only_for_column_*", ret_tmp$avar_name)
|
| 200 | -+ | 7x |
- # #'+ number_of_col_splits <- sum(grepl("<only_for_column_names>", ret_tmp$avar_name))
|
| 201 | -+ | 7x |
- # #' @export+ core_row_names <- ret_tmp[!col_label_rows, -only_col_indexes] |
| 202 | -+ | 7x |
- # #' @name make_row_df+ colnames_to_rename <- colnames(core_row_names) %in% c("avar_name", "row_name", "label_name")
|
| 203 |
- # #' @rdname make_row_df+ # instead of avar_name row_name label_name ("variable_label" is not present in ARDs)
|
||
| 204 | -+ | 7x |
- # #' @aliases make_row_df,VTableTree-method+ colnames(core_row_names)[colnames_to_rename] <- c("variable", "variable_level", "variable_label")
|
| 205 |
- #' @rdname formatters_methods+ |
||
| 206 |
- #' @exportMethod make_row_df+ # Adding stats_names if present |
||
| 207 | -+ | 7x |
- setMethod(+ raw_stat_names <- .get_stat_names_from_table(tt, add_labrows = keep_label_rows) |
| 208 | -+ | 7x |
- "make_row_df", "VTableTree",+ cell_stat_names <- .make_df_from_raw_data(raw_stat_names, nr = nrow(tt), nc = ncol(tt)) |
| 209 |
- function(tt,+ |
||
| 210 |
- colwidths = NULL,+ # Moving colnames to rows (flattening) |
||
| 211 | -+ | 7x |
- visible_only = TRUE,+ ret_w_cols <- NULL |
| 212 |
- rownum = 0,+ # Looping on statistical columns |
||
| 213 | -+ | 7x |
- indent = 0L,+ for (col_i in only_col_indexes) {
|
| 214 |
- path = character(),+ # Making row splits into row specifications (group1 group1_level) |
||
| 215 | -+ | 34x |
- incontent = FALSE,+ current_col_split_level <- unlist(ret_tmp[seq_len(number_of_col_splits), col_i], use.names = FALSE) |
| 216 | -+ | 34x |
- repr_ext = 0L,+ flattened_cols_names <- .c_alternated(column_split_names[[1]][[1]], current_col_split_level) |
| 217 | -+ | 34x |
- repr_inds = integer(),+ names(flattened_cols_names) <- .c_alternated( |
| 218 | -+ | 34x |
- sibpos = NA_integer_,+ paste0("group", seq_along(column_split_names[[1]][[1]]) + n_row_groups),
|
| 219 | -+ | 34x |
- nsibs = NA_integer_,+ paste0("group", seq_along(current_col_split_level) + n_row_groups, "_level")
|
| 220 |
- max_width = NULL,+ ) |
||
| 221 |
- fontspec = NULL,+ |
||
| 222 | -+ | 34x |
- col_gap = 3) {
+ if (n_row_groups > 0) {
|
| 223 | -9224x | +27x |
- indent <- indent + indent_mod(tt)+ tmp_core_ret_by_col_i <- cbind( |
| 224 | -+ | 27x |
- ## retained for debugging info+ core_row_names[, seq(n_row_groups * 2)], |
| 225 | -9224x | +27x |
- orig_rownum <- rownum # nolint+ t(data.frame(flattened_cols_names)), |
| 226 | -9224x | +27x |
- if (incontent) {
+ core_row_names[, -seq(n_row_groups * 2)], |
| 227 | -1268x | +27x |
- path <- c(path, "@content")+ row.names = NULL |
| 228 | -7956x | +
- } else if (length(path) > 0 || nzchar(obj_name(tt))) { ## don't add "" for root
+ ) |
|
| 229 |
- ## else if (length(path) > 0 && nzchar(obj_name(tt))) ## don't add "" for root # nolint+ } else {
|
||
| 230 | -7908x | +7x |
- path <- c(path, obj_name(tt))+ tmp_core_ret_by_col_i <- cbind( |
| 231 | -+ | 7x |
- }+ t(data.frame(flattened_cols_names)), |
| 232 | -9224x | +7x |
- ret <- list()+ core_row_names, |
| 233 | -+ | 7x |
-
+ row.names = NULL |
| 234 |
- ## note this is the **table** not the label row+ ) |
||
| 235 | -9224x | +
- if (!visible_only) {
+ } |
|
| 236 | -21x | +
- ret <- c(+ |
|
| 237 | -21x | +
- ret,+ # retrieving stat names and stats |
|
| 238 | -21x | +34x |
- list(pagdfrow(+ stat_name <- setNames(cell_stat_names[, col_i - min(only_col_indexes) + 1, drop = TRUE], NULL) |
| 239 | -21x | +34x |
- rnum = NA,+ stat <- setNames(ret_tmp[!col_label_rows, col_i, drop = TRUE], NULL) |
| 240 | -21x | +34x |
- nm = obj_name(tt),+ necessary_stat_lengths <- sapply(stat, length) |
| 241 | -21x | +
- lab = "",+ |
|
| 242 | -21x | +
- pth = path,+ # Truncating or adding NA if stat names has more or less elements than stats |
|
| 243 | -21x | +34x |
- colwidths = colwidths,+ stat_name <- lapply(seq_along(stat_name), function(sn_i) {
|
| 244 | -21x | +819x |
- repext = repr_ext,+ stat_name[[sn_i]][seq_len(necessary_stat_lengths[sn_i])] |
| 245 | -21x | +
- repind = list(repr_inds),+ }) |
|
| 246 | -21x | +
- extent = 0,+ |
|
| 247 | -21x | +
- indent = indent,+ # unnesting stat_name and stat |
|
| 248 | -21x | +34x |
- rclass = class(tt), sibpos = sibpos,+ tmp_ret_by_col_i <- NULL |
| 249 | -21x | +34x |
- nsibs = nsibs,+ for (row_i in seq_along(stat)) {
|
| 250 | -21x | +819x |
- nrowrefs = 0L,+ tmp_ret_by_col_i <- rbind( |
| 251 | -21x | +819x |
- ncellrefs = 0L,+ tmp_ret_by_col_i, |
| 252 | -21x | +819x |
- nreflines = 0L,+ cbind( |
| 253 | -21x | +819x |
- fontspec = fontspec+ tmp_core_ret_by_col_i[row_i, ], |
| 254 | -+ | 819x |
- ))+ stat_name = stat_name[[row_i]], |
| 255 | -+ | 819x |
- )+ stat = stat[[row_i]], |
| 256 | -+ | 819x |
- }+ row.names = NULL |
| 257 | -9224x | +
- if (labelrow_visible(tt)) {
+ ) |
|
| 258 | -3209x | +
- lr <- tt_labelrow(tt)+ ) |
|
| 259 | -3209x | +
- newdf <- make_row_df(lr,+ } |
|
| 260 | -3209x | +
- colwidths = colwidths,+ |
|
| 261 | -3209x | +34x |
- visible_only = visible_only,+ ret_w_cols <- rbind(ret_w_cols, tmp_ret_by_col_i) |
| 262 | -3209x | +
- rownum = rownum,+ } |
|
| 263 | -3209x | +
- indent = indent,+ |
|
| 264 | -3209x | +7x |
- path = path,+ ret <- ret_w_cols |
| 265 | -3209x | +
- incontent = TRUE,+ } |
|
| 266 | -3209x | +
- repr_ext = repr_ext,+ |
|
| 267 | -3209x | +
- repr_inds = repr_inds,+ # Simplify the result data frame |
|
| 268 | -3209x | +29x |
- max_width = max_width,+ out <- if (simplify) {
|
| 269 | -3209x | +6x |
- fontspec = fontspec+ .simplify_result_df(ret) |
| 270 |
- )+ } else {
|
||
| 271 | -3209x | +23x |
- rownum <- max(newdf$abs_rownumber, na.rm = TRUE)+ ret |
| 272 |
-
+ } |
||
| 273 | -3209x | +
- ret <- c(+ |
|
| 274 | -3209x | +
- ret,+ # take out rownames |
|
| 275 | -3209x | +29x |
- list(newdf)+ rownames(out) <- NULL |
| 276 |
- )+ } else {
|
||
| 277 | -3209x | +
- repr_ext <- repr_ext + 1L+ # Applying specs |
|
| 278 | -3209x | +! |
- repr_inds <- c(repr_inds, rownum)+ out <- spec(tt, ...) |
| 279 | -3209x | +
- indent <- indent + 1L+ } |
|
| 280 |
- }+ |
||
| 281 | -+ | 29x |
-
+ out |
| 282 | -9224x | +
- if (NROW(content_table(tt)) > 0) {
+ } |
|
| 283 | -1268x | +
- ct_tt <- content_table(tt)+ |
|
| 284 | -1268x | +
- cind <- indent + indent_mod(ct_tt)+ # Helper function used to structure the raw values into a dataframe |
|
| 285 | -1268x | +
- trailing_section_div(ct_tt) <- trailing_section_div(tt_labelrow(tt))+ .make_df_from_raw_data <- function(raw_vals, nr, nc) {
|
|
| 286 | -1268x | +
- contdf <- make_row_df(ct_tt,+ ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values |
|
| 287 | -1268x | +
- colwidths = colwidths,+ ## rather than a list of length 1 representing the single row. This is bad but may not be changeable |
|
| 288 | -1268x | +
- visible_only = visible_only,+ ## at this point. |
|
| 289 | -1268x | +36x |
- rownum = rownum,+ if (nr == 1 && length(raw_vals) > 1) {
|
| 290 | -1268x | +3x |
- indent = cind,+ raw_vals <- list(raw_vals) |
| 291 | -1268x | +
- path = path,+ } |
|
| 292 | -1268x | +
- incontent = TRUE,+ |
|
| 293 | -1268x | +
- repr_ext = repr_ext,+ # Flatten the list of lists (rows) of cell values into a data frame |
|
| 294 | -1268x | +36x |
- repr_inds = repr_inds,+ cellvals <- as.data.frame(do.call(rbind, raw_vals)) |
| 295 | -1268x | +36x |
- max_width = max_width,+ row.names(cellvals) <- NULL |
| 296 | -1268x | +
- fontspec = fontspec+ |
|
| 297 | -+ | 36x |
- )+ if (nr == 1 && nc == 1) {
|
| 298 | -1268x | +5x |
- crnums <- contdf$abs_rownumber+ colnames(cellvals) <- names(raw_vals) |
| 299 | -1268x | +
- crnums <- crnums[!is.na(crnums)]+ } |
|
| 301 | -1268x | +36x |
- newrownum <- max(crnums, na.rm = TRUE)+ cellvals |
| 302 | -1268x | +
- if (is.finite(newrownum)) {
+ } |
|
| 303 | -1268x | +
- rownum <- newrownum+ |
|
| 304 | -1268x | +
- repr_ext <- repr_ext + length(crnums)+ # Is there a better alternative? |
|
| 305 | -1268x | +
- repr_inds <- c(repr_inds, crnums)+ .c_alternated <- function(v1, v2) {
|
|
| 306 | -+ | 68x |
- }+ unlist(mapply(c, v1, v2, SIMPLIFY = FALSE)) |
| 307 | -1268x | +
- ret <- c(ret, list(contdf))+ } |
|
| 308 | -1268x | +
- indent <- cind + 1+ |
|
| 309 |
- }+ # Amazing helper function to get the statistic names from row cells! |
||
| 310 |
-
+ .get_stat_names_from_table <- function(tt, add_labrows = FALSE) {
|
||
| 311 | -9224x | +
- allkids <- tree_children(tt)+ # omit_labrows # omit label rows |
|
| 312 | -9224x | +7x |
- newnsibs <- length(allkids)+ rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = add_labrows) |
| 313 | -9224x | +7x |
- for (i in seq_along(allkids)) {
+ lapply(rows, function(ri) {
|
| 314 | -17528x | +124x |
- kid <- allkids[[i]]+ lapply(row_cells(ri), obj_stat_names) |
| 315 | -17528x | +
- kiddfs <- make_row_df(kid,+ }) |
|
| 316 | -17528x | +
- colwidths = colwidths,+ } |
|
| 317 | -17528x | +
- visible_only = visible_only,+ |
|
| 318 | -17528x | +
- rownum = force(rownum),+ # Helper function to get column split names |
|
| 319 | -17528x | +
- indent = indent, ## + 1,+ .get_column_split_name <- function(ci_coltree) {
|
|
| 320 | -17528x | +
- path = path,+ # ci stands for column information |
|
| 321 | -17528x | +50x |
- incontent = incontent,+ if (is(ci_coltree, "LayoutAxisTree")) {
|
| 322 | -17528x | +16x |
- repr_ext = repr_ext,+ kids <- tree_children(ci_coltree) |
| 323 | -17528x | +16x |
- repr_inds = repr_inds,+ return(lapply(kids, .get_column_split_name)) |
| 324 | -17528x | +
- nsibs = newnsibs,+ } |
|
| 325 | -17528x | +34x |
- sibpos = i,+ sapply(pos_splits(tree_pos(ci_coltree)), spl_payload) |
| 326 | -17528x | +
- max_width = max_width,+ } |
|
| 327 | -17528x | +
- fontspec = fontspec+ |
|
| 328 |
- )+ # Function that selects specific outputs from the result data frame |
||
| 329 |
-
+ .simplify_result_df <- function(df) {
|
||
| 330 | -+ | 6x |
- # print(kiddfs$abs_rownumber)+ col_df <- colnames(df) |
| 331 | -17528x | +6x |
- rownum <- max(rownum + 1L, kiddfs$abs_rownumber, na.rm = TRUE)+ if (!all(c("label_name", "node_class") %in% col_df)) {
|
| 332 | -17528x | +! |
- ret <- c(ret, list(kiddfs))+ stop("Please simplify the result data frame only when it has 'label_name' and 'node_class' columns.")
|
| 333 |
- }+ } |
||
| 334 | -+ | 6x |
-
+ label_names_col <- which(col_df == "label_name") |
| 335 | -9224x | +6x |
- ret <- do.call(rbind, ret)+ result_cols <- seq(which(col_df == "node_class") + 1, length(col_df)) |
| 337 | -+ | 6x |
- # Case where it has Elementary table or VTableTree section_div it is overridden+ df[, c(label_names_col, result_cols)] |
| 338 | -9224x | +
- if (!is.na(trailing_section_div(tt))) {
+ } |
|
| 339 | -110x | +
- ret$trailing_sep[nrow(ret)] <- trailing_section_div(tt)+ |
|
| 340 |
- }+ .remove_empty_elements <- function(char_df) {
|
||
| 341 | -9224x | +11x |
- ret+ if (is.null(dim(char_df))) {
|
| 342 | -+ | 5x |
- }+ return(char_df[nzchar(char_df, keepNA = TRUE)]) |
| 343 |
- )+ } |
||
| 345 | -+ | 6x |
- # #' @exportMethod make_row_df+ apply(char_df, 2, function(col_i) col_i[nzchar(col_i, keepNA = TRUE)]) |
| 346 |
- #' @inherit formatters::make_row_df+ } |
||
| 347 |
- #'+ |
||
| 348 |
- #' @export+ # Helper function to make the character matrix numeric |
||
| 349 |
- #' @rdname formatters_methods+ .make_numeric_char_mf <- function(char_df) {
|
||
| 350 | -+ | 9x |
- setMethod(+ if (is.null(dim(char_df))) {
|
| 351 | -+ | 3x |
- "make_row_df", "TableRow",+ return(as.numeric(stringi::stri_extract_all(char_df, regex = "\\d+.\\d+|\\d+"))) |
| 352 |
- function(tt, colwidths = NULL, visible_only = TRUE,+ } |
||
| 353 |
- rownum = 0,+ |
||
| 354 | -+ | 6x |
- indent = 0L,+ ret <- apply(char_df, 2, function(col_i) {
|
| 355 | -+ | 27x |
- path = "root",+ lapply( |
| 356 | -+ | 27x |
- incontent = FALSE,+ stringi::stri_extract_all(col_i, regex = "\\d+.\\d+|\\d+"), |
| 357 | -+ | 27x |
- repr_ext = 0L,+ as.numeric |
| 358 |
- repr_inds = integer(),+ ) |
||
| 359 |
- sibpos = NA_integer_,+ }) |
||
| 360 |
- nsibs = NA_integer_,+ |
||
| 361 | -+ | 6x |
- max_width = NULL,+ do.call(cbind, ret) |
| 362 |
- fontspec,+ } |
||
| 363 |
- col_gap = 3) {
+
|
||
| 364 | -10364x | +
- indent <- indent + indent_mod(tt)+ make_result_df_md_colnames <- function(maxlen) {
|
|
| 365 | -10364x | +623x |
- rownum <- rownum + 1+ spllen <- floor((maxlen - 2) / 2) |
| 366 | -10364x | +623x |
- rrefs <- row_footnotes(tt)+ ret <- character() |
| 367 | -10364x | +623x |
- crefs <- cell_footnotes(tt)+ if (spllen > 0) {
|
| 368 | -10364x | +562x |
- reflines <- sum(+ ret <- paste("group", rep(seq_len(spllen), each = 2), c("", "_level"), sep = "")
|
| 369 | -10364x | +
- sapply(+ } |
|
| 370 | -10364x | +623x |
- c(rrefs, crefs),+ ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class"))
|
| 371 | -10364x | +
- nlines,+ } |
|
| 372 | -10364x | +
- colwidths = colwidths,+ |
|
| 373 | -10364x | +
- max_width = max_width,+ do_label_row <- function(rdfrow, maxlen) {
|
|
| 374 | -10364x | +209x |
- fontspec = fontspec,+ pth <- rdfrow$path[[1]] |
| 375 | -10364x | +
- col_gap = col_gap+ # Adjusting for the fact that we have two columns for each split |
|
| 376 | -+ | 209x |
- )+ extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2 |
| 377 | -10364x | +
- ) ## col_gap not strictly necessary as these aren't rows, but why not+ |
|
| 378 | -10364x | +
- ret <- pagdfrow(+ # Special cases with hidden labels |
|
| 379 | -10364x | +209x |
- row = tt,+ if (length(pth) %% 2 == 1) {
|
| 380 | -10364x | +150x |
- rnum = rownum,+ extra_nas_from_splits <- extra_nas_from_splits + 1 |
| 381 | -10364x | +
- colwidths = colwidths,+ } |
|
| 382 | -10364x | +
- sibpos = sibpos,+ |
|
| 383 | -10364x | +209x |
- nsibs = nsibs,+ c( |
| 384 | -10364x | +209x |
- pth = c(path, unname(obj_name(tt))),+ as.list(pth[seq_len(length(pth) - 1)]), |
| 385 | -10364x | +209x |
- repext = repr_ext,+ as.list(replicate(extra_nas_from_splits, list(NA_character_))), |
| 386 | -10364x | +209x |
- repind = repr_inds,+ as.list(tail(pth, 1)), |
| 387 | -10364x | +209x |
- indent = indent,+ list( |
| 388 | -10364x | +209x |
- extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap),+ label_name = rdfrow$label, |
| 389 | -+ | 209x |
- ## these two are unlist calls cause they come in lists even with no footnotes+ row_num = rdfrow$abs_rownumber, |
| 390 | -10364x | +209x |
- nrowrefs = length(rrefs),+ content = FALSE, |
| 391 | -10364x | +209x |
- ncellrefs = length(unlist(crefs)),+ node_class = rdfrow$node_class |
| 392 | -10364x | +
- nreflines = reflines,+ ) |
|
| 393 | -10364x | +
- trailing_sep = trailing_section_div(tt),+ ) |
|
| 394 | -10364x | +
- fontspec = fontspec+ } |
|
| 395 |
- )+ |
||
| 396 | -10364x | +
- ret+ do_content_row <- function(rdfrow, maxlen) {
|
|
| 397 | -+ | 44x |
- }+ pth <- rdfrow$path[[1]] |
| 398 | -+ | 44x |
- )+ contpos <- which(pth == "@content") |
| 400 | -+ | 44x |
- # #' @exportMethod make_row_df+ seq_before <- seq_len(contpos - 1) |
| 401 |
- #' @export+ |
||
| 402 | -+ | 44x |
- #' @rdname formatters_methods+ c( |
| 403 | -+ | 44x |
- setMethod(+ as.list(pth[seq_before]), |
| 404 | -+ | 44x |
- "make_row_df", "LabelRow",+ as.list(replicate(maxlen - contpos, list(NA_character_))), |
| 405 | -+ | 44x |
- function(tt, colwidths = NULL, visible_only = TRUE,+ list(tail(pth, 1)), |
| 406 | -+ | 44x |
- rownum = 0,+ list( |
| 407 | -+ | 44x |
- indent = 0L,+ label_name = rdfrow$label, |
| 408 | -+ | 44x |
- path = "root",+ row_num = rdfrow$abs_rownumber, |
| 409 | -+ | 44x |
- incontent = FALSE,+ content = TRUE, |
| 410 | -+ | 44x |
- repr_ext = 0L,+ node_class = rdfrow$node_class |
| 411 |
- repr_inds = integer(),+ ) |
||
| 412 |
- sibpos = NA_integer_,+ ) |
||
| 413 |
- nsibs = NA_integer_,+ } |
||
| 414 |
- max_width = NULL,+ |
||
| 415 |
- fontspec,+ do_data_row <- function(rdfrow, maxlen) {
|
||
| 416 | -+ | 370x |
- col_gap = 3) {
+ pth <- rdfrow$path[[1]] |
| 417 | -3229x | +370x |
- rownum <- rownum + 1+ pthlen <- length(pth) |
| 418 | -3229x | +
- indent <- indent + indent_mod(tt)+ ## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame |
|
| 419 | -3229x | +370x |
- ret <- pagdfrow(tt,+ if (pthlen %% 2 == 1) {
|
| 420 | -3229x | +48x |
- extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap),+ pth <- pth[-1 * (pthlen - 2)] |
| 421 | -3229x | +
- rnum = rownum,+ } |
|
| 422 | -3229x | +370x |
- colwidths = colwidths,+ pthlen_new <- length(pth) |
| 423 | -3229x | +33x |
- sibpos = sibpos,+ if (maxlen == 1) pthlen_new <- 3 |
| 424 | -3229x | +370x |
- nsibs = nsibs,+ c( |
| 425 | -3229x | +370x |
- pth = path,+ as.list(pth[seq_len(pthlen_new - 2)]), |
| 426 | -3229x | +370x |
- repext = repr_ext,+ replicate(maxlen - pthlen, list(NA_character_)), |
| 427 | -3229x | +370x |
- repind = repr_inds,+ as.list(tail(pth, 2)), |
| 428 | -3229x | +370x |
- indent = indent,+ list( |
| 429 | -3229x | +370x |
- nrowrefs = length(row_footnotes(tt)),+ label_name = rdfrow$label, |
| 430 | -3229x | +370x |
- ncellrefs = 0L,+ row_num = rdfrow$abs_rownumber, |
| 431 | -3229x | +370x |
- nreflines = sum(vapply(row_footnotes(tt), nlines, NA_integer_,+ content = FALSE, |
| 432 | -3229x | +370x |
- colwidths = colwidths,+ node_class = rdfrow$node_class |
| 433 | -3229x | +
- max_width = max_width,+ ) |
|
| 434 | -3229x | +
- fontspec = fontspec,+ ) |
|
| 435 | -3229x | +
- col_gap = col_gap+ } |
|
| 436 |
- )),+ |
||
| 437 | -3229x | +
- trailing_sep = trailing_section_div(tt),+ .remove_root_elems_from_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) {
|
|
| 438 | -3229x | +624x |
- fontspec = fontspec+ any_root_paths <- path[1] %in% which_root_name |
| 439 | -+ | 624x |
- )+ if (any_root_paths) {
|
| 440 | -3229x | +274x |
- if (!labelrow_visible(tt)) {
+ if (isTRUE(all)) {
|
| 441 | -! | +
- ret <- ret[0, , drop = FALSE]+ # Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later) |
|
| 442 | -+ | 274x |
- }+ root_indices <- which(path %in% which_root_name) |
| 443 | -3229x | +274x |
- ret+ if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE
|
| 444 | -+ | ! |
- }+ end_point_root_headers <- which(diff(root_indices) > 1)[1] |
| 445 |
- )+ } else {
|
||
| 446 | -+ | 274x |
-
+ end_point_root_headers <- length(root_indices) |
| 447 |
- setGeneric("inner_col_df", function(ct,
+ } |
||
| 448 | -+ | 274x |
- colwidths = NULL,+ root_path_to_remove <- seq_len(end_point_root_headers) |
| 449 |
- visible_only = TRUE,+ } else {
|
||
| 450 | -+ | ! |
- colnum = 0L,+ root_path_to_remove <- 1 |
| 451 |
- sibpos = NA_integer_,+ } |
||
| 452 | -+ | 274x |
- nsibs = NA_integer_,+ path <- path[-root_path_to_remove] |
| 453 |
- ncolref = 0L,+ } |
||
| 454 |
- na_str,+ |
||
| 455 |
- global_cc_format) {
+ # Fix for very edge case where we have only root elements |
||
| 456 | -18785x | +624x |
- standardGeneric("inner_col_df")
+ if (length(path) == 0) {
|
| 457 | -+ | 1x |
- })+ path <- which_root_name[1] |
| 458 |
-
+ } |
||
| 459 |
- #' Column layout summary+ |
||
| 460 | -+ | 624x |
- #'+ path |
| 461 |
- #' Used for pagination. Generate a structural summary of the columns of an `rtables` table and return it as a+ } |
||
| 462 |
- #' `data.frame`.+ |
||
| 463 |
- #'+ handle_rdf_row <- function(rdfrow, maxlen) {
|
||
| 464 | -+ | 623x |
- #' @inheritParams formatters::make_row_df+ nclass <- rdfrow$node_class |
| 465 |
- #' @param ccount_format (`FormatSpec`)\cr The format to be used by default for+ |
||
| 466 | -+ | 623x |
- #' column counts if one is not specified for an individual column count.+ ret <- switch(nclass, |
| 467 | -+ | 623x |
- #' @param na_str (`character(1)`)\cr The string to display when a column count is NA. Users should not need to set this.+ LabelRow = do_label_row(rdfrow, maxlen), |
| 468 | -+ | 623x |
- #' @export+ ContentRow = do_content_row(rdfrow, maxlen), |
| 469 | -+ | 623x |
- make_col_df <- function(tt,+ DataRow = do_data_row(rdfrow, maxlen), |
| 470 | -+ | 623x |
- colwidths = NULL,+ stop("Unrecognized node type in row dataframe, unable to generate result data frame")
|
| 471 |
- visible_only = TRUE,+ ) |
||
| 472 | -+ | 623x |
- na_str = "",+ setNames(ret, make_result_df_md_colnames(maxlen)) |
| 473 |
- ccount_format = colcount_format(tt) %||% "(N=xx)") {
+ } |
||
| 474 | -3403x | +
- ctree <- coltree(tt, ccount_format = colcount_format(tt)) ## this is a null op if its already a coltree object+ |
|
| 475 | -3403x | +
- rows <- inner_col_df(ctree,+ # Helper recurrent function to get the column names for the result data frame from the VTableTree |
|
| 476 |
- ## colwidths is currently unused anyway... propose_column_widths(matrix_form(tt, indent_rownames=TRUE)),+ .get_formatted_colnames <- function(clyt) {
|
||
| 477 | -3403x | +91x |
- colwidths = colwidths,+ ret <- obj_label(clyt) |
| 478 | -3403x | +91x |
- visible_only = visible_only,+ if (!nzchar(ret)) {
|
| 479 | -3403x | +13x |
- colnum = 1L,+ ret <- NULL |
| 480 | -3403x | +
- sibpos = 1L,+ } |
|
| 481 | -3403x | +91x |
- nsibs = 1L,+ if (is.null(tree_children(clyt))) {
|
| 482 | -3403x | +! |
- na_str = na_str,+ return(ret) |
| 483 | -3403x | +
- global_cc_format = ccount_format+ } else {
|
|
| 484 | -3403x | +91x |
- ) ## nsiblings includes current so 1 means "only child"+ ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames))) |
| 485 | -+ | 91x |
-
+ colnames(ret) <- NULL |
| 486 | -3403x | +91x |
- do.call(rbind, rows)+ rownames(ret) <- NULL |
| 487 | -+ | 91x |
- }+ return(ret) |
| 488 |
-
+ } |
||
| 489 |
- setMethod(+ } |
||
| 490 |
- "inner_col_df", "LayoutColLeaf",+ # path_enriched_df ------------------------------------------------------------ |
||
| 491 |
- function(ct, colwidths, visible_only,+ # |
||
| 492 |
- colnum,+ #' @describeIn data.frame_export Transform a `TableTree` object to a path-enriched `data.frame`. |
||
| 493 |
- sibpos,+ #' |
||
| 494 |
- nsibs,+ #' @param path_fun (`function`)\cr function to transform paths into single-string row/column names. |
||
| 495 |
- na_str,+ #' @param value_fun (`function`)\cr function to transform cell values into cells of a `data.frame`. Defaults to |
||
| 496 |
- global_cc_format) {
+ #' `collapse_values`, which creates strings where multi-valued cells are collapsed together, separated by `|`. |
||
| 497 | -12047x | +
- list(col_dfrow(+ #' |
|
| 498 | -12047x | +
- col = ct,+ #' @return |
|
| 499 | -12047x | +
- cnum = colnum,+ #' * `path_enriched_df()` returns a `data.frame` of `tt`'s cell values (processed by `value_fun`, with columns named by |
|
| 500 | -12047x | +
- sibpos = sibpos,+ #' the full column paths (processed by `path_fun` and an additional `row_path` column with the row paths (processed |
|
| 501 | -12047x | +
- nsibs = nsibs,+ #' by `path_fun`). |
|
| 502 | -12047x | +
- leaf_indices = colnum,+ #' |
|
| 503 | -12047x | +
- col_fnotes = col_footnotes(ct),+ #' @examples |
|
| 504 | -12047x | +
- ccount_na_str = na_str,+ #' lyt <- basic_table() %>% |
|
| 505 | -12047x | +
- global_cc_format = global_cc_format+ #' split_cols_by("ARM") %>%
|
|
| 506 |
- ))+ #' analyze(c("AGE", "BMRKR2"))
|
||
| 507 |
- }+ #' |
||
| 508 |
- )+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 509 |
-
+ #' path_enriched_df(tbl) |
||
| 510 |
- setMethod(+ #' |
||
| 511 |
- "inner_col_df", "LayoutColTree",+ #' @export |
||
| 512 |
- function(ct, colwidths, visible_only,+ path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) {
|
||
| 513 | -+ | 3x |
- colnum,+ rdf <- make_row_df(tt) |
| 514 | -+ | 3x |
- sibpos,+ cdf <- make_col_df(tt) |
| 515 | -+ | 3x |
- nsibs,+ cvs <- as.data.frame(do.call(rbind, cell_values(tt))) |
| 516 | -+ | 3x |
- na_str,+ cvs <- as.data.frame(lapply(cvs, value_fun)) |
| 517 | -+ | 3x |
- global_cc_format) {
+ row.names(cvs) <- NULL |
| 518 | -6738x | +3x |
- kids <- tree_children(ct)+ colnames(cvs) <- path_fun(cdf$path) |
| 519 | -6738x | +3x |
- ret <- vector("list", length(kids))
+ preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path) |
| 520 | -6738x | +3x |
- for (i in seq_along(kids)) {
+ cbind.data.frame(row_path = preppaths, cvs) |
| 521 | -15382x | +
- k <- kids[[i]]+ } |
|
| 522 | -15382x | +
- newrows <- do.call(+ |
|
| 523 | -15382x | +
- rbind,+ .collapse_char <- "|" |
|
| 524 | -15382x | +
- inner_col_df(k,+ .collapse_char_esc <- "\\|" |
|
| 525 | -15382x | +
- colnum = colnum,+ |
|
| 526 | -15382x | +
- sibpos = i,+ collapse_path <- function(paths) {
|
|
| 527 | -15382x | +196x |
- nsibs = length(kids),+ if (is.list(paths)) {
|
| 528 | -15382x | +6x |
- visible_only = visible_only,+ return(vapply(paths, collapse_path, "")) |
| 529 | -15382x | +
- na_str = na_str,+ } |
|
| 530 | -15382x | +190x |
- global_cc_format = global_cc_format+ paste(paths, collapse = .collapse_char) |
| 531 |
- )+ } |
||
| 532 |
- )+ |
||
| 533 | -15382x | +
- colnum <- max(newrows$abs_pos, colnum, na.rm = TRUE) + 1+ collapse_values <- function(colvals) {
|
|
| 534 | -15382x | +13x |
- ret[[i]] <- newrows+ if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1))
|
| 535 | -+ | ! |
- }+ return(colvals) |
| 536 | -+ | 13x |
-
+ } else if (all(vapply(colvals, length, 1L) == 1)) {
|
| 537 | -6738x | +1x |
- if (!visible_only) {
+ return(unlist(colvals)) |
| 538 | -1300x | +
- allindices <- unlist(lapply(ret, function(df) df$abs_pos[!is.na(df$abs_pos)]))+ } |
|
| 539 | -1300x | +12x |
- thispth <- pos_to_path(tree_pos(ct))+ vapply(colvals, paste, "", collapse = .collapse_char) |
| 540 | -1300x | +
- if (any(nzchar(thispth))) {
+ } |
|
| 541 | -644x | +
| 1 | +
- thisone <- list(col_dfrow(+ ## NB handling the case where there are no values is done during tabulation |
|||
| 542 | -644x | +|||
| 2 | +
- col = ct,+ ## which is the only reason expression(TRUE) is ok, because otherwise |
|||
| 543 | -644x | +|||
| 3 | +
- cnum = NA_integer_,+ ## we (sometimes) run into |
|||
| 544 | -644x | +|||
| 4 | +
- leaf_indices = allindices,+ ## factor()[TRUE] giving <NA> (i.e. length 1) |
|||
| 545 | -644x | +5 | +4457x |
- sibpos = sibpos,+ setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_expr"))
+ |
+
| 6 | ++ | + + | +||
| 7 | ++ |
+ setMethod(+ |
+ ||
| 8 | ++ |
+ "make_subset_expr", "VarLevelSplit",+ |
+ ||
| 9 | ++ |
+ function(spl, val) {
+ |
+ ||
| 10 | ++ |
+ ## this is how custom split functions will communicate the correct expression+ |
+ ||
| 11 | ++ |
+ ## to the column modeling code |
||
| 546 | -644x | +12 | +3338x |
- nsibs = nsibs,+ if (length(value_expr(val)) > 0) {
|
| 547 | -644x | +13 | +12x |
- pth = thispth,+ return(value_expr(val))+ |
+
| 14 | ++ |
+ }+ |
+ ||
| 15 | ++ | + | ||
| 548 | -644x | +16 | +3326x |
- col_fnotes = col_footnotes(ct),+ v <- unlist(rawvalues(val))+ |
+
| 17 | ++ |
+ ## XXX if we're including all levels should even missing be included? |
||
| 549 | -644x | +18 | +3326x |
- ccount_na_str = na_str,+ if (is(v, "AllLevelsSentinel")) {
|
| 550 | -644x | +19 | +9x |
- global_cc_format = global_cc_format+ as.expression(bquote((!is.na(.(a))), list(a = as.name(spl_payload(spl))))) |
| 551 | +20 |
- ))+ } else {
|
||
| 552 | -644x | +21 | +3317x |
- ret <- c(thisone, ret)+ as.expression(bquote((!is.na(.(a)) & .(a) %in% .(b)), list(+ |
+
| 22 | +3317x | +
+ a = as.name(spl_payload(spl)),+ |
+ ||
| 23 | +3317x | +
+ b = v |
||
| 553 | +24 |
- }+ ))) |
||
| 554 | +25 |
} |
||
| 555 | +26 |
-
+ } |
||
| 556 | -6738x | +|||
| 27 | +
- ret+ ) |
|||
| 557 | +28 |
- }+ |
||
| 558 | +29 |
- )+ setMethod( |
||
| 559 | +30 |
-
+ "make_subset_expr", "MultiVarSplit", |
||
| 560 | +31 |
- ## THIS INCLUDES BOTH "table stub" (i.e. column label and top_left) AND+ function(spl, val) {
|
||
| 561 | +32 |
- ## title/subtitle!!!!!+ ## this is how custom split functions will communicate the correct expression |
||
| 562 | +33 |
- .header_rep_nlines <- function(tt, colwidths, max_width, fontspec, verbose = FALSE) {
+ ## to the column modeling code |
||
| 563 | -3x | +34 | +300x |
- cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)+ if (length(value_expr(val)) > 0) {
|
| 564 | -3x | +|||
| 35 | +! |
- if (any(nzchar(all_titles(tt)))) {
+ return(value_expr(val)) |
||
| 565 | +36 |
- ## +1 is for blank line between subtitles and divider+ } |
||
| 566 | -2x | +|||
| 37 | +
- tlines <- sum(nlines(all_titles(tt),+ |
|||
| 567 | -2x | +|||
| 38 | +
- colwidths = colwidths,+ ## v = rawvalues(val) |
|||
| 568 | -2x | +|||
| 39 | +
- max_width = max_width,+ ## as.expression(bquote(!is.na(.(a)), list(a = v))) |
|||
| 569 | -2x | +40 | +300x |
- fontspec = fontspec+ expression(TRUE) |
| 570 | -2x | +|||
| 41 | +
- )) + divider_height(tt) + 1L+ } |
|||
| 571 | +42 |
- } else {
+ ) |
||
| 572 | -1x | +|||
| 43 | +
- tlines <- 0+ |
|||
| 573 | +44 |
- }+ setMethod( |
||
| 574 | -3x | +|||
| 45 | +
- ret <- cinfo_lines + tlines+ "make_subset_expr", "AnalyzeVarSplit", |
|||
| 575 | -3x | +|||
| 46 | +
- if (verbose) {
+ function(spl, val) {
|
|||
| 576 | +47 | ! |
- message(+ if (avar_inclNAs(spl)) {
|
|
| 577 | +48 | ! |
- "Lines required for header content: ",+ expression(TRUE)+ |
+ |
| 49 | ++ |
+ } else {
|
||
| 578 | +50 | ! |
- ret, " (col info: ", cinfo_lines, ", titles: ", tlines, ")"+ as.expression(bquote(+ |
+ |
| 51 | +! | +
+ !is.na(.(a)),+ |
+ ||
| 52 | +! | +
+ list(a = as.name(spl_payload(spl))) |
||
| 579 | +53 |
- )+ )) |
||
| 580 | +54 | ++ |
+ }+ |
+ |
| 55 |
} |
|||
| 581 | -3x | +|||
| 56 | +
- ret+ ) |
|||
| 582 | +57 |
- }+ |
||
| 583 | +58 | ++ |
+ setMethod(+ |
+ |
| 59 | ++ |
+ "make_subset_expr", "AnalyzeColVarSplit",+ |
+ ||
| 60 | ++ |
+ function(spl, val) {
+ |
+ ||
| 61 | +! | +
+ expression(TRUE)+ |
+ ||
| 62 | ++ |
+ }+ |
+ ||
| 63 | ++ |
+ )+ |
+ ||
| 64 | ||||
| 584 | +65 |
- ## this is ***only*** lines that are expected to be repeated on multiple pages:+ ## XXX these are going to be ridiculously slow |
||
| 585 | +66 |
- ## main footer, prov footer, and referential footnotes on **columns**+ ## FIXME |
||
| 586 | +67 | |||
| 587 | +68 |
- .footer_rep_nlines <- function(tt, colwidths, max_width, have_cfnotes, fontspec, verbose = FALSE) {
+ setMethod(+ |
+ ||
| 69 | ++ |
+ "make_subset_expr", "VarStaticCutSplit",+ |
+ ||
| 70 | ++ |
+ function(spl, val) {
|
||
| 588 | -3x | +71 | +135x |
- flines <- nlines(main_footer(tt),+ v <- rawvalues(val)+ |
+
| 72 | ++ |
+ ## as.expression(bquote(which(cut(.(a), breaks=.(brk), labels = .(labels), |
||
| 589 | -3x | +73 | +135x |
- colwidths = colwidths,+ as.expression(bquote( |
| 590 | -3x | +74 | +135x |
- max_width = max_width - table_inset(tt),+ cut(.(a), |
| 591 | -3x | +75 | +135x |
- fontspec = fontspec+ breaks = .(brk), labels = .(labels), |
| 592 | -+ | |||
| 76 | +135x |
- ) ++ include.lowest = TRUE |
||
| 593 | -3x | +77 | +135x |
- nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec)+ ) == .(b), |
| 594 | -3x | +78 | +135x |
- if (flines > 0) {
+ list( |
| 595 | -2x | +79 | +135x |
- dl_contrib <- if (have_cfnotes) 0 else divider_height(tt)+ a = as.name(spl_payload(spl)), |
| 596 | -2x | +80 | +135x |
- flines <- flines + dl_contrib + 1L+ b = v,+ |
+
| 81 | +135x | +
+ brk = spl_cuts(spl),+ |
+ ||
| 82 | +135x | +
+ labels = spl_cutlabels(spl) |
||
| 597 | +83 | ++ |
+ )+ |
+ |
| 84 | ++ |
+ ))+ |
+ ||
| 85 | ++ |
+ }+ |
+ ||
| 86 | ++ |
+ )+ |
+ ||
| 87 | ++ | + + | +||
| 88 | ++ |
+ ## NB this assumes spl_cutlabels(spl) is in order!!!!!!+ |
+ ||
| 89 | ++ |
+ setMethod(+ |
+ ||
| 90 | ++ |
+ "make_subset_expr", "CumulativeCutSplit",+ |
+ ||
| 91 |
- }+ function(spl, val) {
+ |
+ |||
| 92 | +63x | +
+ v <- rawvalues(val) |
||
| 598 | +93 |
-
+ ## as.expression(bquote(which(as.integer(cut(.(a), breaks=.(brk), |
||
| 599 | -3x | +94 | +63x |
- if (verbose) {
+ as.expression(bquote( |
| 600 | -! | +|||
| 95 | +63x |
- message(+ as.integer(cut(.(a), |
||
| 601 | -! | +|||
| 96 | +63x |
- "Determining lines required for footer content",+ breaks = .(brk), |
||
| 602 | -! | +|||
| 97 | +63x |
- if (have_cfnotes) " [column fnotes present]",+ labels = .(labels), |
||
| 603 | -! | +|||
| 98 | +63x |
- ": ", flines, " lines"+ include.lowest = TRUE |
||
| 604 | +99 |
- )+ )) <= |
||
| 605 | -+ | |||
| 100 | +63x |
- }+ as.integer(factor(.(b), levels = .(labels))), |
||
| 606 | -+ | |||
| 101 | +63x |
-
+ list( |
||
| 607 | -3x | +102 | +63x |
- flines+ a = as.name(spl_payload(spl)), |
| 608 | -+ | |||
| 103 | +63x |
- }+ b = v, |
||
| 609 | -+ | |||
| 104 | +63x |
-
+ brk = spl_cuts(spl), |
||
| 610 | -+ | |||
| 105 | +63x |
- # Pagination ---------------------------------------------------------------+ labels = spl_cutlabels(spl) |
||
| 611 | +106 |
-
+ ) |
||
| 612 | +107 |
- #' Pagination of a `TableTree`+ )) |
||
| 613 | +108 |
- #'+ } |
||
| 614 | +109 |
- #' Paginate an `rtables` table in the vertical and/or horizontal direction, as required for the specified page size.+ ) |
||
| 615 | +110 |
- #'+ |
||
| 616 | +111 |
- #' @inheritParams gen_args+ ## I think this one is unnecessary, |
||
| 617 | +112 |
- #' @inheritParams paginate_table+ ## build_table collapses DynCutSplits into |
||
| 618 | +113 |
- #' @param lpp (`numeric(1)`)\cr maximum lines per page including (re)printed header and context rows.+ ## static ones. |
||
| 619 | +114 |
- #' @param min_siblings (`numeric(1)`)\cr minimum sibling rows which must appear on either side of pagination row for a+ ## |
||
| 620 | +115 |
- #' mid-subtable split to be valid. Defaults to 2.+ ## XXX TODO fixme |
||
| 621 | +116 |
- #' @param nosplitin (`character`)\cr names of sub-tables where page-breaks are not allowed, regardless of other+ ## setMethod("make_subset_expr", "VarDynCutSplit",
|
||
| 622 | +117 |
- #' considerations. Defaults to none.+ ## function(spl, val) {
|
||
| 623 | +118 |
- #'+ ## v = rawvalues(val) |
||
| 624 | +119 |
- #' @return+ ## ## as.expression(bquote(which(.(fun)(.(a)) == .(b)), |
||
| 625 | +120 |
- #' * `pag_tt_indices` returns a list of paginated-groups of row-indices of `tt`.+ ## as.expression(bquote(.(fun)(.(a)) == .(b)), |
||
| 626 | +121 |
- #' * `paginate_table` returns the subtables defined by subsetting by the indices defined by `pag_tt_indices`.+ ## list(a = as.name(spl_payload(spl)), |
||
| 627 | +122 |
- #'+ ## b = v, |
||
| 628 | +123 |
- #' @details+ ## fun = spl@cut_fun)) |
||
| 629 | +124 |
- #' `rtables` pagination is context aware, meaning that label rows and row-group summaries (content rows) are repeated+ ## }) |
||
| 630 | +125 |
- #' after (vertical) pagination, as appropriate. This allows the reader to immediately understand where they are in the+ |
||
| 631 | +126 |
- #' table after turning to a new page, but does also mean that a rendered, paginated table will take up more lines of+ setMethod( |
||
| 632 | +127 |
- #' text than rendering the table without pagination would.+ "make_subset_expr", "AllSplit", |
||
| 633 | -+ | |||
| 128 | +327x |
- #'+ function(spl, val) expression(TRUE) |
||
| 634 | +129 |
- #' Pagination also takes into account word-wrapping of title, footer, column-label, and formatted cell value content.+ ) |
||
| 635 | +130 |
- #'+ |
||
| 636 | +131 |
- #' Vertical pagination information (pagination `data.frame`) is created using (`make_row_df`).+ ## probably don't need this |
||
| 637 | +132 |
- #'+ |
||
| 638 | +133 |
- #' Horizontal pagination is performed by creating a pagination data frame for the columns, and then applying the same+ setMethod( |
||
| 639 | +134 |
- #' algorithm used for vertical pagination to it.+ "make_subset_expr", "expression", |
||
| 640 | -+ | |||
| 135 | +! |
- #'+ function(spl, val) spl |
||
| 641 | +136 |
- #' If physical page size and font information are specified, these are used to derive lines-per-page (`lpp`) and+ ) |
||
| 642 | +137 |
- #' characters-per-page (`cpp`) values.+ |
||
| 643 | +138 |
- #'+ setMethod( |
||
| 644 | +139 |
- #' The full multi-direction pagination algorithm then is as follows:+ "make_subset_expr", "character", |
||
| 645 | +140 |
- #'+ function(spl, val) {
|
||
| 646 | -+ | |||
| 141 | +! |
- #' 0. Adjust `lpp` and `cpp` to account for rendered elements that are not rows (columns):+ newspl <- VarLevelSplit(spl, spl) |
||
| 647 | -+ | |||
| 142 | +! |
- #' - titles/footers/column labels, and horizontal dividers in the vertical pagination case+ make_subset_expr(newspl, val) |
||
| 648 | +143 |
- #' - row-labels, table_inset, and top-left materials in the horizontal case+ } |
||
| 649 | +144 |
- #' 1. Perform 'forced pagination' representing page-by row splits, generating 1 or more tables.+ ) |
||
| 650 | +145 |
- #' 2. Perform vertical pagination separately on each table generated in (1).+ |
||
| 651 | +146 |
- #' 3. Perform horizontal pagination **on the entire table** and apply the results to each table+ .combine_subset_exprs <- function(ex1, ex2) {
|
||
| 652 | -+ | |||
| 147 | +3035x |
- #' page generated in (1)-(2).+ if (is.null(ex1) || identical(ex1, expression(TRUE))) {
|
||
| 653 | -+ | |||
| 148 | +1917x |
- #' 4. Return a list of subtables representing full bi-directional pagination.+ if (is.expression(ex2) && !identical(ex2, expression(TRUE))) {
|
||
| 654 | -+ | |||
| 149 | +1472x |
- #'+ return(ex2) |
||
| 655 | +150 |
- #' Pagination in both directions is done using the *Core Pagination Algorithm* implemented in the `formatters` package:+ } else {
|
||
| 656 | -+ | |||
| 151 | +445x |
- #'+ return(expression(TRUE)) |
||
| 657 | +152 |
- #' @inheritSection formatters::pagination_algo Pagination Algorithm+ } |
||
| 658 | +153 |
- #'+ } |
||
| 659 | +154 |
- #' @examples+ |
||
| 660 | +155 |
- #' s_summary <- function(x) {
+ ## if(is.null(ex2)) |
||
| 661 | +156 |
- #' if (is.numeric(x)) {
+ ## ex2 <- expression(TRUE) |
||
| 662 | -+ | |||
| 157 | +1118x |
- #' in_rows(+ stopifnot(is.expression(ex1), is.expression(ex2)) |
||
| 663 | -+ | |||
| 158 | +1118x |
- #' "n" = rcell(sum(!is.na(x)), format = "xx"),+ as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]]))) |
||
| 664 | +159 |
- #' "Mean (sd)" = rcell(c(mean(x, na.rm = TRUE), sd(x, na.rm = TRUE)),+ } |
||
| 665 | +160 |
- #' format = "xx.xx (xx.xx)"+ |
||
| 666 | +161 |
- #' ),+ make_pos_subset <- function(spls = pos_splits(pos), |
||
| 667 | +162 |
- #' "IQR" = rcell(IQR(x, na.rm = TRUE), format = "xx.xx"),+ svals = pos_splvals(pos), |
||
| 668 | +163 |
- #' "min - max" = rcell(range(x, na.rm = TRUE), format = "xx.xx - xx.xx")+ pos) {
|
||
| 669 | -+ | |||
| 164 | +1037x |
- #' )+ expr <- NULL |
||
| 670 | -+ | |||
| 165 | +1037x |
- #' } else if (is.factor(x)) {
+ for (i in seq_along(spls)) {
|
||
| 671 | -+ | |||
| 166 | +1613x |
- #' vs <- as.list(table(x))+ newexpr <- make_subset_expr(spls[[i]], svals[[i]]) |
||
| 672 | -+ | |||
| 167 | +1613x |
- #' do.call(in_rows, lapply(vs, rcell, format = "xx"))+ expr <- .combine_subset_exprs(expr, newexpr) |
||
| 673 | +168 |
- #' } else {
+ } |
||
| 674 | -+ | |||
| 169 | +1037x |
- #' (+ expr |
||
| 675 | +170 |
- #' stop("type not supported")
+ } |
||
| 676 | +171 |
- #' )+ |
||
| 677 | +172 |
- #' }+ get_pos_extra <- function(svals = pos_splvals(pos), |
||
| 678 | +173 |
- #' }+ pos) {
|
||
| 679 | -+ | |||
| 174 | +1043x |
- #'+ ret <- list() |
||
| 680 | -+ | |||
| 175 | +1043x |
- #' lyt <- basic_table() %>%+ for (i in seq_along(svals)) {
|
||
| 681 | -+ | |||
| 176 | +1625x |
- #' split_cols_by(var = "ARM") %>%+ extrs <- splv_extra(svals[[i]]) |
||
| 682 | -+ | |||
| 177 | +1625x |
- #' analyze(c("AGE", "SEX", "BEP01FL", "BMRKR1", "BMRKR2", "COUNTRY"), afun = s_summary)
+ if (any(names(ret) %in% names(extrs))) {
|
||
| 683 | -+ | |||
| 178 | +! |
- #'+ stop("same extra argument specified at multiple levels of nesting. Not currently supported")
|
||
| 684 | +179 |
- #' tbl <- build_table(lyt, ex_adsl)+ } |
||
| 685 | -+ | |||
| 180 | +1625x |
- #' tbl+ ret <- c(ret, extrs) |
||
| 686 | +181 |
- #'+ } |
||
| 687 | -+ | |||
| 182 | +1043x |
- #' nrow(tbl)+ ret |
||
| 688 | +183 |
- #'+ } |
||
| 689 | +184 |
- #' row_paths_summary(tbl)+ |
||
| 690 | +185 |
- #'+ get_col_extras <- function(ctree) {
|
||
| 691 | -+ | |||
| 186 | +327x |
- #' tbls <- paginate_table(tbl, lpp = 15)+ leaves <- collect_leaves(ctree) |
||
| 692 | -+ | |||
| 187 | +327x |
- #' mf <- matrix_form(tbl, indent_rownames = TRUE)+ lapply( |
||
| 693 | -+ | |||
| 188 | +327x |
- #' w_tbls <- propose_column_widths(mf) # so that we have the same column widths+ leaves, |
||
| 694 | -+ | |||
| 189 | +327x |
- #'+ function(x) get_pos_extra(pos = tree_pos(x)) |
||
| 695 | +190 |
- #'+ ) |
||
| 696 | +191 |
- #' tmp <- lapply(tbls, function(tbli) {
+ } |
||
| 697 | +192 |
- #' cat(toString(tbli, widths = w_tbls))+ |
||
| 698 | +193 |
- #' cat("\n\n")
+ setGeneric( |
||
| 699 | +194 |
- #' cat("~~~~ PAGE BREAK ~~~~")
+ "make_col_subsets", |
||
| 700 | -+ | |||
| 195 | +1363x |
- #' cat("\n\n")
+ function(lyt, df) standardGeneric("make_col_subsets")
|
||
| 701 | +196 |
- #' })+ ) |
||
| 702 | +197 |
- #'+ |
||
| 703 | +198 |
- #' @rdname paginate+ setMethod( |
||
| 704 | +199 |
- #' @export+ "make_col_subsets", "LayoutColTree", |
||
| 705 | +200 |
- pag_tt_indices <- function(tt,+ function(lyt, df) {
|
||
| 706 | -+ | |||
| 201 | +326x |
- lpp = 15,+ leaves <- collect_leaves(lyt) |
||
| 707 | -+ | |||
| 202 | +326x |
- min_siblings = 2,+ lapply(leaves, make_col_subsets) |
||
| 708 | +203 |
- nosplitin = character(),+ } |
||
| 709 | +204 |
- colwidths = NULL,+ ) |
||
| 710 | +205 |
- max_width = NULL,+ |
||
| 711 | +206 |
- fontspec = NULL,+ setMethod( |
||
| 712 | +207 |
- col_gap = 3,+ "make_col_subsets", "LayoutColLeaf", |
||
| 713 | +208 |
- verbose = FALSE) {
+ function(lyt, df) {
|
||
| 714 | -3x | +209 | +1037x |
- dheight <- divider_height(tt)+ make_pos_subset(pos = tree_pos(lyt)) |
| 715 | +210 |
-
+ } |
||
| 716 | +211 |
- # cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width)- |
- ||
| 717 | -3x | -
- coldf <- make_col_df(tt, colwidths)- |
- ||
| 718 | -3x | -
- have_cfnotes <- length(unlist(coldf$col_fnotes)) > 0+ ) |
||
| 719 | +212 | |||
| 720 | -3x | -
- hlines <- .header_rep_nlines(tt,- |
- ||
| 721 | -3x | -
- colwidths = colwidths, max_width = max_width,- |
- ||
| 722 | -3x | +|||
| 213 | +
- verbose = verbose,+ create_colinfo <- function(lyt, df, rtpos = TreePos(), |
|||
| 723 | -3x | +|||
| 214 | +
- fontspec = fontspec+ counts = NULL, |
|||
| 724 | +215 |
- )+ alt_counts_df = NULL, |
||
| 725 | +216 |
- ## if(any(nzchar(all_titles(tt)))) {
+ total = NULL, |
||
| 726 | +217 |
- ## tlines <- sum(nlines(all_titles(tt), colwidths = colwidths, max_width = max_width)) ++ topleft = NULL) {
|
||
| 727 | +218 |
- ## length(wrap_txt(all_titles(tt), max_width = max_width)) ++ ## this will work whether clayout is pre or post |
||
| 728 | +219 |
- ## dheight + 1L+ ## data |
||
| 729 | -+ | |||
| 220 | +332x |
- ## } else {
+ clayout <- clayout(lyt) |
||
| 730 | -+ | |||
| 221 | +332x |
- ## tlines <- 0+ if (is.null(topleft)) {
|
||
| 731 | -+ | |||
| 222 | +332x |
- ## }+ topleft <- top_left(lyt) |
||
| 732 | +223 |
- ## flines <- nlines(main_footer(tt), colwidths = colwidths,+ } |
||
| 733 | -+ | |||
| 224 | +332x |
- ## max_width = max_width - table_inset(tt)) ++ cc_format <- colcount_format(lyt) %||% "(N=xx)" |
||
| 734 | +225 |
- ## nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width)+ |
||
| 735 | +226 |
- ## if(flines > 0) {
+ ## do it this way for full backwards compatibility |
||
| 736 | -+ | |||
| 227 | +332x |
- ## dl_contrib <- if(have_cfnotes) 0 else dheight+ if (is.null(alt_counts_df)) {
|
||
| 737 | -+ | |||
| 228 | +313x |
- ## flines <- flines + dl_contrib + 1L+ alt_counts_df <- df |
||
| 738 | +229 |
- ## }+ } |
||
| 739 | -3x | +230 | +332x |
- flines <- .footer_rep_nlines(tt,+ ctree <- coltree(clayout, df = df, rtpos = rtpos, alt_counts_df = alt_counts_df, ccount_format = cc_format) |
| 740 | -3x | +231 | +325x |
- colwidths = colwidths,+ if (!is.na(disp_ccounts(lyt))) {
|
| 741 | -3x | +232 | +83x |
- max_width = max_width,+ leaf_pths <- make_col_df(ctree, visible_only = TRUE, na_str = "", ccount_format = cc_format)$path |
| 742 | -3x | +233 | +83x |
- have_cfnotes = have_cfnotes,+ for (path in leaf_pths) {
|
| 743 | -3x | +234 | +327x |
- fontspec = fontspec,+ colcount_visible(ctree, path) <- disp_ccounts(lyt) |
| 744 | -3x | +|||
| 235 | +
- verbose = verbose+ } |
|||
| 745 | +236 |
- )+ } |
||
| 746 | +237 |
- ## row lines per page+ |
||
| 747 | -3x | +238 | +325x |
- rlpp <- lpp - hlines - flines+ cexprs <- make_col_subsets(ctree, df) |
| 748 | -3x | -
- if (verbose) {
- |
- ||
| 749 | -! | -
- message(- |
- ||
| 750 | -! | +239 | +325x |
- "Adjusted Lines Per Page: ",+ colextras <- col_extra_args(ctree) |
| 751 | -! | +|||
| 240 | +
- rlpp, " (original lpp: ", lpp, ")"+ |
|||
| 752 | +241 |
- )+ ## calculate the counts based on the df |
||
| 753 | +242 |
- }+ ## This presumes that it is called on the WHOLE dataset, |
||
| 754 | -3x | +|||
| 243 | +
- pagdf <- make_row_df(tt, colwidths, max_width = max_width)+ ## NOT after any splitting has occurred. Otherwise |
|||
| 755 | +244 |
-
+ ## the counts will obviously be wrong. |
||
| 756 | -3x | +245 | +325x |
- pag_indices_inner(pagdf,+ if (is.null(counts)) {
|
| 757 | -3x | +246 | +321x |
- rlpp = rlpp, min_siblings = min_siblings,+ counts <- rep(NA_integer_, length(cexprs)) |
| 758 | -3x | +247 | +4x |
- nosplitin = nosplitin,+ } else if (length(counts) != length(cexprs)) {
|
| 759 | -3x | +248 | +1x |
- verbose = verbose,+ stop( |
| 760 | -3x | +249 | +1x |
- have_col_fnotes = have_cfnotes,+ "Length of overriding counts must equal number of columns. Got ", |
| 761 | -3x | +250 | +1x |
- div_height = dheight,+ length(counts), " values for ", length(cexprs), " columns. ", |
| 762 | -3x | +251 | +1x |
- col_gap = col_gap,+ "Use NAs to specify that the default counting machinery should be ", |
| 763 | -3x | +252 | +1x |
- has_rowlabels = TRUE+ "used for that position." |
| 764 | +253 |
- )+ ) |
||
| 765 | +254 |
- }+ } |
||
| 766 | +255 | |||
| 767 | -- |
- copy_title_footer <- function(to, from, newptitle) {
- |
- ||
| 768 | -18x | +256 | +324x |
- main_title(to) <- main_title(from)+ counts_df_name <- "alt_counts_df" |
| 769 | -18x | +257 | +324x |
- subtitles(to) <- subtitles(from)+ if (identical(alt_counts_df, df)) { # is.null(alt_counts_df)) {
|
| 770 | -18x | +258 | +309x |
- page_titles(to) <- c(page_titles(from), newptitle)+ alt_counts_df <- df |
| 771 | -18x | +259 | +309x |
- main_footer(to) <- main_footer(from)+ counts_df_name <- "df" |
| 772 | -18x | +|||
| 260 | +
- prov_footer(to) <- prov_footer(from)+ } |
|||
| 773 | -18x | -
- to- |
- ||
| 774 | -+ | 261 | +324x |
- }+ calcpos <- is.na(counts) |
| 775 | +262 | |||
| 776 | -+ | |||
| 263 | +324x |
- pag_btw_kids <- function(tt) {
+ calccounts <- sapply(cexprs, function(ex) {
|
||
| 777 | -8x | +264 | +1028x |
- pref <- ptitle_prefix(tt)+ if (identical(ex, expression(TRUE))) {
|
| 778 | -8x | +265 | +149x |
- lapply(+ nrow(alt_counts_df) |
| 779 | -8x | +266 | +879x |
- tree_children(tt),+ } else if (identical(ex, expression(FALSE))) {
|
| 780 | -8x | +|||
| 267 | +! |
- function(tbl) {
+ 0L |
||
| 781 | -18x | +|||
| 268 | +
- tbl <- copy_title_footer(+ } else {
|
|||
| 782 | -18x | +269 | +879x |
- tbl, tt,+ vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE) |
| 783 | -18x | +270 | +879x |
- paste(pref, obj_label(tbl), sep = ": ")+ if (is(vec, "numeric")) {
|
| 784 | -+ | |||
| 271 | +! |
- )+ length(vec) |
||
| 785 | -18x | +272 | +879x |
- labelrow_visible(tbl) <- FALSE+ } else if (is(vec, "logical")) { ## sum(is.na(.)) ????
|
| 786 | -18x | +273 | +879x |
- tbl+ sum(vec, na.rm = TRUE) |
| 787 | +274 |
- }+ } |
||
| 788 | +275 |
- )+ } |
||
| 789 | +276 |
- }+ }) |
||
| 790 | -+ | |||
| 277 | +324x |
-
+ counts[calcpos] <- calccounts[calcpos] |
||
| 791 | -+ | |||
| 278 | +324x |
- force_paginate <- function(tt,+ counts <- as.integer(counts) |
||
| 792 | -+ | |||
| 279 | +324x |
- force_pag = vapply(tree_children(tt), has_force_pag, NA),+ if (is.null(total)) {
+ |
+ ||
| 280 | +! | +
+ total <- sum(counts) |
||
| 793 | +281 |
- verbose = FALSE) {
+ } |
||
| 794 | +282 |
- ## forced pagination is happening at this+ |
||
| 795 | -113x | +283 | +324x |
- if (has_force_pag(tt)) {
+ cpths <- col_paths(ctree) |
| 796 | -8x | +284 | +324x |
- ret <- pag_btw_kids(tt)+ for (i in seq_along(cpths)) {
|
| 797 | -8x | +285 | +1028x |
- return(unlist(lapply(ret, force_paginate)))+ facet_colcount(ctree, cpths[[i]]) <- counts[i] |
| 798 | +286 |
} |
||
| 799 | -105x | +287 | +324x |
- chunks <- list()+ InstantiatedColumnInfo( |
| 800 | -105x | +288 | +324x |
- kinds <- seq_along(force_pag)+ treelyt = ctree, |
| 801 | -105x | +289 | +324x |
- while (length(kinds) > 0) {
+ csubs = cexprs, |
| 802 | -105x | +290 | +324x |
- if (force_pag[kinds[1]]) {
+ extras = colextras, |
| 803 | -! | +|||
| 291 | +324x |
- outertbl <- copy_title_footer(+ cnts = counts, |
||
| 804 | -! | +|||
| 292 | +324x |
- tree_children(tt)[[kinds[1]]],+ dispcounts = disp_ccounts(lyt), |
||
| 805 | -! | +|||
| 293 | +324x |
- tt,+ countformat = cc_format, |
||
| 806 | -! | +|||
| 294 | +324x |
- NULL+ total_cnt = total, |
||
| 807 | -+ | |||
| 295 | +324x |
- )+ topleft = topleft |
||
| 808 | +296 |
-
+ ) |
||
| 809 | -! | +|||
| 297 | +
- chunks <- c(chunks, force_paginate(outertbl))+ } |
|||
| 810 | -! | +
| 1 | +
- kinds <- kinds[-1]+ #' Default tabulation |
|||
| 811 | +2 |
- } else {
+ #' |
||
| 812 | -105x | +|||
| 3 | +
- tmptbl <- tt+ #' This function is used when [analyze()] is invoked. |
|||
| 813 | -105x | +|||
| 4 | +
- runend <- min(which(force_pag[kinds]), length(kinds))+ #' |
|||
| 814 | -105x | +|||
| 5 | +
- useinds <- 1:runend+ #' @param x (`vector`)\cr the *already split* data being tabulated for a particular cell/set of cells. |
|||
| 815 | -105x | +|||
| 6 | +
- tree_children(tmptbl) <- tree_children(tt)[useinds]+ #' @param ... additional parameters to pass on. |
|||
| 816 | -105x | +|||
| 7 | +
- chunks <- c(chunks, tmptbl)+ #' |
|||
| 817 | -105x | +|||
| 8 | +
- kinds <- kinds[-useinds]+ #' @details This function has the following behavior given particular types of inputs: |
|||
| 818 | +9 |
- }+ #' \describe{
|
||
| 819 | +10 |
- }+ #' \item{numeric}{calls [mean()] on `x`.}
|
||
| 820 | -105x | +|||
| 11 | +
- unlist(chunks, recursive = TRUE)+ #' \item{logical}{calls [sum()] on `x`.}
|
|||
| 821 | +12 |
- }+ #' \item{factor}{calls [length()] on `x`.}
|
||
| 822 | +13 |
-
+ #' } |
||
| 823 | +14 |
- #' @importFrom formatters do_forced_paginate+ #' |
||
| 824 | +15 |
- setMethod(+ #' The [in_rows()] function is called on the resulting value(s). All other classes of input currently lead to an error. |
||
| 825 | +16 |
- "do_forced_paginate", "VTableTree",+ #' |
||
| 826 | -95x | +|||
| 17 | +
- function(obj) force_paginate(obj)+ #' @inherit in_rows return |
|||
| 827 | +18 |
- )+ #' |
||
| 828 | +19 |
-
+ #' @author Gabriel Becker and Adrian Waddell |
||
| 829 | -186x | +|||
| 20 | +
- non_null_na <- function(x) !is.null(x) && is.na(x)+ #' |
|||
| 830 | +21 |
-
+ #' @examples |
||
| 831 | +22 |
- #' @inheritParams formatters::vert_pag_indices+ #' simple_analysis(1:3) |
||
| 832 | +23 |
- #' @inheritParams formatters::page_lcpp+ #' simple_analysis(iris$Species) |
||
| 833 | +24 |
- #' @inheritParams formatters::toString+ #' simple_analysis(iris$Species == "setosa") |
||
| 834 | +25 |
- #' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) of the pages for horizontal pagination.+ #' |
||
| 835 | +26 |
- #' `NA` (the default) indicates `cpp` should be inferred from the page size; `NULL` indicates no horizontal+ #' @rdname rtinner |
||
| 836 | +27 |
- #' pagination should be done regardless of page size.+ #' @export+ |
+ ||
| 28 | +1598x | +
+ setGeneric("simple_analysis", function(x, ...) standardGeneric("simple_analysis"))
|
||
| 837 | +29 |
- #'+ |
||
| 838 | +30 |
- #' @rdname paginate+ #' @rdname rtinner |
||
| 839 | +31 |
- #' @aliases paginate_table+ #' @exportMethod simple_analysis |
||
| 840 | +32 |
- #' @export+ setMethod( |
||
| 841 | +33 |
- paginate_table <- function(tt,+ "simple_analysis", "numeric",+ |
+ ||
| 34 | +1113x | +
+ function(x, ...) in_rows("Mean" = rcell(mean(x, ...), stat_names = "mean", format = "xx.xx"))
|
||
| 842 | +35 |
- page_type = "letter",+ ) |
||
| 843 | +36 |
- font_family = "Courier",+ |
||
| 844 | +37 |
- font_size = 8,+ #' @rdname rtinner |
||
| 845 | +38 |
- lineheight = 1,+ #' @exportMethod simple_analysis |
||
| 846 | +39 |
- landscape = FALSE,+ setMethod( |
||
| 847 | +40 |
- pg_width = NULL,+ "simple_analysis", "logical",+ |
+ ||
| 41 | +4x | +
+ function(x, ...) in_rows("Count" = rcell(sum(x, ...), stat_names = "n", format = "xx"))
|
||
| 848 | +42 |
- pg_height = NULL,+ ) |
||
| 849 | +43 |
- margins = c(top = .5, bottom = .5, left = .75, right = .75),+ |
||
| 850 | +44 |
- lpp = NA_integer_,+ #' @rdname rtinner |
||
| 851 | +45 |
- cpp = NA_integer_,+ #' @exportMethod simple_analysis |
||
| 852 | +46 |
- min_siblings = 2,+ setMethod( |
||
| 853 | +47 |
- nosplitin = character(),+ "simple_analysis", "factor",+ |
+ ||
| 48 | +481x | +
+ function(x, ...) in_rows(.list = as.list(table(x)), .stat_names = "n") |
||
| 854 | +49 |
- colwidths = NULL,+ ) |
||
| 855 | +50 |
- tf_wrap = FALSE,+ |
||
| 856 | +51 |
- max_width = NULL,+ #' @rdname rtinner |
||
| 857 | +52 |
- fontspec = font_spec(font_family, font_size, lineheight),+ #' @exportMethod simple_analysis |
||
| 858 | +53 |
- col_gap = 3,+ setMethod( |
||
| 859 | +54 |
- verbose = FALSE) {
+ "simple_analysis", "ANY", |
||
| 860 | -51x | +|||
| 55 | +
- new_dev <- open_font_dev(fontspec)+ function(x, ...) {
|
|||
| 861 | -51x | +|||
| 56 | +! |
- if (new_dev) {
+ stop("No default simple_analysis behavior for class ", class(x), " please specify FUN explicitly.")
|
||
| 862 | -38x | +|||
| 57 | +
- on.exit(close_font_dev())+ } |
|||
| 863 | +58 |
- }+ ) |
||
| 864 | +59 | |||
| 865 | -51x | +|||
| 60 | +
- if ((non_null_na(lpp) || non_null_na(cpp)) &&+ #' Check if an object is a valid `rtable` |
|||
| 866 | -51x | +|||
| 61 | +
- (!is.null(page_type) || (!is.null(pg_width) && !is.null(pg_height)))) { # nolint
+ #' |
|||
| 867 | -12x | +|||
| 62 | +
- pg_lcpp <- page_lcpp(+ #' @param x (`ANY`)\cr an object. |
|||
| 868 | -12x | +|||
| 63 | +
- page_type = page_type,+ #' |
|||
| 869 | -12x | +|||
| 64 | +
- font_family = font_family,+ #' @return `TRUE` if `x` is a formal `TableTree` object, `FALSE` otherwise. |
|||
| 870 | -12x | +|||
| 65 | +
- font_size = font_size,+ #' |
|||
| 871 | -12x | +|||
| 66 | +
- lineheight = lineheight,+ #' @examples |
|||
| 872 | -12x | +|||
| 67 | +
- pg_width = pg_width,+ #' is_rtable(build_table(basic_table(), iris)) |
|||
| 873 | -12x | +|||
| 68 | +
- pg_height = pg_height,+ #' |
|||
| 874 | -12x | +|||
| 69 | +
- margins = margins,+ #' @export |
|||
| 875 | -12x | +|||
| 70 | +
- landscape = landscape,+ is_rtable <- function(x) {
|
|||
| 876 | -12x | +71 | +47x |
- fontspec = fontspec+ is(x, "VTableTree") |
| 877 | +72 |
- )+ } |
||
| 878 | +73 | |||
| 879 | -12x | +|||
| 74 | +
- if (non_null_na(lpp)) {
+ # nocov start |
|||
| 880 | -6x | +|||
| 75 | +
- lpp <- pg_lcpp$lpp+ ## is each object in a collection from a class |
|||
| 881 | +76 |
- }+ are <- function(object_collection, class2) {
|
||
| 882 | -12x | +|||
| 77 | +
- if (is.na(cpp)) {
+ all(vapply(object_collection, is, logical(1), class2)) |
|||
| 883 | -8x | +|||
| 78 | +
- cpp <- pg_lcpp$cpp+ } |
|||
| 884 | +79 |
- }+ |
||
| 885 | +80 |
- } else {
+ num_all_equal <- function(x, tol = .Machine$double.eps^0.5) {
|
||
| 886 | -39x | +|||
| 81 | +
- if (non_null_na(cpp)) {
+ stopifnot(is.numeric(x)) |
|||
| 887 | -! | +|||
| 82 | +
- cpp <- NULL+ |
|||
| 888 | +83 |
- }+ if (length(x) == 1) {
|
||
| 889 | -39x | +|||
| 84 | +
- if (non_null_na(lpp)) {
+ return(TRUE) |
|||
| 890 | -! | +|||
| 85 | +
- lpp <- 70+ } |
|||
| 891 | +86 |
- }+ |
||
| 892 | +87 |
- }+ y <- range(x) / mean(x) |
||
| 893 | +88 |
-
+ isTRUE(all.equal(y[1], y[2], tolerance = tol)) |
||
| 894 | -51x | +|||
| 89 | +
- if (is.null(colwidths)) {
+ } |
|||
| 895 | -34x | +|||
| 90 | +
- colwidths <- propose_column_widths(+ |
|||
| 896 | -34x | +|||
| 91 | +
- matrix_form(+ # copied over from utils.nest which is not open-source |
|||
| 897 | -34x | +|||
| 92 | +
- tt,+ all_true <- function(lst, fcn, ...) {
|
|||
| 898 | -34x | +|||
| 93 | +
- indent_rownames = TRUE,+ all(vapply(lst, fcn, logical(1), ...)) |
|||
| 899 | -34x | +|||
| 94 | +
- fontspec = fontspec,+ } |
|||
| 900 | -34x | +|||
| 95 | +
- col_gap = col_gap+ |
|||
| 901 | +96 |
- ),+ is_logical_single <- function(x) {
|
||
| 902 | -34x | +|||
| 97 | +
- fontspec = fontspec+ !is.null(x) && |
|||
| 903 | +98 |
- )+ is.logical(x) && |
||
| 904 | +99 |
- }+ length(x) == 1 && |
||
| 905 | +100 |
-
+ !is.na(x) |
||
| 906 | -51x | +|||
| 101 | +
- if (!tf_wrap) {
+ } |
|||
| 907 | -41x | +|||
| 102 | +
- if (!is.null(max_width)) {
+
|
|||
| 908 | -! | +|||
| 103 | +
- warning("tf_wrap is FALSE - ignoring non-null max_width value.")
+ is_logical_vector_modif <- function(x, min_length = 1) {
|
|||
| 909 | +104 |
- }+ !is.null(x) && |
||
| 910 | -41x | +|||
| 105 | +
- max_width <- NULL+ is.logical(x) && |
|||
| 911 | -10x | +|||
| 106 | +
- } else if (is.null(max_width)) {
+ is.atomic(x) && |
|||
| 912 | -5x | +|||
| 107 | +
- max_width <- cpp+ !anyNA(x) && |
|||
| 913 | -5x | +|||
| 108 | +
- } else if (identical(max_width, "auto")) {
+ ifelse(min_length > 0, length(x) >= min_length, TRUE) |
|||
| 914 | +109 |
- ## XXX this 3 is column sep width!!!!!!!+ } |
||
| 915 | -! | +|||
| 110 | +
- max_width <- sum(colwidths) + col_gap * (length(colwidths) - 1)+ # nocov end |
|||
| 916 | +111 |
- }+ |
||
| 917 | -51x | +|||
| 112 | +
- if (!is.null(cpp) && !is.null(max_width) && max_width > cpp) {
+ # Shorthand for functions that take df as first parameter |
|||
| 918 | -! | +|||
| 113 | +
- warning("max_width specified is wider than characters per page width (cpp).")
+ .takes_df <- function(f) {
+ |
+ |||
| 114 | +1640x | +
+ func_takes(f, "df", is_first = TRUE) |
||
| 919 | +115 |
- }+ } |
||
| 920 | +116 | |||
| 921 | +117 |
- ## taken care of in vert_pag_indices now+ # Checking if function takes parameters |
||
| 922 | +118 |
- ## if(!is.null(cpp))+ func_takes <- function(func, params, is_first = FALSE) {
|
||
| 923 | -+ | |||
| 119 | +11321x |
- ## cpp <- cpp - table_inset(tt)+ if (is.list(func)) {
+ |
+ ||
| 120 | +2323x | +
+ return(lapply(func, func_takes, params = params, is_first = is_first)) |
||
| 924 | +121 |
-
+ } |
||
| 925 | -51x | +122 | +8998x |
- force_pag <- vapply(tree_children(tt), has_force_pag, TRUE)+ if (is.null(func) || !is(func, "function")) {
|
| 926 | -51x | +|||
| 123 | +
- if (has_force_pag(tt) || any(force_pag)) {
+ # safe-net: should this fail instead? |
|||
| 927 | -5x | +124 | +1830x |
- spltabs <- do_forced_paginate(tt)+ return(setNames(rep(FALSE, length(params)), params)) |
| 928 | -5x | +|||
| 125 | +
- spltabs <- unlist(spltabs, recursive = TRUE)+ } |
|||
| 929 | -5x | +126 | +7168x |
- ret <- lapply(spltabs, paginate_table,+ f_params <- formals(func) |
| 930 | -5x | +127 | +7168x |
- lpp = lpp,+ if (!is_first) {
|
| 931 | -5x | +128 | +2281x |
- cpp = cpp,+ return(setNames(params %in% names(f_params), params)) |
| 932 | -5x | +|||
| 129 | +
- min_siblings = min_siblings,+ } else {
|
|||
| 933 | -5x | +130 | +4887x |
- nosplitin = nosplitin,+ if (length(params) > 1L) {
|
| 934 | -5x | +131 | +1x |
- colwidths = colwidths,+ stop("is_first works only with one parameters.")
|
| 935 | -5x | +|||
| 132 | +
- tf_wrap = tf_wrap,+ } |
|||
| 936 | -5x | +133 | +4886x |
- max_width = max_width,+ return(!is.null(f_params) && names(f_params)[1] == params) |
| 937 | -5x | +|||
| 134 | +
- fontspec = fontspec,+ } |
|||
| 938 | -5x | +|||
| 135 | +
- verbose = verbose,+ } |
|||
| 939 | -5x | +|||
| 136 | +
- col_gap = col_gap+ |
|||
| 940 | +137 |
- )+ #' Translate spl_context to a path to display in error messages |
||
| 941 | -5x | +|||
| 138 | +
- return(unlist(ret, recursive = TRUE))+ #' |
|||
| 942 | +139 |
- }+ #' @param ctx (`data.frame`)\cr the `spl_context` data frame where the error occurred. |
||
| 943 | +140 |
-
+ #' |
||
| 944 | -46x | +|||
| 141 | +
- inds <- paginate_indices(tt,+ #' @return A character string containing a description of the row path corresponding to `ctx`. |
|||
| 945 | -46x | +|||
| 142 | +
- page_type = page_type,+ #' |
|||
| 946 | -46x | +|||
| 143 | +
- fontspec = fontspec,+ #' @export |
|||
| 947 | +144 |
- ## font_family = font_family,+ spl_context_to_disp_path <- function(ctx) {
|
||
| 948 | +145 |
- ## font_size = font_size,+ ## this can happen in the first split in column space, but |
||
| 949 | +146 |
- ## lineheight = lineheight,+ ## should never happen in row space |
||
| 950 | -46x | +147 | +20x |
- landscape = landscape,+ if (length(ctx$split) == 0) {
|
| 951 | -46x | +148 | +2x |
- pg_width = pg_width,+ return("root")
+ |
+
| 149 | ++ |
+ } |
||
| 952 | -46x | +150 | +18x |
- pg_height = pg_height,+ if (ctx$split[1] == "root" && ctx$value[1] == "root") {
+ |
+
| 151 | +17x | +
+ ctx <- ctx[-1, ] |
||
| 953 | -46x | +|||
| 152 | +
- margins = margins,+ } |
|||
| 954 | -46x | +153 | +18x |
- lpp = lpp,+ ret <- paste(sprintf("%s[%s]", ctx[["split"]], ctx[["value"]]),
|
| 955 | -46x | +154 | +18x |
- cpp = cpp,+ collapse = "->" |
| 956 | -46x | +|||
| 155 | +
- min_siblings = min_siblings,+ ) |
|||
| 957 | -46x | +156 | +18x |
- nosplitin = nosplitin,+ if (length(ret) == 0 || nchar(ret) == 0) {
|
| 958 | -46x | +157 | +11x |
- colwidths = colwidths,+ ret <- "root" |
| 959 | -46x | +|||
| 158 | +
- tf_wrap = tf_wrap,+ } |
|||
| 960 | -46x | +159 | +18x |
- max_width = max_width,+ ret |
| 961 | -46x | +|||
| 160 | +
- col_gap = col_gap,+ } |
|||
| 962 | -46x | +|||
| 161 | +
- verbose = verbose+ |
|||
| 963 | -46x | +|||
| 162 | +
- ) ## paginate_table apparently doesn't accept indent_size+ # Utility function to paste vector of values in a nice way |
|||
| 964 | +163 |
-
+ paste_vec <- function(vec) {
|
||
| 965 | -41x | +164 | +7x |
- res <- lapply(+ paste0('c("', paste(vec, collapse = '", "'), '")')
|
| 966 | -41x | +|||
| 165 | +
- inds$pag_row_indices,+ } |
|||
| 967 | -41x | +|||
| 166 | +
- function(ii) {
+
|
|||
| 968 | -115x | +|||
| 167 | +
- subt <- tt[ii, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]+ # Utility for checking if a package is installed |
|||
| 969 | -115x | +|||
| 168 | +
- lapply(+ check_required_packages <- function(pkgs) {
|
|||
| 970 | -115x | +|||
| 169 | +! |
- inds$pag_col_indices,+ for (pkgi in pkgs) {
|
||
| 971 | -115x | +|||
| 170 | +! |
- function(jj) {
+ if (!requireNamespace(pkgi, quietly = TRUE)) {
|
||
| 972 | -214x | +|||
| 171 | +! |
- subt[, jj, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE]+ stop( |
||
| 973 | -+ | |||
| 172 | +! |
- }+ "This function requires the ", pkgi, " package. ",+ |
+ ||
| 173 | +! | +
+ "Please install it if you wish to use it" |
||
| 974 | +174 |
) |
||
| 975 | +175 |
} |
||
| 976 | +176 |
- )- |
- ||
| 977 | -41x | -
- res <- unlist(res, recursive = FALSE)- |
- ||
| 978 | -41x | -
- res+ } |
||
| 979 | +177 |
}@@ -101994,147 +102530,147 @@ rtables coverage - 90.21% |
| 1 |
- # as_result_df ------------------------------------------------------------+ #' @import formatters |
|||
| 2 |
- #' Generate a result data frame+ #' @importMethodsFrom formatters toString matrix_form nlines |
|||
| 3 |
- #'+ NULL |
|||
| 4 |
- #' Collection of utilities to extract `data.frame` objects from `TableTree` objects.+ |
|||
| 5 |
- #'+ # toString ---- |
|||
| 6 |
- #' @inheritParams gen_args+ |
|||
| 7 |
- #' @param spec (`function`)\cr function that generates the result data frame from a table (`TableTree`).+ ## #' @export |
|||
| 8 |
- #' It defaults to `NULL`, for standard processing.+ ## setGeneric("toString", function(x,...) standardGeneric("toString"))
|
|||
| 9 |
- #' @param expand_colnames (`flag`)\cr when `TRUE`, the result data frame will have expanded column+ |
|||
| 10 |
- #' names above the usual output. This is useful when the result data frame is used for further processing.+ ## ## preserve S3 behavior |
|||
| 11 |
- #' @param data_format (`string`)\cr the format of the data in the result data frame. It can be one value+ ## setMethod("toString", "ANY", base::toString)
|
|||
| 12 |
- #' between `"full_precision"` (default), `"strings"`, and `"numeric"`. The last two values show the numeric+ |
|||
| 13 |
- #' data with the visible precision.+ ## #' @export |
|||
| 14 |
- #' @param make_ard (`flag`)\cr when `TRUE`, the result data frame will have only one statistic per row.+ ## setMethod("print", "ANY", base::print)
|
|||
| 15 |
- #' @param keep_label_rows (`flag`)\cr when `TRUE`, the result data frame will have all labels+ |
|||
| 16 |
- #' as they appear in the final table.+ #' Convert an `rtable` object to a string |
|||
| 17 |
- #' @param simplify (`flag`)\cr when `TRUE`, the result data frame will have only visible labels and+ #' |
|||
| 18 |
- #' result columns. Consider showing also label rows with `keep_label_rows = TRUE`. This output can be+ #' @inheritParams formatters::toString |
|||
| 19 |
- #' used again to create a `TableTree` object with [df_to_tt()].+ #' @inheritParams gen_args |
|||
| 20 |
- #' @param ... additional arguments passed to spec-specific result data frame function (`spec`).+ #' @inherit formatters::toString |
|||
| 22 |
- #' @return+ #' @return A string representation of `x` as it appears when printed. |
|||
| 23 |
- #' * `as_result_df` returns a result `data.frame`.+ #' |
|||
| 24 |
- #'+ #' @examplesIf require(dplyr) |
|||
| 25 |
- #' @seealso [df_to_tt()] when using `simplify = TRUE` and [formatters::make_row_df()] to have a+ #' library(dplyr) |
|||
| 26 |
- #' comprehensive view of the hierarchical structure of the rows.+ #' |
|||
| 27 |
- #'+ #' iris2 <- iris %>% |
|||
| 28 |
- #' @examples+ #' group_by(Species) %>% |
|||
| 29 |
- #' lyt <- basic_table() %>%+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
|||
| 30 |
- #' split_cols_by("ARM") %>%
+ #' ungroup() |
|||
| 31 |
- #' split_rows_by("STRATA1") %>%
+ #' |
|||
| 32 |
- #' analyze(c("AGE", "BMRKR2"))
+ #' lyt <- basic_table() %>% |
|||
| 33 |
- #'+ #' split_cols_by("Species") %>%
|
|||
| 34 |
- #' tbl <- build_table(lyt, ex_adsl)+ #' split_cols_by("group") %>%
|
|||
| 35 |
- #' as_result_df(tbl, simplify = TRUE)+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
|
|||
| 37 |
- #' @name data.frame_export+ #' tbl <- build_table(lyt, iris2) |
|||
| 38 |
- #' @export+ #' |
|||
| 39 |
- as_result_df <- function(tt, spec = NULL,+ #' cat(toString(tbl, col_gap = 3)) |
|||
| 40 |
- data_format = c("full_precision", "strings", "numeric"),
+ #' |
|||
| 41 |
- make_ard = FALSE,+ #' @rdname tostring |
|||
| 42 |
- expand_colnames = FALSE,+ #' @aliases tostring toString,VTableTree-method |
|||
| 43 |
- keep_label_rows = FALSE,+ #' @exportMethod toString |
|||
| 44 |
- simplify = FALSE,+ setMethod("toString", "VTableTree", function(x,
|
|||
| 45 |
- ...) {
+ widths = NULL, |
|||
| 46 | -24x | +
- data_format <- data_format[[1]]+ col_gap = 3, |
||
| 47 | -24x | +
- checkmate::assert_class(tt, "VTableTree")+ hsep = horizontal_sep(x), |
||
| 48 | -24x | +
- checkmate::assert_function(spec, null.ok = TRUE)+ indent_size = 2, |
||
| 49 | -24x | +
- checkmate::assert_choice(data_format[[1]], choices = eval(formals(as_result_df)[["data_format"]]))+ tf_wrap = FALSE, |
||
| 50 | -24x | +
- checkmate::assert_flag(make_ard)+ max_width = NULL, |
||
| 51 | -24x | +
- checkmate::assert_flag(expand_colnames)+ fontspec = font_spec(), |
||
| 52 | -24x | +
- checkmate::assert_flag(keep_label_rows)+ ttype_ok = FALSE) {
|
||
| 53 | -24x | +40x |
- checkmate::assert_flag(simplify)+ toString( |
|
| 54 | -+ | 40x |
-
+ matrix_form(x, |
|
| 55 | -24x | +40x |
- if (nrow(tt) == 0) {
+ indent_rownames = TRUE, |
|
| 56 | -2x | +40x |
- return(sanitize_table_struct(tt))+ indent_size = indent_size, |
|
| 57 | -+ | 40x |
- }+ fontspec = fontspec, |
|
| 58 | -+ | 40x |
-
+ col_gap = col_gap |
|
| 59 | -22x | +
- if (make_ard) {
+ ), |
||
| 60 | -! | +40x |
- simplify <- FALSE+ widths = widths, col_gap = col_gap, |
|
| 61 | -! | +40x |
- expand_colnames <- TRUE+ hsep = hsep, |
|
| 62 | -! | +40x |
- keep_label_rows <- FALSE+ tf_wrap = tf_wrap, |
|
| 63 | -+ | 40x |
- }+ max_width = max_width, |
|
| 64 | -+ | 40x |
-
+ fontspec = fontspec, |
|
| 65 | -22x | +40x |
- if (is.null(spec)) {
+ ttype_ok = ttype_ok |
|
| 66 | -22x | +
- raw_cvals <- cell_values(tt)+ ) |
||
| 67 |
- ## if the table has one row and multiple columns, sometimes the cell values returns a list of the cell values+ }) |
|||
| 68 |
- ## rather than a list of length 1 representing the single row. This is bad but may not be changeable+ |
|||
| 69 |
- ## at this point.+ #' Table shells |
|||
| 70 | -22x | +
- if (nrow(tt) == 1 && length(raw_cvals) > 1) {
+ #' |
||
| 71 | -2x | +
- raw_cvals <- list(raw_cvals)+ #' A table shell is a rendering of the table which maintains the structure, but does not display the values, rather |
||
| 72 |
- }+ #' displaying the formatting instructions for each cell. |
|||
| 73 |
-
+ #' |
|||
| 74 |
- # Flatten the list of lists (rows) of cell values into a data frame+ #' @inheritParams formatters::toString |
|||
| 75 | -22x | +
- cellvals <- as.data.frame(do.call(rbind, raw_cvals))+ #' @inheritParams gen_args |
||
| 76 | -22x | +
- row.names(cellvals) <- NULL+ #' |
||
| 77 |
-
+ #' @return |
|||
| 78 | -22x | +
- if (nrow(tt) == 1 && ncol(tt) == 1) {
+ #' * `table_shell` returns `NULL`, as the function is called for the side effect of printing the shell to the console. |
||
| 79 | -5x | +
- colnames(cellvals) <- names(raw_cvals)+ #' * `table_shell_str` returns the string representing the table shell. |
||
| 80 |
- }+ #' |
|||
| 81 |
-
+ #' @seealso [value_formats()] for a matrix of formats for each cell in a table. |
|||
| 82 | -22x | +
- if (data_format %in% c("strings", "numeric")) {
+ #' |
||
| 83 |
- # we keep previous calculations to check the format of the data+ #' @examplesIf require(dplyr) |
|||
| 84 | -9x | +
- mf_tt <- matrix_form(tt)+ #' library(dplyr) |
||
| 85 | -9x | +
- mf_result_chars <- mf_strings(mf_tt)[-seq_len(mf_nlheader(mf_tt)), -1]+ #' |
||
| 86 | -9x | +
- mf_result_chars <- .remove_empty_elements(mf_result_chars)+ #' iris2 <- iris %>% |
||
| 87 | -9x | +
- mf_result_numeric <- as.data.frame(+ #' group_by(Species) %>% |
||
| 88 | -9x | +
- .make_numeric_char_mf(mf_result_chars)+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
||
| 89 |
- )+ #' ungroup() |
|||
| 90 | -9x | +
- mf_result_chars <- as.data.frame(mf_result_chars)+ #' |
||
| 91 | -9x | +
- if (!setequal(dim(mf_result_numeric), dim(cellvals)) || !setequal(dim(mf_result_chars), dim(cellvals))) {
+ #' lyt <- basic_table() %>% |
||
| 92 | -! | +
- stop(+ #' split_cols_by("Species") %>%
|
||
| 93 | -! | +
- "The extracted numeric data.frame does not have the same dimension of the",+ #' split_cols_by("group") %>%
|
||
| 94 | -! | +
- " cell values extracted with cell_values(). This is a bug. Please report it."+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx")
|
||
| 95 | -! | +
- ) # nocov+ #' |
||
| 96 |
- }+ #' tbl <- build_table(lyt, iris2) |
|||
| 97 | -9x | +
- if (data_format == "strings") {
+ #' table_shell(tbl) |
||
| 98 | -5x | +
- colnames(mf_result_chars) <- colnames(cellvals)+ #' |
||
| 99 | -5x | +
- cellvals <- mf_result_chars+ #' @export |
||
| 100 |
- } else {
+ table_shell <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(), |
|||
| 101 | -4x | +
- colnames(mf_result_numeric) <- colnames(cellvals)+ tf_wrap = FALSE, max_width = NULL) {
|
||
| 102 | -4x | +2x |
- cellvals <- mf_result_numeric+ cat(table_shell_str( |
|
| 103 | -+ | 2x |
- }+ tt = tt, widths = widths, col_gap = col_gap, hsep = hsep, |
|
| 104 | -+ | 2x |
- }+ tf_wrap = tf_wrap, max_width = max_width |
|
| 105 |
-
+ )) |
|||
| 106 | -22x | +
- rdf <- make_row_df(tt)+ } |
||
| 107 | -22x | +
- cinfo_df <- col_info(tt)+ |
||
| 108 | -22x | +
- ci_coltree <- coltree(cinfo_df)+ ## XXX consider moving to formatters, its really just a function |
||
| 109 | -22x | +
- column_split_names <- .get_column_split_name(ci_coltree) # used only in make_ard+ ## of the MatrixPrintForm |
||
| 110 |
-
+ #' @rdname table_shell |
|||
| 111 | -22x | +
- df <- rdf[, c("name", "label", "abs_rownumber", "path", "reprint_inds", "node_class")]
+ #' @export |
||
| 112 |
- # Removing initial root elements from path (out of the loop -> right maxlen)+ table_shell_str <- function(tt, widths = NULL, col_gap = 3, hsep = default_hsep(), |
|||
| 113 | -22x | +
- df$path <- lapply(df$path, .remove_root_elems_from_path,+ tf_wrap = FALSE, max_width = NULL) {
|
||
| 114 | -22x | +2x |
- which_root_name = c("root", "rbind_root"),
+ matform <- matrix_form(tt, indent_rownames = TRUE) |
|
| 115 | -22x | +2x |
- all = TRUE+ format_strs <- vapply( |
|
| 116 | -+ | 2x |
- )+ as.vector(matform$formats), |
|
| 117 | -22x | +2x |
- maxlen <- max(lengths(df$path))+ function(x) {
|
|
| 118 | -+ | 18x |
-
+ if (inherits(x, "function")) {
|
|
| 119 | -+ | 1x |
- # Loop for metadata (path and details from make_row_df)+ "<fnc>" |
|
| 120 | -22x | +17x |
- metadf <- do.call(+ } else if (inherits(x, "character")) {
|
|
| 121 | -22x | +17x |
- rbind.data.frame,+ x |
|
| 122 | -22x | +
- lapply(+ } else {
|
||
| 123 | -22x | +! |
- seq_len(NROW(df)),+ stop("Don't know how to make a shell with formats of class: ", class(x))
|
|
| 124 | -22x | +
- function(ii) {
+ } |
||
| 125 | -433x | +
- handle_rdf_row(df[ii, ], maxlen = maxlen)+ }, "" |
||
| 126 |
- }+ ) |
|||
| 127 |
- )+ |
|||
| 128 | -+ | 2x |
- )+ format_strs_mat <- matrix(format_strs, ncol = ncol(matform$strings)) |
|
| 129 | -+ | 2x |
-
+ format_strs_mat[, 1] <- matform$strings[, 1] |
|
| 130 | -+ | 2x |
- # Should we keep label rows with NAs instead of values?+ nlh <- mf_nlheader(matform) |
|
| 131 | -22x | +2x |
- if (keep_label_rows) {
+ format_strs_mat[seq_len(nlh), ] <- matform$strings[seq_len(nlh), ] |
|
| 132 | -6x | +
- cellvals_mat_struct <- as.data.frame(+ |
||
| 133 | -6x | +2x |
- matrix(NA, nrow = nrow(rdf), ncol = ncol(cellvals))+ matform$strings <- format_strs_mat |
|
| 134 | -+ | 2x |
- )+ if (is.null(widths)) {
|
|
| 135 | -6x | +2x |
- colnames(cellvals_mat_struct) <- colnames(cellvals)+ widths <- propose_column_widths(matform) |
|
| 136 | -6x | +
- cellvals_mat_struct[metadf$node_class != "LabelRow", ] <- cellvals+ } |
||
| 137 | -6x | +2x |
- ret <- cbind(metadf, cellvals_mat_struct)+ toString(matform, |
|
| 138 | -+ | 2x |
- } else {
+ widths = widths, col_gap = col_gap, hsep = hsep, |
|
| 139 | -16x | +2x |
- ret <- cbind(+ tf_wrap = tf_wrap, max_width = max_width |
|
| 140 | -16x | +
- metadf[metadf$node_class != "LabelRow", ],+ ) |
||
| 141 | -16x | +
- cellvals+ } |
||
| 142 |
- )+ |
|||
| 143 |
- }+ #' Transform an `rtable` to a list of matrices which can be used for outputting |
|||
| 144 |
-
+ #' |
|||
| 145 |
- # If we want to expand colnames+ #' Although `rtables` are represented as a tree data structure when outputting the table to ASCII or HTML |
|||
| 146 | -22x | +
- if (expand_colnames) {
+ #' it is useful to map the `rtable` to an in-between state with the formatted cells in a matrix form. |
||
| 147 | -6x | +
- col_name_structure <- .get_formatted_colnames(clayout(tt))+ #' |
||
| 148 | -6x | +
- number_of_non_data_cols <- which(colnames(ret) == "node_class")+ #' @inheritParams gen_args |
||
| 149 | -6x | +
- if (NCOL(ret) - number_of_non_data_cols != NCOL(col_name_structure)) {
+ #' @param indent_rownames (`flag`)\cr if `TRUE`, the column with the row names in the `strings` matrix of the output |
||
| 150 | -! | +
- stop(+ #' has indented row names (strings pre-fixed). |
||
| 151 | -! | +
- "When expanding colnames structure, we were not able to find the same",+ #' @param expand_newlines (`flag`)\cr whether the matrix form generated should expand rows whose values contain |
||
| 152 | -! | +
- " number of columns as in the result data frame. This is a bug. Please report it."+ #' newlines into multiple 'physical' rows (as they will appear when rendered into ASCII). Defaults to `TRUE`. |
||
| 153 | -! | +
- ) # nocov+ #' @param fontspec (`font_spec`)\cr The font that should be used by default when |
||
| 154 |
- }+ #' rendering this `MatrixPrintForm` object, or NULL (the default). |
|||
| 155 |
-
+ #' @param col_gap (`numeric(1)`)]\cr The number of spaces (in the font specified |
|||
| 156 | -6x | +
- buffer_rows_for_colnames <- matrix(+ #' by `fontspec`) that should be placed between columns when the table |
||
| 157 | -6x | +
- rep("<only_for_column_names>", number_of_non_data_cols * NROW(col_name_structure)),
+ #' is rendered directly to text (e.g., by `toString` or `export_as_txt`). Defaults |
||
| 158 | -6x | +
- nrow = NROW(col_name_structure)+ #' to `3`. |
||
| 159 |
- )+ #' |
|||
| 160 |
-
+ #' @details |
|||
| 161 | -6x | +
- header_colnames_matrix <- cbind(buffer_rows_for_colnames, data.frame(col_name_structure))+ #' The strings in the return object are defined as follows: row labels are those determined by `make_row_df` and cell |
||
| 162 | -6x | +
- colnames(header_colnames_matrix) <- colnames(ret)+ #' values are determined using `get_formatted_cells`. (Column labels are calculated using a non-exported internal |
||
| 163 |
-
+ #' function. |
|||
| 164 | -6x | +
- count_row <- NULL+ #' |
||
| 165 | -6x | +
- if (disp_ccounts(tt)) {
+ #' @return A list with the following elements: |
||
| 166 | -3x | +
- ccounts <- col_counts(tt)+ #' \describe{
|
||
| 167 | -3x | +
- if (data_format == "strings") {
+ #' \item{`strings`}{The content, as it should be printed, of the top-left material, column headers, row labels,
|
||
| 168 | -2x | +
- ccounts <- mf_strings(mf_tt)[mf_nlheader(mf_tt), ]+ #' and cell values of `tt`.} |
||
| 169 | -2x | +
- ccounts <- .remove_empty_elements(ccounts)+ #' \item{`spans`}{The column-span information for each print-string in the `strings` matrix.}
|
||
| 170 |
- }+ #' \item{`aligns`}{The text alignment for each print-string in the `strings` matrix.}
|
|||
| 171 | -3x | +
- count_row <- c(rep("<only_for_column_counts>", number_of_non_data_cols), ccounts)
+ #' \item{`display`}{Whether each print-string in the strings matrix should be printed.}
|
||
| 172 | -3x | +
- header_colnames_matrix <- rbind(header_colnames_matrix, count_row)+ #' \item{`row_info`}{The `data.frame` generated by `make_row_df`.}
|
||
| 173 |
- }+ #' } |
|||
| 174 | -6x | +
- ret <- rbind(header_colnames_matrix, ret)+ #' |
||
| 175 |
- }+ #' With an additional `nrow_header` attribute indicating the number of pseudo "rows" that the column structure defines. |
|||
| 176 |
-
+ #' |
|||
| 177 |
- # ARD part for one stat per row+ #' @examplesIf require(dplyr) |
|||
| 178 | -22x | +
- if (make_ard) {
+ #' library(dplyr) |
||
| 179 |
- # Unnecessary columns+ #' |
|||
| 180 | -! | +
- ret_tmp <- ret[, !colnames(ret) %in% c("row_num", "is_group_summary", "node_class")]
+ #' iris2 <- iris %>% |
||
| 181 |
-
+ #' group_by(Species) %>% |
|||
| 182 |
- # Indexes of real columns (visible in the output, but no row names)+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
|||
| 183 | -! | +
- only_col_indexes <- seq(which(colnames(ret_tmp) == "label_name") + 1, ncol(ret_tmp))+ #' ungroup() |
||
| 184 |
-
+ #' |
|||
| 185 |
- # Core row names+ #' lyt <- basic_table() %>% |
|||
| 186 | -! | +
- col_label_rows <- grepl("<only_for_column_*", ret_tmp$avar_name)
+ #' split_cols_by("Species") %>%
|
||
| 187 | -! | +
- core_row_names <- ret_tmp[!col_label_rows, -only_col_indexes]+ #' split_cols_by("group") %>%
|
||
| 188 |
-
+ #' analyze(c("Sepal.Length", "Petal.Width"),
|
|||
| 189 |
- # Moving colnames to rows (flattening)+ #' afun = list_wrap_x(summary), format = "xx.xx" |
|||
| 190 | -! | +
- ret_w_cols <- NULL+ #' ) |
||
| 191 | -! | +
- for (col_i in only_col_indexes) {
+ #' |
||
| 192 | -! | +
- tmp_ret_by_col_i <- cbind(+ #' lyt |
||
| 193 | -! | +
- group1 = column_split_names[[ret_tmp[, col_i][[1]]]],+ #' |
||
| 194 | -! | +
- group1_level = ret_tmp[, col_i][[1]],+ #' tbl <- build_table(lyt, iris2) |
||
| 195 |
- # instead of avar_name row_name label_name ("variable_label" is not present in ARDs)
+ #' |
|||
| 196 | -! | +
- setNames(core_row_names, c("variable", "variable_level", "variable_label")), # missing stat_name xxx
+ #' matrix_form(tbl) |
||
| 197 | -! | +
- stat = I(setNames(ret_tmp[!col_label_rows, col_i], NULL))+ #' |
||
| 198 |
- )+ #' @export |
|||
| 199 |
-
+ setMethod( |
|||
| 200 | -! | +
- ret_w_cols <- rbind(ret_w_cols, tmp_ret_by_col_i)+ "matrix_form", "VTableTree", |
||
| 201 |
- }+ function(obj, |
|||
| 202 |
-
+ indent_rownames = FALSE, |
|||
| 203 | -! | +
- ret <- ret_w_cols+ expand_newlines = TRUE, |
||
| 204 |
- }+ indent_size = 2, |
|||
| 205 |
-
+ fontspec = NULL, |
|||
| 206 |
- # Simplify the result data frame+ col_gap = 3L) {
|
|||
| 207 | -22x | +301x |
- out <- if (simplify) {
+ stopifnot(is(obj, "VTableTree")) |
|
| 208 | -6x | +301x |
- .simplify_result_df(ret)+ check_ccount_vis_ok(obj) |
|
| 209 | -+ | 300x |
- } else {
+ header_content <- .tbl_header_mat(obj) # first col are for row.names |
|
| 210 | -16x | +
- ret+ |
||
| 211 | -+ | 298x |
- }+ sr <- make_row_df(obj, fontspec = fontspec) |
|
| 213 | -+ | 298x |
- # take out rownames+ body_content_strings <- if (NROW(sr) == 0) {
|
|
| 214 | -22x | +5x |
- rownames(out) <- NULL+ character() |
|
| 215 |
- } else {
+ } else {
|
|||
| 216 | -+ | 293x |
- # Applying specs+ cbind(as.character(sr$label), get_formatted_cells(obj)) |
|
| 217 | -! | +
- out <- spec(tt, ...)+ } |
||
| 218 |
- }+ |
|||
| 219 | -+ | 298x |
-
+ formats_strings <- if (NROW(sr) == 0) {
|
|
| 220 | -22x | +5x |
- out+ character() |
|
| 221 |
- }+ } else {
|
|||
| 222 | -+ | 293x |
-
+ cbind("", get_formatted_cells(obj, shell = TRUE))
|
|
| 223 |
- # Helper function to get column split names+ } |
|||
| 224 |
- .get_column_split_name <- function(ci_coltree) {
+
|
|||
| 225 | -+ | 298x |
- # ci stands for column information+ tsptmp <- lapply(collect_leaves(obj, TRUE, TRUE), function(rr) {
|
|
| 226 | -126x | +6584x |
- if (is(ci_coltree, "LayoutAxisTree")) {
+ sp <- row_cspans(rr) |
|
| 227 | -46x | +6584x |
- kids <- tree_children(ci_coltree)+ rep(sp, times = sp) |
|
| 228 | -46x | +
- return(unlist(lapply(kids, .get_column_split_name)))+ }) |
||
| 229 |
- }+ |
|||
| 230 | -80x | +
- sapply(pos_splits(tree_pos(ci_coltree)), spl_payload)+ ## the 1 is for row labels |
||
| 231 | -+ | 298x |
- }+ body_spans <- if (nrow(obj) > 0) {
|
|
| 232 | -+ | 293x |
-
+ cbind(1L, do.call(rbind, tsptmp)) |
|
| 233 |
- # Function that selects specific outputs from the result data frame+ } else {
|
|||
| 234 | -+ | 5x |
- .simplify_result_df <- function(df) {
+ matrix(1, nrow = 0, ncol = ncol(obj) + 1) |
|
| 235 | -6x | +
- col_df <- colnames(df)+ } |
||
| 236 | -6x | +
- if (!all(c("label_name", "node_class") %in% col_df)) {
+
|
||
| 237 | -! | +298x |
- stop("Please simplify the result data frame only when it has 'label_name' and 'node_class' columns.")
+ body_aligns <- if (NROW(sr) == 0) {
|
|
| 238 | -+ | 5x |
- }+ character() |
|
| 239 | -6x | +
- label_names_col <- which(col_df == "label_name")+ } else {
|
||
| 240 | -6x | +293x |
- result_cols <- seq(which(col_df == "node_class") + 1, length(col_df))+ cbind("left", get_cell_aligns(obj))
|
|
| 241 |
-
+ } |
|||
| 242 | -6x | +
- df[, c(label_names_col, result_cols)]+ |
||
| 243 | -+ | 298x |
- }+ body <- rbind(header_content$body, body_content_strings) |
|
| 245 | -+ | 298x |
- .remove_empty_elements <- function(char_df) {
+ hdr_fmt_blank <- matrix("",
|
|
| 246 | -11x | +298x |
- if (is.null(dim(char_df))) {
+ nrow = nrow(header_content$body), |
|
| 247 | -5x | +298x |
- return(char_df[nzchar(char_df, keepNA = TRUE)])+ ncol = ncol(header_content$body) |
|
| 248 |
- }+ ) |
|||
| 249 | -+ | 298x |
-
+ if (disp_ccounts(obj)) {
|
|
| 250 | -6x | +36x |
- apply(char_df, 2, function(col_i) col_i[nzchar(col_i, keepNA = TRUE)])+ hdr_fmt_blank[nrow(hdr_fmt_blank), ] <- c("", rep(colcount_format(obj), ncol(obj)))
|
|
| 251 |
- }+ } |
|||
| 253 | -+ | 298x |
- # Helper function to make the character matrix numeric+ formats <- rbind(hdr_fmt_blank, formats_strings) |
|
| 254 |
- .make_numeric_char_mf <- function(char_df) {
+
|
|||
| 255 | -9x | +298x |
- if (is.null(dim(char_df))) {
+ spans <- rbind(header_content$span, body_spans) |
|
| 256 | -3x | +298x |
- return(as.numeric(stringi::stri_extract_all(char_df, regex = "\\d+.\\d+|\\d+")))+ row.names(spans) <- NULL |
|
| 257 |
- }+ |
|||
| 258 | -+ | 298x |
-
+ aligns <- rbind( |
|
| 259 | -6x | +298x |
- ret <- apply(char_df, 2, function(col_i) {
+ matrix(rep("center", length(header_content$body)),
|
|
| 260 | -27x | +298x |
- lapply(+ nrow = nrow(header_content$body) |
|
| 261 | -27x | +
- stringi::stri_extract_all(col_i, regex = "\\d+.\\d+|\\d+"),+ ), |
||
| 262 | -27x | +298x |
- as.numeric+ body_aligns |
|
| 264 |
- })+ |
|||
| 265 | -+ | 298x |
-
+ aligns[, 1] <- "left" # row names and topleft (still needed for topleft) |
|
| 266 | -6x | +
- do.call(cbind, ret)+ |
||
| 267 | -+ | 298x |
- }+ nr_header <- nrow(header_content$body) |
|
| 268 | -+ | 298x |
-
+ if (indent_rownames) {
|
|
| 269 | -+ | 223x |
- make_result_df_md_colnames <- function(maxlen) {
+ body[, 1] <- indent_string(body[, 1], c(rep(0, nr_header), sr$indent), |
|
| 270 | -433x | +223x |
- spllen <- floor((maxlen - 2) / 2)+ incr = indent_size |
|
| 271 | -433x | +
- ret <- character()+ ) |
||
| 272 | -433x | +
- if (spllen > 0) {
+ # why also formats? |
||
| 273 | -387x | +223x |
- ret <- paste(c("spl_var", "spl_value"), rep(seq_len(spllen), rep(2, spllen)), sep = "_")
+ formats[, 1] <- indent_string(formats[, 1], c(rep(0, nr_header), sr$indent), |
|
| 274 | -+ | 223x |
- }+ incr = indent_size |
|
| 275 | -433x | +
- ret <- c(ret, c("avar_name", "row_name", "label_name", "row_num", "is_group_summary", "node_class"))
+ ) |
||
| 276 | -+ | 75x |
- }+ } else if (NROW(sr) > 0) {
|
|
| 277 | -+ | 71x |
-
+ sr$indent <- rep(0, NROW(sr)) |
|
| 278 |
- do_label_row <- function(rdfrow, maxlen) {
+ } |
|||
| 279 | -143x | +
- pth <- rdfrow$path[[1]]+ |
||
| 280 | -+ | 298x |
- # Adjusting for the fact that we have two columns for each split+ col_ref_strs <- matrix(vapply(header_content$footnotes, function(x) {
|
|
| 281 | -143x | +2771x |
- extra_nas_from_splits <- floor((maxlen - length(pth)) / 2) * 2+ if (length(x) == 0) {
|
|
| 282 |
-
+ "" |
|||
| 283 |
- # Special cases with hidden labels+ } else {
|
|||
| 284 | -143x | +5x |
- if (length(pth) %% 2 == 1) {
+ paste(vapply(x, format_fnote_ref, ""), collapse = " ") |
|
| 285 | -108x | +
- extra_nas_from_splits <- extra_nas_from_splits + 1+ } |
||
| 286 | -+ | 298x |
- }+ }, ""), ncol = ncol(body)) |
|
| 287 | -+ | 298x |
-
+ body_ref_strs <- get_ref_matrix(obj) |
|
| 288 | -143x | +
- c(+ |
||
| 289 | -143x | +298x |
- as.list(pth[seq_len(length(pth) - 1)]),+ body <- matrix( |
|
| 290 | -143x | +298x |
- as.list(replicate(extra_nas_from_splits, list(NA_character_))),+ paste0( |
|
| 291 | -143x | +298x |
- as.list(tail(pth, 1)),+ body, |
|
| 292 | -143x | +298x |
- list(+ rbind( |
|
| 293 | -143x | +298x |
- label_name = rdfrow$label,+ col_ref_strs, |
|
| 294 | -143x | +298x |
- row_num = rdfrow$abs_rownumber,+ body_ref_strs |
|
| 295 | -143x | +
- content = FALSE,+ ) |
||
| 296 | -143x | +
- node_class = rdfrow$node_class+ ), |
||
| 297 | -+ | 298x |
- )+ nrow = nrow(body), |
|
| 298 | -+ | 298x |
- )+ ncol = ncol(body) |
|
| 299 |
- }+ ) |
|||
| 301 | -+ | 298x |
- do_content_row <- function(rdfrow, maxlen) {
+ ref_fnotes <- get_formatted_fnotes(obj) # pagination will not count extra lines coming from here |
|
| 302 | -36x | +298x |
- pth <- rdfrow$path[[1]]+ pag_titles <- page_titles(obj) |
|
| 303 | -36x | +
- contpos <- which(pth == "@content")+ |
||
| 304 | -+ | 298x |
-
+ MatrixPrintForm( |
|
| 305 | -36x | +298x |
- seq_before <- seq_len(contpos - 1)+ strings = body, |
|
| 306 | -+ | 298x |
-
+ spans = spans, |
|
| 307 | -36x | +298x |
- c(+ aligns = aligns, |
|
| 308 | -36x | +298x |
- as.list(pth[seq_before]),+ formats = formats, |
|
| 309 | -36x | +
- as.list(replicate(maxlen - contpos, list(NA_character_))),+ ## display = display, purely a function of spans, handled in constructor now |
||
| 310 | -36x | +298x |
- list(tail(pth, 1)),+ row_info = sr, |
|
| 311 | -36x | +298x |
- list(+ colpaths = make_col_df(obj)[["path"]], |
|
| 312 | -36x | +
- label_name = rdfrow$label,+ ## line_grouping handled internally now line_grouping = 1:nrow(body), |
||
| 313 | -36x | +298x |
- row_num = rdfrow$abs_rownumber,+ ref_fnotes = ref_fnotes, |
|
| 314 | -36x | +298x |
- content = TRUE,+ nlines_header = nr_header, ## this is fixed internally |
|
| 315 | -36x | +298x |
- node_class = rdfrow$node_class+ nrow_header = nr_header, |
|
| 316 | -+ | 298x |
- )+ expand_newlines = expand_newlines, |
|
| 317 | -+ | 298x |
- )+ has_rowlabs = TRUE, |
|
| 318 | -+ | 298x |
- }+ has_topleft = TRUE, |
|
| 319 | -+ | 298x |
-
+ main_title = main_title(obj), |
|
| 320 | -+ | 298x |
- do_data_row <- function(rdfrow, maxlen) {
+ subtitles = subtitles(obj), |
|
| 321 | -254x | +298x |
- pth <- rdfrow$path[[1]]+ page_titles = pag_titles, |
|
| 322 | -254x | +298x |
- pthlen <- length(pth)+ main_footer = main_footer(obj), |
|
| 323 | -+ | 298x |
- ## odd means we have a multi-analsysis step in the path, we dont' want that in the result data frame+ prov_footer = prov_footer(obj), |
|
| 324 | -254x | +298x |
- if (pthlen %% 2 == 1) {
+ table_inset = table_inset(obj), |
|
| 325 | -38x | +298x |
- pth <- pth[-1 * (pthlen - 2)]+ header_section_div = header_section_div(obj), |
|
| 326 | -+ | 298x |
- }+ horizontal_sep = horizontal_sep(obj), |
|
| 327 | -254x | +298x |
- pthlen_new <- length(pth)+ indent_size = indent_size, |
|
| 328 | -33x | +298x |
- if (maxlen == 1) pthlen_new <- 3+ fontspec = fontspec, |
|
| 329 | -254x | +298x |
- c(+ col_gap = col_gap |
|
| 330 | -254x | +
- as.list(pth[seq_len(pthlen_new - 2)]),+ ) |
||
| 331 | -254x | +
- replicate(maxlen - pthlen, list(NA_character_)),+ } |
||
| 332 | -254x | +
- as.list(tail(pth, 2)),+ ) |
||
| 333 | -254x | +
- list(+ |
||
| 334 | -254x | +
- label_name = rdfrow$label,+ |
||
| 335 | -254x | +
- row_num = rdfrow$abs_rownumber,+ check_ccount_vis_ok <- function(tt) {
|
||
| 336 | -254x | +301x |
- content = FALSE,+ ctree <- coltree(tt) |
|
| 337 | -254x | +301x |
- node_class = rdfrow$node_class+ tlkids <- tree_children(ctree) |
|
| 338 | -+ | 301x |
- )+ lapply(tlkids, ccvis_check_subtree) |
|
| 339 | -+ | 300x |
- )+ invisible(NULL) |
|
| 342 |
- .remove_root_elems_from_path <- function(path, which_root_name = c("root", "rbind_root"), all = TRUE) {
+ ccvis_check_subtree <- function(ctree) {
|
|||
| 343 | -434x | +1508x |
- any_root_paths <- path[1] %in% which_root_name+ kids <- tree_children(ctree) |
|
| 344 | -434x | +1508x |
- if (any_root_paths) {
+ if (is.null(kids)) {
|
|
| 345 | -274x | +! |
- if (isTRUE(all)) {
+ return(invisible(NULL)) |
|
| 346 |
- # Selecting the header grouping of root and rbind_root (we do not want to remove other root labels-path later)+ } |
|||
| 347 | -274x | +1508x |
- root_indices <- which(path %in% which_root_name)+ vals <- vapply(kids, disp_ccounts, TRUE) |
|
| 348 | -274x | +1508x |
- if (any(diff(root_indices) > 1)) { # integer(0) for diff means FALSE
+ if (length(unique(vals)) > 1) {
|
|
| 349 | -! | +1x |
- end_point_root_headers <- which(diff(root_indices) > 1)[1]+ unmatch <- which(!duplicated(vals))[1:2] |
|
| 350 | -+ | 1x |
- } else {
+ stop( |
|
| 351 | -274x | +1x |
- end_point_root_headers <- length(root_indices)+ "Detected different colcount visibility among sibling facets (those ", |
|
| 352 | -+ | 1x |
- }+ "arising from the same split_cols_by* layout instruction). This is ", |
|
| 353 | -274x | +1x |
- root_path_to_remove <- seq_len(end_point_root_headers)+ "not supported.\n", |
|
| 354 | -+ | 1x |
- } else {
+ "Set count values to NA if you want a blank space to appear as the ", |
|
| 355 | -! | +1x |
- root_path_to_remove <- 1+ "displayed count for particular facets.\n", |
|
| 356 | -+ | 1x |
- }+ "First disagreement occured at paths:\n", |
|
| 357 | -274x | +1x |
- path <- path[-root_path_to_remove]+ .path_to_disp(pos_to_path(tree_pos(kids[[unmatch[1]]]))), "\n", |
|
| 358 | -+ | 1x |
- }+ .path_to_disp(pos_to_path(tree_pos(kids[[unmatch[2]]]))) |
|
| 359 |
-
+ ) |
|||
| 360 |
- # Fix for very edge case where we have only root elements+ } |
|||
| 361 | -434x | +1507x |
- if (length(path) == 0) {
+ lapply(kids, ccvis_check_subtree) |
|
| 362 | -1x | +1507x |
- path <- which_root_name[1]+ invisible(NULL) |
|
| 363 |
- }- |
- |||
| 364 | -- | - - | -||
| 365 | -434x | -
- path- |
- ||
| 366 | -- |
- }- |
- ||
| 367 | -- | - - | -||
| 368 | -- |
- handle_rdf_row <- function(rdfrow, maxlen) {
- |
- ||
| 369 | -433x | -
- nclass <- rdfrow$node_class- |
- ||
| 370 | -- | - - | -||
| 371 | -433x | -
- ret <- switch(nclass,- |
- ||
| 372 | -433x | -
- LabelRow = do_label_row(rdfrow, maxlen),- |
- ||
| 373 | -433x | -
- ContentRow = do_content_row(rdfrow, maxlen),- |
- ||
| 374 | -433x | -
- DataRow = do_data_row(rdfrow, maxlen),- |
- ||
| 375 | -433x | -
- stop("Unrecognized node type in row dataframe, unable to generate result data frame")
- |
- ||
| 376 | -- |
- )- |
- ||
| 377 | -433x | -
- setNames(ret, make_result_df_md_colnames(maxlen))- |
- ||
| 378 | -- |
- }- |
- ||
| 379 | -- | - - | -||
| 380 | -- |
- # Helper recurrent function to get the column names for the result data frame from the VTableTree- |
- ||
| 381 | -- |
- .get_formatted_colnames <- function(clyt) {
- |
- ||
| 382 | -41x | -
- ret <- obj_label(clyt)- |
- ||
| 383 | -41x | -
- if (!nzchar(ret)) {
- |
- ||
| 384 | -6x | -
- ret <- NULL- |
- ||
| 385 | -- |
- }- |
- ||
| 386 | -41x | -
- if (is.null(tree_children(clyt))) {
- |
- ||
| 387 | -! | -
- return(ret)- |
- ||
| 388 | -- |
- } else {
- |
- ||
| 389 | -41x | -
- ret <- rbind(ret, do.call(cbind, lapply(tree_children(clyt), .get_formatted_colnames)))- |
- ||
| 390 | -41x | -
- colnames(ret) <- NULL- |
- ||
| 391 | -41x | -
- rownames(ret) <- NULL- |
- ||
| 392 | -41x | -
- return(ret)- |
- ||
| 393 | -- |
- }- |
- ||
| 394 | -- |
- }- |
- ||
| 395 | -- |
- # path_enriched_df ------------------------------------------------------------- |
- ||
| 396 | -- |
- #- |
- ||
| 397 | -- |
- #' @describeIn data.frame_export Transform a `TableTree` object to a path-enriched `data.frame`.- |
- ||
| 398 | -- |
- #'- |
- ||
| 399 | -- |
- #' @param path_fun (`function`)\cr function to transform paths into single-string row/column names.- |
- ||
| 400 | -- |
- #' @param value_fun (`function`)\cr function to transform cell values into cells of a `data.frame`. Defaults to- |
- ||
| 401 | -- |
- #' `collapse_values`, which creates strings where multi-valued cells are collapsed together, separated by `|`.- |
- ||
| 402 | -- |
- #'- |
- ||
| 403 | -- |
- #' @return- |
- ||
| 404 | -- |
- #' * `path_enriched_df()` returns a `data.frame` of `tt`'s cell values (processed by `value_fun`, with columns named by- |
- ||
| 405 | -- |
- #' the full column paths (processed by `path_fun` and an additional `row_path` column with the row paths (processed- |
- ||
| 406 | -- |
- #' by `path_fun`).- |
- ||
| 407 | -- |
- #'- |
- ||
| 408 | -- |
- #' @examples- |
- ||
| 409 | -- |
- #' lyt <- basic_table() %>%- |
- ||
| 410 | -- |
- #' split_cols_by("ARM") %>%
- |
- ||
| 411 | -- |
- #' analyze(c("AGE", "BMRKR2"))
- |
- ||
| 412 | -- |
- #'- |
- ||
| 413 | -- |
- #' tbl <- build_table(lyt, ex_adsl)- |
- ||
| 414 | -- |
- #' path_enriched_df(tbl)- |
- ||
| 415 | -- |
- #'+ } |
||
| 416 | +364 |
- #' @export+ |
||
| 417 | +365 |
- path_enriched_df <- function(tt, path_fun = collapse_path, value_fun = collapse_values) {
+ .resolve_fn_symbol <- function(fn) {
|
||
| 418 | -3x | +366 | +448x |
- rdf <- make_row_df(tt)+ if (!is(fn, "RefFootnote")) {
|
| 419 | -3x | +|||
| 367 | +! |
- cdf <- make_col_df(tt)+ return(NULL) |
||
| 420 | -3x | +|||
| 368 | +
- cvs <- as.data.frame(do.call(rbind, cell_values(tt)))+ } |
|||
| 421 | -3x | +369 | +448x |
- cvs <- as.data.frame(lapply(cvs, value_fun))+ ret <- ref_symbol(fn) |
| 422 | -3x | +370 | +448x |
- row.names(cvs) <- NULL+ if (is.na(ret)) {
|
| 423 | -3x | +371 | +448x |
- colnames(cvs) <- path_fun(cdf$path)+ ret <- as.character(ref_index(fn)) |
| 424 | -3x | +|||
| 372 | +
- preppaths <- path_fun(rdf[rdf$node_class != "LabelRow", ]$path)+ } |
|||
| 425 | -3x | +373 | +448x |
- cbind.data.frame(row_path = preppaths, cvs)+ ret |
| 426 | +374 |
} |
||
| 427 | +375 | |||
| 428 | -- |
- .collapse_char <- "|"- |
- ||
| 429 | +376 |
- .collapse_char_esc <- "\\|"+ format_fnote_ref <- function(fn) {
|
||
| 430 | -+ | |||
| 377 | +40237x |
-
+ if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
|
||
| 431 | -+ | |||
| 378 | +40173x |
- collapse_path <- function(paths) {
+ return("")
|
||
| 432 | -196x | +379 | +64x |
- if (is.list(paths)) {
+ } else if (is.list(fn) && all(vapply(fn, is.list, TRUE))) {
|
| 433 | -6x | +|||
| 380 | +! |
- return(vapply(paths, collapse_path, ""))+ return(vapply(fn, format_fnote_ref, "")) |
||
| 434 | +381 |
} |
||
| 435 | -190x | +382 | +64x |
- paste(paths, collapse = .collapse_char)+ if (is.list(fn)) {
|
| 436 | -+ | |||
| 383 | +59x |
- }+ inds <- unlist(lapply(unlist(fn), .resolve_fn_symbol)) |
||
| 437 | +384 |
-
+ } else {
+ |
+ ||
| 385 | +5x | +
+ inds <- .resolve_fn_symbol(fn) |
||
| 438 | +386 |
- collapse_values <- function(colvals) {
+ } |
||
| 439 | -13x | +387 | +64x |
- if (!is.list(colvals)) { ## || all(vapply(colvals, length, 1L) == 1))
+ if (length(inds) > 0) {
|
| 440 | -! | +|||
| 388 | +64x |
- return(colvals)+ paste0(" {", paste(unique(inds), collapse = ", "), "}")
|
||
| 441 | -13x | +|||
| 389 | +
- } else if (all(vapply(colvals, length, 1L) == 1)) {
+ } else {
|
|||
| 442 | -1x | +|||
| 390 | +
- return(unlist(colvals))+ "" |
|||
| 443 | +391 |
} |
||
| 444 | -12x | +|||
| 392 | +
- vapply(colvals, paste, "", collapse = .collapse_char)+ } |
|||
| 445 | +393 |
- }+ |
| 1 | +394 |
- insert_brs <- function(vec) {
+ format_fnote_note <- function(fn) {
|
||
| 2 | -1021x | +395 | +373x |
- if (length(vec) == 1) {
+ if (length(fn) == 0 || (is.list(fn) && all(vapply(fn, function(x) length(x) == 0, TRUE)))) {
|
| 3 | -1021x | +|||
| 396 | +! |
- ret <- list(vec)+ return(character()) |
||
| 4 | +397 |
- } else {
+ } |
||
| 5 | -! | +|||
| 398 | +373x |
- nout <- length(vec) * 2 - 1+ if (is.list(fn)) {
|
||
| 6 | +399 | ! |
- ret <- vector("list", nout)
+ return(unlist(lapply(unlist(fn), format_fnote_note))) |
|
| 7 | -! | +|||
| 400 | +
- for (i in seq_along(vec)) {
+ } |
|||
| 8 | -! | +|||
| 401 | +
- ret[[2 * i - 1]] <- vec[i]+ |
|||
| 9 | -! | +|||
| 402 | +373x |
- if (2 * i < nout) {
+ if (is(fn, "RefFootnote")) {
|
||
| 10 | -! | +|||
| 403 | +373x |
- ret[[2 * i]] <- tags$br()+ paste0("{", .resolve_fn_symbol(fn), "} - ", ref_msg(fn))
|
||
| 11 | +404 |
- }+ } else {
|
||
| 12 | -+ | |||
| 405 | +! |
- }+ NULL |
||
| 13 | +406 |
} |
||
| 14 | -1021x | -
- ret- |
- ||
| 15 | +407 |
} |
||
| 16 | +408 | |||
| 17 | +409 |
- div_helper <- function(lst, class) {
+ .fn_ind_extractor <- function(strs) {
|
||
| 18 | -72x | +|||
| 410 | +! |
- do.call(tags$div, c(list(class = paste(class, "rtables-container"), lst)))+ res <- suppressWarnings(as.numeric(gsub("\\{([[:digit:]]+)\\}.*", "\\1", strs)))
|
||
| 19 | -+ | |||
| 411 | +! |
- }+ res[res == "NA"] <- NA_character_ |
||
| 20 | +412 |
-
+ ## these mixing is allowed now with symbols |
||
| 21 | +413 |
- #' Convert an `rtable` object to a `shiny.tag` HTML object+ ## if(!(sum(is.na(res)) %in% c(0L, length(res)))) |
||
| 22 | +414 |
- #'+ ## stop("Got NAs mixed with non-NAS for extracted footnote indices. This should not happen")
|
||
| 23 | -+ | |||
| 415 | +! |
- #' The returned HTML object can be immediately used in `shiny` and `rmarkdown`.+ res |
||
| 24 | +416 |
- #'+ } |
||
| 25 | +417 |
- #' @param x (`VTableTree`)\cr a `TableTree` object.+ |
||
| 26 | +418 |
- #' @param class_table (`character`)\cr class for `table` tag.+ get_ref_matrix <- function(tt) {
|
||
| 27 | -+ | |||
| 419 | +298x |
- #' @param class_tr (`character`)\cr class for `tr` tag.+ if (ncol(tt) == 0 || nrow(tt) == 0) {
|
||
| 28 | -+ | |||
| 420 | +5x |
- #' @param class_th (`character`)\cr class for `th` tag.+ return(matrix("", nrow = nrow(tt), ncol = ncol(tt) + 1L))
|
||
| 29 | +421 |
- #' @param width (`character`)\cr a string to indicate the desired width of the table. Common input formats include a+ } |
||
| 30 | -+ | |||
| 422 | +293x |
- #' percentage of the viewer window width (e.g. `"100%"`) or a distance value (e.g. `"300px"`). Defaults to `NULL`.+ rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE) |
||
| 31 | -+ | |||
| 423 | +293x |
- #' @param link_label (`character`)\cr link anchor label (not including `tab:` prefix) for the table.+ lst <- unlist(lapply(rows, cell_footnotes), recursive = FALSE) |
||
| 32 | -+ | |||
| 424 | +293x |
- #' @param bold (`character`)\cr elements in table output that should be bold. Options are `"main_title"`,+ cstrs <- unlist(lapply(lst, format_fnote_ref)) |
||
| 33 | -+ | |||
| 425 | +293x |
- #' `"subtitles"`, `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label+ bodymat <- matrix(cstrs, |
||
| 34 | -+ | |||
| 426 | +293x |
- #' rows). Defaults to `"header"`.+ byrow = TRUE, |
||
| 35 | -+ | |||
| 427 | +293x |
- #' @param header_sep_line (`flag`)\cr whether a black line should be printed to under the table header. Defaults+ nrow = nrow(tt), |
||
| 36 | -+ | |||
| 428 | +293x |
- #' to `TRUE`.+ ncol = ncol(tt) |
||
| 37 | +429 |
- #' @param no_spaces_between_cells (`flag`)\cr whether spaces between table cells should be collapsed. Defaults+ ) |
||
| 38 | -+ | |||
| 430 | +293x |
- #' to `FALSE`.+ cbind(vapply(rows, function(rw) format_fnote_ref(row_footnotes(rw)), ""), bodymat) |
||
| 39 | +431 |
- #' @param expand_newlines (`flag`)\cr Defaults to `FALSE`, relying on `html` output to solve newline characters (`\n`).+ } |
||
| 40 | +432 |
- #' Doing this keeps the structure of the cells but may depend on the output device.+ |
||
| 41 | +433 |
- #'+ get_formatted_fnotes <- function(tt) {
|
||
| 42 | -+ | |||
| 434 | +298x |
- #' @importFrom htmltools tags+ colresfs <- unlist(make_col_df(tt, visible_only = FALSE)$col_fnotes) |
||
| 43 | -+ | |||
| 435 | +298x |
- #'+ rows <- collect_leaves(tt, incl.cont = TRUE, add.labrows = TRUE) |
||
| 44 | -+ | |||
| 436 | +298x |
- #' @return A `shiny.tag` object representing `x` in HTML.+ lst <- c( |
||
| 45 | -+ | |||
| 437 | +298x |
- #'+ colresfs, |
||
| 46 | -+ | |||
| 438 | +298x |
- #' @examples+ unlist( |
||
| 47 | -+ | |||
| 439 | +298x |
- #' tbl <- rtable(+ lapply(rows, function(r) unlist(c(row_footnotes(r), cell_footnotes(r)), recursive = FALSE)), |
||
| 48 | -+ | |||
| 440 | +298x |
- #' header = LETTERS[1:3],+ recursive = FALSE |
||
| 49 | +441 |
- #' format = "xx",+ ) |
||
| 50 | +442 |
- #' rrow("r1", 1, 2, 3),
+ ) |
||
| 51 | +443 |
- #' rrow("r2", 4, 3, 2, indent = 1),
+
|
||
| 52 | -+ | |||
| 444 | +298x |
- #' rrow("r3", indent = 2)
+ inds <- vapply(lst, ref_index, 1L) |
||
| 53 | -+ | |||
| 445 | +298x |
- #' )+ ord <- order(inds) |
||
| 54 | -+ | |||
| 446 | +298x |
- #'+ lst <- lst[ord] |
||
| 55 | -+ | |||
| 447 | +298x |
- #' as_html(tbl)+ syms <- vapply(lst, ref_symbol, "") |
||
| 56 | -+ | |||
| 448 | +298x |
- #'+ keep <- is.na(syms) | !duplicated(syms) |
||
| 57 | -+ | |||
| 449 | +298x |
- #' as_html(tbl, class_table = "table", class_tr = "row")+ lst <- lst[keep] |
||
| 58 | -+ | |||
| 450 | +298x |
- #'+ unique(vapply(lst, format_fnote_note, "")) |
||
| 59 | +451 |
- #' as_html(tbl, bold = c("header", "row_names"))
+
|
||
| 60 | +452 |
- #'+ ## , recursive = FALSE) |
||
| 61 | +453 |
- #' \dontrun{
+ ## rlst <- unlist(lapply(rows, row_footnotes)) |
||
| 62 | +454 |
- #' Viewer(tbl)+ ## lst <- |
||
| 63 | +455 |
- #' }+ ## syms <- vapply(lst, ref_symbol, "") |
||
| 64 | +456 |
- #'+ ## keep <- is.na(syms) | !duplicated(syms) |
||
| 65 | +457 |
- #' @export+ ## lst <- lst[keep] |
||
| 66 | +458 |
- as_html <- function(x,+ ## inds <- vapply(lst, ref_index, 1L) |
||
| 67 | +459 |
- width = NULL,+ ## cellstrs <- unlist(lapply(lst, format_fnote_note)) |
||
| 68 | +460 |
- class_table = "table table-condensed table-hover",+ ## rstrs <- unlist(lapply(rows, function(rw) format_fnote_note(row_footnotes(rw)))) |
||
| 69 | +461 |
- class_tr = NULL,+ ## allstrs <- c(colstrs, rstrs, cellstrs) |
||
| 70 | +462 |
- class_th = NULL,+ ## inds <- .fn_ind_extractor(allstrs) |
||
| 71 | +463 |
- link_label = NULL,+ ## allstrs[order(inds)] |
||
| 72 | +464 |
- bold = c("header"),
+ } |
||
| 73 | +465 |
- header_sep_line = TRUE,+ |
||
| 74 | +466 |
- no_spaces_between_cells = FALSE,+ .do_tbl_h_piece2 <- function(tt) {
|
||
| 75 | -+ | |||
| 467 | +306x |
- expand_newlines = FALSE) {
+ coldf <- make_col_df(tt, visible_only = FALSE) |
||
| 76 | -9x | +468 | +306x |
- if (is.null(x)) {
+ remain <- seq_len(nrow(coldf)) |
| 77 | -! | +|||
| 469 | +306x |
- return(tags$p("Empty Table"))
+ chunks <- list() |
||
| 78 | -+ | |||
| 470 | +306x |
- }+ cur <- 1 |
||
| 79 | -+ | |||
| 471 | +306x |
-
+ na_str <- colcount_na_str(tt) |
||
| 80 | -9x | +|||
| 472 | +
- stopifnot(is(x, "VTableTree"))+ |
|||
| 81 | +473 |
-
+ ## XXX this would be better as the facet-associated |
||
| 82 | -9x | +|||
| 474 | +
- mat <- matrix_form(x, indent_rownames = TRUE, expand_newlines = expand_newlines)+ ## format but I don't know that we need to |
|||
| 83 | +475 |
-
+ ## support that level of differentiation anyway... |
||
| 84 | -9x | +476 | +306x |
- nlh <- mf_nlheader(mat)+ cc_format <- colcount_format(tt) |
| 85 | -9x | +|||
| 477 | +
- nc <- ncol(x) + 1+ ## each iteration of this loop identifies |
|||
| 86 | -9x | +|||
| 478 | +
- nr <- length(mf_lgrouping(mat))+ ## all rows corresponding to one top-level column |
|||
| 87 | +479 |
-
+ ## label and its children, then processes those |
||
| 88 | +480 |
- # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions+ ## with .do_header_chunk |
||
| 89 | -9x | +481 | +306x |
- cells <- matrix(rep(list(list()), (nr * nc)), ncol = nc)+ while (length(remain) > 0) {
|
| 90 | -+ | |||
| 482 | +823x |
-
+ rw <- remain[1] |
||
| 91 | -9x | +483 | +823x |
- for (i in seq_len(nr)) {
+ inds <- coldf$leaf_indices[[rw]] |
| 92 | -173x | +484 | +823x |
- for (j in seq_len(nc)) {
+ endblock <- which(coldf$abs_pos == max(inds)) |
| 93 | -1021x | +|||
| 485 | +
- curstrs <- mf_strings(mat)[i, j]+ |
|||
| 94 | -1021x | +486 | +823x |
- curspn <- mf_spans(mat)[i, j]+ stopifnot(endblock >= rw) |
| 95 | -1021x | +487 | +823x |
- algn <- mf_aligns(mat)[i, j]+ chunk_res <- .do_header_chunk(coldf[rw:endblock, ], cc_format, na_str = na_str) |
| 96 | -+ | |||
| 488 | +821x |
-
+ chunk_res <- unlist(chunk_res, recursive = FALSE) |
||
| 97 | -1021x | +489 | +821x |
- inhdr <- i <= nlh+ chunks[[cur]] <- chunk_res |
| 98 | -1021x | +490 | +821x |
- tagfun <- if (inhdr) tags$th else tags$td+ remain <- remain[remain > endblock] |
| 99 | -1021x | +491 | +821x |
- cells[i, j][[1]] <- tagfun(+ cur <- cur + 1 |
| 100 | -1021x | +|||
| 492 | +
- class = if (inhdr) class_th else class_tr,+ } |
|||
| 101 | -1021x | +493 | +304x |
- style = paste0("text-align: ", algn, ";"),
+ chunks <- .pad_tops(chunks) |
| 102 | -1021x | +494 | +304x |
- style = if (inhdr && !"header" %in% bold) "font-weight: normal;",+ lapply( |
| 103 | -1021x | +495 | +304x |
- style = if (i == nlh && header_sep_line) "border-bottom: 1px solid black;",+ seq_len(length(chunks[[1]])), |
| 104 | -1021x | +496 | +304x |
- colspan = if (curspn != 1) curspn,+ function(i) {
|
| 105 | -1021x | +497 | +466x |
- insert_brs(curstrs)+ DataRow(unlist(lapply(chunks, `[[`, i), recursive = FALSE)) |
| 106 | +498 |
- )+ } |
||
| 107 | +499 |
- }+ ) |
||
| 108 | +500 |
- }+ } |
||
| 109 | +501 | |||
| 110 | -9x | +|||
| 502 | +
- if (header_sep_line) {
+ .pad_end <- function(lst, padto, ncols) {
|
|||
| 111 | -9x | +503 | +1259x |
- cells[nlh][[1]] <- htmltools::tagAppendAttributes(+ curcov <- sum(vapply(lst, cell_cspan, 0L)) |
| 112 | -9x | +504 | +1259x |
- cells[nlh, 1][[1]],+ if (curcov == padto) {
|
| 113 | -9x | +505 | +1259x |
- style = "border-bottom: 1px solid black;"+ return(lst) |
| 114 | +506 |
- )+ } |
||
| 115 | +507 |
- }+ + |
+ ||
| 508 | +! | +
+ c(lst, list(rcell("", colspan = padto - curcov)))
|
||
| 116 | +509 |
-
+ } |
||
| 117 | +510 |
- # Create a map between line numbers and line groupings, adjusting abs_rownumber with nlh+ |
||
| 118 | -9x | +|||
| 511 | +
- map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping)+ .pad_tops <- function(chunks) {
|
|||
| 119 | -9x | +512 | +304x |
- row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh)+ lens <- vapply(chunks, length, 1L) |
| 120 | -9x | +513 | +304x |
- map <- merge(map, row_info_df, by = "abs_rownumber")+ padto <- max(lens) |
| 121 | -+ | |||
| 514 | +304x |
-
+ needpad <- lens != padto |
||
| 122 | -+ | |||
| 515 | +304x |
- # add indent values for headerlines+ if (all(!needpad)) {
|
||
| 123 | -9x | +516 | +298x |
- map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map)+ return(chunks) |
| 124 | +517 |
-
+ } |
||
| 125 | +518 | |||
| 126 | -+ | |||
| 519 | +6x |
- # Row labels style+ for (i in seq_along(lens)) {
|
||
| 127 | -9x | +520 | +25x |
- for (i in seq_len(nr)) {
+ if (lens[i] < padto) {
|
| 128 | -173x | +521 | +10x |
- indent <- ifelse(any(map$lines == i), map$indent[map$lines == i][1], -1)+ chk <- chunks[[i]] |
| 129 | -+ | |||
| 522 | +10x |
-
+ span <- sum(vapply(chk[[length(chk)]], cell_cspan, 1L)) |
||
| 130 | -+ | |||
| 523 | +10x |
- # Apply indentation+ chunks[[i]] <- c( |
||
| 131 | -173x | +524 | +10x |
- if (indent > 0) {
+ replicate(list(list(rcell("", colspan = span))),
|
| 132 | -127x | +525 | +10x |
- cells[i, 1][[1]] <- htmltools::tagAppendAttributes(+ n = padto - lens[i] |
| 133 | -127x | +|||
| 526 | +
- cells[i, 1][[1]],+ ), |
|||
| 134 | -127x | +527 | +10x |
- style = paste0("padding-left: ", indent * 3, "ch;")
+ chk |
| 135 | +528 |
) |
||
| 136 | +529 |
} |
||
| 137 | -- | - - | -||
| 138 | +530 |
- # Apply bold font weight if "row_names" is in 'bold'- |
- ||
| 139 | -173x | -
- if ("row_names" %in% bold) {
- |
- ||
| 140 | -4x | -
- cells[i, 1][[1]] <- htmltools::tagAppendAttributes(+ } |
||
| 141 | -4x | +531 | +6x |
- cells[i, 1][[1]],+ chunks |
| 142 | -4x | +|||
| 532 | +
- style = "font-weight: bold;"+ } |
|||
| 143 | +533 |
- )+ |
||
| 144 | +534 |
- }+ .do_header_chunk <- function(coldf, cc_format, na_str) {
|
||
| 145 | +535 |
- }+ ## hard assumption that coldf is a section |
||
| 146 | +536 |
-
+ ## of a column dataframe summary that was |
||
| 147 | +537 |
- # label rows style+ ## created with visible_only=FALSE |
||
| 148 | -9x | +538 | +823x |
- if ("label_rows" %in% bold) {
+ nleafcols <- length(coldf$leaf_indices[[1]]) |
| 149 | -! | +|||
| 539 | +
- which_lbl_rows <- which(mat$row_info$node_class == "LabelRow")+ |
|||
| 150 | -! | +|||
| 540 | +823x |
- cells[which_lbl_rows + nlh, ] <- lapply(+ spldfs <- split(coldf, lengths(coldf$path)) |
||
| 151 | -! | +|||
| 541 | +823x |
- cells[which_lbl_rows + nlh, ],+ toret <- lapply( |
||
| 152 | -! | +|||
| 542 | +823x |
- htmltools::tagAppendAttributes,+ seq_along(spldfs), |
||
| 153 | -! | +|||
| 543 | +823x |
- style = "font-weight: bold;"+ function(i) {
|
||
| 154 | -+ | |||
| 544 | +1122x |
- )+ rws <- spldfs[[i]] |
||
| 155 | -+ | |||
| 545 | +1122x |
- }+ thisbit_vals <- lapply( |
||
| 156 | -+ | |||
| 546 | +1122x |
-
+ seq_len(nrow(rws)), |
||
| 157 | -+ | |||
| 547 | +1122x |
- # content rows style+ function(ri) {
|
||
| 158 | -9x | +548 | +1520x |
- if ("content_rows" %in% bold) {
+ cellii <- rcell(rws[ri, "label", drop = TRUE], |
| 159 | -! | +|||
| 549 | +1520x |
- which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow"))
+ colspan = rws$total_span[ri], |
||
| 160 | -! | +|||
| 550 | +1520x |
- cells[which_cntnt_rows + nlh, ] <- lapply(+ footnotes = rws[ri, "col_fnotes", drop = TRUE][[1]] |
||
| 161 | -! | +|||
| 551 | +
- cells[which_cntnt_rows + nlh, ],+ ) |
|||
| 162 | -! | +|||
| 552 | +1520x |
- htmltools::tagAppendAttributes,+ cellii |
||
| 163 | -! | +|||
| 553 | +
- style = "font-weight: bold;"+ } |
|||
| 164 | +554 |
- )+ ) |
||
| 165 | -+ | |||
| 555 | +1122x |
- }+ ret <- list(.pad_end(thisbit_vals, padto = nleafcols)) |
||
| 166 | -+ | |||
| 556 | +1122x |
-
+ anycounts <- any(rws$ccount_visible) |
||
| 167 | -9x | +557 | +1122x |
- if (any(!mat$display)) {
+ if (anycounts) {
|
| 168 | -+ | |||
| 558 | +139x |
- # Check that expansion kept the same display info+ thisbit_ns <- lapply( |
||
| 169 | -2x | +559 | +139x |
- check_expansion <- c()+ seq_len(nrow(rws)), |
| 170 | -2x | +560 | +139x |
- for (ii in unique(mat$line_grouping)) {
+ function(ri) {
|
| 171 | -121x | +561 | +287x |
- rows <- which(mat$line_grouping == ii)+ vis_ri <- rws$ccount_visible[ri] |
| 172 | -121x | +562 | +287x |
- check_expansion <- c(+ val <- if (vis_ri) rws$col_count[ri] else NULL |
| 173 | -121x | +563 | +287x |
- check_expansion,+ fmt <- rws$ccount_format[ri] |
| 174 | -121x | +564 | +287x |
- apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x))+ if (is.character(fmt)) {
|
| 175 | -+ | |||
| 565 | +287x |
- )+ cfmt_dim <- names(which(sapply(formatters::list_valid_format_labels(), function(x) any(x == fmt)))) |
||
| 176 | -+ | |||
| 566 | +287x |
- }+ if (cfmt_dim == "2d") {
+ |
+ ||
| 567 | +7x | +
+ if (grepl("%", fmt)) {
+ |
+ ||
| 568 | +6x | +
+ val <- c(val, 1) ## XXX This is the old behavior but it doesn't take into account parent counts... |
||
| 177 | +569 |
-
+ } else {
|
||
| 178 | -2x | +570 | +1x |
- if (!all(check_expansion)) {
+ stop( |
| 179 | -! | +|||
| 571 | +1x |
- stop(+ "This 2d format is not supported for column counts. ", |
||
| 180 | -! | +|||
| 572 | +1x |
- "Found that a group of rows have different display options even if ",+ "Please choose a 1d format or a 2d format that includes a % value." |
||
| 181 | -! | +|||
| 573 | +
- "they belong to the same line group. This should not happen. Please ",+ ) |
|||
| 182 | -! | +|||
| 574 | +
- "file an issue or report to the maintainers."+ } |
|||
| 183 | -! | +|||
| 575 | +280x |
- ) # nocov+ } else if (cfmt_dim == "3d") {
+ |
+ ||
| 576 | +1x | +
+ stop("3d formats are not supported for column counts.")
|
||
| 184 | +577 |
- }+ } |
||
| 185 | +578 |
-
+ } |
||
| 186 | -2x | +579 | +285x |
- for (ii in unique(mat$line_grouping)) {
+ cellii <- rcell( |
| 187 | -121x | +580 | +285x |
- rows <- which(mat$line_grouping == ii)+ val, |
| 188 | -121x | +581 | +285x |
- should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any)+ colspan = rws$total_span[ri], |
| 189 | -121x | +582 | +285x |
- cells[ii, !should_display_col] <- NA_integer_+ format = fmt, # cc_format,+ |
+
| 583 | +285x | +
+ format_na_str = na_str |
||
| 190 | +584 |
- }+ )+ |
+ ||
| 585 | +285x | +
+ cellii |
||
| 191 | +586 |
- }+ } |
||
| 192 | +587 |
-
+ ) |
||
| 193 | -9x | +588 | +137x |
- rows <- apply(cells, 1, function(row) {
+ ret <- c(ret, list(.pad_end(thisbit_ns, padto = nleafcols))) |
| 194 | -173x | +|||
| 589 | +
- tags$tr(+ } |
|||
| 195 | -173x | +590 | +1120x |
- class = class_tr,+ ret |
| 196 | -173x | +|||
| 591 | +
- style = "white-space: pre;",+ }+ |
+ |||
| 592 | ++ |
+ ) |
||
| 197 | -173x | +593 | +821x |
- Filter(function(x) !identical(x, NA_integer_), row)+ toret |
| 198 | +594 |
- )+ } |
||
| 199 | +595 |
- })+ |
||
| 200 | +596 |
-
+ .tbl_header_mat <- function(tt) {
|
||
| 201 | -9x | +597 | +300x |
- hsep_line <- tags$hr(class = "solid")+ rows <- .do_tbl_h_piece2(tt) ## (clyt)+ |
+
| 598 | +298x | +
+ cinfo <- col_info(tt) |
||
| 202 | +599 | |||
| 203 | -9x | +600 | +298x |
- hdrtag <- div_helper(+ nc <- ncol(tt) |
| 204 | -9x | +601 | +298x |
- class = "rtables-titles-block",+ body <- matrix(rapply(rows, function(x) {
|
| 205 | -9x | +602 | +456x |
- list(+ cs <- row_cspans(x) |
| 206 | -9x | +603 | +456x |
- div_helper(+ strs <- get_formatted_cells(x) |
| 207 | -9x | +604 | +456x |
- class = "rtables-main-titles-block",+ strs |
| 208 | -9x | +605 | +298x |
- lapply(main_title(x), if ("main_title" %in% bold) tags$b else tags$p,
+ }), ncol = nc, byrow = TRUE)+ |
+
| 606 | ++ | + | ||
| 209 | -9x | +607 | +298x |
- class = "rtables-main-title"+ span <- matrix(rapply(rows, function(x) {
|
| 210 | -+ | |||
| 608 | +456x |
- )+ cs <- row_cspans(x) |
||
| 211 | -+ | |||
| 609 | +! |
- ),+ if (is.null(cs)) cs <- rep(1, ncol(x)) |
||
| 212 | -9x | +610 | +456x |
- div_helper(+ rep(cs, cs) |
| 213 | -9x | +611 | +298x |
- class = "rtables-subtitles-block",+ }), ncol = nc, byrow = TRUE)+ |
+
| 612 | ++ | + | ||
| 214 | -9x | +613 | +298x |
- lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p,
+ fnote <- do.call( |
| 215 | -9x | +614 | +298x |
- class = "rtables-subtitle"+ rbind, |
| 216 | -+ | |||
| 615 | +298x |
- )+ lapply(rows, function(x) {
|
||
| 217 | -+ | |||
| 616 | +456x |
- )+ cell_footnotes(x) |
||
| 218 | +617 |
- )+ }) |
||
| 219 | +618 |
) |
||
| 220 | +619 | |||
| 221 | -9x | +620 | +298x |
- tabletag <- do.call(+ tl <- top_left(cinfo) |
| 222 | -9x | +621 | +298x |
- tags$table,+ lentl <- length(tl) |
| 223 | -9x | +622 | +298x |
- c(+ nli <- nrow(body) |
| 224 | -9x | +623 | +298x |
- rows,+ if (lentl == 0) {
|
| 225 | -9x | +624 | +262x |
- list(+ tl <- rep("", nli)
|
| 226 | -9x | +625 | +36x |
- class = class_table,+ } else if (lentl > nli) {
|
| 227 | -9x | +626 | +20x |
- style = paste(+ tl_tmp <- paste0(tl, collapse = "\n") |
| 228 | -9x | +627 | +20x |
- if (no_spaces_between_cells) "border-collapse: collapse;",+ tl <- rep("", nli)
|
| 229 | -9x | +628 | +20x |
- if (!is.null(width)) paste("width:", width)
+ tl[length(tl)] <- tl_tmp+ |
+
| 629 | +16x | +
+ } else if (lentl < nli) {
|
||
| 230 | +630 |
- ),+ # We want topleft alignment that goes to the bottom! |
||
| 231 | -9x | +631 | +7x |
- tags$caption(sprintf("(\\#tag:%s)", link_label),
+ tl <- c(rep("", nli - lentl), tl)
+ |
+
| 632 | ++ |
+ } |
||
| 232 | -9x | +633 | +298x |
- style = "caption-side: top;",+ list( |
| 233 | -9x | +634 | +298x |
- .noWS = "after-begin"+ body = cbind(tl, body, deparse.level = 0), span = cbind(1, span),+ |
+
| 635 | +298x | +
+ footnotes = cbind(list(list()), fnote) |
||
| 234 | +636 |
- )+ ) |
||
| 235 | +637 |
- )+ } |
||
| 236 | +638 |
- )+ |
||
| 237 | +639 |
- )+ # get formatted cells ---- |
||
| 238 | +640 | |||
| 239 | -9x | +|||
| 641 | +
- rfnotes <- div_helper(+ #' Get formatted cells |
|||
| 240 | -9x | +|||
| 642 | +
- class = "rtables-ref-footnotes-block",+ #' |
|||
| 241 | -9x | +|||
| 643 | +
- lapply(mat$ref_footnotes, tags$p,+ #' @inheritParams gen_args |
|||
| 242 | -9x | +|||
| 644 | +
- class = "rtables-referential-footnote"+ #' @param shell (`flag`)\cr whether the formats themselves should be returned instead of the values with formats |
|||
| 243 | +645 |
- )+ #' applied. Defaults to `FALSE`. |
||
| 244 | +646 |
- )+ #' |
||
| 245 | +647 |
-
+ #' @return The formatted print-strings for all (body) cells in `obj`. |
||
| 246 | -9x | +|||
| 648 | +
- mftr <- div_helper(+ #' |
|||
| 247 | -9x | +|||
| 649 | +
- class = "rtables-main-footers-block",+ #' @examplesIf require(dplyr) |
|||
| 248 | -9x | +|||
| 650 | +
- lapply(main_footer(x), tags$p,+ #' library(dplyr) |
|||
| 249 | -9x | +|||
| 651 | +
- class = "rtables-main-footer"+ #' |
|||
| 250 | +652 |
- )+ #' iris2 <- iris %>% |
||
| 251 | +653 |
- )+ #' group_by(Species) %>% |
||
| 252 | +654 |
-
+ #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
|
||
| 253 | -9x | +|||
| 655 | +
- pftr <- div_helper(+ #' ungroup() |
|||
| 254 | -9x | +|||
| 656 | +
- class = "rtables-prov-footers-block",+ #' |
|||
| 255 | -9x | +|||
| 657 | +
- lapply(prov_footer(x), tags$p,+ #' tbl <- basic_table() %>% |
|||
| 256 | -9x | +|||
| 658 | +
- class = "rtables-prov-footer"+ #' split_cols_by("Species") %>%
|
|||
| 257 | +659 |
- )+ #' split_cols_by("group") %>%
|
||
| 258 | +660 |
- )+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = list_wrap_x(summary), format = "xx.xx") %>%
|
||
| 259 | +661 |
-
+ #' build_table(iris2) |
||
| 260 | +662 |
- ## XXX this omits the divs entirely if they are empty. Do we want that or do+ #' |
||
| 261 | +663 |
- ## we want them to be there but empty??+ #' get_formatted_cells(tbl) |
||
| 262 | -9x | +|||
| 664 | +
- ftrlst <- list(+ #' |
|||
| 263 | -9x | +|||
| 665 | +
- if (length(mat$ref_footnotes) > 0) rfnotes,+ #' @export |
|||
| 264 | -9x | +|||
| 666 | +
- if (length(mat$ref_footnotes) > 0) hsep_line,+ #' @rdname gfc |
|||
| 265 | -9x | +667 | +37643x |
- if (length(main_footer(x)) > 0) mftr,+ setGeneric("get_formatted_cells", function(obj, shell = FALSE) standardGeneric("get_formatted_cells"))
|
| 266 | -9x | +|||
| 668 | +
- if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), # line break+ |
|||
| 267 | -9x | +|||
| 669 | +
- if (length(prov_footer(x)) > 0) pftr+ #' @rdname gfc |
|||
| 268 | +670 |
- )+ setMethod( |
||
| 269 | +671 |
-
+ "get_formatted_cells", "TableTree", |
||
| 270 | -! | +|||
| 672 | +
- if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst)+ function(obj, shell = FALSE) {
|
|||
| 271 | -9x | +673 | +2732x |
- ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)]+ lr <- get_formatted_cells(tt_labelrow(obj), shell = shell) |
| 272 | +674 | |||
| 273 | -9x | +675 | +2732x |
- ftrtag <- div_helper(+ ct <- get_formatted_cells(content_table(obj), shell = shell) |
| 274 | -9x | +|||
| 676 | +
- class = "rtables-footers-block",+ |
|||
| 275 | -9x | +677 | +2732x |
- ftrlst+ els <- lapply(tree_children(obj), get_formatted_cells, shell = shell) |
| 276 | +678 |
- )+ |
||
| 277 | +679 |
-
+ ## TODO fix ncol problem for rrow() |
||
| 278 | -9x | +680 | +2732x |
- div_helper(+ if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
|
| 279 | -9x | +681 | +751x |
- class = "rtables-all-parts-block",+ ct <- lr[NULL, ] |
| 280 | -9x | +|||
| 682 | +
- list(+ } |
|||
| 281 | -9x | +|||
| 683 | +
- hdrtag,+ |
|||
| 282 | -9x | +684 | +2732x |
- tabletag,+ do.call(rbind, c(list(lr), list(ct), els)) |
| 283 | -9x | +|||
| 685 | +
- ftrtag+ } |
|||
| 284 | +686 |
- )+ ) |
||
| 285 | +687 |
- )+ |
||
| 286 | +688 |
- }+ #' @rdname gfc |
| 1 | +689 |
- # Generics and how they are used directly -------------------------------------+ setMethod( |
||
| 2 | +690 |
-
+ "get_formatted_cells", "ElementaryTable", |
||
| 3 | +691 |
- ## check_validsplit - Check if the split is valid for the data, error if not+ function(obj, shell = FALSE) {
|
||
| 4 | -+ | |||
| 692 | +5433x |
-
+ lr <- get_formatted_cells(tt_labelrow(obj), shell = shell)+ |
+ ||
| 693 | +5433x | +
+ els <- lapply(tree_children(obj), get_formatted_cells, shell = shell)+ |
+ ||
| 694 | +5433x | +
+ do.call(rbind, c(list(lr), els)) |
||
| 5 | +695 |
- ## .apply_spl_extras - Generate Extras+ } |
||
| 6 | +696 |
-
+ ) |
||
| 7 | +697 |
- ## .apply_spl_datapart - generate data partition+ |
||
| 8 | +698 |
-
+ #' @rdname gfc |
||
| 9 | +699 |
- ## .apply_spl_rawvals - Generate raw (i.e. non SplitValue object) partition values+ setMethod( |
||
| 10 | +700 |
-
+ "get_formatted_cells", "TableRow", |
||
| 11 | +701 |
- setGeneric(+ function(obj, shell = FALSE) {
|
||
| 12 | +702 |
- ".applysplit_rawvals",+ # Parent row format and na_str |
||
| 13 | -982x | +703 | +21285x |
- function(spl, df) standardGeneric(".applysplit_rawvals")
+ pr_row_format <- if (is.null(obj_format(obj))) "xx" else obj_format(obj) |
| 14 | -+ | |||
| 704 | +21285x |
- )+ pr_row_na_str <- obj_na_str(obj) %||% "NA" |
||
| 15 | +705 | |||
| 16 | -+ | |||
| 706 | +21285x |
- setGeneric(+ matrix( |
||
| 17 | -+ | |||
| 707 | +21285x |
- ".applysplit_datapart",+ unlist(Map(function(val, spn, shelli) {
|
||
| 18 | -1055x | +708 | +102456x |
- function(spl, df, vals) standardGeneric(".applysplit_datapart")
+ stopifnot(is(spn, "integer")) |
| 19 | +709 |
- )+ |
||
| 20 | -+ | |||
| 710 | +102456x |
-
+ out <- format_rcell(val, |
||
| 21 | -+ | |||
| 711 | +102456x |
- setGeneric(+ pr_row_format = pr_row_format, |
||
| 22 | -+ | |||
| 712 | +102456x |
- ".applysplit_extras",+ pr_row_na_str = pr_row_na_str, |
||
| 23 | -1055x | +713 | +102456x |
- function(spl, df, vals) standardGeneric(".applysplit_extras")
+ shell = shelli |
| 24 | +714 |
- )+ ) |
||
| 25 | -+ | |||
| 715 | +102456x |
-
+ if (!is.function(out) && is.character(out)) {
+ |
+ ||
| 716 | +102448x | +
+ out <- paste(out, collapse = ", ") |
||
| 26 | +717 |
- setGeneric(+ } |
||
| 27 | +718 |
- ".applysplit_partlabels",+ |
||
| 28 | -1052x | +719 | +102456x |
- function(spl, df, vals, labels) standardGeneric(".applysplit_partlabels")
+ rep(list(out), spn) |
| 29 | -+ | |||
| 720 | +21285x |
- )+ }, val = row_cells(obj), spn = row_cspans(obj), shelli = shell)), |
||
| 30 | -+ | |||
| 721 | +21285x |
-
+ ncol = ncol(obj) |
||
| 31 | +722 |
- setGeneric(+ ) |
||
| 32 | +723 |
- "check_validsplit",- |
- ||
| 33 | -2185x | -
- function(spl, df) standardGeneric("check_validsplit")
+ } |
||
| 34 | +724 |
) |
||
| 35 | +725 | |||
| 36 | +726 |
- setGeneric(+ #' @rdname gfc |
||
| 37 | +727 |
- ".applysplit_ref_vals",+ setMethod( |
||
| 38 | -17x | +|||
| 728 | +
- function(spl, df, vals) standardGeneric(".applysplit_ref_vals")
+ "get_formatted_cells", "LabelRow", |
|||
| 39 | +729 |
- )+ function(obj, shell = FALSE) {
|
||
| 40 | -+ | |||
| 730 | +8193x |
- # Custom split fncs ------------------------------------------------------------+ nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
|
||
| 41 | -+ | |||
| 731 | +8193x |
- #' Custom split functions+ vstr <- if (shell) "-" else "" |
||
| 42 | -+ | |||
| 732 | +8193x |
- #'+ if (labelrow_visible(obj)) {
|
||
| 43 | -+ | |||
| 733 | +2988x |
- #' Split functions provide the work-horse for `rtables`'s generalized partitioning. These functions accept a (sub)set+ matrix(rep(vstr, nc), ncol = nc) |
||
| 44 | +734 |
- #' of incoming data and a split object, and return "splits" of that data.+ } else {
|
||
| 45 | -+ | |||
| 735 | +5205x |
- #'+ matrix(character(0), ncol = nc) |
||
| 46 | +736 |
- #' @section Custom Splitting Function Details:+ } |
||
| 47 | +737 |
- #'+ } |
||
| 48 | +738 |
- #' User-defined custom split functions can perform any type of computation on the incoming data provided that they+ ) |
||
| 49 | +739 |
- #' meet the requirements for generating "splits" of the incoming data based on the split object.+ |
||
| 50 | +740 |
- #'+ #' @rdname gfc |
||
| 51 | -+ | |||
| 741 | +13256x |
- #' Split functions are functions that accept:+ setGeneric("get_cell_aligns", function(obj) standardGeneric("get_cell_aligns"))
|
||
| 52 | +742 |
- #' \describe{
+
|
||
| 53 | +743 |
- #' \item{df}{a `data.frame` of incoming data to be split.}
+ #' @rdname gfc |
||
| 54 | +744 |
- #' \item{spl}{a Split object. This is largely an internal detail custom functions will not need to worry about,
+ setMethod( |
||
| 55 | +745 |
- #' but `obj_name(spl)`, for example, will give the name of the split as it will appear in paths in the resulting+ "get_cell_aligns", "TableTree", |
||
| 56 | +746 |
- #' table.}+ function(obj) {
|
||
| 57 | -+ | |||
| 747 | +1364x |
- #' \item{vals}{any pre-calculated values. If given non-`NULL` values, the values returned should match these.
+ lr <- get_cell_aligns(tt_labelrow(obj)) |
||
| 58 | +748 |
- #' Should be `NULL` in most cases and can usually be ignored.}+ |
||
| 59 | -+ | |||
| 749 | +1364x |
- #' \item{labels}{any pre-calculated value labels. Same as above for `values`.}
+ ct <- get_cell_aligns(content_table(obj)) |
||
| 60 | +750 |
- #' \item{trim}{if `TRUE`, resulting splits that are empty are removed.}
+
|
||
| 61 | -+ | |||
| 751 | +1364x |
- #' \item{(optional) .spl_context}{a `data.frame` describing previously performed splits which collectively
+ els <- lapply(tree_children(obj), get_cell_aligns) |
||
| 62 | +752 |
- #' arrived at `df`.}+ |
||
| 63 | +753 |
- #' }+ ## TODO fix ncol problem for rrow() |
||
| 64 | -+ | |||
| 754 | +1364x |
- #'+ if (ncol(ct) == 0 && ncol(lr) != ncol(ct)) {
|
||
| 65 | -+ | |||
| 755 | +375x |
- #' The function must then output a named `list` with the following elements:+ ct <- lr[NULL, ] |
||
| 66 | +756 |
- #'+ } |
||
| 67 | +757 |
- #' \describe{
+
|
||
| 68 | -+ | |||
| 758 | +1364x |
- #' \item{values}{the vector of all values corresponding to the splits of `df`.}
+ do.call(rbind, c(list(lr), list(ct), els)) |
||
| 69 | +759 |
- #' \item{datasplit}{a list of `data.frame`s representing the groupings of the actual observations from `df`.}
+ } |
||
| 70 | +760 |
- #' \item{labels}{a character vector giving a string label for each value listed in the `values` element above.}
+ ) |
||
| 71 | +761 |
- #' \item{(optional) extras}{if present, extra arguments are to be passed to summary and analysis functions
+
|
||
| 72 | +762 |
- #' whenever they are executed on the corresponding element of `datasplit` or a subset thereof.}+ #' @rdname gfc |
||
| 73 | +763 |
- #' }+ setMethod( |
||
| 74 | +764 |
- #'+ "get_cell_aligns", "ElementaryTable", |
||
| 75 | +765 |
- #' One way to generate custom splitting functions is to wrap existing split functions and modify either the incoming+ function(obj) {
|
||
| 76 | -+ | |||
| 766 | +2712x |
- #' data before they are called or their outputs.+ lr <- get_cell_aligns(tt_labelrow(obj)) |
||
| 77 | -+ | |||
| 767 | +2712x |
- #'+ els <- lapply(tree_children(obj), get_cell_aligns) |
||
| 78 | -+ | |||
| 768 | +2712x |
- #' @seealso [make_split_fun()] for the API for creating custom split functions, and [split_funcs] for a variety of+ do.call(rbind, c(list(lr), els)) |
||
| 79 | +769 |
- #' pre-defined split functions.+ } |
||
| 80 | +770 |
- #'+ ) |
||
| 81 | +771 |
- #' @examples+ |
||
| 82 | +772 |
- #' # Example of a picky split function. The number of values in the column variable+ #' @rdname gfc |
||
| 83 | +773 |
- #' # var decrees if we are going to print also the column with all observation+ setMethod( |
||
| 84 | +774 |
- #' # or not.+ "get_cell_aligns", "TableRow", |
||
| 85 | +775 |
- #'+ function(obj) {
|
||
| 86 | -+ | |||
| 776 | +5090x |
- #' picky_splitter <- function(var) {
+ als <- vapply(row_cells(obj), cell_align, "") |
||
| 87 | -+ | |||
| 777 | +5090x |
- #' # Main layout function+ spns <- row_cspans(obj) |
||
| 88 | +778 |
- #' function(df, spl, vals, labels, trim) {
+
|
||
| 89 | -+ | |||
| 779 | +5090x |
- #' orig_vals <- vals+ matrix(rep(als, times = spns), |
||
| 90 | -+ | |||
| 780 | +5090x |
- #'+ ncol = ncol(obj) |
||
| 91 | +781 |
- #' # Check for number of levels if all are selected+ ) |
||
| 92 | +782 |
- #' if (is.null(vals)) {
+ } |
||
| 93 | +783 |
- #' vec <- df[[var]]+ ) |
||
| 94 | +784 |
- #' vals <- unique(vec)+ |
||
| 95 | +785 |
- #' }+ #' @rdname gfc |
||
| 96 | +786 |
- #'+ setMethod( |
||
| 97 | +787 |
- #' # Do a split with or without All obs+ "get_cell_aligns", "LabelRow", |
||
| 98 | +788 |
- #' if (length(vals) == 1) {
+ function(obj) {
|
||
| 99 | -+ | |||
| 789 | +4090x |
- #' do_base_split(spl = spl, df = df, vals = vals, labels = labels, trim = trim)+ nc <- ncol(obj) # TODO note rrow() or rrow("label") has the wrong ncol
|
||
| 100 | -+ | |||
| 790 | +4090x |
- #' } else {
+ if (labelrow_visible(obj)) {
|
||
| 101 | -+ | |||
| 791 | +1494x |
- #' fnc_tmp <- add_overall_level("Overall", label = "All Obs", first = FALSE)
+ matrix(rep("center", nc), ncol = nc)
|
||
| 102 | +792 |
- #' fnc_tmp(df = df, spl = spl, vals = orig_vals, trim = trim)+ } else {
|
||
| 103 | -+ | |||
| 793 | +2596x |
- #' }+ matrix(character(0), ncol = nc) |
||
| 104 | +794 |
- #' }+ } |
||
| 105 | +795 |
- #' }+ } |
||
| 106 | +796 |
- #'+ ) |
||
| 107 | +797 |
- #' # Data sub-set+ |
||
| 108 | +798 |
- #' d1 <- subset(ex_adsl, ARM == "A: Drug X" | (ARM == "B: Placebo" & SEX == "F"))+ # utility functions ---- |
||
| 109 | +799 |
- #' d1 <- subset(d1, SEX %in% c("M", "F"))
+
|
||
| 110 | +800 |
- #' d1$SEX <- factor(d1$SEX)+ #' From a sorted sequence of numbers, remove numbers where diff == 1 |
||
| 111 | +801 |
#' |
||
| 112 | +802 |
- #' # This table uses the number of values in the SEX column to add the overall col or not+ #' @examples |
||
| 113 | +803 |
- #' lyt <- basic_table() %>%+ #' remove_consecutive_numbers(x = c(2, 4, 9)) |
||
| 114 | +804 |
- #' split_cols_by("ARM", split_fun = drop_split_levels) %>%
+ #' remove_consecutive_numbers(x = c(2, 4, 5, 9)) |
||
| 115 | +805 |
- #' split_cols_by("SEX", split_fun = picky_splitter("SEX")) %>%
+ #' remove_consecutive_numbers(x = c(2, 4, 5, 6, 9)) |
||
| 116 | +806 |
- #' analyze("AGE", show_labels = "visible")
+ #' remove_consecutive_numbers(x = 4:9) |
||
| 117 | +807 |
- #' tbl <- build_table(lyt, d1)+ #' |
||
| 118 | +808 |
- #' tbl+ #' @noRd |
||
| 119 | +809 |
- #'+ remove_consecutive_numbers <- function(x) {
|
||
| 120 | +810 |
- #' @name custom_split_funs+ # actually should be integer |
||
| 121 | -+ | |||
| 811 | +! |
- NULL+ stopifnot(is.wholenumber(x), is.numeric(x), !is.unsorted(x)) |
||
| 122 | +812 | |||
| 123 | -+ | |||
| 813 | +! |
- ## do various cleaning, and naming, plus+ if (length(x) == 0) {
|
||
| 124 | -+ | |||
| 814 | +! |
- ## ensure partinfo$values contains SplitValue objects only+ return(integer(0)) |
||
| 125 | +815 |
- .fixupvals <- function(partinfo) {
+ } |
||
| 126 | -1082x | +|||
| 816 | +! |
- if (is.factor(partinfo$labels)) {
+ if (!is.integer(x)) x <- as.integer(x)+ |
+ ||
| 817 | ++ | + | ||
| 127 | +818 | ! |
- partinfo$labels <- as.character(partinfo$labels)+ x[c(TRUE, diff(x) != 1)] |
|
| 128 | +819 |
- }+ } |
||
| 129 | +820 | |||
| 130 | -1082x | +|||
| 821 | +
- vals <- partinfo$values+ #' Insert an empty string |
|||
| 131 | -1082x | +|||
| 822 | +
- if (is.factor(vals)) {
+ #' |
|||
| 132 | -! | +|||
| 823 | +
- vals <- levels(vals)[vals]+ #' @examples |
|||
| 133 | +824 |
- }+ #' empty_string_after(letters[1:5], 2) |
||
| 134 | -1082x | +|||
| 825 | +
- extr <- partinfo$extras+ #' empty_string_after(letters[1:5], c(2, 4)) |
|||
| 135 | -1082x | +|||
| 826 | +
- dpart <- partinfo$datasplit+ #' |
|||
| 136 | -1082x | +|||
| 827 | +
- labels <- partinfo$labels+ #' @noRd |
|||
| 137 | -1082x | +|||
| 828 | +
- if (is.null(labels)) {
+ empty_string_after <- function(x, indices) {
|
|||
| 138 | +829 | ! |
- if (!is.null(names(vals))) {
+ if (length(indices) > 0) {
|
|
| 139 | +830 | ! |
- labels <- names(vals)+ offset <- 0 |
|
| 140 | +831 | ! |
- } else if (!is.null(names(dpart))) {
+ for (i in sort(indices)) {
|
|
| 141 | +832 | ! |
- labels <- names(dpart)+ x <- append(x, "", i + offset) |
|
| 142 | +833 | ! |
- } else if (!is.null(names(extr))) {
+ offset <- offset + 1 |
|
| 143 | -! | +|||
| 834 | +
- labels <- names(extr)+ } |
|||
| 144 | +835 |
- }+ }+ |
+ ||
| 836 | +! | +
+ x |
||
| 145 | +837 |
- }+ } |
||
| 146 | +838 | |||
| 147 | -1082x | +|||
| 839 | +
- subsets <- partinfo$subset_exprs+ #' Indent strings |
|||
| 148 | -1082x | +|||
| 840 | +
- if (is.null(subsets)) {
+ #' |
|||
| 149 | -1066x | +|||
| 841 | +
- subsets <- vector(mode = "list", length = length(vals))+ #' Used in rtables to indent row names for the ASCII output. |
|||
| 150 | +842 |
- ## use labels here cause we already did all that work+ #' |
||
| 151 | +843 |
- ## to get the names on the labels vector right+ #' @param x (`character`)\cr a character vector. |
||
| 152 | -1066x | +|||
| 844 | +
- names(subsets) <- names(labels)+ #' @param indent (`numeric`)\cr a vector of non-negative integers of length `length(x)`. |
|||
| 153 | +845 |
- }+ #' @param incr (`integer(1)`)\cr a non-negative number of spaces per indent level. |
||
| 154 | +846 |
-
+ #' @param including_newline (`flag`)\cr whether newlines should also be indented. |
||
| 155 | -1082x | +|||
| 847 | +
- if (is.null(vals) && !is.null(extr)) {
+ #' |
|||
| 156 | -! | +|||
| 848 | +
- vals <- seq_along(extr)+ #' @return `x`, indented with left-padding with `indent * incr` white-spaces. |
|||
| 157 | +849 |
- }+ #' |
||
| 158 | +850 |
-
+ #' @examples |
||
| 159 | -1082x | +|||
| 851 | +
- if (length(vals) == 0) {
+ #' indent_string("a", 0)
|
|||
| 160 | -13x | +|||
| 852 | +
- stopifnot(length(extr) == 0)+ #' indent_string("a", 1)
|
|||
| 161 | -13x | +|||
| 853 | +
- return(partinfo)+ #' indent_string(letters[1:3], 0:2) |
|||
| 162 | +854 |
- }+ #' indent_string(paste0(letters[1:3], "\n", LETTERS[1:3]), 0:2) |
||
| 163 | +855 |
- ## length(vals) > 0 from here down+ #' |
||
| 164 | +856 |
-
+ #' @export |
||
| 165 | -1069x | +|||
| 857 | +
- if (are(vals, "SplitValue") && !are(vals, "LevelComboSplitValue")) {
+ indent_string <- function(x, indent = 0, incr = 2, including_newline = TRUE) {
|
|||
| 166 | -22x | +858 | +598x |
- if (!is.null(extr)) {
+ if (length(x) > 0) {
|
| 167 | -+ | |||
| 859 | +598x |
- ## in_ref_cols is in here for some reason even though its already in the SplitValue object.+ indent <- rep_len(indent, length.out = length(x)) |
||
| 168 | -+ | |||
| 860 | +598x |
- ## https://github.com/insightsengineering/rtables/issues/707#issuecomment-1678810598+ incr <- rep_len(incr, length.out = length(x)) |
||
| 169 | +861 |
- ## the if is a bandaid.+ } |
||
| 170 | +862 |
- ## XXX FIXME RIGHT+ |
||
| 171 | -3x | +863 | +598x |
- sq <- seq_along(vals)+ indent_str <- strrep(" ", (indent > 0) * indent * incr)
|
| 172 | -3x | +|||
| 864 | +
- if (any(vapply(sq, function(i) !all(names(extr[[i]]) %in% names(splv_extra(vals[[i]]))), TRUE))) {
+
|
|||
| 173 | -! | +|||
| 865 | +598x |
- warning(+ if (including_newline) {
|
||
| 174 | -! | +|||
| 866 | +598x |
- "Got a partinfo list with values that are ",+ x <- unlist(mapply(function(xi, stri) {
|
||
| 175 | -! | +|||
| 867 | +12796x |
- "already SplitValue objects and non-null extras ",+ gsub("\n", stri, xi, fixed = TRUE)
|
||
| 176 | -! | +|||
| 868 | +598x |
- "element. This shouldn't happen"+ }, x, paste0("\n", indent_str)))
|
||
| 177 | +869 |
- )+ } |
||
| 178 | +870 |
- }+ |
||
| 179 | -+ | |||
| 871 | +598x |
- }+ paste0(indent_str, x) |
||
| 180 | +872 |
- } else {
- |
- ||
| 181 | -1047x | -
- if (is.null(extr)) {
- |
- ||
| 182 | -6x | -
- extr <- rep(list(list()), length(vals))+ } |
||
| 183 | +873 |
- }- |
- ||
| 184 | -1047x | -
- vals <- make_splvalue_vec(vals, extr, labels = labels, subset_exprs = subsets)+ |
||
| 185 | +874 |
- }+ ## .paste_no_na <- function(x, ...) {
|
||
| 186 | +875 |
- ## we're done with this so take it off+ ## paste(na.omit(x), ...) |
||
| 187 | -1069x | +|||
| 876 | +
- partinfo$extras <- NULL+ ## } |
|||
| 188 | +877 | |||
| 189 | -1069x | +|||
| 878 | +
- vnames <- value_names(vals)+ ## #' Pad a string and align within string |
|||
| 190 | -1069x | +|||
| 879 | +
- names(vals) <- vnames+ ## #' |
|||
| 191 | -1069x | +|||
| 880 | +
- partinfo$values <- vals+ ## #' @param x string |
|||
| 192 | +881 |
-
+ ## #' @param n number of character of the output string, if `n < nchar(x)` an error is thrown |
||
| 193 | -1069x | +|||
| 882 | +
- if (!identical(names(dpart), vnames)) {
+ ## #' |
|||
| 194 | -1069x | +|||
| 883 | +
- names(dpart) <- vnames+ ## #' @noRd |
|||
| 195 | -1069x | +|||
| 884 | +
- partinfo$datasplit <- dpart+ ## #' |
|||
| 196 | +885 |
- }+ ## #' @examples |
||
| 197 | +886 |
-
+ ## #' |
||
| 198 | -1069x | +|||
| 887 | +
- partinfo$labels <- labels+ ## #' padstr("abc", 3)
|
|||
| 199 | +888 |
-
+ ## #' padstr("abc", 4)
|
||
| 200 | -1069x | +|||
| 889 | +
- stopifnot(length(unique(sapply(partinfo, NROW))) == 1)+ ## #' padstr("abc", 5)
|
|||
| 201 | -1069x | +|||
| 890 | +
- partinfo+ ## #' padstr("abc", 5, "left")
|
|||
| 202 | +891 |
- }+ ## #' padstr("abc", 5, "right")
|
||
| 203 | +892 |
-
+ ## #' |
||
| 204 | +893 |
- .add_ref_extras <- function(spl, df, partinfo) {
+ ## #' if(interactive()){
|
||
| 205 | +894 |
- ## this is only the .in_ref_col booleans+ ## #' padstr("abc", 1)
|
||
| 206 | -17x | +|||
| 895 | +
- refvals <- .applysplit_ref_vals(spl, df, partinfo$values)+ ## #' } |
|||
| 207 | -17x | +|||
| 896 | +
- ref_ind <- which(unlist(refvals))+ ## #' |
|||
| 208 | -17x | +|||
| 897 | +
- stopifnot(length(ref_ind) == 1)+ ## padstr <- function(x, n, just = c("center", "left", "right")) {
|
|||
| 209 | +898 | |||
| 210 | -17x | +|||
| 899 | +
- vnames <- value_names(partinfo$values)+ ## just <- match.arg(just) |
|||
| 211 | -17x | +|||
| 900 | +
- if (is.null(partinfo$extras)) {
+
|
|||
| 212 | -3x | +|||
| 901 | +
- names(refvals) <- vnames+ ## if (length(x) != 1) stop("length of x needs to be 1 and not", length(x))
|
|||
| 213 | -3x | +|||
| 902 | +
- partinfo$extras <- refvals+ ## if (is.na(n) || !is.numeric(n) || n < 0) stop("n needs to be numeric and > 0")
|
|||
| 214 | +903 |
- } else {
+
|
||
| 215 | -14x | +|||
| 904 | +
- newextras <- mapply(+ ## if (is.na(x)) x <- "<NA>" |
|||
| 216 | -14x | +|||
| 905 | +
- function(old, incol, ref_full) {
+
|
|||
| 217 | -37x | +|||
| 906 | +
- c(old, list(+ ## nc <- nchar(x) |
|||
| 218 | -37x | +|||
| 907 | +
- .in_ref_col = incol,+ |
|||
| 219 | -37x | +|||
| 908 | +
- .ref_full = ref_full+ ## if (n < nc) stop("\"", x, "\" has more than ", n, " characters")
|
|||
| 220 | +909 |
- ))+ |
||
| 221 | +910 |
- },+ ## switch( |
||
| 222 | -14x | +|||
| 911 | +
- old = partinfo$extras,+ ## just, |
|||
| 223 | -14x | +|||
| 912 | +
- incol = unlist(refvals),+ ## center = {
|
|||
| 224 | -14x | +|||
| 913 | +
- MoreArgs = list(ref_full = partinfo$datasplit[[ref_ind]]),+ ## pad <- (n - nc)/2 |
|||
| 225 | -14x | +|||
| 914 | +
- SIMPLIFY = FALSE+ ## paste0(spaces(floor(pad)), x, spaces(ceiling(pad))) |
|||
| 226 | +915 |
- )+ ## }, |
||
| 227 | -14x | +|||
| 916 | +
- names(newextras) <- vnames+ ## left = paste0(x, spaces(n - nc)), |
|||
| 228 | -14x | +|||
| 917 | +
- partinfo$extras <- newextras+ ## right = paste0(spaces(n - nc), x) |
|||
| 229 | +918 |
- }+ ## ) |
||
| 230 | -17x | +|||
| 919 | +
- partinfo+ ## } |
|||
| 231 | +920 |
- }+ |
||
| 232 | +921 |
-
+ ## spaces <- function(n) {
|
||
| 233 | +922 |
- #' Apply basic split (for use in custom split functions)+ ## strrep(" ", n)
|
||
| 234 | +923 |
- #'+ ## } |
||
| 235 | +924 |
- #' This function is intended for use inside custom split functions. It applies the current split *as if it had no+ |
||
| 236 | +925 |
- #' custom splitting function* so that those default splits can be further manipulated.+ #' Convert matrix of strings into a string with aligned columns |
||
| 237 | +926 |
#' |
||
| 238 | +927 |
- #' @inheritParams gen_args+ #' Note that this function is intended to print simple rectangular matrices and not `rtable`s. |
||
| 239 | +928 |
- #' @param vals (`ANY`)\cr already calculated/known values of the split. Generally should be left as `NULL`.+ #' |
||
| 240 | +929 |
- #' @param labels (`character`)\cr labels associated with `vals`. Should be `NULL` whenever `vals` is, which should+ #' @param mat (`matrix`)\cr a matrix of strings. |
||
| 241 | +930 |
- #' almost always be the case.+ #' @param nheader (`integer(1)`)\cr number of header rows. |
||
| 242 | +931 |
- #' @param trim (`flag`)\cr whether groups corresponding to empty data subsets should be removed. Defaults to+ #' @param colsep (`string`)\cr a string that separates the columns. |
||
| 243 | +932 |
- #' `FALSE`.+ #' @param hsep (`character(1)`)\cr character to build line separator. |
||
| 244 | +933 |
#' |
||
| 245 | +934 |
- #' @return The result of the split being applied as if it had no custom split function. See [custom_split_funs].+ #' @return A string. |
||
| 246 | +935 |
#' |
||
| 247 | +936 |
#' @examples |
||
| 248 | +937 |
- #' uneven_splfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ #' mat <- matrix(c("A", "B", "C", "a", "b", "c"), nrow = 2, byrow = TRUE)
|
||
| 249 | +938 |
- #' ret <- do_base_split(spl, df, vals, labels, trim)+ #' cat(mat_as_string(mat)) |
||
| 250 | +939 |
- #' if (NROW(df) == 0) {
+ #' cat("\n")
|
||
| 251 | +940 |
- #' ret <- lapply(ret, function(x) x[1])+ #' |
||
| 252 | +941 |
- #' }+ #' @noRd |
||
| 253 | +942 |
- #' ret+ mat_as_string <- function(mat, nheader = 1, colsep = " ", hsep = default_hsep()) {
+ |
+ ||
| 943 | +2x | +
+ colwidths <- apply(apply(mat, c(1, 2), nchar), 2, max) |
||
| 254 | +944 |
- #' }+ + |
+ ||
| 945 | +2x | +
+ rows_formatted <- apply(mat, 1, function(row) {
+ |
+ ||
| 946 | +36x | +
+ paste(unlist(mapply(padstr, row, colwidths, "left")), collapse = colsep) |
||
| 255 | +947 |
- #'+ }) |
||
| 256 | +948 |
- #' lyt <- basic_table() %>%+ + |
+ ||
| 949 | +2x | +
+ header_rows <- seq_len(nheader)+ |
+ ||
| 950 | +2x | +
+ nchwidth <- nchar(rows_formatted[1])+ |
+ ||
| 951 | +2x | +
+ paste(c(+ |
+ ||
| 952 | +2x | +
+ rows_formatted[header_rows],+ |
+ ||
| 953 | +2x | +
+ substr(strrep(hsep, nchwidth), 1, nchwidth),+ |
+ ||
| 954 | +2x | +
+ rows_formatted[-header_rows]+ |
+ ||
| 955 | +2x | +
+ ), collapse = "\n") |
||
| 257 | +956 |
- #' split_cols_by("ARM") %>%
+ } |
| 258 | +1 |
- #' split_cols_by_multivar(c("USUBJID", "AESEQ", "BMRKR1"),
+ match_extra_args <- function(f, |
||
| 259 | +2 |
- #' varlabels = c("N", "E", "BMR1"),
+ .N_col, |
||
| 260 | +3 |
- #' split_fun = uneven_splfun+ .N_total, |
||
| 261 | +4 |
- #' ) %>%+ .all_col_exprs, |
||
| 262 | +5 |
- #' analyze_colvars(list(+ .all_col_counts, |
||
| 263 | +6 |
- #' USUBJID = function(x, ...) length(unique(x)),+ .var, |
||
| 264 | +7 |
- #' AESEQ = max,+ .ref_group = NULL, |
||
| 265 | +8 |
- #' BMRKR1 = mean+ .alt_df_row = NULL, |
||
| 266 | +9 |
- #' ))+ .alt_df = NULL, |
||
| 267 | +10 |
- #'+ .ref_full = NULL, |
||
| 268 | +11 |
- #' tbl <- build_table(lyt, subset(ex_adae, as.numeric(ARM) <= 2))+ .in_ref_col = NULL, |
||
| 269 | +12 |
- #' tbl+ .spl_context = NULL, |
||
| 270 | +13 |
- #'+ .N_row, |
||
| 271 | +14 |
- #' @export+ .df_row, |
||
| 272 | +15 |
- do_base_split <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
+ extras) {
+ |
+ ||
| 16 | ++ |
+ # This list is always present |
||
| 273 | -13x | +17 | +6106x |
- spl2 <- spl+ possargs <- c( |
| 274 | -13x | +18 | +6106x |
- split_fun(spl2) <- NULL+ list( |
| 275 | -13x | +19 | +6106x |
- do_split(spl2,+ .N_col = .N_col, |
| 276 | -13x | +20 | +6106x |
- df = df, vals = vals, labels = labels, trim = trim,+ .N_total = .N_total, |
| 277 | -13x | +21 | +6106x |
- spl_context = NULL+ .N_row = .N_row, |
| 278 | -+ | |||
| 22 | +6106x |
- )+ .df_row = .df_row, |
||
| 279 | -+ | |||
| 23 | +6106x |
- }+ .all_col_exprs = .all_col_exprs, |
||
| 280 | -+ | |||
| 24 | +6106x |
-
+ .all_col_counts = .all_col_counts |
||
| 281 | +25 |
- ### NB This is called at EACH level of recursive splitting+ ), |
||
| 282 | -+ | |||
| 26 | +6106x |
- do_split <- function(spl,+ extras |
||
| 283 | +27 |
- df,+ ) |
||
| 284 | +28 |
- vals = NULL,+ |
||
| 285 | +29 |
- labels = NULL,+ ## specialized arguments that must be named in formals, cannot go |
||
| 286 | +30 |
- trim = FALSE,+ ## anonymously into ... |
||
| 287 | -+ | |||
| 31 | +6106x |
- spl_context) {
+ if (!is.null(.var) && nzchar(.var)) {
|
||
| 288 | -+ | |||
| 32 | +4802x |
- ## this will error if, e.g., df doesn't have columns+ possargs <- c(possargs, list(.var = .var)) |
||
| 289 | +33 |
- ## required by spl, or generally any time the spl+ } |
||
| 290 | -+ | |||
| 34 | +6106x |
- ## can't be applied to df+ if (!is.null(.ref_group)) {
|
||
| 291 | -1082x | +35 | +1869x |
- check_validsplit(spl, df)+ possargs <- c(possargs, list(.ref_group = .ref_group)) |
| 292 | +36 |
- ## note the <- here!!!+ } |
||
| 293 | -1081x | +37 | +6106x |
- if (!is.null(splfun <- split_fun(spl))) {
+ if (!is.null(.alt_df_row)) {
|
| 294 | -+ | |||
| 38 | +105x |
- ## Currently the contract is that split_functions take df, vals, labels and+ possargs <- c(possargs, list(.alt_df_row = .alt_df_row)) |
||
| 295 | +39 |
- ## return list(values=., datasplit=., labels = .), optionally with+ }+ |
+ ||
| 40 | +6106x | +
+ if (!is.null(.alt_df)) {
+ |
+ ||
| 41 | +105x | +
+ possargs <- c(possargs, list(.alt_df = .alt_df)) |
||
| 296 | +42 |
- ## an additional extras element+ } |
||
| 297 | -353x | +43 | +6106x |
- if (func_takes(splfun, ".spl_context")) {
+ if (!is.null(.ref_full)) {
|
| 298 | -23x | +44 | +141x |
- ret <- tryCatch(+ possargs <- c(possargs, list(.ref_full = .ref_full)) |
| 299 | -23x | +|||
| 45 | +
- splfun(df, spl, vals, labels,+ } |
|||
| 300 | -23x | +46 | +6106x |
- trim = trim,+ if (!is.null(.in_ref_col)) {
|
| 301 | -23x | +47 | +141x |
- .spl_context = spl_context+ possargs <- c(possargs, list(.in_ref_col = .in_ref_col)) |
| 302 | +48 |
- ),+ }+ |
+ ||
| 49 | ++ | + + | +||
| 50 | ++ |
+ # Special case: .spl_context |
||
| 303 | -23x | +51 | +6106x |
- error = function(e) e+ if (!is.null(.spl_context) && !(".spl_context" %in% names(possargs))) {
|
| 304 | -23x | +52 | +6106x |
- ) ## rawvalues(spl_context ))+ possargs <- c(possargs, list(.spl_context = .spl_context)) |
| 305 | +53 |
- } else {
+ } else {
|
||
| 306 | -330x | +|||
| 54 | +! |
- ret <- tryCatch(splfun(df, spl, vals, labels, trim = trim),+ possargs$.spl_context <- NULL |
||
| 307 | -330x | +|||
| 55 | +
- error = function(e) e+ } |
|||
| 308 | +56 |
- )+ |
||
| 309 | +57 |
- }+ # Extra args handling |
||
| 310 | -353x | +58 | +6106x |
- if (is(ret, "error")) {
+ formargs <- formals(f) |
| 311 | -12x | +59 | +6106x |
- stop(+ formnms <- names(formargs) |
| 312 | -12x | +60 | +6106x |
- "Error applying custom split function: ", ret$message, "\n\tsplit: ",+ exnms <- names(extras) |
| 313 | -12x | +61 | +6106x |
- class(spl), " (", payloadmsg(spl), ")\n",
+ if (is.null(formargs)) {
|
| 314 | -12x | +62 | +190x |
- "\toccured at path: ",+ return(NULL) |
| 315 | -12x | +63 | +5916x |
- spl_context_to_disp_path(spl_context), "\n"+ } else if ("..." %in% names(formargs)) {
|
| 316 | -+ | |||
| 64 | +5208x |
- )+ formnms <- c(formnms, exnms[nzchar(exnms)]) |
||
| 317 | +65 |
- }+ } |
||
| 318 | -+ | |||
| 66 | +5916x |
- } else {
+ possargs[names(possargs) %in% formnms] |
||
| 319 | -728x | +|||
| 67 | +
- ret <- .apply_split_inner(df = df, spl = spl, vals = vals, labels = labels, trim = trim)+ } |
|||
| 320 | +68 |
- }+ |
||
| 321 | +69 |
-
+ #' @noRd |
||
| 322 | +70 |
- ## this adds .ref_full and .in_ref_col+ #' @return A `RowsVerticalSection` object representing the `k x 1` section of the |
||
| 323 | -1069x | +|||
| 71 | +
- if (is(spl, "VarLevWBaselineSplit")) {
+ #' table being generated, with `k` the number of rows the analysis function |
|||
| 324 | -17x | +|||
| 72 | +
- ret <- .add_ref_extras(spl, df, ret)+ #' generates. |
|||
| 325 | +73 |
- }+ gen_onerv <- function(csub, col, count, cextr, cpath, |
||
| 326 | +74 |
-
+ dfpart, func, totcount, splextra, |
||
| 327 | +75 |
- ## this:+ all_col_exprs, |
||
| 328 | +76 |
- ## - guarantees that ret$values contains SplitValue objects+ all_col_counts, |
||
| 329 | +77 |
- ## - removes the extras element since its redundant after the above+ takesdf = .takes_df(func), |
||
| 330 | +78 |
- ## - Ensures datasplit and values lists are named according to labels+ baselinedf, |
||
| 331 | +79 |
- ## - ensures labels are character not factor+ alt_dfpart, |
||
| 332 | -1069x | +|||
| 80 | +
- ret <- .fixupvals(ret)+ inclNAs, |
|||
| 333 | +81 |
- ## we didn't put this in .fixupvals because that get called withint he split functions+ col_parent_inds, |
||
| 334 | +82 |
- ## created by make_split_fun and its not clear this check should be happening then.+ spl_context) {
|
||
| 335 | -1069x | +83 | +6106x |
- if (has_force_pag(spl) && length(ret$datasplit) == 0) { ## this means it's page_by=TRUE
+ if (NROW(spl_context) > 0) {
|
| 336 | -3x | +84 | +6085x |
- stop(+ spl_context$cur_col_id <- paste(cpath[seq(2, length(cpath), 2)], collapse = ".") |
| 337 | -3x | +85 | +6085x |
- "Page-by split resulted in zero pages (no observed values of split variable?). \n\tsplit: ",+ spl_context$cur_col_subset <- col_parent_inds |
| 338 | -3x | +86 | +6085x |
- class(spl), " (", payloadmsg(spl), ")\n",
+ spl_context$cur_col_expr <- list(csub) |
| 339 | -3x | +87 | +6085x |
- "\toccured at path: ",+ spl_context$cur_col_n <- vapply(col_parent_inds, sum, 1L) |
| 340 | -3x | +88 | +6085x |
- spl_context_to_disp_path(spl_context), "\n"+ spl_context$cur_col_split <- list(cpath[seq(1, length(cpath), 2)]) |
| 341 | -+ | |||
| 89 | +6085x |
- )+ spl_context$cur_col_split_val <- list(cpath[seq(2, length(cpath), 2)]) |
||
| 342 | +90 |
} |
||
| 343 | -1066x | +|||
| 91 | +
- ret+ |
|||
| 344 | +92 |
- }+ # Making .alt_df from alt_dfpart (i.e. .alt_df_row) |
||
| 345 | -+ | |||
| 93 | +6106x |
-
+ if (NROW(alt_dfpart) > 0) {
|
||
| 346 | -+ | |||
| 94 | +105x |
- .apply_split_inner <- function(spl, df, vals = NULL, labels = NULL, trim = FALSE) {
+ alt_dfpart_fil <- alt_dfpart[eval(csub, envir = alt_dfpart), , drop = FALSE] |
||
| 347 | -1055x | +95 | +105x |
- if (is.null(vals)) {
+ if (!is.null(col) && col %in% names(alt_dfpart_fil) && !inclNAs) {
|
| 348 | -982x | +96 | +99x |
- vals <- .applysplit_rawvals(spl, df)+ alt_dfpart_fil <- alt_dfpart_fil[!is.na(alt_dfpart_fil[[col]]), ,+ |
+
| 97 | +99x | +
+ drop = FALSE |
||
| 349 | +98 |
- }+ ] |
||
| 350 | -1055x | +|||
| 99 | +
- extr <- .applysplit_extras(spl, df, vals)+ } |
|||
| 351 | +100 |
-
+ } else {
|
||
| 352 | -1055x | +101 | +6001x |
- if (is.null(vals)) {
+ alt_dfpart_fil <- alt_dfpart |
| 353 | -! | +|||
| 102 | +
- return(list(+ } |
|||
| 354 | -! | +|||
| 103 | +
- values = list(),+ |
|||
| 355 | -! | +|||
| 104 | +
- datasplit = list(),+ ## workaround for https://github.com/insightsengineering/rtables/issues/159 |
|||
| 356 | -! | +|||
| 105 | +6106x |
- labels = list(),+ if (NROW(dfpart) > 0) {
|
||
| 357 | -! | +|||
| 106 | +5254x |
- extras = list()+ inds <- eval(csub, envir = dfpart)+ |
+ ||
| 107 | +5254x | +
+ dat <- dfpart[inds, , drop = FALSE] |
||
| 358 | +108 |
- ))+ } else {
+ |
+ ||
| 109 | +852x | +
+ dat <- dfpart |
||
| 359 | +110 |
} |
||
| 360 | -+ | |||
| 111 | +6106x |
-
+ if (!is.null(col) && !inclNAs) {
|
||
| 361 | -1055x | +112 | +4776x |
- dpart <- .applysplit_datapart(spl, df, vals)+ dat <- dat[!is.na(dat[[col]]), , drop = FALSE] |
| 362 | +113 | ++ |
+ }+ |
+ |
| 114 | ||||
| 363 | -1055x | +115 | +6106x |
- if (is.null(labels)) {
+ fullrefcoldat <- cextr$.ref_full |
| 364 | -1052x | +116 | +6106x |
- labels <- .applysplit_partlabels(spl, df, vals, labels)+ if (!is.null(fullrefcoldat)) {
+ |
+
| 117 | +141x | +
+ cextr$.ref_full <- NULL |
||
| 365 | +118 |
- } else {
+ }+ |
+ ||
| 119 | +6106x | +
+ inrefcol <- cextr$.in_ref_col |
||
| 366 | -3x | +120 | +6106x |
- stopifnot(names(labels) == names(vals))+ if (!is.null(fullrefcoldat)) {
|
| 367 | -+ | |||
| 121 | +141x |
- }+ cextr$.in_ref_col <- NULL |
||
| 368 | +122 |
- ## get rid of columns that would not have any+ } |
||
| 369 | +123 |
- ## observations.+ |
||
| 370 | -+ | |||
| 124 | +6106x |
- ##+ exargs <- c(cextr, splextra) |
||
| 371 | +125 |
- ## But only if there were any rows to start with+ |
||
| 372 | +126 |
- ## if not we're in a manually constructed table+ ## behavior for x/df and ref-data (full and group) |
||
| 373 | +127 |
- ## column tree+ ## match |
||
| 374 | -1055x | -
- if (trim) {
- |
- ||
| 375 | -! | +128 | +6106x |
- hasdata <- sapply(dpart, function(x) nrow(x) > 0)+ if (!is.null(col) && !takesdf) {
|
| 376 | -! | +|||
| 129 | +3883x |
- if (nrow(df) > 0 && length(dpart) > sum(hasdata)) { # some empties
+ dat <- dat[[col]] |
||
| 377 | -! | +|||
| 130 | +3883x |
- dpart <- dpart[hasdata]+ fullrefcoldat <- fullrefcoldat[[col]] |
||
| 378 | -! | +|||
| 131 | +3883x |
- vals <- vals[hasdata]+ baselinedf <- baselinedf[[col]] |
||
| 379 | -! | +|||
| 132 | +
- extr <- extr[hasdata]+ } |
|||
| 380 | -! | +|||
| 133 | +6106x |
- labels <- labels[hasdata]+ args <- list(dat) |
||
| 381 | +134 |
- }+ |
||
| 382 | -+ | |||
| 135 | +6106x |
- }+ names(all_col_counts) <- names(all_col_exprs) |
||
| 383 | +136 | |||
| 384 | -1055x | +137 | +6106x |
- if (is.null(spl_child_order(spl)) || is(spl, "AllSplit")) {
+ exargs <- match_extra_args(func, |
| 385 | -163x | -
- vord <- seq_along(vals)- |
- ||
| 386 | -+ | 138 | +6106x |
- } else {
+ .N_col = count, |
| 387 | -892x | +139 | +6106x |
- vord <- match(+ .N_total = totcount, |
| 388 | -892x | +140 | +6106x |
- spl_child_order(spl),+ .all_col_exprs = all_col_exprs, |
| 389 | -892x | +141 | +6106x |
- vals+ .all_col_counts = all_col_counts, |
| 390 | -+ | |||
| 142 | +6106x |
- )+ .var = col, |
||
| 391 | -892x | +143 | +6106x |
- vord <- vord[!is.na(vord)]+ .ref_group = baselinedf, |
| 392 | -+ | |||
| 144 | +6106x |
- }+ .alt_df_row = alt_dfpart, |
||
| 393 | -+ | |||
| 145 | +6106x |
-
+ .alt_df = alt_dfpart_fil, |
||
| 394 | -+ | |||
| 146 | +6106x |
- ## FIXME: should be an S4 object, not a list+ .ref_full = fullrefcoldat, |
||
| 395 | -1055x | +147 | +6106x |
- ret <- list(+ .in_ref_col = inrefcol, |
| 396 | -1055x | +148 | +6106x |
- values = vals[vord],+ .N_row = NROW(dfpart), |
| 397 | -1055x | +149 | +6106x |
- datasplit = dpart[vord],+ .df_row = dfpart, |
| 398 | -1055x | +150 | +6106x |
- labels = labels[vord],+ .spl_context = spl_context, |
| 399 | -1055x | +151 | +6106x |
- extras = extr[vord]+ extras = c( |
| 400 | -+ | |||
| 152 | +6106x |
- )+ cextr, |
||
| 401 | -1055x | +153 | +6106x |
- ret+ splextra |
| 402 | +154 |
- }+ ) |
||
| 403 | +155 |
-
+ ) |
||
| 404 | +156 |
- .checkvarsok <- function(spl, df) {
+
|
||
| 405 | -1948x | +157 | +6106x |
- vars <- spl_payload(spl)+ args <- c(args, exargs) |
| 406 | +158 |
- ## could be multiple vars in the future?+ |
||
| 407 | -+ | |||
| 159 | +6106x |
- ## no reason not to make that work here now.+ val <- do.call(func, args) |
||
| 408 | -1948x | +160 | +6103x |
- if (!all(vars %in% names(df))) {
+ if (!is(val, "RowsVerticalSection")) {
|
| 409 | -2x | +161 | +3808x |
- stop(+ if (!is(val, "list")) {
|
| 410 | -2x | +162 | +3330x |
- " variable(s) [",+ val <- list(val) |
| 411 | -2x | +|||
| 163 | +
- paste(setdiff(vars, names(df)),+ } |
|||
| 412 | -2x | +164 | +3808x |
- collapse = ", "+ ret <- in_rows( |
| 413 | -+ | |||
| 165 | +3808x |
- ),+ .list = val, |
||
| 414 | -2x | +166 | +3808x |
- "] not present in data. (",
+ .labels = unlist(value_labels(val)), |
| 415 | -2x | +167 | +3808x |
- class(spl), ")"+ .names = names(val) |
| 416 | +168 |
) |
||
| 417 | +169 |
- }+ } else {
|
||
| 418 | -1946x | +170 | +2295x |
- invisible(NULL)+ ret <- val |
| 419 | +171 |
- }+ } |
||
| 420 | -+ | |||
| 172 | +6103x |
-
+ ret |
||
| 421 | +173 |
- ### Methods to verify a split appears to be valid, applicable+ } |
||
| 422 | +174 |
- ### to the ***current subset*** of the df.+ |
||
| 423 | +175 |
- ###+ strip_multivar_suffix <- function(x) {
|
||
| 424 | -+ | |||
| 176 | +228x |
- ### This is called at each level of recursive splitting so+ gsub("\\._\\[\\[[0-9]\\]\\]_\\.$", "", x)
|
||
| 425 | +177 |
- ### do NOT make it check, e.g., if the ref_group level of+ } |
||
| 426 | +178 |
- ### a factor is present in the data, because it may not be.+ |
||
| 427 | +179 |
-
+ ## Generate all values (one for each column) for one or more rows |
||
| 428 | +180 |
- setMethod(+ ## by calling func once per column (as defined by cinfo) |
||
| 429 | +181 |
- "check_validsplit", "VarLevelSplit",+ #' @noRd |
||
| 430 | +182 |
- function(spl, df) {
- |
- ||
| 431 | -843x | -
- .checkvarsok(spl, df)+ #' @return A list of `m` `RowsVerticalSection` objects, one for each (leaf) column in the table. |
||
| 432 | +183 |
- }+ gen_rowvalues <- function(dfpart, |
||
| 433 | +184 |
- )+ datcol, |
||
| 434 | +185 |
-
+ cinfo, |
||
| 435 | +186 |
- setMethod(+ func, |
||
| 436 | +187 |
- "check_validsplit", "MultiVarSplit",+ splextra, |
||
| 437 | +188 |
- function(spl, df) {
- |
- ||
| 438 | -56x | -
- .checkvarsok(spl, df)+ takesdf = NULL, |
||
| 439 | +189 |
- }+ baselines, |
||
| 440 | +190 |
- )+ alt_dfpart, |
||
| 441 | +191 |
-
+ inclNAs, |
||
| 442 | +192 |
- setMethod(+ spl_context = spl_context) {
|
||
| 443 | -+ | |||
| 193 | +1626x |
- "check_validsplit", "VAnalyzeSplit",+ colexprs <- col_exprs(cinfo) |
||
| 444 | -+ | |||
| 194 | +1626x |
- function(spl, df) {
+ colcounts <- col_counts(cinfo) |
||
| 445 | -1103x | +195 | +1626x |
- if (!is.na(spl_payload(spl))) {
+ colextras <- col_extra_args(cinfo, NULL) |
| 446 | -1049x | +196 | +1626x |
- .checkvarsok(spl, df)+ cpaths <- col_paths(cinfo) |
| 447 | +197 |
- } else {
+ ## XXX I don't think this is used anywhere???+ |
+ ||
| 198 | ++ |
+ ## splextra = c(splextra, list(.spl_context = spl_context)) |
||
| 448 | -54x | +199 | +1626x |
- TRUE+ totcount <- col_total(cinfo) |
| 449 | +200 |
- }+ |
||
| 450 | -+ | |||
| 201 | +1626x |
- }+ colleaves <- collect_leaves(cinfo@tree_layout) |
||
| 451 | +202 |
- )+ + |
+ ||
| 203 | +1626x | +
+ gotflist <- is.list(func) |
||
| 452 | +204 | |||
| 453 | +205 |
- setMethod(+ ## one set of named args to be applied to all columns |
||
| 454 | -+ | |||
| 206 | +1626x |
- "check_validsplit", "CompoundSplit",+ if (!is.null(names(splextra))) {
+ |
+ ||
| 207 | +25x | +
+ splextra <- list(splextra) |
||
| 455 | +208 |
- function(spl, df) {
+ } else {
|
||
| 456 | -! | +|||
| 209 | +1601x |
- all(sapply(spl_payload(spl), df))+ length(splextra) <- ncol(cinfo) |
||
| 457 | +210 |
} |
||
| 458 | +211 |
- )+ |
||
| 459 | -+ | |||
| 212 | +1626x |
-
+ if (!gotflist) {
|
||
| 460 | -+ | |||
| 213 | +1095x |
- ## default does nothing, add methods as they become+ func <- list(func) |
||
| 461 | -+ | |||
| 214 | +531x |
- ## required+ } else if (length(splextra) == 1) {
|
||
| 462 | -+ | |||
| 215 | +114x |
- setMethod(+ splextra <- rep(splextra, length.out = length(func)) |
||
| 463 | +216 |
- "check_validsplit", "Split",+ } |
||
| 464 | -131x | +|||
| 217 | +
- function(spl, df) invisible(NULL)+ ## if(length(func)) == 1 && names(spl) |
|||
| 465 | +218 |
- )+ ## splextra = list(splextra) |
||
| 466 | +219 | |||
| 467 | +220 |
- setMethod(+ ## we are in analyze_colvars, so we have to match |
||
| 468 | +221 |
- ".applysplit_rawvals", "VarLevelSplit",+ ## the exargs value by position for each column repeatedly |
||
| 469 | +222 |
- function(spl, df) {
+ ## across the higher level col splits. |
||
| 470 | -751x | +223 | +1626x |
- varvec <- df[[spl_payload(spl)]]+ if (!is.null(datcol) && is.na(datcol)) {
|
| 471 | -751x | +224 | +54x |
- if (is.factor(varvec)) {
+ datcol <- character(length(colleaves)) |
| 472 | -554x | +225 | +54x |
- levels(varvec)+ exargs <- vector("list", length(colleaves))
|
| 473 | -+ | |||
| 226 | +54x |
- } else {
+ for (i in seq_along(colleaves)) {
|
||
| 474 | -197x | +227 | +228x |
- unique(varvec)+ x <- colleaves[[i]] |
| 475 | +228 |
- }+ |
||
| 476 | -+ | |||
| 229 | +228x |
- }+ pos <- tree_pos(x) |
||
| 477 | -+ | |||
| 230 | +228x |
- )+ spls <- pos_splits(pos) |
||
| 478 | +231 |
-
+ ## values have the suffix but we are populating datacol |
||
| 479 | +232 |
- setMethod(+ ## so it has to match var numbers so strip the suffixes back off |
||
| 480 | -+ | |||
| 233 | +228x |
- ".applysplit_rawvals", "MultiVarSplit",+ splvals <- strip_multivar_suffix(rawvalues(pos)) |
||
| 481 | -+ | |||
| 234 | +228x |
- function(spl, df) {
+ n <- length(spls) |
||
| 482 | -+ | |||
| 235 | +228x |
- ## spl_payload(spl)+ datcol[i] <- if (is(spls[[n]], "MultiVarSplit")) {
|
||
| 483 | -48x | +236 | +228x |
- spl_varnames(spl)+ splvals[n] |
| 484 | +237 |
- }+ } else {
|
||
| 485 | -+ | |||
| 238 | +228x |
- )+ NA_character_ |
||
| 486 | +239 |
-
+ } |
||
| 487 | -+ | |||
| 240 | +228x |
- setMethod(+ argpos <- match(datcol[i], spl_payload(spls[[n]])) |
||
| 488 | +241 |
- ".applysplit_rawvals", "AllSplit",- |
- ||
| 489 | -109x | -
- function(spl, df) obj_name(spl)+ ## single bracket here because assigning NULL into a list removes |
||
| 490 | +242 |
- ) # "all obs")+ ## the position entirely |
||
| 491 | -+ | |||
| 243 | +228x |
-
+ exargs[i] <- if (argpos <= length(splextra)) {
|
||
| 492 | -+ | |||
| 244 | +228x |
- setMethod(+ splextra[argpos] |
||
| 493 | +245 |
- ".applysplit_rawvals", "ManualSplit",- |
- ||
| 494 | -52x | -
- function(spl, df) spl@levels+ } else {
|
||
| 495 | -+ | |||
| 246 | +! |
- )+ list(NULL) |
||
| 496 | +247 |
-
+ } |
||
| 497 | +248 |
- ## setMethod(".applysplit_rawvals", "NULLSplit",
+ } |
||
| 498 | +249 |
- ## function(spl, df) "")+ ## }) |
||
| 499 | -+ | |||
| 250 | +54x |
-
+ if (all(is.na(datcol))) {
|
||
| 500 | -+ | |||
| 251 | +! |
- setMethod(+ datcol <- list(NULL) |
||
| 501 | -+ | |||
| 252 | +54x |
- ".applysplit_rawvals", "VAnalyzeSplit",+ } else if (any(is.na(datcol))) {
|
||
| 502 | +253 | ! |
- function(spl, df) spl_payload(spl)+ stop("mix of var and non-var columns with NA analysis rowvara")
|
|
| 503 | +254 |
- )+ } |
||
| 504 | +255 |
-
+ } else {
|
||
| 505 | -+ | |||
| 256 | +1572x |
- ## formfactor here is gross we're gonna have ot do this+ exargs <- splextra |
||
| 506 | -+ | |||
| 257 | +1572x |
- ## all again in tthe data split part :-/+ if (is.null(datcol)) {
+ |
+ ||
| 258 | +340x | +
+ datcol <- list(NULL) |
||
| 507 | +259 |
- setMethod(+ }+ |
+ ||
| 260 | +1572x | +
+ datcol <- rep(datcol, length(colexprs)) |
||
| 508 | +261 |
- ".applysplit_rawvals", "VarStaticCutSplit",+ ## if(gotflist) |
||
| 509 | +262 |
- function(spl, df) {
+ ## length(exargs) <- length(func) ## func is a list |
||
| 510 | -22x | +263 | +1572x |
- spl_cutlabels(spl)+ exargs <- rep(exargs, length.out = length(colexprs)) |
| 511 | +264 |
} |
||
| 512 | -+ | |||
| 265 | +1626x |
- )+ allfuncs <- rep(func, length.out = length(colexprs)) |
||
| 513 | +266 | |||
| 514 | -+ | |||
| 267 | +1626x |
- setMethod(+ if (is.null(takesdf)) {
+ |
+ ||
| 268 | +1149x | +
+ takesdf <- .takes_df(allfuncs) |
||
| 515 | +269 |
- ".applysplit_datapart", "VarLevelSplit",+ } |
||
| 516 | +270 |
- function(spl, df, vals) {
+
|
||
| 517 | -824x | +271 | +1626x |
- if (!(spl_payload(spl) %in% names(df))) {
+ rawvals <- mapply(gen_onerv, |
| 518 | -! | +|||
| 272 | +1626x |
- stop(+ csub = colexprs, |
||
| 519 | -! | +|||
| 273 | +1626x |
- "Attempted to split on values of column (", spl_payload(spl),
+ col = datcol, |
||
| 520 | -! | +|||
| 274 | +1626x |
- ") not present in the data"+ count = colcounts, |
||
| 521 | -+ | |||
| 275 | +1626x |
- )+ cextr = colextras, |
||
| 522 | -+ | |||
| 276 | +1626x |
- }+ cpath = cpaths, |
||
| 523 | -824x | +277 | +1626x |
- ret <- lapply(seq_along(vals), function(i) {
+ baselinedf = baselines, |
| 524 | -2251x | +278 | +1626x |
- spl_col <- df[[spl_payload(spl)]]+ alt_dfpart = list(alt_dfpart), |
| 525 | -2251x | +279 | +1626x |
- df[!is.na(spl_col) & spl_col == vals[[i]], ]+ func = allfuncs, |
| 526 | -+ | |||
| 280 | +1626x |
- })+ takesdf = takesdf, |
||
| 527 | -824x | +281 | +1626x |
- names(ret) <- as.character(vals)+ col_parent_inds = spl_context[, names(colexprs), |
| 528 | -824x | +282 | +1626x |
- ret+ drop = FALSE |
| 529 | +283 |
- }+ ], |
||
| 530 | -+ | |||
| 284 | +1626x |
- )+ all_col_exprs = list(colexprs), |
||
| 531 | -+ | |||
| 285 | +1626x |
-
+ all_col_counts = list(colcounts), |
||
| 532 | -+ | |||
| 286 | +1626x |
- setMethod(+ splextra = exargs, |
||
| 533 | -+ | |||
| 287 | +1626x |
- ".applysplit_datapart", "MultiVarSplit",+ MoreArgs = list( |
||
| 534 | -+ | |||
| 288 | +1626x |
- function(spl, df, vals) {
+ dfpart = dfpart, |
||
| 535 | -48x | +289 | +1626x |
- allvnms <- spl_varnames(spl)+ totcount = totcount, |
| 536 | -48x | +290 | +1626x |
- if (!is.null(vals) && !identical(allvnms, vals)) {
+ inclNAs = inclNAs, |
| 537 | -! | +|||
| 291 | +1626x |
- incl <- match(vals, allvnms)+ spl_context = spl_context |
||
| 538 | +292 |
- } else {
+ ), |
||
| 539 | -48x | +293 | +1626x |
- incl <- seq_along(allvnms)+ SIMPLIFY = FALSE |
| 540 | +294 |
- }+ )+ |
+ ||
| 295 | ++ | + | ||
| 541 | -48x | +296 | +1623x |
- vars <- spl_payload(spl)[incl]+ names(rawvals) <- names(colexprs) |
| 542 | -+ | |||
| 297 | +1623x |
- ## don't remove nas+ rawvals |
||
| 543 | +298 |
- ## ret = lapply(vars, function(cl) {
+ } |
||
| 544 | +299 |
- ## df[!is.na(df[[cl]]),]+ |
||
| 545 | +300 |
- ## })- |
- ||
| 546 | -48x | -
- ret <- rep(list(df), length(vars))+ .strip_lst_rvals <- function(lst) {
|
||
| 547 | -48x | +|||
| 301 | +! |
- names(ret) <- vals+ lapply(lst, rawvalues) |
||
| 548 | -48x | +|||
| 302 | +
- ret+ } |
|||
| 549 | +303 |
- }+ |
||
| 550 | +304 |
- )+ #' @noRd |
||
| 551 | +305 |
-
+ #' @return A list of table rows, even when only one is generated. |
||
| 552 | +306 |
- setMethod(+ .make_tablerows <- function(dfpart, |
||
| 553 | +307 |
- ".applysplit_datapart", "AllSplit",+ alt_dfpart, |
||
| 554 | -109x | +|||
| 308 | +
- function(spl, df, vals) list(df)+ func, |
|||
| 555 | +309 |
- )+ cinfo, |
||
| 556 | +310 |
-
+ datcol = NULL, |
||
| 557 | +311 |
- ## ## not sure I need this+ lev = 1L, |
||
| 558 | +312 |
- setMethod(+ rvlab = NA_character_, |
||
| 559 | +313 |
- ".applysplit_datapart", "ManualSplit",+ format = NULL, |
||
| 560 | -52x | +|||
| 314 | +
- function(spl, df, vals) rep(list(df), times = length(vals))+ defrowlabs = NULL, |
|||
| 561 | +315 |
- )+ rowconstr = DataRow, |
||
| 562 | +316 |
-
+ splextra = list(), |
||
| 563 | +317 |
- ## setMethod(".applysplit_datapart", "NULLSplit",
+ takesdf = NULL, |
||
| 564 | +318 |
- ## function(spl, df, vals) list(df[FALSE,]))+ baselines = replicate( |
||
| 565 | +319 |
-
+ length(col_exprs(cinfo)), |
||
| 566 | +320 |
- setMethod(+ list(dfpart[0, ]) |
||
| 567 | +321 |
- ".applysplit_datapart", "VarStaticCutSplit",+ ), |
||
| 568 | +322 |
- function(spl, df, vals) {
+ inclNAs, |
||
| 569 | +323 |
- # lbs = spl_cutlabels(spl)+ spl_context = context_df_row(cinfo = cinfo)) {
|
||
| 570 | -14x | +324 | +1626x |
- var <- spl_payload(spl)+ if (is.null(datcol) && !is.na(rvlab)) {
|
| 571 | -14x | +|||
| 325 | +! |
- varvec <- df[[var]]+ stop("NULL datcol but non-na rowvar label")
|
||
| 572 | -14x | +|||
| 326 | +
- cts <- spl_cuts(spl)+ } |
|||
| 573 | -14x | +327 | +1626x |
- cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)+ if (!is.null(datcol) && !is.na(datcol)) {
|
| 574 | -14x | +328 | +1232x |
- split(df, cfct, drop = FALSE)+ if (!all(datcol %in% names(dfpart))) {
|
| 575 | -+ | |||
| 329 | +! |
- }+ stop( |
||
| 576 | -+ | |||
| 330 | +! |
- )+ "specified analysis variable (", datcol,
|
||
| 577 | -+ | |||
| 331 | +! |
-
+ ") not present in data" |
||
| 578 | +332 |
- setMethod(+ ) |
||
| 579 | +333 |
- ".applysplit_datapart", "CumulativeCutSplit",+ } |
||
| 580 | +334 |
- function(spl, df, vals) {
+
+ |
+ ||
| 335 | +1232x | +
+ rowvar <- datcol |
||
| 581 | +336 |
- # lbs = spl_cutlabels(spl)+ } else {
|
||
| 582 | -8x | +337 | +394x |
- var <- spl_payload(spl)+ rowvar <- NA_character_ |
| 583 | -8x | +|||
| 338 | +
- varvec <- df[[var]]+ } |
|||
| 584 | -8x | +|||
| 339 | +
- cts <- spl_cuts(spl)+ |
|||
| 585 | -8x | +340 | +1626x |
- cfct <- cut(varvec, cts, include.lowest = TRUE) # , labels = lbs)+ rawvals <- gen_rowvalues(dfpart, |
| 586 | -8x | +341 | +1626x |
- ret <- lapply(+ alt_dfpart = alt_dfpart, |
| 587 | -8x | +342 | +1626x |
- seq_len(length(levels(cfct))),+ datcol = datcol, |
| 588 | -8x | +343 | +1626x |
- function(i) df[as.integer(cfct) <= i, ]+ cinfo = cinfo, |
| 589 | -+ | |||
| 344 | +1626x |
- )+ func = func, |
||
| 590 | -8x | +345 | +1626x |
- names(ret) <- levels(cfct)+ splextra = splextra, |
| 591 | -8x | +346 | +1626x |
- ret+ takesdf = takesdf, |
| 592 | -+ | |||
| 347 | +1626x |
- }+ baselines = baselines, |
||
| 593 | -+ | |||
| 348 | +1626x |
- )+ inclNAs = inclNAs, |
||
| 594 | -+ | |||
| 349 | +1626x |
-
+ spl_context = spl_context |
||
| 595 | +350 |
- ## XXX TODO *CutSplit Methods+ ) |
||
| 596 | +351 | |||
| 597 | +352 |
- setClass("NullSentinel", contains = "NULL")
+ ## if(is.null(rvtypes)) |
||
| 598 | +353 |
- nullsentinel <- new("NullSentinel")
+ ## rvtypes = rep(NA_character_, length(rawvals)) |
||
| 599 | -! | +|||
| 354 | +1623x |
- noarg <- function() nullsentinel+ lens <- vapply(rawvals, length, NA_integer_) |
||
| 600 | -+ | |||
| 355 | +1623x |
-
+ unqlens <- unique(lens) |
||
| 601 | +356 |
- ## Extras generation methods+ ## length 0 returns are ok to not match cause they are |
||
| 602 | +357 |
- setMethod(+ ## just empty space we can fill in as needed. |
||
| 603 | -+ | |||
| 358 | +1623x |
- ".applysplit_extras", "Split",+ if (length(unqlens[unqlens > 0]) != 1L) { ## length(unqlens) != 1 &&
|
||
| 604 | +359 |
- function(spl, df, vals) {
+ ## (0 %in% unqlens && length(unqlens) != 2)) {
|
||
| 605 | -1003x | +360 | +1x |
- splex <- split_exargs(spl)+ stop( |
| 606 | -1003x | +361 | +1x |
- nvals <- length(vals)+ "Number of rows generated by analysis function do not match ", |
| 607 | -1003x | +362 | +1x |
- lapply(seq_len(nvals), function(vpos) {
+ "across all columns. ", |
| 608 | -2552x | +363 | +1x |
- one_ex <- lapply(splex, function(arg) {
+ if (!is.na(datcol) && is.character(dfpart[[datcol]])) {
|
| 609 | +364 | ! |
- if (length(arg) >= vpos) {
+ paste( |
|
| 610 | +365 | ! |
- arg[[vpos]]- |
- |
| 611 | -- |
- } else {
+ "\nPerhaps convert analysis variable", datcol, |
||
| 612 | +366 | ! |
- noarg()+ "to a factor?" |
|
| 613 | +367 |
- }+ ) |
||
| 614 | +368 |
- })+ } |
||
| 615 | -2552x | +|||
| 369 | +
- names(one_ex) <- names(splex)+ ) |
|||
| 616 | -2552x | +|||
| 370 | +
- one_ex <- one_ex[!sapply(one_ex, is, "NullSentinel")]+ } |
|||
| 617 | -2552x | +371 | +1622x |
- one_ex+ maxind <- match(max(unqlens), lens) |
| 618 | +372 |
- })+ |
||
| 619 | +373 |
- }+ ## look if we got labels, if not apply the |
||
| 620 | +374 |
- )+ ## default row labels |
||
| 621 | +375 |
-
+ ## this is guaranteed to be a RowsVerticalSection object. |
||
| 622 | -+ | |||
| 376 | +1622x |
- setMethod(+ rv1col <- rawvals[[maxind]] |
||
| 623 | +377 |
- ".applysplit_ref_vals", "Split",- |
- ||
| 624 | -! | -
- function(spl, df, vals) rep(list(NULL), length(vals))+ ## nocov start |
||
| 625 | +378 |
- )+ if (!is(rv1col, "RowsVerticalSection")) {
|
||
| 626 | +379 |
-
+ stop( |
||
| 627 | +380 |
- setMethod(+ "gen_rowvalues appears to have generated something that was not ", |
||
| 628 | +381 |
- ".applysplit_ref_vals", "VarLevWBaselineSplit",+ "a RowsVerticalSection object. Please contact the maintainer." |
||
| 629 | +382 |
- function(spl, df, vals) {
+ ) |
||
| 630 | -17x | +|||
| 383 | +
- bl_level <- spl@ref_group_value # XXX XXX+ } |
|||
| 631 | -17x | +|||
| 384 | +
- vnames <- value_names(vals)+ # nocov end |
|||
| 632 | -17x | +|||
| 385 | +
- ret <- lapply(vnames, function(vl) {
+
|
|||
| 633 | -46x | +386 | +1622x |
- list(.in_ref_col = vl == bl_level)+ labels <- value_labels(rv1col) |
| 634 | +387 |
- })+ |
||
| 635 | -17x | +388 | +1622x |
- names(ret) <- vnames+ ncrows <- max(unqlens) |
| 636 | -17x | +389 | +1622x |
- ret+ if (ncrows == 0) {
|
| 637 | -+ | |||
| 390 | +! |
- }+ return(list()) |
||
| 638 | +391 |
- )+ } |
||
| 639 | -+ | |||
| 392 | +1622x |
-
+ stopifnot(ncrows > 0) |
||
| 640 | +393 |
- ## XXX TODO FIXME+ |
||
| 641 | -+ | |||
| 394 | +1622x |
- setMethod(+ if (is.null(labels)) {
|
||
| 642 | -+ | |||
| 395 | +207x |
- ".applysplit_partlabels", "Split",+ if (length(rawvals[[maxind]]) == length(defrowlabs)) {
|
||
| 643 | -131x | +396 | +199x |
- function(spl, df, vals, labels) as.character(vals)+ labels <- defrowlabs |
| 644 | +397 |
- )+ } else {
|
||
| 645 | -+ | |||
| 398 | +8x |
-
+ labels <- rep("", ncrows)
|
||
| 646 | +399 |
- setMethod(+ } |
||
| 647 | +400 |
- ".applysplit_partlabels", "VarLevelSplit",+ } |
||
| 648 | +401 |
- function(spl, df, vals, labels) {
+
|
||
| 649 | -821x | +402 | +1622x |
- varname <- spl_payload(spl)+ rfootnotes <- rep(list(list(), length(rv1col))) |
| 650 | -821x | +403 | +1622x |
- vlabelname <- spl_labelvar(spl)+ nms <- value_names(rv1col) |
| 651 | -821x | +404 | +1622x |
- varvec <- df[[varname]]+ rfootnotes <- row_footnotes(rv1col) |
| 652 | +405 |
- ## we used to check if vals was NULL but+ |
||
| 653 | -+ | |||
| 406 | +1622x |
- ## this is called after a short-circuit return in .apply_split_inner in that+ imods <- indent_mod(rv1col) ## rv1col@indent_mods |
||
| 654 | -+ | |||
| 407 | +1622x |
- ## case+ unwrapped_vals <- lapply(rawvals, as, Class = "list", strict = TRUE) |
||
| 655 | +408 |
- ## so vals is guaranteed to be non-null here+ |
||
| 656 | -821x | +409 | +1622x |
- if (is.null(labels)) {
+ formatvec <- NULL |
| 657 | -821x | +410 | +1622x |
- if (varname == vlabelname) {
+ if (!is.null(format)) {
|
| 658 | -691x | -
- labels <- vals- |
- ||
| 659 | -+ | 411 | +200x |
- } else {
+ if (is.function(format)) {
|
| 660 | -130x | +412 | +1x |
- labfact <- is.factor(df[[vlabelname]])+ format <- list(format) |
| 661 | -130x | +|||
| 413 | +
- lablevs <- if (labfact) levels(df[[vlabelname]]) else NULL+ } |
|||
| 662 | -130x | +414 | +200x |
- labels <- sapply(vals, function(v) {
+ formatvec <- rep(format, length.out = ncrows) |
| 663 | -262x | +|||
| 415 | +
- vlabel <- unique(df[varvec == v, vlabelname, drop = TRUE])+ } |
|||
| 664 | +416 |
- ## TODO remove this once 1-to-1 value-label map is enforced+ |
||
| 665 | -+ | |||
| 417 | +1622x |
- ## elsewhere.+ trows <- lapply(1:ncrows, function(i) {
|
||
| 666 | -262x | +418 | +2656x |
- stopifnot(length(vlabel) < 2)+ rowvals <- lapply(unwrapped_vals, function(colvals) {
|
| 667 | -262x | +419 | +9865x |
- if (length(vlabel) == 0) {
+ colvals[[i]] |
| 668 | -! | +|||
| 420 | +
- vlabel <- ""+ }) |
|||
| 669 | -262x | +421 | +2656x |
- } else if (labfact) {
+ imod <- unique(vapply(rowvals, indent_mod, 0L)) |
| 670 | -6x | +422 | +2656x |
- vlabel <- lablevs[vlabel]+ if (length(imod) != 1) {
|
| 671 | -+ | |||
| 423 | +! |
- }+ stop( |
||
| 672 | -262x | +|||
| 424 | +! |
- vlabel+ "Different cells in the same row appear to have been given ", |
||
| 673 | -+ | |||
| 425 | +! |
- })+ "different indent_mod values" |
||
| 674 | +426 |
- }+ ) |
||
| 675 | +427 |
} |
||
| 676 | -821x | +428 | +2656x |
- names(labels) <- as.character(vals)+ rowconstr( |
| 677 | -821x | +429 | +2656x |
- labels+ vals = rowvals, |
| 678 | -+ | |||
| 430 | +2656x |
- }+ cinfo = cinfo, |
||
| 679 | -+ | |||
| 431 | +2656x |
- )+ lev = lev, |
||
| 680 | -+ | |||
| 432 | +2656x |
-
+ label = labels[i], |
||
| 681 | -+ | |||
| 433 | +2656x |
- setMethod(+ name = nms[i], ## labels[i], ## XXX this is probably wrong?! |
||
| 682 | -+ | |||
| 434 | +2656x |
- ".applysplit_partlabels", "MultiVarSplit",+ var = rowvar, |
||
| 683 | -48x | +435 | +2656x |
- function(spl, df, vals, labels) value_labels(spl)+ format = formatvec[[i]], |
| 684 | -+ | |||
| 436 | +2656x |
- )+ indent_mod = imods[[i]] %||% 0L, |
||
| 685 | -+ | |||
| 437 | +2656x |
-
+ footnotes = rfootnotes[[i]] ## one bracket so list |
||
| 686 | +438 |
- make_splvalue_vec <- function(vals, extrs = list(list()), labels = vals,+ ) |
||
| 687 | +439 |
- subset_exprs) {
+ }) |
||
| 688 | -2803x | +440 | +1622x |
- if (length(vals) == 0) {
+ trows |
| 689 | -377x | +|||
| 441 | +
- return(vals)+ } |
|||
| 690 | +442 |
- }+ |
||
| 691 | +443 |
-
+ .make_caller <- function(parent_cfun, clabelstr = "") {
|
||
| 692 | -2426x | +444 | +488x |
- if (is(extrs, "AsIs")) {
+ formalnms <- names(formals(parent_cfun)) |
| 693 | -! | +|||
| 445 | +
- extrs <- unclass(extrs)+ ## note the <- here |
|||
| 694 | -+ | |||
| 446 | +488x |
- }+ if (!is.na(dotspos <- match("...", formalnms))) {
|
||
| 695 | -+ | |||
| 447 | +1x |
- ## if(are(vals, "SplitValue")) {
+ toremove <- dotspos |
||
| 696 | +448 |
-
+ } else {
|
||
| 697 | -+ | |||
| 449 | +487x |
- ## return(vals)+ toremove <- NULL |
||
| 698 | +450 |
- ## }+ } |
||
| 699 | +451 | |||
| 700 | -2426x | -
- mapply(SplitValue,- |
- ||
| 701 | -2426x | +452 | +488x |
- val = vals, extr = extrs,+ labelstrpos <- match("labelstr", names(formals(parent_cfun)))
|
| 702 | -2426x | +453 | +488x |
- label = labels,+ if (is.na(labelstrpos)) {
|
| 703 | -2426x | +|||
| 454 | +! |
- sub_expr = subset_exprs,+ stop( |
||
| 704 | -2426x | +|||
| 455 | +! |
- SIMPLIFY = FALSE+ "content function does not appear to accept the labelstr", |
||
| 705 | -+ | |||
| 456 | +! |
- )+ "arguent" |
||
| 706 | +457 |
- }+ ) |
| 1 | +458 |
- #' Compare two rtables+ } |
||
| 2 | -+ | |||
| 459 | +488x |
- #'+ toremove <- c(toremove, labelstrpos) |
||
| 3 | -+ | |||
| 460 | +488x |
- #' Prints a matrix where `.` means cell matches, `X` means cell does+ formalnms <- formalnms[-1 * toremove] |
||
| 4 | +461 |
- #' not match, `+` cell (row) is missing, and `-` cell (row)+ |
||
| 5 | -+ | |||
| 462 | +488x |
- #' should not be there. If `structure` is set to `TRUE`, `C` indicates+ caller <- eval(parser_helper(text = paste( |
||
| 6 | -+ | |||
| 463 | +488x |
- #' column-structure mismatch, `R` indicates row-structure mismatch, and+ "function() { parent_cfun(",
|
||
| 7 | -+ | |||
| 464 | +488x |
- #' `S` indicates mismatch in both row and column structure.+ paste(formalnms, "=", |
||
| 8 | -+ | |||
| 465 | +488x |
- #'+ formalnms, |
||
| 9 | -+ | |||
| 466 | +488x |
- #' @param object (`VTableTree`)\cr `rtable` to test.+ collapse = ", " |
||
| 10 | +467 |
- #' @param expected (`VTableTree`)\cr expected `rtable`.+ ), |
||
| 11 | -+ | |||
| 468 | +488x |
- #' @param tol (`numeric(1)`)\cr tolerance.+ ", labelstr = clabelstr, ...)}" |
||
| 12 | +469 |
- #' @param comp.attr (`flag`)\cr whether to compare cell formats. Other attributes are+ ))) |
||
| 13 | -+ | |||
| 470 | +488x |
- #' silently ignored.+ formals(caller) <- c( |
||
| 14 | -+ | |||
| 471 | +488x |
- #' @param structure (`flag`)\cr whether structures (in the form of column and row+ formals(parent_cfun)[-labelstrpos], |
||
| 15 | -+ | |||
| 472 | +488x |
- #' paths to cells) should be compared. Currently defaults to `FALSE`, but this is+ alist("..." = )
|
||
| 16 | -+ | |||
| 473 | +488x |
- #' subject to change in future versions.+ ) # nolint |
||
| 17 | -+ | |||
| 474 | +488x |
- #'+ caller |
||
| 18 | +475 |
- #' @note In its current form, `compare_rtables` does not take structure into+ } |
||
| 19 | +476 |
- #' account, only row and cell position.+ |
||
| 20 | +477 |
- #'+ # Makes content table xxx renaming |
||
| 21 | +478 |
- #' @return A matrix of class `rtables_diff` representing the differences+ .make_ctab <- function(df, |
||
| 22 | +479 |
- #' between `object` and `expected` as described above.+ lvl, ## treepos, |
||
| 23 | +480 |
- #'+ name, |
||
| 24 | +481 |
- #' @examples+ label, |
||
| 25 | +482 |
- #' t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2))
+ cinfo, |
||
| 26 | +483 |
- #' t2 <- rtable(header = c("A", "B", "C"), format = "xx", rrow("row 1", 1, 2, 3))
+ parent_cfun = NULL, |
||
| 27 | +484 |
- #'+ format = NULL, |
||
| 28 | +485 |
- #' compare_rtables(object = t1, expected = t2)+ na_str = NA_character_, |
||
| 29 | +486 |
- #'+ indent_mod = 0L, |
||
| 30 | +487 |
- #' if (interactive()) {
+ cvar = NULL, |
||
| 31 | +488 |
- #' Viewer(t1, t2)+ inclNAs, |
||
| 32 | +489 |
- #' }+ alt_df, |
||
| 33 | +490 |
- #'+ extra_args, |
||
| 34 | +491 |
- #' expected <- rtable(+ spl_context = context_df_row(cinfo = cinfo)) {
|
||
| 35 | -+ | |||
| 492 | +1876x |
- #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ if (length(cvar) == 0 || is.na(cvar) || identical(nchar(cvar), 0L)) {
|
||
| 36 | -+ | |||
| 493 | +1707x |
- #' format = "xx",+ cvar <- NULL |
||
| 37 | +494 |
- #' rrow("row 1", 10, 15),
+ } |
||
| 38 | -+ | |||
| 495 | +1876x |
- #' rrow(),+ if (!is.null(parent_cfun)) {
|
||
| 39 | +496 |
- #' rrow("section title"),
+ ## cfunc <- .make_caller(parent_cfun, label) |
||
| 40 | -+ | |||
| 497 | +477x |
- #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
+ cfunc <- lapply(parent_cfun, .make_caller, clabelstr = label) |
||
| 41 | -+ | |||
| 498 | +477x |
- #' )+ contkids <- tryCatch( |
||
| 42 | -+ | |||
| 499 | +477x |
- #'+ .make_tablerows(df, |
||
| 43 | -+ | |||
| 500 | +477x |
- #' expected+ lev = lvl, |
||
| 44 | -+ | |||
| 501 | +477x |
- #'+ func = cfunc, |
||
| 45 | -+ | |||
| 502 | +477x |
- #' object <- rtable(+ cinfo = cinfo, |
||
| 46 | -+ | |||
| 503 | +477x |
- #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ rowconstr = ContentRow, |
||
| 47 | -+ | |||
| 504 | +477x |
- #' format = "xx",+ datcol = cvar, |
||
| 48 | -+ | |||
| 505 | +477x |
- #' rrow("row 1", 10, 15),
+ takesdf = rep(.takes_df(cfunc), |
||
| 49 | -+ | |||
| 506 | +477x |
- #' rrow("section title"),
+ length.out = ncol(cinfo) |
||
| 50 | +507 |
- #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
+ ), |
||
| 51 | -+ | |||
| 508 | +477x |
- #' )+ inclNAs = FALSE, |
||
| 52 | -+ | |||
| 509 | +477x |
- #'+ alt_dfpart = alt_df, |
||
| 53 | -+ | |||
| 510 | +477x |
- #' compare_rtables(object, expected, comp.attr = FALSE)+ splextra = extra_args, |
||
| 54 | -+ | |||
| 511 | +477x |
- #'+ spl_context = spl_context |
||
| 55 | +512 |
- #' object <- rtable(+ ), |
||
| 56 | -+ | |||
| 513 | +477x |
- #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ error = function(e) e |
||
| 57 | +514 |
- #' format = "xx",+ ) |
||
| 58 | -+ | |||
| 515 | +477x |
- #' rrow("row 1", 10, 15),
+ if (is(contkids, "error")) {
|
||
| 59 | -+ | |||
| 516 | +1x |
- #' rrow(),+ stop("Error in content (summary) function: ", contkids$message,
|
||
| 60 | -+ | |||
| 517 | +1x |
- #' rrow("section title")
+ "\n\toccured at path: ", |
||
| 61 | -+ | |||
| 518 | +1x |
- #' )+ spl_context_to_disp_path(spl_context), |
||
| 62 | -+ | |||
| 519 | +1x |
- #'+ call. = FALSE |
||
| 63 | +520 |
- #' compare_rtables(object, expected)+ ) |
||
| 64 | +521 |
- #'+ } |
||
| 65 | +522 |
- #' object <- rtable(+ } else {
|
||
| 66 | -+ | |||
| 523 | +1399x |
- #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ contkids <- list() |
||
| 67 | +524 |
- #' format = "xx",+ } |
||
| 68 | -+ | |||
| 525 | +1875x |
- #' rrow("row 1", 14, 15.03),
+ ctab <- ElementaryTable( |
||
| 69 | -+ | |||
| 526 | +1875x |
- #' rrow(),+ kids = contkids, |
||
| 70 | -+ | |||
| 527 | +1875x |
- #' rrow("section title"),
+ name = paste0(name, "@content"), |
||
| 71 | -+ | |||
| 528 | +1875x |
- #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
+ lev = lvl, |
||
| 72 | -+ | |||
| 529 | +1875x |
- #' )+ labelrow = LabelRow(), |
||
| 73 | -+ | |||
| 530 | +1875x |
- #'+ cinfo = cinfo, |
||
| 74 | -+ | |||
| 531 | +1875x |
- #' compare_rtables(object, expected)+ iscontent = TRUE, |
||
| 75 | -+ | |||
| 532 | +1875x |
- #'+ format = format, |
||
| 76 | -+ | |||
| 533 | +1875x |
- #' object <- rtable(+ indent_mod = indent_mod, |
||
| 77 | -+ | |||
| 534 | +1875x |
- #' header = c("ARM A\nN=100", "ARM B\nN=200"),
+ na_str = na_str |
||
| 78 | +535 |
- #' format = "xx",+ ) |
||
| 79 | -+ | |||
| 536 | +1875x |
- #' rrow("row 1", 10, 15),
+ ctab |
||
| 80 | +537 |
- #' rrow(),+ } |
||
| 81 | +538 |
- #' rrow("section title"),
+
|
||
| 82 | +539 |
- #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.x, xx.x)"))
+ .make_analyzed_tab <- function(df, |
||
| 83 | +540 |
- #' )+ alt_df, |
||
| 84 | +541 |
- #'+ spl, |
||
| 85 | +542 |
- #' compare_rtables(object, expected)+ cinfo, |
||
| 86 | +543 |
- #'+ partlabel = "", |
||
| 87 | +544 |
- #' @export+ dolab = TRUE, |
||
| 88 | +545 |
- compare_rtables <- function(object, expected, tol = 0.1, comp.attr = TRUE,+ lvl, |
||
| 89 | +546 |
- structure = FALSE) {
+ baselines, |
||
| 90 | +547 |
- # if (identical(object, expected)) return(invisible(TRUE))+ spl_context) {
|
||
| 91 | -+ | |||
| 548 | +1150x |
-
+ stopifnot(is(spl, "VAnalyzeSplit")) |
||
| 92 | -12x | +549 | +1150x |
- if (!is(object, "VTableTree")) {
+ check_validsplit(spl, df) |
| 93 | -! | +|||
| 550 | +1149x |
- stop(+ defrlabel <- spl@default_rowlabel |
||
| 94 | -! | +|||
| 551 | +1149x |
- "argument object is expected to be of class TableTree or ",+ if (nchar(defrlabel) == 0 && !missing(partlabel) && nchar(partlabel) > 0) {
|
||
| 95 | +552 | ! |
- "ElementaryTable"+ defrlabel <- partlabel |
|
| 96 | +553 |
- )+ } |
||
| 97 | -+ | |||
| 554 | +1149x |
- }+ kids <- tryCatch( |
||
| 98 | -12x | +555 | +1149x |
- if (!is(expected, "VTableTree")) {
+ .make_tablerows(df, |
| 99 | -! | +|||
| 556 | +1149x |
- stop(+ func = analysis_fun(spl), |
||
| 100 | -! | +|||
| 557 | +1149x |
- "argument expected is expected to be of class TableTree or ",+ defrowlabs = defrlabel, # XXX |
||
| 101 | -! | +|||
| 558 | +1149x |
- "ElementaryTable"+ cinfo = cinfo, |
||
| 102 | -+ | |||
| 559 | +1149x |
- )+ datcol = spl_payload(spl), |
||
| 103 | -+ | |||
| 560 | +1149x |
- }+ lev = lvl + 1L, |
||
| 104 | -12x | +561 | +1149x |
- dim_out <- apply(rbind(dim(object), dim(expected)), 2, max)+ format = obj_format(spl), |
| 105 | -+ | |||
| 562 | +1149x |
-
+ splextra = split_exargs(spl), |
||
| 106 | -12x | +563 | +1149x |
- X <- matrix(rep(".", dim_out[1] * dim_out[2]), ncol = dim_out[2])
+ baselines = baselines, |
| 107 | -12x | +564 | +1149x |
- row.names(X) <- as.character(1:dim_out[1])+ alt_dfpart = alt_df, |
| 108 | -12x | +565 | +1149x |
- colnames(X) <- as.character(1:dim_out[2])+ inclNAs = avar_inclNAs(spl),+ |
+
| 566 | +1149x | +
+ spl_context = spl_context |
||
| 109 | +567 |
-
+ ), |
||
| 110 | -12x | +568 | +1149x |
- if (!identical(names(object), names(expected))) {
+ error = function(e) e |
| 111 | -7x | +|||
| 569 | +
- attr(X, "info") <- "column names are not the same"+ ) |
|||
| 112 | +570 |
- }+ |
||
| 113 | +571 |
-
+ # Adding section_div for DataRows (analyze leaves) |
||
| 114 | -12x | +572 | +1149x |
- if (!comp.attr) {
+ kids <- .set_kids_section_div(kids, spl_section_div(spl), "DataRow") |
| 115 | -! | +|||
| 573 | +
- attr(X, "info") <- c(+ |
|||
| 116 | -! | +|||
| 574 | +1149x |
- attr(X, "info"),+ if (is(kids, "error")) {
|
||
| 117 | -! | +|||
| 575 | +3x |
- "cell attributes have not been compared"+ stop("Error applying analysis function (var - ",
|
||
| 118 | -+ | |||
| 576 | +3x |
- )+ spl_payload(spl) %||% "colvars", "): ", kids$message, |
||
| 119 | -+ | |||
| 577 | +3x |
- }+ "\n\toccured at (row) path: ", |
||
| 120 | -12x | +578 | +3x |
- if (!identical(row.names(object), row.names(expected))) {
+ spl_context_to_disp_path(spl_context), |
| 121 | -2x | +579 | +3x |
- attr(X, "info") <- c(attr(X, "info"), "row labels are not the same")+ call. = FALSE |
| 122 | +580 |
- }+ ) |
||
| 123 | +581 |
-
+ } |
||
| 124 | -12x | +582 | +1146x |
- nro <- nrow(object)+ lab <- obj_label(spl) |
| 125 | -12x | +583 | +1146x |
- nre <- nrow(expected)+ ret <- TableTree( |
| 126 | -12x | +584 | +1146x |
- nco <- ncol(object)+ kids = kids, |
| 127 | -12x | +585 | +1146x |
- nce <- ncol(expected)+ name = obj_name(spl), |
| 128 | -+ | |||
| 586 | +1146x |
-
+ label = lab, |
||
| 129 | -12x | +587 | +1146x |
- if (nco < nce) {
+ lev = lvl, |
| 130 | -2x | +588 | +1146x |
- X[, seq(nco + 1, nce)] <- "-"+ cinfo = cinfo, |
| 131 | -10x | +589 | +1146x |
- } else if (nce < nco) {
+ format = obj_format(spl), |
| 132 | -3x | +590 | +1146x |
- X[, seq(nce + 1, nco)] <- "+"+ na_str = obj_na_str(spl), |
| 133 | -+ | |||
| 591 | +1146x |
- }+ indent_mod = indent_mod(spl) |
||
| 134 | -12x | +|||
| 592 | +
- if (nro < nre) {
+ ) |
|||
| 135 | -1x | +|||
| 593 | +
- X[seq(nro + 1, nre), ] <- "-"+ |
|||
| 136 | -11x | +594 | +1146x |
- } else if (nre < nro) {
+ labelrow_visible(ret) <- dolab |
| 137 | -! | +|||
| 595 | +1146x |
- X[seq(nre + 1, nro), ] <- "+"+ ret |
||
| 138 | +596 |
- }+ } |
||
| 139 | +597 | |||
| 140 | -12x | +|||
| 598 | +
- orig_object <- object # nolint+ #' @param ... all arguments to `recurse_applysplit`, methods may only use some of them. |
|||
| 141 | -12x | +|||
| 599 | +
- orig_expected <- expected # nolint+ #' @return A `list` of children to place at this level. |
|||
| 142 | -12x | +|||
| 600 | +
- if (nro != nre || nco != nce) {
+ #' |
|||
| 143 | -5x | +|||
| 601 | +
- object <- object[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]+ #' @noRd |
|||
| 144 | -5x | +|||
| 602 | +
- expected <- expected[1:min(nro, nre), 1:min(nco, nce), drop = FALSE]+ setGeneric(".make_split_kids", function(spl, have_controws, make_lrow, ...) {
|
|||
| 145 | -5x | +603 | +1707x |
- inner <- compare_rtables(object, expected, tol = tol, comp.attr = comp.attr, structure = structure)+ standardGeneric(".make_split_kids")
|
| 146 | -5x | +|||
| 604 | +
- X[seq_len(nrow(object)), seq_len(ncol(object))] <- inner+ }) |
|||
| 147 | -5x | +|||
| 605 | +
- class(X) <- c("rtables_diff", class(X))
+
|
|||
| 148 | -5x | +|||
| 606 | +
- return(X)+ ## single AnalyzeSplit |
|||
| 149 | +607 |
- }+ setMethod( |
||
| 150 | +608 |
-
+ ".make_split_kids", "VAnalyzeSplit", |
||
| 151 | +609 |
- ## from here dimensions match!+ function(spl, |
||
| 152 | +610 |
-
+ have_controws, ## unused here |
||
| 153 | -7x | +|||
| 611 | +
- orows <- cell_values(object, omit_labrows = FALSE)+ make_lrow, ## unused here |
|||
| 154 | -7x | +|||
| 612 | +
- erows <- cell_values(expected, omit_labrows = FALSE)+ ..., |
|||
| 155 | -7x | +|||
| 613 | +
- if (nrow(object) == 1) {
+ df, |
|||
| 156 | -! | +|||
| 614 | +
- orows <- list(orows)+ alt_df, |
|||
| 157 | -! | +|||
| 615 | +
- erows <- list(erows)+ lvl, |
|||
| 158 | +616 |
- }+ name, |
||
| 159 | -7x | +|||
| 617 | +
- res <- mapply(compare_rrows,+ cinfo, |
|||
| 160 | -7x | +|||
| 618 | +
- row1 = orows, row2 = erows, tol = tol, ncol = ncol(object),+ baselines, |
|||
| 161 | -7x | +|||
| 619 | +
- USE.NAMES = FALSE, SIMPLIFY = FALSE+ spl_context, |
|||
| 162 | +620 |
- )+ nsibs = 0) {
|
||
| 163 | -7x | +621 | +1150x |
- X <- do.call(rbind, res)+ spvis <- labelrow_visible(spl) |
| 164 | -7x | +622 | +1150x |
- rpo <- row_paths(object)+ if (is.na(spvis)) {
|
| 165 | -7x | +623 | +228x |
- rpe <- row_paths(expected)+ spvis <- nsibs > 0 |
| 166 | +624 |
-
+ } |
||
| 167 | -7x | +|||
| 625 | +
- if (comp.attr) {
+
|
|||
| 168 | -7x | +626 | +1150x |
- ofmts <- value_formats(object)+ ret <- .make_analyzed_tab( |
| 169 | -7x | +627 | +1150x |
- efmts <- value_formats(expected)+ df = df, |
| 170 | -+ | |||
| 628 | +1150x |
- ## dim(ofmts) <- NULL+ alt_df, |
||
| 171 | -+ | |||
| 629 | +1150x |
- ## dim(efmts) <- NULL+ spl = spl, |
||
| 172 | -+ | |||
| 630 | +1150x |
-
+ cinfo = cinfo, |
||
| 173 | -7x | +631 | +1150x |
- fmt_mismatch <- which(!mapply(identical, x = ofmts, y = efmts)) ## inherently ignores dim+ lvl = lvl + 1L, |
| 174 | -+ | |||
| 632 | +1150x |
-
+ dolab = spvis, |
||
| 175 | -+ | |||
| 633 | +1150x |
-
+ partlabel = obj_label(spl), |
||
| 176 | -+ | |||
| 634 | +1150x |
- ## note the single index here!!!, no comma!!!!+ baselines = baselines, |
||
| 177 | -7x | +635 | +1150x |
- X[fmt_mismatch] <- "X"+ spl_context = spl_context |
| 178 | +636 |
- }+ ) |
||
| 179 | -+ | |||
| 637 | +1146x |
-
+ indent_mod(ret) <- indent_mod(spl) |
||
| 180 | +638 | |||
| 181 | -7x | +639 | +1146x |
- if (structure) {
+ kids <- list(ret) |
| 182 | -1x | +640 | +1146x |
- rp_mismatches <- !mapply(identical, x = rpo, y = rpe)+ names(kids) <- obj_name(ret) |
| 183 | -1x | +641 | +1146x |
- cpo <- col_paths(object)+ kids |
| 184 | -1x | +|||
| 642 | +
- cpe <- col_paths(expected)+ } |
|||
| 185 | -1x | +|||
| 643 | +
- cp_mismatches <- !mapply(identical, x = cpo, y = cpe)+ ) |
|||
| 186 | +644 | |||
| 187 | -1x | +|||
| 645 | +
- if (any(rp_mismatches)) { # P for (row or column) path do not match
+ # Adding section_divisors to TableRow |
|||
| 188 | -! | +|||
| 646 | +
- X[rp_mismatches, ] <- "R"+ .set_kids_section_div <- function(lst, trailing_section_div_char, allowed_class = "VTableTree") {
|
|||
| 189 | -+ | |||
| 647 | +1680x |
- }+ if (!is.na(trailing_section_div_char)) {
|
||
| 190 | -1x | +648 | +29x |
- if (any(cp_mismatches)) {
+ lst <- lapply( |
| 191 | -1x | +649 | +29x |
- crep <- rep("C", nrow(X))
+ lst, |
| 192 | -1x | +650 | +29x | +
+ function(k) {
+ |
+
| 651 | +70x |
- if (any(rp_mismatches)) {
+ if (is(k, allowed_class)) {
|
||
| 193 | -! | +|||
| 652 | +70x |
- crep[rp_mismatches] <- "P"+ trailing_section_div(k) <- trailing_section_div_char |
||
| 194 | +653 |
- }+ } |
||
| 195 | -1x | +654 | +70x |
- X[, cp_mismatches] <- rep(crep, sum(cp_mismatches))+ k |
| 196 | +655 |
- }+ } |
||
| 197 | +656 |
- }+ ) |
||
| 198 | -7x | +|||
| 657 | +
- class(X) <- c("rtables_diff", class(X))
+ } |
|||
| 199 | -7x | +658 | +1680x |
- X+ lst |
| 200 | +659 |
} |
||
| 201 | +660 | |||
| 202 | -- |
- ## for (i in 1:dim(X)[1]) {
- |
- ||
| 203 | +661 |
- ## for (j in 1:dim(X)[2]) {
+ ## 1 or more AnalyzeSplits |
||
| 204 | +662 |
-
+ setMethod( |
||
| 205 | +663 |
- ## is_equivalent <- TRUE+ ".make_split_kids", "AnalyzeMultiVars", |
||
| 206 | +664 |
- ## if (i <= nro && i <= nre && j <= nco && j <= nce) {
+ function(spl, |
||
| 207 | +665 |
- ## x <- object[i,j, drop = TRUE]+ have_controws, |
||
| 208 | +666 |
- ## y <- expected[i,j, drop = TRUE]+ make_lrow, ## used here |
||
| 209 | +667 |
-
+ spl_context, |
||
| 210 | +668 |
- ## attr_x <- attributes(x)+ ...) { ## all passed directly down to VAnalyzeSplit method
|
||
| 211 | -+ | |||
| 669 | +121x |
- ## attr_y <- attributes(y)+ avspls <- spl_payload(spl) |
||
| 212 | +670 | |||
| 213 | -+ | |||
| 671 | +121x |
- ## attr_x_sorted <- if (is.null(attr_x)) NULL else attr_x[order(names(attr_x))]+ nspl <- length(avspls) |
||
| 214 | +672 |
- ## attr_y_sorted <- if (is.null(attr_y)) NULL else attr_y[order(names(attr_y))]+ |
||
| 215 | -+ | |||
| 673 | +121x |
-
+ kids <- unlist(lapply(avspls, |
||
| 216 | -+ | |||
| 674 | +121x |
- ## if (comp.attr && !identical(attr_x_sorted, attr_y_sorted)) {
+ .make_split_kids, |
||
| 217 | -+ | |||
| 675 | +121x |
- ## is_equivalent <- FALSE+ nsibs = nspl - 1, |
||
| 218 | -+ | |||
| 676 | +121x |
- ## } else if (is.numeric(x) && is.numeric(y)) {
+ have_controws = have_controws, |
||
| 219 | -+ | |||
| 677 | +121x |
- ## if (any(abs(na.omit(x - y)) > tol)) {
+ make_lrow = make_lrow, |
||
| 220 | -+ | |||
| 678 | +121x |
- ## is_equivalent <- FALSE+ spl_context = spl_context, |
||
| 221 | +679 |
- ## }+ ... |
||
| 222 | +680 |
- ## } else {
+ )) |
||
| 223 | +681 |
- ## if (!identical(x, y)) {
+
|
||
| 224 | -+ | |||
| 682 | +121x |
- ## is_equivalent <- FALSE+ kids <- .set_kids_section_div(kids, spl_section_div(spl), "VTableTree") |
||
| 225 | +683 |
- ## }+ |
||
| 226 | +684 |
- ## }+ ## XXX this seems like it should be identical not !identical |
||
| 227 | +685 |
-
+ ## TODO FIXME |
||
| 228 | -+ | |||
| 686 | +121x |
- ## if (!is_equivalent) {
+ if (!identical(make_lrow, FALSE) && !have_controws && length(kids) == 1) {
|
||
| 229 | +687 |
- ## X[i,j] <- "X"+ ## we only analyzed one var so |
||
| 230 | +688 |
- ## }+ ## we don't need an extra wrapper table |
||
| 231 | +689 |
- ## } else if (i > nro || j > nco) {
+ ## in the structure |
||
| 232 | -+ | |||
| 690 | +! |
- ## ## missing in object+ stopifnot(identical( |
||
| 233 | -+ | |||
| 691 | +! |
- ## X[i, j] <- "+"+ obj_name(kids[[1]]), |
||
| 234 | -+ | |||
| 692 | +! |
- ## } else {
+ spl_payload(spl) |
||
| 235 | +693 |
- ## ## too many elements+ )) |
||
| 236 | -+ | |||
| 694 | +! |
- ## X[i, j] <- "-"+ return(kids[[1]]) |
||
| 237 | +695 |
- ## }+ } |
||
| 238 | +696 |
- ## }+ ## this will be the variables |
||
| 239 | +697 |
- ## }+ ## nms = sapply(spl_payload(spl), spl_payload) |
||
| 240 | +698 |
- ## class(X) <- c("rtable_diff", class(X))
+
|
||
| 241 | -+ | |||
| 699 | +121x |
- ## X+ nms <- vapply(kids, obj_name, "") |
||
| 242 | -+ | |||
| 700 | +121x |
- ## }+ labs <- vapply(kids, obj_label, "") |
||
| 243 | -+ | |||
| 701 | +121x |
-
+ if (length(unique(nms)) != length(nms) && length(unique(nms)) != length(nms)) {
|
||
| 244 | -+ | |||
| 702 | +1x |
- compare_value <- function(x, y, tol) {
+ warning("Non-unique sibling analysis table names. Using Labels ",
|
||
| 245 | -359x | +703 | +1x |
- if (identical(x, y) || (is.numeric(x) && is.numeric(y) && max(abs(x - y)) <= tol)) {
+ "instead. Use the table_names argument to analyze to avoid ", |
| 246 | -+ | |||
| 704 | +1x |
- "."+ "this when analyzing the same variable multiple times.", |
||
| 247 | -+ | |||
| 705 | +1x |
- } else {
+ "\n\toccured at (row) path: ", |
||
| 248 | -72x | +706 | +1x |
- "X"+ spl_context_to_disp_path(spl_context), |
| 249 | -+ | |||
| 707 | +1x |
- }+ call. = FALSE |
||
| 250 | +708 |
- }+ ) |
||
| 251 | -+ | |||
| 709 | +1x |
-
+ kids <- mapply(function(k, nm) {
|
||
| 252 | -+ | |||
| 710 | +2x |
- compare_rrows <- function(row1, row2, tol, ncol) {
+ obj_name(k) <- nm |
||
| 253 | -173x | +711 | +2x |
- if (length(row1) == ncol && length(row2) == ncol) {
+ k |
| 254 | -115x | +712 | +1x |
- mapply(compare_value, x = row1, y = row2, tol = tol, USE.NAMES = FALSE)+ }, k = kids, nm = labs, SIMPLIFY = FALSE) |
| 255 | -58x | +713 | +1x |
- } else if (length(row1) == 0 && length(row2) == 0) {
+ nms <- labs |
| 256 | -44x | +|||
| 714 | +
- rep(".", ncol)
+ } |
|||
| 257 | +715 |
- } else {
+
|
||
| 258 | -14x | +716 | +121x |
- rep("X", ncol)
+ nms[is.na(nms)] <- "" |
| 259 | +717 |
- }+ |
||
| 260 | -+ | |||
| 718 | +121x |
- }+ names(kids) <- nms |
||
| 261 | -+ | |||
| 719 | +121x |
-
+ kids |
||
| 262 | +720 |
- ## #' @export+ } |
||
| 263 | +721 |
- ## print.rtable_diff <- function(x, ...) {
+ ) |
||
| 264 | +722 |
- ## print.default(unclass(x), quote = FALSE, ...)+ |
||
| 265 | +723 |
- ## }+ setMethod( |
| 1 | +724 |
- label_pos_values <- c("hidden", "visible", "topleft")
+ ".make_split_kids", "Split", |
||
| 2 | +725 |
-
+ function(spl, |
||
| 3 | +726 |
- #' @name internal_methods+ have_controws, |
||
| 4 | +727 |
- #' @rdname int_methods+ make_lrow, |
||
| 5 | +728 |
- NULL+ ..., |
||
| 6 | +729 |
-
+ splvec, ## passed to recursive_applysplit |
||
| 7 | +730 |
- #' Combine `SplitVector` objects+ df, ## used to apply split |
||
| 8 | +731 |
- #'+ alt_df, ## used to apply split for alternative df |
||
| 9 | +732 |
- #' @param x (`SplitVector`)\cr a `SplitVector` object.+ lvl, ## used to calculate innerlev |
||
| 10 | +733 |
- #' @param ... splits or `SplitVector` objects.+ cinfo, ## used for sanity check |
||
| 11 | +734 |
- #'+ baselines, ## used to calc new baselines |
||
| 12 | +735 |
- #' @return Various, but should be considered implementation details.+ spl_context) {
|
||
| 13 | +736 |
- #'+ ## do the core splitting of data into children for this split |
||
| 14 | -+ | |||
| 737 | +436x |
- #' @rdname int_methods+ rawpart <- do_split(spl, df, spl_context = spl_context) |
||
| 15 | -+ | |||
| 738 | +425x |
- #' @exportMethod c+ dataspl <- rawpart[["datasplit"]] |
||
| 16 | +739 |
- setMethod("c", "SplitVector", function(x, ...) {
+ ## these are SplitValue objects |
||
| 17 | -409x | +740 | +425x |
- arglst <- list(...)+ splvals <- rawpart[["values"]] |
| 18 | -409x | +741 | +425x |
- stopifnot(all(sapply(arglst, is, "Split")))+ partlabels <- rawpart[["labels"]] |
| 19 | -409x | +742 | +425x |
- tmp <- c(unclass(x), arglst)+ if (is.factor(partlabels)) {
|
| 20 | -409x | +|||
| 743 | +! |
- SplitVector(lst = tmp)+ partlabels <- as.character(partlabels) |
||
| 21 | +744 |
- })+ }+ |
+ ||
| 745 | +425x | +
+ nms <- unlist(value_names(splvals))+ |
+ ||
| 746 | +425x | +
+ if (is.factor(nms)) {
+ |
+ ||
| 747 | +! | +
+ nms <- as.character(nms) |
||
| 22 | +748 |
-
+ } |
||
| 23 | +749 |
- ## split_rows and split_cols are "recursive method stacks" which follow+ |
||
| 24 | +750 |
- ## the general pattern of accept object -> call add_*_split on slot of object ->+ ## Get new baseline values |
||
| 25 | +751 |
- ## update object with value returned from slot method, return object.+ ## |
||
| 26 | +752 |
- ##+ ## XXX this is a lot of data churn, if it proves too slow |
||
| 27 | +753 |
- ## Thus each of the methods is idempotent, returning an updated object of the+ ## we can |
||
| 28 | +754 |
- ## same class it was passed. The exception for idempotency is the NULL method+ ## a) check if any of the analyses (i.e. the afuns) need the baseline in this |
||
| 29 | +755 |
- ## which constructs a PreDataTableLayouts object with the specified split in the+ ## splitvec and not do any of this if not, or |
||
| 30 | +756 |
- ## correct place.+ ## b) refactor row splitting to behave like column splitting |
||
| 31 | +757 |
-
+ ## |
||
| 32 | +758 |
- ## The cascading (by class) in this case is as follows for the row case:+ ## (b) seems the better design but is a major reworking of the guts of how |
||
| 33 | +759 |
- ## PreDataTableLayouts -> PreDataRowLayout -> SplitVector+ ## rtables tabulation works |
||
| 34 | +760 |
- #' @param cmpnd_fun (`function`)\cr intended for internal use.+ ## (a) will only help if analyses that use baseline |
||
| 35 | +761 |
- #' @param pos (`numeric(1)`)\cr intended for internal use.+ ## info are mixed with those who don't.+ |
+ ||
| 762 | +425x | +
+ newbl_raw <- lapply(baselines, function(dat) {
|
||
| 36 | +763 |
- #' @param spl (`Split`)\cr the split.+ # If no ref_group is specified+ |
+ ||
| 764 | +1553x | +
+ if (is.null(dat)) {
+ |
+ ||
| 765 | +1533x | +
+ return(NULL) |
||
| 37 | +766 |
- #'+ } |
||
| 38 | +767 |
- #' @rdname int_methods+ |
||
| 39 | +768 |
- setGeneric(+ ## 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 |
||
| 40 | +771 |
- "split_rows",+ ) |
||
| 41 | +772 |
- function(lyt = NULL, spl, pos,+ |
||
| 42 | +773 |
- cmpnd_fun = AnalyzeMultiVars) {
+ # Error localization |
||
| 43 | -1641x | +774 | +20x |
- standardGeneric("split_rows")
+ if (is(bldataspl, "error")) {
|
| 44 | -+ | |||
| 775 | +! |
- }+ stop("Following error encountered in splitting .ref_group (baselines): ",
+ |
+ ||
| 776 | +! | +
+ bldataspl$message,+ |
+ ||
| 777 | +! | +
+ call. = FALSE |
||
| 45 | +778 |
- )+ ) |
||
| 46 | +779 |
-
+ } |
||
| 47 | +780 |
- #' @rdname int_methods+ |
||
| 48 | +781 |
- setMethod("split_rows", "NULL", function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
+ ## we only keep the ones corresponding with actual data splits |
||
| 49 | -1x | +782 | +20x |
- lifecycle::deprecate_warn(+ res <- lapply( |
| 50 | -1x | +783 | +20x |
- when = "0.3.8",+ names(dataspl), |
| 51 | -1x | +784 | +20x |
- what = I("split_rows(NULL)"),
+ function(nm) {
|
| 52 | -1x | +785 | +52x |
- with = "basic_table()",+ if (nm %in% names(bldataspl)) {
|
| 53 | -1x | +786 | +52x |
- details = "Initializing layouts via `NULL` is no longer supported."+ bldataspl[[nm]] |
| 54 | +787 |
- )+ } else {
|
||
| 55 | -1x | +|||
| 788 | +! |
- rl <- PreDataRowLayout(SplitVector(spl))+ dataspl[[1]][0, ] |
||
| 56 | -1x | +|||
| 789 | +
- cl <- PreDataColLayout()+ } |
|||
| 57 | -1x | +|||
| 790 | +
- PreDataTableLayouts(rlayout = rl, clayout = cl)+ } |
|||
| 58 | +791 |
- })+ ) |
||
| 59 | +792 | |||
| 60 | -+ | |||
| 793 | +20x |
- #' @rdname int_methods+ names(res) <- names(dataspl) |
||
| 61 | -+ | |||
| 794 | +20x |
- setMethod(+ res |
||
| 62 | +795 |
- "split_rows", "PreDataRowLayout",+ }) |
||
| 63 | +796 |
- function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
+
|
||
| 64 | -555x | +797 | +425x |
- stopifnot(pos > 0 && pos <= length(lyt) + 1)+ newbaselines <- lapply(names(dataspl), function(nm) {
|
| 65 | -555x | +798 | +1262x |
- tmp <- if (pos <= length(lyt)) {
+ lapply(newbl_raw, function(rawdat) {
|
| 66 | -530x | +799 | +4573x |
- split_rows(lyt[[pos]], spl, pos, cmpnd_fun)+ if (nm %in% names(rawdat)) {
+ |
+
| 800 | +52x | +
+ rawdat[[nm]] |
||
| 67 | +801 |
- } else {
+ } else {
|
||
| 68 | -25x | +802 | +4521x |
- if (pos != 1 && has_force_pag(spl)) {
+ rawdat[[1]][0, ] |
| 69 | -1x | +|||
| 803 | +
- stop("page_by splits cannot have top-level siblings",
+ } |
|||
| 70 | -1x | +|||
| 804 | +
- call. = FALSE+ }) |
|||
| 71 | +805 |
- )+ }) |
||
| 72 | +806 |
- }+ |
||
| 73 | -24x | +807 | +425x |
- SplitVector(spl)+ if (length(newbaselines) != length(dataspl)) {
|
| 74 | -+ | |||
| 808 | +! |
- }+ stop( |
||
| 75 | -553x | +|||
| 809 | +! |
- lyt[[pos]] <- tmp+ "Baselines (ref_group) after row split does not have", |
||
| 76 | -553x | +|||
| 810 | +! |
- lyt+ " the same number of levels of input data split. ", |
||
| 77 | -+ | |||
| 811 | +! |
- }+ "Contact the maintainer." |
||
| 78 | -+ | |||
| 812 | +! |
- )+ ) # nocov |
||
| 79 | +813 |
-
+ } |
||
| 80 | -+ | |||
| 814 | +425x |
- is_analysis_spl <- function(spl) {
+ if (!(length(newbaselines) == 0 || |
||
| 81 | -! | +|||
| 815 | +425x |
- is(spl, "VAnalyzeSplit") || is(spl, "AnalyzeMultiVars")+ identical( |
||
| 82 | -+ | |||
| 816 | +425x |
- }+ unique(sapply(newbaselines, length)), |
||
| 83 | -+ | |||
| 817 | +425x |
-
+ length(col_exprs(cinfo)) |
||
| 84 | +818 |
- ## note "pos" is ignored here because it is for which nest-chain+ ))) {
|
||
| 85 | -+ | |||
| 819 | +! |
- ## spl should be placed in, NOIT for where in that chain it should go+ stop( |
||
| 86 | -+ | |||
| 820 | +! |
- #' @rdname int_methods+ "Baselines (ref_group) do not have the same number of columns", |
||
| 87 | -+ | |||
| 821 | +! |
- setMethod(+ " in each split. Contact the maintainer." |
||
| 88 | -+ | |||
| 822 | +! |
- "split_rows", "SplitVector",+ ) # nocov |
||
| 89 | +823 |
- function(lyt, spl, pos, cmpnd_fun = AnalyzeMultiVars) {
+ } |
||
| 90 | +824 |
- ## if(is_analysis_spl(spl) &&+ |
||
| 91 | +825 |
- ## is_analysis_spl(last_rowsplit(lyt))) {
+ # If params are not present do not do the calculation |
||
| 92 | -+ | |||
| 826 | +425x |
- ## return(cmpnd_last_rowsplit(lyt, spl, cmpnd_fun))+ acdf_param <- check_afun_cfun_params(+ |
+ ||
| 827 | +425x | +
+ SplitVector(spl, splvec),+ |
+ ||
| 828 | +425x | +
+ c(".alt_df", ".alt_df_row")
|
||
| 93 | +829 |
- ## }+ ) |
||
| 94 | +830 | |||
| 95 | -530x | +|||
| 831 | +
- if (has_force_pag(spl) && length(lyt) > 0 && !has_force_pag(lyt[[length(lyt)]])) {
+ # Apply same split for alt_counts_df |
|||
| 96 | -1x | +832 | +425x |
- stop("page_by splits cannot be nested within non-page_by splits",
+ if (!is.null(alt_df) && any(acdf_param)) {
|
| 97 | -1x | +833 | +17x |
- call. = FALSE+ alt_dfpart <- tryCatch( |
| 98 | -+ | |||
| 834 | +17x |
- )+ do_split(spl, alt_df, |
||
| 99 | -+ | |||
| 835 | +17x |
- }+ spl_context = spl_context |
||
| 100 | -529x | +836 | +17x |
- tmp <- c(unclass(lyt), spl)+ )[["datasplit"]], |
| 101 | -529x | +837 | +17x |
- SplitVector(lst = tmp)+ error = function(e) e |
| 102 | +838 |
- }+ ) |
||
| 103 | +839 |
- )+ |
||
| 104 | +840 |
-
+ # Removing NA rows - to explore why this happens at all in a split |
||
| 105 | +841 |
- #' @rdname int_methods+ # This would be a fix but it is done in post-processing instead of pre-proc -> xxx |
||
| 106 | +842 |
- setMethod(+ # x alt_dfpart <- lapply(alt_dfpart, function(data) {
|
||
| 107 | +843 |
- "split_rows", "PreDataTableLayouts",+ # x data[!apply(is.na(data), 1, all), ] |
||
| 108 | +844 |
- function(lyt, spl, pos) {
+ # x }) |
||
| 109 | -555x | +|||
| 845 | +
- rlyt <- rlayout(lyt)+ |
|||
| 110 | -555x | +|||
| 846 | +
- addtl <- FALSE+ # Error localization |
|||
| 111 | -555x | +847 | +17x |
- split_label <- obj_label(spl)+ if (is(alt_dfpart, "error")) {
|
| 112 | -+ | |||
| 848 | +2x |
- if (+ stop("Following error encountered in splitting alt_counts_df: ",
|
||
| 113 | -555x | +849 | +2x |
- is(spl, "Split") && ## exclude existing tables that are being tacked in+ alt_dfpart$message, |
| 114 | -555x | +850 | +2x |
- identical(label_position(spl), "topleft") &&+ call. = FALSE |
| 115 | -555x | +|||
| 851 | +
- length(split_label) == 1 && nzchar(split_label)+ ) |
|||
| 116 | +852 |
- ) {
+ } |
||
| 117 | -17x | +|||
| 853 | +
- addtl <- TRUE+ # Error if split does not have the same values in the alt_df (and order) |
|||
| 118 | +854 |
- ## label_position(spl) <- "hidden"+ # The following breaks if there are different levels (do_split returns empty list) |
||
| 119 | +855 |
- }+ # or if there are different number of the same levels. Added handling of NAs |
||
| 120 | +856 |
-
+ # in the values of the factor when is all only NAs |
||
| 121 | -555x | +857 | +15x |
- rlyt <- split_rows(rlyt, spl, pos)+ is_all_na <- all(is.na(alt_df[[spl_payload(spl)]]))+ |
+
| 858 | ++ | + | ||
| 122 | -553x | +859 | +15x |
- rlayout(lyt) <- rlyt+ if (!all(names(dataspl) %in% names(alt_dfpart)) || length(alt_dfpart) != length(dataspl) || is_all_na) {
|
| 123 | -553x | +860 | +5x |
- if (addtl) {
+ alt_df_spl_vals <- unique(alt_df[[spl_payload(spl)]]) |
| 124 | -17x | +861 | +5x |
- lyt <- append_topleft(lyt, indent_string(split_label, .tl_indent(lyt)))+ end_part <- "" |
| 125 | +862 |
- }+ |
||
| 126 | -553x | +863 | +5x |
- lyt+ if (!all(alt_df_spl_vals %in% levels(alt_df_spl_vals))) {
|
| 127 | -+ | |||
| 864 | +2x |
- }+ end_part <- paste0( |
||
| 128 | -+ | |||
| 865 | +2x |
- )+ " and following levels: ", |
||
| 129 | -+ | |||
| 866 | +2x |
-
+ paste_vec(levels(alt_df_spl_vals)) |
||
| 130 | +867 |
- #' @rdname int_methods+ ) |
||
| 131 | +868 |
- setMethod(+ } |
||
| 132 | +869 |
- "split_rows", "ANY",+ |
||
| 133 | -+ | |||
| 870 | +5x |
- function(lyt, spl, pos) {
+ if (is_all_na) {
|
||
| 134 | -! | +|||
| 871 | +2x |
- stop("nope. can't add a row split to that (", class(lyt), "). contact the maintaner.")
+ end_part <- ". Found only NAs in alt_counts_df split" |
||
| 135 | +872 |
- }+ } |
||
| 136 | +873 |
- )+ |
||
| 137 | -+ | |||
| 874 | +5x |
-
+ stop( |
||
| 138 | -+ | |||
| 875 | +5x |
- ## cmpnd_last_rowsplit =====+ "alt_counts_df split variable(s) [", spl_payload(spl), |
||
| 139 | -+ | |||
| 876 | +5x |
-
+ "] (in split ", as.character(class(spl)), |
||
| 140 | -+ | |||
| 877 | +5x |
- #' @rdname int_methods+ ") does not have the same factor levels of df.\ndf has c(", '"',
|
||
| 141 | -+ | |||
| 878 | +5x |
- #'+ paste(names(dataspl), collapse = '", "'), '"', ") levels while alt_counts_df has ", |
||
| 142 | -+ | |||
| 879 | +5x |
- #' @param constructor (`function`)\cr constructor function.+ ifelse(length(alt_df_spl_vals) > 0, paste_vec(alt_df_spl_vals), ""), |
||
| 143 | -79x | +880 | +5x |
- setGeneric("cmpnd_last_rowsplit", function(lyt, spl, constructor) standardGeneric("cmpnd_last_rowsplit"))
+ " unique values", end_part |
| 144 | +881 |
-
+ ) |
||
| 145 | +882 |
- #' @rdname int_methods+ } |
||
| 146 | +883 |
- setMethod("cmpnd_last_rowsplit", "NULL", function(lyt, spl, constructor) {
+ } else {
|
||
| 147 | -+ | |||
| 884 | +408x |
- stop("no existing splits to compound with. contact the maintainer") # nocov
+ alt_dfpart <- setNames(rep(list(NULL), length(dataspl)), names(dataspl)) |
||
| 148 | +885 |
- })+ } |
||
| 149 | +886 | |||
| 150 | +887 |
- #' @rdname int_methods+ |
||
| 151 | -+ | |||
| 888 | +418x |
- setMethod(+ innerlev <- lvl + (have_controws || is.na(make_lrow) || make_lrow) |
||
| 152 | +889 |
- "cmpnd_last_rowsplit", "PreDataRowLayout",+ ## do full recursive_applysplit on each part of the split defined by spl |
||
| 153 | -+ | |||
| 890 | +418x |
- function(lyt, spl, constructor) {
+ inner <- unlist(mapply( |
||
| 154 | -26x | +891 | +418x |
- pos <- length(lyt)+ function(dfpart, alt_dfpart, nm, label, baselines, splval) {
|
| 155 | -26x | +892 | +1220x |
- tmp <- cmpnd_last_rowsplit(lyt[[pos]], spl, constructor)+ rsplval <- context_df_row( |
| 156 | -26x | +893 | +1220x |
- lyt[[pos]] <- tmp+ split = obj_name(spl), |
| 157 | -26x | +894 | +1220x |
- lyt+ value = value_names(splval), |
| 158 | -+ | |||
| 895 | +1220x |
- }+ full_parent_df = list(dfpart), |
||
| 159 | -+ | |||
| 896 | +1220x |
- )+ cinfo = cinfo |
||
| 160 | +897 |
- #' @rdname int_methods+ ) |
||
| 161 | +898 |
- setMethod(+ |
||
| 162 | +899 |
- "cmpnd_last_rowsplit", "SplitVector",+ ## if(length(rsplval) > 0) |
||
| 163 | +900 |
- function(lyt, spl, constructor) {
+ ## rsplval <- setNames(rsplval, obj_name(spl)) |
||
| 164 | -27x | +901 | +1220x |
- pos <- length(lyt)+ recursive_applysplit( |
| 165 | -27x | +902 | +1220x |
- lst <- lyt[[pos]]+ df = dfpart, |
| 166 | -27x | +903 | +1220x |
- tmp <- if (is(lst, "CompoundSplit")) {
+ alt_df = alt_dfpart, |
| 167 | -3x | +904 | +1220x |
- spl_payload(lst) <- c(+ name = nm, |
| 168 | -3x | +905 | +1220x |
- .uncompound(spl_payload(lst)),+ lvl = innerlev, |
| 169 | -3x | -
- .uncompound(spl)- |
- ||
| 170 | -+ | 906 | +1220x |
- )+ splvec = splvec, |
| 171 | -3x | +907 | +1220x |
- obj_name(lst) <- make_ma_name(spl = lst)+ cinfo = cinfo, |
| 172 | -3x | -
- lst- |
- ||
| 173 | -+ | 908 | +1220x |
- ## XXX never reached because AnalzyeMultiVars inherits from+ make_lrow = label_kids(spl), |
| 174 | -+ | |||
| 909 | +1220x |
- ## CompoundSplit???+ parent_cfun = content_fun(spl), |
||
| 175 | -+ | |||
| 910 | +1220x |
- } else {
+ cformat = content_format(spl), |
||
| 176 | -24x | +911 | +1220x |
- constructor(.payload = list(lst, spl))+ cna_str = content_na_str(spl), |
| 177 | -+ | |||
| 912 | +1220x |
- }+ partlabel = label, |
||
| 178 | -27x | +913 | +1220x |
- lyt[[pos]] <- tmp+ cindent_mod = content_indent_mod(spl), |
| 179 | -27x | +914 | +1220x |
- lyt+ cvar = content_var(spl), |
| 180 | -+ | |||
| 915 | +1220x |
- }+ baselines = baselines, |
||
| 181 | -+ | |||
| 916 | +1220x |
- )+ cextra_args = content_extra_args(spl), |
||
| 182 | +917 |
-
+ ## splval should still be retaining its name |
||
| 183 | -+ | |||
| 918 | +1220x |
- #' @rdname int_methods+ spl_context = rbind(spl_context, rsplval) |
||
| 184 | +919 |
- setMethod(+ ) |
||
| 185 | +920 |
- "cmpnd_last_rowsplit", "PreDataTableLayouts",+ }, |
||
| 186 | -+ | |||
| 921 | +418x |
- function(lyt, spl, constructor) {
+ dfpart = dataspl, |
||
| 187 | -26x | +922 | +418x |
- rlyt <- rlayout(lyt)+ alt_dfpart = alt_dfpart, |
| 188 | -26x | +923 | +418x |
- rlyt <- cmpnd_last_rowsplit(rlyt, spl, constructor)+ label = partlabels, |
| 189 | -26x | +924 | +418x |
- rlayout(lyt) <- rlyt+ nm = nms, |
| 190 | -26x | +925 | +418x |
- lyt+ baselines = newbaselines, |
| 191 | -+ | |||
| 926 | +418x |
- }+ splval = splvals, |
||
| 192 | -+ | |||
| 927 | +418x |
- )+ SIMPLIFY = FALSE |
||
| 193 | +928 |
- #' @rdname int_methods+ )) |
||
| 194 | +929 |
- setMethod(+ |
||
| 195 | +930 |
- "cmpnd_last_rowsplit", "ANY",+ # Setting the kids section separator if they inherits VTableTree |
||
| 196 | -+ | |||
| 931 | +410x |
- function(lyt, spl, constructor) {
+ inner <- .set_kids_section_div( |
||
| 197 | -! | +|||
| 932 | +410x |
- stop(+ inner, |
||
| 198 | -! | +|||
| 933 | +410x |
- "nope. can't do cmpnd_last_rowsplit to that (",
+ trailing_section_div_char = spl_section_div(spl), |
||
| 199 | -! | +|||
| 934 | +410x |
- class(lyt), "). contact the maintaner."+ allowed_class = "VTableTree" |
||
| 200 | +935 |
) |
||
| 201 | -- |
- }- |
- ||
| 202 | -- |
- )- |
- ||
| 203 | -- | - - | -||
| 204 | -- |
- ## split_cols ====- |
- ||
| 205 | +936 | |||
| 206 | +937 |
- #' @rdname int_methods+ ## This is where we need to build the structural tables |
||
| 207 | +938 |
- setGeneric(+ ## even if they are invisible because their labels are not |
||
| 208 | +939 |
- "split_cols",+ ## not shown. |
||
| 209 | -+ | |||
| 940 | +410x |
- function(lyt = NULL, spl, pos) {
+ innertab <- TableTree( |
||
| 210 | -1034x | +941 | +410x |
- standardGeneric("split_cols")
+ kids = inner, |
| 211 | -+ | |||
| 942 | +410x |
- }+ name = obj_name(spl), |
||
| 212 | -+ | |||
| 943 | +410x |
- )+ labelrow = LabelRow( |
||
| 213 | -+ | |||
| 944 | +410x |
-
+ label = obj_label(spl), |
||
| 214 | -+ | |||
| 945 | +410x |
- #' @rdname int_methods+ vis = isTRUE(vis_label(spl)) |
||
| 215 | +946 |
- setMethod("split_cols", "NULL", function(lyt, spl, pos) {
+ ), |
||
| 216 | -1x | +947 | +410x |
- lifecycle::deprecate_warn(+ cinfo = cinfo, |
| 217 | -1x | +948 | +410x |
- when = "0.3.8",+ iscontent = FALSE, |
| 218 | -1x | +949 | +410x |
- what = I("split_cols(NULL)"),
+ indent_mod = indent_mod(spl), |
| 219 | -1x | +950 | +410x |
- with = "basic_table()",+ page_title = ptitle_prefix(spl) |
| 220 | -1x | +|||
| 951 | +
- details = "Initializing layouts via `NULL` is no longer supported."+ ) |
|||
| 221 | +952 |
- )+ ## kids = inner |
||
| 222 | -1x | +953 | +410x |
- cl <- PreDataColLayout(SplitVector(spl))+ kids <- list(innertab) |
| 223 | -1x | +954 | +410x |
- rl <- PreDataRowLayout()+ kids |
| 224 | -1x | +|||
| 955 | +
- PreDataTableLayouts(rlayout = rl, clayout = cl)+ } |
|||
| 225 | +956 |
- })+ ) |
||
| 226 | +957 | |||
| 227 | +958 |
- #' @rdname int_methods+ context_df_row <- function(split = character(), |
||
| 228 | +959 |
- setMethod(+ value = character(), |
||
| 229 | +960 |
- "split_cols", "PreDataColLayout",+ full_parent_df = list(), |
||
| 230 | +961 |
- function(lyt, spl, pos) {
+ cinfo = NULL) {
|
||
| 231 | -312x | +962 | +2979x |
- stopifnot(pos > 0 && pos <= length(lyt) + 1)+ ret <- data.frame( |
| 232 | -312x | +963 | +2979x |
- tmp <- if (pos <= length(lyt)) {
+ split = split, |
| 233 | -304x | -
- split_cols(lyt[[pos]], spl, pos)- |
- ||
| 234 | -+ | 964 | +2979x |
- } else {
+ value = value, |
| 235 | -8x | +965 | +2979x |
- SplitVector(spl)+ full_parent_df = I(full_parent_df), |
| 236 | +966 |
- }+ # parent_cold_inds = I(parent_col_inds),+ |
+ ||
| 967 | +2979x | +
+ stringsAsFactors = FALSE |
||
| 237 | +968 |
-
+ ) |
||
| 238 | -312x | +969 | +2979x |
- lyt[[pos]] <- tmp+ if (nrow(ret) > 0) {
|
| 239 | -312x | +970 | +2966x |
- lyt+ ret$all_cols_n <- nrow(full_parent_df[[1]]) |
| 240 | +971 |
- }+ } else {
|
||
| 241 | -+ | |||
| 972 | +13x |
- )+ ret$all_cols_n <- integer() ## should this be numeric??? This never happens |
||
| 242 | +973 |
-
+ } |
||
| 243 | +974 |
- #' @rdname int_methods+ |
||
| 244 | -+ | |||
| 975 | +2979x |
- setMethod(+ if (!is.null(cinfo)) {
|
||
| 245 | -+ | |||
| 976 | +1553x |
- "split_cols", "SplitVector",+ if (nrow(ret) > 0) {
|
||
| 246 | -+ | |||
| 977 | +1544x |
- function(lyt, spl, pos) {
+ colcols <- as.data.frame(lapply(col_exprs(cinfo), function(e) {
|
||
| 247 | -409x | +978 | +5577x |
- tmp <- c(lyt, spl)+ vals <- eval(e, envir = full_parent_df[[1]]) |
| 248 | -409x | +979 | +5577x |
- SplitVector(lst = tmp)+ if (identical(vals, TRUE)) {
|
| 249 | -+ | |||
| 980 | +545x |
- }+ vals <- rep(vals, length.out = nrow(full_parent_df[[1]])) |
||
| 250 | +981 |
- )+ } |
||
| 251 | -+ | |||
| 982 | +5577x |
-
+ I(list(vals)) |
||
| 252 | +983 |
- #' @rdname int_methods+ })) |
||
| 253 | +984 |
- setMethod(+ } else {
|
||
| 254 | -+ | |||
| 985 | +9x |
- "split_cols", "PreDataTableLayouts",+ colcols <- as.data.frame(rep(list(logical()), ncol(cinfo))) |
||
| 255 | +986 |
- function(lyt, spl, pos) {
+ } |
||
| 256 | -312x | +987 | +1553x |
- rlyt <- lyt@col_layout+ names(colcols) <- names(col_exprs(cinfo)) |
| 257 | -312x | +988 | +1553x |
- rlyt <- split_cols(rlyt, spl, pos)+ ret <- cbind(ret, colcols) |
| 258 | -312x | +|||
| 989 | +
- lyt@col_layout <- rlyt+ } |
|||
| 259 | -312x | +990 | +2979x |
- lyt+ ret |
| 260 | +991 |
- }+ } |
||
| 261 | +992 |
- )+ |
||
| 262 | +993 |
-
+ recursive_applysplit <- function(df, |
||
| 263 | +994 |
- #' @rdname int_methods+ lvl = 0L, |
||
| 264 | +995 |
- setMethod(+ alt_df, |
||
| 265 | +996 |
- "split_cols", "ANY",+ splvec, |
||
| 266 | +997 |
- function(lyt, spl, pos) {
+ name, |
||
| 267 | -! | +|||
| 998 | +
- stop(+ # label, |
|||
| 268 | -! | +|||
| 999 | +
- "nope. can't add a col split to that (", class(lyt),
+ make_lrow = NA, |
|||
| 269 | -! | +|||
| 1000 | +
- "). contact the maintaner."+ partlabel = "", |
|||
| 270 | +1001 |
- )+ cinfo, |
||
| 271 | +1002 |
- }+ parent_cfun = NULL, |
||
| 272 | +1003 |
- )+ cformat = NULL, |
||
| 273 | +1004 |
-
+ cna_str = NA_character_, |
||
| 274 | +1005 |
- # Constructors =====+ cindent_mod = 0L, |
||
| 275 | +1006 |
-
+ cextra_args = list(), |
||
| 276 | +1007 |
- ## Pipe-able functions to add the various types of splits to the current layout+ cvar = NULL, |
||
| 277 | +1008 |
- ## for both row and column. These all act as wrappers to the split_cols and+ baselines = lapply( |
||
| 278 | +1009 |
- ## split_rows method stacks.+ col_extra_args(cinfo), |
||
| 279 | +1010 |
-
+ function(x) x$.ref_full |
||
| 280 | +1011 |
- #' Declaring a column-split based on levels of a variable+ ), |
||
| 281 | +1012 |
- #'+ spl_context = context_df_row(cinfo = cinfo), |
||
| 282 | +1013 |
- #' Will generate children for each subset of a categorical variable.+ no_outer_tbl = FALSE, |
||
| 283 | +1014 |
- #'+ parent_sect_split = NA_character_) {
|
||
| 284 | +1015 |
- #' @inheritParams lyt_args+ ## pre-existing table was added to the layout+ |
+ ||
| 1016 | +1553x | +
+ if (length(splvec) == 1L && is(splvec[[1]], "VTableNodeInfo")) {
+ |
+ ||
| 1017 | +1x | +
+ return(splvec[[1]]) |
||
| 285 | +1018 |
- #' @param ref_group (`string` or `NULL`)\cr level of `var` that should be considered `ref_group`/reference.+ } |
||
| 286 | +1019 |
- #'+ |
||
| 287 | +1020 |
- #' @return A `PreDataTableLayouts` object suitable for passing to further layouting functions, and to [build_table()].+ ## the content function is the one from the PREVIOUS |
||
| 288 | +1021 |
- #'+ ## split, i.e. the one whose children we are now constructing |
||
| 289 | +1022 |
- #' @inheritSection custom_split_funs Custom Splitting Function Details+ ## this is a bit annoying but makes the semantics for |
||
| 290 | +1023 |
- #'+ ## declaring layouts much more sane. |
||
| 291 | -+ | |||
| 1024 | +1552x |
- #' @examples+ ctab <- .make_ctab(df, |
||
| 292 | -+ | |||
| 1025 | +1552x |
- #' lyt <- basic_table() %>%+ lvl = lvl, |
||
| 293 | -+ | |||
| 1026 | +1552x |
- #' split_cols_by("ARM") %>%
+ name = name, |
||
| 294 | -+ | |||
| 1027 | +1552x |
- #' analyze(c("AGE", "BMRKR2"))
+ label = partlabel, |
||
| 295 | -+ | |||
| 1028 | +1552x |
- #'+ cinfo = cinfo, |
||
| 296 | -+ | |||
| 1029 | +1552x |
- #' tbl <- build_table(lyt, ex_adsl)+ parent_cfun = parent_cfun, |
||
| 297 | -+ | |||
| 1030 | +1552x |
- #' tbl+ format = cformat, |
||
| 298 | -+ | |||
| 1031 | +1552x |
- #'+ na_str = cna_str, |
||
| 299 | -+ | |||
| 1032 | +1552x |
- #' # Let's look at the splits in more detail+ indent_mod = cindent_mod, |
||
| 300 | -+ | |||
| 1033 | +1552x |
- #'+ cvar = cvar, |
||
| 301 | -+ | |||
| 1034 | +1552x |
- #' lyt1 <- basic_table() %>% split_cols_by("ARM")
+ alt_df = alt_df, |
||
| 302 | -+ | |||
| 1035 | +1552x |
- #' lyt1+ extra_args = cextra_args, |
||
| 303 | -+ | |||
| 1036 | +1552x |
- #'+ spl_context = spl_context |
||
| 304 | +1037 |
- #' # add an analysis (summary)+ ) |
||
| 305 | +1038 |
- #' lyt2 <- lyt1 %>%+ |
||
| 306 | -+ | |||
| 1039 | +1551x |
- #' analyze(c("AGE", "COUNTRY"),
+ nonroot <- lvl != 0L |
||
| 307 | +1040 |
- #' afun = list_wrap_x(summary),+ |
||
| 308 | -+ | |||
| 1041 | +1551x |
- #' format = "xx.xx"+ if (is.na(make_lrow)) {
|
||
| 309 | -+ | |||
| 1042 | +1245x |
- #' )+ make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE |
||
| 310 | +1043 |
- #' lyt2+ } |
||
| 311 | +1044 |
- #'+ ## never print an empty row label for root. |
||
| 312 | -+ | |||
| 1045 | +1551x |
- #' tbl2 <- build_table(lyt2, DM)+ if (make_lrow && partlabel == "" && !nonroot) {
|
||
| 313 | -+ | |||
| 1046 | +6x |
- #' tbl2+ make_lrow <- FALSE |
||
| 314 | +1047 |
- #'+ } |
||
| 315 | +1048 |
- #' @examplesIf require(dplyr)+ |
||
| 316 | -+ | |||
| 1049 | +1551x |
- #' # By default sequentially adding layouts results in nesting+ if (length(splvec) == 0L) {
|
||
| 317 | -+ | |||
| 1050 | +99x |
- #' library(dplyr)+ kids <- list() |
||
| 318 | -+ | |||
| 1051 | +99x |
- #'+ imod <- 0L |
||
| 319 | -+ | |||
| 1052 | +99x |
- #' DM_MF <- DM %>%+ spl <- NULL |
||
| 320 | +1053 |
- #' filter(SEX %in% c("M", "F")) %>%
+ } else {
|
||
| 321 | -+ | |||
| 1054 | +1452x |
- #' mutate(SEX = droplevels(SEX))+ spl <- splvec[[1]] |
||
| 322 | -+ | |||
| 1055 | +1452x |
- #'+ splvec <- splvec[-1] |
||
| 323 | +1056 |
- #' lyt3 <- basic_table() %>%+ |
||
| 324 | +1057 |
- #' split_cols_by("ARM") %>%
+ ## we pass this everything recursive_applysplit received and |
||
| 325 | +1058 |
- #' split_cols_by("SEX") %>%
+ ## it all gets passed around through ... as needed |
||
| 326 | +1059 |
- #' analyze(c("AGE", "COUNTRY"),
+ ## to the various methods of .make_split_kids |
||
| 327 | -+ | |||
| 1060 | +1452x |
- #' afun = list_wrap_x(summary),+ kids <- .make_split_kids( |
||
| 328 | -+ | |||
| 1061 | +1452x |
- #' format = "xx.xx"+ spl = spl, |
||
| 329 | -+ | |||
| 1062 | +1452x |
- #' )+ df = df, |
||
| 330 | -+ | |||
| 1063 | +1452x |
- #' lyt3+ alt_df = alt_df, |
||
| 331 | -+ | |||
| 1064 | +1452x |
- #'+ lvl = lvl, |
||
| 332 | -+ | |||
| 1065 | +1452x |
- #' tbl3 <- build_table(lyt3, DM_MF)+ splvec = splvec, |
||
| 333 | -+ | |||
| 1066 | +1452x |
- #' tbl3+ name = name, |
||
| 334 | -+ | |||
| 1067 | +1452x |
- #'+ make_lrow = make_lrow, |
||
| 335 | -+ | |||
| 1068 | +1452x |
- #' # nested=TRUE vs not+ partlabel = partlabel, |
||
| 336 | -+ | |||
| 1069 | +1452x |
- #' lyt4 <- basic_table() %>%+ cinfo = cinfo, |
||
| 337 | -+ | |||
| 1070 | +1452x |
- #' split_cols_by("ARM") %>%
+ parent_cfun = parent_cfun, |
||
| 338 | -+ | |||
| 1071 | +1452x |
- #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
+ cformat = cformat, |
||
| 339 | -+ | |||
| 1072 | +1452x |
- #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ cindent_mod = cindent_mod, |
||
| 340 | -+ | |||
| 1073 | +1452x |
- #' analyze("AGE")
+ cextra_args = cextra_args, cvar = cvar, |
||
| 341 | -+ | |||
| 1074 | +1452x |
- #' lyt4+ baselines = baselines, |
||
| 342 | -+ | |||
| 1075 | +1452x |
- #'+ spl_context = spl_context, |
||
| 343 | -+ | |||
| 1076 | +1452x |
- #' tbl4 <- build_table(lyt4, DM)+ have_controws = nrow(ctab) > 0 |
||
| 344 | +1077 |
- #' tbl4+ ) |
||
| 345 | -+ | |||
| 1078 | +1422x |
- #'+ imod <- 0L |
||
| 346 | +1079 |
- #' lyt5 <- basic_table() %>%+ } ## end length(splvec) |
||
| 347 | +1080 |
- #' split_cols_by("ARM") %>%
+
|
||
| 348 | -+ | |||
| 1081 | +1521x |
- #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
+ if (is.na(make_lrow)) {
|
||
| 349 | -+ | |||
| 1082 | +! |
- #' analyze("AGE") %>%
+ make_lrow <- if (nrow(ctab) > 0 || !nzchar(partlabel)) FALSE else TRUE |
||
| 350 | +1083 |
- #' split_rows_by("RACE", nested = FALSE, split_fun = drop_split_levels) %>%
+ } |
||
| 351 | +1084 |
- #' analyze("AGE")
+ ## never print an empty row label for root. |
||
| 352 | -+ | |||
| 1085 | +1521x |
- #' lyt5+ if (make_lrow && partlabel == "" && !nonroot) {
|
||
| 353 | -+ | |||
| 1086 | +! |
- #'+ make_lrow <- FALSE |
||
| 354 | +1087 |
- #' tbl5 <- build_table(lyt5, DM)+ } |
||
| 355 | +1088 |
- #' tbl5+ |
||
| 356 | +1089 |
- #'+ ## this is only true when called from build_table and the first split |
||
| 357 | +1090 |
- #' @author Gabriel Becker+ ## in (one of the) SplitVector is NOT an AnalyzeMultiVars split. |
||
| 358 | +1091 |
- #' @export+ ## in that case we would be "double creating" the structural |
||
| 359 | +1092 |
- split_cols_by <- function(lyt,+ ## subtable |
||
| 360 | -+ | |||
| 1093 | +1521x |
- var,+ if (no_outer_tbl) {
|
||
| 361 | -+ | |||
| 1094 | +282x |
- labels_var = var,+ ret <- kids[[1]] |
||
| 362 | -+ | |||
| 1095 | +282x |
- split_label = var,+ indent_mod(ret) <- indent_mod(spl) |
||
| 363 | -+ | |||
| 1096 | +1239x |
- split_fun = NULL,+ } else if (nrow(ctab) > 0L || length(kids) > 0L) {
|
||
| 364 | +1097 |
- format = NULL,+ ## previously we checked if the child had an identical label |
||
| 365 | +1098 |
- nested = TRUE,+ ## but I don't think thats needed anymore. |
||
| 366 | -+ | |||
| 1099 | +1239x |
- child_labels = c("default", "visible", "hidden"),
+ tlabel <- partlabel |
||
| 367 | -+ | |||
| 1100 | +1239x |
- extra_args = list(),+ ret <- TableTree( |
||
| 368 | -+ | |||
| 1101 | +1239x |
- ref_group = NULL,+ cont = ctab, |
||
| 369 | -+ | |||
| 1102 | +1239x |
- show_colcounts = FALSE,+ kids = kids, |
||
| 370 | -+ | |||
| 1103 | +1239x |
- colcount_format = NULL) { ## ,
+ name = name, |
||
| 371 | -277x | +1104 | +1239x |
- if (is.null(ref_group)) {
+ label = tlabel, # partlabel, |
| 372 | -268x | +1105 | +1239x |
- spl <- VarLevelSplit(+ lev = lvl, |
| 373 | -268x | +1106 | +1239x |
- var = var,+ iscontent = FALSE, |
| 374 | -268x | +1107 | +1239x |
- split_label = split_label,+ labelrow = LabelRow( |
| 375 | -268x | +1108 | +1239x |
- labels_var = labels_var,+ lev = lvl, |
| 376 | -268x | +1109 | +1239x |
- split_format = format,+ label = tlabel, |
| 377 | -268x | +1110 | +1239x |
- child_labels = child_labels,+ cinfo = cinfo, |
| 378 | -268x | +1111 | +1239x |
- split_fun = split_fun,+ vis = make_lrow |
| 379 | -268x | +|||
| 1112 | +
- extra_args = extra_args,+ ), |
|||
| 380 | -268x | +1113 | +1239x |
- show_colcounts = show_colcounts,+ cinfo = cinfo, |
| 381 | -268x | +1114 | +1239x |
- colcount_format = colcount_format+ indent_mod = imod |
| 382 | +1115 |
) |
||
| 383 | +1116 |
} else {
|
||
| 384 | -9x | +|||
| 1117 | +! |
- spl <- VarLevWBaselineSplit(+ ret <- NULL |
||
| 385 | -9x | +|||
| 1118 | +
- var = var,+ } |
|||
| 386 | -9x | +|||
| 1119 | +
- ref_group = ref_group,+ |
|||
| 387 | -9x | +|||
| 1120 | +
- split_label = split_label,+ ## if(!is.null(spl) && !is.na(spl_section_sep(spl))) |
|||
| 388 | -9x | +|||
| 1121 | +
- split_fun = split_fun,+ ## ret <- apply_kids_section_sep(ret, spl_section_sep(spl)) |
|||
| 389 | -9x | +|||
| 1122 | +
- labels_var = labels_var,+ ## ## message(sprintf("indent modifier: %d", indentmod))
|
|||
| 390 | -9x | +|||
| 1123 | +
- split_format = format,+ ## if(!is.null(ret)) |
|||
| 391 | -9x | +|||
| 1124 | +
- show_colcounts = show_colcounts,+ ## indent_mod(ret) = indentmod |
|||
| 392 | -9x | +1125 | +1521x |
- colcount_format = colcount_format+ ret |
| 393 | +1126 |
- )+ } |
||
| 394 | +1127 |
- }+ |
||
| 395 | -277x | +|||
| 1128 | +
- pos <- next_cpos(lyt, nested)+ #' Create a table from a layout and data |
|||
| 396 | -277x | +|||
| 1129 | +
- split_cols(lyt, spl, pos)+ #' |
|||
| 397 | +1130 |
- }+ #' Layouts are used to describe a table pre-data. `build_table` is used to create a table |
||
| 398 | +1131 |
-
+ #' using a layout and a dataset. |
||
| 399 | +1132 |
- ## .tl_indent ====+ #' |
||
| 400 | +1133 |
-
+ #' @inheritParams gen_args |
||
| 401 | -51x | +|||
| 1134 | +
- setGeneric(".tl_indent_inner", function(lyt) standardGeneric(".tl_indent_inner"))
+ #' @inheritParams lyt_args |
|||
| 402 | +1135 |
-
+ #' @param col_counts (`numeric` or `NULL`)\cr `r lifecycle::badge("deprecated")` if non-`NULL`, column counts
|
||
| 403 | +1136 |
- setMethod(+ #' *for leaf-columns only* which override those calculated automatically during tabulation. Must specify |
||
| 404 | +1137 |
- ".tl_indent_inner", "PreDataTableLayouts",+ #' "counts" for *all* leaf-columns if non-`NULL`. `NA` elements will be replaced with the automatically |
||
| 405 | -17x | +|||
| 1138 | +
- function(lyt) .tl_indent_inner(rlayout(lyt))+ #' calculated counts. Turns on display of leaf-column counts when non-`NULL`. |
|||
| 406 | +1139 |
- )+ #' @param col_total (`integer(1)`)\cr the total observations across all columns. Defaults to `nrow(df)`. |
||
| 407 | +1140 |
- setMethod(+ #' @param ... ignored. |
||
| 408 | +1141 |
- ".tl_indent_inner", "PreDataRowLayout",+ #' |
||
| 409 | +1142 |
- function(lyt) {
+ #' @details |
||
| 410 | -17x | +|||
| 1143 | +
- if (length(lyt) == 0 || length(lyt[[1]]) == 0) {
+ #' When `alt_counts_df` is specified, column counts are calculated by applying the exact column subsetting |
|||
| 411 | -! | +|||
| 1144 | +
- 0L+ #' expressions determined when applying column splitting to the main data (`df`) to `alt_counts_df` and |
|||
| 412 | +1145 |
- } else {
+ #' counting the observations in each resulting subset. |
||
| 413 | -17x | +|||
| 1146 | +
- .tl_indent_inner(lyt[[length(lyt)]])+ #' |
|||
| 414 | +1147 |
- }+ #' In particular, this means that in the case of splitting based on cuts of the data, any dynamic cuts will have |
||
| 415 | +1148 |
- }+ #' been calculated based on `df` and simply re-used for the count calculation. |
||
| 416 | +1149 |
- )+ #' |
||
| 417 | +1150 |
-
+ #' @note |
||
| 418 | +1151 |
- setMethod(+ #' When overriding the column counts or totals care must be taken that, e.g., `length()` or `nrow()` are not called |
||
| 419 | +1152 |
- ".tl_indent_inner", "SplitVector",+ #' within tabulation functions, because those will NOT give the overridden counts. Writing/using tabulation |
||
| 420 | +1153 |
- function(lyt) {
+ #' functions which accept `.N_col` and `.N_total` or do not rely on column counts at all (even implicitly) is the |
||
| 421 | -17x | +|||
| 1154 | +
- sum(vapply(lyt, function(x) label_position(x) == "topleft", TRUE)) - 1L+ #' only way to ensure overridden counts are fully respected. |
|||
| 422 | +1155 |
- }+ #' |
||
| 423 | +1156 |
- ) ## length(lyt) - 1L)+ #' @return A `TableTree` or `ElementaryTable` object representing the table created by performing the tabulations |
||
| 424 | +1157 |
-
+ #' declared in `lyt` to the data `df`. |
||
| 425 | +1158 |
- .tl_indent <- function(lyt, nested = TRUE) {
+ #' |
||
| 426 | -17x | +|||
| 1159 | +
- if (!nested) {
+ #' @examples |
|||
| 427 | -! | +|||
| 1160 | +
- 0L+ #' lyt <- basic_table() %>% |
|||
| 428 | +1161 |
- } else {
+ #' split_cols_by("Species") %>%
|
||
| 429 | -17x | +|||
| 1162 | +
- .tl_indent_inner(lyt)+ #' analyze("Sepal.Length", afun = function(x) {
|
|||
| 430 | +1163 |
- }+ #' list( |
||
| 431 | +1164 |
- }+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), |
||
| 432 | +1165 |
-
+ #' "range" = diff(range(x)) |
||
| 433 | +1166 |
- #' Add rows according to levels of a variable+ #' ) |
||
| 434 | +1167 |
- #'+ #' }) |
||
| 435 | +1168 |
- #' @inheritParams lyt_args+ #' lyt |
||
| 436 | +1169 |
#' |
||
| 437 | +1170 |
- #' @inherit split_cols_by return+ #' tbl <- build_table(lyt, iris) |
||
| 438 | +1171 | ++ |
+ #' tbl+ |
+ |
| 1172 |
#' |
|||
| 439 | +1173 |
- #' @inheritSection custom_split_funs Custom Splitting Function Details+ #' # analyze multiple variables |
||
| 440 | +1174 |
- #'+ #' lyt2 <- basic_table() %>% |
||
| 441 | +1175 |
- #' @note+ #' split_cols_by("Species") %>%
|
||
| 442 | +1176 |
- #' If `var` is a factor with empty unobserved levels and `labels_var` is specified, it must also be a factor+ #' analyze(c("Sepal.Length", "Petal.Width"), afun = function(x) {
|
||
| 443 | +1177 |
- #' with the same number of levels as `var`. Currently the error that occurs when this is not the case is not very+ #' list( |
||
| 444 | +1178 |
- #' informative, but that will change in the future.+ #' "mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), |
||
| 445 | +1179 |
- #'+ #' "range" = diff(range(x)) |
||
| 446 | +1180 |
- #' @examples+ #' ) |
||
| 447 | +1181 |
- #' lyt <- basic_table() %>%+ #' }) |
||
| 448 | +1182 |
- #' split_cols_by("ARM") %>%
+ #' |
||
| 449 | +1183 |
- #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ #' tbl2 <- build_table(lyt2, iris) |
||
| 450 | +1184 |
- #' analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
+ #' tbl2 |
||
| 451 | +1185 |
#' |
||
| 452 | +1186 |
- #' tbl <- build_table(lyt, DM)+ #' # an example more relevant for clinical trials with column counts |
||
| 453 | +1187 |
- #' tbl+ #' lyt3 <- basic_table(show_colcounts = TRUE) %>% |
||
| 454 | +1188 |
- #'+ #' split_cols_by("ARM") %>%
|
||
| 455 | +1189 |
- #' lyt2 <- basic_table() %>%+ #' analyze("AGE", afun = function(x) {
|
||
| 456 | +1190 |
- #' split_cols_by("ARM") %>%
+ #' setNames(as.list(fivenum(x)), c( |
||
| 457 | +1191 |
- #' split_rows_by("RACE") %>%
+ #' "minimum", "lower-hinge", "median", |
||
| 458 | +1192 |
- #' analyze("AGE", mean, var_labels = "Age", format = "xx.xx")
+ #' "upper-hinge", "maximum" |
||
| 459 | +1193 | ++ |
+ #' ))+ |
+ |
| 1194 | ++ |
+ #' })+ |
+ ||
| 1195 |
#' |
|||
| 460 | +1196 |
- #' tbl2 <- build_table(lyt2, DM)+ #' tbl3 <- build_table(lyt3, DM) |
||
| 461 | +1197 |
- #' tbl2+ #' tbl3 |
||
| 462 | +1198 |
#' |
||
| 463 | +1199 |
- #' lyt3 <- basic_table() %>%+ #' tbl4 <- build_table(lyt3, subset(DM, AGE > 40)) |
||
| 464 | +1200 |
- #' split_cols_by("ARM") %>%
+ #' tbl4 |
||
| 465 | +1201 |
- #' split_cols_by("SEX") %>%
+ #' |
||
| 466 | +1202 |
- #' summarize_row_groups(label_fstr = "Overall (N)") %>%+ #' # with column counts calculated based on different data |
||
| 467 | +1203 |
- #' split_rows_by("RACE",
+ #' miniDM <- DM[sample(1:NROW(DM), 100), ] |
||
| 468 | +1204 |
- #' split_label = "Ethnicity", labels_var = "ethn_lab",+ #' tbl5 <- build_table(lyt3, DM, alt_counts_df = miniDM) |
||
| 469 | +1205 |
- #' split_fun = drop_split_levels+ #' tbl5 |
||
| 470 | +1206 |
- #' ) %>%+ #' |
||
| 471 | +1207 |
- #' summarize_row_groups("RACE", label_fstr = "%s (n)") %>%
+ #' tbl6 <- build_table(lyt3, DM, col_counts = 1:3) |
||
| 472 | +1208 |
- #' analyze("AGE", var_labels = "Age", afun = mean, format = "xx.xx")
+ #' tbl6 |
||
| 473 | +1209 |
#' |
||
| 474 | +1210 |
- #' lyt3+ #' @author Gabriel Becker |
||
| 475 | +1211 |
- #'+ #' @export |
||
| 476 | +1212 |
- #' @examplesIf require(dplyr)+ build_table <- function(lyt, df, |
||
| 477 | +1213 |
- #' library(dplyr)+ alt_counts_df = NULL, |
||
| 478 | +1214 |
- #'+ col_counts = NULL, |
||
| 479 | +1215 |
- #' DM2 <- DM %>%+ col_total = if (is.null(alt_counts_df)) nrow(df) else nrow(alt_counts_df), |
||
| 480 | +1216 |
- #' filter(SEX %in% c("M", "F")) %>%
+ topleft = NULL, |
||
| 481 | +1217 |
- #' mutate(+ hsep = default_hsep(), |
||
| 482 | +1218 |
- #' SEX = droplevels(SEX),+ ...) {
|
||
| 483 | -+ | |||
| 1219 | +344x |
- #' gender_lab = c(+ if (!is(lyt, "PreDataTableLayouts")) {
|
||
| 484 | -+ | |||
| 1220 | +! |
- #' "F" = "Female", "M" = "Male",+ stop( |
||
| 485 | -+ | |||
| 1221 | +! |
- #' "U" = "Unknown",+ "lyt must be a PreDataTableLayouts object. Got object of class ", |
||
| 486 | -+ | |||
| 1222 | +! |
- #' "UNDIFFERENTIATED" = "Undifferentiated"+ class(lyt) |
||
| 487 | +1223 |
- #' )[SEX],+ ) |
||
| 488 | +1224 |
- #' ethn_lab = c(+ } |
||
| 489 | +1225 |
- #' "ASIAN" = "Asian",+ |
||
| 490 | +1226 |
- #' "BLACK OR AFRICAN AMERICAN" = "Black or African American",+ ## if no columns are defined (e.g. because lyt is NULL) |
||
| 491 | +1227 |
- #' "WHITE" = "White",+ ## add a single overall column as the "most basic" |
||
| 492 | +1228 |
- #' "AMERICAN INDIAN OR ALASKA NATIVE" = "American Indian or Alaska Native",+ ## table column structure that makes sense |
||
| 493 | -+ | |||
| 1229 | +344x |
- #' "MULTIPLE" = "Multiple",+ clyt <- clayout(lyt) |
||
| 494 | -+ | |||
| 1230 | +344x |
- #' "NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER" =+ if (length(clyt) == 1 && length(clyt[[1]]) == 0) {
|
||
| 495 | -+ | |||
| 1231 | +105x |
- #' "Native Hawaiian or Other Pacific Islander",+ clyt[[1]] <- add_overall_col(clyt[[1]], "") |
||
| 496 | -+ | |||
| 1232 | +105x |
- #' "OTHER" = "Other", "UNKNOWN" = "Unknown"+ clayout(lyt) <- clyt |
||
| 497 | +1233 |
- #' )[RACE]+ } |
||
| 498 | +1234 |
- #' )+ |
||
| 499 | +1235 |
- #'+ ## do checks and defensive programming now that we have the data |
||
| 500 | -+ | |||
| 1236 | +344x |
- #' tbl3 <- build_table(lyt3, DM2)+ lyt <- fix_dyncuts(lyt, df) |
||
| 501 | -+ | |||
| 1237 | +344x |
- #' tbl3+ lyt <- set_def_child_ord(lyt, df) |
||
| 502 | -+ | |||
| 1238 | +343x |
- #'+ lyt <- fix_analyze_vis(lyt) |
||
| 503 | -+ | |||
| 1239 | +343x |
- #' @author Gabriel Becker+ df <- fix_split_vars(lyt, df, char_ok = is.null(col_counts)) |
||
| 504 | -+ | |||
| 1240 | +334x |
- #' @export+ alt_params <- check_afun_cfun_params(lyt, c(".alt_df", ".alt_df_row"))
|
||
| 505 | -+ | |||
| 1241 | +334x |
- split_rows_by <- function(lyt,+ if (any(alt_params) && is.null(alt_counts_df)) {
|
||
| 506 | -+ | |||
| 1242 | +2x |
- var,+ stop( |
||
| 507 | -+ | |||
| 1243 | +2x |
- labels_var = var,+ "Layout contains afun/cfun functions that have optional parameters ", |
||
| 508 | -+ | |||
| 1244 | +2x |
- split_label = var,+ ".alt_df and/or .alt_df_row, but no alt_counts_df was provided in ", |
||
| 509 | -+ | |||
| 1245 | +2x |
- split_fun = NULL,+ "build_table()." |
||
| 510 | +1246 |
- format = NULL,+ ) |
||
| 511 | +1247 |
- na_str = NA_character_,+ } |
||
| 512 | +1248 |
- nested = TRUE,+ |
||
| 513 | -+ | |||
| 1249 | +332x |
- child_labels = c("default", "visible", "hidden"),
+ rtpos <- TreePos() |
||
| 514 | -+ | |||
| 1250 | +332x |
- label_pos = "hidden",+ cinfo <- create_colinfo(lyt, df, rtpos, |
||
| 515 | -+ | |||
| 1251 | +332x |
- indent_mod = 0L,+ counts = col_counts, |
||
| 516 | -+ | |||
| 1252 | +332x |
- page_by = FALSE,+ alt_counts_df = alt_counts_df, |
||
| 517 | -+ | |||
| 1253 | +332x |
- page_prefix = split_label,+ total = col_total,+ |
+ ||
| 1254 | +332x | +
+ topleft |
||
| 518 | +1255 |
- section_div = NA_character_) {
+ ) |
||
| 519 | -249x | +1256 | +324x |
- label_pos <- match.arg(label_pos, label_pos_values)+ if (!is.null(col_counts)) {
|
| 520 | -249x | +1257 | +3x |
- child_labels <- match.arg(child_labels)+ toreplace <- !is.na(col_counts) |
| 521 | -249x | +1258 | +3x |
- spl <- VarLevelSplit(+ newccs <- col_counts(cinfo) ## old actual counts |
| 522 | -249x | +1259 | +3x |
- var = var,+ newccs[toreplace] <- col_counts[toreplace] |
| 523 | -249x | +1260 | +3x |
- split_label = split_label,+ col_counts(cinfo) <- newccs |
| 524 | -249x | +1261 | +3x |
- label_pos = label_pos,+ leaf_paths <- col_paths(cinfo) |
| 525 | -249x | +1262 | +3x |
- labels_var = labels_var,+ for (pth in leaf_paths) {
|
| 526 | -249x | +1263 | +21x |
- split_fun = split_fun,+ colcount_visible(cinfo, pth) <- TRUE+ |
+
| 1264 | ++ |
+ }+ |
+ ||
| 1265 | ++ |
+ } |
||
| 527 | -249x | +1266 | +324x |
- split_format = format,+ rlyt <- rlayout(lyt) |
| 528 | -249x | +1267 | +324x |
- split_na_str = na_str,+ rtspl <- root_spl(rlyt) |
| 529 | -249x | +1268 | +324x |
- child_labels = child_labels,+ ctab <- .make_ctab(df, 0L, |
| 530 | -249x | +1269 | +324x |
- indent_mod = indent_mod,+ alt_df = NULL, |
| 531 | -249x | +1270 | +324x |
- page_prefix = if (page_by) page_prefix else NA_character_,+ name = "root", |
| 532 | -249x | +1271 | +324x |
- section_div = section_div+ label = "", |
| 533 | -+ | |||
| 1272 | +324x |
- )+ cinfo = cinfo, ## cexprs, ctree, |
||
| 534 | -+ | |||
| 1273 | +324x |
-
+ parent_cfun = content_fun(rtspl), |
||
| 535 | -249x | +1274 | +324x |
- pos <- next_rpos(lyt, nested)+ format = content_format(rtspl), |
| 536 | -249x | +1275 | +324x |
- ret <- split_rows(lyt, spl, pos)+ na_str = content_na_str(rtspl), |
| 537 | -+ | |||
| 1276 | +324x |
-
+ indent_mod = 0L, |
||
| 538 | -247x | +1277 | +324x |
- ret+ cvar = content_var(rtspl), |
| 539 | -+ | |||
| 1278 | +324x |
- }+ extra_args = content_extra_args(rtspl) |
||
| 540 | +1279 |
-
+ ) |
||
| 541 | +1280 |
- #' Associate multiple variables with columns+ |
||
| 542 | -+ | |||
| 1281 | +324x |
- #'+ kids <- lapply(seq_along(rlyt), function(i) {
|
||
| 543 | -+ | |||
| 1282 | +347x |
- #' In some cases, the variable to be ultimately analyzed is most naturally defined on a column, not a row, basis.+ splvec <- rlyt[[i]] |
||
| 544 | -+ | |||
| 1283 | +347x |
- #' When we need columns to reflect different variables entirely, rather than different levels of a single+ if (length(splvec) == 0) {
|
||
| 545 | -+ | |||
| 1284 | +14x |
- #' variable, we use `split_cols_by_multivar`.+ return(NULL) |
||
| 546 | +1285 |
- #'+ } |
||
| 547 | -+ | |||
| 1286 | +333x |
- #' @inheritParams lyt_args+ firstspl <- splvec[[1]] |
||
| 548 | -+ | |||
| 1287 | +333x |
- #'+ nm <- obj_name(firstspl) |
||
| 549 | +1288 |
- #' @inherit split_cols_by return+ ## XXX unused, probably shouldn't be? |
||
| 550 | +1289 |
- #'+ ## this seems to be covered by grabbing the partlabel |
||
| 551 | +1290 |
- #' @seealso [analyze_colvars()]+ ## TODO confirm this |
||
| 552 | +1291 |
- #'+ ## lab <- obj_label(firstspl) |
||
| 553 | -+ | |||
| 1292 | +333x |
- #' @examplesIf require(dplyr)+ recursive_applysplit( |
||
| 554 | -+ | |||
| 1293 | +333x |
- #' library(dplyr)+ df = df, lvl = 0L, |
||
| 555 | -+ | |||
| 1294 | +333x |
- #'+ alt_df = alt_counts_df, |
||
| 556 | -+ | |||
| 1295 | +333x |
- #' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n()))+ name = nm, |
||
| 557 | -+ | |||
| 1296 | +333x |
- #'+ splvec = splvec, |
||
| 558 | -+ | |||
| 1297 | +333x |
- #' ## toy example where we take the mean of the first variable and the+ cinfo = cinfo, |
||
| 559 | +1298 |
- #' ## count of >.5 for the second.+ ## XXX are these ALWAYS right? |
||
| 560 | -+ | |||
| 1299 | +333x |
- #' colfuns <- list(+ make_lrow = label_kids(firstspl), |
||
| 561 | -+ | |||
| 1300 | +333x |
- #' function(x) in_rows(mean = mean(x), .formats = "xx.x"),+ parent_cfun = NULL, |
||
| 562 | -+ | |||
| 1301 | +333x |
- #' function(x) in_rows("# x > 5" = sum(x > .5), .formats = "xx")
+ cformat = content_format(firstspl), |
||
| 563 | -+ | |||
| 1302 | +333x |
- #' )+ cna_str = content_na_str(firstspl), |
||
| 564 | -+ | |||
| 1303 | +333x |
- #'+ cvar = content_var(firstspl), |
||
| 565 | -+ | |||
| 1304 | +333x |
- #' lyt <- basic_table() %>%+ cextra_args = content_extra_args(firstspl), |
||
| 566 | -+ | |||
| 1305 | +333x |
- #' split_cols_by("ARM") %>%
+ spl_context = context_df_row( |
||
| 567 | -+ | |||
| 1306 | +333x |
- #' split_cols_by_multivar(c("value", "pctdiff")) %>%
+ split = "root", value = "root", |
||
| 568 | -+ | |||
| 1307 | +333x |
- #' split_rows_by("RACE",
+ full_parent_df = list(df), |
||
| 569 | -+ | |||
| 1308 | +333x |
- #' split_label = "ethnicity",+ cinfo = cinfo |
||
| 570 | +1309 |
- #' split_fun = drop_split_levels+ ), |
||
| 571 | +1310 |
- #' ) %>%+ ## we DO want the 'outer table' if the first |
||
| 572 | +1311 |
- #' summarize_row_groups() %>%+ ## one is a multi-analyze |
||
| 573 | -+ | |||
| 1312 | +333x |
- #' analyze_colvars(afun = colfuns)+ no_outer_tbl = !is(firstspl, "AnalyzeMultiVars") |
||
| 574 | +1313 |
- #' lyt+ ) |
||
| 575 | +1314 |
- #'+ }) |
||
| 576 | -+ | |||
| 1315 | +301x |
- #' tbl <- build_table(lyt, ANL)+ kids <- kids[!sapply(kids, is.null)] |
||
| 577 | -+ | |||
| 1316 | +287x |
- #' tbl+ if (length(kids) > 0) names(kids) <- sapply(kids, obj_name) |
||
| 578 | +1317 |
- #'+ |
||
| 579 | +1318 |
- #' @author Gabriel Becker+ # top level divisor |
||
| 580 | -+ | |||
| 1319 | +301x |
- #' @export+ if (!is.na(top_level_section_div(lyt))) {
|
||
| 581 | -+ | |||
| 1320 | +2x |
- split_cols_by_multivar <- function(lyt,+ kids <- lapply(kids, function(first_level_kids) {
|
||
| 582 | -+ | |||
| 1321 | +4x |
- vars,+ trailing_section_div(first_level_kids) <- top_level_section_div(lyt) |
||
| 583 | -+ | |||
| 1322 | +4x |
- split_fun = NULL,+ first_level_kids |
||
| 584 | +1323 |
- varlabels = vars,+ }) |
||
| 585 | +1324 |
- varnames = NULL,+ } |
||
| 586 | +1325 |
- nested = TRUE,+ |
||
| 587 | -+ | |||
| 1326 | +301x |
- extra_args = list(),+ if (nrow(ctab) == 0L && length(kids) == 1L && is(kids[[1]], "VTableTree")) {
|
||
| 588 | -+ | |||
| 1327 | +258x |
- ## for completeness even though it doesn't make sense+ tab <- kids[[1]] |
||
| 589 | -+ | |||
| 1328 | +258x |
- show_colcounts = FALSE,+ main_title(tab) <- main_title(lyt) |
||
| 590 | -+ | |||
| 1329 | +258x |
- colcount_format = NULL) {
+ subtitles(tab) <- subtitles(lyt) |
||
| 591 | -24x | +1330 | +258x |
- spl <- MultiVarSplit(+ main_footer(tab) <- main_footer(lyt) |
| 592 | -24x | +1331 | +258x |
- vars = vars, split_label = "",+ prov_footer(tab) <- prov_footer(lyt) |
| 593 | -24x | +1332 | +258x |
- varlabels = varlabels,+ header_section_div(tab) <- header_section_div(lyt)+ |
+
| 1333 | ++ |
+ } else {
|
||
| 594 | -24x | +1334 | +43x |
- varnames = varnames,+ tab <- TableTree( |
| 595 | -24x | +1335 | +43x |
- split_fun = split_fun,+ cont = ctab, |
| 596 | -24x | +1336 | +43x |
- extra_args = extra_args,+ kids = kids, |
| 597 | -24x | +1337 | +43x |
- show_colcounts = show_colcounts,+ lev = 0L, |
| 598 | -24x | +1338 | +43x |
- colcount_format = colcount_format+ name = "root", |
| 599 | -+ | |||
| 1339 | +43x |
- )+ label = "", |
||
| 600 | -24x | +1340 | +43x |
- pos <- next_cpos(lyt, nested)+ iscontent = FALSE, |
| 601 | -24x | +1341 | +43x |
- split_cols(lyt, spl, pos)+ cinfo = cinfo, |
| 602 | -+ | |||
| 1342 | +43x |
- }+ format = obj_format(rtspl), |
||
| 603 | -+ | |||
| 1343 | +43x |
-
+ na_str = obj_na_str(rtspl), |
||
| 604 | -+ | |||
| 1344 | +43x |
- #' Associate multiple variables with rows+ title = main_title(lyt), |
||
| 605 | -+ | |||
| 1345 | +43x |
- #'+ subtitles = subtitles(lyt), |
||
| 606 | -+ | |||
| 1346 | +43x |
- #' When we need rows to reflect different variables rather than different+ main_footer = main_footer(lyt), |
||
| 607 | -+ | |||
| 1347 | +43x |
- #' levels of a single variable, we use `split_rows_by_multivar`.+ prov_footer = prov_footer(lyt), |
||
| 608 | -+ | |||
| 1348 | +43x |
- #'+ header_section_div = header_section_div(lyt) |
||
| 609 | +1349 |
- #' @inheritParams lyt_args+ ) |
||
| 610 | +1350 |
- #'+ } |
||
| 611 | +1351 |
- #' @inherit split_rows_by return+ |
||
| 612 | +1352 |
- #'+ ## This seems to be unneeded, not clear what 'top_left' check it refers to |
||
| 613 | +1353 |
- #' @seealso [split_rows_by()] for typical row splitting, and [split_cols_by_multivar()] to perform the same type of+ ## but both top_left taller than column headers and very long topleft are now |
||
| 614 | +1354 |
- #' split on a column basis.+ ## allowed, so this is just wasted computation. |
||
| 615 | +1355 |
- #'+ |
||
| 616 | +1356 |
- #' @examples+ ## ## this is where the top_left check lives right now. refactor later maybe |
||
| 617 | +1357 |
- #' lyt <- basic_table() %>%+ ## ## but now just call it so the error gets thrown when I want it to |
||
| 618 | +1358 |
- #' split_cols_by("ARM") %>%
+ ## unused <- matrix_form(tab) |
||
| 619 | -+ | |||
| 1359 | +301x |
- #' split_rows_by_multivar(c("SEX", "STRATA1")) %>%
+ tab <- update_ref_indexing(tab) |
||
| 620 | -+ | |||
| 1360 | +301x |
- #' summarize_row_groups() %>%+ horizontal_sep(tab) <- hsep |
||
| 621 | -+ | |||
| 1361 | +301x |
- #' analyze(c("AGE", "SEX"))
+ if (table_inset(lyt) > 0) {
|
||
| 622 | -+ | |||
| 1362 | +1x |
- #'+ table_inset(tab) <- table_inset(lyt) |
||
| 623 | +1363 |
- #' tbl <- build_table(lyt, DM)+ } |
||
| 624 | -+ | |||
| 1364 | +301x |
- #' tbl+ tab |
||
| 625 | +1365 |
- #'+ } |
||
| 626 | +1366 |
- #' @export+ |
||
| 627 | +1367 |
- split_rows_by_multivar <- function(lyt,+ # fix_split_vars ---- |
||
| 628 | +1368 |
- vars,+ # These checks guarantee that all the split variables are present in the data. |
||
| 629 | +1369 |
- split_fun = NULL,+ # No generic is needed because it is not dependent on the input layout but |
||
| 630 | +1370 |
- split_label = "",+ # on the df. |
||
| 631 | +1371 |
- varlabels = vars,+ fix_one_split_var <- function(spl, df, char_ok = TRUE) {
|
||
| 632 | -+ | |||
| 1372 | +564x |
- format = NULL,+ var <- spl_payload(spl) |
||
| 633 | -+ | |||
| 1373 | +564x |
- na_str = NA_character_,+ if (!(var %in% names(df))) {
|
||
| 634 | -+ | |||
| 1374 | +2x |
- nested = TRUE,+ stop("Split variable [", var, "] not found in data being tabulated.")
|
||
| 635 | +1375 |
- child_labels = c("default", "visible", "hidden"),
+ } |
||
| 636 | -+ | |||
| 1376 | +562x |
- indent_mod = 0L,+ varvec <- df[[var]] |
||
| 637 | -+ | |||
| 1377 | +562x |
- section_div = NA_character_,+ if (!is(varvec, "character") && !is.factor(varvec)) {
|
||
| 638 | -+ | |||
| 1378 | +1x |
- extra_args = list()) {
+ message(sprintf( |
||
| 639 | -3x | +1379 | +1x |
- child_labels <- match.arg(child_labels)+ paste( |
| 640 | -3x | +1380 | +1x |
- spl <- MultiVarSplit(+ "Split var [%s] was not character or factor.", |
| 641 | -3x | +1381 | +1x |
- vars = vars, split_label = split_label, varlabels,+ "Converting to factor" |
| 642 | -3x | +|||
| 1382 | +
- split_format = format,+ ), |
|||
| 643 | -3x | +1383 | +1x |
- split_na_str = na_str,+ var |
| 644 | -3x | +|||
| 1384 | +
- child_labels = child_labels,+ )) |
|||
| 645 | -3x | +1385 | +1x |
- indent_mod = indent_mod,+ varvec <- factor(varvec) |
| 646 | -3x | +1386 | +1x |
- split_fun = split_fun,+ df[[var]] <- varvec |
| 647 | -3x | +1387 | +561x |
- section_div = section_div,+ } else if (is(varvec, "character") && !char_ok) {
|
| 648 | -3x | +1388 | +1x |
- extra_args = extra_args+ stop( |
| 649 | -+ | |||
| 1389 | +1x |
- )+ "Overriding column counts is not supported when splitting on ", |
||
| 650 | -3x | +1390 | +1x |
- pos <- next_rpos(lyt, nested)+ "character variables.\n Please convert all column split variables to ", |
| 651 | -3x | +1391 | +1x |
- split_rows(lyt, spl, pos)+ "factors." |
| 652 | +1392 |
- }+ ) |
||
| 653 | +1393 |
-
+ } |
||
| 654 | +1394 |
- #' Split on static or dynamic cuts of the data+ |
||
| 655 | -+ | |||
| 1395 | +561x |
- #'+ if (is.factor(varvec)) {
|
||
| 656 | -+ | |||
| 1396 | +403x |
- #' Create columns (or row splits) based on values (such as quartiles) of `var`.+ levs <- levels(varvec) |
||
| 657 | +1397 |
- #'+ } else {
|
||
| 658 | -+ | |||
| 1398 | +158x |
- #' @inheritParams lyt_args+ levs <- unique(varvec) |
||
| 659 | +1399 |
- #'+ } |
||
| 660 | -+ | |||
| 1400 | +561x |
- #' @details For dynamic cuts, the cut is transformed into a static cut by [build_table()] *based on the full dataset*,+ if (!all(nzchar(levs))) {
|
||
| 661 | -+ | |||
| 1401 | +4x |
- #' before proceeding. Thus even when nested within another split in column/row space, the resulting split will reflect+ stop( |
||
| 662 | -+ | |||
| 1402 | +4x |
- #' the overall values (e.g., quartiles) in the dataset, NOT the values for subset it is nested under.+ "Got empty string level in splitting variable ", var, |
||
| 663 | -+ | |||
| 1403 | +4x |
- #'+ " This is not supported.\nIf display as an empty level is ", |
||
| 664 | -+ | |||
| 1404 | +4x |
- #' @inherit split_cols_by return+ "desired use a value-labeling variable." |
||
| 665 | +1405 |
- #'+ ) |
||
| 666 | +1406 |
- #' @examplesIf require(dplyr)+ } |
||
| 667 | +1407 |
- #' library(dplyr)+ |
||
| 668 | +1408 |
- #'+ ## handle label var |
||
| 669 | -+ | |||
| 1409 | +557x |
- #' # split_cols_by_cuts+ lblvar <- spl_label_var(spl) |
||
| 670 | -+ | |||
| 1410 | +557x |
- #' lyt <- basic_table() %>%+ have_lblvar <- !identical(var, lblvar) |
||
| 671 | -+ | |||
| 1411 | +557x |
- #' split_cols_by("ARM") %>%
+ if (have_lblvar) {
|
||
| 672 | -+ | |||
| 1412 | +85x |
- #' split_cols_by_cuts("AGE",
+ if (!(lblvar %in% names(df))) {
|
||
| 673 | -+ | |||
| 1413 | +1x |
- #' split_label = "Age",+ stop( |
||
| 674 | -+ | |||
| 1414 | +1x |
- #' cuts = c(0, 25, 35, 1000),+ "Value label variable [", lblvar, |
||
| 675 | -+ | |||
| 1415 | +1x |
- #' cutlabels = c("young", "medium", "old")
+ "] not found in data being tabulated." |
||
| 676 | +1416 |
- #' ) %>%+ ) |
||
| 677 | +1417 |
- #' analyze(c("BMRKR2", "STRATA2")) %>%
+ } |
||
| 678 | -+ | |||
| 1418 | +84x |
- #' append_topleft("counts")
+ lblvec <- df[[lblvar]] |
||
| 679 | -+ | |||
| 1419 | +84x |
- #'+ tab <- table(varvec, lblvec) |
||
| 680 | +1420 |
- #' tbl <- build_table(lyt, ex_adsl)+ |
||
| 681 | -+ | |||
| 1421 | +84x |
- #' tbl+ if (any(rowSums(tab > 0) > 1) || any(colSums(tab > 0) > 1)) {
|
||
| 682 | -+ | |||
| 1422 | +1x |
- #'+ stop(sprintf( |
||
| 683 | -+ | |||
| 1423 | +1x |
- #' # split_rows_by_cuts+ paste( |
||
| 684 | -+ | |||
| 1424 | +1x |
- #' lyt2 <- basic_table() %>%+ "There does not appear to be a 1-1", |
||
| 685 | -+ | |||
| 1425 | +1x |
- #' split_cols_by("ARM") %>%
+ "correspondence between values in split var", |
||
| 686 | -+ | |||
| 1426 | +1x |
- #' split_rows_by_cuts("AGE",
+ "[%s] and label var [%s]" |
||
| 687 | +1427 |
- #' split_label = "Age",+ ), |
||
| 688 | -+ | |||
| 1428 | +1x |
- #' cuts = c(0, 25, 35, 1000),+ var, lblvar |
||
| 689 | +1429 |
- #' cutlabels = c("young", "medium", "old")
+ )) |
||
| 690 | +1430 |
- #' ) %>%+ } |
||
| 691 | +1431 |
- #' analyze(c("BMRKR2", "STRATA2")) %>%
+
|
||
| 692 | -+ | |||
| 1432 | +83x |
- #' append_topleft("counts")
+ if (!is(lblvec, "character") && !is.factor(lblvec)) {
|
||
| 693 | -+ | |||
| 1433 | +! |
- #'+ message(sprintf( |
||
| 694 | -+ | |||
| 1434 | +! |
- #'+ paste( |
||
| 695 | -+ | |||
| 1435 | +! |
- #' tbl2 <- build_table(lyt2, ex_adsl)+ "Split label var [%s] was not character or", |
||
| 696 | -+ | |||
| 1436 | +! |
- #' tbl2+ "factor. Converting to factor" |
||
| 697 | +1437 |
- #'+ ), |
||
| 698 | -+ | |||
| 1438 | +! |
- #' # split_cols_by_quartiles+ var |
||
| 699 | +1439 |
- #'+ )) |
||
| 700 | -+ | |||
| 1440 | +! |
- #' lyt3 <- basic_table() %>%+ lblvec <- factor(lblvec) |
||
| 701 | -+ | |||
| 1441 | +! |
- #' split_cols_by("ARM") %>%
+ df[[lblvar]] <- lblvec |
||
| 702 | +1442 |
- #' split_cols_by_quartiles("AGE", split_label = "Age") %>%
+ } |
||
| 703 | +1443 |
- #' analyze(c("BMRKR2", "STRATA2")) %>%
+ } |
||
| 704 | +1444 |
- #' append_topleft("counts")
+
|
||
| 705 | -+ | |||
| 1445 | +555x |
- #'+ df |
||
| 706 | +1446 |
- #' tbl3 <- build_table(lyt3, ex_adsl)+ } |
||
| 707 | +1447 |
- #' tbl3+ |
||
| 708 | +1448 |
- #'+ fix_split_vars <- function(lyt, df, char_ok) {
|
||
| 709 | -+ | |||
| 1449 | +343x |
- #' # split_rows_by_quartiles+ df <- fix_split_vars_inner(clayout(lyt), df, char_ok = char_ok) |
||
| 710 | -+ | |||
| 1450 | +339x |
- #' lyt4 <- basic_table(show_colcounts = TRUE) %>%+ df <- fix_split_vars_inner(rlayout(lyt), df, char_ok = TRUE) |
||
| 711 | -+ | |||
| 1451 | +334x |
- #' split_cols_by("ARM") %>%
+ df |
||
| 712 | +1452 |
- #' split_rows_by_quartiles("AGE", split_label = "Age") %>%
+
|
||
| 713 | +1453 |
- #' analyze("BMRKR2") %>%
+ ## clyt <- clayout(lyt) |
||
| 714 | +1454 |
- #' append_topleft(c("Age Quartiles", " Counts BMRKR2"))
+ ## rlyt <- rlayout(lyt) |
||
| 715 | +1455 |
- #'+ |
||
| 716 | +1456 |
- #' tbl4 <- build_table(lyt4, ex_adsl)+ ## allspls <- unlist(list(clyt, rlyt)) |
||
| 717 | +1457 |
- #' tbl4+ ## VarLevelSplit includes sublclass VarLevWBaselineSplit |
||
| 718 | +1458 |
- #'+ } |
||
| 719 | +1459 |
- #' # split_cols_by_cutfun+ |
||
| 720 | +1460 |
- #' cutfun <- function(x) {
+ fix_split_vars_inner <- function(lyt, df, char_ok) {
|
||
| 721 | -+ | |||
| 1461 | +682x |
- #' cutpoints <- c(+ stopifnot(is(lyt, "PreDataAxisLayout")) |
||
| 722 | -+ | |||
| 1462 | +682x |
- #' min(x),+ allspls <- unlist(lyt) |
||
| 723 | -+ | |||
| 1463 | +682x |
- #' mean(x),+ varspls <- allspls[sapply(allspls, is, "VarLevelSplit")] |
||
| 724 | -+ | |||
| 1464 | +682x |
- #' max(x)+ unqvarinds <- !duplicated(sapply(varspls, spl_payload)) |
||
| 725 | -+ | |||
| 1465 | +682x |
- #' )+ unqvarspls <- varspls[unqvarinds] |
||
| 726 | -+ | |||
| 1466 | +564x |
- #'+ for (spl in unqvarspls) df <- fix_one_split_var(spl, df, char_ok = char_ok) |
||
| 727 | +1467 |
- #' names(cutpoints) <- c("", "Younger", "Older")
+
|
||
| 728 | -+ | |||
| 1468 | +673x |
- #' cutpoints+ df |
||
| 729 | +1469 |
- #' }+ } |
||
| 730 | +1470 |
- #'+ |
||
| 731 | +1471 |
- #' lyt5 <- basic_table() %>%+ # set_def_child_ord ---- |
||
| 732 | +1472 |
- #' split_cols_by_cutfun("AGE", cutfun = cutfun) %>%
+ ## the table is built by recursively splitting the data and doing things to each |
||
| 733 | +1473 |
- #' analyze("SEX")
+ ## piece. The order (or even values) of unique(df[[col]]) is not guaranteed to |
||
| 734 | +1474 |
- #'+ ## be the same in all the different partitions. This addresses that. |
||
| 735 | +1475 |
- #' tbl5 <- build_table(lyt5, ex_adsl)+ setGeneric( |
||
| 736 | +1476 |
- #' tbl5+ "set_def_child_ord", |
||
| 737 | -+ | |||
| 1477 | +3901x |
- #'+ function(lyt, df) standardGeneric("set_def_child_ord")
|
||
| 738 | +1478 |
- #' # split_rows_by_cutfun+ ) |
||
| 739 | +1479 |
- #' lyt6 <- basic_table() %>%+ |
||
| 740 | +1480 |
- #' split_cols_by("SEX") %>%
+ setMethod( |
||
| 741 | +1481 |
- #' split_rows_by_cutfun("AGE", cutfun = cutfun) %>%
+ "set_def_child_ord", "PreDataTableLayouts", |
||
| 742 | +1482 |
- #' analyze("BMRKR2")
+ function(lyt, df) {
|
||
| 743 | -+ | |||
| 1483 | +344x |
- #'+ clayout(lyt) <- set_def_child_ord(clayout(lyt), df) |
||
| 744 | -+ | |||
| 1484 | +343x |
- #' tbl6 <- build_table(lyt6, ex_adsl)+ rlayout(lyt) <- set_def_child_ord(rlayout(lyt), df) |
||
| 745 | -+ | |||
| 1485 | +343x |
- #' tbl6+ lyt |
||
| 746 | +1486 |
- #'+ } |
||
| 747 | +1487 |
- #' @author Gabriel Becker+ ) |
||
| 748 | +1488 |
- #' @export+ |
||
| 749 | +1489 |
- #' @rdname varcuts+ setMethod( |
||
| 750 | +1490 |
- split_cols_by_cuts <- function(lyt, var, cuts,+ "set_def_child_ord", "PreDataAxisLayout", |
||
| 751 | +1491 |
- cutlabels = NULL,+ function(lyt, df) {
|
||
| 752 | -+ | |||
| 1492 | +1021x |
- split_label = var,+ lyt@.Data <- lapply(lyt, set_def_child_ord, df = df) |
||
| 753 | -+ | |||
| 1493 | +1020x |
- nested = TRUE,+ lyt |
||
| 754 | +1494 |
- cumulative = FALSE,+ } |
||
| 755 | +1495 |
- show_colcounts = FALSE,+ ) |
||
| 756 | +1496 |
- colcount_format = NULL) {
+
|
||
| 757 | -3x | +|||
| 1497 | +
- spl <- make_static_cut_split(+ setMethod( |
|||
| 758 | -3x | +|||
| 1498 | +
- var = var,+ "set_def_child_ord", "SplitVector", |
|||
| 759 | -3x | +|||
| 1499 | +
- split_label = split_label,+ function(lyt, df) {
|
|||
| 760 | -3x | +1500 | +1061x |
- cuts = cuts,+ lyt[] <- lapply(lyt, set_def_child_ord, df = df) |
| 761 | -3x | +1501 | +1060x |
- cutlabels = cutlabels,+ lyt |
| 762 | -3x | +|||
| 1502 | +
- cumulative = cumulative,+ } |
|||
| 763 | -3x | +|||
| 1503 | +
- show_colcounts = show_colcounts,+ ) |
|||
| 764 | -3x | +|||
| 1504 | +
- colcount_format = colcount_format+ |
|||
| 765 | +1505 |
- )+ ## for most split types, don't do anything |
||
| 766 | +1506 |
- ## if(cumulative)+ ## becuause their ordering already isn't data-based |
||
| 767 | +1507 |
- ## spl = as(spl, "CumulativeCutSplit")+ setMethod( |
||
| 768 | -3x | +|||
| 1508 | +
- pos <- next_cpos(lyt, nested)+ "set_def_child_ord", "ANY", |
|||
| 769 | -3x | +1509 | +617x |
- split_cols(lyt, spl, pos)+ function(lyt, df) lyt |
| 770 | +1510 |
- }+ ) |
||
| 771 | +1511 | |||
| 772 | +1512 |
- #' @export+ setMethod( |
||
| 773 | +1513 |
- #' @rdname varcuts+ "set_def_child_ord", "VarLevelSplit", |
||
| 774 | +1514 |
- split_rows_by_cuts <- function(lyt, var, cuts,+ function(lyt, df) {
|
||
| 775 | -+ | |||
| 1515 | +841x |
- cutlabels = NULL,+ if (!is.null(spl_child_order(lyt))) {
|
||
| 776 | -+ | |||
| 1516 | +277x |
- split_label = var,+ return(lyt) |
||
| 777 | +1517 |
- format = NULL,+ } |
||
| 778 | +1518 |
- na_str = NA_character_,+ |
||
| 779 | -+ | |||
| 1519 | +564x |
- nested = TRUE,+ vec <- df[[spl_payload(lyt)]] |
||
| 780 | -+ | |||
| 1520 | +564x |
- cumulative = FALSE,+ vals <- if (is.factor(vec)) {
|
||
| 781 | -+ | |||
| 1521 | +404x |
- label_pos = "hidden",+ levels(vec) |
||
| 782 | +1522 |
- section_div = NA_character_) {
+ } else {
|
||
| 783 | -2x | +1523 | +160x |
- label_pos <- match.arg(label_pos, label_pos_values)+ unique(vec) |
| 784 | +1524 |
- ## VarStaticCutSplit(- |
- ||
| 785 | -2x | -
- spl <- make_static_cut_split(var, split_label,- |
- ||
| 786 | -2x | -
- cuts = cuts,+ } |
||
| 787 | -2x | +1525 | +564x |
- cutlabels = cutlabels,+ spl_child_order(lyt) <- vals |
| 788 | -2x | +1526 | +564x |
- split_format = format,+ lyt |
| 789 | -2x | +|||
| 1527 | +
- split_na_str = na_str,+ } |
|||
| 790 | -2x | +|||
| 1528 | +
- label_pos = label_pos,+ ) |
|||
| 791 | -2x | +|||
| 1529 | +
- cumulative = cumulative,+ |
|||
| 792 | -2x | +|||
| 1530 | +
- section_div = section_div+ setMethod( |
|||
| 793 | +1531 |
- )+ "set_def_child_ord", "VarLevWBaselineSplit", |
||
| 794 | +1532 |
- ## if(cumulative)+ function(lyt, df) {
|
||
| 795 | -+ | |||
| 1533 | +17x |
- ## spl = as(spl, "CumulativeCutSplit")+ bline <- spl_ref_group(lyt) |
||
| 796 | -2x | +1534 | +17x |
- pos <- next_rpos(lyt, nested)+ if (!is.null(spl_child_order(lyt)) && match(bline, spl_child_order(lyt), nomatch = -1) == 1L) {
|
| 797 | -2x | +1535 | +6x |
- split_rows(lyt, spl, pos)+ return(lyt) |
| 798 | +1536 |
- }+ } |
||
| 799 | +1537 | |||
| 800 | -+ | |||
| 1538 | +11x |
- #' @export+ if (!is.null(split_fun(lyt))) {
|
||
| 801 | +1539 |
- #' @rdname varcuts+ ## expensive but sadly necessary, I think |
||
| 802 | -+ | |||
| 1540 | +3x |
- split_cols_by_cutfun <- function(lyt, var,+ pinfo <- do_split(lyt, df, spl_context = context_df_row()) |
||
| 803 | -+ | |||
| 1541 | +3x |
- cutfun = qtile_cuts,+ vals <- sort(unlist(value_names(pinfo$values))) |
||
| 804 | +1542 |
- cutlabelfun = function(x) NULL,+ } else {
|
||
| 805 | -+ | |||
| 1543 | +8x |
- split_label = var,+ vec <- df[[spl_payload(lyt)]] |
||
| 806 | -+ | |||
| 1544 | +8x |
- nested = TRUE,+ vals <- if (is.factor(vec)) {
|
||
| 807 | -+ | |||
| 1545 | +5x |
- extra_args = list(),+ levels(vec) |
||
| 808 | +1546 |
- cumulative = FALSE,+ } else {
|
||
| 809 | -+ | |||
| 1547 | +3x |
- show_colcounts = FALSE,+ unique(vec) |
||
| 810 | +1548 |
- colcount_format = NULL) {
+ } |
||
| 811 | -3x | +|||
| 1549 | +
- spl <- VarDynCutSplit(var, split_label,+ } |
|||
| 812 | -3x | +1550 | +11x |
- cutfun = cutfun,+ if (!bline %in% vals) {
|
| 813 | -3x | +1551 | +1x |
- cutlabelfun = cutlabelfun,+ stop(paste0( |
| 814 | -3x | +1552 | +1x |
- extra_args = extra_args,+ 'Reference group "', bline, '"', " was not present in the levels of ", spl_payload(lyt), " in the data." |
| 815 | -3x | +|||
| 1553 | +
- cumulative = cumulative,+ )) |
|||
| 816 | -3x | +|||
| 1554 | +
- label_pos = "hidden",+ } |
|||
| 817 | -3x | +1555 | +10x |
- show_colcounts = show_colcounts,+ spl_child_order(lyt) <- vals |
| 818 | -3x | +1556 | +10x |
- colcount_format = colcount_format+ lyt |
| 819 | +1557 |
- )+ } |
||
| 820 | -3x | +|||
| 1558 | +
- pos <- next_cpos(lyt, nested)+ ) |
|||
| 821 | -3x | +|||
| 1559 | +
- split_cols(lyt, spl, pos)+ |
|||
| 822 | +1560 |
- }+ splitvec_to_coltree <- function(df, splvec, pos = NULL, |
||
| 823 | +1561 |
-
+ lvl = 1L, label = "", |
||
| 824 | +1562 |
- #' @export+ spl_context = context_df_row(cinfo = NULL), |
||
| 825 | +1563 |
- #' @rdname varcuts+ alt_counts_df = df, |
||
| 826 | +1564 |
- split_cols_by_quartiles <- function(lyt, var, split_label = var,+ global_cc_format) {
|
||
| 827 | -+ | |||
| 1565 | +1801x |
- nested = TRUE,+ stopifnot(+ |
+ ||
| 1566 | +1801x | +
+ lvl <= length(splvec) + 1L,+ |
+ ||
| 1567 | +1801x | +
+ is(splvec, "SplitVector") |
||
| 828 | +1568 |
- extra_args = list(),+ ) |
||
| 829 | +1569 |
- cumulative = FALSE,+ |
||
| 830 | +1570 |
- show_colcounts = FALSE,+ + |
+ ||
| 1571 | +1801x | +
+ if (lvl == length(splvec) + 1L) {
|
||
| 831 | +1572 |
- colcount_format = NULL) {
+ ## XXX this should be a LayoutColree I Think. |
||
| 832 | -2x | +1573 | +1181x |
- split_cols_by_cutfun(+ nm <- unlist(tail(value_names(pos), 1)) %||% "" |
| 833 | -2x | +1574 | +1181x |
- lyt = lyt,+ spl <- tail(pos_splits(pos), 1)[[1]] |
| 834 | -2x | +1575 | +1181x |
- var = var,+ fmt <- colcount_format(spl) %||% global_cc_format |
| 835 | -2x | +1576 | +1181x |
- split_label = split_label,+ LayoutColLeaf( |
| 836 | -2x | +1577 | +1181x |
- cutfun = qtile_cuts,+ lev = lvl - 1L, |
| 837 | -2x | +1578 | +1181x |
- cutlabelfun = function(x) {
+ label = label, |
| 838 | -2x | +1579 | +1181x |
- c(+ tpos = pos, |
| 839 | -2x | +1580 | +1181x |
- "[min, Q1]",+ name = nm, |
| 840 | -2x | +1581 | +1181x |
- "(Q1, Q2]",+ colcount = NROW(alt_counts_df), |
| 841 | -2x | +1582 | +1181x |
- "(Q2, Q3]",+ disp_ccounts = disp_ccounts(spl), |
| 842 | -2x | +1583 | +1181x |
- "(Q3, max]"+ colcount_format = fmt |
| 843 | +1584 |
- )+ ) |
||
| 844 | +1585 |
- },+ } else {
|
||
| 845 | -2x | +1586 | +620x |
- nested = nested,+ spl <- splvec[[lvl]] |
| 846 | -2x | +1587 | +620x |
- extra_args = extra_args,+ nm <- if (is.null(pos) || length(pos_splits(pos)) == 0) {
|
| 847 | -2x | +1588 | +383x |
- cumulative = cumulative,+ obj_name(spl) |
| 848 | -2x | +|||
| 1589 | +
- show_colcounts = show_colcounts,+ } else {
|
|||
| 849 | -2x | -
- colcount_format = colcount_format- |
- ||
| 850 | -+ | 1590 | +237x |
- )+ unlist(tail( |
| 851 | -+ | |||
| 1591 | +237x |
- ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts,+ value_names(pos), |
||
| 852 | -+ | |||
| 1592 | +237x |
- ## cutlabelfun = function(x) c("[min, Q1]",
+ 1 |
||
| 853 | +1593 |
- ## "(Q1, Q2]",+ )) |
||
| 854 | +1594 |
- ## "(Q2, Q3]",+ } |
||
| 855 | -+ | |||
| 1595 | +620x |
- ## "(Q3, max]"),+ rawpart <- do_split(spl, df, |
||
| 856 | -+ | |||
| 1596 | +620x |
- ## split_format = format,+ trim = FALSE, |
||
| 857 | -+ | |||
| 1597 | +620x |
- ## extra_args = extra_args,+ spl_context = spl_context |
||
| 858 | +1598 |
- ## cumulative = cumulative,+ ) |
||
| 859 | -+ | |||
| 1599 | +617x |
- ## label_pos = "hidden")+ datparts <- rawpart[["datasplit"]] |
||
| 860 | -+ | |||
| 1600 | +617x |
- ## pos = next_cpos(lyt, nested)+ vals <- rawpart[["values"]] |
||
| 861 | -+ | |||
| 1601 | +617x |
- ## split_cols(lyt, spl, pos)+ labs <- rawpart[["labels"]] |
||
| 862 | +1602 |
- }+ |
||
| 863 | -+ | |||
| 1603 | +617x |
-
+ force(alt_counts_df) |
||
| 864 | -+ | |||
| 1604 | +617x |
- #' @export+ kids <- mapply( |
||
| 865 | -+ | |||
| 1605 | +617x |
- #' @rdname varcuts+ function(dfpart, value, partlab) {
|
||
| 866 | +1606 |
- split_rows_by_quartiles <- function(lyt, var, split_label = var,+ ## we could pass subset expression in here but the spec |
||
| 867 | +1607 |
- format = NULL,+ ## currently doesn't call for it in column space |
||
| 868 | -+ | |||
| 1608 | +1422x |
- na_str = NA_character_,+ newprev <- context_df_row( |
||
| 869 | -+ | |||
| 1609 | +1422x |
- nested = TRUE,+ split = obj_name(spl), |
||
| 870 | -+ | |||
| 1610 | +1422x |
- child_labels = c("default", "visible", "hidden"),
+ value = value_names(value), |
||
| 871 | -+ | |||
| 1611 | +1422x |
- extra_args = list(),+ full_parent_df = list(dfpart), |
||
| 872 | -+ | |||
| 1612 | +1422x |
- cumulative = FALSE,+ cinfo = NULL |
||
| 873 | +1613 |
- indent_mod = 0L,+ ) |
||
| 874 | +1614 |
- label_pos = "hidden",+ ## subset expressions handled inside make_child_pos, |
||
| 875 | +1615 |
- section_div = NA_character_) {
+ ## value is (optionally, for the moment) carrying it around |
||
| 876 | -2x | +1616 | +1422x |
- split_rows_by_cutfun(+ newpos <- make_child_pos(pos, spl, value, partlab) |
| 877 | -2x | +1617 | +1422x |
- lyt = lyt,+ acdf_subset_expr <- make_subset_expr(spl, value) |
| 878 | -2x | +1618 | +1422x |
- var = var,+ new_acdf_subset <- try(eval(acdf_subset_expr, alt_counts_df), silent = TRUE) |
| 879 | -2x | +1619 | +1422x |
- split_label = split_label,+ if (is(new_acdf_subset, "try-error")) {
|
| 880 | -2x | +1620 | +4x |
- format = format,+ stop(sprintf( |
| 881 | -2x | +1621 | +4x |
- na_str = na_str,+ paste( |
| 882 | -2x | +1622 | +4x |
- cutfun = qtile_cuts,+ ifelse(identical(df, alt_counts_df), "df", "alt_counts_df"), |
| 883 | -2x | +1623 | +4x |
- cutlabelfun = function(x) {
+ "appears incompatible with column-split", |
| 884 | -2x | +1624 | +4x |
- c(+ "structure. Offending column subset", |
| 885 | -2x | +1625 | +4x |
- "[min, Q1]",+ "expression: %s\nOriginal error", |
| 886 | -2x | +1626 | +4x |
- "(Q1, Q2]",+ "message: %s" |
| 887 | -2x | +1627 | +4x |
- "(Q2, Q3]",+ ), deparse(acdf_subset_expr[[1]]), |
| 888 | -2x | +1628 | +4x |
- "(Q3, max]"+ conditionMessage(attr(new_acdf_subset, "condition")) |
| 889 | +1629 |
- )+ )) |
||
| 890 | +1630 |
- },- |
- ||
| 891 | -2x | -
- nested = nested,+ } |
||
| 892 | -2x | +|||
| 1631 | +
- child_labels = child_labels,+ |
|||
| 893 | -2x | +1632 | +1418x |
- extra_args = extra_args,+ splitvec_to_coltree(dfpart, splvec, newpos, |
| 894 | -2x | +1633 | +1418x |
- cumulative = cumulative,+ lvl + 1L, partlab, |
| 895 | -2x | +1634 | +1418x |
- indent_mod = indent_mod,+ spl_context = rbind(spl_context, newprev), |
| 896 | -2x | +1635 | +1418x |
- label_pos = label_pos,+ alt_counts_df = alt_counts_df[new_acdf_subset, , drop = FALSE], |
| 897 | -2x | -
- section_div = section_div- |
- ||
| 898 | -+ | 1636 | +1418x |
- )+ global_cc_format = global_cc_format |
| 899 | +1637 |
-
+ ) |
||
| 900 | +1638 |
- ## label_pos <- match.arg(label_pos, label_pos_values)+ }, |
||
| 901 | -+ | |||
| 1639 | +617x |
- ## spl = VarDynCutSplit(var, split_label, cutfun = qtile_cuts,+ dfpart = datparts, value = vals, |
||
| 902 | -+ | |||
| 1640 | +617x |
- ## cutlabelfun = ,+ partlab = labs, SIMPLIFY = FALSE |
||
| 903 | +1641 |
- ## split_format = format,+ ) |
||
| 904 | -+ | |||
| 1642 | +611x |
- ## child_labels = child_labels,+ disp_cc <- FALSE |
||
| 905 | -+ | |||
| 1643 | +611x |
- ## extra_args = extra_args,+ cc_format <- global_cc_format # this doesn't matter probably, but its technically more correct |
||
| 906 | -+ | |||
| 1644 | +611x |
- ## cumulative = cumulative,+ if (lvl > 1) {
|
||
| 907 | -+ | |||
| 1645 | +235x |
- ## indent_mod = indent_mod,+ disp_cc <- disp_ccounts(splvec[[lvl - 1]]) |
||
| 908 | -+ | |||
| 1646 | +235x |
- ## label_pos = label_pos)+ cc_format <- colcount_format(splvec[[lvl - 1]]) %||% global_cc_format |
||
| 909 | +1647 |
- ## pos = next_rpos(lyt, nested)+ } |
||
| 910 | +1648 |
- ## split_rows(lyt, spl, pos)+ |
||
| 911 | -+ | |||
| 1649 | +611x |
- }+ names(kids) <- value_names(vals) |
||
| 912 | -+ | |||
| 1650 | +611x |
-
+ LayoutColTree( |
||
| 913 | -+ | |||
| 1651 | +611x |
- qtile_cuts <- function(x) {
+ lev = lvl, label = label, |
||
| 914 | -6x | +1652 | +611x |
- ret <- quantile(x)+ spl = spl, |
| 915 | -6x | +1653 | +611x |
- names(ret) <- c(+ kids = kids, tpos = pos, |
| 916 | -+ | |||
| 1654 | +611x |
- "",+ name = nm, |
||
| 917 | -6x | +1655 | +611x |
- "1st qrtile",+ summary_function = content_fun(spl), |
| 918 | -6x | +1656 | +611x |
- "2nd qrtile",+ colcount = NROW(alt_counts_df), |
| 919 | -6x | +1657 | +611x |
- "3rd qrtile",+ disp_ccounts = disp_cc, |
| 920 | -6x | +1658 | +611x |
- "4th qrtile"+ colcount_format = cc_format |
| 921 | +1659 |
- )+ ) |
||
| 922 | -6x | +|||
| 1660 | +
- ret+ } |
|||
| 923 | +1661 |
} |
||
| 924 | +1662 | |||
| 925 | +1663 |
- #' @export+ # fix_analyze_vis ---- |
||
| 926 | +1664 |
- #' @rdname varcuts+ ## now that we know for sure the number of siblings |
||
| 927 | +1665 |
- split_rows_by_cutfun <- function(lyt, var,+ ## collaplse NAs to TRUE/FALSE for whether |
||
| 928 | +1666 |
- cutfun = qtile_cuts,+ ## labelrows should be visible for ElementaryTables |
||
| 929 | +1667 |
- cutlabelfun = function(x) NULL,+ ## generatead from analyzing a single variable |
||
| 930 | -+ | |||
| 1668 | +1052x |
- split_label = var,+ setGeneric("fix_analyze_vis", function(lyt) standardGeneric("fix_analyze_vis"))
|
||
| 931 | +1669 |
- format = NULL,+ |
||
| 932 | +1670 |
- na_str = NA_character_,+ setMethod( |
||
| 933 | +1671 |
- nested = TRUE,+ "fix_analyze_vis", "PreDataTableLayouts", |
||
| 934 | +1672 |
- child_labels = c("default", "visible", "hidden"),
+ function(lyt) {
|
||
| 935 | -+ | |||
| 1673 | +343x |
- extra_args = list(),+ rlayout(lyt) <- fix_analyze_vis(rlayout(lyt)) |
||
| 936 | -+ | |||
| 1674 | +343x |
- cumulative = FALSE,+ lyt |
||
| 937 | +1675 |
- indent_mod = 0L,+ } |
||
| 938 | +1676 |
- label_pos = "hidden",+ ) |
||
| 939 | +1677 |
- section_div = NA_character_) {
- |
- ||
| 940 | -2x | -
- label_pos <- match.arg(label_pos, label_pos_values)- |
- ||
| 941 | -2x | -
- child_labels <- match.arg(child_labels)- |
- ||
| 942 | -2x | -
- spl <- VarDynCutSplit(var, split_label,- |
- ||
| 943 | -2x | -
- cutfun = cutfun,- |
- ||
| 944 | -2x | -
- cutlabelfun = cutlabelfun,- |
- ||
| 945 | -2x | -
- split_format = format,+ |
||
| 946 | -2x | +|||
| 1678 | +
- split_na_str = na_str,+ setMethod( |
|||
| 947 | -2x | +|||
| 1679 | +
- child_labels = child_labels,+ "fix_analyze_vis", "PreDataRowLayout", |
|||
| 948 | -2x | +|||
| 1680 | +
- extra_args = extra_args,+ function(lyt) {
|
|||
| 949 | -2x | +1681 | +343x |
- cumulative = cumulative,+ splvecs <- lapply(lyt, fix_analyze_vis) |
| 950 | -2x | +1682 | +343x |
- indent_mod = indent_mod,+ PreDataRowLayout( |
| 951 | -2x | +1683 | +343x |
- label_pos = label_pos,+ root = root_spl(lyt), |
| 952 | -2x | +1684 | +343x |
- section_div = section_div+ lst = splvecs |
| 953 | +1685 |
- )- |
- ||
| 954 | -2x | -
- pos <- next_rpos(lyt, nested)- |
- ||
| 955 | -2x | -
- split_rows(lyt, spl, pos)+ ) |
||
| 956 | +1686 |
- }+ } |
||
| 957 | +1687 |
-
+ ) |
||
| 958 | +1688 |
- #' .spl_context within analysis and split functions+ |
||
| 959 | +1689 |
- #'+ setMethod( |
||
| 960 | +1690 |
- #' `.spl_context` is an optional parameter for any of rtables' special functions, i.e. `afun` (analysis function+ "fix_analyze_vis", "SplitVector", |
||
| 961 | +1691 |
- #' in [analyze()]), `cfun` (content or label function in [summarize_row_groups()]), or `split_fun` (e.g. for+ function(lyt) {
|
||
| 962 | -+ | |||
| 1692 | +366x |
- #' [split_rows_by()]).+ len <- length(lyt) |
||
| 963 | -+ | |||
| 1693 | +366x |
- #'+ if (len == 0) {
|
||
| 964 | -+ | |||
| 1694 | +14x |
- #' @details+ return(lyt) |
||
| 965 | +1695 |
- #' The `.spl_context` `data.frame` gives information about the subsets of data corresponding to the splits within+ } |
||
| 966 | -+ | |||
| 1696 | +352x |
- #' which the current `analyze` action is nested. Taken together, these correspond to the path that the resulting (set+ lastspl <- lyt[[len]] |
||
| 967 | -+ | |||
| 1697 | +352x |
- #' of) rows the analysis function is creating, although the information is in a slightly different form. Each split+ if (!(is(lastspl, "VAnalyzeSplit") || is(lastspl, "AnalyzeMultivar"))) {
|
||
| 968 | -+ | |||
| 1698 | +79x |
- #' (which correspond to groups of rows in the resulting table), as well as the initial 'root' "split", is represented+ return(lyt) |
||
| 969 | +1699 |
- #' via the following columns:+ } |
||
| 970 | +1700 |
- #'+ |
||
| 971 | -+ | |||
| 1701 | +273x |
- #' \describe{
+ if (is(lastspl, "VAnalyzeSplit") && is.na(labelrow_visible(lastspl))) {
|
||
| 972 | +1702 |
- #' \item{split}{The name of the split (often the variable being split).}
+ ## labelrow_visible(lastspl) = FALSE |
||
| 973 | -+ | |||
| 1703 | +267x |
- #' \item{value}{The string representation of the value at that split (`split`).}
+ labelrow_visible(lastspl) <- "hidden" |
||
| 974 | -+ | |||
| 1704 | +6x |
- #' \item{full_parent_df}{A `data.frame` containing the full data (i.e. across all columns) corresponding to the path
+ } else if (is(lastspl, "AnalyzeMultiVar")) {
|
||
| 975 | -+ | |||
| 1705 | +! |
- #' defined by the combination of `split` and `value` of this row *and all rows above this row*.}+ pld <- spl_payload(lastspl) |
||
| 976 | -+ | |||
| 1706 | +! |
- #' \item{all_cols_n}{The number of observations corresponding to the row grouping (union of all columns).}
+ newpld <- lapply(pld, function(sp, havesibs) {
|
||
| 977 | -+ | |||
| 1707 | +! |
- #' \item{column for each column in the table structure (*row-split and analyze contexts only*)}{These list columns
+ if (is.na(labelrow_visible(sp))) {
|
||
| 978 | -+ | |||
| 1708 | +! |
- #' (named the same as `names(col_exprs(tab))`) contain logical vectors corresponding to the subset of this row's+ labelrow_visible(sp) <- havesibs |
||
| 979 | +1709 |
- #' `full_parent_df` corresponding to the column.}+ } |
||
| 980 | -+ | |||
| 1710 | +! |
- #' \item{cur_col_id}{Identifier of the current column. This may be an internal name, constructed by pasting the
+ }, havesibs = len > 1) |
||
| 981 | -+ | |||
| 1711 | +! |
- #' column path together.}+ spl_payload(lastspl) <- newpld |
||
| 982 | +1712 |
- #' \item{cur_col_subset}{List column containing logical vectors indicating the subset of this row's `full_parent_df`
+ ## pretty sure this isn't needed... |
||
| 983 | -+ | |||
| 1713 | +! |
- #' for the column currently being created by the analysis function.}+ if (is.na(label_kids(lastspl))) {
|
||
| 984 | -+ | |||
| 1714 | +! |
- #' \item{cur_col_expr}{List of current column expression. This may be used to filter `.alt_df_row`, or any external
+ label_kids(lastspl) <- len > 1 |
||
| 985 | +1715 |
- #' data, by column. Filtering `.alt_df_row` by columns produces `.alt_df`.}+ } |
||
| 986 | +1716 |
- #' \item{cur_col_n}{Integer column containing the observation counts for that split.}
+ } |
||
| 987 | -+ | |||
| 1717 | +273x |
- #' \item{cur_col_split}{Current column split names. This is recovered from the current column path.}
+ lyt[[len]] <- lastspl |
||
| 988 | -+ | |||
| 1718 | +273x |
- #' \item{cur_col_split_val}{Current column split values. This is recovered from the current column path.}
+ lyt |
||
| 989 | +1719 |
- #' }+ } |
||
| 990 | +1720 |
- #'+ ) |
||
| 991 | +1721 |
- #' @note+ |
||
| 992 | +1722 |
- #' Within analysis functions that accept `.spl_context`, the `all_cols_n` and `cur_col_n` columns of the data frame+ # check_afun_cfun_params ---- |
||
| 993 | +1723 |
- #' will contain the 'true' observation counts corresponding to the row-group and row-group x column subsets of the+ |
||
| 994 | +1724 |
- #' data. These numbers will not, and currently cannot, reflect alternate column observation counts provided by the+ # This checks if the input params are used anywhere in cfun/afun |
||
| 995 | +1725 |
- #' `alt_counts_df`, `col_counts` or `col_total` arguments to [build_table()].+ setGeneric("check_afun_cfun_params", function(lyt, params) {
|
||
| 996 | -+ | |||
| 1726 | +3266x |
- #'+ standardGeneric("check_afun_cfun_params")
|
||
| 997 | +1727 |
- #' @name spl_context+ }) |
||
| 998 | +1728 |
- NULL+ |
||
| 999 | +1729 |
-
+ setMethod( |
||
| 1000 | +1730 |
- #' Additional parameters within analysis and content functions (`afun`/`cfun`)+ "check_afun_cfun_params", "PreDataTableLayouts", |
||
| 1001 | +1731 |
- #'+ function(lyt, params) {
|
||
| 1002 | +1732 |
- #' @description+ # clayout does not have analysis functions |
||
| 1003 | -+ | |||
| 1733 | +334x |
- #' It is possible to add specific parameters to `afun` and `cfun`, in [analyze()] and [summarize_row_groups()],+ check_afun_cfun_params(rlayout(lyt), params) |
||
| 1004 | +1734 |
- #' respectively. These parameters grant access to relevant information like the row split structure (see+ } |
||
| 1005 | +1735 |
- #' [spl_context]) and the predefined baseline (`.ref_group`).+ ) |
||
| 1006 | +1736 |
- #'+ |
||
| 1007 | +1737 |
- #' @details+ setMethod( |
||
| 1008 | +1738 |
- #' We list and describe all the parameters that can be added to a custom analysis function below:+ "check_afun_cfun_params", "PreDataRowLayout", |
||
| 1009 | +1739 |
- #'+ function(lyt, params) {
|
||
| 1010 | -+ | |||
| 1740 | +334x |
- #' \describe{
+ ro_spl_parm_l <- check_afun_cfun_params(root_spl(lyt), params) |
||
| 1011 | -+ | |||
| 1741 | +334x |
- #' \item{.N_col}{Column-wise N (column count) for the full column being tabulated within.}
+ r_spl_parm_l <- lapply(lyt, check_afun_cfun_params, params = params) |
||
| 1012 | -+ | |||
| 1742 | +334x |
- #' \item{.N_total}{Overall N (all observation count, defined as sum of column counts) for the tabulation.}
+ Reduce(`|`, c(list(ro_spl_parm_l), r_spl_parm_l)) |
||
| 1013 | +1743 |
- #' \item{.N_row}{Row-wise N (row group count) for the group of observations being analyzed (i.e. with no
+ } |
||
| 1014 | +1744 |
- #' column-based subsetting).}+ ) |
||
| 1015 | +1745 |
- #' \item{.df_row}{`data.frame` for observations in the row group being analyzed (i.e. with no column-based
+
|
||
| 1016 | +1746 |
- #' subsetting).}+ # Main function for checking parameters |
||
| 1017 | +1747 |
- #' \item{.var}{Variable being analyzed.}
+ setMethod( |
||
| 1018 | +1748 |
- #' \item{.ref_group}{`data.frame` or vector of subset corresponding to the `ref_group` column including subsetting
+ "check_afun_cfun_params", "SplitVector", |
||
| 1019 | +1749 |
- #' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.}+ function(lyt, params) {
|
||
| 1020 | -+ | |||
| 1750 | +782x |
- #' \item{.ref_full}{`data.frame` or vector of subset corresponding to the `ref_group` column without subsetting
+ param_l <- lapply(lyt, check_afun_cfun_params, params = params) |
||
| 1021 | -+ | |||
| 1751 | +782x |
- #' defined by row-splitting. Only required/meaningful if a `ref_group` column has been defined.}+ Reduce(`|`, param_l) |
||
| 1022 | +1752 |
- #' \item{.in_ref_col}{Boolean indicating if calculation is done for cells within the reference column.}
+ } |
||
| 1023 | +1753 |
- #' \item{.spl_context}{`data.frame` where each row gives information about a previous 'ancestor' split state.
+ ) |
||
| 1024 | +1754 |
- #' See [spl_context].}+ |
||
| 1025 | +1755 |
- #' \item{.alt_df_row}{`data.frame`, i.e. the `alt_count_df` after row splitting. It can be used with
+ # Helper function for check_afun_cfun_params |
||
| 1026 | +1756 |
- #' `.all_col_exprs` and `.spl_context` information to retrieve current faceting, but for `alt_count_df`.+ .afun_cfun_switch <- function(spl_i) {
|
||
| 1027 | -+ | |||
| 1757 | +1815x |
- #' It can be an empty table if all the entries are filtered out.}+ if (is(spl_i, "VAnalyzeSplit")) {
|
||
| 1028 | -+ | |||
| 1758 | +594x |
- #' \item{.alt_df}{`data.frame`, `.alt_df_row` but filtered by columns expression. This data present the same
+ analysis_fun(spl_i) |
||
| 1029 | +1759 |
- #' faceting of main data `df`. This also filters `NA`s out if related parameters are set to do so (e.g. `inclNAs`+ } else {
|
||
| 1030 | -+ | |||
| 1760 | +1221x |
- #' in [analyze()]). Similarly to `.alt_df_row`, it can be an empty table if all the entries are filtered out.}+ content_fun(spl_i) |
||
| 1031 | +1761 |
- #' \item{.all_col_exprs}{List of expressions. Each of them represents a different column splitting.}
+ } |
||
| 1032 | +1762 |
- #' \item{.all_col_counts}{Vector of integers. Each of them represents the global count for each column. It differs
+ } |
||
| 1033 | +1763 |
- #' if `alt_counts_df` is used (see [build_table()]).}+ |
||
| 1034 | +1764 |
- #' }+ # Extreme case that happens only when using add_existing_table |
||
| 1035 | +1765 |
- #'+ setMethod( |
||
| 1036 | +1766 |
- #' @note If any of these formals is specified incorrectly or not present in the tabulation machinery, it will be+ "check_afun_cfun_params", "VTableTree", |
||
| 1037 | +1767 |
- #' treated as if missing. For example, `.ref_group` will be missing if no baseline is previously defined during+ function(lyt, params) {
|
||
| 1038 | -+ | |||
| 1768 | +1x |
- #' data splitting (via `ref_group` parameters in, e.g., [split_rows_by()]). Similarly, if no `alt_counts_df` is+ setNames(logical(length(params)), params) # All FALSE |
||
| 1039 | +1769 |
- #' provided to [build_table()], `.alt_df_row` and `.alt_df` will not be present.+ } |
||
| 1040 | +1770 |
- #'+ ) |
||
| 1041 | +1771 |
- #' @name additional_fun_params+ |
||
| 1042 | +1772 |
- NULL+ setMethod( |
||
| 1043 | +1773 |
-
+ "check_afun_cfun_params", "Split", |
||
| 1044 | +1774 |
- #' Generate rows analyzing variables across columns+ function(lyt, params) {
|
||
| 1045 | +1775 |
- #'+ # Extract function in the split |
||
| 1046 | -+ | |||
| 1776 | +1815x |
- #' Adding *analyzed variables* to our table layout defines the primary tabulation to be performed. We do this by+ fnc <- .afun_cfun_switch(lyt) |
||
| 1047 | +1777 |
- #' adding calls to `analyze` and/or [analyze_colvars()] into our layout pipeline. As with adding further splitting,+ |
||
| 1048 | +1778 |
- #' the tabulation will occur at the current/next level of nesting by default.+ # For each parameter, check if it is called |
||
| 1049 | -+ | |||
| 1779 | +1815x |
- #'+ sapply(params, function(pai) any(unlist(func_takes(fnc, pai)))) |
||
| 1050 | +1780 |
- #' @inheritParams lyt_args+ } |
||
| 1051 | +1781 |
- #'+ ) |
||
| 1052 | +1782 |
- #' @inherit split_cols_by return+ |
||
| 1053 | +1783 |
- #'+ # Helper functions ---- |
||
| 1054 | +1784 |
- #' @details+ |
||
| 1055 | -+ | |||
| 1785 | +231x |
- #' When non-`NULL`, `format` is used to specify formats for all generated rows, and can be a character vector, a+ count <- function(df, ...) NROW(df) |
||
| 1056 | +1786 |
- #' function, or a list of functions. It will be repped out to the number of rows once this is calculated during the+ |
||
| 1057 | +1787 |
- #' tabulation process, but will be overridden by formats specified within `rcell` calls in `afun`.+ guess_format <- function(val) {
|
||
| 1058 | -+ | |||
| 1788 | +1054x |
- #'+ if (length(val) == 1) {
|
||
| 1059 | -+ | |||
| 1789 | +1042x |
- #' The analysis function (`afun`) should take as its first parameter either `x` or `df`. Whichever of these the+ if (is.integer(val) || !is.numeric(val)) {
|
||
| 1060 | -+ | |||
| 1790 | +226x |
- #' function accepts will change the behavior when tabulation is performed as follows:+ "xx" |
||
| 1061 | +1791 |
- #'+ } else {
|
||
| 1062 | -+ | |||
| 1792 | +816x |
- #' - If `afun`'s first parameter is `x`, it will receive the corresponding subset *vector* of data from the relevant+ "xx.xx" |
||
| 1063 | +1793 |
- #' column (from `var` here) of the raw data being used to build the table.+ } |
||
| 1064 | -+ | |||
| 1794 | +12x |
- #' - If `afun`'s first parameter is `df`, it will receive the corresponding subset *data frame* (i.e. all columns) of+ } else if (length(val) == 2) {
|
||
| 1065 | -+ | |||
| 1795 | +12x |
- #' the raw data being tabulated.+ "xx.x / xx.x" |
||
| 1066 | -+ | |||
| 1796 | +! |
- #'+ } else if (length(val) == 3) {
|
||
| 1067 | -+ | |||
| 1797 | +! |
- #' In addition to differentiation on the first argument, the analysis function can optionally accept a number of+ "xx.x (xx.x - xx.x)" |
||
| 1068 | +1798 |
- #' other parameters which, *if and only if* present in the formals, will be passed to the function by the tabulation+ } else {
|
||
| 1069 | -+ | |||
| 1799 | +! |
- #' machinery. These are listed and described in [additional_fun_params].+ stop("got value of length > 3")
|
||
| 1070 | +1800 |
- #'+ } |
||
| 1071 | +1801 |
- #' @note None of the arguments described in the Details section can be overridden via `extra_args` or when calling+ } |
||
| 1072 | +1802 |
- #' [make_afun()]. `.N_col` and `.N_total` can be overridden via the `col_counts` argument to [build_table()].+ |
||
| 1073 | +1803 |
- #' Alternative values for the others must be calculated within `afun` based on a combination of extra arguments and+ .quick_afun <- function(afun, lbls) {
|
||
| 1074 | -+ | |||
| 1804 | +14x |
- #' the unmodified values provided by the tabulation framework.+ if (.takes_df(afun)) {
|
||
| 1075 | -+ | |||
| 1805 | +5x |
- #'+ function(df, .spl_context, ...) {
|
||
| 1076 | -+ | |||
| 1806 | +226x |
- #' @examples+ if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
|
||
| 1077 | -+ | |||
| 1807 | +222x |
- #' lyt <- basic_table() %>%+ lbls <- tail(.spl_context$value, 1) |
||
| 1078 | +1808 |
- #' split_cols_by("ARM") %>%
+ } |
||
| 1079 | -+ | |||
| 1809 | +226x |
- #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
+ if (".spl_context" %in% names(formals(afun))) {
|
||
| 1080 | -+ | |||
| 1810 | +! |
- #' lyt+ res <- afun(df = df, .spl_context = .spl_context, ...) |
||
| 1081 | +1811 |
- #'+ } else {
|
||
| 1082 | -+ | |||
| 1812 | +226x |
- #' tbl <- build_table(lyt, DM)+ res <- afun(df = df, ...) |
||
| 1083 | +1813 |
- #' tbl+ } |
||
| 1084 | -+ | |||
| 1814 | +226x |
- #'+ if (is(res, "RowsVerticalSection")) {
|
||
| 1085 | -+ | |||
| 1815 | +! |
- #' lyt2 <- basic_table() %>%+ ret <- res |
||
| 1086 | +1816 |
- #' split_cols_by("Species") %>%
+ } else {
|
||
| 1087 | -+ | |||
| 1817 | +226x |
- #' analyze(head(names(iris), -1), afun = function(x) {
+ if (!is.list(res)) {
|
||
| 1088 | -+ | |||
| 1818 | +226x |
- #' list(+ ret <- rcell(res, label = lbls, format = guess_format(res)) |
||
| 1089 | +1819 |
- #' "mean / sd" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"),+ } else {
|
||
| 1090 | -+ | |||
| 1820 | +! |
- #' "range" = rcell(diff(range(x)), format = "xx.xx")+ if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
|
||
| 1091 | -+ | |||
| 1821 | +! |
- #' )+ names(res) <- lbls |
||
| 1092 | +1822 |
- #' })+ } |
||
| 1093 | -+ | |||
| 1823 | +! |
- #' lyt2+ ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, "")) |
||
| 1094 | +1824 |
- #'+ } |
||
| 1095 | +1825 |
- #' tbl2 <- build_table(lyt2, iris)+ } |
||
| 1096 | -+ | |||
| 1826 | +226x |
- #' tbl2+ ret |
||
| 1097 | +1827 |
- #'+ } |
||
| 1098 | +1828 |
- #' @author Gabriel Becker+ } else {
|
||
| 1099 | -+ | |||
| 1829 | +9x |
- #' @export+ function(x, .spl_context, ...) {
|
||
| 1100 | -+ | |||
| 1830 | +387x |
- analyze <- function(lyt,+ if (!is.null(lbls) && length(lbls) == 1 && is.na(lbls)) {
|
||
| 1101 | -+ | |||
| 1831 | +225x |
- vars,+ lbls <- tail(.spl_context$value, 1) |
||
| 1102 | +1832 |
- afun = simple_analysis,+ } |
||
| 1103 | -+ | |||
| 1833 | +387x |
- var_labels = vars,+ if (".spl_context" %in% names(formals(afun))) {
|
||
| 1104 | -+ | |||
| 1834 | +! |
- table_names = vars,+ res <- afun(x = x, .spl_context = .spl_context, ...) |
||
| 1105 | +1835 |
- format = NULL,+ } else {
|
||
| 1106 | -+ | |||
| 1836 | +387x |
- na_str = NA_character_,+ res <- afun(x = x, ...) |
||
| 1107 | +1837 |
- nested = TRUE,+ } |
||
| 1108 | -+ | |||
| 1838 | +387x |
- ## can't name this na_rm symbol conflict with possible afuns!!+ if (is(res, "RowsVerticalSection")) {
|
||
| 1109 | -+ | |||
| 1839 | +! |
- inclNAs = FALSE,+ ret <- res |
||
| 1110 | +1840 |
- extra_args = list(),+ } else {
|
||
| 1111 | -+ | |||
| 1841 | +387x |
- show_labels = c("default", "visible", "hidden"),
+ if (!is.list(res)) {
|
||
| 1112 | -+ | |||
| 1842 | +297x |
- indent_mod = 0L,+ ret <- rcell(res, label = lbls, format = guess_format(res)) |
||
| 1113 | +1843 |
- section_div = NA_character_) {
+ } else {
|
||
| 1114 | -305x | +1844 | +90x |
- show_labels <- match.arg(show_labels)+ if (!is.null(lbls) && length(lbls) == length(res) && all(!is.na(lbls))) {
|
| 1115 | -305x | +1845 | +9x |
- subafun <- substitute(afun)+ names(res) <- lbls |
| 1116 | +1846 |
- # R treats a single NA value as a logical atomic. The below+ }+ |
+ ||
| 1847 | +90x | +
+ ret <- in_rows(.list = res, .labels = names(res), .formats = vapply(res, guess_format, "")) |
||
| 1117 | +1848 |
- # maps all the NAs in `var_labels` to NA_character_ required by `Split`+ } |
||
| 1118 | +1849 |
- # and avoids the error when `var_labels` is just c(NA).+ } |
||
| 1119 | -305x | +1850 | +387x |
- var_labels <- vapply(var_labels, function(label) ifelse(is.na(label), NA_character_, label), character(1))+ ret |
| 1120 | +1851 |
- if (+ } |
||
| 1121 | -305x | +|||
| 1852 | +
- is.name(subafun) &&+ } |
|||
| 1122 | -305x | +|||
| 1853 | +
- is.function(afun) &&+ } |
|||
| 1123 | +1854 |
- ## this is gross. basically testing+ |
||
| 1124 | +1855 |
- ## if the symbol we have corresponds+ # qtable ---- |
||
| 1125 | +1856 |
- ## in some meaningful way to the function+ |
||
| 1126 | +1857 |
- ## we will be calling.+ n_cells_res <- function(res) {
|
||
| 1127 | -305x | +1858 | +8x |
- identical(+ ans <- 1L |
| 1128 | -305x | +1859 | +8x |
- mget(+ if (is.list(res)) {
|
| 1129 | -305x | +1860 | +4x |
- as.character(subafun),+ ans <- length(res) |
| 1130 | -305x | +1861 | +4x |
- mode = "function",+ } else if (is(res, "RowsVerticalSection")) {
|
| 1131 | -305x | +|||
| 1862 | +! |
- ifnotfound = list(NULL),+ ans <- length(res$values) |
||
| 1132 | -305x | +|||
| 1863 | +
- inherits = TRUE+ } # XXX penetrating the abstraction |
|||
| 1133 | -305x | +1864 | +8x |
- )[[1]], afun+ ans |
| 1134 | +1865 |
- )+ } |
||
| 1135 | +1866 |
- ) {
+
|
||
| 1136 | -173x | +|||
| 1867 | +
- defrowlab <- as.character(subafun)+ #' Generalized frequency table |
|||
| 1137 | +1868 |
- } else {
+ #' |
||
| 1138 | -132x | +|||
| 1869 | +
- defrowlab <- var_labels+ #' This function provides a convenience interface for generating generalizations of a 2-way frequency table. Row and |
|||
| 1139 | +1870 |
- }+ #' column space can be facetted by variables, and an analysis function can be specified. The function then builds a |
||
| 1140 | +1871 |
-
+ #' layout with the specified layout and applies it to the data provided. |
||
| 1141 | -305x | +|||
| 1872 | +
- spl <- AnalyzeMultiVars(vars, var_labels,+ #' |
|||
| 1142 | -305x | +|||
| 1873 | +
- afun = afun,+ #' @inheritParams constr_args |
|||
| 1143 | -305x | +|||
| 1874 | +
- split_format = format,+ #' @inheritParams basic_table |
|||
| 1144 | -305x | +|||
| 1875 | +
- split_na_str = na_str,+ #' @param row_vars (`character`)\cr the names of variables to be used in row facetting. |
|||
| 1145 | -305x | +|||
| 1876 | +
- defrowlab = defrowlab,+ #' @param col_vars (`character`)\cr the names of variables to be used in column facetting. |
|||
| 1146 | -305x | +|||
| 1877 | +
- inclNAs = inclNAs,+ #' @param data (`data.frame`)\cr the data to tabulate. |
|||
| 1147 | -305x | +|||
| 1878 | +
- extra_args = extra_args,+ #' @param avar (`string`)\cr the variable to be analyzed. Defaults to the first variable in `data`. |
|||
| 1148 | -305x | +|||
| 1879 | +
- indent_mod = indent_mod,+ #' @param row_labels (`character` or `NULL`)\cr row label(s) which should be applied to the analysis rows. Length must |
|||
| 1149 | -305x | +|||
| 1880 | +
- child_names = table_names,+ #' match the number of rows generated by `afun`. |
|||
| 1150 | -305x | +|||
| 1881 | +
- child_labels = show_labels,+ #' @param afun (`function`)\cr the function to generate the analysis row cell values. This can be a proper analysis |
|||
| 1151 | -305x | +|||
| 1882 | +
- section_div = section_div+ #' function, or a function which returns a vector or list. Vectors are taken as multi-valued single cells, whereas |
|||
| 1152 | +1883 |
- )+ #' lists are interpreted as multiple cells. |
||
| 1153 | +1884 |
-
+ #' @param drop_levels (`flag`)\cr whether unobserved factor levels should be dropped during facetting. Defaults to |
||
| 1154 | -305x | +|||
| 1885 | +
- if (nested && (is(last_rowsplit(lyt), "VAnalyzeSplit") || is(last_rowsplit(lyt), "AnalyzeMultiVars"))) {
+ #' `TRUE`. |
|||
| 1155 | -26x | +|||
| 1886 | +
- cmpnd_last_rowsplit(lyt, spl, AnalyzeMultiVars)+ #' @param summarize_groups (`flag`)\cr whether each level of nesting should include marginal summary rows. Defaults to |
|||
| 1156 | +1887 |
- } else {
+ #' `FALSE`. |
||
| 1157 | +1888 |
- ## analysis compounding now done in split_rows+ #' @param ... additional arguments passed to `afun`. |
||
| 1158 | -277x | +|||
| 1889 | +
- pos <- next_rpos(lyt, nested)+ #' @param .default_rlabel (`string`)\cr this is an implementation detail that should not be set by end users. |
|||
| 1159 | -277x | +|||
| 1890 | +
- split_rows(lyt, spl, pos)+ #' |
|||
| 1160 | +1891 |
- }+ #' @details |
||
| 1161 | +1892 |
- }+ #' This function creates a table with a single top-level structure in both row and column dimensions involving faceting |
||
| 1162 | +1893 | ++ |
+ #' by 0 or more variables in each dimension.+ |
+ |
| 1894 | ++ |
+ #'+ |
+ ||
| 1895 |
-
+ #' The display of the table depends on certain details of the tabulation. In the case of an `afun` which returns a |
|||
| 1163 | +1896 |
- get_acolvar_name <- function(lyt) {
+ #' single cell's contents (either a scalar or a vector of 2 or 3 elements), the label rows for the deepest-nested row |
||
| 1164 | +1897 |
- ## clyt <- clayout(lyt)+ #' facets will be hidden and the labels used there will be used as the analysis row labels. In the case of an `afun` |
||
| 1165 | +1898 |
- ## stopifnot(length(clyt) == 1L)+ #' which returns a list (corresponding to multiple cells), the names of the list will be used as the analysis row |
||
| 1166 | +1899 |
- ## vec = clyt[[1]]+ #' labels and the deepest-nested facet row labels will be visible. |
||
| 1167 | +1900 |
- ## vcls = vapply(vec, class, "")+ #' |
||
| 1168 | +1901 |
- ## pos = max(which(vcls == "MultiVarSplit"))+ #' The table will be annotated in the top-left area with an informative label displaying the analysis variable |
||
| 1169 | -22x | +|||
| 1902 | +
- paste(c("ac", get_acolvar_vars(lyt)), collapse = "_")
+ #' (`avar`), if set, and the function used (captured via substitute) where possible, or 'count' if not. One exception |
|||
| 1170 | +1903 |
- }+ #' where the user may directly modify the top-left area (via `row_labels`) is the case of a table with row facets and |
||
| 1171 | +1904 |
-
+ #' an `afun` which returns a single row. |
||
| 1172 | +1905 |
- get_acolvar_vars <- function(lyt) {
+ #' |
||
| 1173 | -35x | +|||
| 1906 | +
- clyt <- clayout(lyt)+ #' @return |
|||
| 1174 | -35x | +|||
| 1907 | +
- stopifnot(length(clyt) == 1L)+ #' * `qtable` returns a built `TableTree` object representing the desired table |
|||
| 1175 | -35x | +|||
| 1908 | +
- vec <- clyt[[1]]+ #' * `qtable_layout` returns a `PreDataTableLayouts` object declaring the structure of the desired table, suitable for |
|||
| 1176 | -35x | +|||
| 1909 | +
- vcls <- vapply(vec, class, "")+ #' passing to [build_table()]. |
|||
| 1177 | -35x | +|||
| 1910 | +
- pos <- which(vcls == "MultiVarSplit")+ #' |
|||
| 1178 | -35x | +|||
| 1911 | +
- if (length(pos) > 0) {
+ #' @examples |
|||
| 1179 | -35x | +|||
| 1912 | +
- spl_payload(vec[[pos]])+ #' qtable(ex_adsl) |
|||
| 1180 | +1913 |
- } else {
+ #' qtable(ex_adsl, row_vars = "ARM") |
||
| 1181 | -! | +|||
| 1914 | +
- "non_multivar"+ #' qtable(ex_adsl, col_vars = "ARM") |
|||
| 1182 | +1915 |
- }+ #' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM") |
||
| 1183 | +1916 |
- }+ #' qtable(ex_adsl, row_vars = c("COUNTRY", "SEX"), col_vars = c("ARM", "STRATA1"))
|
||
| 1184 | +1917 |
-
+ #' qtable(ex_adsl, |
||
| 1185 | +1918 |
- #' Generate rows analyzing different variables across columns+ #' row_vars = c("COUNTRY", "SEX"),
|
||
| 1186 | +1919 |
- #'+ #' col_vars = c("ARM", "STRATA1"), avar = "AGE", afun = mean
|
||
| 1187 | +1920 |
- #' @inheritParams lyt_args+ #' ) |
||
| 1188 | +1921 |
- #' @param afun (`function` or `list`)\cr function(s) to be used to calculate the values in each column. The list+ #' summary_list <- function(x, ...) as.list(summary(x)) |
||
| 1189 | +1922 |
- #' will be repped out as needed and matched by position with the columns during tabulation. This functions+ #' qtable(ex_adsl, row_vars = "SEX", col_vars = "ARM", avar = "AGE", afun = summary_list) |
||
| 1190 | +1923 |
- #' accepts the same parameters as [analyze()] like `afun` and `format`. For further information see+ #' suppressWarnings(qtable(ex_adsl, |
||
| 1191 | +1924 |
- #' [additional_fun_params].+ #' row_vars = "SEX", |
||
| 1192 | +1925 |
- #'+ #' col_vars = "ARM", avar = "AGE", afun = range |
||
| 1193 | +1926 |
- #' @inherit split_cols_by return+ #' )) |
||
| 1194 | +1927 |
#' |
||
| 1195 | +1928 |
- #' @seealso [split_cols_by_multivar()]+ #' @export |
||
| 1196 | +1929 |
- #'+ qtable_layout <- function(data, |
||
| 1197 | +1930 |
- #' @examplesIf require(dplyr)+ row_vars = character(), |
||
| 1198 | +1931 |
- #' library(dplyr)+ col_vars = character(), |
||
| 1199 | +1932 |
- #'+ avar = NULL, |
||
| 1200 | +1933 |
- #' ANL <- DM %>% mutate(value = rnorm(n()), pctdiff = runif(n()))+ row_labels = NULL, |
||
| 1201 | +1934 |
- #'+ afun = NULL, |
||
| 1202 | +1935 |
- #' ## toy example where we take the mean of the first variable and the+ summarize_groups = FALSE, |
||
| 1203 | +1936 |
- #' ## count of >.5 for the second.+ title = "", |
||
| 1204 | +1937 |
- #' colfuns <- list(+ subtitles = character(), |
||
| 1205 | +1938 |
- #' function(x) rcell(mean(x), format = "xx.x"),+ main_footer = character(), |
||
| 1206 | +1939 |
- #' function(x) rcell(sum(x > .5), format = "xx")+ prov_footer = character(), |
||
| 1207 | +1940 |
- #' )+ show_colcounts = TRUE, |
||
| 1208 | +1941 |
- #'+ drop_levels = TRUE, |
||
| 1209 | +1942 |
- #' lyt <- basic_table() %>%+ ..., |
||
| 1210 | +1943 |
- #' split_cols_by("ARM") %>%
+ .default_rlabel = NULL) {
|
||
| 1211 | -+ | |||
| 1944 | +16x |
- #' split_cols_by_multivar(c("value", "pctdiff")) %>%
+ subafun <- substitute(afun) |
||
| 1212 | -+ | |||
| 1945 | +16x |
- #' split_rows_by("RACE",
+ if (!is.null(.default_rlabel)) {
|
||
| 1213 | -+ | |||
| 1946 | +16x |
- #' split_label = "ethnicity",+ dflt_row_lbl <- .default_rlabel |
||
| 1214 | +1947 |
- #' split_fun = drop_split_levels+ } else if ( |
||
| 1215 | -+ | |||
| 1948 | +! |
- #' ) %>%+ is.name(subafun) && |
||
| 1216 | -+ | |||
| 1949 | +! |
- #' summarize_row_groups() %>%+ is.function(afun) && |
||
| 1217 | +1950 |
- #' analyze_colvars(afun = colfuns)+ ## this is gross. basically testing |
||
| 1218 | +1951 |
- #' lyt+ ## if the symbol we have corresponds |
||
| 1219 | +1952 |
- #'+ ## in some meaningful way to the function |
||
| 1220 | +1953 |
- #' tbl <- build_table(lyt, ANL)+ ## we will be calling. |
||
| 1221 | -+ | |||
| 1954 | +! |
- #' tbl+ identical( |
||
| 1222 | -+ | |||
| 1955 | +! |
- #'+ mget( |
||
| 1223 | -+ | |||
| 1956 | +! |
- #' lyt2 <- basic_table() %>%+ as.character(subafun), |
||
| 1224 | -+ | |||
| 1957 | +! |
- #' split_cols_by("ARM") %>%
+ mode = "function", |
||
| 1225 | -+ | |||
| 1958 | +! |
- #' split_cols_by_multivar(c("value", "pctdiff"),
+ envir = parent.frame(1), |
||
| 1226 | -+ | |||
| 1959 | +! |
- #' varlabels = c("Measurement", "Pct Diff")
+ ifnotfound = list(NULL), |
||
| 1227 | -+ | |||
| 1960 | +! |
- #' ) %>%+ inherits = TRUE |
||
| 1228 | -+ | |||
| 1961 | +! |
- #' split_rows_by("RACE",
+ )[[1]], |
||
| 1229 | -+ | |||
| 1962 | +! |
- #' split_label = "ethnicity",+ afun |
||
| 1230 | +1963 |
- #' split_fun = drop_split_levels+ ) |
||
| 1231 | +1964 |
- #' ) %>%+ ) {
|
||
| 1232 | -+ | |||
| 1965 | +! |
- #' summarize_row_groups() %>%+ dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ") |
||
| 1233 | +1966 |
- #' analyze_colvars(afun = mean, format = "xx.xx")+ } else {
|
||
| 1234 | -+ | |||
| 1967 | +! |
- #'+ dflt_row_lbl <- if (is.null(avar)) "count" else avar |
||
| 1235 | +1968 |
- #' tbl2 <- build_table(lyt2, ANL)+ } |
||
| 1236 | +1969 |
- #' tbl2+ |
||
| 1237 | -+ | |||
| 1970 | +16x |
- #'+ if (is.null(afun)) {
|
||
| 1238 | -+ | |||
| 1971 | +5x |
- #' @author Gabriel Becker+ afun <- count |
||
| 1239 | +1972 |
- #' @export+ } |
||
| 1240 | +1973 |
- analyze_colvars <- function(lyt,+ |
||
| 1241 | -+ | |||
| 1974 | +16x |
- afun,+ if (is.null(avar)) {
|
||
| 1242 | -+ | |||
| 1975 | +5x |
- format = NULL,+ avar <- names(data)[1] |
||
| 1243 | +1976 |
- na_str = NA_character_,+ } |
||
| 1244 | -+ | |||
| 1977 | +16x |
- nested = TRUE,+ fakeres <- afun(data[[avar]], ...) |
||
| 1245 | -+ | |||
| 1978 | +16x |
- extra_args = list(),+ multirow <- is.list(fakeres) || is(fakeres, "RowsVerticalSection") || summarize_groups |
||
| 1246 | +1979 |
- indent_mod = 0L,+ ## this is before we plug in the default so if not specified by the user |
||
| 1247 | +1980 |
- inclNAs = FALSE) {
+ ## explicitly, row_labels is NULL at this point. |
||
| 1248 | -22x | +1981 | +16x |
- if (is.function(afun)) {
+ if (!is.null(row_labels) && length(row_labels) != n_cells_res(fakeres)) {
|
| 1249 | -13x | +1982 | +2x |
- subafun <- substitute(afun)+ stop( |
| 1250 | -+ | |||
| 1983 | +2x |
- if (+ "Length of row_labels (",
|
||
| 1251 | -13x | +1984 | +2x |
- is.name(subafun) &&+ length(row_labels), |
| 1252 | -13x | +1985 | +2x |
- is.function(afun) &&+ ") does not agree with number of rows generated by analysis function (",
+ |
+
| 1986 | +2x | +
+ n_cells_res(fakeres), |
||
| 1253 | +1987 |
- ## this is gross. basically testing+ ")." |
||
| 1254 | +1988 |
- ## if the symbol we have corresponds+ ) |
||
| 1255 | +1989 |
- ## in some meaningful way to the function+ } |
||
| 1256 | +1990 |
- ## we will be calling.+ |
||
| 1257 | -13x | +1991 | +14x |
- identical(+ if (is.null(row_labels)) {
|
| 1258 | -13x | +1992 | +10x |
- mget(+ row_labels <- dflt_row_lbl+ |
+
| 1993 | ++ |
+ }+ |
+ ||
| 1994 | ++ | + | ||
| 1259 | -13x | +1995 | +14x |
- as.character(subafun),+ lyt <- basic_table( |
| 1260 | -13x | +1996 | +14x |
- mode = "function",+ title = title, |
| 1261 | -13x | +1997 | +14x |
- ifnotfound = list(NULL),+ subtitles = subtitles, |
| 1262 | -13x | +1998 | +14x |
- inherits = TRUE+ main_footer = main_footer, |
| 1263 | -13x | +1999 | +14x |
- )[[1]],+ prov_footer = prov_footer, |
| 1264 | -13x | +2000 | +14x |
- afun+ show_colcounts = show_colcounts |
| 1265 | +2001 |
- )+ ) |
||
| 1266 | +2002 |
- ) {
+
|
||
| 1267 | -13x | +2003 | +14x |
- defrowlab <- as.character(subafun)+ for (var in col_vars) lyt <- split_cols_by(lyt, var) |
| 1268 | +2004 |
- } else {
+
|
||
| 1269 | -! | +|||
| 2005 | +14x |
- defrowlab <- ""+ for (var in head(row_vars, -1)) {
|
||
| 1270 | -+ | |||
| 2006 | +4x |
- }+ lyt <- split_rows_by(lyt, var, split_fun = if (drop_levels) drop_split_levels else NULL) |
||
| 1271 | -13x | +2007 | +4x |
- afun <- lapply(+ if (summarize_groups) {
|
| 1272 | -13x | +2008 | +2x |
- get_acolvar_vars(lyt),+ lyt <- summarize_row_groups(lyt) |
| 1273 | -13x | +|||
| 2009 | +
- function(x) afun+ } |
|||
| 1274 | +2010 |
- )+ } |
||
| 1275 | +2011 |
- } else {
+
|
||
| 1276 | -9x | +2012 | +14x |
- defrowlab <- ""+ tleft <- if (multirow || length(row_vars) > 0) dflt_row_lbl else character()+ |
+
| 2013 | +14x | +
+ if (length(row_vars) > 0) {
+ |
+ ||
| 2014 | +10x | +
+ if (!multirow) {
|
||
| 1277 | +2015 |
- }+ ## in the single row in splitting case, we use the row label as the topleft |
||
| 1278 | -22x | +|||
| 2016 | +
- spl <- AnalyzeColVarSplit(+ ## and the split values as the row labels for a more compact apeparance |
|||
| 1279 | -22x | +2017 | +6x |
- afun = afun,+ tleft <- row_labels |
| 1280 | -22x | +2018 | +6x |
- defrowlab = defrowlab,+ row_labels <- NA_character_ |
| 1281 | -22x | +2019 | +6x |
- split_format = format,+ lyt <- split_rows_by( |
| 1282 | -22x | +2020 | +6x |
- split_na_str = na_str,+ lyt, tail(row_vars, 1), |
| 1283 | -22x | +2021 | +6x |
- split_name = get_acolvar_name(lyt),+ split_fun = if (drop_levels) drop_split_levels else NULL, child_labels = "hidden"+ |
+
| 2022 | ++ |
+ )+ |
+ ||
| 2023 | ++ |
+ } else {
|
||
| 1284 | -22x | +2024 | +4x |
- indent_mod = indent_mod,+ lyt <- split_rows_by(lyt, tail(row_vars, 1), split_fun = if (drop_levels) drop_split_levels else NULL)+ |
+
| 2025 | ++ |
+ } |
||
| 1285 | -22x | +2026 | +10x |
- extra_args = extra_args,+ if (summarize_groups) {
|
| 1286 | -22x | +2027 | +2x |
- inclNAs = inclNAs+ lyt <- summarize_row_groups(lyt) |
| 1287 | +2028 |
- )+ }+ |
+ ||
| 2029 | ++ |
+ } |
||
| 1288 | -22x | +2030 | +14x |
- pos <- next_rpos(lyt, nested, for_analyze = TRUE)+ inner_afun <- .quick_afun(afun, row_labels) |
| 1289 | -22x | +2031 | +14x |
- split_rows(lyt, spl, pos)+ lyt <- analyze(lyt, avar, afun = inner_afun, extra_args = list(...))+ |
+
| 2032 | +14x | +
+ lyt <- append_topleft(lyt, tleft) |
||
| 1290 | +2033 |
} |
||
| 1291 | +2034 | |||
| 1292 | +2035 |
- ## Add a total column at the next **top level** spot in+ #' @rdname qtable_layout |
||
| 1293 | +2036 |
- ## the column layout.+ #' @export |
||
| 1294 | +2037 |
-
+ qtable <- function(data, |
||
| 1295 | +2038 |
- #' Add overall column+ row_vars = character(), |
||
| 1296 | +2039 |
- #'+ col_vars = character(), |
||
| 1297 | +2040 |
- #' This function will *only* add an overall column at the *top* level of splitting, NOT within existing column splits.+ avar = NULL, |
||
| 1298 | +2041 |
- #' See [add_overall_level()] for the recommended way to add overall columns more generally within existing splits.+ row_labels = NULL, |
||
| 1299 | +2042 |
- #'+ afun = NULL, |
||
| 1300 | +2043 |
- #' @inheritParams lyt_args+ summarize_groups = FALSE, |
||
| 1301 | +2044 |
- #'+ title = "", |
||
| 1302 | +2045 |
- #' @inherit split_cols_by return+ subtitles = character(), |
||
| 1303 | +2046 |
- #'+ main_footer = character(), |
||
| 1304 | +2047 |
- #' @seealso [add_overall_level()]+ prov_footer = character(), |
||
| 1305 | +2048 |
- #'+ show_colcounts = TRUE, |
||
| 1306 | +2049 |
- #' @examples+ drop_levels = TRUE, |
||
| 1307 | +2050 |
- #' lyt <- basic_table() %>%+ ...) {
|
||
| 1308 | +2051 |
- #' split_cols_by("ARM") %>%
+ ## this involves substitution so it needs to appear in both functions. Gross but true.+ |
+ ||
| 2052 | +16x | +
+ subafun <- substitute(afun) |
||
| 1309 | +2053 |
- #' add_overall_col("All Patients") %>%
+ if (+ |
+ ||
| 2054 | +16x | +
+ is.name(subafun) && is.function(afun) && |
||
| 1310 | +2055 |
- #' analyze("AGE")
+ ## this is gross. basically testing |
||
| 1311 | +2056 |
- #' lyt+ ## if the symbol we have corresponds |
||
| 1312 | +2057 |
- #'+ ## in some meaningful way to the function |
||
| 1313 | +2058 |
- #' tbl <- build_table(lyt, DM)+ ## we will be calling.+ |
+ ||
| 2059 | +16x | +
+ identical(+ |
+ ||
| 2060 | +16x | +
+ mget(+ |
+ ||
| 2061 | +16x | +
+ as.character(subafun),+ |
+ ||
| 2062 | +16x | +
+ mode = "function", envir = parent.frame(1), ifnotfound = list(NULL), inherits = TRUE+ |
+ ||
| 2063 | +16x | +
+ )[[1]],+ |
+ ||
| 2064 | +16x | +
+ afun |
||
| 1314 | +2065 |
- #' tbl+ ) |
||
| 1315 | +2066 |
- #'+ ) {
+ |
+ ||
| 2067 | +11x | +
+ dflt_row_lbl <- paste(avar, as.character(subafun), sep = " - ") |
||
| 1316 | +2068 |
- #' @export+ } else {
+ |
+ ||
| 2069 | +5x | +
+ dflt_row_lbl <- if (is.null(avar)) "count" else avar+ |
+ ||
| 2070 | ++ |
+ }+ |
+ ||
| 2071 | ++ | + + | +||
| 2072 | +16x | +
+ lyt <- qtable_layout(+ |
+ ||
| 2073 | +16x | +
+ data = data,+ |
+ ||
| 2074 | +16x | +
+ row_vars = row_vars,+ |
+ ||
| 2075 | +16x | +
+ col_vars = col_vars,+ |
+ ||
| 2076 | +16x | +
+ avar = avar,+ |
+ ||
| 2077 | +16x | +
+ row_labels = row_labels,+ |
+ ||
| 2078 | +16x | +
+ afun = afun,+ |
+ ||
| 2079 | +16x | +
+ summarize_groups = summarize_groups,+ |
+ ||
| 2080 | +16x | +
+ title = title, |
||
| 1317 | -+ | |||
| 2081 | +16x |
- add_overall_col <- function(lyt, label) {
+ subtitles = subtitles, |
||
| 1318 | -111x | +2082 | +16x |
- spl <- AllSplit(label)+ main_footer = main_footer, |
| 1319 | -111x | +2083 | +16x |
- split_cols(+ prov_footer = prov_footer, |
| 1320 | -111x | +2084 | +16x |
- lyt,+ show_colcounts = show_colcounts, |
| 1321 | -111x | +2085 | +16x |
- spl,+ drop_levels = drop_levels,+ |
+
| 2086 | ++ |
+ ..., |
||
| 1322 | -111x | +2087 | +16x |
- next_cpos(lyt, FALSE)+ .default_rlabel = dflt_row_lbl |
| 1323 | +2088 |
) |
||
| 2089 | +14x | +
+ build_table(lyt, data)+ |
+ ||
| 1324 | +2090 |
} |
| 1325 | +1 |
-
+ #' Cell value constructors |
||
| 1326 | +2 |
- ## add_row_summary ====+ #' |
||
| 1327 | +3 |
-
+ #' Construct a cell value and associate formatting, labeling, indenting, and column spanning information with it. |
||
| 1328 | +4 |
- #' @inheritParams lyt_args+ #' |
||
| 1329 | +5 |
- #'+ #' @inheritParams compat_args |
||
| 1330 | +6 |
- #' @export+ #' @inheritParams lyt_args |
||
| 1331 | +7 |
- #'+ #' @param x (`ANY`)\cr cell value. |
||
| 1332 | +8 |
- #' @rdname int_methods+ #' @param format (`string` or `function`)\cr the format label (string) or `formatters` function to apply to `x`. |
||
| 1333 | +9 |
- setGeneric(+ #' See [formatters::list_valid_format_labels()] for currently supported format labels. |
||
| 1334 | +10 |
- ".add_row_summary",+ #' @param label (`string` or `NULL`)\cr label. If non-`NULL`, it will be looked at when determining row labels. |
||
| 1335 | +11 |
- function(lyt,+ #' @param colspan (`integer(1)`)\cr column span value. |
||
| 1336 | +12 |
- label,+ #' @param footnotes (`list` or `NULL`)\cr referential footnote messages for the cell. |
||
| 1337 | +13 |
- cfun,+ #' @param stat_names (`character` or `NA`)\cr names for the statistics in the cell. It can be a vector of strings. |
||
| 1338 | +14 |
- child_labels = c("default", "visible", "hidden"),
+ #' If `NA`, statistic names are not specified. |
||
| 1339 | +15 |
- cformat = NULL,+ #' |
||
| 1340 | +16 |
- cna_str = "-",+ #' @inherit CellValue return |
||
| 1341 | +17 |
- indent_mod = 0L,+ #' |
||
| 1342 | +18 |
- cvar = "",+ #' @note Currently column spanning is only supported for defining header structure. |
||
| 1343 | +19 |
- extra_args = list()) {
+ #' |
||
| 1344 | -447x | +|||
| 20 | +
- standardGeneric(".add_row_summary")
+ #' @examples |
|||
| 1345 | +21 |
- }+ #' rcell(1, format = "xx.x") |
||
| 1346 | +22 |
- )+ #' rcell(c(1, 2), format = c("xx - xx"))
|
||
| 1347 | +23 |
-
+ #' rcell(c(1, 2), stat_names = c("Rand1", "Rand2"))
|
||
| 1348 | +24 |
- #' @rdname int_methods+ #' |
||
| 1349 | +25 |
- setMethod(+ #' @rdname rcell |
||
| 1350 | +26 |
- ".add_row_summary", "PreDataTableLayouts",+ #' @export |
||
| 1351 | +27 |
- function(lyt,+ rcell <- function(x, |
||
| 1352 | +28 |
- label,+ format = NULL, |
||
| 1353 | +29 |
- cfun,+ colspan = 1L, |
||
| 1354 | +30 |
- child_labels = c("default", "visible", "hidden"),
+ label = NULL, |
||
| 1355 | +31 |
- cformat = NULL,+ indent_mod = NULL, |
||
| 1356 | +32 |
- cna_str = "-",+ footnotes = NULL, |
||
| 1357 | +33 |
- indent_mod = 0L,+ align = NULL, |
||
| 1358 | +34 |
- cvar = "",+ format_na_str = NULL, |
||
| 1359 | +35 |
- extra_args = list()) {
+ stat_names = NULL) {
|
||
| 1360 | -114x | +36 | +33750x |
- child_labels <- match.arg(child_labels)+ checkmate::assert_character(stat_names, null.ok = TRUE) |
| 1361 | -114x | +37 | +33750x |
- tmp <- .add_row_summary(rlayout(lyt), label, cfun,+ if (!is.null(align)) {
|
| 1362 | -114x | +38 | +56x |
- child_labels = child_labels,+ check_aligns(align)+ |
+
| 39 | ++ |
+ } |
||
| 1363 | -114x | +40 | +33750x |
- cformat = cformat,+ if (is(x, "CellValue")) {
|
| 1364 | -114x | +41 | +20308x |
- cna_str = cna_str,+ if (!is.null(label)) {
|
| 1365 | -114x | +42 | +1x |
- indent_mod = indent_mod,+ obj_label(x) <- label+ |
+
| 43 | ++ |
+ } |
||
| 1366 | -114x | +44 | +20308x |
- cvar = cvar,+ if (colspan != 1L) {
|
| 1367 | -114x | +45 | +1x |
- extra_args = extra_args+ cell_cspan(x) <- colspan |
| 1368 | +46 |
- )+ } |
||
| 1369 | -114x | +47 | +20308x |
- rlayout(lyt) <- tmp+ if (!is.null(indent_mod)) {
|
| 1370 | -114x | +48 | +1x |
- lyt+ indent_mod(x) <- indent_mod |
| 1371 | +49 |
- }+ } |
||
| 1372 | -+ | |||
| 50 | +20308x |
- )+ if (!is.null(format)) {
|
||
| 1373 | -+ | |||
| 51 | +1x |
-
+ obj_format(x) <- format |
||
| 1374 | +52 |
- #' @rdname int_methods+ } |
||
| 1375 | -+ | |||
| 53 | +20308x |
- setMethod(+ if (!is.null(footnotes)) {
|
||
| 1376 | -+ | |||
| 54 | +374x |
- ".add_row_summary", "PreDataRowLayout",+ cell_footnotes(x) <- lapply(footnotes, RefFootnote) |
||
| 1377 | +55 |
- function(lyt,+ } |
||
| 1378 | -+ | |||
| 56 | +20308x |
- label,+ if (!is.null(format_na_str)) {
|
||
| 1379 | -+ | |||
| 57 | +! |
- cfun,+ obj_na_str(x) <- format_na_str |
||
| 1380 | +58 |
- child_labels = c("default", "visible", "hidden"),
+ } |
||
| 1381 | -+ | |||
| 59 | +20308x |
- cformat = NULL,+ if (!is.null(stat_names)) {
|
||
| 1382 | -+ | |||
| 60 | +8x |
- cna_str = "-",+ obj_stat_names(x) <- stat_names |
||
| 1383 | +61 |
- indent_mod = 0L,+ } |
||
| 1384 | -+ | |||
| 62 | +20308x |
- cvar = "",+ ret <- x |
||
| 1385 | +63 |
- extra_args = list()) {
+ } else {
|
||
| 1386 | -114x | +64 | +13442x |
- child_labels <- match.arg(child_labels)+ if (is.null(label)) {
|
| 1387 | -114x | +65 | +10484x |
- if (length(lyt) == 0 || (length(lyt) == 1 && length(lyt[[1]]) == 0)) {
+ label <- obj_label(x) |
| 1388 | +66 |
- ## XXX ignoring indent mod here+ } |
||
| 1389 | -9x | +67 | +13442x |
- rt <- root_spl(lyt)+ if (is.null(format)) {
|
| 1390 | -9x | +68 | +7371x |
- rt <- .add_row_summary(rt,+ format <- obj_format(x) |
| 1391 | -9x | +|||
| 69 | +
- label,+ } |
|||
| 1392 | -9x | +70 | +13442x |
- cfun,+ if (is.null(indent_mod)) {
|
| 1393 | -9x | +71 | +13442x |
- child_labels = child_labels,+ indent_mod <- indent_mod(x) |
| 1394 | -9x | +|||
| 72 | +
- cformat = cformat,+ } |
|||
| 1395 | -9x | +73 | +13442x |
- cna_str = cna_str,+ footnotes <- lapply(footnotes, RefFootnote) |
| 1396 | -9x | +74 | +13442x |
- cvar = cvar,+ ret <- CellValue( |
| 1397 | -9x | +75 | +13442x |
- extra_args = extra_args+ val = x, |
| 1398 | -+ | |||
| 76 | +13442x |
- )+ format = format, |
||
| 1399 | -9x | +77 | +13442x |
- root_spl(lyt) <- rt+ colspan = colspan, |
| 1400 | -+ | |||
| 78 | +13442x |
- } else {
+ label = label, |
||
| 1401 | -105x | +79 | +13442x |
- ind <- length(lyt)+ indent_mod = indent_mod, |
| 1402 | -105x | +80 | +13442x |
- tmp <- .add_row_summary(lyt[[ind]], label, cfun,+ footnotes = footnotes, |
| 1403 | -105x | +81 | +13442x |
- child_labels = child_labels,+ format_na_str = format_na_str, |
| 1404 | -105x | +82 | +13442x |
- cformat = cformat,+ stat_names = stat_names %||% NA_character_ |
| 1405 | -105x | +83 | +13442x |
- cna_str = cna_str,+ ) # RefFootnote(footnote)) |
| 1406 | -105x | +|||
| 84 | +
- indent_mod = indent_mod,+ } |
|||
| 1407 | -105x | +85 | +33750x |
- cvar = cvar,+ if (!is.null(align)) {
|
| 1408 | -105x | +86 | +56x |
- extra_args = extra_args+ cell_align(ret) <- align |
| 1409 | +87 |
- )+ } |
||
| 1410 | -105x | +88 | +33750x |
- lyt[[ind]] <- tmp+ ret |
| 1411 | +89 |
- }+ } |
||
| 1412 | -114x | +|||
| 90 | +
- lyt+ |
|||
| 1413 | +91 |
- }+ #' @param is_ref (`flag`)\cr whether function is being used in the reference column (i.e. `.in_ref_col` should be |
||
| 1414 | +92 |
- )+ #' passed to this argument). |
||
| 1415 | +93 |
-
+ #' @param refval (`ANY`)\cr value to use when in the reference column. Defaults to `NULL`. |
||
| 1416 | +94 |
- #' @rdname int_methods+ #' |
||
| 1417 | +95 |
- setMethod(+ #' @details |
||
| 1418 | +96 |
- ".add_row_summary", "SplitVector",+ #' `non_ref_rcell` provides the common *blank for cells in the reference column, this value otherwise*, and should |
||
| 1419 | +97 |
- function(lyt,+ #' be passed the value of `.in_ref_col` when it is used. |
||
| 1420 | +98 |
- label,+ #' |
||
| 1421 | +99 |
- cfun,+ #' @rdname rcell |
||
| 1422 | +100 |
- child_labels = c("default", "visible", "hidden"),
+ #' @export |
||
| 1423 | +101 |
- cformat = NULL,+ non_ref_rcell <- function(x, is_ref, format = NULL, colspan = 1L, |
||
| 1424 | +102 |
- cna_str = "-",+ label = NULL, indent_mod = NULL, |
||
| 1425 | +103 |
- indent_mod = 0L,+ refval = NULL, |
||
| 1426 | +104 |
- cvar = "",+ align = "center", |
||
| 1427 | +105 |
- extra_args = list()) {
+ format_na_str = NULL) {
|
||
| 1428 | -105x | +106 | +2x |
- child_labels <- match.arg(child_labels)+ val <- if (is_ref) refval else x |
| 1429 | -105x | +107 | +2x |
- ind <- length(lyt)+ rcell(val, |
| 1430 | -! | +|||
| 108 | +2x |
- if (ind == 0) stop("no split to add content rows at")
+ format = format, colspan = colspan, label = label, |
||
| 1431 | -105x | +109 | +2x |
- spl <- lyt[[ind]]+ indent_mod = indent_mod, align = align,+ |
+
| 110 | +2x | +
+ format_na_str = format_na_str |
||
| 1432 | +111 |
- # if(is(spl, "AnalyzeVarSplit"))+ ) |
||
| 1433 | +112 |
- # stop("can't add content rows to analyze variable split")
+ } |
||
| 1434 | -105x | +|||
| 113 | +
- tmp <- .add_row_summary(spl,+ |
|||
| 1435 | -105x | +|||
| 114 | +
- label,+ #' Create multiple rows in analysis or summary functions |
|||
| 1436 | -105x | +|||
| 115 | +
- cfun,+ #' |
|||
| 1437 | -105x | +|||
| 116 | +
- child_labels = child_labels,+ #' Define the cells that get placed into multiple rows in `afun`. |
|||
| 1438 | -105x | +|||
| 117 | +
- cformat = cformat,+ #' |
|||
| 1439 | -105x | +|||
| 118 | +
- cna_str = cna_str,+ #' @param ... single row defining expressions. |
|||
| 1440 | -105x | +|||
| 119 | +
- indent_mod = indent_mod,+ #' @param .list (`list`)\cr list cell content (usually `rcells`). The `.list` is concatenated to `...`. |
|||
| 1441 | -105x | +|||
| 120 | +
- cvar = cvar,+ #' @param .names (`character` or `NULL`)\cr names of the returned list/structure. |
|||
| 1442 | -105x | +|||
| 121 | +
- extra_args = extra_args+ #' @param .labels (`character` or `NULL`)\cr labels for the defined rows. |
|||
| 1443 | +122 |
- )+ #' @param .formats (`character` or `NULL`)\cr formats for the values. |
||
| 1444 | -105x | +|||
| 123 | +
- lyt[[ind]] <- tmp+ #' @param .indent_mods (`integer` or `NULL`)\cr indent modifications for the defined rows. |
|||
| 1445 | -105x | +|||
| 124 | +
- lyt+ #' @param .cell_footnotes (`list`)\cr referential footnote messages to be associated by name with *cells*. |
|||
| 1446 | +125 |
- }+ #' @param .row_footnotes (`list`)\cr referential footnotes messages to be associated by name with *rows*. |
||
| 1447 | +126 |
- )+ #' @param .aligns (`character` or `NULL`)\cr alignments for the cells. Standard for `NULL` is `"center"`. |
||
| 1448 | +127 |
-
+ #' See [formatters::list_valid_aligns()] for currently supported alignments. |
||
| 1449 | +128 |
- #' @rdname int_methods+ #' @param .format_na_strs (`character` or `NULL`)\cr NA strings for the cells. |
||
| 1450 | +129 |
- setMethod(+ #' @param .stat_names (`list`)\cr names for the statistics in the cells. |
||
| 1451 | +130 |
- ".add_row_summary", "Split",+ #' It can be a vector of values. If `list(NULL)`, statistic names are not specified and will |
||
| 1452 | +131 |
- function(lyt,+ #' appear as `NA`. |
||
| 1453 | +132 |
- label,+ #' |
||
| 1454 | +133 |
- cfun,+ #' @note In post-processing, referential footnotes can also be added using row and column |
||
| 1455 | +134 |
- child_labels = c("default", "visible", "hidden"),
+ #' paths with [`fnotes_at_path<-`]. |
||
| 1456 | +135 |
- cformat = NULL,+ #' |
||
| 1457 | +136 |
- cna_str = "-",+ #' @return A `RowsVerticalSection` object (or `NULL`). The details of this object should be considered an |
||
| 1458 | +137 |
- indent_mod = 0L,+ #' internal implementation detail. |
||
| 1459 | +138 |
- cvar = "",+ #' |
||
| 1460 | +139 |
- extra_args = list()) {
+ #' @seealso [analyze()] |
||
| 1461 | -114x | +|||
| 140 | +
- child_labels <- match.arg(child_labels)+ #' |
|||
| 1462 | +141 |
- # lbl_kids = .labelkids_helper(child_labels)+ #' @examples |
||
| 1463 | -114x | +|||
| 142 | +
- content_fun(lyt) <- cfun+ #' in_rows(1, 2, 3, .names = c("a", "b", "c"))
|
|||
| 1464 | -114x | +|||
| 143 | +
- content_indent_mod(lyt) <- indent_mod+ #' in_rows(1, 2, 3, .labels = c("a", "b", "c"))
|
|||
| 1465 | -114x | +|||
| 144 | +
- content_var(lyt) <- cvar+ #' in_rows(1, 2, 3, .names = c("a", "b", "c"), .labels = c("AAA", "BBB", "CCC"))
|
|||
| 1466 | +145 |
- ## obj_format(lyt) = cformat+ #' in_rows( |
||
| 1467 | -114x | +|||
| 146 | +
- content_format(lyt) <- cformat+ #' .list = list(a = c(NA, NA)), |
|||
| 1468 | -114x | +|||
| 147 | +
- if (!identical(child_labels, "default") && !identical(child_labels, label_kids(lyt))) {
+ #' .formats = "xx - xx", |
|||
| 1469 | -! | +|||
| 148 | +
- label_kids(lyt) <- child_labels+ #' .format_na_strs = list(c("asda", "lkjklj"))
|
|||
| 1470 | +149 |
- }+ #' ) |
||
| 1471 | -114x | +|||
| 150 | +
- content_na_str <- cna_str+ #' in_rows(.list = list(a = c(NA, NA)), .format_na_strs = c("asda", "lkjklj"))
|
|||
| 1472 | -114x | +|||
| 151 | +
- content_extra_args(lyt) <- extra_args+ #' |
|||
| 1473 | -114x | +|||
| 152 | +
- lyt+ #' in_rows(.list = list(a = 1, b = 2, c = 3)) |
|||
| 1474 | +153 |
- }+ #' in_rows(1, 2, .list = list(3), .names = c("a", "b", "c"))
|
||
| 1475 | +154 |
- )+ #' |
||
| 1476 | +155 |
-
+ #' lyt <- basic_table() %>% |
||
| 1477 | +156 |
- .count_raw_constr <- function(var, format, label_fstr) {
+ #' split_cols_by("ARM") %>%
|
||
| 1478 | -1x | +|||
| 157 | +
- function(df, labelstr = "") {
+ #' analyze("AGE", afun = function(x) {
|
|||
| 1479 | -3x | +|||
| 158 | +
- if (grepl("%s", label_fstr, fixed = TRUE)) {
+ #' in_rows( |
|||
| 1480 | -! | +|||
| 159 | +
- label <- sprintf(label_fstr, labelstr)+ #' "Mean (sd)" = rcell(c(mean(x), sd(x)), format = "xx.xx (xx.xx)"), |
|||
| 1481 | +160 |
- } else {
+ #' "Range" = rcell(range(x), format = "xx.xx - xx.xx") |
||
| 1482 | -3x | +|||
| 161 | +
- label <- label_fstr+ #' ) |
|||
| 1483 | +162 |
- }+ #' }) |
||
| 1484 | -3x | +|||
| 163 | +
- if (is(df, "data.frame")) {
+ #' |
|||
| 1485 | -3x | +|||
| 164 | +
- if (!is.null(var) && nzchar(var)) {
+ #' tbl <- build_table(lyt, ex_adsl) |
|||
| 1486 | -3x | +|||
| 165 | +
- cnt <- sum(!is.na(df[[var]]))+ #' tbl |
|||
| 1487 | +166 |
- } else {
+ #' |
||
| 1488 | -! | +|||
| 167 | +
- cnt <- nrow(df)+ #' @export |
|||
| 1489 | +168 |
- }+ in_rows <- function(..., .list = NULL, .names = NULL, |
||
| 1490 | -1x | +|||
| 169 | +
- } else { # df is the data column vector
+ .labels = NULL, |
|||
| 1491 | -! | +|||
| 170 | +
- cnt <- sum(!is.na(df))+ .formats = NULL, |
|||
| 1492 | +171 |
- }+ .indent_mods = NULL, |
||
| 1493 | -3x | +|||
| 172 | +
- ret <- rcell(cnt,+ .cell_footnotes = list(NULL), |
|||
| 1494 | -3x | +|||
| 173 | +
- format = format,+ .row_footnotes = list(NULL), |
|||
| 1495 | -3x | +|||
| 174 | +
- label = label+ .aligns = NULL, |
|||
| 1496 | +175 |
- )+ .format_na_strs = NULL,+ |
+ ||
| 176 | ++ |
+ .stat_names = list(NULL)) {
|
||
| 1497 | -3x | +177 | +6148x |
- ret+ if (is.function(.formats)) {
|
| 1498 | -+ | |||
| 178 | +! |
- }+ .formats <- list(.formats) |
||
| 1499 | +179 |
- }+ } |
||
| 1500 | +180 | |||
| 1501 | -+ | |||
| 181 | +6148x |
- .count_wpcts_constr <- function(var, format, label_fstr) {
+ l <- c(list(...), .list) |
||
| 1502 | -100x | +|||
| 182 | +
- function(df, labelstr = "", .N_col) {
+
|
|||
| 1503 | -1507x | +183 | +6148x |
- if (grepl("%s", label_fstr, fixed = TRUE)) {
+ if (missing(.names) && missing(.labels)) {
|
| 1504 | -1483x | +184 | +2061x |
- label <- sprintf(label_fstr, labelstr)+ if (length(l) > 0 && is.null(names(l))) {
+ |
+
| 185 | +! | +
+ stop("need a named list")
|
||
| 1505 | +186 |
} else {
|
||
| 1506 | -24x | +187 | +2061x |
- label <- label_fstr+ .names <- names(l) |
| 1507 | +188 |
} |
||
| 1508 | -1507x | -
- if (is(df, "data.frame")) {
- |
- ||
| 1509 | -1507x | +189 | +2061x |
- if (!is.null(var) && nzchar(var)) {
+ stopifnot(!anyNA(.names)) |
| 1510 | -383x | +|||
| 190 | +
- cnt <- sum(!is.na(df[[var]]))+ } |
|||
| 1511 | +191 |
- } else {
+
|
||
| 1512 | -1124x | +192 | +6148x |
- cnt <- nrow(df)+ if (length(l) == 0) {
|
| 1513 | +193 |
- }+ if ( |
||
| 1514 | -100x | +|||
| 194 | +! |
- } else { # df is the data column vector
+ length(.labels) > 0 || |
||
| 1515 | +195 | ! |
- cnt <- sum(!is.na(df))+ length(.formats) > 0 || |
|
| 1516 | -+ | |||
| 196 | +! |
- }+ length(.names) > 0 || |
||
| 1517 | -+ | |||
| 197 | +! |
- ## the formatter does the *100 so we don't here.+ length(.indent_mods) > 0 || |
||
| 1518 | -+ | |||
| 198 | +! | +
+ length(.format_na_strs) > 0 ||+ |
+ ||
| 199 | +! |
- ## TODO name elements of this so that ARD generation has access to them+ (!all(is.na(.stat_names)) && length(.stat_names) > 0) |
||
| 1519 | +200 |
- ## ret <- rcell(c(n = cnt, pct = cnt / .N_col),+ ) {
|
||
| 1520 | -1507x | +|||
| 201 | +! |
- ret <- rcell(c(cnt, cnt / .N_col),+ stop( |
||
| 1521 | -1507x | +|||
| 202 | +! |
- format = format,+ "in_rows got 0 rows but length >0 of at least one of ", |
||
| 1522 | -1507x | +|||
| 203 | +! |
- label = label+ ".labels, .formats, .names, .indent_mods, .format_na_strs, .stat_names. ", |
||
| 1523 | -+ | |||
| 204 | +! |
- )+ "Does your analysis/summary function handle the 0 row ", |
||
| 1524 | -1507x | +|||
| 205 | +! |
- ret+ "df/length 0 x case?" |
||
| 1525 | +206 |
- }+ ) |
||
| 1526 | +207 |
- }+ } |
||
| 1527 | -+ | |||
| 208 | +! |
-
+ l2 <- list() |
||
| 1528 | +209 |
- .validate_cfuns <- function(fun) {
+ } else {
|
||
| 1529 | -120x | +210 | +6148x |
- if (is.list(fun)) {
+ if (is.null(.formats)) {
|
| 1530 | -2x | +211 | +5687x |
- return(unlist(lapply(fun, .validate_cfuns)))+ .formats <- list(NULL) |
| 1531 | +212 |
- }+ } |
||
| 1532 | -+ | |||
| 213 | +6148x |
-
+ stopifnot(is.list(.cell_footnotes)) |
||
| 1533 | -118x | +214 | +6148x |
- frmls <- formals(fun)+ if (length(.cell_footnotes) != length(l)) {
|
| 1534 | -118x | +215 | +1337x |
- ls_pos <- match("labelstr", names(frmls))
+ .cell_footnotes <- c( |
| 1535 | -118x | +216 | +1337x |
- if (is.na(ls_pos)) {
+ .cell_footnotes, |
| 1536 | -! | +|||
| 217 | +1337x |
- stop("content functions must explicitly accept a 'labelstr' argument")
+ setNames( |
||
| 1537 | -+ | |||
| 218 | +1337x |
- }+ rep(list(character()), |
||
| 1538 | -+ | |||
| 219 | +1337x |
-
+ length.out = length(setdiff( |
||
| 1539 | -118x | +220 | +1337x |
- list(fun)+ names(l), |
| 1540 | -+ | |||
| 221 | +1337x |
- }+ names(.cell_footnotes) |
||
| 1541 | +222 |
-
+ )) |
||
| 1542 | +223 |
- #' Analysis function to count levels of a factor with percentage of the column total+ ), |
||
| 1543 | -+ | |||
| 224 | +1337x |
- #'+ setdiff( |
||
| 1544 | -+ | |||
| 225 | +1337x |
- #' @param x (`factor`)\cr a vector of data, provided by rtables pagination machinery.+ names(l), |
||
| 1545 | -+ | |||
| 226 | +1337x |
- #' @param .N_col (`integer(1)`)\cr total count for the column, provided by rtables pagination machinery.+ names(.cell_footnotes) |
||
| 1546 | +227 |
- #'+ ) |
||
| 1547 | +228 |
- #' @return A `RowsVerticalSection` object with counts (and percents) for each level of the factor.+ ) |
||
| 1548 | +229 |
- #'+ ) |
||
| 1549 | -+ | |||
| 230 | +1337x |
- #' @examples+ .cell_footnotes <- .cell_footnotes[names(l)] |
||
| 1550 | +231 |
- #' counts_wpcts(DM$SEX, 400)+ } |
||
| 1551 | -+ | |||
| 232 | +6148x |
- #'+ if (is.null(.aligns)) {
+ |
+ ||
| 233 | +6145x | +
+ .aligns <- list(NULL) |
||
| 1552 | +234 |
- #' @export+ } |
||
| 1553 | +235 |
- counts_wpcts <- function(x, .N_col) {
+
|
||
| 1554 | -2x | +236 | +6148x |
- if (!is.factor(x)) {
+ l2 <- mapply(rcell, |
| 1555 | -1x | +237 | +6148x |
- stop(+ x = l, format = .formats, |
| 1556 | -1x | +238 | +6148x |
- "using the 'counts_wpcts' analysis function requires factor data ",+ footnotes = .cell_footnotes %||% list(NULL), |
| 1557 | -1x | +239 | +6148x |
- "to guarantee equal numbers of rows across all collumns, got class ",+ align = .aligns, |
| 1558 | -1x | +240 | +6148x |
- class(x), "."+ format_na_str = .format_na_strs %||% list(NULL),+ |
+
| 241 | +6148x | +
+ stat_names = .stat_names %||% list(NULL),+ |
+ ||
| 242 | +6148x | +
+ SIMPLIFY = FALSE |
||
| 1559 | +243 |
) |
||
| 1560 | +244 |
} |
||
| 1561 | -1x | +245 | +6148x |
- ret <- table(x)+ if (is.null(.labels)) {
|
| 1562 | -1x | +246 | +2918x |
- in_rows(.list = lapply(ret, function(y) rcell(y * c(1, 1 / .N_col), format = "xx (xx.x%)")))+ objlabs <- vapply(l2, function(x) obj_label(x) %||% "", "") |
| 1563 | -+ | |||
| 247 | +2918x |
- }+ if (any(nzchar(objlabs))) {
|
||
| 1564 | -+ | |||
| 248 | +69x |
-
+ .labels <- objlabs |
||
| 1565 | +249 |
- #' Add a content row of summary counts+ } |
||
| 1566 | +250 |
- #'+ } |
||
| 1567 | +251 |
- #' @inheritParams lyt_args+ |
||
| 1568 | -+ | |||
| 252 | +6148x |
- #'+ if (is.null(.names) && !is.null(names(l))) {
|
||
| 1569 | -+ | |||
| 253 | +99x |
- #' @inherit split_cols_by return+ .names <- names(l) |
||
| 1570 | +254 |
- #'+ } |
||
| 1571 | -+ | |||
| 255 | +6148x |
- #' @details+ stopifnot(is.list(.row_footnotes)) |
||
| 1572 | -+ | |||
| 256 | +6148x |
- #' If `format` expects 1 value (i.e. it is specified as a format string and `xx` appears for two values+ if (length(.row_footnotes) != length(l2)) {
|
||
| 1573 | -+ | |||
| 257 | +1337x |
- #' (i.e. `xx` appears twice in the format string) or is specified as a function, then both raw and percent of+ tmp <- .row_footnotes |
||
| 1574 | -+ | |||
| 258 | +1337x |
- #' column total counts are calculated. If `format` is a format string where `xx` appears only one time, only+ .row_footnotes <- vector("list", length(l2))
|
||
| 1575 | -+ | |||
| 259 | +1337x |
- #' raw counts are used.+ pos <- match(names(tmp), .names) |
||
| 1576 | -+ | |||
| 260 | +1337x |
- #'+ nonna <- which(!is.na(pos)) |
||
| 1577 | -+ | |||
| 261 | +1337x |
- #' `cfun` must accept `x` or `df` as its first argument. For the `df` argument `cfun` will receive the subset+ .row_footnotes[pos] <- tmp[nonna] |
||
| 1578 | +262 |
- #' `data.frame` corresponding with the row- and column-splitting for the cell being calculated. Must accept+ # length(.row_footnotes) <- length(l2) |
||
| 1579 | +263 |
- #' `labelstr` as the second parameter, which accepts the `label` of the level of the parent split currently+ } |
||
| 1580 | -+ | |||
| 264 | +6148x |
- #' being summarized. Can additionally take any optional argument supported by analysis functions. (see [analyze()]).+ ret <- RowsVerticalSection(l2, |
||
| 1581 | -+ | |||
| 265 | +6148x |
- #'+ names = .names, |
||
| 1582 | -+ | |||
| 266 | +6148x |
- #' In addition, if complex custom functions are needed, we suggest checking the available [additional_fun_params]+ labels = .labels, |
||
| 1583 | -+ | |||
| 267 | +6148x |
- #' that can be used in `cfun`.+ indent_mods = .indent_mods, |
||
| 1584 | -+ | |||
| 268 | +6148x |
- #'+ formats = .formats, |
||
| 1585 | -+ | |||
| 269 | +6148x |
- #' @examples+ footnotes = .row_footnotes, |
||
| 1586 | -+ | |||
| 270 | +6148x |
- #' DM2 <- subset(DM, COUNTRY %in% c("USA", "CAN", "CHN"))
+ format_na_strs = .format_na_strs |
||
| 1587 | +271 |
- #'+ ) |
||
| 1588 | +272 |
- #' lyt <- basic_table() %>%+ ## if(!is.null(.names)) |
||
| 1589 | +273 |
- #' split_cols_by("ARM") %>%
+ ## names(l2) <- .names |
||
| 1590 | +274 |
- #' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
+ ## else |
||
| 1591 | +275 |
- #' summarize_row_groups(label_fstr = "%s (n)") %>%+ ## names(l2) <- names(l) |
||
| 1592 | -+ | |||
| 276 | +! |
- #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx")
+ if (length(ret) == 0) NULL else ret |
||
| 1593 | +277 |
- #' lyt+ |
||
| 1594 | +278 |
- #'+ ## if (length(l) == 0) NULL else l |
||
| 1595 | +279 |
- #' tbl <- build_table(lyt, DM2)+ } |
||
| 1596 | +280 |
- #' tbl+ |
||
| 1597 | +281 |
- #'+ .validate_nms <- function(vals, .stats, arg) {
|
||
| 1598 | -+ | |||
| 282 | +268x |
- #' row_paths_summary(tbl) # summary count is a content table+ if (!is.null(arg)) {
|
||
| 1599 | -+ | |||
| 283 | +112x |
- #'+ if (is.null(names(arg))) {
|
||
| 1600 | -+ | |||
| 284 | +! |
- #' ## use a cfun and extra_args to customize summarization+ stopifnot(length(arg) == length(.stats)) |
||
| 1601 | -+ | |||
| 285 | +! |
- #' ## behavior+ names(arg) <- names(vals) |
||
| 1602 | +286 |
- #' sfun <- function(x, labelstr, trim) {
+ } else {
|
||
| 1603 | -+ | |||
| 287 | +112x |
- #' in_rows(+ lblpos <- match(names(arg), names(vals)) |
||
| 1604 | -+ | |||
| 288 | +112x |
- #' c(mean(x, trim = trim), trim),+ stopifnot(!anyNA(lblpos)) |
||
| 1605 | +289 |
- #' .formats = "xx.x (xx.x%)",+ } |
||
| 1606 | +290 |
- #' .labels = sprintf(+ } |
||
| 1607 | -+ | |||
| 291 | +268x |
- #' "%s (Trimmed mean and trim %%)",+ arg |
||
| 1608 | +292 |
- #' labelstr+ } |
||
| 1609 | +293 |
- #' )+ |
||
| 1610 | +294 |
- #' )+ #' Create a custom analysis function wrapping an existing function |
||
| 1611 | +295 |
- #' }+ #' |
||
| 1612 | +296 |
- #'+ #' @param fun (`function`)\cr the function to be wrapped in a new customized analysis function. |
||
| 1613 | +297 |
- #' lyt2 <- basic_table(show_colcounts = TRUE) %>%+ #' `fun` should return a named `list`. |
||
| 1614 | +298 |
- #' split_cols_by("ARM") %>%
+ #' @param .stats (`character`)\cr names of elements to keep from `fun`'s full output. |
||
| 1615 | +299 |
- #' split_rows_by("COUNTRY", split_fun = drop_split_levels) %>%
+ #' @param .formats (`ANY`)\cr vector or list of formats to override any defaults applied by `fun`. |
||
| 1616 | +300 |
- #' summarize_row_groups("AGE",
+ #' @param .labels (`character`)\cr vector of labels to override defaults returned by `fun`. |
||
| 1617 | +301 |
- #' cfun = sfun,+ #' @param .indent_mods (`integer`)\cr named vector of indent modifiers for the generated rows. |
||
| 1618 | +302 |
- #' extra_args = list(trim = .2)+ #' @param .ungroup_stats (`character`)\cr vector of names, which must match elements of `.stats`. |
||
| 1619 | +303 |
- #' ) %>%+ #' @param ... additional arguments to `fun` which effectively become new defaults. These can still be |
||
| 1620 | +304 |
- #' analyze("AGE", afun = list_wrap_x(summary), format = "xx.xx") %>%
+ #' overridden by `extra_args` within a split. |
||
| 1621 | +305 |
- #' append_topleft(c("Country", " Age"))
+ #' @param .null_ref_cells (`flag`)\cr whether cells for the reference column should be `NULL`-ed by the |
||
| 1622 | +306 |
- #'+ #' returned analysis function. Defaults to `TRUE` if `fun` accepts `.in_ref_col` as a formal argument. Note |
||
| 1623 | +307 |
- #' tbl2 <- build_table(lyt2, DM2)+ #' this argument occurs after `...` so it must be *fully* specified by name when set. |
||
| 1624 | +308 |
- #' tbl2+ #' @param .format_na_strs (`ANY`)\cr vector/list of `NA` strings to override any defaults applied by `fun`. |
||
| 1625 | +309 |
#' |
||
| 1626 | +310 |
- #' @author Gabriel Becker+ #' @return A function suitable for use in [analyze()] with element selection, reformatting, and relabeling |
||
| 1627 | +311 |
- #' @export+ #' performed automatically. |
||
| 1628 | +312 |
- summarize_row_groups <- function(lyt,+ #' |
||
| 1629 | +313 |
- var = "",+ #' @note |
||
| 1630 | +314 |
- label_fstr = "%s",+ #' Setting `.ungroup_stats` to non-`NULL` changes the *structure* of the value(s) returned by `fun`, rather than |
||
| 1631 | +315 |
- format = "xx (xx.x%)",+ #' just labeling (`.labels`), formatting (`.formats`), and selecting amongst (`.stats`) them. This means that |
||
| 1632 | +316 |
- na_str = "-",+ #' subsequent `make_afun` calls to customize the output further both can and must operate on the new structure, |
||
| 1633 | +317 |
- cfun = NULL,+ #' *not* the original structure returned by `fun`. See the final pair of examples below. |
||
| 1634 | +318 |
- indent_mod = 0L,+ #' |
||
| 1635 | +319 |
- extra_args = list()) {
+ #' @seealso [analyze()] |
||
| 1636 | -114x | +|||
| 320 | +
- if (is.null(cfun)) {
+ #' |
|||
| 1637 | -101x | +|||
| 321 | +
- if (is.character(format) && length(gregexpr("xx(\\.x*){0,1}", format)[[1]]) == 1) {
+ #' @examples |
|||
| 1638 | -1x | +|||
| 322 | +
- cfun <- .count_raw_constr(var, format, label_fstr)+ #' s_summary <- function(x) {
|
|||
| 1639 | +323 |
- } else {
+ #' stopifnot(is.numeric(x)) |
||
| 1640 | -100x | +|||
| 324 | +
- cfun <- .count_wpcts_constr(var, format, label_fstr)+ #' |
|||
| 1641 | +325 |
- }+ #' list( |
||
| 1642 | +326 |
- }+ #' n = sum(!is.na(x)), |
||
| 1643 | -114x | +|||
| 327 | +
- cfun <- .validate_cfuns(cfun)+ #' mean_sd = c(mean = mean(x), sd = sd(x)), |
|||
| 1644 | -114x | +|||
| 328 | +
- .add_row_summary(lyt,+ #' min_max = range(x) |
|||
| 1645 | -114x | +|||
| 329 | +
- cfun = cfun,+ #' ) |
|||
| 1646 | -114x | +|||
| 330 | +
- cformat = format,+ #' } |
|||
| 1647 | -114x | +|||
| 331 | +
- cna_str = na_str,+ #' |
|||
| 1648 | -114x | +|||
| 332 | +
- indent_mod = indent_mod,+ #' s_summary(iris$Sepal.Length) |
|||
| 1649 | -114x | +|||
| 333 | +
- cvar = var,+ #' |
|||
| 1650 | -114x | +|||
| 334 | +
- extra_args = extra_args+ #' a_summary <- make_afun( |
|||
| 1651 | +335 |
- )+ #' fun = s_summary, |
||
| 1652 | +336 |
- }+ #' .formats = c(n = "xx", mean_sd = "xx.xx (xx.xx)", min_max = "xx.xx - xx.xx"), |
||
| 1653 | +337 |
-
+ #' .labels = c(n = "n", mean_sd = "Mean (sd)", min_max = "min - max") |
||
| 1654 | +338 |
- #' Add the column population counts to the header+ #' ) |
||
| 1655 | +339 |
#' |
||
| 1656 | +340 |
- #' Add the data derived column counts.+ #' a_summary(x = iris$Sepal.Length) |
||
| 1657 | +341 |
#' |
||
| 1658 | +342 |
- #' @details It is often the case that the the column counts derived from the+ #' a_summary2 <- make_afun(a_summary, .stats = c("n", "mean_sd"))
|
||
| 1659 | +343 |
- #' input data to [build_table()] is not representative of the population counts.+ #' |
||
| 1660 | +344 |
- #' For example, if events are counted in the table and the header should+ #' a_summary2(x = iris$Sepal.Length) |
||
| 1661 | +345 |
- #' display the number of subjects and not the total number of events.+ #' |
||
| 1662 | +346 |
- #'+ #' a_summary3 <- make_afun(a_summary, .formats = c(mean_sd = "(xx.xxx, xx.xxx)")) |
||
| 1663 | +347 |
- #' @inheritParams lyt_args+ #' |
||
| 1664 | +348 |
- #'+ #' s_foo <- function(df, .N_col, a = 1, b = 2) {
|
||
| 1665 | +349 |
- #' @inherit split_cols_by return+ #' list( |
||
| 1666 | +350 |
- #'+ #' nrow_df = nrow(df), |
||
| 1667 | +351 |
- #' @examples+ #' .N_col = .N_col, |
||
| 1668 | +352 |
- #' lyt <- basic_table() %>%+ #' a = a, |
||
| 1669 | +353 |
- #' split_cols_by("ARM") %>%
+ #' b = b |
||
| 1670 | +354 |
- #' add_colcounts() %>%+ #' ) |
||
| 1671 | +355 |
- #' split_rows_by("RACE", split_fun = drop_split_levels) %>%
+ #' } |
||
| 1672 | +356 |
- #' analyze("AGE", afun = function(x) list(min = min(x), max = max(x)))
+ #' |
||
| 1673 | +357 |
- #' lyt+ #' s_foo(iris, 40) |
||
| 1674 | +358 |
#' |
||
| 1675 | +359 |
- #' tbl <- build_table(lyt, DM)+ #' a_foo <- make_afun(s_foo, |
||
| 1676 | +360 |
- #' tbl+ #' b = 4, |
||
| 1677 | +361 |
- #'+ #' .formats = c(nrow_df = "xx.xx", ".N_col" = "xx.", a = "xx", b = "xx.x"), |
||
| 1678 | +362 |
- #' @author Gabriel Becker+ #' .labels = c( |
||
| 1679 | +363 |
- #' @export+ #' nrow_df = "Nrow df", |
||
| 1680 | +364 |
- add_colcounts <- function(lyt, format = "(N=xx)") {
- |
- ||
| 1681 | -5x | -
- if (is.null(lyt)) {
- |
- ||
| 1682 | -! | -
- lyt <- PreDataTableLayouts()+ #' ".N_col" = "n in cols", a = "a value", b = "b value" |
||
| 1683 | +365 |
- }+ #' ), |
||
| 1684 | -5x | +|||
| 366 | +
- disp_ccounts(lyt) <- TRUE+ #' .indent_mods = c(nrow_df = 2L, a = 1L) |
|||
| 1685 | -5x | +|||
| 367 | +
- colcount_format(lyt) <- format+ #' ) |
|||
| 1686 | -5x | +|||
| 368 | +
- lyt+ #' |
|||
| 1687 | +369 |
- }+ #' a_foo(iris, .N_col = 40) |
||
| 1688 | +370 |
-
+ #' a_foo2 <- make_afun(a_foo, .labels = c(nrow_df = "Number of Rows")) |
||
| 1689 | +371 |
- ## Currently existing tables can ONLY be added as new entries at the top level, never at any level of nesting.+ #' a_foo2(iris, .N_col = 40) |
||
| 1690 | +372 |
- #' Add an already calculated table to the layout+ #' |
||
| 1691 | +373 |
- #'+ #' # grouping and further customization |
||
| 1692 | +374 |
- #' @inheritParams lyt_args+ #' s_grp <- function(df, .N_col, a = 1, b = 2) {
|
||
| 1693 | +375 |
- #' @inheritParams gen_args+ #' list( |
||
| 1694 | +376 |
- #'+ #' nrow_df = nrow(df), |
||
| 1695 | +377 |
- #' @inherit split_cols_by return+ #' .N_col = .N_col, |
||
| 1696 | +378 |
- #'+ #' letters = list( |
||
| 1697 | +379 |
- #' @examples+ #' a = a, |
||
| 1698 | +380 |
- #' lyt1 <- basic_table() %>%+ #' b = b |
||
| 1699 | +381 |
- #' split_cols_by("ARM") %>%
+ #' ) |
||
| 1700 | +382 |
- #' analyze("AGE", afun = mean, format = "xx.xx")
+ #' ) |
||
| 1701 | +383 |
- #'+ #' } |
||
| 1702 | +384 |
- #' tbl1 <- build_table(lyt1, DM)+ #' a_grp <- make_afun(s_grp, |
||
| 1703 | +385 |
- #' tbl1+ #' b = 3, |
||
| 1704 | +386 |
- #'+ #' .labels = c( |
||
| 1705 | +387 |
- #' lyt2 <- basic_table() %>%+ #' nrow_df = "row count", |
||
| 1706 | +388 |
- #' split_cols_by("ARM") %>%
+ #' .N_col = "count in column" |
||
| 1707 | +389 |
- #' analyze("AGE", afun = sd, format = "xx.xx") %>%
+ #' ), |
||
| 1708 | +390 |
- #' add_existing_table(tbl1)+ #' .formats = c(nrow_df = "xx.", .N_col = "xx."), |
||
| 1709 | +391 |
- #'+ #' .indent_mods = c(letters = 1L), |
||
| 1710 | +392 |
- #' tbl2 <- build_table(lyt2, DM)+ #' .ungroup_stats = "letters" |
||
| 1711 | +393 |
- #' tbl2+ #' ) |
||
| 1712 | +394 |
- #'+ #' a_grp(iris, 40) |
||
| 1713 | +395 |
- #' table_structure(tbl2)+ #' a_aftergrp <- make_afun(a_grp, |
||
| 1714 | +396 |
- #' row_paths_summary(tbl2)+ #' .stats = c("nrow_df", "b"),
|
||
| 1715 | +397 |
- #'+ #' .formats = c(b = "xx.") |
||
| 1716 | +398 |
- #' @author Gabriel Becker+ #' ) |
||
| 1717 | +399 |
- #' @export+ #' a_aftergrp(iris, 40) |
||
| 1718 | +400 |
- add_existing_table <- function(lyt, tt, indent_mod = 0) {
+ #' |
||
| 1719 | -1x | +|||
| 401 | +
- indent_mod(tt) <- indent_mod+ #' s_ref <- function(x, .in_ref_col, .ref_group) {
|
|||
| 1720 | -1x | +|||
| 402 | +
- lyt <- split_rows(+ #' list( |
|||
| 1721 | -1x | +|||
| 403 | +
- lyt,+ #' mean_diff = mean(x) - mean(.ref_group) |
|||
| 1722 | -1x | +|||
| 404 | +
- tt,+ #' ) |
|||
| 1723 | -1x | +|||
| 405 | +
- next_rpos(lyt, nested = FALSE)+ #' } |
|||
| 1724 | +406 |
- )+ #' |
||
| 1725 | -1x | +|||
| 407 | +
- lyt+ #' a_ref <- make_afun(s_ref, |
|||
| 1726 | +408 |
- }+ #' .labels = c(mean_diff = "Mean Difference from Ref") |
||
| 1727 | +409 |
-
+ #' ) |
||
| 1728 | +410 |
- ## takes_coln = function(f) {
+ #' a_ref(iris$Sepal.Length, .in_ref_col = TRUE, 1:10) |
||
| 1729 | +411 |
- ## stopifnot(is(f, "function"))+ #' a_ref(iris$Sepal.Length, .in_ref_col = FALSE, 1:10) |
||
| 1730 | +412 |
- ## forms = names(formals(f))+ #' |
||
| 1731 | +413 |
- ## res = ".N_col" %in% forms+ #' @export |
||
| 1732 | +414 |
- ## res+ make_afun <- function(fun, |
||
| 1733 | +415 |
- ## }+ .stats = NULL, |
||
| 1734 | +416 |
-
+ .formats = NULL, |
||
| 1735 | +417 |
- ## takes_totn = function(f) {
+ .labels = NULL, |
||
| 1736 | +418 |
- ## stopifnot(is(f, "function"))+ .indent_mods = NULL, |
||
| 1737 | +419 |
- ## forms = names(formals(f))+ .ungroup_stats = NULL, |
||
| 1738 | +420 |
- ## res = ".N_total" %in% forms+ .format_na_strs = NULL, |
||
| 1739 | +421 |
- ## res+ ..., |
||
| 1740 | +422 |
- ## }+ .null_ref_cells = ".in_ref_col" %in% names(formals(fun))) {
|
||
| 1741 | +423 |
-
+ ## there is a LOT more computing-on-the-language hackery in here that I |
||
| 1742 | +424 |
- ## use data to transform dynamic cuts to static cuts+ ## would prefer, but currently this is the way I see to do everything we |
||
| 1743 | +425 |
- #' @rdname int_methods+ ## want to do. |
||
| 1744 | -2739x | +|||
| 426 | +
- setGeneric("fix_dyncuts", function(spl, df) standardGeneric("fix_dyncuts"))
+
|
|||
| 1745 | +427 |
-
+ ## too clever by three-quarters (because half wasn't enough) |
||
| 1746 | +428 |
- #' @rdname int_methods+ ## gross scope hackery |
||
| 1747 | -1016x | +429 | +23x |
- setMethod("fix_dyncuts", "Split", function(spl, df) spl)
+ fun_args <- force(list(...)) |
| 1748 | -+ | |||
| 430 | +23x |
-
+ fun_fnames <- names(formals(fun)) |
||
| 1749 | +431 |
- #' @rdname int_methods+ |
||
| 1750 | +432 |
- setMethod(+ ## force EVERYTHING otherwise calling this within loops is the stuff of |
||
| 1751 | +433 |
- "fix_dyncuts", "VarDynCutSplit",+ ## nightmares |
||
| 1752 | -+ | |||
| 434 | +23x |
- function(spl, df) {
+ force(.stats) |
||
| 1753 | -5x | +435 | +23x |
- var <- spl_payload(spl)+ force(.formats) |
| 1754 | -5x | +436 | +23x |
- varvec <- df[[var]]+ force(.format_na_strs) |
| 1755 | -+ | |||
| 437 | +23x |
-
+ force(.labels) |
||
| 1756 | -5x | +438 | +23x |
- cfun <- spl_cutfun(spl)+ force(.indent_mods) |
| 1757 | -5x | +439 | +23x |
- cuts <- cfun(varvec)+ force(.ungroup_stats) |
| 1758 | -5x | +440 | +23x |
- cutlabels <- spl_cutlabelfun(spl)(cuts)+ force(.null_ref_cells) ## this one probably isn't needed? |
| 1759 | -5x | +|||
| 441 | +
- if (length(cutlabels) != length(cuts) - 1 && !is.null(names(cuts))) {
+
|
|||
| 1760 | -1x | +442 | +23x |
- cutlabels <- names(cuts)[-1]+ ret <- function(x, ...) { ## remember formals get clobbered here
|
| 1761 | +443 |
- }+ |
||
| 1762 | +444 |
-
+ ## this helper will grab the value and wrap it in a named list if+ |
+ ||
| 445 | ++ |
+ ## we need the variable and return list() otherwise.+ |
+ ||
| 446 | ++ |
+ ## We define it in here so that the scoping hackery works correctly |
||
| 1763 | -5x | +447 | +66x |
- ret <- make_static_cut_split(+ .if_in_formals <- function(nm, ifnot = list(), named_lwrap = TRUE) {
|
| 1764 | -5x | +448 | +660x |
- var = var, split_label = obj_label(spl),+ val <- if (nm %in% fun_fnames) get(nm) else ifnot |
| 1765 | -5x | +449 | +660x |
- cuts = cuts, cutlabels = cutlabels,+ if (named_lwrap && !identical(val, ifnot)) {
|
| 1766 | -5x | +450 | +78x |
- cumulative = spl_is_cmlcuts(spl)+ setNames(list(val), nm) |
| 1767 | +451 |
- )+ } else {
|
||
| 1768 | -+ | |||
| 452 | +582x |
- ## ret = VarStaticCutSplit(var = var, split_label = obj_label(spl),+ val |
||
| 1769 | +453 |
- ## cuts = cuts, cutlabels = cutlabels)+ } |
||
| 1770 | +454 |
- ## ## classes are tthe same structurally CumulativeCutSplit+ } |
||
| 1771 | +455 |
- ## ## is just a sentinal so it can hit different make_subset_expr+ |
||
| 1772 | -+ | |||
| 456 | +66x |
- ## ## method+ custargs <- fun_args |
||
| 1773 | +457 |
- ## if(spl_is_cmlcuts(spl))+ |
||
| 1774 | +458 |
- ## ret = as(ret, "CumulativeCutSplit")+ ## special handling cause I need it at the bottom as well |
||
| 1775 | -5x | +459 | +66x |
- ret+ in_rc_argl <- .if_in_formals(".in_ref_col")
|
| 1776 | -+ | |||
| 460 | +66x |
- }+ .in_ref_col <- if (length(in_rc_argl) > 0) in_rc_argl[[1]] else FALSE |
||
| 1777 | +461 |
- )+ |
||
| 1778 | -+ | |||
| 462 | +66x |
-
+ sfunargs <- c( |
||
| 1779 | +463 |
- #' @rdname int_methods+ ## these are either named lists containing the arg, or list() |
||
| 1780 | +464 |
- setMethod(+ ## depending on whether fun accept the argument or not |
||
| 1781 | -+ | |||
| 465 | +66x |
- "fix_dyncuts", "VTableTree",+ .if_in_formals("x"),
|
||
| 1782 | -1x | +466 | +66x |
- function(spl, df) spl+ .if_in_formals("df"),
|
| 1783 | -+ | |||
| 467 | +66x |
- )+ .if_in_formals(".N_col"),
|
||
| 1784 | -+ | |||
| 468 | +66x |
-
+ .if_in_formals(".N_total"),
|
||
| 1785 | -+ | |||
| 469 | +66x |
- .fd_helper <- function(spl, df) {
+ .if_in_formals(".N_row"),
|
||
| 1786 | -1380x | +470 | +66x |
- lst <- lapply(spl, fix_dyncuts, df = df)+ .if_in_formals(".ref_group"),
|
| 1787 | -1380x | +471 | +66x |
- spl@.Data <- lst+ in_rc_argl, |
| 1788 | -1380x | +472 | +66x |
- spl+ .if_in_formals(".df_row"),
|
| 1789 | -+ | |||
| 473 | +66x |
- }+ .if_in_formals(".var"),
|
||
| 1790 | -+ | |||
| 474 | +66x |
-
+ .if_in_formals(".ref_full")
|
||
| 1791 | +475 |
- #' @rdname int_methods+ ) |
||
| 1792 | +476 |
- setMethod(+ |
||
| 1793 | -+ | |||
| 477 | +66x |
- "fix_dyncuts", "PreDataRowLayout",+ allvars <- setdiff(fun_fnames, c("...", names(sfunargs)))
|
||
| 1794 | +478 |
- function(spl, df) {
+ ## values int he actual call to this function override customization |
||
| 1795 | +479 |
- # rt = root_spl(spl)+ ## done by the constructor. evalparse is to avoid a "... in wrong context" NOTE |
||
| 1796 | -337x | +480 | +66x |
- ret <- .fd_helper(spl, df)+ if ("..." %in% fun_fnames) {
|
| 1797 | -+ | |||
| 481 | +5x |
- # root_spl(ret) = rt+ exargs <- eval(parser_helper(text = "list(...)")) |
||
| 1798 | -337x | +482 | +5x |
- ret+ custargs[names(exargs)] <- exargs |
| 1799 | -+ | |||
| 483 | +5x |
- }+ allvars <- unique(c(allvars, names(custargs))) |
||
| 1800 | +484 |
- )+ } |
||
| 1801 | +485 | |||
| 486 | +66x | +
+ for (var in allvars) {
+ |
+ ||
| 1802 | +487 |
- #' @rdname int_methods+ ## not missing, i.e. specified in the direct call, takes precedence+ |
+ ||
| 488 | +22x | +
+ if (var %in% fun_fnames && eval(parser_helper(text = paste0("!missing(", var, ")")))) {
+ |
+ ||
| 489 | +5x | +
+ sfunargs[[var]] <- get(var)+ |
+ ||
| 490 | +17x | +
+ } else if (var %in% names(custargs)) { ## not specified in the call, but specified in the constructor
+ |
+ ||
| 491 | +4x | +
+ sfunargs[[var]] <- custargs[[var]] |
||
| 1803 | +492 |
- setMethod(+ } |
||
| 1804 | +493 |
- "fix_dyncuts", "PreDataColLayout",+ ## else left out so we hit the original default we inherited from fun |
||
| 1805 | +494 |
- function(spl, df) {
+ } |
||
| 1806 | +495 |
- # rt = root_spl(spl)+ |
||
| 1807 | -337x | +496 | +66x |
- ret <- .fd_helper(spl, df)+ rawvals <- do.call(fun, sfunargs) |
| 1808 | +497 |
- # root_spl(ret) = rt+ |
||
| 1809 | +498 |
- # disp_ccounts(ret) = disp_ccounts(spl)+ ## note single brackets here so its a list |
||
| 1810 | +499 |
- # colcount_format(ret) = colcount_format(spl)+ ## no matter what. thats important! |
||
| 1811 | -337x | +500 | +66x |
- ret+ final_vals <- if (is.null(.stats)) rawvals else rawvals[.stats] |
| 1812 | +501 |
- }+ |
||
| 1813 | -+ | |||
| 502 | +66x |
- )+ if (!is.list(rawvals)) {
|
||
| 1814 | -+ | |||
| 503 | +! |
-
+ stop("make_afun expects a function fun that always returns a list")
|
||
| 1815 | +504 |
- #' @rdname int_methods+ } |
||
| 1816 | -+ | |||
| 505 | +66x |
- setMethod(+ if (!is.null(.stats)) {
|
||
| 1817 | -+ | |||
| 506 | +10x |
- "fix_dyncuts", "SplitVector",+ stopifnot(all(.stats %in% names(rawvals))) |
||
| 1818 | +507 |
- function(spl, df) {
+ } else {
|
||
| 1819 | -706x | +508 | +56x |
- .fd_helper(spl, df)+ .stats <- names(rawvals) |
| 1820 | +509 |
- }+ } |
||
| 1821 | -+ | |||
| 510 | +66x |
- )+ if (!is.null(.ungroup_stats) && !all(.ungroup_stats %in% .stats)) {
|
||
| 1822 | -+ | |||
| 511 | +! |
-
+ stop( |
||
| 1823 | -+ | |||
| 512 | +! |
- #' @rdname int_methods+ "Stats specified for ungrouping not included in non-null .stats list: ",+ |
+ ||
| 513 | +! | +
+ setdiff(.ungroup_stats, .stats) |
||
| 1824 | +514 |
- setMethod(+ ) |
||
| 1825 | +515 |
- "fix_dyncuts", "PreDataTableLayouts",+ } |
||
| 1826 | +516 |
- function(spl, df) {
+
|
||
| 1827 | -337x | +517 | +66x |
- rlayout(spl) <- fix_dyncuts(rlayout(spl), df)+ .labels <- .validate_nms(final_vals, .stats, .labels) |
| 1828 | -337x | +518 | +66x |
- clayout(spl) <- fix_dyncuts(clayout(spl), df)+ .formats <- .validate_nms(final_vals, .stats, .formats) |
| 1829 | -337x | +519 | +66x |
- spl+ .indent_mods <- .validate_nms(final_vals, .stats, .indent_mods) |
| 1830 | -+ | |||
| 520 | +66x |
- }+ .format_na_strs <- .validate_nms(final_vals, .stats, .format_na_strs) |
||
| 1831 | +521 |
- )+ + |
+ ||
| 522 | +66x | +
+ final_labels <- value_labels(final_vals)+ |
+ ||
| 523 | +66x | +
+ final_labels[names(.labels)] <- .labels |
||
| 1832 | +524 | |||
| 1833 | -+ | |||
| 525 | +66x |
- ## Manual column construction in a simple (seeming to the user) way.+ final_formats <- lapply(final_vals, obj_format) |
||
| 1834 | -+ | |||
| 526 | +66x |
- #' Manual column declaration+ final_formats[names(.formats)] <- .formats |
||
| 1835 | +527 |
- #'+ |
||
| 1836 | -+ | |||
| 528 | +66x |
- #' @param ... one or more vectors of levels to appear in the column space. If more than one set of levels is given,+ final_format_na_strs <- lapply(final_vals, obj_na_str) |
||
| 1837 | -+ | |||
| 529 | +66x |
- #' the values of the second are nested within each value of the first, and so on.+ final_format_na_strs[names(.format_na_strs)] <- .format_na_strs |
||
| 1838 | +530 |
- #' @param .lst (`list`)\cr a list of sets of levels, by default populated via `list(...)`.+ |
||
| 1839 | -+ | |||
| 531 | +66x |
- #' @param ccount_format (`FormatSpec`)\cr the format to use when counts are displayed.+ if (is(final_vals, "RowsVerticalSection")) {
|
||
| 1840 | -+ | |||
| 532 | +20x |
- #'+ final_imods <- indent_mod(final_vals) |
||
| 1841 | +533 |
- #' @return An `InstantiatedColumnInfo` object, suitable for declaring the column structure for a manually constructed+ } else {
|
||
| 1842 | -+ | |||
| 534 | +46x |
- #' table.+ final_imods <- vapply(final_vals, indent_mod, 1L) |
||
| 1843 | +535 |
- #'+ } |
||
| 1844 | -+ | |||
| 536 | +66x |
- #' @examples+ final_imods[names(.indent_mods)] <- .indent_mods |
||
| 1845 | +537 |
- #' # simple one level column space+ |
||
| 1846 | -+ | |||
| 538 | +66x |
- #' rows <- lapply(1:5, function(i) {
+ if (!is.null(.ungroup_stats)) {
|
||
| 1847 | -+ | |||
| 539 | +2x |
- #' DataRow(rep(i, times = 3))+ for (nm in .ungroup_stats) {
|
||
| 1848 | -+ | |||
| 540 | +3x |
- #' })+ tmp <- final_vals[[nm]] |
||
| 1849 | -+ | |||
| 541 | +3x |
- #' tbl <- TableTree(kids = rows, cinfo = manual_cols(split = c("a", "b", "c")))
+ if (is(tmp, "CellValue")) {
|
||
| 1850 | -+ | |||
| 542 | +1x |
- #' tbl+ tmp <- tmp[[1]] |
||
| 1851 | -+ | |||
| 543 | +23x |
- #'+ } ## unwrap it |
||
| 1852 | -+ | |||
| 544 | +3x |
- #' # manually declared nesting+ final_vals <- insert_replace(final_vals, nm, tmp) |
||
| 1853 | -+ | |||
| 545 | +3x |
- #' tbl2 <- TableTree(+ stopifnot(all(nzchar(names(final_vals)))) |
||
| 1854 | +546 |
- #' kids = list(DataRow(as.list(1:4))),+ |
||
| 1855 | -+ | |||
| 547 | +3x |
- #' cinfo = manual_cols(+ final_labels <- insert_replace( |
||
| 1856 | -+ | |||
| 548 | +3x |
- #' Arm = c("Arm A", "Arm B"),
+ final_labels, |
||
| 1857 | -+ | |||
| 549 | +3x |
- #' Gender = c("M", "F")
+ nm, |
||
| 1858 | -+ | |||
| 550 | +3x |
- #' )+ setNames( |
||
| 1859 | -+ | |||
| 551 | +3x |
- #' )+ value_labels(tmp), |
||
| 1860 | -+ | |||
| 552 | +3x |
- #' tbl2+ names(tmp) |
||
| 1861 | +553 |
- #'+ ) |
||
| 1862 | +554 |
- #' @author Gabriel Becker+ ) |
||
| 1863 | -+ | |||
| 555 | +3x |
- #' @export+ final_formats <- insert_replace( |
||
| 1864 | -+ | |||
| 556 | +3x |
- manual_cols <- function(..., .lst = list(...), ccount_format = NULL) {
+ final_formats, |
||
| 1865 | -41x | +557 | +3x |
- if (is.null(names(.lst))) {
+ nm, |
| 1866 | -41x | +558 | +3x |
- names(.lst) <- paste("colsplit", seq_along(.lst))
+ setNames( |
| 1867 | -+ | |||
| 559 | +3x | +
+ rep(final_formats[nm],+ |
+ ||
| 560 | +3x |
- }+ length.out = length(tmp) |
||
| 1868 | +561 | - - | -||
| 1869 | -41x | -
- splvec <- SplitVector(lst = mapply(ManualSplit,+ ), |
||
| 1870 | -41x | +562 | +3x |
- levels = .lst,+ names(tmp) |
| 1871 | -41x | +|||
| 563 | +
- label = names(.lst)+ ) |
|||
| 1872 | +564 |
- ))+ ) |
||
| 1873 | -41x | +565 | +3x |
- ctree <- splitvec_to_coltree(data.frame(), splvec = splvec, pos = TreePos(), global_cc_format = ccount_format)+ final_format_na_strs <- insert_replace( |
| 1874 | -+ | |||
| 566 | +3x |
-
+ final_format_na_strs, |
||
| 1875 | -41x | +567 | +3x |
- ret <- InstantiatedColumnInfo(treelyt = ctree)+ nm, |
| 1876 | -41x | +568 | +3x |
- rm_all_colcounts(ret)+ setNames( |
| 1877 | -+ | |||
| 569 | +3x |
- }+ rep(final_format_na_strs[nm], |
||
| 1878 | -+ | |||
| 570 | +3x |
-
+ length.out = length(tmp) |
||
| 1879 | +571 |
-
+ ), |
||
| 1880 | -+ | |||
| 572 | +3x |
- #' Set all column counts at all levels of nesting to NA+ names(tmp) |
||
| 1881 | +573 |
- #'+ ) |
||
| 1882 | +574 |
- #' @inheritParams gen_args+ ) |
||
| 1883 | -+ | |||
| 575 | +3x |
- #'+ final_imods <- insert_replace( |
||
| 1884 | -+ | |||
| 576 | +3x |
- #' @return `obj` with all column counts reset to missing+ final_imods, |
||
| 1885 | -+ | |||
| 577 | +3x |
- #'+ nm, |
||
| 1886 | -+ | |||
| 578 | +3x |
- #' @export+ setNames( |
||
| 1887 | -+ | |||
| 579 | +3x |
- #' @examples+ rep(final_imods[nm], |
||
| 1888 | -+ | |||
| 580 | +3x |
- #' lyt <- basic_table() %>%+ length.out = length(tmp) |
||
| 1889 | +581 |
- #' split_cols_by("ARM") %>%
+ ), |
||
| 1890 | -+ | |||
| 582 | +3x |
- #' split_cols_by("SEX") %>%
+ names(tmp) |
||
| 1891 | +583 |
- #' analyze("AGE")
+ ) |
||
| 1892 | +584 |
- #' tbl <- build_table(lyt, ex_adsl)+ ) |
||
| 1893 | +585 |
- #'+ } |
||
| 1894 | +586 |
- #' # before+ } |
||
| 1895 | -+ | |||
| 587 | +66x |
- #' col_counts(tbl)+ rcells <- mapply( |
||
| 1896 | -+ | |||
| 588 | +66x |
- #' tbl <- rm_all_colcounts(tbl)+ function(x, f, l, na_str) {
|
||
| 1897 | -+ | |||
| 589 | +197x |
- #' col_counts(tbl)+ if (is(x, "CellValue")) {
|
||
| 1898 | -229x | +590 | +65x |
- setGeneric("rm_all_colcounts", function(obj) standardGeneric("rm_all_colcounts"))
+ obj_label(x) <- l |
| 1899 | -+ | |||
| 591 | +65x |
-
+ obj_format(x) <- f |
||
| 1900 | -+ | |||
| 592 | +65x |
- #' @rdname rm_all_colcounts+ obj_na_str(x) <- na_str |
||
| 1901 | +593 |
- #' @export+ # indent_mod(x) <- im |
||
| 1902 | -+ | |||
| 594 | +65x |
- setMethod(+ x |
||
| 1903 | -+ | |||
| 595 | +132x |
- "rm_all_colcounts", "VTableTree",+ } else if (.null_ref_cells) {
|
||
| 1904 | -+ | |||
| 596 | +! |
- function(obj) {
+ non_ref_rcell(x, |
||
| 1905 | +597 | ! |
- cinfo <- col_info(obj)+ is_ref = .in_ref_col, |
|
| 1906 | +598 | ! |
- cinfo <- rm_all_colcounts(cinfo)+ format = f, label = l, |
|
| 1907 | +599 | ! |
- col_info(obj) <- cinfo+ format_na_str = na_str |
|
| 1908 | +600 | ! |
- obj+ ) # , indent_mod = im) |
|
| 1909 | +601 |
- }+ } else {
|
||
| 1910 | -+ | |||
| 602 | +132x |
- )+ rcell(x, format = f, label = l, format_na_str = na_str) # , indent_mod = im) |
||
| 1911 | +603 |
-
+ } |
||
| 1912 | +604 |
- #' @rdname rm_all_colcounts+ }, |
||
| 1913 | -+ | |||
| 605 | +66x |
- #' @export+ f = final_formats, x = final_vals, |
||
| 1914 | -+ | |||
| 606 | +66x |
- setMethod(+ l = final_labels,+ |
+ ||
| 607 | +66x | +
+ na_str = final_format_na_strs, |
||
| 1915 | +608 |
- "rm_all_colcounts", "InstantiatedColumnInfo",+ # im = final_imods,+ |
+ ||
| 609 | +66x | +
+ SIMPLIFY = FALSE |
||
| 1916 | +610 |
- function(obj) {
+ ) |
||
| 1917 | -41x | +611 | +66x |
- ctree <- coltree(obj)+ in_rows(.list = rcells, .indent_mods = final_imods) ## , .labels = .labels) |
| 1918 | -41x | +|||
| 612 | +
- ctree <- rm_all_colcounts(ctree)+ } |
|||
| 1919 | -41x | +613 | +23x |
- coltree(obj) <- ctree+ formals(ret) <- formals(fun) |
| 1920 | -41x | +614 | +23x |
- obj+ ret |
| 1921 | +615 |
- }+ } |
||
| 1922 | +616 |
- )+ |
||
| 1923 | +617 |
-
+ insert_replace <- function(x, nm, newvals = x[[nm]]) {
|
||
| 1924 | -+ | |||
| 618 | +15x |
- #' @rdname rm_all_colcounts+ i <- match(nm, names(x)) |
||
| 1925 | -+ | |||
| 619 | +15x |
- #' @export+ if (is.na(i)) {
|
||
| 1926 | -+ | |||
| 620 | +! |
- setMethod(+ stop("name not found")
|
||
| 1927 | +621 |
- "rm_all_colcounts", "LayoutColTree",+ } |
||
| 1928 | -+ | |||
| 622 | +15x |
- function(obj) {
+ bef <- if (i > 1) 1:(i - 1) else numeric() |
||
| 1929 | -52x | +623 | +15x |
- obj@column_count <- NA_integer_+ aft <- if (i < length(x)) (i + 1):length(x) else numeric() |
| 1930 | -52x | +624 | +15x |
- tree_children(obj) <- lapply(tree_children(obj), rm_all_colcounts)+ ret <- c(x[bef], newvals, x[aft]) |
| 1931 | -52x | +625 | +15x |
- obj+ names(ret) <- c(names(x)[bef], names(newvals), names(x)[aft]) |
| 1932 | -+ | |||
| 626 | +15x |
- }+ ret |
||
| 1933 | +627 |
- )+ } |
||
| 1934 | +628 | |||
| 1935 | +629 |
- #' @rdname rm_all_colcounts+ parser_helper <- function(text, envir = parent.frame(2)) {
|
||
| 1936 | -+ | |||
| 630 | +513x |
- #' @export+ parse(text = text, keep.source = FALSE) |
||
| 1937 | +631 |
- setMethod(+ } |
||
| 1938 | +632 |
- "rm_all_colcounts", "LayoutColLeaf",+ |
||
| 1939 | +633 |
- function(obj) {
+ length_w_name <- function(x, .parent_splval) {
|
||
| 1940 | -136x | +|||
| 634 | +! |
- obj@column_count <- NA_integer_+ in_rows(length(x), |
||
| 1941 | -136x | +|||
| 635 | +! |
- obj+ .names = value_labels(.parent_splval) |
||
| 1942 | +636 |
- }+ ) |
||
| 1943 | +637 |
- )+ } |
| 1944 | +1 |
-
+ ## Rules for pagination |
||
| 1945 | +2 |
- #' Returns a function that coerces the return values of a function to a list+ ## |
||
| 1946 | +3 |
- #'+ ## 1. user defined number of lines per page |
||
| 1947 | +4 |
- #' @param f (`function`)\cr the function to wrap.+ ## 2. all lines have the same height |
||
| 1948 | +5 |
- #'+ ## 3. header always reprinted on all pages |
||
| 1949 | +6 |
- #' @details+ ## 4. "Label-rows", i.e. content rows above break in the nesting structure, optionally reprinted (default TRUE) |
||
| 1950 | +7 |
- #' `list_wrap_x` generates a wrapper which takes `x` as its first argument, while `list_wrap_df` generates an+ ## 5. Never (?) break on a "label"/content row |
||
| 1951 | +8 |
- #' otherwise identical wrapper function whose first argument is named `df`.+ ## 6. Never (?) break on the second (i.e. after the first) data row at a particular leaf Elementary table. |
||
| 1952 | +9 |
- #'+ ## |
||
| 1953 | +10 |
- #' We provide both because when using the functions as tabulation in [analyze()], functions which take `df` as+ ## Current behavior: paginate_ttree takes a TableTree object and |
||
| 1954 | +11 |
- #' their first argument are passed the full subset data frame, while those which accept anything else notably+ ## returns a list of rtable (S3) objects for printing. |
||
| 1955 | +12 |
- #' including `x` are passed only the relevant subset of the variable being analyzed.+ |
||
| 1956 | +13 |
- #'+ #' @inheritParams formatters::nlines |
||
| 1957 | +14 |
- #' @return A function that returns a list of `CellValue` objects.+ #' |
||
| 1958 | +15 |
- #'+ #' @rdname formatters_methods |
||
| 1959 | +16 |
- #' @examples+ #' @aliases nlines,TableRow-method |
||
| 1960 | +17 |
- #' summary(iris$Sepal.Length)+ #' @exportMethod nlines |
||
| 1961 | +18 |
- #'+ setMethod( |
||
| 1962 | +19 |
- #' f <- list_wrap_x(summary)+ "nlines", "TableRow", |
||
| 1963 | +20 |
- #' f(x = iris$Sepal.Length)+ function(x, colwidths, max_width, fontspec, col_gap = 3) {
|
||
| 1964 | -+ | |||
| 21 | +10622x |
- #'+ fns <- sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) + |
||
| 1965 | -+ | |||
| 22 | +10622x |
- #' f2 <- list_wrap_df(summary)+ sum(unlist(lapply(cell_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) |
||
| 1966 | -+ | |||
| 23 | +10622x |
- #' f2(df = iris$Sepal.Length)+ fcells <- as.vector(get_formatted_cells(x)) |
||
| 1967 | -+ | |||
| 24 | +10622x |
- #'+ spans <- row_cspans(x) |
||
| 1968 | -+ | |||
| 25 | +10622x |
- #' @author Gabriel Becker+ have_cw <- !is.null(colwidths) |
||
| 1969 | +26 |
- #' @rdname list_wrap+ ## handle spanning so that the projected word-wrapping from nlines is correct |
||
| 1970 | -+ | |||
| 27 | +10622x |
- #' @export+ if (any(spans > 1)) {
|
||
| 1971 | -+ | |||
| 28 | +10x |
- list_wrap_x <- function(f) {
+ new_fcells <- character(length(spans)) |
||
| 1972 | -16x | +29 | +10x |
- function(x, ...) {
+ new_colwidths <- numeric(length(spans)) |
| 1973 | -70x | +30 | +10x |
- vs <- as.list(f(x, ...))+ cur_fcells <- fcells |
| 1974 | -70x | +31 | +10x |
- ret <- mapply(+ cur_colwidths <- colwidths[-1] ## not the row labels they can't span |
| 1975 | -70x | +32 | +10x |
- function(v, nm) {
+ for (i in seq_along(spans)) {
|
| 1976 | -250x | +33 | +24x |
- rcell(v, label = nm)+ spi <- spans[i] |
| 1977 | -+ | |||
| 34 | +24x |
- },+ new_fcells[i] <- cur_fcells[1] ## 1 cause we're trimming it every loop |
||
| 1978 | -70x | +35 | +24x |
- v = vs,+ new_colwidths[i] <- sum(head(cur_colwidths, spi)) + col_gap * (spi - 1) |
| 1979 | -70x | +36 | +24x |
- nm = names(vs)+ cur_fcells <- tail(cur_fcells, -1 * spi)+ |
+
| 37 | +24x | +
+ cur_colwidths <- tail(cur_colwidths, -1 * spi) |
||
| 1980 | +38 |
- )+ } |
||
| 1981 | -70x | +39 | +10x |
- ret+ if (have_cw) {
+ |
+
| 40 | +4x | +
+ colwidths <- c(colwidths[1], new_colwidths) |
||
| 1982 | +41 |
- }+ }+ |
+ ||
| 42 | +10x | +
+ fcells <- new_fcells |
||
| 1983 | +43 |
- }+ } |
||
| 1984 | +44 | |||
| 1985 | +45 |
- #' @rdname list_wrap+ ## rowext <- max(vapply(strsplit(c(obj_label(x), fcells), "\n", fixed = TRUE), |
||
| 1986 | +46 |
- #' @export+ ## length, |
||
| 1987 | +47 |
- list_wrap_df <- function(f) {
+ ## 1L)) |
||
| 1988 | -1x | +48 | +10622x |
- function(df, ...) {
+ rowext <- max( |
| 1989 | -1x | +49 | +10622x |
- vs <- as.list(f(df, ...))+ unlist( |
| 1990 | -1x | +50 | +10622x |
- ret <- mapply(+ mapply( |
| 1991 | -1x | +51 | +10622x |
- function(v, nm) {
+ function(s, w) {
|
| 1992 | -6x | +52 | +57987x |
- rcell(v, label = nm)+ nlines(strsplit(s, "\n", fixed = TRUE), max_width = w, fontspec = fontspec) |
| 1993 | +53 |
- },+ }, |
||
| 1994 | -1x | +54 | +10622x |
- v = vs,+ s = c(obj_label(x), fcells), |
| 1995 | -1x | +55 | +10622x |
- nm = names(vs)+ w = (colwidths %||% max_width) %||% vector("list", length(c(obj_label(x), fcells))),
|
| 1996 | -+ | |||
| 56 | +10622x |
- )+ SIMPLIFY = FALSE |
||
| 1997 | -1x | +|||
| 57 | +
- ret+ ) |
|||
| 1998 | +58 |
- }+ ) |
||
| 1999 | +59 |
- }+ ) |
||
| 2000 | +60 | |||
| 2001 | -+ | |||
| 61 | +10622x |
- #' Layout with 1 column and zero rows+ rowext + fns |
||
| 2002 | +62 |
- #'+ } |
||
| 2003 | +63 |
- #' Every layout must start with a basic table.+ ) |
||
| 2004 | +64 |
- #'+ |
||
| 2005 | +65 |
- #' @inheritParams constr_args+ #' @export |
||
| 2006 | +66 |
- #' @param show_colcounts (`logical(1)`)\cr Indicates whether the lowest level of+ #' @rdname formatters_methods |
||
| 2007 | +67 |
- #' applied to data. `NA`, the default, indicates that the `show_colcounts`+ setMethod( |
||
| 2008 | +68 |
- #' argument(s) passed to the relevant calls to `split_cols_by*`+ "nlines", "LabelRow", |
||
| 2009 | +69 |
- #' functions. Non-missing values will override the behavior specified in+ function(x, colwidths, max_width, fontspec = fontspec, col_gap = NULL) {
|
||
| 2010 | -+ | |||
| 70 | +3361x |
- #' column splitting layout instructions which create the lowest level, or+ if (labelrow_visible(x)) {
|
||
| 2011 | -+ | |||
| 71 | +3361x |
- #' leaf, columns.+ nlines(strsplit(obj_label(x), "\n", fixed = TRUE)[[1]], max_width = colwidths[1], fontspec = fontspec) + |
||
| 2012 | -+ | |||
| 72 | +3361x |
- #' @param colcount_format (`string`)\cr format for use when displaying the column counts. Must be 1d, or 2d+ sum(unlist(lapply(row_footnotes(x), nlines, max_width = max_width, fontspec = fontspec))) |
||
| 2013 | +73 |
- #' where one component is a percent. This will also apply to any displayed higher+ } else {
+ |
+ ||
| 74 | +! | +
+ 0L |
||
| 2014 | +75 |
- #' level column counts where an explicit format was not specified. Defaults to `"(N=xx)"`. See Details below.+ } |
||
| 2015 | +76 |
- #' @param top_level_section_div (`character(1)`)\cr if assigned a single character, the first (top level) split+ } |
||
| 2016 | +77 |
- #' or division of the table will be highlighted by a line made of that character. See [section_div] for more+ ) |
||
| 2017 | +78 |
- #' information.+ |
||
| 2018 | +79 |
- #'+ #' @export |
||
| 2019 | +80 |
- #' @details+ #' @rdname formatters_methods |
||
| 2020 | +81 |
- #' `colcount_format` is ignored if `show_colcounts` is `FALSE` (the default). When `show_colcounts` is `TRUE`,+ setMethod( |
||
| 2021 | +82 |
- #' and `colcount_format` is 2-dimensional with a percent component, the value component for the percent is always+ "nlines", "RefFootnote", |
||
| 2022 | +83 |
- #' populated with `1` (i.e. 100%). 1d formats are used to render the counts exactly as they normally would be,+ function(x, colwidths, max_width, fontspec, col_gap = NULL) {
+ |
+ ||
| 84 | +298x | +
+ nlines(format_fnote_note(x), colwidths = colwidths, max_width = max_width, fontspec = fontspec) |
||
| 2023 | +85 |
- #' while 2d formats which don't include a percent, and all 3d formats result in an error. Formats in the form of+ } |
||
| 2024 | +86 |
- #' functions are not supported for `colcount` format. See [formatters::list_valid_format_labels()] for the list+ ) |
||
| 2025 | +87 |
- #' of valid format labels to select from.+ |
||
| 2026 | +88 |
- #'+ #' @export |
||
| 2027 | +89 |
- #' @inherit split_cols_by return+ #' @rdname formatters_methods |
||
| 2028 | +90 |
- #'+ setMethod( |
||
| 2029 | +91 |
- #' @note+ "nlines", "InstantiatedColumnInfo", |
||
| 2030 | +92 |
- #' - Because percent components in `colcount_format` are *always* populated with the value 1, we can get arguably+ function(x, colwidths, max_width, fontspec, col_gap = 3) {
+ |
+ ||
| 93 | +6x | +
+ h_rows <- .do_tbl_h_piece2(x)+ |
+ ||
| 94 | +6x | +
+ tl <- top_left(x) %||% rep("", length(h_rows))
+ |
+ ||
| 95 | +6x | +
+ main_nls <- vapply(+ |
+ ||
| 96 | +6x | +
+ seq_along(h_rows),+ |
+ ||
| 97 | +6x | +
+ function(i) {
+ |
+ ||
| 98 | +10x | +
+ max(+ |
+ ||
| 99 | +10x | +
+ nlines(h_rows[[i]],+ |
+ ||
| 100 | +10x | +
+ colwidths = colwidths,+ |
+ ||
| 101 | +10x | +
+ fontspec = fontspec,+ |
+ ||
| 102 | +10x | +
+ col_gap = col_gap |
||
| 2031 | +103 |
- #' strange results, such as that individual arm columns and a combined "all patients" column all list "100%" as+ ),+ |
+ ||
| 104 | +10x | +
+ nlines(tl[i],+ |
+ ||
| 105 | +10x | +
+ colwidths = colwidths[1],+ |
+ ||
| 106 | +10x | +
+ fontspec = fontspec |
||
| 2032 | +107 |
- #' their percentage, even though the individual arm columns represent strict subsets of the "all patients" column.+ ) |
||
| 2033 | +108 |
- #'+ ) |
||
| 2034 | +109 |
- #' - Note that subtitles ([formatters::subtitles()]) and footers ([formatters::main_footer()] and+ }, |
||
| 2035 | -+ | |||
| 110 | +6x |
- #' [formatters::prov_footer()]) that span more than one line can be supplied as a character vector to maintain+ 1L |
||
| 2036 | +111 |
- #' indentation on multiple lines.+ ) |
||
| 2037 | +112 |
- #'+ |
||
| 2038 | +113 |
- #' @examples+ ## lfs <- collect_leaves(coltree(x)) |
||
| 2039 | +114 |
- #' lyt <- basic_table() %>%+ ## depths <- sapply(lfs, function(l) length(pos_splits(l))) |
||
| 2040 | +115 |
- #' analyze("AGE", afun = mean)
+
|
||
| 2041 | -+ | |||
| 116 | +6x |
- #'+ coldf <- make_col_df(x, colwidths = colwidths) |
||
| 2042 | -+ | |||
| 117 | +6x |
- #' tbl <- build_table(lyt, DM)+ have_fnotes <- length(unlist(coldf$col_fnotes)) > 0 |
||
| 2043 | +118 |
- #' tbl+ ## ret <- max(depths, length(top_left(x))) + |
||
| 2044 | +119 |
- #'+ ## divider_height(x) |
||
| 2045 | -+ | |||
| 120 | +6x |
- #' lyt2 <- basic_table(+ ret <- sum(main_nls, divider_height(x)) |
||
| 2046 | -+ | |||
| 121 | +6x |
- #' title = "Title of table",+ if (have_fnotes) {
|
||
| 2047 | -+ | |||
| 122 | +! |
- #' subtitles = c("a number", "of subtitles"),
+ ret <- sum( |
||
| 2048 | -+ | |||
| 123 | +! |
- #' main_footer = "test footer",+ ret, |
||
| 2049 | -+ | |||
| 124 | +! |
- #' prov_footer = paste(+ vapply(unlist(coldf$col_fnotes), |
||
| 2050 | -+ | |||
| 125 | +! |
- #' "test.R program, executed at",+ nlines, |
||
| 2051 | -+ | |||
| 126 | +! |
- #' Sys.time()+ 1, |
||
| 2052 | -+ | |||
| 127 | +! |
- #' )+ max_width = max_width, |
||
| 2053 | -+ | |||
| 128 | +! |
- #' ) %>%+ fontspec = fontspec |
||
| 2054 | +129 |
- #' split_cols_by("ARM") %>%
+ ), |
||
| 2055 | -+ | |||
| 130 | +! |
- #' analyze("AGE", mean)
+ 2 * divider_height(x) |
||
| 2056 | +131 |
- #'+ ) |
||
| 2057 | +132 |
- #' tbl2 <- build_table(lyt2, DM)+ } |
||
| 2058 | -+ | |||
| 133 | +6x |
- #' tbl2+ ret |
||
| 2059 | +134 |
- #'+ } |
||
| 2060 | +135 |
- #' lyt3 <- basic_table(+ ) |
||
| 2061 | +136 |
- #' show_colcounts = TRUE,+ |
||
| 2062 | +137 |
- #' colcount_format = "xx. (xx.%)"+ col_dfrow <- function(col, |
||
| 2063 | +138 |
- #' ) %>%+ nm = obj_name(col), |
||
| 2064 | +139 |
- #' split_cols_by("ARM")
+ lab = obj_label(col), |
||
| 2065 | +140 |
- #'+ cnum, |
||
| 2066 | +141 |
- #' @export+ pth = NULL, |
||
| 2067 | +142 |
- basic_table <- function(title = "",+ sibpos = NA_integer_, |
||
| 2068 | +143 |
- subtitles = character(),+ nsibs = NA_integer_, |
||
| 2069 | +144 |
- main_footer = character(),+ leaf_indices = cnum, |
||
| 2070 | +145 |
- prov_footer = character(),+ span = length(leaf_indices), |
||
| 2071 | +146 |
- show_colcounts = NA, # FALSE,+ col_fnotes = list(), |
||
| 2072 | +147 |
- colcount_format = "(N=xx)",+ col_count = facet_colcount(col, NULL), |
||
| 2073 | +148 |
- header_section_div = NA_character_,+ ccount_visible = disp_ccounts(col), |
||
| 2074 | +149 |
- top_level_section_div = NA_character_,+ ccount_format = colcount_format(col), |
||
| 2075 | +150 |
- inset = 0L) {
+ ccount_na_str, |
||
| 2076 | -322x | +|||
| 151 | +
- inset <- as.integer(inset)+ global_cc_format) {
|
|||
| 2077 | -322x | +152 | +13105x |
- if (is.na(inset) || inset < 0L) {
+ if (is.null(pth)) {
|
| 2078 | -2x | +153 | +12461x |
- stop("Got invalid table_inset value, must be an integer > 0")
+ pth <- pos_to_path(tree_pos(col)) |
| 2079 | +154 |
} |
||
| 2080 | -320x | +155 | +13105x |
- .check_header_section_div(header_section_div)+ data.frame( |
| 2081 | -320x | -
- checkmate::assert_character(top_level_section_div, len = 1, n.chars = 1)- |
- ||
| 2082 | -+ | 156 | +13105x |
-
+ stringsAsFactors = FALSE, |
| 2083 | -320x | +157 | +13105x |
- ret <- PreDataTableLayouts(+ name = nm, |
| 2084 | -320x | +158 | +13105x |
- title = title,+ label = lab, |
| 2085 | -320x | +159 | +13105x |
- subtitles = subtitles,+ abs_pos = cnum, |
| 2086 | -320x | +160 | +13105x |
- main_footer = main_footer,+ path = I(list(pth)), |
| 2087 | -320x | +161 | +13105x |
- prov_footer = prov_footer,+ pos_in_siblings = sibpos, |
| 2088 | -320x | +162 | +13105x |
- header_section_div = header_section_div,+ n_siblings = nsibs, |
| 2089 | -320x | +163 | +13105x |
- top_level_section_div = top_level_section_div,+ leaf_indices = I(list(leaf_indices)), |
| 2090 | -320x | -
- table_inset = as.integer(inset)- |
- ||
| 2091 | -+ | 164 | +13105x |
- )+ total_span = span, |
| 2092 | -+ | |||
| 165 | +13105x |
-
+ col_fnotes = I(list(col_fnotes)), |
||
| 2093 | -+ | |||
| 166 | +13105x |
- ## unconditional now, NA case is handled in cinfo construction+ n_col_fnotes = length(col_fnotes), |
||
| 2094 | -320x | +167 | +13105x |
- disp_ccounts(ret) <- show_colcounts+ col_count = col_count, |
| 2095 | -320x | +168 | +13105x |
- colcount_format(ret) <- colcount_format+ ccount_visible = ccount_visible, |
| 2096 | -+ | |||
| 169 | +13105x |
- ## if (isTRUE(show_colcounts)) {
+ ccount_format = ccount_format %||% global_cc_format, |
||
| 2097 | -+ | |||
| 170 | +13105x |
- ## ret <- add_colcounts(ret, format = colcount_format)+ ccount_na_str = ccount_na_str |
||
| 2098 | +171 |
- ## }- |
- ||
| 2099 | -320x | -
- ret+ ) |
||
| 2100 | +172 |
} |
||
| 2101 | +173 | |||
| 2102 | +174 |
- #' Append a description to the 'top-left' materials for the layout+ pos_to_path <- function(pos) {
|
||
| 2103 | -+ | |||
| 175 | +47471x |
- #'+ spls <- pos_splits(pos) |
||
| 2104 | -+ | |||
| 176 | +47471x |
- #' This function *adds* `newlines` to the current set of "top-left materials".+ vals <- pos_splvals(pos) |
||
| 2105 | +177 |
- #'+ |
||
| 2106 | -+ | |||
| 178 | +47471x |
- #' @details+ path <- character() |
||
| 2107 | -+ | |||
| 179 | +47471x |
- #' Adds `newlines` to the set of strings representing the 'top-left' materials declared in the layout (the content+ for (i in seq_along(spls)) {
|
||
| 2108 | -+ | |||
| 180 | +60059x |
- #' displayed to the left of the column labels when the resulting tables are printed).+ nm <- obj_name(spls[[i]]) |
||
| 2109 | -+ | |||
| 181 | +60059x |
- #'+ val_i <- value_names(vals[[i]]) |
||
| 2110 | -+ | |||
| 182 | +60059x |
- #' Top-left material strings are stored and then displayed *exactly as is*, no structure or indenting is applied to+ path <- c( |
||
| 2111 | -+ | |||
| 183 | +60059x |
- #' them either when they are added or when they are displayed.+ path, |
||
| 2112 | -+ | |||
| 184 | +60059x |
- #'+ obj_name(spls[[i]]), |
||
| 2113 | +185 |
- #' @inheritParams lyt_args+ ## rawvalues(vals[[i]])) |
||
| 2114 | -+ | |||
| 186 | +60059x |
- #' @param newlines (`character`)\cr the new line(s) to be added to the materials.+ if (!is.na(val_i)) val_i |
||
| 2115 | +187 |
- #'+ ) |
||
| 2116 | +188 |
- #' @note+ } |
||
| 2117 | -+ | |||
| 189 | +47471x |
- #' Currently, where in the construction of the layout this is called makes no difference, as it is independent of+ path |
||
| 2118 | +190 |
- #' the actual splitting keywords. This may change in the future.+ } |
||
| 2119 | +191 |
- #'+ |
||
| 2120 | +192 |
- #' This function is experimental, its name and the details of its behavior are subject to change in future versions.+ # make_row_df --------------------------------------------------------------- |
||
| 2121 | +193 |
- #'+ |
||
| 2122 | +194 |
- #' @inherit split_cols_by return+ #' @inherit formatters::make_row_df |
||
| 2123 | +195 |
#' |
||
| 2124 | +196 |
- #' @seealso [top_left()]+ # #' @note The technically present root tree node is excluded from the summary returned by both `make_row_df` and |
||
| 2125 | +197 |
- #'+ # #' `make_col_df`, as it is simply the row/column structure of `tt` and thus not useful for pathing or pagination. |
||
| 2126 | +198 |
- #' @examplesIf require(dplyr)+ # #' |
||
| 2127 | +199 |
- #' library(dplyr)+ # #' @return a data.frame of row/column-structure information used by the pagination machinery. |
||
| 2128 | +200 |
- #'+ # #' |
||
| 2129 | +201 |
- #' DM2 <- DM %>% mutate(RACE = factor(RACE), SEX = factor(SEX))+ # #' @export |
||
| 2130 | +202 |
- #'+ # #' @name make_row_df |
||
| 2131 | +203 |
- #' lyt <- basic_table() %>%+ # #' @rdname make_row_df |
||
| 2132 | +204 |
- #' split_cols_by("ARM") %>%
+ # #' @aliases make_row_df,VTableTree-method |
||
| 2133 | +205 |
- #' split_cols_by("SEX") %>%
+ #' @rdname formatters_methods |
||
| 2134 | +206 |
- #' split_rows_by("RACE") %>%
+ #' @exportMethod make_row_df |
||
| 2135 | +207 |
- #' append_topleft("Ethnicity") %>%
+ setMethod( |
||
| 2136 | +208 |
- #' analyze("AGE") %>%
+ "make_row_df", "VTableTree", |
||
| 2137 | +209 |
- #' append_topleft(" Age")
+ function(tt, |
||
| 2138 | +210 |
- #'+ colwidths = NULL, |
||
| 2139 | +211 |
- #' tbl <- build_table(lyt, DM2)+ visible_only = TRUE, |
||
| 2140 | +212 |
- #' tbl+ rownum = 0, |
||
| 2141 | +213 |
- #'+ indent = 0L, |
||
| 2142 | +214 |
- #' @export+ path = character(), |
||
| 2143 | +215 |
- append_topleft <- function(lyt, newlines) {
- |
- ||
| 2144 | -51x | -
- stopifnot(- |
- ||
| 2145 | -51x | -
- is(lyt, "PreDataTableLayouts"),- |
- ||
| 2146 | -51x | -
- is(newlines, "character")+ incontent = FALSE, |
||
| 2147 | +216 |
- )- |
- ||
| 2148 | -51x | -
- lyt@top_left <- c(lyt@top_left, newlines)+ repr_ext = 0L, |
||
| 2149 | -51x | +|||
| 217 | +
- lyt+ repr_inds = integer(), |
|||
| 2150 | +218 |
- }+ sibpos = NA_integer_, |
| 1 | +219 |
- #' Create an `ElementaryTable` from a `data.frame`+ nsibs = NA_integer_, |
||
| 2 | +220 |
- #'+ max_width = NULL, |
||
| 3 | +221 |
- #' @param df (`data.frame`)\cr a data frame.+ fontspec = NULL, |
||
| 4 | +222 |
- #'+ col_gap = 3) {
|
||
| 5 | -+ | |||
| 223 | +9416x |
- #' @details+ indent <- indent + indent_mod(tt) |
||
| 6 | +224 |
- #' If row names are not defined in `df` (or they are simple numbers), then the row names are taken from the column+ ## retained for debugging info |
||
| 7 | -+ | |||
| 225 | +9416x |
- #' `label_name`, if it exists. If `label_name` exists, then it is also removed from the original data. This behavior+ orig_rownum <- rownum # nolint |
||
| 8 | -+ | |||
| 226 | +9416x |
- #' is compatible with [as_result_df()], when `as_is = TRUE` and the row names are not unique.+ if (incontent) {
|
||
| 9 | -+ | |||
| 227 | +1284x |
- #'+ path <- c(path, "@content") |
||
| 10 | -+ | |||
| 228 | +8132x |
- #' @seealso [as_result_df()] for the inverse operation.+ } else if (length(path) > 0 || nzchar(obj_name(tt))) { ## don't add "" for root
|
||
| 11 | +229 |
- #'+ ## else if (length(path) > 0 && nzchar(obj_name(tt))) ## don't add "" for root # nolint |
||
| 12 | -+ | |||
| 230 | +8084x |
- #' @examples+ path <- c(path, obj_name(tt)) |
||
| 13 | +231 |
- #' df_to_tt(mtcars)+ } |
||
| 14 | -+ | |||
| 232 | +9416x |
- #'+ ret <- list() |
||
| 15 | +233 |
- #' @export+ |
||
| 16 | +234 |
- df_to_tt <- function(df) {
+ ## note this is the **table** not the label row |
||
| 17 | -4x | +235 | +9416x |
- colnms <- colnames(df)+ if (!visible_only) {
|
| 18 | -4x | +236 | +21x |
- cinfo <- manual_cols(colnms)+ ret <- c( |
| 19 | -4x | +237 | +21x |
- rnames <- rownames(df)+ ret, |
| 20 | -4x | -
- havern <- !is.null(rnames)- |
- ||
| 21 | -+ | 238 | +21x |
-
+ list(pagdfrow( |
| 22 | -4x | +239 | +21x |
- if ((!havern || all(grepl("[0-9]+", rnames))) && "label_name" %in% colnms) {
+ rnum = NA, |
| 23 | -2x | +240 | +21x |
- rnames <- df$label_name+ nm = obj_name(tt), |
| 24 | -2x | +241 | +21x |
- df <- df[, -match("label_name", colnms)]
+ lab = "", |
| 25 | -2x | +242 | +21x |
- colnms <- colnames(df)+ pth = path, |
| 26 | -2x | +243 | +21x |
- cinfo <- manual_cols(colnms)+ colwidths = colwidths, |
| 27 | -2x | -
- havern <- TRUE- |
- ||
| 28 | -- |
- }- |
- ||
| 29 | -+ | 244 | +21x |
-
+ repext = repr_ext, |
| 30 | -4x | +245 | +21x |
- kids <- lapply(seq_len(nrow(df)), function(i) {
+ repind = list(repr_inds), |
| 31 | -124x | +246 | +21x |
- rni <- if (havern) rnames[i] else ""+ extent = 0, |
| 32 | -124x | -
- do.call(rrow, c(list(row.name = rni), unclass(df[i, ])))- |
- ||
| 33 | -- |
- })- |
- ||
| 34 | -+ | 247 | +21x |
-
+ indent = indent, |
| 35 | -4x | -
- ElementaryTable(kids = kids, cinfo = cinfo)- |
- ||
| 36 | -- |
- }- |
-
| 1 | -- |
- # Split functions --------------------------------------------------------------- |
- ||
| 2 | -- |
- #' Split functions- |
- ||
| 3 | -- |
- #'- |
- ||
| 4 | -- |
- #' @description- |
- ||
| 5 | -- |
- #' This is a collection of useful, default split function that can help you in dividing the data, hence the- |
- ||
| 6 | -+ | 248 | +21x |
- #' table rows or columns, into different parts or groups (splits). You can also create your own split function if you+ rclass = class(tt), sibpos = sibpos, |
| 7 | -+ | |||
| 249 | +21x |
- #' need to create a custom division as specific as you need. Please consider reading [custom_split_funs] if+ nsibs = nsibs, |
||
| 8 | -+ | |||
| 250 | +21x |
- #' this is the case. Beyond this list of functions, you can also use [add_overall_level()] and [add_combo_levels()]+ nrowrefs = 0L, |
||
| 9 | -+ | |||
| 251 | +21x |
- #' for adding or modifying levels and [trim_levels_to_map()] to provide possible level combinations to filter the split+ ncellrefs = 0L, |
||
| 10 | -+ | |||
| 252 | +21x |
- #' with.+ nreflines = 0L, |
||
| 11 | -+ | |||
| 253 | +21x |
- #'+ fontspec = fontspec |
||
| 12 | +254 |
- #' @inheritParams sf_args+ )) |
||
| 13 | +255 |
- #' @inheritParams gen_args+ ) |
||
| 14 | +256 |
- #' @param vals (`ANY`)\cr for internal use only.+ } |
||
| 15 | -+ | |||
| 257 | +9416x |
- #' @param labels (`character`)\cr labels to use for the remaining levels instead of the existing ones.+ if (labelrow_visible(tt)) {
|
||
| 16 | -+ | |||
| 258 | +3341x |
- #'+ lr <- tt_labelrow(tt) |
||
| 17 | -+ | |||
| 259 | +3341x |
- #' @returns A function that can be used to split the data accordingly. The actual function signature+ newdf <- make_row_df(lr, |
||
| 18 | -+ | |||
| 260 | +3341x |
- #' is similar to the one you can define when creating a fully custom one. For more details see [custom_split_funs].+ colwidths = colwidths, |
||
| 19 | -+ | |||
| 261 | +3341x |
- #'+ visible_only = visible_only, |
||
| 20 | -+ | |||
| 262 | +3341x |
- #' @note+ rownum = rownum, |
||
| 21 | -+ | |||
| 263 | +3341x |
- #' The following parameters are also documented here but they are only the default+ indent = indent, |
||
| 22 | -+ | |||
| 264 | +3341x |
- #' signature of a split function: `df` (data to be split), `spl` (split object), and `vals = NULL`,+ path = path, |
||
| 23 | -+ | |||
| 265 | +3341x |
- #' `labels = NULL`, `trim = FALSE` (last three only for internal use). See [custom_split_funs] for more details+ incontent = TRUE, |
||
| 24 | -+ | |||
| 266 | +3341x |
- #' and [make_split_fun()] for a more advanced API.+ repr_ext = repr_ext, |
||
| 25 | -+ | |||
| 267 | +3341x |
- #'+ repr_inds = repr_inds, |
||
| 26 | -+ | |||
| 268 | +3341x |
- #' @seealso [custom_split_funs], [add_overall_level()], [add_combo_levels()], and [trim_levels_to_map()].+ max_width = max_width, |
||
| 27 | -+ | |||
| 269 | +3341x |
- #'+ fontspec = fontspec |
||
| 28 | +270 |
- #' @name split_funcs+ ) |
||
| 29 | -+ | |||
| 271 | +3341x |
- NULL+ rownum <- max(newdf$abs_rownumber, na.rm = TRUE) |
||
| 30 | +272 | |||
| 31 | -+ | |||
| 273 | +3341x |
- # helper fncs+ ret <- c( |
||
| 32 | -+ | |||
| 274 | +3341x |
- .get_unique_levels <- function(vec) {
+ ret, |
||
| 33 | -80x | +275 | +3341x |
- out <- if (is.factor(vec)) {
+ list(newdf)+ |
+
| 276 | ++ |
+ ) |
||
| 34 | -79x | +277 | +3341x |
- levels(vec)+ repr_ext <- repr_ext + 1L |
| 35 | -+ | |||
| 278 | +3341x |
- } else {
+ repr_inds <- c(repr_inds, rownum) |
||
| 36 | -1x | +279 | +3341x |
- unique(vec)+ indent <- indent + 1L |
| 37 | +280 |
- }+ } |
||
| 38 | +281 | |||
| 39 | -80x | +282 | +9416x |
- out+ if (NROW(content_table(tt)) > 0) {
|
| 40 | -+ | |||
| 283 | +1284x |
- }+ ct_tt <- content_table(tt) |
||
| 41 | -+ | |||
| 284 | +1284x |
-
+ cind <- indent + indent_mod(ct_tt) |
||
| 42 | -+ | |||
| 285 | +1284x |
- .print_setdiff_error <- function(provided, existing) {
+ trailing_section_div(ct_tt) <- trailing_section_div(tt_labelrow(tt)) |
||
| 43 | -3x | +286 | +1284x |
- paste(setdiff(provided, existing), collapse = ", ")+ contdf <- make_row_df(ct_tt, |
| 44 | -+ | |||
| 287 | +1284x |
- }+ colwidths = colwidths, |
||
| 45 | -+ | |||
| 288 | +1284x |
-
+ visible_only = visible_only, |
||
| 46 | -+ | |||
| 289 | +1284x |
- #' @describeIn split_funcs keeps only specified levels (`only`) in the split variable. If any of the specified+ rownum = rownum, |
||
| 47 | -+ | |||
| 290 | +1284x |
- #' levels is not present, an error is returned. `reorder = TRUE` (the default) orders the split levels+ indent = cind, |
||
| 48 | -+ | |||
| 291 | +1284x |
- #' according to the order of `only`.+ path = path, |
||
| 49 | -+ | |||
| 292 | +1284x |
- #'+ incontent = TRUE, |
||
| 50 | -+ | |||
| 293 | +1284x |
- #' @param only (`character`)\cr levels to retain (all others will be dropped). If none of the levels is present+ repr_ext = repr_ext, |
||
| 51 | -+ | |||
| 294 | +1284x |
- #' an empty table is returned.+ repr_inds = repr_inds, |
||
| 52 | -+ | |||
| 295 | +1284x |
- #' @param reorder (`flag`)\cr whether the order of `only` should be used as the order of the children of the+ max_width = max_width, |
||
| 53 | -+ | |||
| 296 | +1284x |
- #' split. Defaults to `TRUE`.+ fontspec = fontspec |
||
| 54 | +297 |
- #'+ ) |
||
| 55 | -+ | |||
| 298 | +1284x |
- #' @examples+ crnums <- contdf$abs_rownumber |
||
| 56 | -+ | |||
| 299 | +1284x |
- #' # keep_split_levels keeps specified levels (reorder = TRUE by default)+ crnums <- crnums[!is.na(crnums)] |
||
| 57 | +300 |
- #' lyt <- basic_table() %>%+ |
||
| 58 | -+ | |||
| 301 | +1284x |
- #' split_rows_by("COUNTRY",
+ newrownum <- max(crnums, na.rm = TRUE) |
||
| 59 | -+ | |||
| 302 | +1284x |
- #' split_fun = keep_split_levels(c("USA", "CAN", "BRA"))
+ if (is.finite(newrownum)) {
|
||
| 60 | -+ | |||
| 303 | +1284x |
- #' ) %>%+ rownum <- newrownum |
||
| 61 | -+ | |||
| 304 | +1284x |
- #' analyze("AGE")
+ repr_ext <- repr_ext + length(crnums) |
||
| 62 | -+ | |||
| 305 | +1284x |
- #'+ repr_inds <- c(repr_inds, crnums) |
||
| 63 | +306 |
- #' tbl <- build_table(lyt, DM)+ } |
||
| 64 | -+ | |||
| 307 | +1284x |
- #' tbl+ ret <- c(ret, list(contdf)) |
||
| 65 | -+ | |||
| 308 | +1284x |
- #'+ indent <- cind + 1 |
||
| 66 | +309 |
- #' @export+ } |
||
| 67 | +310 |
- keep_split_levels <- function(only, reorder = TRUE) {
+
|
||
| 68 | -44x | +311 | +9416x |
- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ allkids <- tree_children(tt) |
| 69 | -72x | +312 | +9416x |
- var <- spl_payload(spl)+ newnsibs <- length(allkids) |
| 70 | -72x | +313 | +9416x |
- varvec <- df[[var]]+ for (i in seq_along(allkids)) {
|
| 71 | -+ | |||
| 314 | +17938x |
-
+ kid <- allkids[[i]] |
||
| 72 | -+ | |||
| 315 | +17938x |
- # Unique values from the split variable+ kiddfs <- make_row_df(kid, |
||
| 73 | -72x | +316 | +17938x |
- unique_vals <- .get_unique_levels(varvec)+ colwidths = colwidths, |
| 74 | -+ | |||
| 317 | +17938x |
-
+ visible_only = visible_only, |
||
| 75 | -+ | |||
| 318 | +17938x |
- # Error in case not all levels are present+ rownum = force(rownum), |
||
| 76 | -72x | +319 | +17938x |
- if (!all(only %in% unique_vals)) {
+ indent = indent, ## + 1, |
| 77 | -2x | +320 | +17938x |
- stop(+ path = path, |
| 78 | -2x | +321 | +17938x |
- "Attempted to keep factor level(s) in split that are not present in data: \n",+ incontent = incontent, |
| 79 | -2x | +322 | +17938x |
- .print_setdiff_error(only, unique_vals)+ repr_ext = repr_ext, |
| 80 | -+ | |||
| 323 | +17938x |
- )+ repr_inds = repr_inds, |
||
| 81 | -+ | |||
| 324 | +17938x |
- }+ nsibs = newnsibs, |
||
| 82 | -+ | |||
| 325 | +17938x |
-
+ sibpos = i, |
||
| 83 | -70x | +326 | +17938x |
- df2 <- df[varvec %in% only, ]+ max_width = max_width, |
| 84 | -70x | +327 | +17938x |
- if (reorder) {
+ fontspec = fontspec |
| 85 | -69x | +|||
| 328 | +
- df2[[var]] <- factor(df2[[var]], levels = only)+ ) |
|||
| 86 | +329 |
- } else {
+
|
||
| 87 | +330 |
- # Find original order of only+ # print(kiddfs$abs_rownumber) |
||
| 88 | -1x | +331 | +17938x |
- only <- unique_vals[sort(match(only, unique_vals))]+ rownum <- max(rownum + 1L, kiddfs$abs_rownumber, na.rm = TRUE)+ |
+
| 332 | +17938x | +
+ ret <- c(ret, list(kiddfs)) |
||
| 89 | +333 |
} |
||
| 90 | +334 | |||
| 91 | -70x | +335 | +9416x |
- spl_child_order(spl) <- only+ ret <- do.call(rbind, ret) |
| 92 | -70x | +|||
| 336 | +
- .apply_split_inner(spl, df2,+ |
|||
| 93 | -70x | +|||
| 337 | +
- vals = only,+ # Case where it has Elementary table or VTableTree section_div it is overridden |
|||
| 94 | -70x | +338 | +9416x |
- labels = labels,+ if (!is.na(trailing_section_div(tt))) {
|
| 95 | -70x | -
- trim = trim- |
- ||
| 96 | -+ | 339 | +110x |
- )+ ret$trailing_sep[nrow(ret)] <- trailing_section_div(tt) |
| 97 | +340 |
- }+ } |
||
| 98 | -+ | |||
| 341 | +9416x |
- }+ ret |
||
| 99 | +342 |
-
+ } |
||
| 100 | +343 |
- #' @describeIn split_funcs Removes specified levels (`excl`) from the split variable. Nothing done if not in data.+ ) |
||
| 101 | +344 |
- #'+ |
||
| 102 | +345 |
- #' @param excl (`character`)\cr levels to be excluded (they will not be reflected in the resulting table structure+ # #' @exportMethod make_row_df |
||
| 103 | +346 |
- #' regardless of presence in the data).+ #' @inherit formatters::make_row_df |
||
| 104 | +347 |
#' |
||
| 105 | +348 |
- #' @examples+ #' @export |
||
| 106 | +349 |
- #' # remove_split_levels removes specified split levels+ #' @rdname formatters_methods |
||
| 107 | +350 |
- #' lyt <- basic_table() %>%+ setMethod( |
||
| 108 | +351 |
- #' split_rows_by("COUNTRY",
+ "make_row_df", "TableRow", |
||
| 109 | +352 |
- #' split_fun = remove_split_levels(c(+ function(tt, colwidths = NULL, visible_only = TRUE, |
||
| 110 | +353 |
- #' "USA", "CAN",+ rownum = 0, |
||
| 111 | +354 |
- #' "CHE", "BRA"+ indent = 0L, |
||
| 112 | +355 |
- #' ))+ path = "root", |
||
| 113 | +356 |
- #' ) %>%+ incontent = FALSE, |
||
| 114 | +357 |
- #' analyze("AGE")
+ repr_ext = 0L, |
||
| 115 | +358 |
- #'+ repr_inds = integer(), |
||
| 116 | +359 |
- #' tbl <- build_table(lyt, DM)+ sibpos = NA_integer_, |
||
| 117 | +360 |
- #' tbl+ nsibs = NA_integer_, |
||
| 118 | +361 |
- #'+ max_width = NULL, |
||
| 119 | +362 |
- #' @export+ fontspec, |
||
| 120 | +363 |
- remove_split_levels <- function(excl) {
+ col_gap = 3) {
|
||
| 121 | -28x | +364 | +10612x |
- stopifnot(is.character(excl))+ indent <- indent + indent_mod(tt) |
| 122 | -28x | +365 | +10612x |
- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ rownum <- rownum + 1 |
| 123 | -55x | +366 | +10612x |
- var <- spl_payload(spl)+ rrefs <- row_footnotes(tt) |
| 124 | -55x | +367 | +10612x |
- df2 <- df[!(df[[var]] %in% excl), ]+ crefs <- cell_footnotes(tt) |
| 125 | -55x | +368 | +10612x |
- if (is.factor(df2[[var]])) {
+ reflines <- sum( |
| 126 | -2x | +369 | +10612x |
- levels <- levels(df2[[var]])+ sapply( |
| 127 | -2x | +370 | +10612x |
- levels <- levels[!(levels %in% excl)]+ c(rrefs, crefs), |
| 128 | -2x | -
- df2[[var]] <- factor(df2[[var]], levels = levels)- |
- ||
| 129 | -+ | 371 | +10612x |
- }+ nlines, |
| 130 | -55x | +372 | +10612x |
- .apply_split_inner(spl, df2,+ colwidths = colwidths, |
| 131 | -55x | +373 | +10612x |
- vals = vals,+ max_width = max_width, |
| 132 | -55x | +374 | +10612x |
- labels = labels,+ fontspec = fontspec, |
| 133 | -55x | -
- trim = trim- |
- ||
| 134 | -- |
- )- |
- ||
| 135 | -- |
- }- |
- ||
| 136 | -- |
- }- |
- ||
| 137 | -- | - - | -||
| 138 | -- |
- #' @describeIn split_funcs Drops levels that have no representation in the data.- |
- ||
| 139 | -+ | 375 | +10612x |
- #'+ col_gap = col_gap |
| 140 | +376 |
- #' @examples+ ) |
||
| 141 | -+ | |||
| 377 | +10612x |
- #' # drop_split_levels drops levels that are not present in the data+ ) ## col_gap not strictly necessary as these aren't rows, but why not |
||
| 142 | -+ | |||
| 378 | +10612x |
- #' lyt <- basic_table() %>%+ ret <- pagdfrow( |
||
| 143 | -+ | |||
| 379 | +10612x |
- #' split_rows_by("SEX", split_fun = drop_split_levels) %>%
+ row = tt, |
||
| 144 | -+ | |||
| 380 | +10612x |
- #' analyze("AGE")
+ rnum = rownum, |
||
| 145 | -+ | |||
| 381 | +10612x |
- #'+ colwidths = colwidths, |
||
| 146 | -+ | |||
| 382 | +10612x |
- #' tbl <- build_table(lyt, DM)+ sibpos = sibpos, |
||
| 147 | -+ | |||
| 383 | +10612x |
- #' tbl+ nsibs = nsibs, |
||
| 148 | -+ | |||
| 384 | +10612x |
- #'+ pth = c(path, unname(obj_name(tt))), |
||
| 149 | -+ | |||
| 385 | +10612x |
- #' @export+ repext = repr_ext, |
||
| 150 | -+ | |||
| 386 | +10612x |
- drop_split_levels <- function(df,+ repind = repr_inds, |
||
| 151 | -+ | |||
| 387 | +10612x |
- spl,+ indent = indent, |
||
| 152 | -+ | |||
| 388 | +10612x |
- vals = NULL,+ extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap), |
||
| 153 | +389 |
- labels = NULL,+ ## these two are unlist calls cause they come in lists even with no footnotes |
||
| 154 | -+ | |||
| 390 | +10612x |
- trim = FALSE) {
+ nrowrefs = length(rrefs), |
||
| 155 | -168x | +391 | +10612x |
- var <- spl_payload(spl)+ ncellrefs = length(unlist(crefs)), |
| 156 | -168x | +392 | +10612x |
- df2 <- df+ nreflines = reflines, |
| 157 | -168x | +393 | +10612x |
- df2[[var]] <- factor(df[[var]])+ trailing_sep = trailing_section_div(tt), |
| 158 | -168x | +394 | +10612x |
- lblvar <- spl_label_var(spl)+ fontspec = fontspec |
| 159 | -168x | +|||
| 395 | +
- if (!is.null(lblvar)) {
+ ) |
|||
| 160 | -168x | +396 | +10612x |
- df2[[lblvar]] <- factor(df[[lblvar]])+ ret |
| 161 | +397 |
} |
||
| 162 | +398 | - - | -||
| 163 | -168x | -
- .apply_split_inner(spl, df2,- |
- ||
| 164 | -168x | -
- vals = vals,- |
- ||
| 165 | -168x | -
- labels = labels,+ ) |
||
| 166 | -168x | +|||
| 399 | +
- trim = trim+ |
|||
| 167 | +400 |
- )+ # #' @exportMethod make_row_df |
||
| 168 | +401 |
- }+ #' @export |
||
| 169 | +402 |
-
+ #' @rdname formatters_methods |
||
| 170 | +403 |
- #' @describeIn split_funcs Removes specified levels `excl` and drops all levels that are+ setMethod( |
||
| 171 | +404 |
- #' not in the data.+ "make_row_df", "LabelRow", |
||
| 172 | +405 |
- #'+ function(tt, colwidths = NULL, visible_only = TRUE, |
||
| 173 | +406 |
- #' @examples+ rownum = 0, |
||
| 174 | +407 |
- #' # Removing "M" and "U" directly, then "UNDIFFERENTIATED" because not in data+ indent = 0L, |
||
| 175 | +408 |
- #' lyt <- basic_table() %>%+ path = "root", |
||
| 176 | +409 |
- #' split_rows_by("SEX", split_fun = drop_and_remove_levels(c("M", "U"))) %>%
+ incontent = FALSE, |
||
| 177 | +410 |
- #' analyze("AGE")
+ repr_ext = 0L, |
||
| 178 | +411 |
- #'+ repr_inds = integer(), |
||
| 179 | +412 |
- #' tbl <- build_table(lyt, DM)+ sibpos = NA_integer_, |
||
| 180 | +413 |
- #' tbl+ nsibs = NA_integer_, |
||
| 181 | +414 |
- #'+ max_width = NULL, |
||
| 182 | +415 |
- #' @export+ fontspec, |
||
| 183 | +416 |
- drop_and_remove_levels <- function(excl) {
+ col_gap = 3) {
|
||
| 184 | -4x | +417 | +3361x |
- stopifnot(is.character(excl))+ rownum <- rownum + 1 |
| 185 | -4x | +418 | +3361x |
- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ indent <- indent + indent_mod(tt) |
| 186 | -13x | +419 | +3361x |
- var <- spl_payload(spl)+ ret <- pagdfrow(tt, |
| 187 | -13x | +420 | +3361x |
- df2 <- df[!(df[[var]] %in% excl), ]+ extent = nlines(tt, colwidths = colwidths, max_width = max_width, fontspec = fontspec, col_gap = col_gap), |
| 188 | -13x | +421 | +3361x |
- df2[[var]] <- factor(df2[[var]])+ rnum = rownum, |
| 189 | -13x | +422 | +3361x |
- .apply_split_inner(+ colwidths = colwidths, |
| 190 | -13x | +423 | +3361x |
- spl,+ sibpos = sibpos, |
| 191 | -13x | +424 | +3361x |
- df2,+ nsibs = nsibs, |
| 192 | -13x | +425 | +3361x |
- vals = vals,+ pth = path, |
| 193 | -13x | +426 | +3361x |
- labels = labels,+ repext = repr_ext, |
| 194 | -13x | -
- trim = trim- |
- ||
| 195 | -- |
- )- |
- ||
| 196 | -- |
- }- |
- ||
| 197 | -- |
- }- |
- ||
| 198 | -- | - - | -||
| 199 | -- |
- #' @describeIn split_funcs Reorders split levels following `neworder`, which needs to be of- |
- ||
| 200 | -- |
- #' same size as the levels in data.- |
- ||
| 201 | -- |
- #'- |
- ||
| 202 | -- |
- #' @param neworder (`character`)\cr new order of factor levels. All need to be present in the data.- |
- ||
| 203 | -- |
- #' To add empty levels, rely on pre-processing or create your [custom_split_funs].- |
- ||
| 204 | -+ | 427 | +3361x |
- #' @param newlabels (`character`)\cr labels for (new order of) factor levels. If named, the levels are matched.+ repind = repr_inds, |
| 205 | -+ | |||
| 428 | +3361x |
- #' Otherwise, the order of `neworder` is used.+ indent = indent, |
||
| 206 | -+ | |||
| 429 | +3361x |
- #' @param drlevels (`flag`)\cr whether levels that are not in `neworder` should be dropped.+ nrowrefs = length(row_footnotes(tt)), |
||
| 207 | -+ | |||
| 430 | +3361x |
- #' Default is `TRUE`. Note: `drlevels = TRUE` does not drop levels that are not originally in the data.+ ncellrefs = 0L, |
||
| 208 | -+ | |||
| 431 | +3361x |
- #' Rely on pre-processing or use a combination of split functions with [make_split_fun()] to also drop+ nreflines = sum(vapply(row_footnotes(tt), nlines, NA_integer_, |
||
| 209 | -+ | |||
| 432 | +3361x |
- #' unused levels.+ colwidths = colwidths, |
||
| 210 | -+ | |||
| 433 | +3361x |
- #'+ max_width = max_width, |
||
| 211 | -+ | |||
| 434 | +3361x |
- #' @examples+ fontspec = fontspec, |
||
| 212 | -+ | |||
| 435 | +3361x |
- #' # Reordering levels in split variable+ col_gap = col_gap |
||
| 213 | +436 |
- #' lyt <- basic_table() %>%+ )), |
||
| 214 | -+ | |||
| 437 | +3361x |
- #' split_rows_by(+ trailing_sep = trailing_section_div(tt), |
||
| 215 | -+ | |||
| 438 | +3361x |
- #' "SEX",+ fontspec = fontspec |
||
| 216 | +439 |
- #' split_fun = reorder_split_levels(+ ) |
||
| 217 | -+ | |||
| 440 | +3361x |
- #' neworder = c("U", "F"),
+ if (!labelrow_visible(tt)) {
|
||
| 218 | -+ | |||
| 441 | +! |
- #' newlabels = c(U = "Uu", `F` = "Female")+ ret <- ret[0, , drop = FALSE] |
||
| 219 | +442 |
- #' )+ } |
||
| 220 | -+ | |||
| 443 | +3361x |
- #' ) %>%+ ret |
||
| 221 | +444 |
- #' analyze("AGE")
+ } |
||
| 222 | +445 |
- #'+ ) |
||
| 223 | +446 |
- #' tbl <- build_table(lyt, DM)+ |
||
| 224 | +447 |
- #' tbl+ setGeneric("inner_col_df", function(ct,
|
||
| 225 | +448 |
- #'+ colwidths = NULL, |
||
| 226 | +449 |
- #' # Reordering levels in split variable but keeping all the levels+ visible_only = TRUE, |
||
| 227 | +450 |
- #' lyt <- basic_table() %>%+ colnum = 0L, |
||
| 228 | +451 |
- #' split_rows_by(+ sibpos = NA_integer_, |
||
| 229 | +452 |
- #' "SEX",+ nsibs = NA_integer_, |
||
| 230 | +453 |
- #' split_fun = reorder_split_levels(+ ncolref = 0L, |
||
| 231 | +454 |
- #' neworder = c("U", "F"),
+ na_str, |
||
| 232 | +455 |
- #' newlabels = c("Uu", "Female"),
+ global_cc_format) {
|
||
| 233 | -+ | |||
| 456 | +19388x |
- #' drlevels = FALSE+ standardGeneric("inner_col_df")
|
||
| 234 | +457 |
- #' )+ }) |
||
| 235 | +458 |
- #' ) %>%+ |
||
| 236 | +459 |
- #' analyze("AGE")
+ #' Column layout summary |
||
| 237 | +460 |
#' |
||
| 238 | +461 |
- #' tbl <- build_table(lyt, DM)+ #' Used for pagination. Generate a structural summary of the columns of an `rtables` table and return it as a |
||
| 239 | +462 |
- #' tbl+ #' `data.frame`. |
||
| 240 | +463 |
#' |
||
| 241 | +464 |
- #' @export+ #' @inheritParams formatters::make_row_df |
||
| 242 | +465 |
- reorder_split_levels <- function(neworder,+ #' @param ccount_format (`FormatSpec`)\cr The format to be used by default for |
||
| 243 | +466 |
- newlabels = neworder,+ #' column counts if one is not specified for an individual column count. |
||
| 244 | +467 |
- drlevels = TRUE) {
- |
- ||
| 245 | -8x | -
- function(df, spl, trim, ...) {
- |
- ||
| 246 | -8x | -
- df2 <- df- |
- ||
| 247 | -8x | -
- valvec <- df2[[spl_payload(spl)]]+ #' @param na_str (`character(1)`)\cr The string to display when a column count is NA. Users should not need to set this. |
||
| 248 | +468 |
-
+ #' @export |
||
| 249 | -8x | +|||
| 469 | +
- uni_vals <- .get_unique_levels(valvec)+ make_col_df <- function(tt, |
|||
| 250 | +470 |
-
+ colwidths = NULL, |
||
| 251 | +471 |
- # No sense adding things that are not present -> creating unexpected NAs+ visible_only = TRUE, |
||
| 252 | -8x | +|||
| 472 | +
- if (!all(neworder %in% uni_vals)) {
+ na_str = "", |
|||
| 253 | -1x | +|||
| 473 | +
- stop(+ ccount_format = colcount_format(tt) %||% "(N=xx)") {
|
|||
| 254 | -1x | +474 | +3469x |
- "Attempted to reorder factor levels in split that are not present in data:\n",+ ctree <- coltree(tt, ccount_format = colcount_format(tt)) ## this is a null op if its already a coltree object |
| 255 | -1x | +475 | +3469x |
- .print_setdiff_error(neworder, uni_vals)+ rows <- inner_col_df(ctree, |
| 256 | +476 |
- )+ ## colwidths is currently unused anyway... propose_column_widths(matrix_form(tt, indent_rownames=TRUE)), |
||
| 257 | -+ | |||
| 477 | +3469x |
- }+ colwidths = colwidths, |
||
| 258 | -+ | |||
| 478 | +3469x |
-
+ visible_only = visible_only, |
||
| 259 | -+ | |||
| 479 | +3469x |
- # Keeping all levels also from before if not dropped+ colnum = 1L, |
||
| 260 | -7x | +480 | +3469x |
- diff_with_uni_vals <- setdiff(uni_vals, neworder)+ sibpos = 1L, |
| 261 | -7x | +481 | +3469x |
- if (!drlevels && length(diff_with_uni_vals) > 0) {
+ nsibs = 1L, |
| 262 | -3x | +482 | +3469x |
- if (length(newlabels) > length(neworder)) {
+ na_str = na_str, |
| 263 | -1x | +483 | +3469x |
- stop(+ global_cc_format = ccount_format |
| 264 | -1x | +484 | +3469x |
- "When keeping levels not in neworder (drlevels = FALSE), newlabels can ",+ ) ## nsiblings includes current so 1 means "only child" |
| 265 | -1x | +|||
| 485 | +
- "affect only selected neworder, and not other levels.\n",+ |
|||
| 266 | -1x | +486 | +3469x |
- "Add labels for current neworder: ", paste0(neworder, collapse = ", ")+ do.call(rbind, rows) |
| 267 | +487 |
- )+ } |
||
| 268 | +488 |
- }+ |
||
| 269 | -2x | +|||
| 489 | +
- neworder <- c(neworder, diff_with_uni_vals)+ setMethod( |
|||
| 270 | -2x | +|||
| 490 | +
- if (is.null(names(newlabels))) {
+ "inner_col_df", "LayoutColLeaf", |
|||
| 271 | -! | +|||
| 491 | +
- newlabels <- c(newlabels, diff_with_uni_vals)+ function(ct, colwidths, visible_only, |
|||
| 272 | +492 |
- } else {
+ colnum, |
||
| 273 | -2x | +|||
| 493 | +
- newlabels <- c(newlabels, setNames(diff_with_uni_vals, diff_with_uni_vals))+ sibpos, |
|||
| 274 | +494 |
- }+ nsibs, |
||
| 275 | +495 |
- }+ na_str, |
||
| 276 | +496 |
-
+ global_cc_format) {
|
||
| 277 | -6x | +497 | +12461x |
- valvec <- factor(valvec, levels = neworder)+ list(col_dfrow( |
| 278 | -+ | |||
| 498 | +12461x |
-
+ col = ct, |
||
| 279 | -+ | |||
| 499 | +12461x |
- # Labels+ cnum = colnum, |
||
| 280 | -6x | +500 | +12461x |
- if (!is.null(names(newlabels))) {
+ sibpos = sibpos, |
| 281 | -5x | +501 | +12461x |
- if (any(!names(newlabels) %in% neworder)) {
+ nsibs = nsibs, |
| 282 | -2x | +502 | +12461x |
- stop(+ leaf_indices = colnum, |
| 283 | -2x | +503 | +12461x |
- "Got labels' names for levels that are not present:\n",+ col_fnotes = col_footnotes(ct), |
| 284 | -2x | +504 | +12461x |
- setdiff(names(newlabels), neworder)+ ccount_na_str = na_str, |
| 285 | -+ | |||
| 505 | +12461x |
- )+ global_cc_format = global_cc_format |
||
| 286 | +506 |
- }+ )) |
||
| 287 | +507 |
- # To be safe: sorting by neworder+ } |
||
| 288 | -3x | +|||
| 508 | +
- newlabels <- newlabels[sapply(names(newlabels), function(x) which(x == neworder))]+ ) |
|||
| 289 | -1x | +|||
| 509 | +
- } else if (length(neworder) != length(newlabels)) {
+
|
|||
| 290 | -1x | +|||
| 510 | +
- stop(+ setMethod( |
|||
| 291 | -1x | +|||
| 511 | +
- "Got unnamed newlabels with different length than neworder. ",+ "inner_col_df", "LayoutColTree", |
|||
| 292 | -1x | +|||
| 512 | +
- "Please provide names or make sure they are of the same length.\n",+ function(ct, colwidths, visible_only, |
|||
| 293 | -1x | +|||
| 513 | +
- "Current neworder: ", paste0(neworder, collapse = ", ")+ colnum, |
|||
| 294 | +514 |
- )+ sibpos, |
||
| 295 | +515 |
- }+ nsibs, |
||
| 296 | +516 |
-
+ na_str, |
||
| 297 | +517 |
- # Final values+ global_cc_format) {
|
||
| 298 | -3x | +518 | +6927x |
- spl_child_order(spl) <- neworder+ kids <- tree_children(ct) |
| 299 | -3x | +519 | +6927x |
- df2[[spl_payload(spl)]] <- valvec+ ret <- vector("list", length(kids))
|
| 300 | -3x | +520 | +6927x |
- .apply_split_inner(spl, df2,+ for (i in seq_along(kids)) {
|
| 301 | -3x | +521 | +15919x |
- vals = neworder,+ k <- kids[[i]] |
| 302 | -3x | +522 | +15919x |
- labels = newlabels,+ newrows <- do.call( |
| 303 | -3x | +523 | +15919x |
- trim = trim+ rbind, |
| 304 | -+ | |||
| 524 | +15919x |
- )+ inner_col_df(k, |
||
| 305 | -+ | |||
| 525 | +15919x |
- }+ colnum = colnum, |
||
| 306 | -+ | |||
| 526 | +15919x |
- }+ sibpos = i, |
||
| 307 | -+ | |||
| 527 | +15919x |
-
+ nsibs = length(kids), |
||
| 308 | -+ | |||
| 528 | +15919x |
- #' @describeIn split_funcs Takes the split groups and removes levels of `innervar` if not present in+ visible_only = visible_only, |
||
| 309 | -+ | |||
| 529 | +15919x |
- #' those split groups. If you want to specify a filter of possible combinations, please+ na_str = na_str, |
||
| 310 | -+ | |||
| 530 | +15919x |
- #' consider using [trim_levels_to_map()].+ global_cc_format = global_cc_format |
||
| 311 | +531 |
- #'+ ) |
||
| 312 | +532 |
- #' @param innervar (`string`)\cr variable whose factor levels should be trimmed (e.g. empty levels dropped)+ ) |
||
| 313 | -+ | |||
| 533 | +15919x |
- #' *separately within each grouping defined at this point in the structure*.+ colnum <- max(newrows$abs_pos, colnum, na.rm = TRUE) + 1 |
||
| 314 | -+ | |||
| 534 | +15919x |
- #' @param drop_outlevs (`flag`)\cr whether empty levels in the variable being split on (i.e. the "outer"+ ret[[i]] <- newrows |
||
| 315 | +535 |
- #' variable, not `innervar`) should be dropped. Defaults to `TRUE`.+ } |
||
| 316 | +536 |
- #'+ |
||
| 317 | -+ | |||
| 537 | +6927x |
- #' @examples+ if (!visible_only) {
|
||
| 318 | -+ | |||
| 538 | +1300x |
- #' # trim_levels_in_group() trims levels within each group defined by the split variable+ allindices <- unlist(lapply(ret, function(df) df$abs_pos[!is.na(df$abs_pos)])) |
||
| 319 | -+ | |||
| 539 | +1300x |
- #' dat <- data.frame(+ thispth <- pos_to_path(tree_pos(ct)) |
||
| 320 | -+ | |||
| 540 | +1300x |
- #' col1 = factor(c("A", "B", "C"), levels = c("A", "B", "C", "N")),
+ if (any(nzchar(thispth))) {
|
||
| 321 | -+ | |||
| 541 | +644x |
- #' col2 = factor(c("a", "b", "c"), levels = c("a", "b", "c", "x"))
+ thisone <- list(col_dfrow( |
||
| 322 | -+ | |||
| 542 | +644x |
- #' ) # N is removed if drop_outlevs = TRUE, x is removed always+ col = ct, |
||
| 323 | -+ | |||
| 543 | +644x |
- #'+ cnum = NA_integer_, |
||
| 324 | -+ | |||
| 544 | +644x |
- #' tbl <- basic_table() %>%+ leaf_indices = allindices, |
||
| 325 | -+ | |||
| 545 | +644x |
- #' split_rows_by("col1", split_fun = trim_levels_in_group("col2")) %>%
+ sibpos = sibpos, |
||
| 326 | -+ | |||
| 546 | +644x |
- #' analyze("col2") %>%
+ nsibs = nsibs, |
||
| 327 | -+ | |||
| 547 | +644x |
- #' build_table(dat)+ pth = thispth, |
||
| 328 | -+ | |||
| 548 | +644x |
- #' tbl+ col_fnotes = col_footnotes(ct), |
||
| 329 | -+ | |||
| 549 | +644x |
- #'+ ccount_na_str = na_str, |
||
| 330 | -+ | |||
| 550 | +644x |
- #' @export+ global_cc_format = global_cc_format |
||
| 331 | +551 |
- trim_levels_in_group <- function(innervar, drop_outlevs = TRUE) {
- |
- ||
| 332 | -6x | -
- myfun <- function(df, spl, vals = NULL, labels = NULL, trim = FALSE) {
+ )) |
||
| 333 | -6x | -
- if (!drop_outlevs) {
- |
- ||
| 334 | -! | -
- ret <- .apply_split_inner(spl, df,- |
- ||
| 335 | -! | +552 | +644x |
- vals = vals,+ ret <- c(thisone, ret) |
| 336 | -! | +|||
| 553 | +
- labels = labels, trim = trim+ } |
|||
| 337 | +554 |
- )+ } |
||
| 338 | +555 |
- } else {
+
|
||
| 339 | -6x | +556 | +6927x |
- ret <- drop_split_levels(+ ret |
| 340 | -6x | +|||
| 557 | +
- df = df, spl = spl, vals = vals,+ } |
|||
| 341 | -6x | +|||
| 558 | +
- labels = labels, trim = trim+ ) |
|||
| 342 | +559 |
- )+ |
||
| 343 | +560 |
- }+ ## THIS INCLUDES BOTH "table stub" (i.e. column label and top_left) AND |
||
| 344 | +561 |
-
+ ## title/subtitle!!!!! |
||
| 345 | -6x | +|||
| 562 | +
- ret$datasplit <- lapply(ret$datasplit, function(x) {
+ .header_rep_nlines <- function(tt, colwidths, max_width, fontspec, verbose = FALSE) {
|
|||
| 346 | -14x | +563 | +3x |
- coldat <- x[[innervar]]+ cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec) |
| 347 | -14x | -
- if (is(coldat, "character")) {
- |
- ||
| 348 | -! | -
- if (!is.null(vals)) {
- |
- ||
| 349 | -! | +564 | +3x |
- lvs <- vals+ if (any(nzchar(all_titles(tt)))) {
|
| 350 | +565 |
- } else {
+ ## +1 is for blank line between subtitles and divider |
||
| 351 | -! | +|||
| 566 | +2x |
- lvs <- unique(coldat)+ tlines <- sum(nlines(all_titles(tt), |
||
| 352 | -+ | |||
| 567 | +2x |
- }+ colwidths = colwidths, |
||
| 353 | -! | +|||
| 568 | +2x |
- coldat <- factor(coldat, levels = lvs) ## otherwise+ max_width = max_width, |
||
| 354 | -+ | |||
| 569 | +2x |
- } else {
+ fontspec = fontspec |
||
| 355 | -14x | +570 | +2x |
- coldat <- droplevels(coldat)+ )) + divider_height(tt) + 1L |
| 356 | +571 |
- }- |
- ||
| 357 | -14x | -
- x[[innervar]] <- coldat+ } else {
|
||
| 358 | -14x | +572 | +1x |
- x+ tlines <- 0 |
| 359 | +573 |
- })+ } |
||
| 360 | -6x | +574 | +3x |
- ret$labels <- as.character(ret$labels) # TODO+ ret <- cinfo_lines + tlines |
| 361 | -6x | +575 | +3x |
- ret+ if (verbose) {
|
| 362 | -+ | |||
| 576 | +! |
- }+ message( |
||
| 363 | -6x | +|||
| 577 | +! |
- myfun+ "Lines required for header content: ", |
||
| 364 | -+ | |||
| 578 | +! |
- }+ ret, " (col info: ", cinfo_lines, ", titles: ", tlines, ")" |
||
| 365 | +579 |
-
+ ) |
||
| 366 | +580 |
- # add_combo_levels -------------------------------------------------------------+ } |
||
| 367 | -+ | |||
| 581 | +3x |
- # Dedicated docs are attached to default split functions+ ret |
||
| 368 | +582 |
- .add_combo_part_info <- function(part,+ } |
||
| 369 | +583 |
- df,+ |
||
| 370 | +584 |
- valuename,+ ## this is ***only*** lines that are expected to be repeated on multiple pages: |
||
| 371 | +585 |
- levels,+ ## main footer, prov footer, and referential footnotes on **columns** |
||
| 372 | +586 |
- label,+ |
||
| 373 | +587 |
- extras,+ .footer_rep_nlines <- function(tt, colwidths, max_width, have_cfnotes, fontspec, verbose = FALSE) {
|
||
| 374 | -+ | |||
| 588 | +3x |
- first = TRUE) {
+ flines <- nlines(main_footer(tt), |
||
| 375 | -24x | +589 | +3x |
- value <- LevelComboSplitValue(valuename, extras,+ colwidths = colwidths, |
| 376 | -24x | +590 | +3x |
- combolevels = levels,+ max_width = max_width - table_inset(tt), |
| 377 | -24x | +591 | +3x |
- label = label+ fontspec = fontspec |
| 378 | +592 |
- )- |
- ||
| 379 | -24x | -
- newdat <- setNames(list(df), valuename)+ ) + |
||
| 380 | -24x | +593 | +3x |
- newval <- setNames(list(value), valuename)+ nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width, fontspec = fontspec) |
| 381 | -24x | +594 | +3x |
- newextra <- setNames(list(extras), valuename)+ if (flines > 0) {
|
| 382 | -24x | +595 | +2x |
- if (first) {
+ dl_contrib <- if (have_cfnotes) 0 else divider_height(tt) |
| 383 | -6x | +596 | +2x |
- part$datasplit <- c(newdat, part$datasplit)+ flines <- flines + dl_contrib + 1L |
| 384 | -6x | +|||
| 597 | +
- part$values <- c(newval, part$values)+ } |
|||
| 385 | -6x | +|||
| 598 | +
- part$labels <- c(setNames(label, valuename), part$labels)+ |
|||
| 386 | -6x | -
- part$extras <- c(newextra, part$extras)- |
- ||
| 387 | -+ | 599 | +3x |
- } else {
+ if (verbose) {
|
| 388 | -18x | +|||
| 600 | +! |
- part$datasplit <- c(part$datasplit, newdat)+ message( |
||
| 389 | -18x | +|||
| 601 | +! |
- part$values <- c(part$values, newval)+ "Determining lines required for footer content", |
||
| 390 | -18x | +|||
| 602 | +! |
- part$labels <- c(part$labels, setNames(label, valuename))+ if (have_cfnotes) " [column fnotes present]", |
||
| 391 | -18x | +|||
| 603 | +! |
- part$extras <- c(part$extras, newextra)+ ": ", flines, " lines" |
||
| 392 | +604 |
- }+ ) |
||
| 393 | +605 |
- ## not needed even in custom split function case.+ } |
||
| 394 | +606 |
- ## part = .fixupvals(part)+ |
||
| 395 | -24x | +607 | +3x |
- part+ flines |
| 396 | +608 |
} |
||
| 397 | +609 | |||
| 398 | -- |
- #' Add overall or combination levels to split groups- |
- ||
| 399 | +610 |
- #'+ # Pagination --------------------------------------------------------------- |
||
| 400 | +611 |
- #' @description+ |
||
| 401 | +612 |
- #' `add_overall_level` is a split function that adds a global level to the current levels in the split. Similarly,+ #' Pagination of a `TableTree` |
||
| 402 | +613 |
- #' `add_combo_df` uses a user-provided `data.frame` to define the combine the levels to be added. If you need a+ #' |
||
| 403 | +614 |
- #' single overall column, after all splits, please check [add_overall_col()]. Consider also defining+ #' Paginate an `rtables` table in the vertical and/or horizontal direction, as required for the specified page size. |
||
| 404 | +615 |
- #' your custom split function if you need more flexibility (see [custom_split_funs]).+ #' |
||
| 405 | +616 |
- #'+ #' @inheritParams gen_args |
||
| 406 | +617 |
- #' @inheritParams lyt_args+ #' @inheritParams paginate_table |
||
| 407 | +618 |
- #' @inheritParams sf_args+ #' @param lpp (`numeric(1)`)\cr maximum lines per page including (re)printed header and context rows. |
||
| 408 | +619 |
- #' @param valname (`string`)\cr value to be assigned to the implicit all-observations split level. Defaults to+ #' @param min_siblings (`numeric(1)`)\cr minimum sibling rows which must appear on either side of pagination row for a |
||
| 409 | +620 |
- #' `"Overall"`.+ #' mid-subtable split to be valid. Defaults to 2. |
||
| 410 | +621 |
- #' @param first (`flag`)\cr whether the implicit level should appear first (`TRUE`) or last (`FALSE`). Defaults+ #' @param nosplitin (`character`)\cr names of sub-tables where page-breaks are not allowed, regardless of other |
||
| 411 | +622 |
- #' to `TRUE`.+ #' considerations. Defaults to none. |
||
| 412 | +623 |
#' |
||
| 413 | +624 |
- #' @return A splitting function (`splfun`) that adds or changes the levels of a split.+ #' @return |
||
| 414 | +625 |
- #'+ #' * `pag_tt_indices` returns a list of paginated-groups of row-indices of `tt`. |
||
| 415 | +626 |
- #' @seealso [custom_split_funs] and [split_funcs].+ #' * `paginate_table` returns the subtables defined by subsetting by the indices defined by `pag_tt_indices`. |
||
| 416 | +627 |
#' |
||
| 417 | +628 |
- #' @examples+ #' @details |
||
| 418 | +629 |
- #' lyt <- basic_table() %>%+ #' `rtables` pagination is context aware, meaning that label rows and row-group summaries (content rows) are repeated |
||
| 419 | +630 |
- #' split_cols_by("ARM", split_fun = add_overall_level("All Patients",
+ #' after (vertical) pagination, as appropriate. This allows the reader to immediately understand where they are in the |
||
| 420 | +631 |
- #' first = FALSE+ #' table after turning to a new page, but does also mean that a rendered, paginated table will take up more lines of |
||
| 421 | +632 |
- #' )) %>%+ #' text than rendering the table without pagination would. |
||
| 422 | +633 |
- #' analyze("AGE")
+ #' |
||
| 423 | +634 |
- #'+ #' Pagination also takes into account word-wrapping of title, footer, column-label, and formatted cell value content. |
||
| 424 | +635 |
- #' tbl <- build_table(lyt, DM)+ #' |
||
| 425 | +636 |
- #' tbl+ #' Vertical pagination information (pagination `data.frame`) is created using (`make_row_df`). |
||
| 426 | +637 |
#' |
||
| 427 | +638 |
- #' lyt2 <- basic_table() %>%+ #' Horizontal pagination is performed by creating a pagination data frame for the columns, and then applying the same |
||
| 428 | +639 |
- #' split_cols_by("ARM") %>%
+ #' algorithm used for vertical pagination to it. |
||
| 429 | +640 |
- #' split_rows_by("RACE",
+ #' |
||
| 430 | +641 |
- #' split_fun = add_overall_level("All Ethnicities")
+ #' If physical page size and font information are specified, these are used to derive lines-per-page (`lpp`) and |
||
| 431 | +642 |
- #' ) %>%+ #' characters-per-page (`cpp`) values. |
||
| 432 | +643 |
- #' summarize_row_groups(label_fstr = "%s (n)") %>%+ #' |
||
| 433 | +644 |
- #' analyze("AGE")
+ #' The full multi-direction pagination algorithm then is as follows: |
||
| 434 | +645 |
- #' lyt2+ #' |
||
| 435 | +646 |
- #'+ #' 0. Adjust `lpp` and `cpp` to account for rendered elements that are not rows (columns): |
||
| 436 | +647 |
- #' tbl2 <- build_table(lyt2, DM)+ #' - titles/footers/column labels, and horizontal dividers in the vertical pagination case |
||
| 437 | +648 |
- #' tbl2+ #' - row-labels, table_inset, and top-left materials in the horizontal case |
||
| 438 | +649 |
- #'+ #' 1. Perform 'forced pagination' representing page-by row splits, generating 1 or more tables. |
||
| 439 | +650 |
- #' @export+ #' 2. Perform vertical pagination separately on each table generated in (1). |
||
| 440 | +651 |
- add_overall_level <- function(valname = "Overall",+ #' 3. Perform horizontal pagination **on the entire table** and apply the results to each table |
||
| 441 | +652 |
- label = valname,+ #' page generated in (1)-(2). |
||
| 442 | +653 |
- extra_args = list(),+ #' 4. Return a list of subtables representing full bi-directional pagination. |
||
| 443 | +654 |
- first = TRUE,+ #' |
||
| 444 | +655 |
- trim = FALSE) {
- |
- ||
| 445 | -6x | -
- combodf <- data.frame(- |
- ||
| 446 | -6x | -
- valname = valname,- |
- ||
| 447 | -6x | -
- label = label,- |
- ||
| 448 | -6x | -
- levelcombo = I(list(select_all_levels)),- |
- ||
| 449 | -6x | -
- exargs = I(list(extra_args)),- |
- ||
| 450 | -6x | -
- stringsAsFactors = FALSE+ #' Pagination in both directions is done using the *Core Pagination Algorithm* implemented in the `formatters` package: |
||
| 451 | +656 |
- )- |
- ||
| 452 | -6x | -
- add_combo_levels(combodf,+ #' |
||
| 453 | -6x | +|||
| 657 | +
- trim = trim, first = first+ #' @inheritSection formatters::pagination_algo Pagination Algorithm |
|||
| 454 | +658 |
- )+ #' |
||
| 455 | +659 |
- }+ #' @examples |
||
| 456 | +660 |
-
+ #' s_summary <- function(x) {
|
||
| 457 | +661 |
- setClass("AllLevelsSentinel", contains = "character")
+ #' if (is.numeric(x)) {
|
||
| 458 | +662 |
-
+ #' in_rows( |
||
| 459 | +663 |
- # nocov start+ #' "n" = rcell(sum(!is.na(x)), format = "xx"), |
||
| 460 | +664 |
- #' @rdname add_overall_level+ #' "Mean (sd)" = rcell(c(mean(x, na.rm = TRUE), sd(x, na.rm = TRUE)), |
||
| 461 | +665 |
- #' @export+ #' format = "xx.xx (xx.xx)" |
||
| 462 | +666 |
- select_all_levels <- new("AllLevelsSentinel")
+ #' ), |
||
| 463 | +667 |
- # nocov end+ #' "IQR" = rcell(IQR(x, na.rm = TRUE), format = "xx.xx"), |
||
| 464 | +668 |
-
+ #' "min - max" = rcell(range(x, na.rm = TRUE), format = "xx.xx - xx.xx") |
||
| 465 | +669 |
- #' @param combosdf (`data.frame` or `tbl_df`)\cr a data frame with columns `valname`, `label`, `levelcombo`, and+ #' ) |
||
| 466 | +670 |
- #' `exargs`. `levelcombo` and `exargs` should be list columns. Passing the `select_all_levels` object as a value in+ #' } else if (is.factor(x)) {
|
||
| 467 | +671 |
- #' `comblevels` column indicates that an overall/all-observations level should be created.+ #' vs <- as.list(table(x)) |
||
| 468 | +672 |
- #' @param keep_levels (`character` or `NULL`)\cr if non-`NULL`, the levels to retain across both combination and+ #' do.call(in_rows, lapply(vs, rcell, format = "xx")) |
||
| 469 | +673 |
- #' individual levels.+ #' } else {
|
||
| 470 | +674 |
- #'+ #' ( |
||
| 471 | +675 |
- #' @inherit add_overall_level return+ #' stop("type not supported")
|
||
| 472 | +676 |
- #'+ #' ) |
||
| 473 | +677 |
- #' @note+ #' } |
||
| 474 | +678 |
- #' Analysis or summary functions for which the order matters should never be used within the tabulation framework.+ #' } |
||
| 475 | +679 |
#' |
||
| 476 | +680 |
- #' @examplesIf require(tibble)+ #' lyt <- basic_table() %>% |
||
| 477 | +681 |
- #'+ #' split_cols_by(var = "ARM") %>% |
||
| 478 | +682 |
- #' library(tibble)+ #' analyze(c("AGE", "SEX", "BEP01FL", "BMRKR1", "BMRKR2", "COUNTRY"), afun = s_summary)
|
||
| 479 | +683 |
- #' combodf <- tribble(+ #' |
||
| 480 | +684 |
- #' ~valname, ~label, ~levelcombo, ~exargs,+ #' tbl <- build_table(lyt, ex_adsl) |
||
| 481 | +685 |
- #' "A_B", "Arms A+B", c("A: Drug X", "B: Placebo"), list(),
+ #' tbl |
||
| 482 | +686 |
- #' "A_C", "Arms A+C", c("A: Drug X", "C: Combination"), list()
+ #' |
||
| 483 | +687 |
- #' )+ #' nrow(tbl) |
||
| 484 | +688 |
#' |
||
| 485 | +689 |
- #' lyt <- basic_table(show_colcounts = TRUE) %>%+ #' row_paths_summary(tbl) |
||
| 486 | +690 |
- #' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
+ #' |
||
| 487 | +691 |
- #' analyze("AGE")
+ #' tbls <- paginate_table(tbl, lpp = 15) |
||
| 488 | +692 |
- #'+ #' mf <- matrix_form(tbl, indent_rownames = TRUE) |
||
| 489 | +693 |
- #' tbl <- build_table(lyt, DM)+ #' w_tbls <- propose_column_widths(mf) # so that we have the same column widths |
||
| 490 | +694 |
- #' tbl+ #' |
||
| 491 | +695 |
#' |
||
| 492 | +696 |
- #' lyt1 <- basic_table(show_colcounts = TRUE) %>%+ #' tmp <- lapply(tbls, function(tbli) {
|
||
| 493 | +697 |
- #' split_cols_by("ARM",
+ #' cat(toString(tbli, widths = w_tbls)) |
||
| 494 | +698 |
- #' split_fun = add_combo_levels(combodf,+ #' cat("\n\n")
|
||
| 495 | +699 |
- #' keep_levels = c(+ #' cat("~~~~ PAGE BREAK ~~~~")
|
||
| 496 | +700 |
- #' "A_B",+ #' cat("\n\n")
|
||
| 497 | +701 |
- #' "A_C"+ #' }) |
||
| 498 | +702 |
- #' )+ #' |
||
| 499 | +703 |
- #' )+ #' @rdname paginate |
||
| 500 | +704 |
- #' ) %>%+ #' @export |
||
| 501 | +705 |
- #' analyze("AGE")
+ pag_tt_indices <- function(tt, |
||
| 502 | +706 |
- #'+ lpp = 15, |
||
| 503 | +707 |
- #' tbl1 <- build_table(lyt1, DM)+ min_siblings = 2, |
||
| 504 | +708 |
- #' tbl1+ nosplitin = character(), |
||
| 505 | +709 |
- #'+ colwidths = NULL, |
||
| 506 | +710 |
- #' smallerDM <- droplevels(subset(DM, SEX %in% c("M", "F") &
+ max_width = NULL, |
||
| 507 | +711 |
- #' grepl("^(A|B)", ARM)))
+ fontspec = NULL, |
||
| 508 | +712 |
- #' lyt2 <- basic_table(show_colcounts = TRUE) %>%+ col_gap = 3, |
||
| 509 | +713 |
- #' split_cols_by("ARM", split_fun = add_combo_levels(combodf[1, ])) %>%
+ verbose = FALSE) {
|
||
| 510 | -+ | |||
| 714 | +3x |
- #' split_cols_by("SEX",
+ dheight <- divider_height(tt) |
||
| 511 | +715 |
- #' split_fun = add_overall_level("SEX_ALL", "All Genders")
+
|
||
| 512 | +716 |
- #' ) %>%+ # cinfo_lines <- nlines(col_info(tt), colwidths = colwidths, max_width = max_width) |
||
| 513 | -+ | |||
| 717 | +3x |
- #' analyze("AGE")
+ coldf <- make_col_df(tt, colwidths) |
||
| 514 | -+ | |||
| 718 | +3x |
- #'+ have_cfnotes <- length(unlist(coldf$col_fnotes)) > 0 |
||
| 515 | +719 |
- #' lyt3 <- basic_table(show_colcounts = TRUE) %>%+ |
||
| 516 | -+ | |||
| 720 | +3x |
- #' split_cols_by("ARM", split_fun = add_combo_levels(combodf)) %>%
+ hlines <- .header_rep_nlines(tt, |
||
| 517 | -+ | |||
| 721 | +3x |
- #' split_rows_by("SEX",
+ colwidths = colwidths, max_width = max_width, |
||
| 518 | -+ | |||
| 722 | +3x |
- #' split_fun = add_overall_level("SEX_ALL", "All Genders")
+ verbose = verbose, |
||
| 519 | -+ | |||
| 723 | +3x |
- #' ) %>%+ fontspec = fontspec |
||
| 520 | +724 |
- #' summarize_row_groups() %>%+ ) |
||
| 521 | +725 |
- #' analyze("AGE")
+ ## if(any(nzchar(all_titles(tt)))) {
|
||
| 522 | +726 |
- #'+ ## tlines <- sum(nlines(all_titles(tt), colwidths = colwidths, max_width = max_width)) + |
||
| 523 | +727 |
- #' tbl3 <- build_table(lyt3, smallerDM)+ ## length(wrap_txt(all_titles(tt), max_width = max_width)) + |
||
| 524 | +728 |
- #' tbl3+ ## dheight + 1L |
||
| 525 | +729 |
- #'+ ## } else {
|
||
| 526 | +730 |
- #' @rdname add_overall_level+ ## tlines <- 0 |
||
| 527 | +731 |
- #' @export+ ## } |
||
| 528 | +732 |
- add_combo_levels <- function(combosdf,+ ## flines <- nlines(main_footer(tt), colwidths = colwidths, |
||
| 529 | +733 |
- trim = FALSE,+ ## max_width = max_width - table_inset(tt)) + |
||
| 530 | +734 |
- first = FALSE,+ ## nlines(prov_footer(tt), colwidths = colwidths, max_width = max_width) |
||
| 531 | +735 |
- keep_levels = NULL) {
- |
- ||
| 532 | -14x | -
- myfun <- function(df, spl, vals = NULL, labels = NULL, ...) {
- |
- ||
| 533 | -19x | -
- if (is(spl, "MultiVarSplit")) {
- |
- ||
| 534 | -1x | -
- stop("Combining levels of a MultiVarSplit does not make sense.",
- |
- ||
| 535 | -1x | -
- call. = FALSE+ ## if(flines > 0) {
|
||
| 536 | +736 |
- )+ ## dl_contrib <- if(have_cfnotes) 0 else dheight |
||
| 537 | -14x | +|||
| 737 | +
- } # nocov+ ## flines <- flines + dl_contrib + 1L |
|||
| 538 | -18x | +|||
| 738 | +
- ret <- .apply_split_inner(spl, df,+ ## } |
|||
| 539 | -18x | +739 | +3x |
- vals = vals,+ flines <- .footer_rep_nlines(tt, |
| 540 | -18x | -
- labels = labels, trim = trim- |
- ||
| 541 | -+ | 740 | +3x |
- )+ colwidths = colwidths, |
| 542 | -18x | +741 | +3x |
- for (i in seq_len(nrow(combosdf))) {
+ max_width = max_width, |
| 543 | -24x | +742 | +3x |
- lcombo <- combosdf[i, "levelcombo", drop = TRUE][[1]]+ have_cfnotes = have_cfnotes, |
| 544 | -24x | +743 | +3x |
- spld <- spl_payload(spl)+ fontspec = fontspec, |
| 545 | -24x | +744 | +3x |
- if (is(lcombo, "AllLevelsSentinel")) {
+ verbose = verbose |
| 546 | -6x | +|||
| 745 | +
- subdf <- df+ ) |
|||
| 547 | -18x | +|||
| 746 | +
- } else if (is(spl, "VarLevelSplit")) {
+ ## row lines per page |
|||
| 548 | -18x | +747 | +3x |
- subdf <- df[df[[spld]] %in% lcombo, ]+ rlpp <- lpp - hlines - flines |
| 549 | -14x | -
- } else { ## this covers non-var splits, e.g. Cut-based splits
- |
- ||
| 550 | -! | +748 | +3x |
- stopifnot(all(lcombo %in% c(ret$labels, ret$vals)))+ if (verbose) {
|
| 551 | +749 | ! |
- subdf <- do.call(+ message( |
|
| 552 | +750 | ! |
- rbind,+ "Adjusted Lines Per Page: ", |
|
| 553 | +751 | ! |
- ret$datasplit[names(ret$datasplit) %in% lcombo | ret$vals %in% lcombo]+ rlpp, " (original lpp: ", lpp, ")" |
|
| 554 | +752 |
- )+ ) |
||
| 555 | +753 |
- }- |
- ||
| 556 | -24x | -
- ret <- .add_combo_part_info(+ } |
||
| 557 | -24x | +754 | +3x |
- ret, subdf,+ pagdf <- make_row_df(tt, colwidths, max_width = max_width) |
| 558 | -24x | +|||
| 755 | +
- combosdf[i, "valname", drop = TRUE],+ |
|||
| 559 | -24x | +756 | +3x |
- lcombo,+ pag_indices_inner(pagdf, |
| 560 | -24x | +757 | +3x |
- combosdf[i, "label", drop = TRUE],+ rlpp = rlpp, min_siblings = min_siblings, |
| 561 | -24x | +758 | +3x |
- combosdf[i, "exargs", drop = TRUE][[1]],+ nosplitin = nosplitin, |
| 562 | -24x | -
- first- |
- ||
| 563 | -- |
- )- |
- ||
| 564 | -+ | 759 | +3x |
- }+ verbose = verbose, |
| 565 | -18x | +760 | +3x |
- if (!is.null(keep_levels)) {
+ have_col_fnotes = have_cfnotes, |
| 566 | +761 | 3x |
- keep_inds <- value_names(ret$values) %in% keep_levels+ div_height = dheight, |
|
| 567 | +762 | 3x |
- ret <- lapply(ret, function(x) x[keep_inds])- |
- |
| 568 | -- |
- }- |
- ||
| 569 | -- |
-
+ col_gap = col_gap, |
||
| 570 | -18x | +763 | +3x |
- ret+ has_rowlabels = TRUE |
| 571 | +764 |
- }- |
- ||
| 572 | -14x | -
- myfun+ ) |
||
| 573 | +765 |
} |
||
| 574 | +766 | |||
| 575 | -- |
- #' Trim levels to map- |
- ||
| 576 | -- |
- #'- |
- ||
| 577 | -- |
- #' This split function constructor creates a split function which trims levels of a variable to reflect restrictions- |
- ||
| 578 | -- |
- #' on the possible combinations of two or more variables which the data is split by (along the same axis) within a- |
- ||
| 579 | -- |
- #' layout.- |
- ||
| 580 | -- |
- #'- |
- ||
| 581 | -- |
- #' @param map data.frame. A data.frame defining allowed combinations of- |
- ||
| 582 | +767 |
- #' variables. Any combination at the level of this split not present in the+ copy_title_footer <- function(to, from, newptitle) {
|
||
| 583 | -+ | |||
| 768 | +18x |
- #' map will be removed from the data, both for the variable being split and+ main_title(to) <- main_title(from) |
||
| 584 | -+ | |||
| 769 | +18x |
- #' those present in the data but not associated with this split or any parents+ subtitles(to) <- subtitles(from) |
||
| 585 | -+ | |||
| 770 | +18x |
- #' of it.+ page_titles(to) <- c(page_titles(from), newptitle) |
||
| 586 | -+ | |||
| 771 | +18x |
- #'+ main_footer(to) <- main_footer(from) |
||
| 587 | -+ | |||
| 772 | +18x |
- #' @details+ prov_footer(to) <- prov_footer(from) |
||
| 588 | -+ | |||
| 773 | +18x |
- #' When splitting occurs, the map is subset to the values of all previously performed splits. The levels of the+ to |
||
| 589 | +774 |
- #' variable being split are then pruned to only those still present within this subset of the map representing the+ } |
||
| 590 | +775 |
- #' current hierarchical splitting context.+ |
||
| 591 | +776 |
- #'+ pag_btw_kids <- function(tt) {
|
||
| 592 | -+ | |||
| 777 | +8x |
- #' Splitting is then performed via the [keep_split_levels()] split function.+ pref <- ptitle_prefix(tt) |
||
| 593 | -+ | |||
| 778 | +8x |
- #'+ lapply( |
||
| 594 | -+ | |||
| 779 | +8x |
- #' Each resulting element of the partition is then further trimmed by pruning values of any remaining variables+ tree_children(tt), |
||
| 595 | -+ | |||
| 780 | +8x |
- #' specified in the map to those values allowed under the combination of the previous and current split.+ function(tbl) {
|
||
| 596 | -+ | |||
| 781 | +18x |
- #'+ tbl <- copy_title_footer( |
||
| 597 | -+ | |||
| 782 | +18x |
- #' @return A function that can be used as a split function.+ tbl, tt, |
||
| 598 | -+ | |||
| 783 | +18x |
- #'+ paste(pref, obj_label(tbl), sep = ": ") |
||
| 599 | +784 |
- #' @seealso [trim_levels_in_group()].+ ) |
||
| 600 | -+ | |||
| 785 | +18x |
- #'+ labelrow_visible(tbl) <- FALSE |
||
| 601 | -+ | |||
| 786 | +18x |
- #' @examples+ tbl |
||
| 602 | +787 |
- #' map <- data.frame(+ } |
||
| 603 | +788 |
- #' LBCAT = c("CHEMISTRY", "CHEMISTRY", "CHEMISTRY", "IMMUNOLOGY"),
+ ) |
||
| 604 | +789 |
- #' PARAMCD = c("ALT", "CRP", "CRP", "IGA"),
+ } |
||
| 605 | +790 |
- #' ANRIND = c("LOW", "LOW", "HIGH", "HIGH"),
+
|
||
| 606 | +791 |
- #' stringsAsFactors = FALSE+ force_paginate <- function(tt, |
||
| 607 | +792 |
- #' )+ force_pag = vapply(tree_children(tt), has_force_pag, NA), |
||
| 608 | +793 |
- #'+ verbose = FALSE) {
|
||
| 609 | +794 |
- #' lyt <- basic_table() %>%+ ## forced pagination is happening at this |
||
| 610 | -+ | |||
| 795 | +113x |
- #' split_rows_by("LBCAT") %>%
+ if (has_force_pag(tt)) {
|
||
| 611 | -+ | |||
| 796 | +8x |
- #' split_rows_by("PARAMCD", split_fun = trim_levels_to_map(map = map)) %>%
+ ret <- pag_btw_kids(tt) |
||
| 612 | -+ | |||
| 797 | +8x |
- #' analyze("ANRIND")
+ return(unlist(lapply(ret, force_paginate))) |
||
| 613 | +798 |
- #' tbl <- build_table(lyt, ex_adlb)+ } |
||
| 614 | -+ | |||
| 799 | +105x |
- #'+ chunks <- list() |
||
| 615 | -+ | |||
| 800 | +105x |
- #' @export+ kinds <- seq_along(force_pag) |
||
| 616 | -+ | |||
| 801 | +105x |
- trim_levels_to_map <- function(map = NULL) {
+ while (length(kinds) > 0) {
|
||
| 617 | -7x | +802 | +105x |
- if (is.null(map) || any(sapply(map, class) != "character")) {
+ if (force_pag[kinds[1]]) {
|
| 618 | +803 | ! |
- stop(+ outertbl <- copy_title_footer( |
|
| 619 | +804 | ! |
- "No map dataframe was provided or not all of the columns are of ",+ tree_children(tt)[[kinds[1]]], |
|
| 620 | +805 | ! |
- "type character."+ tt, |
|
| 621 | -+ | |||
| 806 | +! |
- )+ NULL |
||
| 622 | +807 |
- }+ ) |
||
| 623 | +808 | |||
| 624 | -7x | -
- myfun <- function(df,- |
- ||
| 625 | -7x | +|||
| 809 | +! |
- spl,+ chunks <- c(chunks, force_paginate(outertbl)) |
||
| 626 | -7x | +|||
| 810 | +! |
- vals = NULL,+ kinds <- kinds[-1] |
||
| 627 | -7x | +|||
| 811 | +
- labels = NULL,+ } else {
|
|||
| 628 | -7x | +812 | +105x |
- trim = FALSE,+ tmptbl <- tt |
| 629 | -7x | +813 | +105x |
- .spl_context) {
+ runend <- min(which(force_pag[kinds]), length(kinds)) |
| 630 | -12x | +814 | +105x |
- allvars <- colnames(map)+ useinds <- 1:runend |
| 631 | -12x | -
- splvar <- spl_payload(spl)- |
- ||
| 632 | -+ | 815 | +105x |
-
+ tree_children(tmptbl) <- tree_children(tt)[useinds] |
| 633 | -12x | +816 | +105x |
- allvmatches <- match(.spl_context$split, allvars)+ chunks <- c(chunks, tmptbl) |
| 634 | -12x | +817 | +105x |
- outvars <- allvars[na.omit(allvmatches)]+ kinds <- kinds[-useinds] |
| 635 | +818 |
- ## invars are variables present in data, but not in+ } |
||
| 636 | +819 |
- ## previous or current splits- |
- ||
| 637 | -12x | -
- invars <- intersect(- |
- ||
| 638 | -12x | -
- setdiff(allvars, c(outvars, splvar)),+ } |
||
| 639 | -12x | +820 | +105x |
- names(df)+ unlist(chunks, recursive = TRUE) |
| 640 | +821 |
- )+ } |
||
| 641 | +822 |
- ## allvarord <- c(na.omit(allvmatches), ## appear in prior splits+ |
||
| 642 | +823 |
- ## which(allvars == splvar), ## this split+ #' @importFrom formatters do_forced_paginate |
||
| 643 | +824 |
- ## allvars[-1*na.omit(allvmatches)]) ## "outvars"+ setMethod( |
||
| 644 | +825 |
-
+ "do_forced_paginate", "VTableTree", |
||
| 645 | -+ | |||
| 826 | +95x |
- ## allvars <- allvars[allvarord]+ function(obj) force_paginate(obj) |
||
| 646 | +827 |
- ## outvars <- allvars[-(which(allvars == splvar):length(allvars))]- |
- ||
| 647 | -12x | -
- if (length(outvars) > 0) {
- |
- ||
| 648 | -10x | -
- indfilters <- vapply(outvars, function(ivar) {
+ ) |
||
| 649 | -12x | +|||
| 828 | +
- obsval <- .spl_context$value[match(ivar, .spl_context$split)]+ |
|||
| 650 | -12x | +829 | +186x |
- sprintf("%s == '%s'", ivar, obsval)
+ non_null_na <- function(x) !is.null(x) && is.na(x) |
| 651 | +830 |
- }, "")+ |
||
| 652 | +831 |
-
+ #' @inheritParams formatters::vert_pag_indices |
||
| 653 | -10x | +|||
| 832 | +
- allfilters <- paste(indfilters, collapse = " & ")+ #' @inheritParams formatters::page_lcpp |
|||
| 654 | -10x | +|||
| 833 | +
- map <- map[eval(parse(text = allfilters), envir = map), ]+ #' @inheritParams formatters::toString |
|||
| 655 | +834 |
- }+ #' @param cpp (`numeric(1)` or `NULL`)\cr width (in characters) of the pages for horizontal pagination. |
||
| 656 | -12x | +|||
| 835 | +
- map_splvarpos <- which(names(map) == splvar)+ #' `NA` (the default) indicates `cpp` should be inferred from the page size; `NULL` indicates no horizontal |
|||
| 657 | -12x | +|||
| 836 | +
- nondup <- !duplicated(map[[splvar]])+ #' pagination should be done regardless of page size. |
|||
| 658 | -12x | +|||
| 837 | +
- ksl_fun <- keep_split_levels(+ #' |
|||
| 659 | -12x | +|||
| 838 | +
- only = map[[splvar]][nondup],+ #' @rdname paginate |
|||
| 660 | -12x | +|||
| 839 | +
- reorder = TRUE+ #' @aliases paginate_table |
|||
| 661 | +840 |
- )+ #' @export |
||
| 662 | -12x | +|||
| 841 | +
- ret <- ksl_fun(df, spl, vals, labels, trim = trim)+ paginate_table <- function(tt, |
|||
| 663 | +842 |
-
+ page_type = "letter", |
||
| 664 | -12x | +|||
| 843 | +
- if (length(ret$datasplit) == 0) {
+ font_family = "Courier", |
|||
| 665 | -1x | +|||
| 844 | +
- msg <- paste(sprintf("%s[%s]", .spl_context$split, .spl_context$value),
+ font_size = 8, |
|||
| 666 | -1x | +|||
| 845 | +
- collapse = "->"+ lineheight = 1, |
|||
| 667 | +846 |
- )+ landscape = FALSE, |
||
| 668 | -1x | +|||
| 847 | +
- stop(+ pg_width = NULL, |
|||
| 669 | -1x | +|||
| 848 | +
- "map does not allow any values present in data for split ",+ pg_height = NULL, |
|||
| 670 | -1x | +|||
| 849 | +
- "variable ", splvar,+ margins = c(top = .5, bottom = .5, left = .75, right = .75), |
|||
| 671 | -1x | +|||
| 850 | +
- " under the following parent splits:\n\t", msg+ lpp = NA_integer_, |
|||
| 672 | +851 |
- )+ cpp = NA_integer_, |
||
| 673 | +852 |
- }+ min_siblings = 2, |
||
| 674 | +853 |
-
+ nosplitin = character(), |
||
| 675 | +854 |
- ## keep non-split (inner) variables levels+ colwidths = NULL, |
||
| 676 | -11x | +|||
| 855 | +
- ret$datasplit <- lapply(ret$values, function(splvar_lev) {
+ tf_wrap = FALSE, |
|||
| 677 | -19x | +|||
| 856 | +
- df3 <- ret$datasplit[[splvar_lev]]+ max_width = NULL, |
|||
| 678 | -19x | +|||
| 857 | +
- curmap <- map[map[[map_splvarpos]] == splvar_lev, ]+ fontspec = font_spec(font_family, font_size, lineheight), |
|||
| 679 | +858 |
- ## loop through inner variables+ col_gap = 3, |
||
| 680 | -19x | +|||
| 859 | +
- for (iv in invars) { ## setdiff(colnames(map), splvar)) {
+ verbose = FALSE) {
|
|||
| 681 | -19x | +860 | +51x |
- iv_lev <- df3[[iv]]+ new_dev <- open_font_dev(fontspec) |
| 682 | -19x | +861 | +51x |
- levkeep <- as.character(unique(curmap[[iv]]))+ if (new_dev) {
|
| 683 | -19x | -
- if (is.factor(iv_lev) && !all(levkeep %in% levels(iv_lev))) {
- |
- ||
| 684 | -! | -
- stop(- |
- ||
| 685 | -! | -
- "Attempted to keep invalid factor level(s) in split ",- |
- ||
| 686 | -! | -
- setdiff(levkeep, levels(iv_lev))- |
- ||
| 687 | -+ | 862 | +38x |
- )+ on.exit(close_font_dev()) |
| 688 | +863 |
- }+ } |
||
| 689 | +864 | |||
| 690 | -19x | -
- df3 <- df3[iv_lev %in% levkeep, , drop = FALSE]- |
- ||
| 691 | -+ | 865 | +51x |
-
+ if ((non_null_na(lpp) || non_null_na(cpp)) && |
| 692 | -19x | +866 | +51x |
- if (is.factor(iv_lev)) {
+ (!is.null(page_type) || (!is.null(pg_width) && !is.null(pg_height)))) { # nolint
|
| 693 | -19x | +867 | +12x |
- df3[[iv]] <- factor(as.character(df3[[iv]]),+ pg_lcpp <- page_lcpp( |
| 694 | -19x | +868 | +12x |
- levels = levkeep+ page_type = page_type, |
| 695 | -+ | |||
| 869 | +12x |
- )+ font_family = font_family, |
||
| 696 | -+ | |||
| 870 | +12x |
- }+ font_size = font_size, |
||
| 697 | -+ | |||
| 871 | +12x |
- }+ lineheight = lineheight, |
||
| 698 | -+ | |||
| 872 | +12x |
-
+ pg_width = pg_width, |
||
| 699 | -19x | +873 | +12x |
- df3+ pg_height = pg_height, |
| 700 | -+ | |||
| 874 | +12x |
- })+ margins = margins, |
||
| 701 | -11x | +875 | +12x |
- names(ret$datasplit) <- ret$values+ landscape = landscape, |
| 702 | -11x | +876 | +12x |
- ret+ fontspec = fontspec |
| 703 | +877 |
- }+ ) |
||
| 704 | +878 | |||
| 705 | -7x | -
- myfun- |
- ||
| 706 | -- |
- }- |
-
| 1 | -- |
- #' Find degenerate (sub)structures within a table- |
- ||
| 2 | -- |
- #'- |
- ||
| 3 | -+ | 879 | +12x |
- #' @description `r lifecycle::badge("experimental")`
+ if (non_null_na(lpp)) {
|
| 4 | -+ | |||
| 880 | +6x |
- #'+ lpp <- pg_lcpp$lpp |
||
| 5 | +881 |
- #' This function returns a list with the row-paths to all structural subtables which contain no data rows (even if+ } |
||
| 6 | -+ | |||
| 882 | +12x |
- #' they have associated content rows).+ if (is.na(cpp)) {
|
||
| 7 | -+ | |||
| 883 | +8x |
- #'+ cpp <- pg_lcpp$cpp |
||
| 8 | +884 |
- #' @param tt (`TableTree`)\cr a `TableTree` object.+ } |
||
| 9 | +885 |
- #'+ } else {
|
||
| 10 | -+ | |||
| 886 | +39x |
- #' @return A list of character vectors representing the row paths, if any, to degenerate substructures within the table.+ if (non_null_na(cpp)) {
|
||
| 11 | -+ | |||
| 887 | +! |
- #'+ cpp <- NULL |
||
| 12 | +888 |
- #' @examples+ } |
||
| 13 | -+ | |||
| 889 | +39x |
- #' find_degen_struct(rtable("hi"))
+ if (non_null_na(lpp)) {
|
||
| 14 | -+ | |||
| 890 | +! |
- #'+ lpp <- 70 |
||
| 15 | +891 |
- #' @family table structure validation functions+ } |
||
| 16 | +892 |
- #' @export+ } |
||
| 17 | +893 |
- find_degen_struct <- function(tt) {
+
|
||
| 18 | -7x | +894 | +51x |
- degen <- list()+ if (is.null(colwidths)) {
|
| 19 | -+ | |||
| 895 | +34x |
-
+ colwidths <- propose_column_widths( |
||
| 20 | -7x | +896 | +34x |
- recurse_check <- function(tti, path) {
+ matrix_form( |
| 21 | -103x | +897 | +34x |
- if (is(tti, "VTableTree")) {
+ tt, |
| 22 | -103x | +898 | +34x |
- kids <- tree_children(tti)+ indent_rownames = TRUE, |
| 23 | -103x | +899 | +34x |
- if (length(kids) == 0) {
+ fontspec = fontspec, |
| 24 | -69x | +900 | +34x |
- degen <<- c(degen, list(path))+ col_gap = col_gap |
| 25 | +901 |
- } else {
+ ), |
||
| 26 | +902 | 34x |
- for (i in seq_along(kids)) {
- |
- |
| 27 | -96x | -
- recurse_check(kids[[i]], path = c(path, names(kids)[i]))+ fontspec = fontspec |
||
| 28 | +903 |
- }+ ) |
||
| 29 | +904 |
- }+ } |
||
| 30 | +905 |
- }+ |
||
| 31 | -+ | |||
| 906 | +51x |
- }+ if (!tf_wrap) {
|
||
| 32 | -7x | +907 | +41x |
- recurse_check(tt, obj_name(tt) %||% "root")+ if (!is.null(max_width)) {
|
| 33 | -7x | +|||
| 908 | +! |
- degen+ warning("tf_wrap is FALSE - ignoring non-null max_width value.")
|
||
| 34 | +909 |
- }+ } |
||
| 35 | -+ | |||
| 910 | +41x |
-
+ max_width <- NULL |
||
| 36 | -+ | |||
| 911 | +10x |
- #' Validate and assert valid table structure+ } else if (is.null(max_width)) {
|
||
| 37 | -+ | |||
| 912 | +5x |
- #'+ max_width <- cpp |
||
| 38 | -+ | |||
| 913 | +5x |
- #' @description `r lifecycle::badge("experimental")`
+ } else if (identical(max_width, "auto")) {
|
||
| 39 | +914 |
- #'+ ## XXX this 3 is column sep width!!!!!!! |
||
| 40 | -+ | |||
| 915 | +! |
- #' A `TableTree` (`rtables`-built table) is considered degenerate if:+ max_width <- sum(colwidths) + col_gap * (length(colwidths) - 1) |
||
| 41 | +916 |
- #' \enumerate{
+ } |
||
| 42 | -+ | |||
| 917 | +51x |
- #' \item{It contains no subtables or data rows (content rows do not count).}
+ if (!is.null(cpp) && !is.null(max_width) && max_width > cpp) {
|
||
| 43 | -+ | |||
| 918 | +! |
- #' \item{It contains a subtable which is degenerate by the criterion above.}
+ warning("max_width specified is wider than characters per page width (cpp).")
|
||
| 44 | +919 |
- #' }+ } |
||
| 45 | +920 |
- #'+ |
||
| 46 | +921 |
- #' `validate_table_struct` assesses whether `tt` has a valid (non-degenerate) structure.+ ## taken care of in vert_pag_indices now |
||
| 47 | +922 |
- #'+ ## if(!is.null(cpp)) |
||
| 48 | +923 |
- #' `assert_valid_table` asserts a table must have a valid structure, and throws an informative error (the default) or+ ## cpp <- cpp - table_inset(tt) |
||
| 49 | +924 |
- #' warning (if `warn_only` is `TRUE`) if the table is degenerate (has invalid structure or contains one or more+ |
||
| 50 | -+ | |||
| 925 | +51x |
- #' invalid substructures.+ force_pag <- vapply(tree_children(tt), has_force_pag, TRUE) |
||
| 51 | -+ | |||
| 926 | +51x |
- #'+ if (has_force_pag(tt) || any(force_pag)) {
|
||
| 52 | -+ | |||
| 927 | +5x |
- #' @param tt (`TableTree`)\cr a `TableTree` object.+ spltabs <- do_forced_paginate(tt) |
||
| 53 | -+ | |||
| 928 | +5x |
- #'+ spltabs <- unlist(spltabs, recursive = TRUE) |
||
| 54 | -+ | |||
| 929 | +5x |
- #' @return+ ret <- lapply(spltabs, paginate_table, |
||
| 55 | -+ | |||
| 930 | +5x | +
+ lpp = lpp,+ |
+ ||
| 931 | +5x |
- #' * `validate_table_struct` returns a logical value indicating valid structure.+ cpp = cpp, |
||
| 56 | -+ | |||
| 932 | +5x |
- #' * `assert_valid_table` is called for its side-effect of throwing an error or warning for degenerate tables.+ min_siblings = min_siblings, |
||
| 57 | -+ | |||
| 933 | +5x |
- #'+ nosplitin = nosplitin, |
||
| 58 | -+ | |||
| 934 | +5x |
- #' @note This function is experimental and the exact text of the warning/error is subject to change in future releases.+ colwidths = colwidths, |
||
| 59 | -+ | |||
| 935 | +5x |
- #'+ tf_wrap = tf_wrap, |
||
| 60 | -+ | |||
| 936 | +5x |
- #' @examples+ max_width = max_width, |
||
| 61 | -+ | |||
| 937 | +5x |
- #' validate_table_struct(rtable("hahaha"))
+ fontspec = fontspec, |
||
| 62 | -+ | |||
| 938 | +5x |
- #' \dontrun{
+ verbose = verbose, |
||
| 63 | -+ | |||
| 939 | +5x |
- #' assert_valid_table(rtable("oops"))
+ col_gap = col_gap |
||
| 64 | +940 |
- #' }+ ) |
||
| 65 | -+ | |||
| 941 | +5x |
- #'+ return(unlist(ret, recursive = TRUE)) |
||
| 66 | +942 |
- #' @family table structure validation functions+ } |
||
| 67 | +943 |
- #' @export+ |
||
| 68 | -+ | |||
| 944 | +46x |
- validate_table_struct <- function(tt) {
+ inds <- paginate_indices(tt, |
||
| 69 | -1x | +945 | +46x |
- degen_pths <- find_degen_struct(tt)+ page_type = page_type, |
| 70 | -1x | +946 | +46x |
- length(degen_pths) == 0+ fontspec = fontspec, |
| 71 | +947 |
- }+ ## font_family = font_family, |
||
| 72 | +948 |
-
+ ## font_size = font_size, |
||
| 73 | +949 |
- ## XXX this doesn't handle content paths correctly+ ## lineheight = lineheight, |
||
| 74 | -+ | |||
| 950 | +46x |
- .path_to_disp <- function(pth) {
+ landscape = landscape, |
||
| 75 | -4x | +951 | +46x |
- if (length(pth) == 1) {
+ pg_width = pg_width, |
| 76 | -1x | +952 | +46x |
- return(pth)+ pg_height = pg_height, |
| 77 | -+ | |||
| 953 | +46x |
- }+ margins = margins, |
||
| 78 | -3x | +954 | +46x |
- has_cont <- any(pth == "@content")+ lpp = lpp, |
| 79 | -3x | +955 | +46x |
- if (has_cont) {
+ cpp = cpp, |
| 80 | -! | +|||
| 956 | +46x |
- contpos <- which(pth == "@content")+ min_siblings = min_siblings, |
||
| 81 | -! | +|||
| 957 | +46x |
- cont_disp <- paste(tail(pth, length(pth) - contpos + 1),+ nosplitin = nosplitin, |
||
| 82 | -! | +|||
| 958 | +46x |
- collapse = "->"+ colwidths = colwidths, |
||
| 83 | -+ | |||
| 959 | +46x |
- )+ tf_wrap = tf_wrap, |
||
| 84 | -! | +|||
| 960 | +46x |
- pth <- head(pth, contpos)+ max_width = max_width, |
||
| 85 | -+ | |||
| 961 | +46x |
- } else {
+ col_gap = col_gap, |
||
| 86 | -3x | +962 | +46x |
- cont_disp <- character()+ verbose = verbose |
| 87 | -+ | |||
| 963 | +46x |
- }+ ) ## paginate_table apparently doesn't accept indent_size |
||
| 88 | +964 | |||
| 89 | -3x | +965 | +41x |
- topaste <- character(0)+ res <- lapply( |
| 90 | -3x | +966 | +41x |
- fullpth <- pth+ inds$pag_row_indices, |
| 91 | -3x | +967 | +41x |
- while (length(pth) > 0) {
+ function(ii) {
|
| 92 | -6x | -
- if (length(pth) <= 1) {
- |
- ||
| 93 | -! | +968 | +115x |
- topaste <- c(topaste, pth)+ subt <- tt[ii, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE] |
| 94 | -! | +|||
| 969 | +115x |
- pth <- character()+ lapply( |
||
| 95 | -+ | |||
| 970 | +115x |
- } else {
+ inds$pag_col_indices, |
||
| 96 | -6x | +971 | +115x |
- topaste <- c(topaste, sprintf("%s[%s]", pth[1], pth[2]))
+ function(jj) {
|
| 97 | -6x | +972 | +214x |
- pth <- tail(pth, -2)+ subt[, jj, drop = FALSE, keep_titles = TRUE, keep_topleft = TRUE, reindex_refs = FALSE] |
| 98 | +973 |
- }+ } |
||
| 99 | +974 |
- }- |
- ||
| 100 | -3x | -
- topaste <- c(topaste, cont_disp)- |
- ||
| 101 | -3x | -
- paste(topaste, collapse = "->")+ ) |
||
| 102 | +975 |
- }+ } |
||
| 103 | +976 |
-
+ ) |
||
| 104 | -+ | |||
| 977 | +41x |
- no_analyze_guess <- paste0(+ res <- unlist(res, recursive = FALSE) |
||
| 105 | -+ | |||
| 978 | +41x |
- "Was this table created using ",+ res |
||
| 106 | +979 |
- "summarize_row_groups but no calls ",+ } |
| 107 | +1 |
- "to analyze?\n"+ treestruct <- function(obj, ind = 0L) {
|
||
| 108 | -+ | |||
| 2 | +19x |
- )+ nc <- ncol(obj) |
||
| 109 | -+ | |||
| 3 | +19x |
-
+ cat(rep(" ", times = ind),
|
||
| 110 | -+ | |||
| 4 | +19x |
- use_sanitize_msg <- paste(" Use sanitize_table_struct() to fix these issues")
+ sprintf("[%s] %s", class(obj), obj_name(obj)),
|
||
| 111 | -+ | |||
| 5 | +19x |
-
+ sep = "" |
||
| 112 | +6 |
- make_degen_message <- function(degen_pths, tt) {
+ ) |
||
| 113 | -2x | +7 | +19x |
- msg <- sprintf(+ if (!is(obj, "ElementaryTable") && nrow(obj@content) > 0) {
|
| 114 | -2x | +8 | +6x |
- paste0(+ crows <- nrow(content_table(obj)) |
| 115 | -2x | +9 | +6x |
- "Invalid table - found %d (sub)structures which contain no data rows.",+ ccols <- if (crows == 0) 0 else nc |
| 116 | -2x | +10 | +6x |
- "\n\tThe first occured at path: %s"+ cat(sprintf( |
| 117 | -+ | |||
| 11 | +6x |
- ),+ " [cont: %d x %d]", |
||
| 118 | -2x | +12 | +6x |
- length(degen_pths), .path_to_disp(degen_pths[[1]])+ crows, ccols |
| 119 | +13 |
- )+ )) |
||
| 120 | -2x | +|||
| 14 | +
- if (length(degen_pths) == 1 && length(degen_pths[[1]]) == 1) {
+ } |
|||
| 121 | -1x | +15 | +19x |
- msg <- paste(msg, " Likely Cause: Empty data or first row split on variable with only NA values",+ if (is(obj, "VTableTree") && length(tree_children(obj))) {
|
| 122 | -1x | +16 | +19x |
- sep = "\n"+ kids <- tree_children(obj) |
| 123 | -+ | |||
| 17 | +19x |
- )+ if (are(kids, "TableRow")) {
|
||
| 124 | -1x | +18 | +9x |
- } else if (all(make_row_df(tt)$node_class %in% c("LabelRow", "ContentRow"))) {
+ cat(sprintf( |
| 125 | -1x | +19 | +9x |
- msg <- paste(msg, " Cause: Layout did not contain any analyze() calls (only summarize_row_groups())",+ " (%d x %d)\n", |
| 126 | -1x | +20 | +9x |
- sep = "\n"+ length(kids), nc |
| 127 | +21 |
- )+ )) |
||
| 128 | +22 |
- }+ } else {
|
||
| 129 | -2x | +23 | +10x |
- msg <- paste(msg, use_sanitize_msg, sep = "\n")+ cat("\n")
|
| 130 | -2x | +24 | +10x |
- msg+ lapply(kids, treestruct, ind = ind + 1) |
| 131 | +25 |
- }+ } |
||
| 132 | +26 |
-
+ } |
||
| 133 | -+ | |||
| 27 | +19x |
- #' @param warn_only (`flag`)\cr whether a warning should be thrown instead of an error. Defaults to `FALSE`.+ invisible(NULL) |
||
| 134 | +28 |
- #'+ } |
||
| 135 | +29 |
- #' @rdname validate_table_struct+ |
||
| 136 | +30 |
- #' @export+ setGeneric( |
||
| 137 | +31 |
- assert_valid_table <- function(tt, warn_only = FALSE) {
- |
- ||
| 138 | -2x | -
- degen_pths <- find_degen_struct(tt)+ "ploads_to_str", |
||
| 139 | -2x | -
- if (length(degen_pths) == 0) {
- |
- ||
| 140 | -! | +32 | +103x |
- return(TRUE)+ function(x, collapse = ":") standardGeneric("ploads_to_str")
|
| 141 | +33 |
- }+ ) |
||
| 142 | +34 | |||
| 143 | +35 |
- ## we failed, now we build an informative error/warning message+ setMethod( |
||
| 144 | -2x | +|||
| 36 | +
- msg <- make_degen_message(degen_pths, tt)+ "ploads_to_str", "Split", |
|||
| 145 | +37 |
-
+ function(x, collapse = ":") {
|
||
| 146 | -2x | +38 | +52x |
- if (!warn_only) {
+ paste(sapply(spl_payload(x), ploads_to_str), |
| 147 | -2x | +39 | +52x |
- stop(msg)+ collapse = collapse |
| 148 | +40 |
- }- |
- ||
| 149 | -! | -
- warning(msg)+ ) |
||
| 150 | -! | +|||
| 41 | +
- return(FALSE)+ } |
|||
| 151 | +42 |
- }+ ) |
||
| 152 | +43 | |||
| 153 | +44 |
- #' Sanitize degenerate table structures+ setMethod( |
||
| 154 | +45 |
- #'+ "ploads_to_str", "CompoundSplit", |
||
| 155 | +46 |
- #' @description `r lifecycle::badge("experimental")`
+ function(x, collapse = ":") {
|
||
| 156 | -+ | |||
| 47 | +6x |
- #'+ paste(sapply(spl_payload(x), ploads_to_str), |
||
| 157 | -+ | |||
| 48 | +6x |
- #' Experimental function to correct structure of degenerate tables by adding messaging rows to empty sub-structures.+ collapse = collapse |
||
| 158 | +49 |
- #'+ ) |
||
| 159 | +50 |
- #' @param tt (`TableTree`)\cr a `TableTree` object.+ } |
||
| 160 | +51 |
- #' @param empty_msg (`string`)\cr the string which should be spanned across the inserted empty rows.+ ) |
||
| 161 | +52 |
- #'+ |
||
| 162 | +53 |
- #' @details+ setMethod( |
||
| 163 | +54 |
- #' This function locates degenerate portions of the table (including the table overall in the case of a table with no+ "ploads_to_str", "list", |
||
| 164 | +55 |
- #' data rows) and inserts a row which spans all columns with the message `empty_msg` at each one, generating a table+ function(x, collapse = ":") {
|
||
| 165 | -+ | |||
| 56 | +! |
- #' guaranteed to be non-degenerate.+ stop("Please contact the maintainer")
|
||
| 166 | +57 |
- #'+ } |
||
| 167 | +58 |
- #' @return If `tt` is already valid, it is returned unmodified. If `tt` is degenerate, a modified, non-degenerate+ ) |
||
| 168 | +59 |
- #' version of the table is returned.+ |
||
| 169 | +60 |
- #'+ setMethod( |
||
| 170 | +61 |
- #' @examples+ "ploads_to_str", "SplitVector", |
||
| 171 | +62 |
- #' sanitize_table_struct(rtable("cool beans"))
+ function(x, collapse = ":") {
|
||
| 172 | -+ | |||
| 63 | +8x |
- #'+ sapply(x, ploads_to_str) |
||
| 173 | +64 |
- #' lyt <- basic_table() %>%+ } |
||
| 174 | +65 |
- #' split_cols_by("ARM") %>%
+ ) |
||
| 175 | +66 |
- #' split_rows_by("SEX") %>%
+
|
||
| 176 | +67 |
- #' summarize_row_groups()+ setMethod( |
||
| 177 | +68 |
- #'+ "ploads_to_str", "ANY", |
||
| 178 | +69 |
- #' ## Degenerate because it doesn't have any analyze calls -> no data rows+ function(x, collapse = ":") {
|
||
| 179 | -+ | |||
| 70 | +37x |
- #' badtab <- build_table(lyt, DM)+ paste(x) |
||
| 180 | +71 |
- #' sanitize_table_struct(badtab)+ } |
||
| 181 | +72 |
- #'+ ) |
||
| 182 | +73 |
- #' @family table structure validation functions+ + |
+ ||
| 74 | +47x | +
+ setGeneric("payloadmsg", function(spl) standardGeneric("payloadmsg"))
|
||
| 183 | +75 |
- #' @export+ |
||
| 184 | +76 |
- sanitize_table_struct <- function(tt, empty_msg = "-- This Section Contains No Data --") {
+ setMethod( |
||
| 185 | -4x | +|||
| 77 | +
- rdf <- make_row_df(tt)+ "payloadmsg", "VarLevelSplit", |
|||
| 186 | +78 |
-
+ function(spl) {
|
||
| 187 | -4x | +79 | +45x |
- emptyrow <- DataRow(+ spl_payload(spl) |
| 188 | -4x | +|||
| 80 | +
- vals = list(empty_msg),+ } |
|||
| 189 | -4x | +|||
| 81 | +
- name = "empty_section",+ ) |
|||
| 190 | -4x | +|||
| 82 | +
- label = "",+ |
|||
| 191 | -4x | +|||
| 83 | +
- cspan = ncol(tt),+ setMethod( |
|||
| 192 | -4x | +|||
| 84 | +
- cinfo = col_info(tt),+ "payloadmsg", "MultiVarSplit", |
|||
| 193 | -4x | +85 | +2x |
- format = "xx",+ function(spl) "var" |
| 194 | -4x | +|||
| 86 | +
- table_inset = table_inset(tt)+ ) |
|||
| 195 | +87 |
- )+ |
||
| 196 | -4x | +|||
| 88 | +
- degen_pths <- find_degen_struct(tt)+ setMethod( |
|||
| 197 | +89 |
-
+ "payloadmsg", "VarLevWBaselineSplit", |
||
| 198 | -4x | +|||
| 90 | +
- if (identical(degen_pths, list("root"))) {
+ function(spl) {
|
|||
| 199 | -2x | +|||
| 91 | +! |
- tree_children(tt) <- list(empty_row = emptyrow)+ paste0( |
||
| 200 | -2x | +|||
| 92 | +! |
- return(tt)+ spl_payload(spl), "[bsl ", |
||
| 201 | -+ | |||
| 93 | +! |
- }+ spl@ref_group_value, # XXX XXX |
||
| 202 | +94 | - - | -||
| 203 | -2x | -
- for (pth in degen_pths) {
+ "]" |
||
| 204 | +95 |
- ## FIXME this shouldn't be necessary. why is it?+ ) |
||
| 205 | -33x | +|||
| 96 | +
- tti <- tt_at_path(tt, path = pth)+ } |
|||
| 206 | -33x | +|||
| 97 | +
- tree_children(tti) <- list(empty_section = emptyrow)+ ) |
|||
| 207 | -33x | +|||
| 98 | +
- tt_at_path(tt, path = pth) <- tti+ |
|||
| 208 | +99 |
- }+ setMethod( |
||
| 209 | -2x | +|||
| 100 | +
- tt+ "payloadmsg", "ManualSplit", |
|||
| 210 | -+ | |||
| 101 | +! |
- }+ function(spl) "mnl" |
| 1 | +102 |
- ## NB handling the case where there are no values is done during tabulation+ ) |
||
| 2 | +103 |
- ## which is the only reason expression(TRUE) is ok, because otherwise+ |
||
| 3 | +104 |
- ## we (sometimes) run into+ setMethod( |
||
| 4 | +105 |
- ## factor()[TRUE] giving <NA> (i.e. length 1)+ "payloadmsg", "AllSplit", |
||
| 5 | -4313x | +|||
| 106 | +! |
- setGeneric("make_subset_expr", function(spl, val) standardGeneric("make_subset_expr"))
+ function(spl) "all" |
||
| 6 | +107 |
-
+ ) |
||
| 7 | +108 |
- setMethod(+ |
||
| 8 | +109 |
- "make_subset_expr", "VarLevelSplit",+ setMethod( |
||
| 9 | +110 |
- function(spl, val) {
+ "payloadmsg", "ANY", |
||
| 10 | +111 |
- ## this is how custom split functions will communicate the correct expression+ function(spl) {
|
||
| 11 | -+ | |||
| 112 | +! |
- ## to the column modeling code+ warning("don't know how to make payload print message for Split of class", class(spl))
|
||
| 12 | -3194x | +|||
| 113 | +! |
- if (length(value_expr(val)) > 0) {
+ "XXX" |
||
| 13 | -12x | +|||
| 114 | +
- return(value_expr(val))+ } |
|||
| 14 | +115 |
- }+ ) |
||
| 15 | +116 | |||
| 16 | -3182x | +|||
| 117 | +
- v <- unlist(rawvalues(val))+ spldesc <- function(spl, value = "") {
|
|||
| 17 | -+ | |||
| 118 | +32x |
- ## XXX if we're including all levels should even missing be included?+ value <- rawvalues(value) |
||
| 18 | -3182x | +119 | +32x |
- if (is(v, "AllLevelsSentinel")) {
+ payloadmsg <- payloadmsg(spl) |
| 19 | -9x | +120 | +32x |
- as.expression(bquote((!is.na(.(a))), list(a = as.name(spl_payload(spl)))))+ format <- "%s (%s)" |
| 20 | -+ | |||
| 121 | +32x |
- } else {
+ sprintf( |
||
| 21 | -3173x | +122 | +32x |
- as.expression(bquote((!is.na(.(a)) & .(a) %in% .(b)), list(+ format, |
| 22 | -3173x | +123 | +32x |
- a = as.name(spl_payload(spl)),+ value, |
| 23 | -3173x | +124 | +32x |
- b = v+ payloadmsg |
| 24 | +125 |
- )))+ ) |
||
| 25 | +126 |
- }+ } |
||
| 26 | +127 |
- }+ |
||
| 27 | +128 |
- )+ layoutmsg <- function(obj) {
|
||
| 28 | +129 |
-
+ ## if(!is(obj, "VLayoutNode")) |
||
| 29 | +130 |
- setMethod(+ ## stop("how did a non layoutnode object get in docatlayout??")
|
||
| 30 | +131 |
- "make_subset_expr", "MultiVarSplit",+ |
||
| 31 | -+ | |||
| 132 | +28x |
- function(spl, val) {
+ pos <- tree_pos(obj) |
||
| 32 | -+ | |||
| 133 | +28x |
- ## this is how custom split functions will communicate the correct expression+ spllst <- pos_splits(pos) |
||
| 33 | -+ | |||
| 134 | +28x |
- ## to the column modeling code+ spvallst <- pos_splvals(pos) |
||
| 34 | -300x | +135 | +28x |
- if (length(value_expr(val)) > 0) {
+ if (is(obj, "LayoutAxisTree")) {
|
| 35 | -! | +|||
| 136 | +12x |
- return(value_expr(val))+ kids <- tree_children(obj) |
||
| 36 | -+ | |||
| 137 | +12x |
- }+ return(unlist(lapply(kids, layoutmsg))) |
||
| 37 | +138 |
-
+ } |
||
| 38 | +139 |
- ## v = rawvalues(val)+ |
||
| 39 | -+ | |||
| 140 | +16x |
- ## as.expression(bquote(!is.na(.(a)), list(a = v)))+ msg <- paste( |
||
| 40 | -300x | +141 | +16x |
- expression(TRUE)+ collapse = " -> ", |
| 41 | -+ | |||
| 142 | +16x |
- }+ mapply(spldesc, |
||
| 42 | -+ | |||
| 143 | +16x |
- )+ spl = spllst, |
||
| 43 | -+ | |||
| 144 | +16x |
-
+ value = spvallst |
||
| 44 | +145 |
- setMethod(+ ) |
||
| 45 | +146 |
- "make_subset_expr", "AnalyzeVarSplit",+ ) |
||
| 46 | -+ | |||
| 147 | +16x |
- function(spl, val) {
+ msg |
||
| 47 | -! | +|||
| 148 | +
- if (avar_inclNAs(spl)) {
+ } |
|||
| 48 | -! | +|||
| 149 | +
- expression(TRUE)+ |
|||
| 49 | +150 |
- } else {
+ setMethod( |
||
| 50 | -! | +|||
| 151 | +
- as.expression(bquote(+ "show", "LayoutAxisTree", |
|||
| 51 | -! | +|||
| 152 | +
- !is.na(.(a)),+ function(object) {
|
|||
| 52 | -! | +|||
| 153 | +2x |
- list(a = as.name(spl_payload(spl)))+ msg <- layoutmsg(object) |
||
| 53 | -+ | |||
| 154 | +2x |
- ))+ cat(msg, "\n") |
||
| 54 | -+ | |||
| 155 | +2x |
- }+ invisible(object) |
||
| 55 | +156 |
} |
||
| 56 | +157 |
) |
||
| 57 | +158 | |||
| 58 | +159 |
- setMethod(+ |
||
| 59 | +160 |
- "make_subset_expr", "AnalyzeColVarSplit",+ #' Display column tree structure |
||
| 60 | +161 |
- function(spl, val) {
+ #' |
||
| 61 | -! | +|||
| 162 | +
- expression(TRUE)+ #' Displays the tree structure of the columns of a |
|||
| 62 | +163 |
- }+ #' table or column structure object. |
||
| 63 | +164 |
- )+ #' |
||
| 64 | +165 |
-
+ #' @inheritParams gen_args |
||
| 65 | +166 |
- ## XXX these are going to be ridiculously slow+ #' |
||
| 66 | +167 |
- ## FIXME+ #' @return Nothing, called for its side effect of displaying |
||
| 67 | +168 |
-
+ #' a summary to the terminal. |
||
| 68 | +169 |
- setMethod(+ #' |
||
| 69 | +170 |
- "make_subset_expr", "VarStaticCutSplit",+ #' @examples |
||
| 70 | +171 |
- function(spl, val) {
+ #' lyt <- basic_table() %>% |
||
| 71 | -135x | +|||
| 172 | +
- v <- rawvalues(val)+ #' split_cols_by("ARM") %>%
|
|||
| 72 | +173 |
- ## as.expression(bquote(which(cut(.(a), breaks=.(brk), labels = .(labels),+ #' split_cols_by("STRATA1") %>%
|
||
| 73 | -135x | +|||
| 174 | +
- as.expression(bquote(+ #' split_cols_by("SEX", nested = FALSE) %>%
|
|||
| 74 | -135x | +|||
| 175 | +
- cut(.(a),+ #' analyze("AGE")
|
|||
| 75 | -135x | +|||
| 176 | +
- breaks = .(brk), labels = .(labels),+ #' |
|||
| 76 | -135x | +|||
| 177 | +
- include.lowest = TRUE+ #' tbl <- build_table(lyt, ex_adsl) |
|||
| 77 | -135x | +|||
| 178 | +
- ) == .(b),+ #' coltree_structure(tbl) |
|||
| 78 | -135x | +|||
| 179 | +
- list(+ #' @export |
|||
| 79 | -135x | +|||
| 180 | +
- a = as.name(spl_payload(spl)),+ coltree_structure <- function(obj) {
|
|||
| 80 | -135x | +181 | +1x |
- b = v,+ ctree <- coltree(obj) |
| 81 | -135x | +182 | +1x |
- brk = spl_cuts(spl),+ cat(layoutmsg2(ctree)) |
| 82 | -135x | +|||
| 183 | +
- labels = spl_cutlabels(spl)+ } |
|||
| 83 | +184 |
- )+ |
||
| 84 | +185 |
- ))+ lastposmsg <- function(pos) {
|
||
| 85 | -+ | |||
| 186 | +6x |
- }+ spls <- pos_splits(pos) |
||
| 86 | -+ | |||
| 187 | +6x |
- )+ splvals <- value_names(pos_splvals(pos)) |
||
| 87 | -+ | |||
| 188 | +6x |
-
+ indiv_msgs <- unlist(mapply(function(spl, valnm) paste(obj_name(spl), valnm, sep = ": "), |
||
| 88 | -+ | |||
| 189 | +6x |
- ## NB this assumes spl_cutlabels(spl) is in order!!!!!!+ spl = spls, |
||
| 89 | -+ | |||
| 190 | +6x |
- setMethod(+ valnm = splvals, |
||
| 90 | -+ | |||
| 191 | +6x |
- "make_subset_expr", "CumulativeCutSplit",+ SIMPLIFY = FALSE |
||
| 91 | +192 |
- function(spl, val) {
+ )) |
||
| 92 | -63x | +193 | +6x |
- v <- rawvalues(val)+ paste(indiv_msgs, collapse = " -> ") |
| 93 | +194 |
- ## as.expression(bquote(which(as.integer(cut(.(a), breaks=.(brk),+ } |
||
| 94 | -63x | +|||
| 195 | +
- as.expression(bquote(+ |
|||
| 95 | -63x | +|||
| 196 | +
- as.integer(cut(.(a),+ layoutmsg2 <- function(obj, level = 1) {
|
|||
| 96 | -63x | +197 | +7x |
- breaks = .(brk),+ nm <- obj_name(obj) |
| 97 | -63x | +198 | +7x |
- labels = .(labels),+ pos <- tree_pos(obj) |
| 98 | -63x | +199 | +7x |
- include.lowest = TRUE+ nopos <- identical(pos, EmptyTreePos) |
| 99 | +200 |
- )) <=+ |
||
| 100 | -63x | +201 | +7x |
- as.integer(factor(.(b), levels = .(labels))),+ msg <- paste0(strrep(" ", times = 2 * (level - 1)), "[", nm, "] (", if (nopos) "no pos" else lastposmsg(pos), ")\n")
|
| 101 | -63x | +202 | +7x |
- list(+ if (is(obj, "LayoutAxisTree")) {
|
| 102 | -63x | +203 | +3x |
- a = as.name(spl_payload(spl)),+ kids <- tree_children(obj) |
| 103 | -63x | +204 | +3x |
- b = v,+ msg <- c(msg, unlist(lapply(kids, layoutmsg2, level = level + 1))) |
| 104 | -63x | +|||
| 205 | +
- brk = spl_cuts(spl),+ } |
|||
| 105 | -63x | -
- labels = spl_cutlabels(spl)- |
- ||
| 106 | -+ | 206 | +7x |
- )+ msg |
| 107 | +207 |
- ))+ } |
||
| 108 | +208 |
- }+ |
||
| 109 | -+ | |||
| 209 | +46x |
- )+ setGeneric("spltype_abbrev", function(obj) standardGeneric("spltype_abbrev"))
|
||
| 110 | +210 | |||
| 111 | +211 |
- ## I think this one is unnecessary,+ setMethod( |
||
| 112 | +212 |
- ## build_table collapses DynCutSplits into+ "spltype_abbrev", "VarLevelSplit", |
||
| 113 | -+ | |||
| 213 | +4x |
- ## static ones.+ function(obj) "lvls" |
||
| 114 | +214 |
- ##+ ) |
||
| 115 | +215 |
- ## XXX TODO fixme+ |
||
| 116 | +216 |
- ## setMethod("make_subset_expr", "VarDynCutSplit",
+ setMethod( |
||
| 117 | +217 |
- ## function(spl, val) {
+ "spltype_abbrev", "VarLevWBaselineSplit", |
||
| 118 | -+ | |||
| 218 | +5x |
- ## v = rawvalues(val)+ function(obj) paste("ref_group", obj@ref_group_value)
|
||
| 119 | +219 |
- ## ## as.expression(bquote(which(.(fun)(.(a)) == .(b)),+ ) |
||
| 120 | +220 |
- ## as.expression(bquote(.(fun)(.(a)) == .(b)),+ |
||
| 121 | +221 |
- ## list(a = as.name(spl_payload(spl)),+ setMethod( |
||
| 122 | +222 |
- ## b = v,+ "spltype_abbrev", "MultiVarSplit", |
||
| 123 | -+ | |||
| 223 | +! |
- ## fun = spl@cut_fun))+ function(obj) "vars" |
||
| 124 | +224 |
- ## })+ ) |
||
| 125 | +225 | |||
| 126 | +226 |
setMethod( |
||
| 127 | +227 |
- "make_subset_expr", "AllSplit",+ "spltype_abbrev", "VarStaticCutSplit", |
||
| 128 | -327x | +228 | +10x |
- function(spl, val) expression(TRUE)+ function(obj) "scut" |
| 129 | +229 |
) |
||
| 130 | -- | - - | -||
| 131 | -- |
- ## probably don't need this- |
- ||
| 132 | +230 | |||
| 133 | +231 |
setMethod( |
||
| 134 | +232 |
- "make_subset_expr", "expression",+ "spltype_abbrev", "VarDynCutSplit", |
||
| 135 | -! | +|||
| 233 | +5x |
- function(spl, val) spl+ function(obj) "dcut" |
||
| 136 | +234 |
) |
||
| 137 | +235 |
-
+ setMethod( |
||
| 138 | +236 |
- setMethod(+ "spltype_abbrev", "AllSplit", |
||
| 139 | -+ | |||
| 237 | +15x |
- "make_subset_expr", "character",+ function(obj) "all obs" |
||
| 140 | +238 |
- function(spl, val) {
- |
- ||
| 141 | -! | -
- newspl <- VarLevelSplit(spl, spl)- |
- ||
| 142 | -! | -
- make_subset_expr(newspl, val)+ ) |
||
| 143 | +239 |
- }+ ## setMethod("spltype_abbrev", "NULLSplit",
|
||
| 144 | +240 |
- )+ ## function(obj) "no obs") |
||
| 145 | +241 | |||
| 146 | +242 |
- .combine_subset_exprs <- function(ex1, ex2) {
- |
- ||
| 147 | -2934x | -
- if (is.null(ex1) || identical(ex1, expression(TRUE))) {
- |
- ||
| 148 | -1864x | -
- if (is.expression(ex2) && !identical(ex2, expression(TRUE))) {
- |
- ||
| 149 | -1419x | -
- return(ex2)+ setMethod( |
||
| 150 | +243 |
- } else {
+ "spltype_abbrev", "AnalyzeVarSplit", |
||
| 151 | -445x | -
- return(expression(TRUE))- |
- ||
| 152 | -+ | 244 | +1x |
- }+ function(obj) "** analysis **" |
| 153 | +245 |
- }+ ) |
||
| 154 | +246 | |||
| 155 | +247 |
- ## if(is.null(ex2))+ setMethod( |
||
| 156 | +248 |
- ## ex2 <- expression(TRUE)- |
- ||
| 157 | -1070x | -
- stopifnot(is.expression(ex1), is.expression(ex2))+ "spltype_abbrev", "CompoundSplit", |
||
| 158 | -1070x | +|||
| 249 | +! |
- as.expression(bquote((.(a)) & .(b), list(a = ex1[[1]], b = ex2[[1]])))+ function(obj) paste("compound", paste(sapply(spl_payload(obj), spltype_abbrev), collapse = " "))
|
||
| 159 | +250 |
- }+ ) |
||
| 160 | +251 | |||
| 161 | -- |
- make_pos_subset <- function(spls = pos_splits(pos),- |
- ||
| 162 | +252 |
- svals = pos_splvals(pos),+ setMethod( |
||
| 163 | +253 |
- pos) {
- |
- ||
| 164 | -1003x | -
- expr <- NULL+ "spltype_abbrev", "AnalyzeMultiVars", |
||
| 165 | -1003x | +254 | +6x |
- for (i in seq_along(spls)) {
+ function(obj) "** multivar analysis **" |
| 166 | -1555x | +|||
| 255 | +
- newexpr <- make_subset_expr(spls[[i]], svals[[i]])+ ) |
|||
| 167 | -1555x | +|||
| 256 | +
- expr <- .combine_subset_exprs(expr, newexpr)+ setMethod( |
|||
| 168 | +257 |
- }+ "spltype_abbrev", "AnalyzeColVarSplit", |
||
| 169 | -1003x | +|||
| 258 | +! |
- expr+ function(obj) "** col-var analysis **" |
||
| 170 | +259 |
- }+ ) |
||
| 171 | +260 | |||
| 172 | +261 |
- get_pos_extra <- function(svals = pos_splvals(pos),+ docat_splitvec <- function(object, indent = 0) {
|
||
| 173 | -+ | |||
| 262 | +8x |
- pos) {
+ if (indent > 0) {
|
||
| 174 | -1009x | +|||
| 263 | +! |
- ret <- list()+ cat(rep(" ", times = indent), sep = "")
|
||
| 175 | -1009x | +|||
| 264 | +
- for (i in seq_along(svals)) {
+ } |
|||
| 176 | -1567x | +265 | +8x |
- extrs <- splv_extra(svals[[i]])+ if (length(object) == 1L && is(object[[1]], "VTableNodeInfo")) {
|
| 177 | -1567x | +|||
| 266 | +! |
- if (any(names(ret) %in% names(extrs))) {
+ tab <- object[[1]] |
||
| 178 | +267 | ! |
- stop("same extra argument specified at multiple levels of nesting. Not currently supported")
+ msg <- sprintf( |
|
| 179 | -+ | |||
| 268 | +! |
- }+ "A Pre-Existing Table [%d x %d]", |
||
| 180 | -1567x | +|||
| 269 | +! |
- ret <- c(ret, extrs)+ nrow(tab), ncol(tab) |
||
| 181 | +270 |
- }- |
- ||
| 182 | -1009x | -
- ret+ ) |
||
| 183 | +271 |
- }+ } else {
|
||
| 184 | -+ | |||
| 272 | +8x |
-
+ plds <- ploads_to_str(object) ## lapply(object, spl_payload)) |
||
| 185 | +273 |
- get_col_extras <- function(ctree) {
+
|
||
| 186 | -320x | +274 | +8x |
- leaves <- collect_leaves(ctree)+ tabbrev <- sapply(object, spltype_abbrev) |
| 187 | -320x | +275 | +8x |
- lapply(+ msg <- paste( |
| 188 | -320x | +276 | +8x |
- leaves,+ collapse = " -> ", |
| 189 | -320x | +277 | +8x |
- function(x) get_pos_extra(pos = tree_pos(x))+ paste0(plds, " (", tabbrev, ")")
|
| 190 | +278 |
- )+ ) |
||
| 191 | +279 |
- }+ } |
||
| 192 | -+ | |||
| 280 | +8x |
-
+ cat(msg, "\n") |
||
| 193 | +281 |
- setGeneric(+ } |
||
| 194 | +282 |
- "make_col_subsets",- |
- ||
| 195 | -1322x | -
- function(lyt, df) standardGeneric("make_col_subsets")
+
|
||
| 196 | +283 |
- )+ setMethod( |
||
| 197 | +284 |
-
+ "show", "SplitVector", |
||
| 198 | +285 |
- setMethod(+ function(object) {
|
||
| 199 | -+ | |||
| 286 | +1x |
- "make_col_subsets", "LayoutColTree",+ cat("A SplitVector Pre-defining a Tree Structure\n\n")
|
||
| 200 | -+ | |||
| 287 | +1x |
- function(lyt, df) {
+ docat_splitvec(object) |
||
| 201 | -319x | +288 | +1x |
- leaves <- collect_leaves(lyt)+ cat("\n")
|
| 202 | -319x | +289 | +1x |
- lapply(leaves, make_col_subsets)+ invisible(object) |
| 203 | +290 |
} |
||
| 204 | +291 |
) |
||
| 205 | +292 | |||
| 206 | +293 |
- setMethod(+ docat_predataxis <- function(object, indent = 0) {
|
||
| 207 | -+ | |||
| 294 | +6x |
- "make_col_subsets", "LayoutColLeaf",+ lapply(object, docat_splitvec) |
||
| 208 | +295 |
- function(lyt, df) {
+ } |
||
| 209 | -1003x | +|||
| 296 | +
- make_pos_subset(pos = tree_pos(lyt))+ |
|||
| 210 | +297 |
- }+ setMethod( |
||
| 211 | +298 |
- )+ "show", "PreDataColLayout", |
||
| 212 | +299 |
-
+ function(object) {
|
||
| 213 | -+ | |||
| 300 | +1x |
- create_colinfo <- function(lyt, df, rtpos = TreePos(),+ cat("A Pre-data Column Layout Object\n\n")
+ |
+ ||
| 301 | +1x | +
+ docat_predataxis(object)+ |
+ ||
| 302 | +1x | +
+ invisible(object) |
||
| 214 | +303 |
- counts = NULL,+ } |
||
| 215 | +304 |
- alt_counts_df = NULL,+ ) |
||
| 216 | +305 |
- total = NULL,+ |
||
| 217 | +306 |
- topleft = NULL) {
+ setMethod( |
||
| 218 | +307 |
- ## this will work whether clayout is pre or post+ "show", "PreDataRowLayout", |
||
| 219 | +308 |
- ## data+ function(object) {
|
||
| 220 | -325x | +309 | +1x |
- clayout <- clayout(lyt)+ cat("A Pre-data Row Layout Object\n\n")
|
| 221 | -325x | +310 | +1x |
- if (is.null(topleft)) {
+ docat_predataxis(object) |
| 222 | -325x | +311 | +1x |
- topleft <- top_left(lyt)+ invisible(object) |
| 223 | +312 |
} |
||
| 224 | -325x | +|||
| 313 | +
- cc_format <- colcount_format(lyt) %||% "(N=xx)"+ ) |
|||
| 225 | +314 | |||
| 226 | +315 |
- ## do it this way for full backwards compatibility+ setMethod( |
||
| 227 | -325x | +|||
| 316 | +
- if (is.null(alt_counts_df)) {
+ "show", "PreDataTableLayouts", |
|||
| 228 | -306x | +|||
| 317 | +
- alt_counts_df <- df+ function(object) {
|
|||
| 229 | -+ | |||
| 318 | +2x |
- }+ cat("A Pre-data Table Layout\n")
|
||
| 230 | -325x | +319 | +2x |
- ctree <- coltree(clayout, df = df, rtpos = rtpos, alt_counts_df = alt_counts_df, ccount_format = cc_format)+ cat("\nColumn-Split Structure:\n")
|
| 231 | -318x | +320 | +2x |
- if (!is.na(disp_ccounts(lyt))) {
+ docat_predataxis(object@col_layout) |
| 232 | -81x | +321 | +2x |
- leaf_pths <- make_col_df(ctree, visible_only = TRUE, na_str = "", ccount_format = cc_format)$path+ cat("\nRow-Split Structure:\n")
|
| 233 | -81x | +322 | +2x |
- for (path in leaf_pths) {
+ docat_predataxis(object@row_layout) |
| 234 | -323x | +323 | +2x |
- colcount_visible(ctree, path) <- disp_ccounts(lyt)+ cat("\n")
|
| 235 | -+ | |||
| 324 | +2x |
- }+ invisible(object) |
||
| 236 | +325 |
} |
||
| 237 | +326 | - - | -||
| 238 | -318x | -
- cexprs <- make_col_subsets(ctree, df)- |
- ||
| 239 | -318x | -
- colextras <- col_extra_args(ctree)+ ) |
||
| 240 | +327 | |||
| 241 | +328 |
- ## calculate the counts based on the df+ setMethod( |
||
| 242 | +329 |
- ## This presumes that it is called on the WHOLE dataset,+ "show", "InstantiatedColumnInfo", |
||
| 243 | +330 |
- ## NOT after any splitting has occurred. Otherwise+ function(object) {
|
||
| 244 | -+ | |||
| 331 | +2x |
- ## the counts will obviously be wrong.+ layoutmsg <- layoutmsg(coltree(object)) |
||
| 245 | -318x | +332 | +2x |
- if (is.null(counts)) {
+ cat("An InstantiatedColumnInfo object",
|
| 246 | -314x | +333 | +2x |
- counts <- rep(NA_integer_, length(cexprs))+ "Columns:", |
| 247 | -4x | +334 | +2x |
- } else if (length(counts) != length(cexprs)) {
+ layoutmsg, |
| 248 | -1x | +335 | +2x |
- stop(+ if (disp_ccounts(object)) {
|
| 249 | -1x | +336 | +2x |
- "Length of overriding counts must equal number of columns. Got ",+ paste( |
| 250 | -1x | +337 | +2x |
- length(counts), " values for ", length(cexprs), " columns. ",+ "ColumnCounts:\n", |
| 251 | -1x | +338 | +2x |
- "Use NAs to specify that the default counting machinery should be ",+ paste(col_counts(object), |
| 252 | -1x | +339 | +2x |
- "used for that position."+ collapse = ", " |
| 253 | +340 |
- )+ ) |
||
| 254 | +341 |
- }+ ) |
||
| 255 | +342 |
-
+ }, |
||
| 256 | -317x | +|||
| 343 | +
- counts_df_name <- "alt_counts_df"+ "", |
|||
| 257 | -317x | +344 | +2x |
- if (identical(alt_counts_df, df)) { # is.null(alt_counts_df)) {
+ sep = "\n" |
| 258 | -302x | +|||
| 345 | +
- alt_counts_df <- df+ ) |
|||
| 259 | -302x | +346 | +2x |
- counts_df_name <- "df"+ invisible(object) |
| 260 | +347 |
} |
||
| 261 | -317x | +|||
| 348 | +
- calcpos <- is.na(counts)+ ) |
|||
| 262 | +349 | |||
| 263 | -317x | -
- calccounts <- sapply(cexprs, function(ex) {
- |
- ||
| 264 | -994x | -
- if (identical(ex, expression(TRUE))) {
- |
- ||
| 265 | -149x | -
- nrow(alt_counts_df)- |
- ||
| 266 | -845x | -
- } else if (identical(ex, expression(FALSE))) {
- |
- ||
| 267 | -! | -
- 0L- |
- ||
| 268 | +350 |
- } else {
+ #' @rdname int_methods |
||
| 269 | -845x | +|||
| 351 | +
- vec <- try(eval(ex, envir = alt_counts_df), silent = TRUE)+ setMethod("print", "VTableTree", function(x, ...) {
|
|||
| 270 | -845x | -
- if (is(vec, "numeric")) {
- |
- ||
| 271 | -! | +352 | +5x |
- length(vec)+ msg <- toString(x, ...) |
| 272 | -845x | +353 | +4x |
- } else if (is(vec, "logical")) { ## sum(is.na(.)) ????
+ cat(msg) |
| 273 | -845x | +354 | +4x |
- sum(vec, na.rm = TRUE)+ invisible(x) |
| 274 | +355 |
- }+ }) |
||
| 275 | +356 |
- }+ |
||
| 276 | +357 |
- })- |
- ||
| 277 | -317x | -
- counts[calcpos] <- calccounts[calcpos]+ #' @rdname int_methods |
||
| 278 | -317x | +|||
| 358 | +
- counts <- as.integer(counts)+ setMethod("show", "VTableTree", function(object) {
|
|||
| 279 | -317x | +|||
| 359 | +! |
- if (is.null(total)) {
+ cat(toString(object)) |
||
| 280 | +360 | ! |
- total <- sum(counts)+ invisible(object) |
|
| 281 | +361 |
- }+ }) |
||
| 282 | +362 | |||
| 283 | -317x | -
- cpths <- col_paths(ctree)- |
- ||
| 284 | -317x | -
- for (i in seq_along(cpths)) {
- |
- ||
| 285 | -994x | -
- facet_colcount(ctree, cpths[[i]]) <- counts[i]- |
- ||
| 286 | +363 |
- }+ setMethod("show", "TableRow", function(object) {
|
||
| 287 | -317x | +364 | +1x |
- InstantiatedColumnInfo(+ cat(sprintf( |
| 288 | -317x | +365 | +1x |
- treelyt = ctree,+ "[%s indent_mod %d]: %s %s\n", |
| 289 | -317x | +366 | +1x |
- csubs = cexprs,+ class(object), |
| 290 | -317x | +367 | +1x |
- extras = colextras,+ indent_mod(object), |
| 291 | -317x | +368 | +1x |
- cnts = counts,+ obj_label(object), |
| 292 | -317x | +369 | +1x |
- dispcounts = disp_ccounts(lyt),+ paste(as.vector(get_formatted_cells(object)), |
| 293 | -317x | +370 | +1x |
- countformat = cc_format,+ collapse = " " |
| 294 | -317x | +|||
| 371 | +
- total_cnt = total,+ ) |
|||
| 295 | -317x | +|||
| 372 | +
- topleft = topleft+ )) |
|||
| 296 | -+ | |||
| 373 | +1x |
- )+ invisible(object) |
||
| 297 | +374 |
- }+ }) |
||
| 2 | -2223x | +2273x |
if (length(refs) == 0) {
|
|
| 3 | -2157x | +2207x |
return(refs) |
@@ -138145,28 +138202,28 @@ |
| 56 | -419x | +426x |
ctree <- coltree(tt) |
|
| 57 | -419x | +426x |
ctree <- .index_col_refs_inner(ctree, cur_idx_fun) |
|
| 58 | -419x | +426x |
coltree(tt) <- ctree |
|
| 59 | -419x | +426x |
tt |
@@ -138194,21 +138251,21 @@ |
| 63 | -1998x | +2048x |
col_footnotes(ctree) <- .reindex_one_pos( |
|
| 64 | -1998x | +2048x |
col_footnotes(ctree), |
|
| 65 | -1998x | +2048x |
cur_idx_fun |
@@ -138229,28 +138286,28 @@ |
| 68 | -1998x | +2048x |
if (is(ctree, "LayoutColTree")) {
|
|
| 69 | -747x | +763x |
tree_children(ctree) <- lapply(tree_children(ctree), |
|
| 70 | -747x | +763x |
.index_col_refs_inner, |
|
| 71 | -747x | +763x |
cur_idx_fun = cur_idx_fun |
@@ -138271,7 +138328,7 @@ |
| 74 | -1998x | +2048x |
ctree |
@@ -138425,42 +138482,42 @@ |
| 96 | -419x | +426x |
col_fnotes <- c(list(row_fnotes = list()), col_footnotes(tt)) |
|
| 97 | -419x | +426x |
row_fnotes <- row_footnotes(tt) |
|
| 98 | -419x | +426x |
cell_fnotes <- cell_footnotes(tt) |
|
| 99 | -419x | +426x |
all_fns <- rbind(col_fnotes, cbind(row_fnotes, cell_fnotes)) |
|
| 100 | -419x | +426x |
all_fns <- unlist(t(all_fns)) |
|
| 101 | -419x | +426x |
unique_fnotes <- unique(sapply(all_fns, ref_msg)) |
@@ -138474,7 +138531,7 @@ |
| 103 | -419x | +426x |
cur_index <- function(ref_fn) {
|
@@ -138502,14 +138559,14 @@ |
| 107 | -419x | +426x |
if (ncol(tt) > 0) {
|
|
| 108 | -419x | +426x |
tt <- index_col_refs(tt, cur_index) |
@@ -138537,7 +138594,7 @@ |
| 112 | -419x | +426x |
if (nrow(tt) == 0) {
|
@@ -138565,7 +138622,7 @@ |
| 116 | -403x | +410x |
rdf <- make_row_df(tt) |
@@ -138579,21 +138636,21 @@ |
| 118 | -403x | +410x |
rdf <- rdf[rdf$nreflines > 0, ] |
|
| 119 | -403x | +410x |
if (nrow(rdf) == 0) {
|
|
| 120 | -371x | +378x |
return(tt) |
@@ -138685,3100 +138742,3953 @@
| 1 |
- # paths summary ----+ #' Trimming and pruning criteria |
|||
| 2 |
-
+ #' |
|||
| 3 |
- #' Get a list of table row/column paths+ #' 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. |
||
| 4 | +74 |
#' |
||
| 5 | +75 |
- #' @param x (`VTableTree`)\cr an `rtable` object.+ #' @seealso [prune_table()] |
||
| 6 | +76 |
#' |
||
| 7 | +77 |
- #' @return A list of paths to each row/column within `x`.+ #' @examples |
||
| 8 | +78 |
- #'+ #' adsl <- ex_adsl |
||
| 9 | +79 |
- #' @seealso [cell_values()], [`fnotes_at_path<-`], [row_paths_summary()], [col_paths_summary()]+ #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER") |
||
| 10 | +80 |
#' |
||
| 11 | +81 |
- #' @examples+ #' tbl_to_trim <- basic_table() %>% |
||
| 12 | +82 |
- #' lyt <- basic_table() %>%+ #' analyze("BMRKR1") %>%
|
||
| 13 | +83 |
#' split_cols_by("ARM") %>%
|
||
| 14 | +84 |
- #' analyze(c("SEX", "AGE"))
+ #' split_rows_by("SEX") %>%
|
||
| 15 | +85 |
- #'+ #' summarize_row_groups() %>% |
||
| 16 | +86 |
- #' tbl <- build_table(lyt, ex_adsl)+ #' split_rows_by("STRATA1") %>%
|
||
| 17 | +87 |
- #' tbl+ #' summarize_row_groups() %>% |
||
| 18 | +88 |
- #'+ #' analyze("AGE") %>%
|
||
| 19 | +89 |
- #' row_paths(tbl)+ #' build_table(adsl) |
||
| 20 | +90 |
- #' col_paths(tbl)+ #' |
||
| 21 | +91 |
- #'+ #' tbl_to_trim %>% trim_rows() |
||
| 22 | +92 |
- #' cell_values(tbl, c("AGE", "Mean"), c("ARM", "B: Placebo"))
+ #' |
||
| 23 | +93 |
- #'+ #' tbl_to_trim %>% trim_rows(all_zero) |
||
| 24 | +94 |
- #' @rdname make_col_row_df+ #' |
||
| 25 | +95 |
#' @export |
||
| 26 | +96 |
- row_paths <- function(x) {
+ trim_rows <- function(tt, criteria = all_zero_or_na) {
|
||
| 27 | -45x | +97 | +3x |
- stopifnot(is_rtable(x))+ rows <- collect_leaves(tt, TRUE, TRUE) |
| 28 | -45x | +98 | +3x |
- make_row_df(x, visible_only = TRUE)$path+ torm <- vapply(rows, criteria, |
| 29 | -+ | |||
| 99 | +3x |
- }+ NA, |
||
| 30 | -+ | |||
| 100 | +3x |
-
+ USE.NAMES = FALSE |
||
| 31 | +101 |
- #' @rdname make_col_row_df+ ) |
||
| 32 | -+ | |||
| 102 | +3x |
- #' @export+ tt[!torm, , |
||
| 33 | -+ | |||
| 103 | +3x |
- col_paths <- function(x) {
+ keep_topleft = TRUE, |
||
| 34 | -2341x | +104 | +3x |
- if (!is(coltree(x), "LayoutColTree")) {
+ keep_titles = TRUE, |
| 35 | -! | +|||
| 105 | +3x |
- stop("I don't know how to extract the column paths from an object of class ", class(x))
+ keep_footers = TRUE, |
||
| 36 | -+ | |||
| 106 | +3x |
- }+ reindex_refs = TRUE |
||
| 37 | -2341x | +|||
| 107 | +
- make_col_df(x, visible_only = TRUE)$path+ ] |
|||
| 38 | +108 |
} |
||
| 39 | +109 | |||
| 40 | +110 |
- #' Print row/column paths summary+ #' @inheritParams trim_rows |
||
| 41 | +111 |
#' |
||
| 42 | +112 |
- #' @param x (`VTableTree`)\cr an `rtable` object.+ #' @details |
||
| 43 | +113 |
- #'+ #' `content_all_zeros_nas` prunes a subtable if both of the following are true: |
||
| 44 | +114 |
- #' @return A data frame summarizing the row- or column-structure of `x`.+ #' |
||
| 45 | +115 |
- #'+ #' * It has a content table with exactly one row in it. |
||
| 46 | +116 |
- #' @examplesIf require(dplyr)+ #' * `all_zero_or_na` returns `TRUE` for that single content row. In practice, when the default summary/content |
||
| 47 | +117 |
- #' ex_adsl_MF <- ex_adsl %>% dplyr::filter(SEX %in% c("M", "F"))
+ #' function is used, this represents pruning any subtable which corresponds to an empty set of the input data |
||
| 48 | +118 |
- #'+ #' (e.g. because a factor variable was used in [split_rows_by()] but not all levels were present in the data). |
||
| 49 | +119 |
- #' lyt <- basic_table() %>%+ #' |
||
| 50 | +120 |
- #' split_cols_by("ARM") %>%
+ #' @examples |
||
| 51 | +121 |
- #' split_cols_by("SEX", split_fun = drop_split_levels) %>%
+ #' tbl_to_prune %>% prune_table(content_all_zeros_nas) |
||
| 52 | +122 |
- #' analyze(c("AGE", "BMRKR2"))
+ #' |
||
| 53 | +123 |
- #'+ #' @rdname trim_prune_funs |
||
| 54 | +124 |
- #' tbl <- build_table(lyt, ex_adsl_MF)+ #' @export |
||
| 55 | +125 |
- #' tbl+ content_all_zeros_nas <- function(tt, criteria = all_zero_or_na) {
|
||
| 56 | +126 |
- #'+ ## this will be NULL if |
||
| 57 | +127 |
- #' df <- row_paths_summary(tbl)+ ## tt is something that doesn't have a content table |
||
| 58 | -+ | |||
| 128 | +254x |
- #' df+ ct <- content_table(tt) |
||
| 59 | +129 |
- #'+ ## NROW returns 0 for NULL. |
||
| 60 | -+ | |||
| 130 | +254x |
- #' col_paths_summary(tbl)+ if (NROW(ct) == 0 || nrow(ct) > 1) {
|
||
| 61 | -+ | |||
| 131 | +242x |
- #'+ return(FALSE) |
||
| 62 | +132 |
- #' # manually constructed table+ } |
||
| 63 | +133 |
- #' tbl2 <- rtable(+ |
||
| 64 | -+ | |||
| 134 | +12x |
- #' rheader(+ cr <- tree_children(ct)[[1]] |
||
| 65 | -+ | |||
| 135 | +12x |
- #' rrow(+ criteria(cr) |
||
| 66 | +136 |
- #' "row 1", rcell("a", colspan = 2),
+ } |
||
| 67 | +137 |
- #' rcell("b", colspan = 2)
+
|
||
| 68 | +138 |
- #' ),+ #' @details |
||
| 69 | +139 |
- #' rrow("h2", "a", "b", "c", "d")
+ #' `prune_empty_level` combines `all_zero_or_na` behavior for `TableRow` objects, `content_all_zeros_nas` on |
||
| 70 | +140 |
- #' ),+ #' `content_table(tt)` for `TableTree` objects, and an additional check that returns `TRUE` if the `tt` has no |
||
| 71 | +141 |
- #' rrow("r1", 1, 2, 1, 2), rrow("r2", 3, 4, 2, 1)
+ #' children. |
||
| 72 | +142 |
- #' )+ #' |
||
| 73 | +143 |
- #' col_paths_summary(tbl2)+ #' @examples |
||
| 74 | +144 |
- #'+ #' tbl_to_prune %>% prune_table(prune_empty_level) |
||
| 75 | +145 |
- #' @export+ #' |
||
| 76 | +146 |
- row_paths_summary <- function(x) {
+ #' @rdname trim_prune_funs |
||
| 77 | -1x | +|||
| 147 | +
- stopifnot(is_rtable(x))+ #' @export |
|||
| 78 | +148 |
-
+ prune_empty_level <- function(tt) {
|
||
| 79 | -1x | +149 | +389x |
- if (nrow(x) == 0) {
+ if (is(tt, "TableRow")) {
|
| 80 | -! | +|||
| 150 | +151x |
- return("rowname node_class path\n---------------------\n")
+ return(all_zero_or_na(tt)) |
||
| 81 | +151 |
} |
||
| 82 | +152 | |||
| 83 | -1x | +153 | +238x |
- pagdf <- make_row_df(x, visible_only = TRUE)+ if (content_all_zeros_nas(tt)) {
|
| 84 | -1x | +154 | +2x |
- row.names(pagdf) <- NULL+ return(TRUE) |
| 85 | +155 |
-
+ } |
||
| 86 | -1x | +156 | +236x |
- mat <- rbind(+ kids <- tree_children(tt) |
| 87 | -1x | +157 | +236x |
- c("rowname", "node_class", "path"),
+ length(kids) == 0 |
| 88 | -1x | +|||
| 158 | +
- t(apply(pagdf, 1, function(xi) {
+ } |
|||
| 89 | -28x | +|||
| 159 | +
- c(+ |
|||
| 90 | -28x | +|||
| 160 | +
- indent_string(xi$label, xi$indent),+ #' @details `prune_zeros_only` behaves as `prune_empty_level` does, except that like `all_zero` it prunes |
|||
| 91 | -28x | +|||
| 161 | +
- xi$node_class,+ #' only in the case of all non-missing zero values. |
|||
| 92 | -28x | +|||
| 162 | +
- paste(xi$path, collapse = ", ")+ #' |
|||
| 93 | +163 |
- )+ #' @examples |
||
| 94 | +164 |
- }))+ #' tbl_to_prune %>% prune_table(prune_zeros_only) |
||
| 95 | +165 |
- )+ #' |
||
| 96 | +166 |
-
+ #' @rdname trim_prune_funs |
||
| 97 | -1x | +|||
| 167 | +
- txt <- mat_as_string(mat)+ #' @export+ |
+ |||
| 168 | ++ |
+ prune_zeros_only <- function(tt) {
|
||
| 98 | -1x | +169 | +16x |
- cat(txt)+ if (is(tt, "TableRow")) {
|
| 99 | -1x | +170 | +8x |
- cat("\n")
+ return(all_zero(tt)) |
| 100 | +171 | ++ |
+ }+ |
+ |
| 172 | ||||
| 101 | -1x | +173 | +8x |
- invisible(pagdf[, c("label", "indent", "node_class", "path")])
+ if (content_all_zeros_nas(tt, criteria = all_zero)) {
|
| 102 | -+ | |||
| 174 | +! |
- }+ return(TRUE) |
||
| 103 | +175 |
-
+ }+ |
+ ||
| 176 | +8x | +
+ kids <- tree_children(tt)+ |
+ ||
| 177 | +8x | +
+ length(kids) == 0 |
||
| 104 | +178 |
- #' @rdname row_paths_summary+ } |
||
| 105 | +179 |
- #' @export+ |
||
| 106 | +180 |
- col_paths_summary <- function(x) {
+ #' @param min (`numeric(1)`)\cr (used by `low_obs_pruner` only). Minimum aggregate count value. |
||
| 107 | -1x | +|||
| 181 | +
- stopifnot(is_rtable(x))+ #' Subtables whose combined/average count are below this threshold will be pruned. |
|||
| 108 | +182 |
-
+ #' @param type (`string`)\cr how count values should be aggregated. Must be `"sum"` (the default) or `"mean"`. |
||
| 109 | -1x | +|||
| 183 | +
- pagdf <- make_col_df(x, visible_only = FALSE)+ #' |
|||
| 110 | -1x | +|||
| 184 | +
- row.names(pagdf) <- NULL+ #' @details |
|||
| 111 | +185 |
-
+ #' `low_obs_pruner` is a *constructor function* which, when called, returns a pruning criteria function which |
||
| 112 | -1x | +|||
| 186 | +
- mat <- rbind(+ #' will prune on content rows by comparing sum or mean (dictated by `type`) of the count portions of the cell |
|||
| 113 | -1x | +|||
| 187 | +
- c("label", "path"),
+ #' values (defined as the first value per cell regardless of how many values per cell there are) against `min`. |
|||
| 114 | -1x | +|||
| 188 | +
- t(apply(pagdf, 1, function(xi) {
+ #' |
|||
| 115 | -6x | +|||
| 189 | +
- c(+ #' @examples |
|||
| 116 | -6x | +|||
| 190 | +
- indent_string(xi$label, floor(length(xi$path) / 2 - 1)),+ #' min_prune <- low_obs_pruner(70, "sum") |
|||
| 117 | -6x | +|||
| 191 | +
- paste(xi$path, collapse = ", ")+ #' tbl_to_prune %>% prune_table(min_prune) |
|||
| 118 | +192 |
- )+ #' |
||
| 119 | +193 |
- }))+ #' @rdname trim_prune_funs |
||
| 120 | +194 |
- )+ #' @export |
||
| 121 | +195 |
-
+ low_obs_pruner <- function(min, type = c("sum", "mean")) {
|
||
| 122 | -1x | +196 | +3x |
- txt <- mat_as_string(mat)+ type <- match.arg(type) |
| 123 | -1x | +197 | +3x |
- cat(txt)+ function(tt) {
|
| 124 | -1x | +198 | +21x |
- cat("\n")
+ if (is(tt, "TableRow") || NROW(ctab <- content_table(tt)) != 1) { ## note the <- in there!!!
+ |
+
| 199 | +9x | +
+ return(FALSE) ## only trimming on count content rows |
||
| 125 | +200 |
-
+ } |
||
| 126 | -1x | +201 | +12x |
- invisible(pagdf[, c("label", "path")])
+ ctr <- tree_children(ctab)[[1]] |
| 127 | -+ | |||
| 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) |
||
| 128 | +206 |
-
+ }+ |
+ ||
| 207 | +12x | +
+ sumvals < min |
||
| 129 | +208 |
- # Rows ----+ } |
||
| 130 | +209 |
- # . Summarize Rows ----+ } |
||
| 131 | +210 | |||
| 132 | +211 |
- # summarize_row_df <-+ #' Recursively prune a `TableTree` |
||
| 133 | +212 |
- # function(name,+ #' |
||
| 134 | +213 |
- # label,+ #' @inheritParams gen_args |
||
| 135 | +214 |
- # indent,+ #' @param prune_func (`function`)\cr a function to be called on each subtree which returns `TRUE` if the |
||
| 136 | +215 |
- # depth,+ #' entire subtree should be removed. |
||
| 137 | +216 |
- # rowtype,+ #' @param stop_depth (`numeric(1)`)\cr the depth after which subtrees should not be checked for pruning. |
||
| 138 | +217 |
- # indent_mod,+ #' Defaults to `NA` which indicates pruning should happen at all levels. |
||
| 139 | +218 |
- # level) {
+ #' @param depth (`numeric(1)`)\cr used internally, not intended to be set by the end user. |
||
| 140 | +219 |
- # data.frame(+ #' |
||
| 141 | +220 |
- # name = name,+ #' @return A `TableTree` pruned via recursive application of `prune_func`. |
||
| 142 | +221 |
- # label = label,+ #' |
||
| 143 | +222 |
- # indent = indent,+ #' @seealso [prune_empty_level()] for details on this and several other basic pruning functions included |
||
| 144 | +223 |
- # depth = level,+ #' in the `rtables` package. |
||
| 145 | +224 |
- # rowtype = rowtype,+ #' |
||
| 146 | +225 |
- # indent_mod = indent_mod,+ #' @examples |
||
| 147 | +226 |
- # level = level,+ #' adsl <- ex_adsl |
||
| 148 | +227 |
- # stringsAsFactors = FALSE+ #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER") |
||
| 149 | +228 |
- # )+ #' |
||
| 150 | +229 |
- # }+ #' tbl_to_prune <- basic_table() %>% |
||
| 151 | +230 |
-
+ #' split_cols_by("ARM") %>%
|
||
| 152 | +231 |
- #' Summarize rows+ #' split_rows_by("SEX") %>%
|
||
| 153 | +232 |
- #'+ #' summarize_row_groups() %>% |
||
| 154 | +233 |
- #' @inheritParams gen_args+ #' split_rows_by("STRATA1") %>%
|
||
| 155 | +234 |
- #' @param depth (`numeric(1)`)\cr depth.+ #' summarize_row_groups() %>% |
||
| 156 | +235 |
- #' @param indent (`numeric(1)`)\cr indent.+ #' analyze("AGE") %>%
|
||
| 157 | +236 |
- #'+ #' build_table(adsl) |
||
| 158 | +237 |
- #' @examplesIf require(dplyr)+ #' |
||
| 159 | +238 |
- #' library(dplyr)+ #' tbl_to_prune %>% prune_table() |
||
| 160 | +239 |
#' |
||
| 161 | +240 |
- #' iris2 <- iris %>%+ #' @export |
||
| 162 | +241 |
- #' group_by(Species) %>%+ prune_table <- function(tt, |
||
| 163 | +242 |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ prune_func = prune_empty_level, |
||
| 164 | +243 |
- #' ungroup()+ stop_depth = NA_real_, |
||
| 165 | +244 |
- #'+ depth = 0) {
|
||
| 166 | -+ | |||
| 245 | +323x |
- #' lyt <- basic_table() %>%+ if (!is.na(stop_depth) && depth > stop_depth) {
|
||
| 167 | -+ | |||
| 246 | +! |
- #' split_cols_by("Species") %>%
+ return(tt) |
||
| 168 | +247 |
- #' split_cols_by("group") %>%
+ } |
||
| 169 | -+ | |||
| 248 | +323x |
- #' analyze(c("Sepal.Length", "Petal.Width"),
+ if (is(tt, "TableRow")) {
|
||
| 170 | -+ | |||
| 249 | +54x |
- #' afun = list_wrap_x(summary),+ if (prune_func(tt)) {
+ |
+ ||
| 250 | +! | +
+ tt <- NULL |
||
| 171 | +251 |
- #' format = "xx.xx"+ }+ |
+ ||
| 252 | +54x | +
+ return(tt) |
||
| 172 | +253 |
- #' )+ } |
||
| 173 | +254 |
- #'+ + |
+ ||
| 255 | +269x | +
+ kids <- tree_children(tt) |
||
| 174 | +256 |
- #' tbl <- build_table(lyt, iris2)+ + |
+ ||
| 257 | +269x | +
+ torm <- vapply(kids, function(tb) {
+ |
+ ||
| 258 | +386x | +
+ !is.null(tb) && prune_func(tb)+ |
+ ||
| 259 | +269x | +
+ }, NA) |
||
| 175 | +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 |
||
| 176 | +266 |
- #' @rdname int_methods+ ) |
||
| 177 | +267 |
- setGeneric("summarize_rows_inner", function(obj, depth = 0, indent = 0) {
+
|
||
| 178 | -! | +|||
| 268 | +269x |
- standardGeneric("summarize_rows_inner")
+ keepkids <- keepkids[!vapply(keepkids, is.null, NA)] |
||
| 179 | -+ | |||
| 269 | +269x |
- })+ if (length(keepkids) > 0) {
+ |
+ ||
| 270 | +135x | +
+ tree_children(tt) <- keepkids |
||
| 180 | +271 |
-
+ } else {
+ |
+ ||
| 272 | +134x | +
+ tt <- NULL |
||
| 181 | +273 |
- #' @rdname int_methods+ }+ |
+ ||
| 274 | +269x | +
+ tt |
||
| 182 | +275 |
- setMethod(+ } |
| 183 | +1 |
- "summarize_rows_inner", "TableTree",+ insert_brs <- function(vec) {
|
||
| 184 | -+ | |||
| 2 | +1021x |
- function(obj, depth = 0, indent = 0) {
+ if (length(vec) == 1) {
|
||
| 185 | -! | +|||
| 3 | +1021x |
- indent <- max(0L, indent + indent_mod(obj))+ ret <- list(vec) |
||
| 186 | +4 |
-
+ } else {
|
||
| 187 | +5 | ! |
- lr <- summarize_rows_inner(tt_labelrow(obj), depth, indent)+ nout <- length(vec) * 2 - 1 |
|
| 188 | +6 | ! |
- if (!is.null(lr)) {
+ ret <- vector("list", nout)
|
|
| 189 | +7 | ! |
- ret <- list(lr)+ for (i in seq_along(vec)) {
|
|
| 190 | -+ | |||
| 8 | +! |
- } else {
+ ret[[2 * i - 1]] <- vec[i] |
||
| 191 | +9 | ! |
- ret <- list()+ if (2 * i < nout) {
|
|
| 192 | -+ | |||
| 10 | +! |
- }+ ret[[2 * i]] <- tags$br() |
||
| 193 | +11 |
-
+ } |
||
| 194 | -! | +|||
| 12 | +
- indent <- indent + (!is.null(lr))+ } |
|||
| 195 | +13 |
-
+ } |
||
| 196 | -! | +|||
| 14 | +1021x |
- ctab <- content_table(obj)+ ret |
||
| 197 | -! | +|||
| 15 | +
- if (NROW(ctab)) {
+ } |
|||
| 198 | -! | +|||
| 16 | +
- ct <- summarize_rows_inner(ctab,+ |
|||
| 199 | -! | +|||
| 17 | +
- depth = depth,+ div_helper <- function(lst, class) {
|
|||
| 200 | -! | +|||
| 18 | +72x |
- indent = indent + indent_mod(ctab)+ do.call(tags$div, c(list(class = paste(class, "rtables-container"), lst))) |
||
| 201 | +19 |
- )+ } |
||
| 202 | -! | +|||
| 20 | +
- ret <- c(ret, ct)+ |
|||
| 203 | -! | +|||
| 21 | +
- indent <- indent + (length(ct) > 0) * (1 + indent_mod(ctab))+ #' Convert an `rtable` object to a `shiny.tag` HTML object |
|||
| 204 | +22 |
- }+ #' |
||
| 205 | +23 |
-
+ #' The returned HTML object can be immediately used in `shiny` and `rmarkdown`. |
||
| 206 | -! | +|||
| 24 | +
- kids <- tree_children(obj)+ #' |
|||
| 207 | -! | +|||
| 25 | +
- els <- lapply(tree_children(obj), summarize_rows_inner,+ #' @param x (`VTableTree`)\cr a `TableTree` object. |
|||
| 208 | -! | +|||
| 26 | +
- depth = depth + 1, indent = indent+ #' @param class_table (`character`)\cr class for `table` tag. |
|||
| 209 | +27 |
- )+ #' @param class_tr (`character`)\cr class for `tr` tag. |
||
| 210 | -! | +|||
| 28 | +
- if (!are(kids, "TableRow")) {
+ #' @param class_th (`character`)\cr class for `th` tag. |
|||
| 211 | -! | +|||
| 29 | +
- if (!are(kids, "VTableTree")) {
+ #' @param width (`character`)\cr a string to indicate the desired width of the table. Common input formats include a |
|||
| 212 | +30 |
- ## hatchet job of a hack, wrap em just so we can unlist em all at+ #' percentage of the viewer window width (e.g. `"100%"`) or a distance value (e.g. `"300px"`). Defaults to `NULL`. |
||
| 213 | +31 |
- ## the same level+ #' @param link_label (`character`)\cr link anchor label (not including `tab:` prefix) for the table. |
||
| 214 | -! | +|||
| 32 | +
- rowinds <- vapply(kids, is, NA, class2 = "TableRow")+ #' @param bold (`character`)\cr elements in table output that should be bold. Options are `"main_title"`, |
|||
| 215 | -! | +|||
| 33 | +
- els[rowinds] <- lapply(els[rowinds], function(x) list(x))+ #' `"subtitles"`, `"header"`, `"row_names"`, `"label_rows"`, and `"content_rows"` (which includes any non-label |
|||
| 216 | +34 |
- }+ #' rows). Defaults to `"header"`. |
||
| 217 | -! | +|||
| 35 | +
- els <- unlist(els, recursive = FALSE)+ #' @param header_sep_line (`flag`)\cr whether a black line should be printed to under the table header. Defaults |
|||
| 218 | +36 |
- }+ #' to `TRUE`. |
||
| 219 | -! | +|||
| 37 | +
- ret <- c(ret, els)+ #' @param no_spaces_between_cells (`flag`)\cr whether spaces between table cells should be collapsed. Defaults |
|||
| 220 | -! | +|||
| 38 | +
- ret+ #' to `FALSE`. |
|||
| 221 | +39 |
- ## df <- do.call(rbind, c(list(lr), list(ct), els))+ #' @param expand_newlines (`flag`)\cr Defaults to `FALSE`, relying on `html` output to solve newline characters (`\n`). |
||
| 222 | +40 |
-
+ #' Doing this keeps the structure of the cells but may depend on the output device. |
||
| 223 | +41 |
- ## row.names(df) <- NULL+ #' |
||
| 224 | +42 |
- ## df+ #' @importFrom htmltools tags |
||
| 225 | +43 |
- }+ #' |
||
| 226 | +44 |
- )+ #' @return A `shiny.tag` object representing `x` in HTML. |
||
| 227 | +45 |
-
+ #' |
||
| 228 | +46 |
- # Print Table Structure ----+ #' @examples |
||
| 229 | +47 |
-
+ #' tbl <- rtable( |
||
| 230 | +48 |
- #' Summarize table+ #' header = LETTERS[1:3], |
||
| 231 | +49 |
- #'+ #' format = "xx", |
||
| 232 | +50 |
- #' @param x (`VTableTree`)\cr a table object.+ #' rrow("r1", 1, 2, 3),
|
||
| 233 | +51 |
- #' @param detail (`string`)\cr either `row` or `subtable`.+ #' rrow("r2", 4, 3, 2, indent = 1),
|
||
| 234 | +52 |
- #'+ #' rrow("r3", indent = 2)
|
||
| 235 | +53 |
- #' @return No return value. Called for the side-effect of printing a row- or subtable-structure summary of `x`.+ #' ) |
||
| 236 | +54 |
#' |
||
| 237 | +55 |
- #' @examplesIf require(dplyr)+ #' as_html(tbl) |
||
| 238 | +56 |
- #' library(dplyr)+ #' |
||
| 239 | +57 |
- #'+ #' as_html(tbl, class_table = "table", class_tr = "row") |
||
| 240 | +58 |
- #' iris2 <- iris %>%+ #' |
||
| 241 | +59 |
- #' group_by(Species) %>%+ #' as_html(tbl, bold = c("header", "row_names"))
|
||
| 242 | +60 |
- #' mutate(group = as.factor(rep_len(c("a", "b"), length.out = n()))) %>%
+ #' |
||
| 243 | +61 |
- #' ungroup()+ #' \dontrun{
|
||
| 244 | +62 |
- #'+ #' Viewer(tbl) |
||
| 245 | +63 |
- #' lyt <- basic_table() %>%+ #' } |
||
| 246 | +64 |
- #' split_cols_by("Species") %>%
+ #' |
||
| 247 | +65 |
- #' split_cols_by("group") %>%
+ #' @export |
||
| 248 | +66 |
- #' analyze(c("Sepal.Length", "Petal.Width"),
+ as_html <- function(x, |
||
| 249 | +67 |
- #' afun = list_wrap_x(summary),+ width = NULL, |
||
| 250 | +68 |
- #' format = "xx.xx"+ class_table = "table table-condensed table-hover", |
||
| 251 | +69 |
- #' )+ class_tr = NULL, |
||
| 252 | +70 |
- #'+ class_th = NULL, |
||
| 253 | +71 |
- #' tbl <- build_table(lyt, iris2)+ link_label = NULL, |
||
| 254 | +72 |
- #' tbl+ bold = c("header"),
|
||
| 255 | +73 |
- #'+ header_sep_line = TRUE, |
||
| 256 | +74 |
- #' row_paths(tbl)+ no_spaces_between_cells = FALSE, |
||
| 257 | +75 |
- #'+ expand_newlines = FALSE) {
|
||
| 258 | -+ | |||
| 76 | +9x |
- #' table_structure(tbl)+ if (is.null(x)) {
|
||
| 259 | -+ | |||
| 77 | +! |
- #'+ return(tags$p("Empty Table"))
|
||
| 260 | +78 |
- #' table_structure(tbl, detail = "row")+ } |
||
| 261 | +79 |
- #'+ |
||
| 262 | -+ | |||
| 80 | +9x |
- #' @export+ stopifnot(is(x, "VTableTree")) |
||
| 263 | +81 |
- table_structure <- function(x, detail = c("subtable", "row")) {
+
|
||
| 264 | -2x | +82 | +9x |
- detail <- match.arg(detail)+ mat <- matrix_form(x, indent_rownames = TRUE, expand_newlines = expand_newlines) |
| 265 | +83 | |||
| 266 | -2x | +84 | +9x |
- switch(detail,+ nlh <- mf_nlheader(mat) |
| 267 | -1x | +85 | +9x |
- subtable = treestruct(x),+ nc <- ncol(x) + 1 |
| 268 | -1x | +86 | +9x |
- row = table_structure_inner(x),+ nr <- length(mf_lgrouping(mat)) |
| 269 | -! | +|||
| 87 | +
- stop("unsupported level of detail ", detail)
+
|
|||
| 270 | +88 |
- )+ # Structure is a list of lists with rows (one for each line grouping) and cols as dimensions |
||
| 271 | -+ | |||
| 89 | +9x |
- }+ cells <- matrix(rep(list(list()), (nr * nc)), ncol = nc) |
||
| 272 | +90 | |||
| 273 | -+ | |||
| 91 | +9x |
- #' @param obj (`VTableTree`)\cr a table object.+ for (i in seq_len(nr)) {
|
||
| 274 | -+ | |||
| 92 | +173x |
- #' @param depth (`numeric(1)`)\cr depth in tree.+ for (j in seq_len(nc)) {
|
||
| 275 | -+ | |||
| 93 | +1021x |
- #' @param indent (`numeric(1)`)\cr indent.+ curstrs <- mf_strings(mat)[i, j] |
||
| 276 | -+ | |||
| 94 | +1021x |
- #' @param print_indent (`numeric(1)`)\cr indent for printing.+ curspn <- mf_spans(mat)[i, j] |
||
| 277 | -+ | |||
| 95 | +1021x |
- #'+ algn <- mf_aligns(mat)[i, j] |
||
| 278 | +96 |
- #' @rdname int_methods+ |
||
| 279 | -+ | |||
| 97 | +1021x |
- setGeneric(+ inhdr <- i <= nlh |
||
| 280 | -+ | |||
| 98 | +1021x |
- "table_structure_inner",+ tagfun <- if (inhdr) tags$th else tags$td |
||
| 281 | -+ | |||
| 99 | +1021x |
- function(obj,+ cells[i, j][[1]] <- tagfun( |
||
| 282 | -+ | |||
| 100 | +1021x |
- depth = 0,+ class = if (inhdr) class_th else class_tr, |
||
| 283 | -+ | |||
| 101 | +1021x |
- indent = 0,+ style = paste0("text-align: ", algn, ";"),
|
||
| 284 | -+ | |||
| 102 | +1021x |
- print_indent = 0) {
+ style = if (inhdr && !"header" %in% bold) "font-weight: normal;", |
||
| 285 | -70x | +103 | +1021x |
- standardGeneric("table_structure_inner")
+ style = if (i == nlh && header_sep_line) "border-bottom: 1px solid black;", |
| 286 | -+ | |||
| 104 | +1021x |
- }+ colspan = if (curspn != 1) curspn, |
||
| 287 | -+ | |||
| 105 | +1021x |
- )+ insert_brs(curstrs) |
||
| 288 | +106 |
-
+ ) |
||
| 289 | +107 |
- scat <- function(..., indent = 0, newline = TRUE) {
+ } |
||
| 290 | -101x | +|||
| 108 | +
- txt <- paste(..., collapse = "", sep = "")+ } |
|||
| 291 | +109 | |||
| 292 | -101x | +110 | +9x |
- cat(indent_string(txt, indent))+ if (header_sep_line) {
|
| 293 | -+ | |||
| 111 | +9x |
-
+ cells[nlh][[1]] <- htmltools::tagAppendAttributes( |
||
| 294 | -101x | +112 | +9x |
- if (newline) cat("\n")
+ cells[nlh, 1][[1]],+ |
+
| 113 | +9x | +
+ style = "border-bottom: 1px solid black;" |
||
| 295 | +114 |
- }+ ) |
||
| 296 | +115 |
-
+ } |
||
| 297 | +116 |
- ## helper functions+ |
||
| 298 | +117 |
- obj_visible <- function(x) {
+ # Create a map between line numbers and line groupings, adjusting abs_rownumber with nlh |
||
| 299 | -50x | +118 | +9x |
- x@visible+ map <- data.frame(lines = seq_len(nr), abs_rownumber = mat$line_grouping) |
| 300 | -+ | |||
| 119 | +9x |
- }+ row_info_df <- data.frame(indent = mat$row_info$indent, abs_rownumber = mat$row_info$abs_rownumber + nlh)+ |
+ ||
| 120 | +9x | +
+ map <- merge(map, row_info_df, by = "abs_rownumber") |
||
| 301 | +121 | |||
| 302 | +122 |
- is_empty_labelrow <- function(x) {
+ # add indent values for headerlines |
||
| 303 | -4x | +123 | +9x |
- obj_label(x) == "" && !labelrow_visible(x)+ map <- rbind(data.frame(abs_rownumber = 1:nlh, indent = 0, lines = 0), map) |
| 304 | +124 |
- }+ |
||
| 305 | +125 | |||
| 306 | +126 |
- is_empty_ElementaryTable <- function(x) {
+ # Row labels style |
||
| 307 | -10x | +127 | +9x |
- length(tree_children(x)) == 0 && is_empty_labelrow(tt_labelrow(x))+ for (i in seq_len(nr)) {
|
| 308 | -+ | |||
| 128 | +173x |
- }+ indent <- ifelse(any(map$lines == i), map$indent[map$lines == i][1], -1) |
||
| 309 | +129 | |||
| 310 | +130 |
- #' @param object (`VTableTree`)\cr a table object.+ # Apply indentation |
||
| 311 | -+ | |||
| 131 | +173x |
- #'+ if (indent > 0) {
|
||
| 312 | -+ | |||
| 132 | +127x |
- #' @rdname int_methods+ cells[i, 1][[1]] <- htmltools::tagAppendAttributes( |
||
| 313 | -+ | |||
| 133 | +127x |
- #' @export+ cells[i, 1][[1]], |
||
| 314 | -+ | |||
| 134 | +127x |
- setGeneric("str", function(object, ...) {
+ style = paste0("padding-left: ", indent * 3, "ch;")
|
||
| 315 | -! | +|||
| 135 | +
- standardGeneric("str")
+ ) |
|||
| 316 | +136 |
- })+ } |
||
| 317 | +137 | |||
| 318 | +138 |
- #' @param max.level (`numeric(1)`)\cr passed to `utils::str`. Defaults to 3 for the `VTableTree` method, unlike+ # Apply bold font weight if "row_names" is in 'bold' |
||
| 319 | -+ | |||
| 139 | +173x |
- #' the underlying default of `NA`. `NA` is *not* appropriate for `VTableTree` objects.+ if ("row_names" %in% bold) {
|
||
| 320 | -+ | |||
| 140 | +4x |
- #'+ cells[i, 1][[1]] <- htmltools::tagAppendAttributes(+ |
+ ||
| 141 | +4x | +
+ cells[i, 1][[1]],+ |
+ ||
| 142 | +4x | +
+ style = "font-weight: bold;" |
||
| 321 | +143 |
- #' @rdname int_methods+ ) |
||
| 322 | +144 |
- #' @export+ } |
||
| 323 | +145 |
- setMethod(+ } |
||
| 324 | +146 |
- "str", "VTableTree",+ |
||
| 325 | +147 |
- function(object, max.level = 3L, ...) {
+ # label rows style |
||
| 326 | -! | +|||
| 148 | +9x |
- utils::str(object, max.level = max.level, ...)+ if ("label_rows" %in% bold) {
|
||
| 327 | +149 | ! |
- warning("str provides a low level, implementation-detail-specific description of the TableTree object structure. ",
+ which_lbl_rows <- which(mat$row_info$node_class == "LabelRow") |
|
| 328 | +150 | ! |
- "See table_structure(.) for a summary of table struture intended for end users.",+ cells[which_lbl_rows + nlh, ] <- lapply( |
|
| 329 | +151 | ! |
- call. = FALSE+ cells[which_lbl_rows + nlh, ], |
|
| 330 | -+ | |||
| 152 | +! |
- )+ htmltools::tagAppendAttributes, |
||
| 331 | +153 | ! |
- invisible(NULL)+ style = "font-weight: bold;" |
|
| 332 | +154 |
- }+ ) |
||
| 333 | +155 |
- )+ } |
||
| 334 | +156 | |||
| 335 | +157 |
- #' @inheritParams table_structure_inner+ # content rows style |
||
| 336 | -+ | |||
| 158 | +9x |
- #' @rdname int_methods+ if ("content_rows" %in% bold) {
+ |
+ ||
| 159 | +! | +
+ which_cntnt_rows <- which(mat$row_info$node_class %in% c("ContentRow", "DataRow"))
+ |
+ ||
| 160 | +! | +
+ cells[which_cntnt_rows + nlh, ] <- lapply(+ |
+ ||
| 161 | +! | +
+ cells[which_cntnt_rows + nlh, ],+ |
+ ||
| 162 | +! | +
+ htmltools::tagAppendAttributes,+ |
+ ||
| 163 | +! | +
+ style = "font-weight: bold;" |
||
| 337 | +164 |
- setMethod(+ ) |
||
| 338 | +165 |
- "table_structure_inner", "TableTree",+ } |
||
| 339 | +166 |
- function(obj, depth = 0, indent = 0, print_indent = 0) {
+
|
||
| 340 | -10x | +167 | +9x |
- indent <- indent + indent_mod(obj)+ if (any(!mat$display)) {
|
| 341 | +168 |
-
+ # Check that expansion kept the same display info |
||
| 342 | -10x | +169 | +2x |
- scat("TableTree: ", "[", obj_name(obj), "] (",
+ check_expansion <- c() |
| 343 | -10x | +170 | +2x |
- obj_label(obj), ")",+ for (ii in unique(mat$line_grouping)) {
|
| 344 | -10x | +171 | +121x |
- indent = print_indent+ rows <- which(mat$line_grouping == ii)+ |
+
| 172 | +121x | +
+ check_expansion <- c(+ |
+ ||
| 173 | +121x | +
+ check_expansion,+ |
+ ||
| 174 | +121x | +
+ apply(mat$display[rows, , drop = FALSE], 2, function(x) all(x) || all(!x)) |
||
| 345 | +175 |
- )+ ) |
||
| 346 | +176 | ++ |
+ }+ |
+ |
| 177 | ||||
| 347 | -10x | +178 | +2x |
- table_structure_inner(+ if (!all(check_expansion)) {
|
| 348 | -10x | +|||
| 179 | +! |
- tt_labelrow(obj), depth, indent,+ stop( |
||
| 349 | -10x | +|||
| 180 | +! | +
+ "Found that a group of rows have different display options even if ",+ |
+ ||
| 181 | +! | +
+ "they belong to the same line group. This should not happen. Please ",+ |
+ ||
| 182 | +! | +
+ "file an issue or report to the maintainers."+ |
+ ||
| 183 | +! |
- print_indent + 1+ ) # nocov |
||
| 350 | +184 |
- )+ } |
||
| 351 | +185 | |||
| 352 | -10x | +186 | +2x |
- ctab <- content_table(obj)+ for (ii in unique(mat$line_grouping)) {
|
| 353 | -10x | +187 | +121x |
- visible_content <- if (is_empty_ElementaryTable(ctab)) {
+ rows <- which(mat$line_grouping == ii)+ |
+
| 188 | +121x | +
+ should_display_col <- apply(mat$display[rows, , drop = FALSE], 2, any)+ |
+ ||
| 189 | +121x | +
+ cells[ii, !should_display_col] <- NA_integer_ |
||
| 354 | +190 |
- # scat("content: -", indent = print_indent + 1)
+ } |
||
| 355 | -4x | +|||
| 191 | +
- FALSE+ } |
|||
| 356 | +192 |
- } else {
+
|
||
| 357 | -6x | +193 | +9x |
- scat("content:", indent = print_indent + 1)
+ rows <- apply(cells, 1, function(row) {
|
| 358 | -6x | +194 | +173x |
- table_structure_inner(ctab,+ tags$tr( |
| 359 | -6x | +195 | +173x |
- depth = depth,+ class = class_tr, |
| 360 | -6x | +196 | +173x |
- indent = indent + indent_mod(ctab),+ style = "white-space: pre;", |
| 361 | -6x | +197 | +173x |
- print_indent = print_indent + 2+ Filter(function(x) !identical(x, NA_integer_), row) |
| 362 | +198 |
- )+ ) |
||
| 363 | +199 |
- }+ }) |
||
| 364 | +200 | |||
| 365 | -10x | +201 | +9x |
- if (length(tree_children(obj)) == 0) {
+ hsep_line <- tags$hr(class = "solid") |
| 366 | -! | +|||
| 202 | +
- scat("children: - ", indent = print_indent + 1)
+
|
|||
| 367 | -+ | |||
| 203 | +9x |
- } else {
+ hdrtag <- div_helper( |
||
| 368 | -10x | +204 | +9x |
- scat("children: ", indent = print_indent + 1)
+ class = "rtables-titles-block", |
| 369 | -10x | +205 | +9x |
- lapply(tree_children(obj), table_structure_inner,+ list( |
| 370 | -10x | +206 | +9x |
- depth = depth + 1,+ div_helper( |
| 371 | -10x | +207 | +9x |
- indent = indent + visible_content * (1 + indent_mod(ctab)),+ class = "rtables-main-titles-block", |
| 372 | -10x | +208 | +9x |
- print_indent = print_indent + 2+ lapply(main_title(x), if ("main_title" %in% bold) tags$b else tags$p,
|
| 373 | -+ | |||
| 209 | +9x |
- )+ class = "rtables-main-title" |
||
| 374 | +210 |
- }+ ) |
||
| 375 | +211 |
-
+ ), |
||
| 376 | -10x | +212 | +9x |
- invisible(NULL)+ div_helper( |
| 377 | -+ | |||
| 213 | +9x |
- }+ class = "rtables-subtitles-block", |
||
| 378 | -+ | |||
| 214 | +9x |
- )+ lapply(subtitles(x), if ("subtitles" %in% bold) tags$b else tags$p,
+ |
+ ||
| 215 | +9x | +
+ class = "rtables-subtitle" |
||
| 379 | +216 |
-
+ ) |
||
| 380 | +217 |
- #' @rdname int_methods+ ) |
||
| 381 | +218 |
- setMethod(+ ) |
||
| 382 | +219 |
- "table_structure_inner", "ElementaryTable",+ ) |
||
| 383 | +220 |
- function(obj, depth = 0, indent = 0, print_indent = 0) {
+
|
||
| 384 | -15x | +221 | +9x |
- scat("ElementaryTable: ", "[", obj_name(obj),
+ tabletag <- do.call( |
| 385 | -15x | +222 | +9x |
- "] (", obj_label(obj), ")",
+ tags$table, |
| 386 | -15x | +223 | +9x |
- indent = print_indent+ c( |
| 387 | -+ | |||
| 224 | +9x |
- )+ rows, |
||
| 388 | -+ | |||
| 225 | +9x |
-
+ list( |
||
| 389 | -15x | +226 | +9x |
- indent <- indent + indent_mod(obj)+ class = class_table,+ |
+
| 227 | +9x | +
+ style = paste(+ |
+ ||
| 228 | +9x | +
+ if (no_spaces_between_cells) "border-collapse: collapse;",+ |
+ ||
| 229 | +9x | +
+ if (!is.null(width)) paste("width:", width)
|
||
| 390 | +230 |
-
+ ), |
||
| 391 | -15x | +231 | +9x |
- table_structure_inner(+ tags$caption(sprintf("(\\#tag:%s)", link_label),
|
| 392 | -15x | +232 | +9x |
- tt_labelrow(obj), depth,+ style = "caption-side: top;", |
| 393 | -15x | +233 | +9x |
- indent, print_indent + 1+ .noWS = "after-begin" |
| 394 | +234 |
- )+ ) |
||
| 395 | +235 |
-
+ ) |
||
| 396 | -15x | +|||
| 236 | +
- if (length(tree_children(obj)) == 0) {
+ ) |
|||
| 397 | -! | +|||
| 237 | +
- scat("children: - ", indent = print_indent + 1)
+ ) |
|||
| 398 | +238 |
- } else {
+
|
||
| 399 | -15x | +239 | +9x |
- scat("children: ", indent = print_indent + 1)
+ rfnotes <- div_helper( |
| 400 | -15x | +240 | +9x |
- lapply(tree_children(obj), table_structure_inner,+ class = "rtables-ref-footnotes-block", |
| 401 | -15x | +241 | +9x |
- depth = depth + 1, indent = indent,+ lapply(mat$ref_footnotes, tags$p, |
| 402 | -15x | +242 | +9x |
- print_indent = print_indent + 2+ class = "rtables-referential-footnote" |
| 403 | +243 |
- )+ ) |
||
| 404 | +244 |
- }+ ) |
||
| 405 | +245 | |||
| 406 | -15x | +246 | +9x |
- invisible(NULL)+ mftr <- div_helper( |
| 407 | -+ | |||
| 247 | +9x |
- }+ class = "rtables-main-footers-block", |
||
| 408 | -+ | |||
| 248 | +9x |
- )+ lapply(main_footer(x), tags$p, |
||
| 409 | -+ | |||
| 249 | +9x |
-
+ class = "rtables-main-footer" |
||
| 410 | +250 |
- #' @rdname int_methods+ ) |
||
| 411 | +251 |
- setMethod(+ ) |
||
| 412 | +252 |
- "table_structure_inner", "TableRow",+ |
||
| 413 | -+ | |||
| 253 | +9x |
- function(obj, depth = 0, indent = 0, print_indent = 0) {
+ pftr <- div_helper( |
||
| 414 | -20x | +254 | +9x |
- scat(class(obj), ": ", "[", obj_name(obj), "] (",
+ class = "rtables-prov-footers-block", |
| 415 | -20x | +255 | +9x |
- obj_label(obj), ")",+ lapply(prov_footer(x), tags$p, |
| 416 | -20x | +256 | +9x |
- indent = print_indent+ class = "rtables-prov-footer" |
| 417 | +257 |
) |
||
| 418 | +258 | ++ |
+ )+ |
+ |
| 259 | ||||
| 419 | -20x | +|||
| 260 | +
- indent <- indent + indent_mod(obj)+ ## XXX this omits the divs entirely if they are empty. Do we want that or do |
|||
| 420 | +261 |
-
+ ## we want them to be there but empty?? |
||
| 421 | -20x | +262 | +9x |
- invisible(NULL)+ ftrlst <- list( |
| 422 | -+ | |||
| 263 | +9x |
- }+ if (length(mat$ref_footnotes) > 0) rfnotes, |
||
| 423 | -+ | |||
| 264 | +9x |
- )+ if (length(mat$ref_footnotes) > 0) hsep_line, |
||
| 424 | -+ | |||
| 265 | +9x |
-
+ if (length(main_footer(x)) > 0) mftr, |
||
| 425 | -+ | |||
| 266 | +9x |
- #' @rdname int_methods+ if (length(main_footer(x)) > 0 && length(prov_footer(x)) > 0) tags$br(), # line break |
||
| 426 | -+ | |||
| 267 | +9x |
- setMethod(+ if (length(prov_footer(x)) > 0) pftr |
||
| 427 | +268 |
- "table_structure_inner", "LabelRow",+ ) |
||
| 428 | +269 |
- function(obj, depth = 0, indent = 0, print_indent = 0) {
+
+ |
+ ||
| 270 | +! | +
+ if (!is.null(unlist(ftrlst))) ftrlst <- c(list(hsep_line), ftrlst) |
||
| 429 | -25x | +271 | +9x |
- indent <- indent + indent_mod(obj)+ ftrlst <- ftrlst[!vapply(ftrlst, is.null, TRUE)] |
| 430 | +272 | |||
| 431 | -25x | +273 | +9x |
- txtvis <- if (!obj_visible(obj)) " - <not visible>" else ""+ ftrtag <- div_helper(+ |
+
| 274 | +9x | +
+ class = "rtables-footers-block",+ |
+ ||
| 275 | +9x | +
+ ftrlst |
||
| 432 | +276 | ++ |
+ )+ |
+ |
| 277 | ||||
| 433 | -25x | +278 | +9x |
- scat("labelrow: ", "[", obj_name(obj), "] (", obj_label(obj), ")",
+ div_helper( |
| 434 | -25x | +279 | +9x |
- txtvis,+ class = "rtables-all-parts-block", |
| 435 | -25x | +280 | +9x |
- indent = print_indent+ list( |
| 436 | -+ | |||
| 281 | +9x |
- )+ hdrtag, |
||
| 437 | -+ | |||
| 282 | +9x |
-
+ tabletag, |
||
| 438 | -25x | +283 | +9x |
- obj_visible(obj)+ ftrtag |
| 439 | +284 |
- }+ ) |
||
| 440 | +285 |
- )+ )+ |
+ ||
| 286 | ++ |
+ } |
| 1 |
- #' Score functions for sorting `TableTrees`+ #' Compare two rtables |
||
| 3 |
- #' @inheritParams gen_args+ #' Prints a matrix where `.` means cell matches, `X` means cell does |
||
| 4 |
- #'+ #' not match, `+` cell (row) is missing, and `-` cell (row) |
||
| 5 |
- #' @return A single numeric value indicating score according to the relevant metric for `tt`, to be used when sorting.+ #' should not be there. If `structure` is set to `TRUE`, `C` indicates |
||
| 6 |
- #'+ #' column-structure mismatch, `R` indicates row-structure mismatch, and |
||
| 7 |
- #' @export+ #' `S` indicates mismatch in both row and column structure. |
||
| 8 |
- #' @rdname score_funs+ #' |
||
| 9 |
- cont_n_allcols <- function(tt) {
+ #' @param object (`VTableTree`)\cr `rtable` to test. |
||
| 10 | -6x | +
- ctab <- content_table(tt)+ #' @param expected (`VTableTree`)\cr expected `rtable`. |
|
| 11 | -6x | +
- if (NROW(ctab) == 0) {
+ #' @param tol (`numeric(1)`)\cr tolerance. |
|
| 12 | -2x | +
- stop(+ #' @param comp.attr (`flag`)\cr whether to compare cell formats. Other attributes are |
|
| 13 | -2x | +
- "cont_n_allcols score function used at subtable [",+ #' silently ignored. |
|
| 14 | -2x | +
- obj_name(tt), "] that has no content table."+ #' @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 | -4x | +
- sum(sapply(+ #' |
|
| 18 | -4x | +
- row_values(tree_children(ctab)[[1]]),+ #' @note In its current form, `compare_rtables` does not take structure into |
|
| 19 | -4x | +
- function(cv) cv[1]+ #' 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 |
- #' @param j (`numeric(1)`)\cr index of column used for scoring.+ #' |
||
| 24 |
- #'+ #' @examples |
||
| 25 |
- #' @seealso For examples and details, please read the documentation for [sort_at_path()] and the+ #' t1 <- rtable(header = c("A", "B"), format = "xx", rrow("row 1", 1, 2))
|
||
| 26 |
- #' [Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html)+ #' t2 <- rtable(header = c("A", "B", "C"), format = "xx", rrow("row 1", 1, 2, 3))
|
||
| 27 |
- #' vignette.+ #' |
||
| 28 |
- #'+ #' compare_rtables(object = t1, expected = t2) |
||
| 29 |
- #' @export+ #' |
||
| 30 |
- #' @rdname score_funs+ #' if (interactive()) {
|
||
| 31 |
- cont_n_onecol <- function(j) {
+ #' Viewer(t1, t2) |
||
| 32 | -2x | +
- function(tt) {
+ #' } |
|
| 33 | -6x | +
- ctab <- content_table(tt)+ #' |
|
| 34 | -6x | +
- if (NROW(ctab) == 0) {
+ #' expected <- rtable( |
|
| 35 | -2x | +
- stop(+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
|
|
| 36 | -2x | +
- "cont_n_allcols score function used at subtable [",+ #' format = "xx", |
|
| 37 | -2x | +
- obj_name(tt), "] that has no content table."+ #' rrow("row 1", 10, 15),
|
|
| 38 |
- )+ #' rrow(), |
||
| 39 |
- }+ #' rrow("section title"),
|
||
| 40 | -4x | +
- row_values(tree_children(ctab)[[1]])[[j]][1]+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
|
|
| 41 |
- }+ #' ) |
||
| 42 |
- }+ #' |
||
| 43 |
-
+ #' expected |
||
| 44 |
- #' Sorting a table at a specific path+ #' |
||
| 45 |
- #'+ #' object <- rtable( |
||
| 46 |
- #' Main sorting function to order the sub-structure of a `TableTree` at a particular path in the table tree.+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
|
||
| 47 |
- #'+ #' format = "xx", |
||
| 48 |
- #' @inheritParams gen_args+ #' rrow("row 1", 10, 15),
|
||
| 49 |
- #' @param scorefun (`function`)\cr scoring function. Should accept the type of children directly under the position+ #' rrow("section title"),
|
||
| 50 |
- #' at `path` (either `VTableTree`, `VTableRow`, or `VTableNodeInfo`, which covers both) and return a numeric value+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
|
||
| 51 |
- #' to be sorted.+ #' ) |
||
| 52 |
- #' @param decreasing (`flag`)\cr whether the scores generated by `scorefun` should be sorted in decreasing order. If+ #' |
||
| 53 |
- #' unset (the default of `NA`), it is set to `TRUE` if the generated scores are numeric and `FALSE` if they are+ #' compare_rtables(object, expected, comp.attr = FALSE) |
||
| 54 |
- #' characters.+ #' |
||
| 55 |
- #' @param na.pos (`string`)\cr what should be done with children (sub-trees/rows) with `NA` scores. Defaults to+ #' object <- rtable( |
||
| 56 |
- #' `"omit"`, which removes them. Other allowed values are `"last"` and `"first"`, which indicate where `NA` scores+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
|
||
| 57 |
- #' should be placed in the order.+ #' format = "xx", |
||
| 58 |
- #' @param .prev_path (`character`)\cr internal detail, do not set manually.+ #' rrow("row 1", 10, 15),
|
||
| 59 |
- #'+ #' rrow(), |
||
| 60 |
- #' @return A `TableTree` with the same structure as `tt` with the exception that the requested sorting has been done+ #' rrow("section title")
|
||
| 61 |
- #' at `path`.+ #' ) |
||
| 63 |
- #' @details+ #' compare_rtables(object, expected) |
||
| 64 |
- #' `sort_at_path`, given a path, locates the (sub)table(s) described by the path (see below for handling of the `"*"`+ #' |
||
| 65 |
- #' wildcard). For each such subtable, it then calls `scorefun` on each direct child of the table, using the resulting+ #' object <- rtable( |
||
| 66 |
- #' scores to determine their sorted order. `tt` is then modified to reflect each of these one or more sorting+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
|
||
| 67 |
- #' operations.+ #' format = "xx", |
||
| 68 |
- #'+ #' rrow("row 1", 14, 15.03),
|
||
| 69 |
- #' In `path`, a leading `"root"` element will be ignored, regardless of whether this matches the object name (and thus+ #' rrow(), |
||
| 70 |
- #' actual root path name) of `tt`. Including `"root"` in paths where it does not match the name of `tt` may mask deeper+ #' rrow("section title"),
|
||
| 71 |
- #' misunderstandings of how valid paths within a `TableTree` object correspond to the layout used to originally declare+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.xx, xx.xx)"))
|
||
| 72 |
- #' it, which we encourage users to avoid.+ #' ) |
||
| 74 |
- #' `path` can include the "wildcard" `"*"` as a step, which translates roughly to *any* node/branching element and means+ #' compare_rtables(object, expected) |
||
| 75 |
- #' that each child at that step will be *separately* sorted based on `scorefun` and the remaining `path` entries. This+ #' |
||
| 76 |
- #' can occur multiple times in a path.+ #' object <- rtable( |
||
| 77 |
- #'+ #' header = c("ARM A\nN=100", "ARM B\nN=200"),
|
||
| 78 |
- #' A list of valid (non-wildcard) paths can be seen in the `path` column of the `data.frame` created by+ #' format = "xx", |
||
| 79 |
- #' [formatters::make_row_df()] with the `visible_only` argument set to `FALSE`. It can also be inferred from the+ #' rrow("row 1", 10, 15),
|
||
| 80 |
- #' summary given by [table_structure()].+ #' rrow(), |
||
| 81 |
- #'+ #' rrow("section title"),
|
||
| 82 |
- #' Note that sorting needs a deeper understanding of table structure in `rtables`. Please consider reading the related+ #' rrow("row colspan", rcell(c(.345543, .4432423), colspan = 2, format = "(xx.x, xx.x)"))
|
||
| 83 |
- #' vignette+ #' ) |
||
| 84 |
- #' ([Sorting and Pruning](https://insightsengineering.github.io/rtables/latest-tag/articles/sorting_pruning.html))+ #' |
||
| 85 |
- #' and explore table structure with useful functions like [table_structure()] and [row_paths_summary()]. It is also+ #' compare_rtables(object, expected) |
||
| 86 |
- #' very important to understand the difference between "content" rows and "data" rows. The first one analyzes and+ #' |
||
| 87 |
- #' describes the split variable generally and is generated with [summarize_row_groups()], while the second one is+ #' @export |
||
| 88 |
- #' commonly produced by calling one of the various [analyze()] instances.+ compare_rtables <- function(object, expected, tol = 0.1, comp.attr = TRUE, |
||
| 89 |
- #'+ structure = FALSE) {
|
||
| 90 |
- #' Built-in score functions are [cont_n_allcols()] and [cont_n_onecol()]. They are both working with content rows+ # if (identical(object, expected)) return(invisible(TRUE)) |
||
| 91 |
- #' (coming from [summarize_row_groups()]) while a custom score function needs to be used on `DataRow`s. Here, some+ |
||
| 92 | -+ | 12x |
- #' useful descriptor and accessor functions (coming from related vignette):+ if (!is(object, "VTableTree")) {
|
| 93 | -+ | ! |
- #' - [cell_values()] - Retrieves a named list of a `TableRow` or `TableTree` object's values.+ stop( |
| 94 | -+ | ! |
- #' - [formatters::obj_name()] - Retrieves the name of an object. Note this can differ from the label that is+ "argument object is expected to be of class TableTree or ", |
| 95 | -+ | ! |
- #' displayed (if any is) when printing.+ "ElementaryTable" |
| 96 |
- #' - [formatters::obj_label()] - Retrieves the display label of an object. Note this can differ from the name that+ ) |
||
| 97 |
- #' appears in the path.+ } |
||
| 98 | -+ | 12x |
- #' - [content_table()] - Retrieves a `TableTree` object's content table (which contains its summary rows).+ if (!is(expected, "VTableTree")) {
|
| 99 | -+ | ! |
- #' - [tree_children()] - Retrieves a `TableTree` object's direct children (either subtables, rows or possibly a mix+ stop( |
| 100 | -+ | ! |
- #' thereof, though that should not happen in practice).+ "argument expected is expected to be of class TableTree or ", |
| 101 | -+ | ! |
- #'+ "ElementaryTable" |
| 102 |
- #' @seealso+ ) |
||
| 103 |
- #' * Score functions [cont_n_allcols()] and [cont_n_onecol()].+ } |
||
| 104 | -+ | 12x |
- #' * [formatters::make_row_df()] and [table_structure()] for pathing information.+ dim_out <- apply(rbind(dim(object), dim(expected)), 2, max) |
| 105 |
- #' * [tt_at_path()] to select a table's (sub)structure at a given path.+ |
||
| 106 | -+ | 12x |
- #'+ X <- matrix(rep(".", dim_out[1] * dim_out[2]), ncol = dim_out[2])
|
| 107 | -+ | 12x |
- #' @examples+ row.names(X) <- as.character(1:dim_out[1]) |
| 108 | -+ | 12x |
- #' # Creating a table to sort+ colnames(X) <- as.character(1:dim_out[2]) |
| 109 |
- #'+ |
||
| 110 | -+ | 12x |
- #' # Function that gives two statistics per table-tree "leaf"+ if (!identical(names(object), names(expected))) {
|
| 111 | -+ | 7x |
- #' more_analysis_fnc <- function(x) {
+ attr(X, "info") <- "column names are not the same" |
| 112 |
- #' in_rows(+ } |
||
| 113 |
- #' "median" = median(x),+ |
||
| 114 | -+ | 12x |
- #' "mean" = mean(x),+ if (!comp.attr) {
|
| 115 | -+ | ! |
- #' .formats = "xx.x"+ attr(X, "info") <- c( |
| 116 | -+ | ! |
- #' )+ attr(X, "info"), |
| 117 | -+ | ! |
- #' }+ "cell attributes have not been compared" |
| 118 |
- #'+ ) |
||
| 119 |
- #' # Main layout of the table+ } |
||
| 120 | -+ | 12x |
- #' raw_lyt <- basic_table() %>%+ if (!identical(row.names(object), row.names(expected))) {
|
| 121 | -+ | 2x |
- #' split_cols_by("ARM") %>%
+ attr(X, "info") <- c(attr(X, "info"), "row labels are not the same") |
| 122 |
- #' split_rows_by(+ } |
||
| 123 |
- #' "RACE",+ |
||
| 124 | -+ | 12x |
- #' split_fun = drop_and_remove_levels("WHITE") # dropping WHITE levels
+ nro <- nrow(object) |
| 125 | -+ | 12x |
- #' ) %>%+ nre <- nrow(expected) |
| 126 | -+ | 12x |
- #' summarize_row_groups() %>%+ nco <- ncol(object) |
| 127 | -+ | 12x |
- #' split_rows_by("STRATA1") %>%
+ nce <- ncol(expected) |
| 128 |
- #' summarize_row_groups() %>%+ |
||
| 129 | -+ | 12x |
- #' analyze("AGE", afun = more_analysis_fnc)
+ if (nco < nce) {
|
| 130 | -+ | 2x |
- #'+ X[, seq(nco + 1, nce)] <- "-" |
| 131 | -+ | 10x |
- #' # Creating the table and pruning empty and NAs+ } else if (nce < nco) {
|
| 132 | -+ | 3x |
- #' tbl <- build_table(raw_lyt, DM) %>%+ X[, seq(nce + 1, nco)] <- "+" |
| 133 |
- #' prune_table()+ } |
||
| 134 | -+ | 12x |
- #'+ if (nro < nre) {
|
| 135 | -+ | 1x |
- #' # Peek at the table structure to understand how it is built+ X[seq(nro + 1, nre), ] <- "-" |
| 136 | -+ | 11x |
- #' table_structure(tbl)+ } else if (nre < nro) {
|
| 137 | -+ | ! |
- #'+ X[seq(nre + 1, nro), ] <- "+" |
| 138 |
- #' # Sorting only ASIAN sub-table, or, in other words, sorting STRATA elements for+ } |
||
| 139 |
- #' # the ASIAN group/row-split. This uses content_table() accessor function as it+ |
||
| 140 | -+ | 12x |
- #' # is a "ContentRow". In this case, we also base our sorting only on the second column.+ orig_object <- object # nolint |
| 141 | -+ | 12x |
- #' sort_at_path(tbl, c("ASIAN", "STRATA1"), cont_n_onecol(2))
+ orig_expected <- expected # nolint |
| 142 | -+ | 12x |
- #'+ if (nro != nre || nco != nce) {
|
| 143 | -+ | 5x |
- #' # Custom scoring function that is working on "DataRow"s+ object <- object[1:min(nro, nre), 1:min(nco, nce), drop = FALSE] |
| 144 | -+ | 5x |
- #' scorefun <- function(tt) {
+ expected <- expected[1:min(nro, nre), 1:min(nco, nce), drop = FALSE] |
| 145 | -+ | 5x |
- #' # Here we could use browser()+ inner <- compare_rtables(object, expected, tol = tol, comp.attr = comp.attr, structure = structure) |
| 146 | -+ | 5x |
- #' sum(unlist(row_values(tt))) # Different accessor function+ X[seq_len(nrow(object)), seq_len(ncol(object))] <- inner |
| 147 | -+ | 5x |
- #' }+ class(X) <- c("rtables_diff", class(X))
|
| 148 | -+ | 5x |
- #' # Sorting mean and median for all the AGE leaves!+ return(X) |
| 149 |
- #' sort_at_path(tbl, c("RACE", "*", "STRATA1", "*", "AGE"), scorefun)
+ } |
||
| 150 |
- #'+ |
||
| 151 |
- #' @export+ ## from here dimensions match! |
||
| 152 |
- sort_at_path <- function(tt,+ |
||
| 153 | -+ | 7x |
- path,+ orows <- cell_values(object, omit_labrows = FALSE) |
| 154 | -+ | 7x |
- scorefun,+ erows <- cell_values(expected, omit_labrows = FALSE) |
| 155 | -+ | 7x |
- decreasing = NA,+ if (nrow(object) == 1) {
|
| 156 | -+ | ! |
- na.pos = c("omit", "last", "first"),
+ orows <- list(orows) |
| 157 | -+ | ! |
- .prev_path = character()) {
+ erows <- list(erows) |
| 158 | -35x | +
- if (NROW(tt) == 0) {
+ } |
|
| 159 | -1x | +7x |
- return(tt)+ res <- mapply(compare_rrows, |
| 160 | -+ | 7x |
- }+ row1 = orows, row2 = erows, tol = tol, ncol = ncol(object), |
| 161 | -+ | 7x |
-
+ USE.NAMES = FALSE, SIMPLIFY = FALSE |
| 162 |
- ## XXX hacky fix this!!!+ ) |
||
| 163 | -+ | 7x |
- ## tt_at_path removes root even if actual root table isn't named root, we need to match that behavior+ X <- do.call(rbind, res) |
| 164 | -34x | +7x |
- if (path[1] == "root") {
+ rpo <- row_paths(object) |
| 165 | -+ | 7x |
- ## always remove first root element but only add it to+ rpe <- row_paths(expected) |
| 166 |
- ## .prev_path (used for error reporting) if it actually matched the name+ |
||
| 167 | -1x | +7x |
- if (obj_name(tt) == "root") {
+ if (comp.attr) {
|
| 168 | -1x | +7x |
- .prev_path <- c(.prev_path, path[1])+ ofmts <- value_formats(object) |
| 169 | -+ | 7x |
- }+ efmts <- value_formats(expected) |
| 170 | -1x | +
- path <- path[-1]+ ## dim(ofmts) <- NULL |
|
| 171 |
- }+ ## dim(efmts) <- NULL |
||
| 172 | -34x | +
- if (identical(obj_name(tt), path[1])) {
+
|
|
| 173 | -1x | +7x |
- .prev_path <- c(.prev_path, path[1])+ fmt_mismatch <- which(!mapply(identical, x = ofmts, y = efmts)) ## inherently ignores dim |
| 174 | -1x | +
- path <- path[-1]+ |
|
| 175 |
- }+ |
||
| 176 |
-
+ ## note the single index here!!!, no comma!!!! |
||
| 177 | -34x | +7x |
- curpath <- path+ X[fmt_mismatch] <- "X" |
| 178 | -34x | +
- subtree <- tt+ } |
|
| 179 | -34x | +
- backpath <- c()+ |
|
| 180 | -34x | +
- count <- 0+ |
|
| 181 | -34x | +7x |
- while (length(curpath) > 0) {
+ if (structure) {
|
| 182 | -40x | +1x |
- curname <- curpath[1]+ rp_mismatches <- !mapply(identical, x = rpo, y = rpe) |
| 183 | -40x | +1x |
- oldkids <- tree_children(subtree)+ cpo <- col_paths(object) |
| 184 | -+ | 1x |
- ## we sort each child separately based on the score function+ cpe <- col_paths(expected) |
| 185 | -+ | 1x |
- ## and the remaining path+ cp_mismatches <- !mapply(identical, x = cpo, y = cpe) |
| 186 | -40x | +
- if (curname == "*") {
+
|
|
| 187 | -7x | +1x |
- oldnames <- vapply(oldkids, obj_name, "")+ if (any(rp_mismatches)) { # P for (row or column) path do not match
|
| 188 | -7x | +! |
- newkids <- lapply(+ X[rp_mismatches, ] <- "R" |
| 189 | -7x | +
- seq_along(oldkids),+ } |
|
| 190 | -7x | +1x |
- function(i) {
+ if (any(cp_mismatches)) {
|
| 191 | -27x | +1x |
- sort_at_path(oldkids[[i]],+ crep <- rep("C", nrow(X))
|
| 192 | -27x | +1x |
- path = curpath[-1],+ if (any(rp_mismatches)) {
|
| 193 | -27x | +! |
- scorefun = scorefun,+ crep[rp_mismatches] <- "P" |
| 194 | -27x | +
- decreasing = decreasing,+ } |
|
| 195 | -27x | +1x |
- na.pos = na.pos,+ X[, cp_mismatches] <- rep(crep, sum(cp_mismatches)) |
| 196 |
- ## its ok to modify the "path" here because its only ever used for+ } |
||
| 197 |
- ## informative error reporting.+ } |
||
| 198 | -27x | +7x |
- .prev_path = c(.prev_path, backpath, paste0("* (", oldnames[i], ")"))
+ class(X) <- c("rtables_diff", class(X))
|
| 199 | -+ | 7x |
- )+ X |
| 200 |
- }+ } |
||
| 201 |
- )+ |
||
| 202 | -4x | +
- names(newkids) <- oldnames+ ## for (i in 1:dim(X)[1]) {
|
|
| 203 | -4x | +
- newtab <- subtree+ ## for (j in 1:dim(X)[2]) {
|
|
| 204 | -4x | +
- tree_children(newtab) <- newkids+ |
|
| 205 | -4x | +
- if (length(backpath) > 0) {
+ ## is_equivalent <- TRUE |
|
| 206 | -3x | +
- ret <- recursive_replace(tt, backpath, value = newtab)+ ## if (i <= nro && i <= nre && j <= nco && j <= nce) {
|
|
| 207 |
- } else {
+ ## x <- object[i,j, drop = TRUE] |
||
| 208 | -1x | +
- ret <- newtab+ ## y <- expected[i,j, drop = TRUE] |
|
| 209 |
- }+ |
||
| 210 | -4x | +
- return(ret)+ ## attr_x <- attributes(x) |
|
| 211 | -33x | +
- } else if (!(curname %in% names(oldkids))) {
+ ## attr_y <- attributes(y) |
|
| 212 | -1x | +
- stop(+ |
|
| 213 | -1x | +
- "Unable to find child(ren) '",+ ## attr_x_sorted <- if (is.null(attr_x)) NULL else attr_x[order(names(attr_x))] |
|
| 214 | -1x | +
- curname, "'\n\t occurred at path: ",+ ## attr_y_sorted <- if (is.null(attr_y)) NULL else attr_y[order(names(attr_y))] |
|
| 215 | -1x | +
- paste(c(.prev_path, path[seq_len(count)]), collapse = " -> "),+ |
|
| 216 | -1x | +
- "\n Use 'make_row_df(obj, visible_only = TRUE)[, c(\"label\", \"path\", \"node_class\")]' or \n",+ ## if (comp.attr && !identical(attr_x_sorted, attr_y_sorted)) {
|
|
| 217 | -1x | +
- "'table_structure(obj)' to explore valid paths."+ ## is_equivalent <- FALSE |
|
| 218 |
- )+ ## } else if (is.numeric(x) && is.numeric(y)) {
|
||
| 219 |
- }+ ## if (any(abs(na.omit(x - y)) > tol)) {
|
||
| 220 | -32x | +
- subtree <- tree_children(subtree)[[curname]]+ ## is_equivalent <- FALSE |
|
| 221 | -32x | +
- backpath <- c(backpath, curpath[1])+ ## } |
|
| 222 | -32x | +
- curpath <- curpath[-1]+ ## } else {
|
|
| 223 | -32x | +
- count <- count + 1+ ## if (!identical(x, y)) {
|
|
| 224 |
- }+ ## is_equivalent <- FALSE |
||
| 225 | -26x | +
- real_backpath <- path[seq_len(count)]+ ## } |
|
| 226 |
-
+ ## } |
||
| 227 | -26x | +
- na.pos <- match.arg(na.pos)+ |
|
| 228 |
- ## subtree <- tt_at_path(tt, path)+ ## if (!is_equivalent) {
|
||
| 229 | -26x | +
- kids <- tree_children(subtree)+ ## X[i,j] <- "X" |
|
| 230 |
- ## relax this to allow character "scores"+ ## } |
||
| 231 |
- ## scores <- vapply(kids, scorefun, NA_real_)+ ## } else if (i > nro || j > nco) {
|
||
| 232 | -26x | +
- scores <- lapply(kids, function(x) tryCatch(scorefun(x), error = function(e) e))+ ## ## missing in object |
|
| 233 | -26x | +
- errs <- which(vapply(scores, is, class2 = "error", TRUE))+ ## X[i, j] <- "+" |
|
| 234 | -26x | +
- if (length(errs) > 0) {
+ ## } else {
|
|
| 235 | -2x | +
- stop("Encountered at least ", length(errs), " error(s) when applying score function.\n",
+ ## ## too many elements |
|
| 236 | -2x | +
- "First error: ", scores[[errs[1]]]$message,+ ## X[i, j] <- "-" |
|
| 237 | -2x | +
- "\n\toccurred at path: ",+ ## } |
|
| 238 | -2x | +
- paste(c(.prev_path, real_backpath, names(kids)[errs[1]]), collapse = " -> "),+ ## } |
|
| 239 | -2x | +
- call. = FALSE+ ## } |
|
| 240 |
- )+ ## class(X) <- c("rtable_diff", class(X))
|
||
| 241 |
- } else {
+ ## X |
||
| 242 | -24x | +
- scores <- unlist(scores)+ ## } |
|
| 243 |
- }+ |
||
| 244 | -24x | +
- if (!is.null(dim(scores)) || length(scores) != length(kids)) {
+ compare_value <- function(x, y, tol) {
|
|
| 245 | -! | +359x |
- stop(+ if (identical(x, y) || (is.numeric(x) && is.numeric(y) && max(abs(x - y)) <= tol)) {
|
| 246 | -! | +
- "Score function does not appear to have return exactly one ",+ "." |
|
| 247 | -! | +
- "scalar value per child"+ } else {
|
|
| 248 | -+ | 72x |
- )+ "X" |
| 250 | -24x | +
- if (is.na(decreasing)) {
+ } |
|
| 251 | -8x | +
- decreasing <- if (is.character(scores)) FALSE else TRUE+ |
|
| 252 |
- }+ compare_rrows <- function(row1, row2, tol, ncol) {
|
||
| 253 | -24x | +173x |
- ord <- order(scores, na.last = (na.pos != "first"), decreasing = decreasing)+ if (length(row1) == ncol && length(row2) == ncol) {
|
| 254 | -24x | +115x |
- newkids <- kids[ord]+ mapply(compare_value, x = row1, y = row2, tol = tol, USE.NAMES = FALSE) |
| 255 | -24x | +58x |
- if (anyNA(scores) && na.pos == "omit") { # we did na last here
+ } else if (length(row1) == 0 && length(row2) == 0) {
|
| 256 | -! | +44x |
- newkids <- head(newkids, -1 * sum(is.na(scores)))+ rep(".", ncol)
|
| 257 |
- }+ } else {
|
||
| 258 | -+ | 14x |
-
+ rep("X", ncol)
|
| 259 | -24x | +
- newtree <- subtree+ } |
|
| 260 | -24x | +
- tree_children(newtree) <- newkids+ } |
|
| 261 | -24x | +
- tt_at_path(tt, path) <- newtree+ |
|
| 262 | -24x | +
- tt+ ## #' @export |
|
| 263 |
- }+ ## print.rtable_diff <- function(x, ...) {
+ |
+ ||
| 264 | ++ |
+ ## print.default(unclass(x), quote = FALSE, ...)+ |
+ |
| 265 | ++ |
+ ## } |
| 1 |
- #' Trimming and pruning criteria+ #' Change indentation of all `rrows` in an `rtable` |
||
| 3 |
- #' Criteria functions (and constructors thereof) for trimming and pruning tables.+ #' Change indentation of all `rrows` in an `rtable` |
||
| 5 |
- #' @inheritParams gen_args+ #' @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 |
- #' @return A logical value indicating whether `tr` should be included (`TRUE`) or pruned (`FALSE`) during pruning.+ #' less than 0, the indentation is set to 0. |
||
| 9 |
- #' @seealso [prune_table()], [trim_rows()]+ #' @return `x` with its indent modifier incremented by `by`. |
||
| 11 |
- #' @details `all_zero_or_na` returns `TRUE` (and thus indicates trimming/pruning) for any *non-`LabelRow`*+ #' @examples |
||
| 12 |
- #' `TableRow` which contain only any mix of `NA` (including `NaN`), `0`, `Inf` and `-Inf` values.+ #' is_setosa <- iris$Species == "setosa" |
||
| 13 |
- #'+ #' m_tbl <- rtable( |
||
| 14 |
- #' @examples+ #' header = rheader( |
||
| 15 |
- #' adsl <- ex_adsl+ #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
|
||
| 16 |
- #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")+ #' rrow(NULL, "mean", "median", "mean", "median") |
||
| 17 |
- #' adsl$AGE[adsl$SEX == "UNDIFFERENTIATED"] <- 0+ #' ), |
||
| 18 |
- #' adsl$BMRKR1 <- 0+ #' rrow( |
||
| 19 |
- #'+ #' row.name = "All Species", |
||
| 20 |
- #' tbl_to_prune <- basic_table() %>%+ #' mean(iris$Sepal.Length), median(iris$Sepal.Length), |
||
| 21 |
- #' analyze("BMRKR1") %>%
+ #' mean(iris$Petal.Length), median(iris$Petal.Length), |
||
| 22 |
- #' split_cols_by("ARM") %>%
+ #' format = "xx.xx" |
||
| 23 |
- #' split_rows_by("SEX") %>%
+ #' ), |
||
| 24 |
- #' summarize_row_groups() %>%+ #' rrow( |
||
| 25 |
- #' split_rows_by("STRATA1") %>%
+ #' row.name = "Setosa", |
||
| 26 |
- #' summarize_row_groups() %>%+ #' mean(iris$Sepal.Length[is_setosa]), median(iris$Sepal.Length[is_setosa]), |
||
| 27 |
- #' analyze("AGE") %>%
+ #' mean(iris$Petal.Length[is_setosa]), median(iris$Petal.Length[is_setosa]), |
||
| 28 |
- #' build_table(adsl)+ #' format = "xx.xx" |
||
| 29 |
- #'+ #' ) |
||
| 30 |
- #' tbl_to_prune %>% prune_table(all_zero_or_na)+ #' ) |
||
| 31 |
- #'+ #' indent(m_tbl) |
||
| 32 |
- #' @rdname trim_prune_funs+ #' indent(m_tbl, 2) |
||
| 33 |
- #' @export+ #' |
||
| 34 |
- all_zero_or_na <- function(tr) {
+ #' @export |
||
| 35 | -347x | +
- if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
+ indent <- function(x, by = 1) {
|
|
| 36 | -93x | +9x |
- return(FALSE)+ if (nrow(x) == 0 || by == 0) {
|
| 37 | -+ | 9x |
- }+ return(x) |
| 38 | -254x | +
- rvs <- unlist(unname(row_values(tr)))+ } |
|
| 39 | -254x | +
- all(is.na(rvs) | rvs == 0 | !is.finite(rvs))+ |
|
| 40 | -+ | ! |
- }+ indent_mod(x) <- indent_mod(x) + by |
| 41 | -+ | ! |
-
+ x |
| 42 |
- #' @details `all_zero` returns `TRUE` for any non-`LabelRow` which contains only (non-missing) zero values.+ } |
||
| 43 |
- #'+ |
||
| 44 |
- #' @examples+ #' Clear all indent modifiers from a table |
||
| 45 |
- #' tbl_to_prune %>% prune_table(all_zero)+ #' |
||
| 46 |
- #'+ #' @inheritParams gen_args |
||
| 47 |
- #' @rdname trim_prune_funs+ #' |
||
| 48 |
- #' @export+ #' @return The same class as `tt`, with all indent modifiers set to zero. |
||
| 49 |
- all_zero <- function(tr) {
+ #' |
||
| 50 | -8x | +
- if (!is(tr, "TableRow") || is(tr, "LabelRow")) {
+ #' @examples |
|
| 51 | -! | +
- return(FALSE)+ #' lyt1 <- basic_table() %>% |
|
| 52 |
- }+ #' summarize_row_groups("STUDYID", label_fstr = "overall summary") %>%
|
||
| 53 | -8x | +
- rvs <- unlist(unname(row_values(tr)))+ #' split_rows_by("AEBODSYS", child_labels = "visible") %>%
|
|
| 54 | -8x | +
- isTRUE(all(rvs == 0))+ #' summarize_row_groups("STUDYID", label_fstr = "subgroup summary") %>%
|
|
| 55 |
- }+ #' analyze("AGE", indent_mod = -1L)
|
||
| 56 |
-
+ #' |
||
| 57 |
- #' Trim rows from a populated table without regard for table structure+ #' tbl1 <- build_table(lyt1, ex_adae) |
||
| 58 |
- #'+ #' tbl1 |
||
| 59 |
- #' @inheritParams gen_args+ #' clear_indent_mods(tbl1) |
||
| 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()].+ #' @export |
||
| 62 |
- #'+ #' @rdname clear_imods |
||
| 63 | -+ | 40x |
- #' @return The table with rows that have only `NA` or 0 cell values removed.+ setGeneric("clear_indent_mods", function(tt) standardGeneric("clear_indent_mods"))
|
| 64 |
- #'+ |
||
| 65 |
- #' @note+ #' @export |
||
| 66 |
- #' Visible `LabelRow`s are including in this trimming, which can lead to either all label rows being trimmed or+ #' @rdname clear_imods |
||
| 67 |
- #' label rows remaining when all data rows have been trimmed, depending on what `criteria` returns when called on+ setMethod( |
||
| 68 |
- #' a `LabelRow` object. To avoid this, use the structurally-aware [prune_table()] machinery instead.+ "clear_indent_mods", "VTableTree", |
||
| 69 |
- #'+ function(tt) {
|
||
| 70 | -+ | 25x |
- #' @details+ ct <- content_table(tt) |
| 71 | -+ | 25x |
- #' This function will be deprecated in the future in favor of the more elegant and versatile [prune_table()]+ if (!is.null(ct)) {
|
| 72 | -+ | 9x |
- #' function which can perform the same function as `trim_rows()` but is more powerful as it takes table structure+ content_table(tt) <- clear_indent_mods(ct) |
| 73 |
- #' into account.+ } |
||
| 74 | -+ | 25x |
- #'+ tree_children(tt) <- lapply(tree_children(tt), clear_indent_mods) |
| 75 | -+ | 25x |
- #' @seealso [prune_table()]+ indent_mod(tt) <- 0L |
| 76 | -+ | 25x |
- #'+ tt |
| 77 |
- #' @examples+ } |
||
| 78 |
- #' adsl <- ex_adsl+ ) |
||
| 79 |
- #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")+ |
||
| 80 |
- #'+ #' @export |
||
| 81 |
- #' tbl_to_trim <- basic_table() %>%+ #' @rdname clear_imods |
||
| 82 |
- #' analyze("BMRKR1") %>%
+ setMethod( |
||
| 83 |
- #' split_cols_by("ARM") %>%
+ "clear_indent_mods", "TableRow", |
||
| 84 |
- #' split_rows_by("SEX") %>%
+ function(tt) {
|
||
| 85 | -+ | 15x |
- #' summarize_row_groups() %>%+ indent_mod(tt) <- 0L |
| 86 | -+ | 15x |
- #' split_rows_by("STRATA1") %>%
+ tt |
| 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 | +1 |
-
+ #' Create an `ElementaryTable` from a `data.frame` |
||
| 110 | +2 |
- #' @inheritParams trim_rows+ #' |
||
| 111 | +3 |
- #'+ #' @param df (`data.frame`)\cr a data frame. |
||
| 112 | +4 |
- #' @details+ #' |
||
| 113 | +5 |
- #' `content_all_zeros_nas` prunes a subtable if both of the following are true:+ #' @details |
||
| 114 | +6 |
- #'+ #' If row names are not defined in `df` (or they are simple numbers), then the row names are taken from the column |
||
| 115 | +7 |
- #' * It has a content table with exactly one row in it.+ #' `label_name`, if it exists. If `label_name` exists, then it is also removed from the original data. This behavior |
||
| 116 | +8 |
- #' * `all_zero_or_na` returns `TRUE` for that single content row. In practice, when the default summary/content+ #' is compatible with [as_result_df()], when `as_is = TRUE` and the row names are not unique. |
||
| 117 | +9 |
- #' function is used, this represents pruning any subtable which corresponds to an empty set of the input data+ #' |
||
| 118 | +10 |
- #' (e.g. because a factor variable was used in [split_rows_by()] but not all levels were present in the data).+ #' @seealso [as_result_df()] for the inverse operation. |
||
| 119 | +11 |
#' |
||
| 120 | +12 |
#' @examples |
||
| 121 | +13 |
- #' tbl_to_prune %>% prune_table(content_all_zeros_nas)+ #' df_to_tt(mtcars) |
||
| 122 | +14 |
#' |
||
| 123 | +15 |
- #' @rdname trim_prune_funs+ #' @export |
||
| 124 | +16 |
- #' @export+ df_to_tt <- function(df) {
|
||
| 125 | -+ | |||
| 17 | +4x |
- content_all_zeros_nas <- function(tt, criteria = all_zero_or_na) {
+ colnms <- colnames(df) |
||
| 126 | -+ | |||
| 18 | +4x |
- ## this will be NULL if+ cinfo <- manual_cols(colnms) |
||
| 127 | -+ | |||
| 19 | +4x |
- ## tt is something that doesn't have a content table+ rnames <- rownames(df) |
||
| 128 | -254x | +20 | +4x |
- ct <- content_table(tt)+ havern <- !is.null(rnames) |
| 129 | +21 |
- ## NROW returns 0 for NULL.+ |
||
| 130 | -254x | +22 | +4x |
- if (NROW(ct) == 0 || nrow(ct) > 1) {
+ if ((!havern || all(grepl("[0-9]+", rnames))) && "label_name" %in% colnms) {
|
| 131 | -242x | +23 | +2x |
- return(FALSE)+ rnames <- df$label_name |
| 132 | -+ | |||
| 24 | +2x |
- }+ df <- df[, -match("label_name", colnms)]
|
||
| 133 | -+ | |||
| 25 | +2x |
-
+ colnms <- colnames(df) |
||
| 134 | -12x | +26 | +2x |
- cr <- tree_children(ct)[[1]]+ cinfo <- manual_cols(colnms) |
| 135 | -12x | +27 | +2x |
- criteria(cr)+ havern <- TRUE |
| 136 | +28 |
- }+ } |
||
| 137 | +29 | |||
| 138 | -+ | |||
| 30 | +4x |
- #' @details+ kids <- lapply(seq_len(nrow(df)), function(i) {
|
||
| 139 | -+ | |||
| 31 | +124x |
- #' `prune_empty_level` combines `all_zero_or_na` behavior for `TableRow` objects, `content_all_zeros_nas` on+ rni <- if (havern) rnames[i] else "" |
||
| 140 | -+ | |||
| 32 | +124x |
- #' `content_table(tt)` for `TableTree` objects, and an additional check that returns `TRUE` if the `tt` has no+ do.call(rrow, c(list(row.name = rni), unclass(df[i, ]))) |
||
| 141 | +33 |
- #' children.+ }) |
||
| 142 | +34 |
- #'+ |
||
| 143 | -+ | |||
| 35 | +4x |
- #' @examples+ ElementaryTable(kids = kids, cinfo = cinfo) |
||
| 144 | +36 |
- #' tbl_to_prune %>% prune_table(prune_empty_level)+ } |
| 145 | +1 |
- #'+ #' @importFrom utils browseURL |
||
| 146 | +2 |
- #' @rdname trim_prune_funs+ NULL |
||
| 147 | +3 |
- #' @export+ |
||
| 148 | +4 |
- prune_empty_level <- function(tt) {
- |
- ||
| 149 | -389x | -
- if (is(tt, "TableRow")) {
- |
- ||
| 150 | -151x | -
- return(all_zero_or_na(tt))+ #' Display an `rtable` object in the Viewer pane in RStudio or in a browser |
||
| 151 | +5 |
- }+ #' |
||
| 152 | +6 | - - | -||
| 153 | -238x | -
- if (content_all_zeros_nas(tt)) {
- |
- ||
| 154 | -2x | -
- return(TRUE)+ #' The table will be displayed using bootstrap styling. |
||
| 155 | +7 |
- }- |
- ||
| 156 | -236x | -
- kids <- tree_children(tt)+ #' |
||
| 157 | -236x | +|||
| 8 | +
- length(kids) == 0+ #' @param x (`rtable` or `shiny.tag`)\cr an object of class `rtable` or `shiny.tag` (defined in `htmltools` package). |
|||
| 158 | +9 |
- }+ #' @param y (`rtable` or `shiny.tag`)\cr optional second argument of same type as `x`. |
||
| 159 | +10 |
-
+ #' @param ... arguments passed to [as_html()]. |
||
| 160 | +11 |
- #' @details `prune_zeros_only` behaves as `prune_empty_level` does, except that like `all_zero` it prunes+ #' |
||
| 161 | +12 |
- #' only in the case of all non-missing zero values.+ #' @return Not meaningful. Called for the side effect of opening a browser or viewer pane. |
||
| 162 | +13 |
#' |
||
| 163 | +14 |
#' @examples |
||
| 164 | +15 |
- #' tbl_to_prune %>% prune_table(prune_zeros_only)+ #' if (interactive()) {
|
||
| 165 | +16 |
- #'+ #' sl5 <- factor(iris$Sepal.Length > 5, |
||
| 166 | +17 |
- #' @rdname trim_prune_funs+ #' levels = c(TRUE, FALSE), |
||
| 167 | +18 |
- #' @export+ #' labels = c("S.L > 5", "S.L <= 5")
|
||
| 168 | +19 |
- prune_zeros_only <- function(tt) {
- |
- ||
| 169 | -16x | -
- if (is(tt, "TableRow")) {
- |
- ||
| 170 | -8x | -
- return(all_zero(tt))+ #' ) |
||
| 171 | +20 |
- }+ #' |
||
| 172 | +21 | - - | -||
| 173 | -8x | -
- if (content_all_zeros_nas(tt, criteria = all_zero)) {
- |
- ||
| 174 | -! | -
- return(TRUE)+ #' df <- cbind(iris, sl5 = sl5) |
||
| 175 | +22 |
- }- |
- ||
| 176 | -8x | -
- kids <- tree_children(tt)- |
- ||
| 177 | -8x | -
- length(kids) == 0+ #' |
||
| 178 | +23 |
- }+ #' lyt <- basic_table() %>% |
||
| 179 | +24 |
-
+ #' split_cols_by("sl5") %>%
|
||
| 180 | +25 |
- #' @param min (`numeric(1)`)\cr (used by `low_obs_pruner` only). Minimum aggregate count value.+ #' analyze("Sepal.Length")
|
||
| 181 | +26 |
- #' Subtables whose combined/average count are below this threshold will be pruned.+ #' |
||
| 182 | +27 |
- #' @param type (`string`)\cr how count values should be aggregated. Must be `"sum"` (the default) or `"mean"`.+ #' tbl <- build_table(lyt, df) |
||
| 183 | +28 |
#' |
||
| 184 | +29 |
- #' @details+ #' Viewer(tbl) |
||
| 185 | +30 |
- #' `low_obs_pruner` is a *constructor function* which, when called, returns a pruning criteria function which+ #' Viewer(tbl, tbl) |
||
| 186 | +31 |
- #' will prune on content rows by comparing sum or mean (dictated by `type`) of the count portions of the cell+ #' |
||
| 187 | +32 |
- #' values (defined as the first value per cell regardless of how many values per cell there are) against `min`.+ #' |
||
| 188 | +33 |
- #'+ #' tbl2 <- htmltools::tags$div( |
||
| 189 | +34 |
- #' @examples+ #' class = "table-responsive", |
||
| 190 | +35 |
- #' min_prune <- low_obs_pruner(70, "sum")+ #' as_html(tbl, class_table = "table") |
||
| 191 | +36 |
- #' tbl_to_prune %>% prune_table(min_prune)+ #' ) |
||
| 192 | +37 |
#' |
||
| 193 | +38 |
- #' @rdname trim_prune_funs+ #' Viewer(tbl, tbl2) |
||
| 194 | +39 |
- #' @export+ #' } |
||
| 195 | +40 |
- low_obs_pruner <- function(min, type = c("sum", "mean")) {
+ #' @export |
||
| 196 | -3x | +|||
| 41 | +
- type <- match.arg(type)+ Viewer <- function(x, y = NULL, ...) {
|
|||
| 197 | +42 | 3x |
- function(tt) {
+ check_convert <- function(x, name, accept_NULL = FALSE) {
|
|
| 198 | -21x | +43 | +6x |
- if (is(tt, "TableRow") || NROW(ctab <- content_table(tt)) != 1) { ## note the <- in there!!!
+ if (accept_NULL && is.null(x)) {
|
| 199 | -9x | +44 | +3x |
- return(FALSE) ## only trimming on count content rows+ NULL |
| 200 | -+ | |||
| 45 | +3x |
- }+ } else if (is(x, "shiny.tag")) {
|
||
| 201 | -12x | +|||
| 46 | +! |
- ctr <- tree_children(ctab)[[1]]+ x |
||
| 202 | -12x | +47 | +3x |
- vals <- sapply(row_values(ctr), function(v) v[[1]])+ } else if (is(x, "VTableTree")) {
|
| 203 | -12x | +48 | +3x |
- sumvals <- sum(vals)+ as_html(x, ...) |
| 204 | -12x | +|||
| 49 | +
- if (type == "mean") {
+ } else {
|
|||
| 205 | -8x | +|||
| 50 | +! |
- sumvals <- sumvals / length(vals)+ stop("object of class rtable or shiny tag excepted for ", name)
|
||
| 206 | +51 |
} |
||
| 207 | -12x | -
- sumvals < min- |
- ||
| 208 | +52 |
} |
||
| 209 | +53 |
- }+ |
||
| 210 | -+ | |||
| 54 | +3x |
-
+ x_tag <- check_convert(x, "x", FALSE) |
||
| 211 | -+ | |||
| 55 | +3x |
- #' Recursively prune a `TableTree`+ y_tag <- check_convert(y, "y", TRUE) |
||
| 212 | +56 |
- #'+ |
||
| 213 | -+ | |||
| 57 | +3x |
- #' @inheritParams gen_args+ html_output <- if (is.null(y)) {
|
||
| 214 | -+ | |||
| 58 | +3x |
- #' @param prune_func (`function`)\cr a function to be called on each subtree which returns `TRUE` if the+ x_tag |
||
| 215 | +59 |
- #' entire subtree should be removed.+ } else {
|
||
| 216 | -+ | |||
| 60 | +! |
- #' @param stop_depth (`numeric(1)`)\cr the depth after which subtrees should not be checked for pruning.+ tags$div(class = "container-fluid", htmltools::tags$div( |
||
| 217 | -+ | |||
| 61 | +! |
- #' Defaults to `NA` which indicates pruning should happen at all levels.+ class = "row", |
||
| 218 | -+ | |||
| 62 | +! |
- #' @param depth (`numeric(1)`)\cr used internally, not intended to be set by the end user.+ tags$div(class = "col-xs-6", x_tag), |
||
| 219 | -+ | |||
| 63 | +! |
- #'+ tags$div(class = "col-xs-6", y_tag) |
||
| 220 | +64 |
- #' @return A `TableTree` pruned via recursive application of `prune_func`.+ )) |
||
| 221 | +65 |
- #'+ } |
||
| 222 | +66 |
- #' @seealso [prune_empty_level()] for details on this and several other basic pruning functions included+ |
||
| 223 | -+ | |||
| 67 | +3x |
- #' in the `rtables` package.+ sandbox_folder <- file.path(tempdir(), "rtable") |
||
| 224 | +68 |
- #'+ |
||
| 225 | -+ | |||
| 69 | +3x |
- #' @examples+ if (!dir.exists(sandbox_folder)) {
|
||
| 226 | -+ | |||
| 70 | +1x |
- #' adsl <- ex_adsl+ dir.create(sandbox_folder, recursive = TRUE) |
||
| 227 | -+ | |||
| 71 | +1x |
- #' levels(adsl$SEX) <- c(levels(ex_adsl$SEX), "OTHER")+ pbs <- file.path(path.package(package = "rtables"), "bootstrap/") |
||
| 228 | -+ | |||
| 72 | +1x |
- #'+ file.copy(list.files(pbs, full.names = TRUE, recursive = FALSE), sandbox_folder, recursive = TRUE) |
||
| 229 | +73 |
- #' tbl_to_prune <- basic_table() %>%+ # list.files(sandbox_folder) |
||
| 230 | +74 |
- #' split_cols_by("ARM") %>%
+ } |
||
| 231 | +75 |
- #' split_rows_by("SEX") %>%
+
|
||
| 232 | +76 |
- #' summarize_row_groups() %>%+ # get html name |
||
| 233 | -+ | |||
| 77 | +3x |
- #' split_rows_by("STRATA1") %>%
+ n_try <- 10000 |
||
| 234 | -+ | |||
| 78 | +3x |
- #' summarize_row_groups() %>%+ for (i in seq_len(n_try)) {
|
||
| 235 | -+ | |||
| 79 | +6x |
- #' analyze("AGE") %>%
+ htmlFile <- file.path(sandbox_folder, paste0("table", i, ".html"))
|
||
| 236 | +80 |
- #' build_table(adsl)+ |
||
| 237 | -+ | |||
| 81 | +6x |
- #'+ if (!file.exists(htmlFile)) {
|
||
| 238 | -+ | |||
| 82 | +3x |
- #' tbl_to_prune %>% prune_table()+ break |
||
| 239 | -+ | |||
| 83 | +3x |
- #'+ } else if (i == n_try) {
|
||
| 240 | -+ | |||
| 84 | +! |
- #' @export+ stop("too many html rtables created, restart your session")
|
||
| 241 | +85 |
- prune_table <- function(tt,+ } |
||
| 242 | +86 |
- prune_func = prune_empty_level,+ } |
||
| 243 | +87 |
- stop_depth = NA_real_,+ |
||
| 244 | -+ | |||
| 88 | +3x |
- depth = 0) {
+ html_bs <- tags$html( |
||
| 245 | -323x | +89 | +3x |
- if (!is.na(stop_depth) && depth > stop_depth) {
+ lang = "en", |
| 246 | -! | +|||
| 90 | +3x |
- return(tt)+ tags$head( |
||
| 247 | -+ | |||
| 91 | +3x |
- }+ tags$meta(charset = "utf-8"), |
||
| 248 | -323x | +92 | +3x |
- if (is(tt, "TableRow")) {
+ tags$meta("http-equiv" = "X-UA-Compatible", content = "IE=edge"),
|
| 249 | -54x | +93 | +3x |
- if (prune_func(tt)) {
+ tags$meta( |
| 250 | -! | +|||
| 94 | +3x |
- tt <- NULL+ name = "viewport",+ |
+ ||
| 95 | +3x | +
+ content = "width=device-width, initial-scale=1" |
||
| 251 | +96 |
- }+ ), |
||
| 252 | -54x | +97 | +3x |
- return(tt)+ tags$title("rtable"),
|
| 253 | -+ | |||
| 98 | +3x |
- }+ tags$link( |
||
| 254 | -+ | |||
| 99 | +3x |
-
+ href = "css/bootstrap.min.css", |
||
| 255 | -269x | +100 | +3x |
- kids <- tree_children(tt)+ rel = "stylesheet" |
| 256 | +101 |
-
+ ) |
||
| 257 | -269x | +|||
| 102 | +
- torm <- vapply(kids, function(tb) {
+ ), |
|||
| 258 | -386x | +103 | +3x |
- !is.null(tb) && prune_func(tb)+ tags$body( |
| 259 | -269x | +104 | +3x |
- }, NA)+ html_output |
| 260 | +105 |
-
+ ) |
||
| 261 | -269x | +|||
| 106 | +
- keepkids <- kids[!torm]+ ) |
|||
| 262 | -269x | +|||
| 107 | +
- keepkids <- lapply(keepkids, prune_table,+ |
|||
| 263 | -269x | +108 | +3x |
- prune_func = prune_func,+ cat( |
| 264 | -269x | +109 | +3x |
- stop_depth = stop_depth,+ paste("<!DOCTYPE html>\n", htmltools::doRenderTags(html_bs)),
|
| 265 | -269x | +110 | +3x |
- depth = depth + 1+ file = htmlFile, append = FALSE |
| 266 | +111 |
) |
||
| 267 | +112 | |||
| 268 | -269x | +113 | +3x |
- keepkids <- keepkids[!vapply(keepkids, is.null, NA)]+ viewer <- getOption("viewer")
+ |
+
| 114 | ++ | + | ||
| 269 | -269x | +115 | +3x |
- if (length(keepkids) > 0) {
+ if (!is.null(viewer)) {
|
| 270 | -135x | +116 | +3x |
- tree_children(tt) <- keepkids+ viewer(htmlFile) |
| 271 | +117 |
} else {
|
||
| 272 | -134x | +|||
| 118 | +! |
- tt <- NULL+ browseURL(htmlFile) |
||
| 273 | +119 |
} |
||
| 274 | -269x | -
- tt- |
- ||
| 275 | +120 |
}@@ -145549,14 +146268,14 @@ rtables coverage - 90.21% |
| 1 |
- #' Default tabulation+ #' Variable associated with a split |
||
| 3 |
- #' This function is used when [analyze()] is invoked.+ #' 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 |
- #' @param x (`vector`)\cr the *already split* data being tabulated for a particular cell/set of cells.+ #' via the [split_rows_by()], [split_cols_by()], [split_rows_by_cuts()], [split_cols_by_cuts()], |
||
| 6 |
- #' @param ... additional parameters to pass on.+ #' [split_rows_by_cutfun()], and [split_cols_by_cutfun()] layout directives. |
||
| 8 |
- #' @details This function has the following behavior given particular types of inputs:+ #' @param spl (`VarLevelSplit`)\cr the split object. |
||
| 9 |
- #' \describe{
+ #' |
||
| 10 |
- #' \item{numeric}{calls [mean()] on `x`.}
+ #' @return For splits with a single variable associated with them, returns the split. Otherwise, an error is raised. |
||
| 11 |
- #' \item{logical}{calls [sum()] on `x`.}
+ #' |
||
| 12 |
- #' \item{factor}{calls [length()] on `x`.}
+ #' @export |
||
| 13 |
- #' }+ #' @seealso \code{\link{make_split_fun}}
|
||
| 14 | -+ | 2x |
- #'+ setGeneric("spl_variable", function(spl) standardGeneric("spl_variable"))
|
| 15 |
- #' The [in_rows()] function is called on the resulting value(s). All other classes of input currently lead to an error.+ |
||
| 16 |
- #'+ #' @rdname spl_variable |
||
| 17 |
- #' @inherit in_rows return+ #' @export |
||
| 18 | -+ | 1x |
- #'+ setMethod("spl_variable", "VarLevelSplit", function(spl) spl_payload(spl))
|
| 19 |
- #' @author Gabriel Becker and Adrian Waddell+ |
||
| 20 |
- #'+ #' @rdname spl_variable |
||
| 21 |
- #' @examples+ #' @export |
||
| 22 | -+ | ! |
- #' simple_analysis(1:3)+ setMethod("spl_variable", "VarDynCutSplit", function(spl) spl_payload(spl))
|
| 23 |
- #' simple_analysis(iris$Species)+ |
||
| 24 |
- #' simple_analysis(iris$Species == "setosa")+ #' @rdname spl_variable |
||
| 25 |
- #'+ #' @export |
||
| 26 | -+ | ! |
- #' @rdname rtinner+ setMethod("spl_variable", "VarStaticCutSplit", function(spl) spl_payload(spl))
|
| 27 |
- #' @export+ |
||
| 28 | -1304x | +
- setGeneric("simple_analysis", function(x, ...) standardGeneric("simple_analysis"))
+ #' @rdname spl_variable |
|
| 29 |
-
+ #' @export |
||
| 30 |
- #' @rdname rtinner+ setMethod( |
||
| 31 |
- #' @exportMethod simple_analysis+ "spl_variable", "Split", |
||
| 32 | -+ | 1x |
- setMethod(+ function(spl) stop("Split class ", class(spl), " not associated with a single variable.")
|
| 33 |
- "simple_analysis", "numeric",+ ) |
||
| 34 | -966x | +
- function(x, ...) in_rows("Mean" = rcell(mean(x, ...), format = "xx.xx"))
+
|
|
| 35 |
- )+ in_col_split <- function(spl_ctx) {
|
||
| 36 | -+ | ! |
-
+ identical( |
| 37 | -+ | ! |
- #' @rdname rtinner+ names(spl_ctx), |
| 38 | -+ | ! |
- #' @exportMethod simple_analysis+ names(context_df_row(cinfo = NULL)) |
| 39 |
- setMethod(+ ) |
||
| 40 |
- "simple_analysis", "logical",+ } |
||
| 41 | -4x | +
- function(x, ...) in_rows("Count" = rcell(sum(x, ...), format = "xx"))
+
|
|
| 42 |
- )+ assert_splres_element <- function(pinfo, nm, len = NULL, component = NULL) {
|
||
| 43 | -+ | 45x |
-
+ msg_2_append <- "" |
| 44 | -+ | 45x |
- #' @rdname rtinner+ if (!is.null(component)) {
|
| 45 | -+ | 33x |
- #' @exportMethod simple_analysis+ msg_2_append <- paste0( |
| 46 | -+ | 33x |
- setMethod(+ "Invalid split function constructed by upstream call to ", |
| 47 | -+ | 33x |
- "simple_analysis", "factor",+ "make_split_fun. Problem source: ", |
| 48 | -334x | +33x |
- function(x, ...) in_rows(.list = as.list(table(x)))+ component, " argument." |
| 49 |
- )+ ) |
||
| 50 |
-
+ } |
||
| 51 | -+ | 45x |
- #' @rdname rtinner+ if (!(nm %in% names(pinfo))) {
|
| 52 | -+ | ! |
- #' @exportMethod simple_analysis+ stop( |
| 53 | -+ | ! |
- setMethod(+ "Split result does not have required element: ", nm, ".", |
| 54 | -+ | ! |
- "simple_analysis", "ANY",+ msg_2_append |
| 55 |
- function(x, ...) {
+ ) |
||
| 56 | -! | +
- stop("No default simple_analysis behavior for class ", class(x), " please specify FUN explicitly.")
+ } |
|
| 57 | -+ | 45x |
- }+ if (!is.null(len) && length(pinfo[[nm]]) != len) {
|
| 58 | -+ | ! |
- )+ stop( |
| 59 | -+ | ! |
-
+ "Split result element ", nm, " does not have required length ", len, ".", |
| 60 | -+ | ! |
- #' Check if an object is a valid `rtable`+ msg_2_append |
| 61 |
- #'+ ) |
||
| 62 |
- #' @param x (`ANY`)\cr an object.+ } |
||
| 63 | -+ | 45x |
- #'+ TRUE |
| 64 |
- #' @return `TRUE` if `x` is a formal `TableTree` object, `FALSE` otherwise.+ } |
||
| 65 |
- #'+ |
||
| 66 |
- #' @examples+ validate_split_result <- function(pinfo, component = NULL) {
|
||
| 67 | -+ | 15x |
- #' is_rtable(build_table(basic_table(), iris))+ assert_splres_element(pinfo, "datasplit", component = component) |
| 68 | -+ | 15x |
- #'+ len <- length(pinfo$datasplit) |
| 69 | -+ | 15x |
- #' @export+ assert_splres_element(pinfo, "values", len, component = component) |
| 70 | -+ | 15x |
- is_rtable <- function(x) {
+ assert_splres_element(pinfo, "labels", len, component = component) |
| 71 | -47x | +15x |
- is(x, "VTableTree")+ TRUE |
| 74 |
- # nocov start+ #' Construct split result object |
||
| 75 |
- ## is each object in a collection from a class+ #' |
||
| 76 |
- are <- function(object_collection, class2) {
+ #' These functions can be used to create or add to a split result in functions which implement core splitting or |
||
| 77 |
- all(vapply(object_collection, is, logical(1), class2))+ #' post-processing within a custom split function. |
||
| 78 |
- }+ #' |
||
| 79 |
-
+ #' @param values (`character` or `list(SplitValue)`)\cr the values associated with each facet. |
||
| 80 |
- num_all_equal <- function(x, tol = .Machine$double.eps^0.5) {
+ #' @param datasplit (`list(data.frame)`)\cr the facet data for each facet generated in the split. |
||
| 81 |
- stopifnot(is.numeric(x))+ #' @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 |
- if (length(x) == 1) {
+ #' analysis functions applied within the facet. |
||
| 84 |
- return(TRUE)+ #' @param subset_exprs (`list`)\cr A list of subsetting expressions (e.g., |
||
| 85 |
- }+ #' created with `quote()`) to be used during column subsetting. |
||
| 86 |
-
+ #' |
||
| 87 |
- y <- range(x) / mean(x)+ #' @return A named list representing the facets generated by the split with elements `values`, `datasplit`, and |
||
| 88 |
- isTRUE(all.equal(y[1], y[2], tolerance = tol))+ #' `labels`, which are the same length and correspond to each other element-wise. |
||
| 89 |
- }+ #' |
||
| 90 |
-
+ #' @details |
||
| 91 |
- # copied over from utils.nest which is not open-source+ #' These functions performs various housekeeping tasks to ensure that the split result list is as the rtables |
||
| 92 |
- all_true <- function(lst, fcn, ...) {
+ #' internals expect it, most of which are not relevant to end users. |
||
| 93 |
- all(vapply(lst, fcn, logical(1), ...))+ #' |
||
| 94 |
- }+ #' @examples |
||
| 95 |
-
+ #' splres <- make_split_result( |
||
| 96 |
- is_logical_single <- function(x) {
+ #' values = c("hi", "lo"),
|
||
| 97 |
- !is.null(x) &&+ #' datasplit = list(hi = mtcars, lo = mtcars[1:10, ]), |
||
| 98 |
- is.logical(x) &&+ #' labels = c("more data", "less data"),
|
||
| 99 |
- length(x) == 1 &&+ #' subset_exprs = list(expression(TRUE), expression(seq_along(wt) <= 10)) |
||
| 100 |
- !is.na(x)+ #' ) |
||
| 101 |
- }+ #' |
||
| 102 |
-
+ #' splres2 <- add_to_split_result(splres, |
||
| 103 |
- is_logical_vector_modif <- function(x, min_length = 1) {
+ #' values = "med", |
||
| 104 |
- !is.null(x) &&+ #' datasplit = list(med = mtcars[1:20, ]), |
||
| 105 |
- is.logical(x) &&+ #' labels = "kinda some data", |
||
| 106 |
- is.atomic(x) &&+ #' subset_exprs = quote(seq_along(wt) <= 20) |
||
| 107 |
- !anyNA(x) &&+ #' ) |
||
| 108 |
- ifelse(min_length > 0, length(x) >= min_length, TRUE)+ #' |
||
| 109 |
- }+ #' @family make_custom_split |
||
| 110 |
- # nocov end+ #' @rdname make_split_result |
||
| 111 |
-
+ #' @export |
||
| 112 |
- # Shorthand for functions that take df as first parameter+ #' @family make_custom_split |
||
| 113 |
- .takes_df <- function(f) {
+ make_split_result <- function(values, datasplit, labels, extras = NULL, subset_exprs = vector("list", length(values))) {
|
||
| 114 | -1585x | +9x |
- func_takes(f, "df", is_first = TRUE)+ if (length(values) == 1 && is(datasplit, "data.frame")) {
|
| 115 | -+ | ! |
- }+ datasplit <- list(datasplit) |
| 116 |
-
+ } |
||
| 117 | -+ | 9x |
- # Checking if function takes parameters+ ret <- list(values = values, datasplit = datasplit, labels = labels, subset_exprs = subset_exprs) |
| 118 | -+ | 9x |
- func_takes <- function(func, params, is_first = FALSE) {
+ if (!is.null(extras)) {
|
| 119 | -10852x | +! |
- if (is.list(func)) {
+ ret$extras <- extras |
| 120 | -2256x | +
- return(lapply(func, func_takes, params = params, is_first = is_first))+ } |
|
| 121 | -+ | 9x |
- }+ .fixupvals(ret) |
| 122 | -8596x | +
- if (is.null(func) || !is(func, "function")) {
+ } |
|
| 123 |
- # safe-net: should this fail instead?+ |
||
| 124 | -1752x | +
- return(setNames(rep(FALSE, length(params)), params))+ #' @param splres (`list`)\cr a list representing the result of splitting. |
|
| 125 |
- }+ #' |
||
| 126 | -6844x | +
- f_params <- formals(func)+ #' @rdname make_split_result |
|
| 127 | -6844x | +
- if (!is_first) {
+ #' @export |
|
| 128 | -2265x | +
- return(setNames(params %in% names(f_params), params))+ add_to_split_result <- function(splres, values, datasplit, labels, extras = NULL, subset_exprs = NULL) {
|
|
| 129 | -+ | 4x |
- } else {
+ validate_split_result(splres) |
| 130 | -4579x | +4x |
- if (length(params) > 1L) {
+ newstuff <- make_split_result(values, datasplit, labels, extras, subset_exprs = list(subset_exprs)) |
| 131 | -1x | +4x |
- stop("is_first works only with one parameters.")
+ ret <- lapply( |
| 132 | -+ | 4x |
- }+ names(splres), |
| 133 | -4578x | +4x |
- return(!is.null(f_params) && names(f_params)[1] == params)+ function(nm) c(splres[[nm]], newstuff[[nm]]) |
| 134 |
- }+ ) |
||
| 135 | -+ | 4x |
- }+ names(ret) <- names(splres) |
| 136 | -+ | 4x |
-
+ .fixupvals(ret) |
| 137 |
- #' Translate spl_context to a path to display in error messages+ } |
||
| 138 |
- #'+ |
||
| 139 |
- #' @param ctx (`data.frame`)\cr the `spl_context` data frame where the error occurred.+ |
||
| 140 | -+ | 13x |
- #'+ .can_take_spl_context <- function(f) any(c(".spl_context", "...") %in% names(formals(f)))
|
| 141 |
- #' @return A character string containing a description of the row path corresponding to `ctx`.+ |
||
| 142 |
- #'+ #' Create a custom splitting function |
||
| 143 |
- #' @export+ #' |
||
| 144 |
- spl_context_to_disp_path <- function(ctx) {
+ #' @param pre (`list`)\cr zero or more functions which operate on the incoming data and return a new data frame that |
||
| 145 |
- ## this can happen in the first split in column space, but+ #' should split via `core_split`. They will be called on the data in the order they appear in the list. |
||
| 146 |
- ## should never happen in row space+ #' @param core_split (`function` or `NULL`)\cr if non-`NULL`, a function which accepts the same arguments that |
||
| 147 | -20x | +
- if (length(ctx$split) == 0) {
+ #' `do_base_split` does, and returns the same type of named list. Custom functions which override this behavior |
|
| 148 | -2x | +
- return("root")
+ #' cannot be used in column splits. |
|
| 149 |
- }+ #' @param post (`list`)\cr zero or more functions which should be called on the list output by splitting. |
||
| 150 | -18x | +
- if (ctx$split[1] == "root" && ctx$value[1] == "root") {
+ #' |
|
| 151 | -17x | +
- ctx <- ctx[-1, ]+ #' @details |
|
| 152 |
- }+ #' Custom split functions can be thought of as (up to) 3 different types of manipulations of the splitting process: |
||
| 153 | -18x | +
- ret <- paste(sprintf("%s[%s]", ctx[["split"]], ctx[["value"]]),
+ #' |
|
| 154 | -18x | +
- collapse = "->"+ #' 1. Pre-processing of the incoming data to be split. |
|
| 155 |
- )+ #' 2. (Row-splitting only) Customization of the core mapping of incoming data to facets. |
||
| 156 | -18x | +
- if (length(ret) == 0 || nchar(ret) == 0) {
+ #' 3. Post-processing operations on the set of facets (groups) generated by the split. |
|
| 157 | -11x | +
- ret <- "root"+ #' |
|
| 158 |
- }+ #' This function provides an interface to create custom split functions by implementing and specifying sets of |
||
| 159 | -18x | +
- ret+ #' operations in each of those classes of customization independently. |
|
| 160 |
- }+ #' |
||
| 161 |
-
+ #' Pre-processing functions (1), must accept: `df`, `spl`, `vals`, and `labels`, and can optionally accept |
||
| 162 |
- # Utility function to paste vector of values in a nice way+ #' `.spl_context`. They then manipulate `df` (the incoming data for the split) and return a modified data frame. |
||
| 163 |
- paste_vec <- function(vec) {
+ #' This modified data frame *must* contain all columns present in the incoming data frame, but can add columns if |
||
| 164 | -7x | +
- paste0('c("', paste(vec, collapse = '", "'), '")')
+ #' necessary (though we note that these new columns cannot be used in the layout as split or analysis variables, |
|
| 165 |
- }+ #' because they will not be present when validity checking is done). |
||
| 166 |
-
+ #' |
||
| 167 |
- # Utility for checking if a package is installed+ #' The preprocessing component is useful for things such as manipulating factor levels, e.g., to trim unobserved ones |
||
| 168 |
- check_required_packages <- function(pkgs) {
+ #' or to reorder levels based on observed counts, etc. |
||
| 169 | -! | +
- for (pkgi in pkgs) {
+ #' |
|
| 170 | -! | +
- if (!requireNamespace(pkgi, quietly = TRUE)) {
+ #' Core splitting functions override the fundamental |
|
| 171 | -! | +
- stop(+ #' splitting procedure, and are only necessary in rare cases. These |
|
| 172 | -! | +
- "This function requires the ", pkgi, " package. ",+ #' must accept `spl`, `df`, `vals`, `labels`, and can optionally |
|
| 173 | -! | +
- "Please install it if you wish to use it"+ #' accept `.spl_context`. They should return a split result object |
|
| 174 |
- )+ #' constructed via `make_split_result()`. |
||
| 175 |
- }+ #' |
||
| 176 |
- }+ #' In particular, if the custom split function will be used in |
||
| 177 |
- }+ #' column space, subsetting expressions (e.g., as returned by |
| 1 | +178 |
- #' @importFrom utils browseURL+ #' `quote()` or `bquote` must be provided, while they are |
||
| 2 | +179 |
- NULL+ #' optional (and largely ignored, currently) in row space. |
||
| 3 | +180 |
-
+ #' |
||
| 4 | +181 |
- #' Display an `rtable` object in the Viewer pane in RStudio or in a browser+ #' |
||
| 5 | +182 |
- #'+ #' Post-processing functions (3) must accept the result of the core split as their first argument (which can be |
||
| 6 | +183 |
- #' The table will be displayed using bootstrap styling.+ #' anything), in addition to `spl`, and `fulldf`, and can optionally accept `.spl_context`. They must each return a |
||
| 7 | +184 | ++ |
+ #' modified version of the same structure specified above for core splitting.+ |
+ |
| 185 |
#' |
|||
| 8 | +186 |
- #' @param x (`rtable` or `shiny.tag`)\cr an object of class `rtable` or `shiny.tag` (defined in `htmltools` package).+ #' In both the pre- and post-processing cases, multiple functions can be specified. When this happens, they are applied |
||
| 9 | +187 |
- #' @param y (`rtable` or `shiny.tag`)\cr optional second argument of same type as `x`.+ #' sequentially, in the order they appear in the list passed to the relevant argument (`pre` and `post`, respectively). |
||
| 10 | +188 |
- #' @param ... arguments passed to [as_html()].+ #' |
||
| 11 | +189 | ++ |
+ #' @return A custom function that can be used as a split function.+ |
+ |
| 190 |
#' |
|||
| 12 | +191 |
- #' @return Not meaningful. Called for the side effect of opening a browser or viewer pane.+ #' @seealso [custom_split_funs] for a more detailed discussion on what custom split functions do. |
||
| 13 | +192 |
#' |
||
| 14 | +193 |
#' @examples |
||
| 15 | +194 |
- #' if (interactive()) {
+ #' mysplitfun <- make_split_fun( |
||
| 16 | +195 |
- #' sl5 <- factor(iris$Sepal.Length > 5,+ #' pre = list(drop_facet_levels), |
||
| 17 | +196 |
- #' levels = c(TRUE, FALSE),+ #' post = list(add_overall_facet("ALL", "All Arms"))
|
||
| 18 | +197 |
- #' labels = c("S.L > 5", "S.L <= 5")
+ #' ) |
||
| 19 | +198 | ++ |
+ #'+ |
+ |
| 199 | ++ |
+ #' basic_table(show_colcounts = TRUE) %>%+ |
+ ||
| 200 | ++ |
+ #' split_cols_by("ARM", split_fun = mysplitfun) %>%
+ |
+ ||
| 201 | ++ |
+ #' analyze("AGE") %>%
+ |
+ ||
| 202 | ++ |
+ #' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
+ |
+ ||
| 203 | ++ |
+ #'+ |
+ ||
| 204 | ++ |
+ #' ## post (and pre) arguments can take multiple functions, here+ |
+ ||
| 205 | ++ |
+ #' ## we add an overall facet and the reorder the facets+ |
+ ||
| 206 | ++ |
+ #' reorder_facets <- function(splret, spl, fulldf, ...) {
+ |
+ ||
| 207 | ++ |
+ #' ord <- order(names(splret$values))+ |
+ ||
| 208 | ++ |
+ #' make_split_result(+ |
+ ||
| 209 | ++ |
+ #' splret$values[ord],+ |
+ ||
| 210 | ++ |
+ #' splret$datasplit[ord],+ |
+ ||
| 211 | ++ |
+ #' splret$labels[ord]+ |
+ ||
| 212 |
#' ) |
|||
| 20 | +213 | ++ |
+ #' }+ |
+ |
| 214 |
#' |
|||
| 21 | +215 |
- #' df <- cbind(iris, sl5 = sl5)+ #' mysplitfun2 <- make_split_fun( |
||
| 22 | +216 | ++ |
+ #' pre = list(drop_facet_levels),+ |
+ |
| 217 | ++ |
+ #' post = list(+ |
+ ||
| 218 | ++ |
+ #' add_overall_facet("ALL", "All Arms"),
+ |
+ ||
| 219 | ++ |
+ #' reorder_facets+ |
+ ||
| 220 | ++ |
+ #' )+ |
+ ||
| 221 | ++ |
+ #' )+ |
+ ||
| 222 | ++ |
+ #' basic_table(show_colcounts = TRUE) %>%+ |
+ ||
| 223 | ++ |
+ #' split_cols_by("ARM", split_fun = mysplitfun2) %>%
+ |
+ ||
| 224 | ++ |
+ #' analyze("AGE") %>%
+ |
+ ||
| 225 | ++ |
+ #' build_table(subset(DM, ARM %in% c("B: Placebo", "C: Combination")))
+ |
+ ||
| 226 |
#' |
|||
| 23 | +227 |
- #' lyt <- basic_table() %>%+ #' very_stupid_core <- function(spl, df, vals, labels, .spl_context) {
|
||
| 24 | +228 |
- #' split_cols_by("sl5") %>%
+ #' make_split_result(c("stupid", "silly"),
|
||
| 25 | +229 |
- #' analyze("Sepal.Length")
+ #' datasplit = list(df[1:10, ], df[11:30, ]), |
||
| 26 | +230 | ++ |
+ #' labels = c("first 10", "second 20")
+ |
+ |
| 231 | ++ |
+ #' )+ |
+ ||
| 232 | ++ |
+ #' }+ |
+ ||
| 233 |
#' |
|||
| 27 | +234 |
- #' tbl <- build_table(lyt, df)+ #' dumb_30_facet <- add_combo_facet("dumb",
|
||
| 28 | +235 | ++ |
+ #' label = "thirty patients",+ |
+ |
| 236 | ++ |
+ #' levels = c("stupid", "silly")
+ |
+ ||
| 237 | ++ |
+ #' )+ |
+ ||
| 238 | ++ |
+ #' nonsense_splfun <- make_split_fun(+ |
+ ||
| 239 | ++ |
+ #' core_split = very_stupid_core,+ |
+ ||
| 240 | ++ |
+ #' post = list(dumb_30_facet)+ |
+ ||
| 241 | ++ |
+ #' )+ |
+ ||
| 242 |
#' |
|||
| 29 | +243 |
- #' Viewer(tbl)+ #' ## recall core split overriding is not supported in column space |
||
| 30 | +244 |
- #' Viewer(tbl, tbl)+ #' ## currently, but we can see it in action in row space |
||
| 31 | +245 |
#' |
||
| 32 | +246 | ++ |
+ #' lyt_silly <- basic_table() %>%+ |
+ |
| 247 | ++ |
+ #' split_rows_by("ARM", split_fun = nonsense_splfun) %>%
+ |
+ ||
| 248 | ++ |
+ #' summarize_row_groups() %>%+ |
+ ||
| 249 | ++ |
+ #' analyze("AGE")
+ |
+ ||
| 250 | ++ |
+ #' silly_table <- build_table(lyt_silly, DM)+ |
+ ||
| 251 | ++ |
+ #' silly_table+ |
+ ||
| 252 |
#' |
|||
| 33 | +253 |
- #' tbl2 <- htmltools::tags$div(+ #' @family make_custom_split |
||
| 34 | +254 |
- #' class = "table-responsive",+ #' @export |
||
| 35 | +255 |
- #' as_html(tbl, class_table = "table")+ make_split_fun <- function(pre = list(), core_split = NULL, post = list()) {
+ |
+ ||
| 256 | +7x | +
+ function(df,+ |
+ ||
| 257 | +7x | +
+ spl,+ |
+ ||
| 258 | +7x | +
+ vals = NULL,+ |
+ ||
| 259 | +7x | +
+ labels = NULL,+ |
+ ||
| 260 | +7x | +
+ trim = FALSE,+ |
+ ||
| 261 | +7x | +
+ .spl_context) {
+ |
+ ||
| 262 | +11x | +
+ orig_columns <- names(df)+ |
+ ||
| 263 | +11x | +
+ for (pre_fn in pre) {
+ |
+ ||
| 264 | +5x | +
+ if (.can_take_spl_context(pre_fn)) {
+ |
+ ||
| 265 | +5x | +
+ df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels, .spl_context = .spl_context)+ |
+ ||
| 266 | ++ |
+ } else {
+ |
+ ||
| 267 | +! | +
+ df <- pre_fn(df = df, spl = spl, vals = vals, labels = labels)+ |
+ ||
| 268 | ++ |
+ }+ |
+ ||
| 269 | +3x | +
+ if (!is(df, "data.frame")) {
+ |
+ ||
| 270 | +! | +
+ stop( |
||
| 36 | -+ | |||
| 271 | +! |
- #' )+ "Error in custom split function, pre-split step did not return a data.frame. ", |
||
| 37 | -+ | |||
| 272 | +! |
- #'+ "See upstream call to make_split_fun for original source of error." |
||
| 38 | +273 |
- #' Viewer(tbl, tbl2)+ ) |
||
| 39 | +274 |
- #' }+ } |
||
| 40 | +275 |
- #' @export+ } |
||
| 41 | +276 |
- 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 | +277 | +9x |
- } else if (is(x, "shiny.tag")) {
+ if (!all(orig_columns %in% names(df))) {
|
| 46 | +278 | ! |
- x- |
- |
| 47 | -3x | -
- } else if (is(x, "VTableTree")) {
- |
- ||
| 48 | -3x | -
- as_html(x, ...)+ stop( |
||
| 49 | -+ | |||
| 279 | +! |
- } else {
+ "Preprocessing functions(s) in custom split function removed a column from the incoming data.", |
||
| 50 | +280 | ! |
- stop("object of class rtable or shiny tag excepted for ", name)
+ " This is not supported. See upstread make_split_fun call (pre argument) for original source of error." |
|
| 51 | +281 |
- }+ ) |
||
| 52 | +282 |
- }+ } |
||
| 53 | +283 | |||
| 54 | -3x | +284 | +9x |
- x_tag <- check_convert(x, "x", FALSE)+ if (is.null(core_split)) {
|
| 55 | -3x | +285 | +7x |
- y_tag <- check_convert(y, "y", TRUE)+ ret <- do_base_split(spl = spl, df = df, vals = vals, labels = labels) |
| 56 | +286 |
-
+ } else {
|
||
| 57 | -3x | +287 | +2x |
- html_output <- if (is.null(y)) {
+ ret <- core_split(spl = spl, df = df, vals = vals, labels = labels, .spl_context) |
| 58 | -3x | +288 | +2x |
- x_tag+ validate_split_result(ret, component = "core_split") |
| 59 | +289 |
- } else {
+ } |
||
| 60 | -! | +|||
| 290 | +
- tags$div(class = "container-fluid", htmltools::tags$div(+ |
|||
| 61 | -! | +|||
| 291 | +9x |
- class = "row",+ for (post_fn in post) {
|
||
| 62 | -! | +|||
| 292 | +8x |
- tags$div(class = "col-xs-6", x_tag),+ if (.can_take_spl_context(post_fn)) {
|
||
| 63 | -! | +|||
| 293 | +8x |
- tags$div(class = "col-xs-6", y_tag)+ ret <- post_fn(ret, spl = spl, .spl_context = .spl_context, fulldf = df) |
||
| 64 | +294 |
- ))+ } else {
|
||
| 65 | -+ | |||
| 295 | +! |
- }+ ret <- post_fn(ret, spl = spl, fulldf = df) |
||
| 66 | +296 | - - | -||
| 67 | -3x | -
- sandbox_folder <- file.path(tempdir(), "rtable")+ } |
||
| 68 | +297 |
-
+ } |
||
| 69 | -3x | +298 | +9x |
- if (!dir.exists(sandbox_folder)) {
+ validate_split_result(ret, "post") |
| 70 | -1x | +299 | +9x |
- dir.create(sandbox_folder, recursive = TRUE)+ ret |
| 71 | -1x | +|||
| 300 | +
- pbs <- file.path(path.package(package = "rtables"), "bootstrap/")+ } |
|||
| 72 | -1x | +|||
| 301 | +
- file.copy(list.files(pbs, full.names = TRUE, recursive = FALSE), sandbox_folder, recursive = TRUE)+ } |
|||
| 73 | +302 |
- # list.files(sandbox_folder)+ |
||
| 74 | +303 |
- }+ #' Add a combination facet in post-processing |
||
| 75 | +304 |
-
+ #' |
||
| 76 | +305 |
- # get html name+ #' Add a combination facet during the post-processing stage in a custom split fun. |
||
| 77 | -3x | +|||
| 306 | +
- n_try <- 10000+ #' |
|||
| 78 | -3x | +|||
| 307 | +
- for (i in seq_len(n_try)) {
+ #' @param name (`string`)\cr name for the resulting facet (for use in pathing, etc.). |
|||
| 79 | -6x | +|||
| 308 | +
- htmlFile <- file.path(sandbox_folder, paste0("table", i, ".html"))
+ #' @param label (`string`)\cr label for the resulting facet. |
|||
| 80 | +309 |
-
+ #' @param levels (`character`)\cr vector of levels to combine within the resulting facet. |
||
| 81 | -6x | +|||
| 310 | +
- if (!file.exists(htmlFile)) {
+ #' @param extra (`list`)\cr extra arguments to be passed to analysis functions applied within the resulting facet. |
|||
| 82 | -3x | +|||
| 311 | +
- break+ #' |
|||
| 83 | -3x | +|||
| 312 | +
- } else if (i == n_try) {
+ #' @details |
|||
| 84 | -! | +|||
| 313 | +
- stop("too many html rtables created, restart your session")
+ #' For `add_combo_facet`, the data associated with the resulting facet will be the data associated with the facets for |
|||
| 85 | +314 |
- }+ #' each level in `levels`, row-bound together. In particular, this means that if those levels are overlapping, data |
||
| 86 | +315 |
- }+ #' that appears in both will be duplicated. |
||
| 87 | +316 |
-
+ #' |
||
| 88 | -3x | +|||
| 317 | +
- html_bs <- tags$html(+ #' @return A function which can be used within the `post` argument in [make_split_fun()]. |
|||
| 89 | -3x | +|||
| 318 | +
- lang = "en",+ #' |
|||
| 90 | -3x | +|||
| 319 | +
- tags$head(+ #' @seealso [make_split_fun()] |
|||
| 91 | -3x | +|||
| 320 | +
- tags$meta(charset = "utf-8"),+ #' |
|||
| 92 | -3x | +|||
| 321 | +
- tags$meta("http-equiv" = "X-UA-Compatible", content = "IE=edge"),
+ #' @examples |
|||
| 93 | -3x | +|||
| 322 | +
- tags$meta(+ #' mysplfun <- make_split_fun(post = list( |
|||
| 94 | -3x | +|||
| 323 | +
- name = "viewport",+ #' add_combo_facet("A_B",
|
|||
| 95 | -3x | +|||
| 324 | +
- content = "width=device-width, initial-scale=1"+ #' label = "Arms A+B", |
|||
| 96 | +325 |
- ),+ #' levels = c("A: Drug X", "B: Placebo")
|
||
| 97 | -3x | +|||
| 326 | +
- tags$title("rtable"),
+ #' ), |
|||
| 98 | -3x | +|||
| 327 | +
- tags$link(+ #' add_overall_facet("ALL", label = "All Arms")
|
|||
| 99 | -3x | +|||
| 328 | +
- href = "css/bootstrap.min.css",+ #' )) |
|||
| 100 | -3x | +|||
| 329 | +
- rel = "stylesheet"+ #' |
|||
| 101 | +330 |
- )+ #' lyt <- basic_table(show_colcounts = TRUE) %>% |
||
| 102 | +331 |
- ),+ #' split_cols_by("ARM", split_fun = mysplfun) %>%
|
||
| 103 | -3x | +|||
| 332 | +
- tags$body(+ #' analyze("AGE")
|
|||
| 104 | -3x | +|||
| 333 | +
- html_output+ #' |
|||
| 105 | +334 |
- )+ #' tbl <- build_table(lyt, DM) |
||
| 106 | +335 |
- )+ #' |
||
| 107 | +336 |
-
+ #' @family make_custom_split |
||
| 108 | -3x | +|||
| 337 | +
- cat(+ #' @export |
|||
| 109 | -3x | +|||
| 338 | +
- paste("<!DOCTYPE html>\n", htmltools::doRenderTags(html_bs)),
+ add_combo_facet <- function(name, label = name, levels, extra = list()) {
|
|||
| 110 | +339 | 3x |
- file = htmlFile, append = FALSE+ function(ret, spl, .spl_context, fulldf) {
|
|
| 111 | -+ | |||
| 340 | +4x |
- )+ if (is(levels, "AllLevelsSentinel")) {
|
||
| 112 | -+ | |||
| 341 | +1x |
-
+ subexpr <- expression(TRUE) |
||
| 113 | -3x | +342 | +1x |
- viewer <- getOption("viewer")
+ datpart <- list(fulldf) |
| 114 | +343 |
-
+ } else {
|
||
| 115 | +344 | 3x |
- if (!is.null(viewer)) {
+ subexpr <- .combine_value_exprs(ret$values[levels]) |
|
| 116 | +345 | 3x |
- viewer(htmlFile)+ datpart <- list(do.call(rbind, ret$datasplit[levels])) |
|
| 117 | +346 |
- } else {
+ } |
||
| 118 | -! | +|||
| 347 | +
- browseURL(htmlFile)+ |
|||
| 119 | +348 |
- }+ |
||
| 120 | -+ | |||
| 349 | +4x |
- }+ val <- LevelComboSplitValue( |
| 1 | -+ | |||
| 350 | +4x |
- #' Change indentation of all `rrows` in an `rtable`+ val = name, extr = extra, combolevels = levels, label = label, |
||
| 2 | -+ | |||
| 351 | +4x |
- #'+ sub_expr = subexpr |
||
| 3 | +352 |
- #' Change indentation of all `rrows` in an `rtable`+ ) |
||
| 4 | -+ | |||
| 353 | +4x |
- #'+ add_to_split_result(ret, |
||
| 5 | -+ | |||
| 354 | +4x |
- #' @param x (`VTableTree`)\cr an `rtable` object.+ values = list(val), labels = label, |
||
| 6 | -+ | |||
| 355 | +4x |
- #' @param by (`integer`)\cr number to increase indentation of rows by. Can be negative. If final indentation is+ datasplit = datpart |
||
| 7 | +356 |
- #' less than 0, the indentation is set to 0.+ ) |
||
| 8 | +357 |
- #'+ } |
||
| 9 | +358 |
- #' @return `x` with its indent modifier incremented by `by`.+ } |
||
| 10 | +359 |
- #'+ |
||
| 11 | +360 |
- #' @examples+ .combine_value_exprs <- function(val_lst, spl) {
|
||
| 12 | -+ | |||
| 361 | +3x |
- #' is_setosa <- iris$Species == "setosa"+ exprs <- lapply(val_lst, value_expr) |
||
| 13 | -+ | |||
| 362 | +3x |
- #' m_tbl <- rtable(+ nulls <- vapply(exprs, is.null, TRUE) |
||
| 14 | -+ | |||
| 363 | +3x |
- #' header = rheader(+ if (all(nulls)) {
|
||
| 15 | -+ | |||
| 364 | +1x |
- #' rrow(row.name = NULL, rcell("Sepal.Length", colspan = 2), rcell("Petal.Length", colspan = 2)),
+ return(NULL) # default behavior all the way down the line, no need to do anything. |
||
| 16 | -+ | |||
| 365 | +2x |
- #' rrow(NULL, "mean", "median", "mean", "median")+ } else if (any(nulls)) {
|
||
| 17 | -+ | |||
| 366 | +! |
- #' ),+ exprs[nulls] <- lapply(val_lst[nulls], function(vali) make_subset_expr(spl, vali)) |
||
| 18 | +367 |
- #' rrow(+ } |
||
| 19 | -+ | |||
| 368 | +2x |
- #' row.name = "All Species",+ Reduce(.or_combine_exprs, exprs) |
||
| 20 | +369 |
- #' mean(iris$Sepal.Length), median(iris$Sepal.Length),+ } |
||
| 21 | +370 |
- #' mean(iris$Petal.Length), median(iris$Petal.Length),+ |
||
| 22 | +371 |
- #' format = "xx.xx"+ ## no NULLS coming in here, everything has been populated |
||
| 23 | +372 |
- #' ),+ ## by either custom subsetting expressions or the result of make_subset_expr(spl, val) |
||
| 24 | +373 |
- #' rrow(+ .or_combine_exprs <- function(ex1, ex2) {
|
||
| 25 | -+ | |||
| 374 | +2x |
- #' row.name = "Setosa",+ if (identical(ex1, expression(FALSE))) {
|
||
| 26 | -+ | |||
| 375 | +! |
- #' mean(iris$Sepal.Length[is_setosa]), median(iris$Sepal.Length[is_setosa]),+ return(ex2) |
||
| 27 | -+ | |||
| 376 | +2x |
- #' mean(iris$Petal.Length[is_setosa]), median(iris$Petal.Length[is_setosa]),+ } else if (identical(ex2, expression(FALSE))) {
|
||
| 28 | -+ | |||
| 377 | +! |
- #' format = "xx.xx"+ return(ex1) |
||
| 29 | -+ | |||
| 378 | +2x |
- #' )+ } else if (identical(ex1, expression(TRUE)) || identical(ex2, expression(TRUE))) {
+ |
+ ||
| 379 | +! | +
+ return(TRUE) |
||
| 30 | +380 |
- #' )+ }+ |
+ ||
| 381 | +2x | +
+ as.expression(bquote((.(a)) | .(b), list(a = ex1[[1]], b = ex2[[1]]))) |
||
| 31 | +382 |
- #' indent(m_tbl)+ } |
||
| 32 | +383 |
- #' indent(m_tbl, 2)+ |
||
| 33 | +384 |
- #'+ #' @rdname add_combo_facet |
||
| 34 | +385 |
#' @export |
||
| 35 | +386 |
- indent <- function(x, by = 1) {
+ add_overall_facet <- function(name, label, extra = list()) {
|
||
| 36 | -9x | +387 | +1x |
- if (nrow(x) == 0 || by == 0) {
+ add_combo_facet( |
| 37 | -9x | +388 | +1x |
- return(x)+ name = name, label = label, levels = select_all_levels, |
| 38 | -+ | |||
| 389 | +1x |
- }+ extra = extra |
||
| 39 | +390 | - - | -||
| 40 | -! | -
- indent_mod(x) <- indent_mod(x) + by- |
- ||
| 41 | -! | -
- x+ ) |
||
| 42 | +391 |
} |
||
| 43 | +392 | |||
| 44 | +393 |
- #' Clear all indent modifiers from a table+ #' Trim levels of another variable from each facet (post-processing split step) |
||
| 45 | +394 |
#' |
||
| 46 | +395 |
- #' @inheritParams gen_args+ #' @param innervar (`character`)\cr the variable(s) to trim (remove unobserved levels) independently within each facet. |
||
| 47 | +396 |
#' |
||
| 48 | +397 |
- #' @return The same class as `tt`, with all indent modifiers set to zero.+ #' @return A function suitable for use in the `pre` (list) argument of `make_split_fun`. |
||
| 49 | +398 |
#' |
||
| 50 | -- |
- #' @examples- |
- ||
| 51 | +399 |
- #' lyt1 <- basic_table() %>%+ #' @seealso [make_split_fun()] |
||
| 52 | +400 |
- #' summarize_row_groups("STUDYID", label_fstr = "overall summary") %>%
+ #' |
||
| 53 | +401 |
- #' split_rows_by("AEBODSYS", child_labels = "visible") %>%
+ #' @family make_custom_split |
||
| 54 | +402 |
- #' summarize_row_groups("STUDYID", label_fstr = "subgroup summary") %>%
+ #' @export |
||
| 55 | +403 |
- #' analyze("AGE", indent_mod = -1L)
+ trim_levels_in_facets <- function(innervar) {
|
||
| 56 | -+ | |||
| 404 | +1x |
- #'+ function(ret, ...) {
|
||
| 57 | -+ | |||
| 405 | +1x |
- #' tbl1 <- build_table(lyt1, ex_adae)+ for (var in innervar) {
|
||
| 58 | -+ | |||
| 406 | +1x |
- #' tbl1+ ret$datasplit <- lapply(ret$datasplit, function(df) {
|
||
| 59 | -+ | |||
| 407 | +2x |
- #' clear_indent_mods(tbl1)+ df[[var]] <- factor(df[[var]]) |
||
| 60 | -+ | |||
| 408 | +2x |
- #'+ df |
||
| 61 | +409 |
- #' @export+ }) |
||
| 62 | +410 |
- #' @rdname clear_imods+ } |
||
| 63 | -40x | +411 | +1x |
- setGeneric("clear_indent_mods", function(tt) standardGeneric("clear_indent_mods"))
+ ret |
| 64 | +412 |
-
+ } |
||
| 65 | +413 |
- #' @export+ } |
||
| 66 | +414 |
- #' @rdname clear_imods+ |
||
| 67 | +415 |
- setMethod(+ #' Pre-processing function for use in `make_split_fun` |
||
| 68 | +416 |
- "clear_indent_mods", "VTableTree",+ #' |
||
| 69 | +417 |
- function(tt) {
- |
- ||
| 70 | -25x | -
- ct <- content_table(tt)+ #' This function is intended for use as a pre-processing component in `make_split_fun`, and should not be called |
||
| 71 | -25x | +|||
| 418 | +
- if (!is.null(ct)) {
+ #' directly by end users. |
|||
| 72 | -9x | +|||
| 419 | +
- content_table(tt) <- clear_indent_mods(ct)+ #' |
|||
| 73 | +420 |
- }+ #' @param df (`data.frame`)\cr the incoming data corresponding with the parent facet. |
||
| 74 | -25x | +|||
| 421 | +
- tree_children(tt) <- lapply(tree_children(tt), clear_indent_mods)+ #' @param spl (`VarLevelSplit`)\cr the split. |
|||
| 75 | -25x | +|||
| 422 | +
- indent_mod(tt) <- 0L+ #' @param ... additional parameters passed internally. |
|||
| 76 | -25x | +|||
| 423 | +
- tt+ #' |
|||
| 77 | +424 |
- }+ #' @seealso [make_split_fun()] |
||
| 78 | +425 |
- )+ #' |
||
| 79 | +426 |
-
+ #' @family make_custom_split |
||
| 80 | +427 |
#' @export |
||
| 81 | +428 |
- #' @rdname clear_imods+ drop_facet_levels <- function(df, spl, ...) {
|
||
| 82 | -+ | |||
| 429 | +2x |
- setMethod(+ if (!is(spl, "VarLevelSplit") || is.na(spl_payload(spl))) {
|
||
| 83 | -+ | |||
| 430 | +! |
- "clear_indent_mods", "TableRow",+ stop("Unable to determine faceting variable in drop_facet_levels application.")
|
||
| 84 | +431 |
- function(tt) {
+ } |
||
| 85 | -15x | +432 | +2x |
- indent_mod(tt) <- 0L+ var <- spl_payload(spl) |
| 86 | -15x | +433 | +2x |
- tt+ df[[var]] <- factor(df[[var]]) |
| 87 | -+ | |||
| 434 | +2x |
- }+ df |
||
| 88 | +435 |
- )+ } |
||
| 37 | -100835x | +102473x |
format <- if (missing(format)) obj_format(x) else format |
|
| 38 | -100835x | +102473x |
if (is.null(format) && !is.null(pr_row_format)) {
|
|
| 39 | -72163x | +73339x |
format <- pr_row_format |
@@ -148554,14 +149611,14 @@ |
| 42 | -100835x | +102473x |
if (is.null(obj_na_str(x)) && !is.null(pr_row_na_str)) {
|
|
| 43 | -86302x | +87796x |
na_str <- pr_row_na_str |
@@ -148589,7 +149646,7 @@ |
| 47 | -100835x | +102473x |
if (shell) {
|
@@ -148610,28 +149667,28 @@ |
| 50 | -74193x | +75831x |
format_value(rawvalues(x), |
|
| 51 | -74193x | +75831x |
format = format, |
|
| 52 | -74193x | +75831x |
output = output, |
|
| 53 | -74193x | +75831x |
na_str = na_str |